Compilable output.

1 files changed, 153 insertions, 27 deletions

diff --git a/c2haskell.hs b/c2haskell.hs
index d3075e4..2fbbfc2 100644
--- a/c2haskell.hs
+++ b/c2haskell.hs
@@ -20,6 +20,7 @@ import qualified Data.Set           as Set
 import Language.C.Data.Ident        as C
 import Language.C                   as C hiding (prettyUsingInclude)
 import Language.C.System.GCC
+import Language.Haskell.Exts.Parser as HS
 import Language.Haskell.Exts.Pretty as HS
 import Language.Haskell.Exts.Syntax as HS
 import Language.Haskell.TH
@@ -63,6 +64,7 @@ specs _                                  = []
 declrSym :: CDeclarator t -> Maybe Ident
 declrSym (CDeclr m _ _ _ _) = m
 
+-- Used by update to add a symbols to the database.
 sym :: CExternalDeclaration a -> [Maybe Ident]
 sym (CFDefExt (CFunDef specs m _ _ _)) = [ declrSym m ]
 sym (CDeclExt (CDecl specs ms _))      = ms >>= \(m,_,_) -> maybe [] (pure . declrSym) m
@@ -152,7 +154,9 @@ grokSymbol d k msi =
     , symbolSource = d : symbolSource si
     }
 
--- update :: CExternalDeclaration a -> Transpile -> Transpile
+update :: CExternalDeclaration NodeInfo
+                -> Transpile [CExternalDeclaration NodeInfo]
+                -> Transpile [CExternalDeclaration NodeInfo]
 update d transpile = transpile
     { syms = foldr (\k m -> Map.alter (grokSymbol d k) k m) (syms transpile)
                 $ map (maybe "" identToString) $ sym d
@@ -168,23 +172,40 @@ hsMkName str = HS.UnQual () (foo () str)
  where
     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 _                                                               = []
+
+notKnown "Word8"  = False
+notKnown "Word16" = False
+notKnown "Word32" = False
+notKnown "Bool"   = False
+notKnown "Int"    = False
+notKnown "Char"   = False
+notKnown "()"     = False
+notKnown _        = True
+
+hsTypeSpec :: CDeclarationSpecifier t -> [Either Ident String]
+hsTypeSpec (CTypeSpec (CVoidType _)) = [ Right "()" ]
+hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "uint8_t" _ _) _))                = [ Right "Word8"]
+hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "uint16_t" _ _) _))               = [ Right "Word16"]
+hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "uint32_t" _ _) _))               = [ Right "Word32"]
+hsTypeSpec (CTypeSpec (CTypeDef ctyp _))                                   = [ Left ctyp ]
+hsTypeSpec (CTypeSpec (CBoolType _))                                       = [ Right "Bool"]
+hsTypeSpec (CTypeSpec (CIntType  _))                                       = [ Right "Int"]
+hsTypeSpec (CTypeSpec (CCharType _))                                       = [ Right "Char"]
+hsTypeSpec (CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _)) = maybeToList $ fmap Left mctyp
+
+hsTypeSpec (CTypeSpec unhandled) = trace ("hsTypeSpec unhandled: "++ show (const () <$> unhandled)) $ []
+hsTypeSpec _ = []
+
 
 -- hsTransField :: [CDeclarationSpecifier t3] -> [(Maybe (CDeclarator t2), Maybe t1, Maybe t)] -> [HS.Decl ()]
+-- recursive for function signatures.
+hsTransField :: Show b =>
+                      [CDeclarationSpecifier b] -- c structure name
+                      -> [(Maybe (CDeclarator b), Maybe (CInitializer b), Maybe (CExpression b))] -- c variable declarations
+                      -> [(String{-field name-}, HS.Type () {- haskell type -}) ]
 hsTransField ctyps vars
     = do
-        typname <- hsMkName <$> (hsTypeSpec =<< ctyps)
+        typname <- hsMkName . either (capitalize . identToString) id <$> (hsTypeSpec =<< ctyps)
         trace ("typname="++show typname) $ return ()
         (var,Nothing,Nothing) <- vars
         trace ("var="++show var) $ return ()
@@ -195,8 +216,12 @@ hsTransField ctyps vars
             grok bs b = case bs of
                 []                               -> b
                 (CPtrDeclr [] _:cs)              -> HS.TyApp () (HS.TyCon () (hsMkName "Ptr")) (grok cs b)
-                [CFunDeclr (Right (args,flg)) attrs _] -> let (as,ts) = unzip $ concatMap (\(CDecl rs as _) -> hsTransField rs as) args
-                                                          in foldr (HS.TyFun ()) b ts
+                CFunDeclr (Right (args,flg)) attrs _:p ->
+                    let (as,ts) = unzip $ concatMap (\(CDecl rs as _) -> hsTransField rs as) args
+                        b0 = case p of
+                               CPtrDeclr [] _:cs -> HS.TyApp () (HS.TyCon () (hsMkName "Ptr")) (grok cs b)
+                               []                -> b
+                    in foldr (HS.TyFun ()) b0 ts
                 _                                -> HS.TyCon () (hsMkName $ show $ map (fmap (const ())) ptrdeclr)
             ftyp = grok ptrdeclr btyp
             fieldName = identToString fident
@@ -215,11 +240,44 @@ transField (CDecl [CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _)
 hsTransField _ _ = []
 -}
 
+extractType (HS.TypeDecl _ _ ftyp) = ftyp
+extractType (HS.TypeSig _ _ ftyp)  = ftyp
+extractType _                      = TyCon () (Special () (UnitCon ()))
+
+hsTransFieldExt :: Show b =>
+                         [CDeclarationSpecifier b]
+                         -> [(Maybe (CDeclarator b), Maybe (CInitializer b),
+                              Maybe (CExpression b))]
+                         -> [Decl ()]
 hsTransFieldExt rs as = concatMap (\(fieldName,ftyp)-> [ HS.TypeSig () [ HS.Ident () fieldName ] ftyp ])
                                         $ hsTransField rs as
 
-sig (CDeclExt (CDecl rs as _))              = hsTransFieldExt rs as
-sig (CFDefExt (CFunDef rs cdeclr [] bdy _)) = hsTransFieldExt rs [(Just cdeclr, Nothing, Nothing)]
+hsTransSig rs as = concatMap (\(fieldName,ftyp)-> [ HS.TypeDecl () (DHead () (HS.Ident () ("Sig_" ++ fieldName))) ftyp ])
+                                        $ hsTransField rs as
+
+types (HS.TypeDecl _ _ typ) = primtypes typ
+
+primtypes (HS.TyFun _ a b) = primtypes a ++ primtypes b
+primtypes t = [t]
+
+tname (HS.TyCon () (HS.UnQual () (HS.Ident () str))) = str
+tname _                                              = "_unkonwn"
+
+getPtrType (HS.TyApp _ (HS.TyCon _ (HS.UnQual _ (HS.Ident _ "Ptr"))) x) = Just x
+getPtrType _                                                            = Nothing
+
+-- pointers :: [HS.Decl ()] -> [String]
+pointers :: [HS.Type l] -> [HS.Type l]
+pointers decls = do
+    d <- decls
+    maybeToList $ getPtrType d
+
+
+sig :: Show t => CExternalDeclaration t -> [HS.Decl ()]
+sig = sigf hsTransFieldExt
+
+sigf f (CDeclExt (CDecl rs as _))              = f rs as
+sigf f (CFDefExt (CFunDef rs cdeclr [] bdy _)) = f rs [(Just cdeclr, Nothing, Nothing)]
 
 body0 (CFDefExt (CFunDef rs cdeclr [] bdy _)) = Just bdy
 body0 _                                       = Nothing
@@ -278,17 +336,52 @@ parseOptions ("-v":args) opts = parseOptions args opts
     { verbose = True
     }
 
+getsig (k,si) = do
+    d <- take 1 $ symbolSource si
+    let ts = filter notKnown $ map tname $ pointers $ concatMap types $ sigf hsTransSig d
+        s = sig d
+    [(ts,(k,s))]
+
+isAcceptableImport (HS.TyFun _ (TyCon _ (UnQual _ (HS.Ident _ x))) xs) | not (notKnown x) = isAcceptableImport xs
+isAcceptableImport (HS.TyFun _ (TyApp _ (TyCon _ (UnQual _ (HS.Ident _ "Ptr"))) x) xs) = isAcceptableImport xs
+isAcceptableImport (HS.TyFun _ (TyApp _ (TyCon _ (UnQual _ (HS.Ident _ "Ptr"))) x) xs) = isAcceptableImport xs
+isAcceptableImport (TyCon _ _) = True
+isAcceptableImport (TyApp _ _ _) = True
+isAcceptableImport _ = False
+
 c2haskell opts cs (CTranslUnit edecls _) = do
     let db = foldr update initTranspile edecls
         es = Map.filter (\d -> symbolLocal d && not (symbolStatic d)) (syms db)
     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)
+        Nothing -> do
+          putStrLn $ "module T where"
+          putStrLn $ "import Foreign.Ptr"
+          putStrLn $ "import Data.Word"
+          let sigs = concatMap getsig (Map.toList es)
+              ts = foldr (\t -> Map.insert t ()) Map.empty $ concatMap fst sigs
+          forM_ (Map.keys ts) $ \t -> do
+            putStrLn $ "data " ++ t
+          forM_ sigs $ \(_,(k,hs)) -> do
+            forM_ hs $ \hdecl -> do
+                {-
+                putStr (commented k)
+                putStr $ commented $ show $ length $ symbolSource si
+                forM_ (take 1 $ symbolSource si) $ \d -> do
+                    let ts = filter notKnown $ map tname $ pointers $ concatMap types $ sigf hsTransSig d
+                    -- putStr $ commented (ppShow (fmap (const ()) d))
+                    -- putStr $ commented (show $ pretty d)
+                    let typ = (TyCon () (Special () (UnitCon ())))
+                    -- when (null $ sig d) $ putStr $ commented (ppShow (fmap (const ()) d))
+                    forM_ (sig d) $ \hs -> case hs of
+                        htyp -> -- putStr $ commented $ "Unsupported haskell type: " ++ HS.prettyPrint htyp
+                            -}
+                let htyp = extractType hdecl
+                putStrLn $ (if isAcceptableImport htyp then id else commented)
+                         $ HS.prettyPrint $ (HS.ForImp () (HS.CCall ()) Nothing (Just k)
+                                                     (HS.Ident () k)
+                                                     htyp)
+
+                -- mapM_ (putStrLn . HS.prettyPrint) (sig d)
                 {-
                 forM_  (body d) $ \stmt -> do
                     putStr $ commented (take 130 $ show (fmap (const ()) stmt))
@@ -304,8 +397,39 @@ c2haskell opts cs (CTranslUnit edecls _) = 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)
+                -- when (verbose opts) $ print (sig d)
+                let ts = filter notKnown $ map tname $ pointers $ concatMap types $ sigf hsTransSig d
+                forM_ ts $ \t -> do
+                    putStrLn $ "data " ++ t
+                forM_ (sigf hsTransSig d) $ \hs -> do
+                putStrLn . HS.prettyPrint $ hs
+                case hs of
+                    HS.TypeDecl _ (DHead _ (HS.Ident _ signame)) ftyp  -> do
+                        let wrapname = "wrap" ++ drop 3 signame
+                            settername = "setf" ++ drop 3 signame
+                            funptr = (TyApp () (TyCon () (UnQual () (HS.Ident () "FunPtr")))
+                                               (TyCon () (UnQual () (HS.Ident () signame))))
+                        -- putStrLn $ ppShow $ HS.parseDecl "foreign import ccall \"wrapper\" fname :: Spec -> IO (FunPtr Spec)"
+                        -- mapM_ (putStrLn . HS.prettyPrint) (importWrapper $ sigf hsTransSig d)
+                        putStrLn $ HS.prettyPrint $
+                                      (HS.ForImp () (HS.CCall ()) Nothing (Just "wrapper")
+                                         (HS.Ident () wrapname)
+                                         (TyFun ()
+                                            (TyCon () (UnQual () (HS.Ident () signame)))
+                                            (TyApp ()
+                                               (TyCon () (UnQual () (HS.Ident () "IO")))
+                                               (TyParen () funptr))))
+                        putStrLn $ HS.prettyPrint $
+                                      (HS.ForImp () (HS.CCall ()) Nothing (Just settername)
+                                         (HS.Ident () settername)
+                                         (TyFun ()
+                                            funptr
+                                            (TyApp ()
+                                               (TyCon () (UnQual () (HS.Ident () "IO")))
+                                               (TyCon () (Special () (UnitCon ()))))))
+
+
+                    htyp -> putStr $ commented $ "Unsupported haskell type: " ++ HS.prettyPrint htyp
 
 
 readComments fname = parseComments 1 1 <$> readFile fname
@@ -319,6 +443,7 @@ findCloser !d (l,c,b) []           = (l,c,b)
 
 mkComment lin no str = (lin,no,str)
 
+parseComments :: (Num col, Num lin) => lin -> col -> [Char] -> [(lin, col, [Char])]
 parseComments !lin !col = \case
     ('/':'*':cs) -> let (lcnt,col',bcnt) = findCloser 1 (0,col,0) cs
                         (xs,cs') = splitAt bcnt cs
@@ -348,6 +473,7 @@ usage args = do
             return (hopts,cargs,fname)
         _ -> Nothing
 
+(<&>) :: Functor f => f a -> (a -> b) -> f b
 m <&> f = fmap f m
 
 main :: IO ()