From d7897ff1c2ac599a133b09bc48134a7f74af3d03 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Mon, 19 Nov 2018 21:53:11 -0500 Subject: Compilable output. --- c2haskell.hs | 180 ++++++++++++++++++++++++++++++++++++++++++++++++++--------- 1 file 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 () -- cgit v1.2.3