From d52b9beb1c8735b0915a0fa6a9e27ccd33478532 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Mon, 19 Nov 2018 15:00:43 -0500 Subject: uncommitted hacking + verbose options + usage string --- c2haskell.hs | 115 +++++++++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 89 insertions(+), 26 deletions(-) diff --git a/c2haskell.hs b/c2haskell.hs index 03ba9cd..d3075e4 100644 --- a/c2haskell.hs +++ b/c2haskell.hs @@ -7,7 +7,7 @@ import Data.Generics.Aliases import Data.Generics.Schemes -import Debug.Trace +-- import Debug.Trace import Control.Monad import Data.Char import Data.Data @@ -31,6 +31,8 @@ import Text.PrettyPrint (Doc, doubleQuotes, empty, text, vcat, ($$), (<+>)) import Text.Show.Pretty +trace _ = id + -- | Pretty print the given tranlation unit, but replace declarations from header files with @#include@ directives. -- -- The resulting file may not compile (because of missing @#define@ directives and similar things), but is very useful @@ -167,17 +169,28 @@ hsMkName str = HS.UnQual () (foo () str) foo = HS.Ident -- alternative: HS.Symbol hsTypeSpec :: CDeclarationSpecifier t -> [String] +hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "uint8_t" _ _) _)) = ["Word8"] +hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "uint16_t" _ _) _)) = ["Word16"] +hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "uint32_t" _ _) _)) = ["Word32"] hsTypeSpec (CTypeSpec (CTypeDef ctyp _)) = [capitalize . identToString $ ctyp] hsTypeSpec (CTypeSpec (CBoolType _)) = ["Bool"] +hsTypeSpec (CTypeSpec (CIntType _)) = ["Int"] +hsTypeSpec (CTypeSpec (CCharType _)) = ["Char"] hsTypeSpec (CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _)) = maybeToList $ fmap (capitalize . identToString) mctyp +hsTypeSpec (CTypeSpec unhandled) = trace ("hsTypeSpec unhandled: "++ show (const () <$> unhandled)) + $ [] hsTypeSpec _ = [] -- hsTransField :: [CDeclarationSpecifier t3] -> [(Maybe (CDeclarator t2), Maybe t1, Maybe t)] -> [HS.Decl ()] hsTransField ctyps vars = do typname <- hsMkName <$> (hsTypeSpec =<< ctyps) + trace ("typname="++show typname) $ return () (var,Nothing,Nothing) <- vars + trace ("var="++show var) $ return () CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var + trace ("fident="++show fident) $ return () + trace ("ptrdeclr="++show ptrdeclr) $ return () let btyp = HS.TyCon () typname grok bs b = case bs of [] -> b @@ -242,27 +255,58 @@ mutations = everything (++) (mkQ [] mutations1) commented :: String -> String commented s = unlines $ map ("-- " ++) (lines s) -c2haskell cs (CTranslUnit edecls _) = do +data C2HaskellOptions = C2HaskellOptions + { selectFunction :: Maybe String + , prettyC :: Bool + , verbose :: Bool + } + +defopts = C2HaskellOptions + { selectFunction = Nothing + , prettyC = False + , verbose = False + } + +parseOptions [] opts = opts +parseOptions ("-f":f:args) opts = parseOptions args opts + { selectFunction = Just f + } +parseOptions ("-p":args) opts = parseOptions args opts + { prettyC = True + } +parseOptions ("-v":args) opts = parseOptions args opts + { verbose = True + } + +c2haskell opts cs (CTranslUnit edecls _) = do let db = foldr update initTranspile edecls es = Map.filter (\d -> symbolLocal d && not (symbolStatic d)) (syms db) - forM_ (Map.toList es) $ \(k,si) -> do - putStrLn "" - putStrLn (commented k) - forM_ (symbolSource si) $ \d -> do - putStr $ commented (ppShow (fmap (const ()) d)) - putStr $ commented (show $ pretty d) - mapM_ (putStrLn . HS.prettyPrint) (sig d) - {- - forM_ (body d) $ \stmt -> do - putStr $ commented (take 130 $ show (fmap (const ()) stmt)) - putStr $ commented (ppShow (fmap (const ()) stmt)) - putStrLn $ commented . show . pretty $ stmt - putStr $ commented "calls" - mapM_ (putStr . commented . show . pretty) (calls (body d)) - putStrLn "--" - putStr $ commented "mutations" - mapM_ (putStr . commented . show . pretty) (mutations (body d)) - -} + case selectFunction opts of + Nothing -> forM_ (Map.toList es) $ \(k,si) -> do + putStrLn "" + putStrLn (commented k) + forM_ (symbolSource si) $ \d -> do + putStr $ commented (ppShow (fmap (const ()) d)) + putStr $ commented (show $ pretty d) + mapM_ (putStrLn . HS.prettyPrint) (sig d) + {- + forM_ (body d) $ \stmt -> do + putStr $ commented (take 130 $ show (fmap (const ()) stmt)) + putStr $ commented (ppShow (fmap (const ()) stmt)) + putStrLn $ commented . show . pretty $ stmt + putStr $ commented "calls" + mapM_ (putStr . commented . show . pretty) (calls (body d)) + putStrLn "--" + putStr $ commented "mutations" + mapM_ (putStr . commented . show . pretty) (mutations (body d)) + -} + Just cfun -> do + forM_ (symbolSource $ syms db Map.! cfun) $ \d -> do + -- putStr $ commented (ppShow (fmap (const ()) d)) + -- putStr $ commented (show $ pretty d) + when (verbose opts) $ print (sig d) + mapM_ (putStrLn . HS.prettyPrint) (sig d) + readComments fname = parseComments 1 1 <$> readFile fname @@ -293,12 +337,31 @@ sanitizeArgs ("-o":args) = sanitizeArgs $ drop 1 args sanitizeArgs (arg:args) = arg : sanitizeArgs args sanitizeArgs [] = [] +usage :: [String] -> Maybe (C2HaskellOptions, [String], FilePath) +usage args = do + let fname = last args + case break (=="--") args of + (targs,_:cargs0) -> do + let opts = init cargs0 + cargs = (sanitizeArgs opts) + hopts = parseOptions targs defopts + return (hopts,cargs,fname) + _ -> Nothing + +m <&> f = fmap f m + main :: IO () main = do + self <- getProgName args <- getArgs - let fname = last args - opts = init args - r <- parseCFile (newGCC "gcc") Nothing (sanitizeArgs opts) fname - -- print (fmap prettyUsingInclude r) - cs <- readComments fname - either print (c2haskell cs) r + let usageString = self ++ " [-v] [-p] [-f ] -- [gcc options] " + let m = usage args + fromMaybe (putStrLn usageString) $ m <&> \(hopts,cargs,fname) -> do + r <- parseCFile (newGCC "gcc") Nothing cargs fname + cs <- readComments fname + putStrLn $ "----------------------------" + if prettyC hopts -- -p + then do + print (fmap prettyUsingInclude r) + else do + either print (c2haskell hopts cs) r -- cgit v1.2.3