uncommitted hacking + verbose options + usage string

1 files 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 <sym>] -- [gcc options] <cfile>"
+    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