From e728b91d49807a327e66f1c56c25dd02626ce2ce Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sat, 24 Nov 2018 00:12:14 -0500 Subject: It worked! --- c2haskell.hs | 105 ++++++++++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 79 insertions(+), 26 deletions(-) diff --git a/c2haskell.hs b/c2haskell.hs index 41d9ba0..92fafe4 100644 --- a/c2haskell.hs +++ b/c2haskell.hs @@ -232,34 +232,43 @@ hsTypeSpec (CTypeSpec unhandled) = trace ("hsTypeSpec unhandled: "++ show (const hsTypeSpec _ = [] +-- fieldInfo :: CDeclarator b -> (Maybe (CDeclarator b), Maybe (CInitializer b), Maybe (CExpression b)) +-- fieldInfo var = (Just var,Nothing,Nothing) +fieldInfo :: (Maybe (CDeclarator b), Maybe (CInitializer b), Maybe (CExpression b)) -> [CDeclarator b] +fieldInfo (Just var,_,_) = [var] +fieldInfo _ = [] + -- 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 + -- -> [(Maybe (CDeclarator b), Maybe (CInitializer b), Maybe (CExpression b))] -- c variable declarations + -> [CDeclarator b] -- c variable declarations -> [(String{-field name-}, HS.Type () {- haskell type -}) ] hsTransField ctyps vars = do typname <- hsMkName . either (capitalize . identToString) id <$> (hsTypeSpec =<< ctyps) trace ("typname="++show typname) $ return () - (var,Nothing,Nothing) <- vars + -- (var,Nothing,Nothing) <- vars + var <- vars trace ("var="++show var) $ return () - CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var - trace ("fident="++show fident) $ return () + -- CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var + let CDeclr mfident ptrdeclr Nothing [] _ = var + trace ("fident="++show mfident) $ return () trace ("ptrdeclr="++show ptrdeclr) $ return () let btyp = HS.TyCon () typname grok bs b = case bs of [] -> b (CPtrDeclr [] _:cs) -> HS.TyApp () (HS.TyCon () (hsMkName "Ptr")) (grok cs b) CFunDeclr (Right (args,flg)) attrs _:p -> - let (as,ts) = unzip $ concatMap (\(CDecl rs as _) -> hsTransField rs as) args + let (as,ts) = unzip $ concatMap (\(CDecl rs as _) -> hsTransField rs $ concatMap fieldInfo 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 + fieldName = maybe ("_") identToString mfident [ ( fieldName, ftyp ) ] {- transField (CDecl [CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _)] vars _) @@ -279,11 +288,15 @@ 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 :: Show b => + [CDeclarationSpecifier b] -> [CDeclarator b] -> [Decl ()] hsTransFieldExt rs as = concatMap (\(fieldName,ftyp)-> [ HS.TypeSig () [ HS.Ident () fieldName ] ftyp ]) $ hsTransField rs as @@ -311,11 +324,31 @@ unpointer t = case getPtrType t of Nothing -> t Just t' -> t' -sig :: Show t => CExternalDeclaration t -> [HS.Decl ()] +-- sig :: Show t => CExternalDeclaration t -> [HS.Decl ()] +sig :: CExternalDeclaration NodeInfo -> [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)] +-- • Couldn't match expected type ‘CDerivedDeclarator a -> (Maybe (CDeclarator a), Maybe (CInitializer a), Maybe (CExpression a))’ +-- with actual type ‘(CDerivedDeclarator NodeInfo -> Maybe (CDeclarator NodeInfo), Maybe a0, Maybe a1)’ + + +-- CDeclr (Maybe Ident) +-- [CDerivedDeclarator a] +-- (Maybe (CStringLiteral a)) +-- [CAttribute a] +-- a +-- sigf f d@(CDeclExt (CDecl rs ((Just (CDeclr i x j k l),b,c):zs) n)) = f rs $ map (\v -> (Just (CDeclr Nothing [v] Nothing [] n),Nothing,Nothing)) x +sigf :: ([CDeclarationSpecifier b] -> [CDeclarator b] -> p) -> CExternalDeclaration b -> p +sigf f (CDeclExt (CDecl rs as _)) = f rs $ concatMap fieldInfo as +sigf f (CFDefExt (CFunDef rs cdeclr [] bdy _)) = f rs [cdeclr] +{- +sigf f d = f (getReturnValue d) $ do + arg <- getArgList d + let node (CDeclExt (CDecl rs as n)) = n + node (CFDefExt (CFunDef rs cdeclr [] bdy n)) = n + s = listToMaybe $ catMaybes $ sym d + return $ CDeclr s [arg] Nothing [] (node d) +-} body0 (CFDefExt (CFunDef rs cdeclr [] bdy _)) = Just bdy body0 _ = Nothing @@ -386,10 +419,14 @@ parseOptions ("-v":args) opts = parseOptions args opts parseOptions as x = error (show as) getsig (k,si) = do - d <- take 1 $ symbolSource si - let ts = filter notKnown $ map tname $ map unpointer $ concatMap types $ sigf hsTransSig d + d0 <- take 1 $ symbolSource si + let d = case getArgList d0 of + oargs:xs -> let args = fst $ makeParameterNames oargs + in changeArgList (const $ args:xs) d0 + _ -> d0 + ts = filter notKnown $ map tname $ map unpointer $ concatMap types $ sigf hsTransSig d s = sig d - [(ts,(k,s))] + [(ts,(k,s,d))] 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 @@ -413,15 +450,18 @@ makeAcceptableImport t = t -- c2haskell :: Foldable t => C2HaskellOptions -> p -> t String -> CTranslationUnit NodeInfo -> IO () c2haskell :: C2HaskellOptions - -> p1 -> [String] -> IncludeStack -> CTranslationUnit NodeInfo -> IO () -c2haskell opts cs missings incs (CTranslUnit edecls _) = do + -> p1 -> FilePath -> [String] -> IncludeStack -> CTranslationUnit NodeInfo -> IO () +c2haskell opts cs cmodname missings incs (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 -> do createDirectoryIfMissing False "MonkeyPatch" let fname = ("MonkeyPatch/" ++ modname ++ ".hs") - modname = "T" -- todo + basename f = case break (=='.') $ takeWhile (/='/') $ reverse f of + (ext,_:rname) -> reverse rname + (rname,_) -> reverse rname + modname = capitalize $ basename cmodname stubsname = "MonkeyPatch/t_stubs.c" -- todo putStrLn $ "writing " ++ fname withFile fname WriteMode $ \haskmod -> do @@ -443,11 +483,14 @@ c2haskell opts cs missings incs (CTranslUnit edecls _) = do putStrLn $ "-- ip_is_lan `elem` sigs2 = " ++ show (elem "ip_is_lan" sigs2) forM_ (uniq $ ts ++ sigs2) $ \t -> do hPutStrLn haskmod $ "data " ++ t - forM_ sigs $ \(_,(k,hs)) -> do + forM_ sigs $ \(_,(k,hs,d)) -> do forM_ hs $ \hdecl -> do + hPutStr haskmod (commented k) + hPutStr haskmod (commented $ show $ pretty d) + hPutStr haskmod (commented $ show $ getReturnValue d) + hPutStr haskmod (commented $ show hdecl) + -- hPutStr haskmod $ commented $ show $ length $ symbolSource si {- - 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)) @@ -517,6 +560,7 @@ c2haskell opts cs missings incs (CTranslUnit edecls _) = do Just cfun -> do forM_ (Map.lookup cfun $ syms db) $ \si -> do forM_ (take 1 $ symbolSource si) $ \d -> do + putStrLn $ concatMap HS.prettyPrint $ sig d putStrLn $ show $ pretty d putStrLn $ show $ pretty $ makeFunctionPointer d putStrLn $ show $ pretty $ makeSetter d @@ -571,6 +615,8 @@ changeArgList2 f ((a,b,c):zs) = (changeArgList3 f a,b,c):zs changeArgList3 f (Just (CDeclr a x b c d)) = Just (CDeclr a (f x) b c d) +changeArgList :: ([CDerivedDeclarator a] -> [CDerivedDeclarator a]) + -> CExternalDeclaration a -> CExternalDeclaration a changeArgList f (CFDefExt (CFunDef xs ys zs c d)) = CFDefExt (CFunDef xs (changeArgList1 f ys) zs c d) changeArgList f (CDeclExt (CDecl xs ys pos)) = (CDeclExt (CDecl xs (changeArgList2 f ys) pos)) @@ -586,6 +632,7 @@ getArgList2 ((a,b,c):zs) = getArgList3 a getArgList3 (Just (CDeclr a x b c d)) = x +getArgList :: CExternalDeclaration a -> [CDerivedDeclarator a] getArgList (CFDefExt (CFunDef xs ys zs c d)) = getArgList1 ys getArgList (CDeclExt (CDecl xs ys pos)) = getArgList2 ys @@ -598,7 +645,7 @@ getReturnValue (CDeclExt (CDecl xs ys pos)) = xs voidReturnType = [ CTypeSpec (CVoidType undefNode) ] setBody bdy (CFDefExt (CFunDef xs ys zs c d)) = (CFDefExt (CFunDef xs ys zs bdy d)) -setBody bdy (CDeclExt (CDecl xs ys pos)) = (CFDefExt (CFunDef xs v [] bdy pos)) +setBody bdy (CDeclExt (CDecl xs ys pos)) = (CFDefExt (CFunDef xs v [] bdy pos)) where v = case ys of (Just y,_,_):_ -> y _ -> CDeclr Nothing [] Nothing [] pos @@ -608,7 +655,7 @@ makeStub d = -- @(CDeclExt (CDecl xs ys pos)) = [ CTypeSpec (CVoidType _) ] -> False -- void function. _ -> True name = concatMap identToString $ take 1 $ catMaybes $ sym d - msg = "undefined: " ++ HS.prettyPrint (makeAcceptableDecl $ head $ sig d) ++ "\n" + msg = "undefined: " ++ concatMap (HS.prettyPrint . makeAcceptableDecl) (take 1 $ sig d) ++ "\n" in case getArgList d of oargs:xs -> let (args,vs) = makeParameterNames oargs @@ -622,7 +669,8 @@ parameterIdent (CDecl _ xs n) = listToMaybe $ do return x -makeParameterNames :: CDerivedDeclarator NodeInfo -> (CDerivedDeclarator NodeInfo,[CExpression NodeInfo]) +-- makeParameterNames :: CDerivedDeclarator NodeInfo -> (CDerivedDeclarator NodeInfo,[CExpression NodeInfo]) +makeParameterNames :: CDerivedDeclarator n -> (CDerivedDeclarator n,[CExpression n]) makeParameterNames (CFunDeclr (Right (ps, flg)) z2 z3) = case ps of [CDecl [CTypeSpec (CVoidType _)] [] _] -> ( CFunDeclr (Right (ps, flg)) z2 z3 , []) -- void argument list. _ -> ( CFunDeclr (Right (qs, flg)) z2 z3 , map expr qs ) @@ -630,9 +678,9 @@ makeParameterNames (CFunDeclr (Right (ps, flg)) z2 z3) = case ps of -- TODO: ensure uniqueness of generated parameter names qs = zipWith mkp [0..] ps mkp num (CDecl rtyp ((Just (CDeclr Nothing typ x ys z),a,b):xs) n) - = (CDecl rtyp ((Just (CDeclr (Just $ mkidn num n) typ x ys z),a,b):xs) n) + = (CDecl rtyp ((Just (CDeclr (Just $ mkidn num undefNode) typ x ys z),a,b):xs) n) mkp num (CDecl rtyp [] n) - = (CDecl rtyp ((Just (CDeclr (Just $ mkidn num n) [] Nothing [] n),Nothing,Nothing):[]) n) + = (CDecl rtyp ((Just (CDeclr (Just $ mkidn num undefNode) [] Nothing [] n),Nothing,Nothing):[]) n) mkp num p = p expr :: CDeclaration a -> CExpression a @@ -717,10 +765,14 @@ goMissing :: Show b => Handle -> Transpile [CExternalDeclaration b] -> String -> IO () goMissing haskmod db cfun = do forM_ (Map.lookup cfun $ syms db) $ \si -> do - forM_ (take 1 $ symbolSource si) $ \d -> do + forM_ (take 1 $ symbolSource si) $ \d0 -> do -- putStr $ commented (ppShow (fmap (const ()) d)) -- putStr $ commented (show $ pretty d) -- when (verbose opts) $ print (sig d) + let d = case getArgList d0 of + oargs:xs -> let args = fst $ makeParameterNames oargs + in changeArgList (const $ args:xs) d0 + _ -> d0 let ts = filter notKnown $ map tname $ pointers $ concatMap types $ sigf hsTransSig d -- forM_ ts $ \t -> putStrLn $ "data " ++ t forM_ (sigf hsTransSig d) $ \hs -> do @@ -796,7 +848,7 @@ usage :: [String] -> Maybe (C2HaskellOptions, [String], [FilePath]) usage args = case break (=="--") args of (targs,_:cargs0) -> do - let (rfs,ropts) = span isModule cargs0 + let (rfs,ropts) = span isModule $ reverse cargs0 opts = reverse ropts cargs = (sanitizeArgs opts) hopts = parseOptions targs defopts @@ -875,6 +927,7 @@ main = do let usageString = self ++ " [--cpp | -p | -t ] [-v] [-f ] -- [gcc options] [modules] " let m = usage args fromMaybe (putStrLn usageString) $ m <&> \(hopts,cargs,fname:fs) -> do + putStrLn $ "fname = " ++ fname prer <- runPreprocessor (newGCC "gcc") (rawCppArgs cargs fname) let r = do pre <- left Left $ prer @@ -895,4 +948,4 @@ main = do putStrLn $ ppShow $ everywhere (mkT eraseNodeInfo) . snd <$> r _ -> do syms <- linker (cargs ++ reverse fs) fname - either print (uncurry $ c2haskell hopts cs syms) r + either print (uncurry $ c2haskell hopts cs fname syms) r -- cgit v1.2.3