From 4571dcae244b81a4b6aa0acacd773f728be49772 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sun, 10 Mar 2019 20:41:59 -0400 Subject: Signatures. --- monkeypatch.hs | 72 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 71 insertions(+), 1 deletion(-) diff --git a/monkeypatch.hs b/monkeypatch.hs index ac67afa..cfa9011 100644 --- a/monkeypatch.hs +++ b/monkeypatch.hs @@ -71,6 +71,7 @@ prettyUsingInclude incs (CTranslUnit edecls _) = sysfst (Left ('"':a)) (Left ('<':b)) = Prelude.GT sysfst _ _ = Prelude.LT +includeTopLevel :: IncludeStack -> FilePath -> [Char] includeTopLevel (IncludeStack incs) f = do stacks <- maybeToList $ Map.lookup f incs stack <- take 1 stacks @@ -132,6 +133,7 @@ transField (CDecl [CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _) transField _ = [] +transpile :: CExternalDeclaration a -> Maybe (Q Dec) transpile (CDeclExt (CDecl [ CTypeSpec (CSUType (CStruct CStructTag mbIdent (Just fields) [] _) _) ] @@ -158,6 +160,8 @@ data SymbolInformation c = SymbolInformation } deriving (Eq,Ord,Show,Functor) +symbolInformation :: SymbolInformation + [CExternalDeclaration NodeInfo] symbolInformation = SymbolInformation { symbolLocal = False , symbolStatic = False @@ -168,11 +172,16 @@ data Transpile c = Transpile { syms :: Map String (SymbolInformation c) } +initTranspile :: Transpile c initTranspile = Transpile { syms = Map.empty } -- grokSymbol :: CExternalDeclaration a -> String -> Maybe SymbolInformation -> Maybe SymbolInformation +grokSymbol :: CExternalDeclaration NodeInfo + -> p + -> Maybe (SymbolInformation [CExternalDeclaration NodeInfo]) + -> Maybe (SymbolInformation [CExternalDeclaration NodeInfo]) grokSymbol d k msi = let si = fromMaybe symbolInformation msi in Just $ si @@ -200,6 +209,7 @@ hsMkName str = HS.UnQual () (foo () str) foo = HS.Ident -- alternative: HS.Symbol +notKnown :: String -> Bool notKnown "Word8" = False notKnown "Word16" = False notKnown "Word32" = False @@ -292,6 +302,7 @@ transField (CDecl [CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _) hsTransField _ _ = [] -} +extractType :: Decl () -> HS.Type () extractType (HS.TypeDecl _ _ ftyp) = ftyp extractType (HS.TypeSig _ _ ftyp) = ftyp extractType _ = TyCon () (Special () (UnitCon ())) @@ -326,6 +337,7 @@ tname :: HS.Type () -> String tname (HS.TyCon () (HS.UnQual () (HS.Ident () str))) = str tname _ = "_unkonwn" +getPtrType :: HS.Type l -> Maybe (HS.Type l) getPtrType (HS.TyApp _ (HS.TyCon _ (HS.UnQual _ (HS.Ident _ "Ptr"))) x) = Just x getPtrType _ = Nothing @@ -368,9 +380,11 @@ sigf f d = f (getReturnValue d) $ do return $ CDeclr s [arg] Nothing [] (node d) -} +body0 :: CExternalDeclaration a -> Maybe (CStatement a) body0 (CFDefExt (CFunDef rs cdeclr [] bdy _)) = Just bdy body0 _ = Nothing +body :: CExternalDeclaration a -> [CCompoundBlockItem a] body (CFDefExt (CFunDef rs cdeclr [] (CCompound [] bdy _) _)) = bdy body _ = [] @@ -379,6 +393,7 @@ data SideEffect = PointerWrite | FunctionCall calls :: Data t => t -> [CExpression NodeInfo] calls = everything (++) (mkQ [] (\case { cc@C.CCall {} -> [cc] ; _ -> [] })) +mutations1 :: CExpression a -> [CExpression a] mutations1 e@(CAssign {}) = [e] mutations1 e@(CUnary CPreIncOp _ _) = [e] mutations1 e@(CUnary CPreDecOp _ _) = [e] @@ -410,6 +425,7 @@ data C2HaskellOptions = C2HaskellOptions , preprocess :: Bool } +defopts :: C2HaskellOptions defopts = C2HaskellOptions { selectFunction = Nothing , prettyC = False @@ -418,6 +434,7 @@ defopts = C2HaskellOptions , preprocess = False } +parseOptions :: [String] -> C2HaskellOptions -> C2HaskellOptions parseOptions [] opts = opts parseOptions ("-f":f:args) opts = parseOptions args opts { selectFunction = Just f @@ -436,6 +453,8 @@ parseOptions ("-v":args) opts = parseOptions args opts } parseOptions as x = error (show as) +tnames :: Show b => + CExternalDeclaration b -> [(String, Maybe String)] tnames d = filter (notKnown . fst) $ map (first $ tname . unpointer) $ concatMap (\(t,c) -> map (,c) (types t)) $ sigf hsTransSig d @@ -454,6 +473,7 @@ getsig (k,si) = do s = sig d [(ts,(k,s,d))] +isAcceptableImport :: HS.Type l -> Bool 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 (TyCon _ _) = True @@ -466,6 +486,7 @@ makeFunctionUseIO t@(TyApp a (TyCon b (UnQual c (HS.Ident d "IO"))) x) = t makeFunctionUseIO t = TyApp () (TyCon () (UnQual () (HS.Ident () "IO"))) t +makeAcceptableImport :: HS.Type l -> HS.Type l makeAcceptableImport (HS.TyFun a (TyCon b (UnQual c (HS.Ident d x))) xs) | not (notKnown x) = (HS.TyFun a (TyCon b (UnQual c (HS.Ident d x))) (makeAcceptableImport xs)) makeAcceptableImport (HS.TyFun a (TyApp b (TyCon c (UnQual d (HS.Ident e "Ptr"))) x) xs) @@ -474,8 +495,10 @@ makeAcceptableImport (HS.TyFun a (TyCon c (UnQual d (HS.Ident e x))) xs) = (HS.TyFun a (TyApp c (TyCon c (UnQual d (HS.Ident e "Ptr"))) (TyCon e (UnQual e (HS.Ident e x)))) (makeAcceptableImport xs)) makeAcceptableImport t = t +enumCases :: CExternalDeclaration a + -> [(a, [(Ident, Maybe (CExpression a))])] enumCases (CDeclExt (CDecl xs _ ni)) = do - CTypeSpec (CEnumType (CEnum _ (Just cs))) <- xs + CTypeSpec (CEnumType (CEnum _ (Just cs) _ _) _) <- xs return (ni,cs) @@ -614,6 +637,8 @@ makeStatic :: [CDeclarationSpecifier NodeInfo] -> [CDeclarationSpecifier NodeInf makeStatic xs = CStorageSpec (CStatic undefNode) : xs -- makeStatic xs = CStorageSpec (CStatic ()) : xs +makePointer1 :: Maybe (CDeclarator NodeInfo) + -> Maybe (CDeclarator NodeInfo) makePointer1 (Just (CDeclr a bs c d e)) = (Just (CDeclr a (p:bs) c d e)) where @@ -627,6 +652,8 @@ makePointer ((a,b,c):zs) = (makePointer1 a,b,c):zs setNull1 :: Maybe (CInitializer NodeInfo) setNull1 = Just (CInitExpr (CVar (C.Ident "NULL" 0 undefNode) undefNode) undefNode) +setNull :: [(a, Maybe (CInitializer NodeInfo), c)] + -> [(a, Maybe (CInitializer NodeInfo), c)] setNull ((a,_,b):zs) = (a,setNull1,b):zs makeFunctionPointer :: CExternalDeclaration NodeInfo @@ -634,27 +661,47 @@ makeFunctionPointer :: CExternalDeclaration NodeInfo makeFunctionPointer d@(CDeclExt (CDecl xs ys pos)) = changeName ("f_"++) $ CDeclExt (CDecl (makeStatic xs) (setNull $ makePointer ys) pos) makeFunctionPointer d = d +changeName2 :: (String -> String) + -> Maybe (CDeclarator a) -> Maybe (CDeclarator a) changeName2 f (Just (CDeclr (Just (C.Ident nm n p)) bs c d e)) = (Just (CDeclr (Just (C.Ident (f nm) n p)) bs c d e)) changeName2 f d = d +changeName1 :: (String -> String) + -> [(Maybe (CDeclarator a), b, c)] + -> [(Maybe (CDeclarator a), b, c)] changeName1 f ((a,b,c):zs) = (changeName2 f a,b,c):zs +changeName :: (String -> String) + -> CExternalDeclaration a -> CExternalDeclaration a changeName f d@(CDeclExt (CDecl xs ys pos)) = CDeclExt (CDecl xs (changeName1 f ys) pos) changeName f d = d +makeAcceptableDecl :: Decl () -> Decl () makeAcceptableDecl (HS.TypeDecl a (DHead b (HS.Ident c signame)) ftyp) = (HS.TypeDecl a (DHead b (HS.Ident c signame)) (makeFunctionUseIO $ makeAcceptableImport ftyp)) makeAcceptableDecl (HS.TypeSig a b ftyp) = HS.TypeSig a b (makeFunctionUseIO $ makeAcceptableImport ftyp) +makeSetter :: CExternalDeclaration NodeInfo + -> CExternalDeclaration NodeInfo makeSetter d = -- @(CDeclExt (CDecl xs ys pos)) = let name = concatMap identToString $ take 1 $ catMaybes $ sym d in setBody (setterBody ("f_"++name)) $ changeReturnValue (const voidReturnType) $ changeArgList (const voidp) $ changeName ("setf_"++) d +changeArgList1 :: ([CDerivedDeclarator a] + -> [CDerivedDeclarator a]) + -> CDeclarator a -> CDeclarator a changeArgList1 f (CDeclr a xs b c d) = CDeclr a (f xs) b c d +changeArgList2 :: ([CDerivedDeclarator a] + -> [CDerivedDeclarator a]) + -> [(Maybe (CDeclarator a), b, c)] + -> [(Maybe (CDeclarator a), b, c)] changeArgList2 f ((a,b,c):zs) = (changeArgList3 f a,b,c):zs +changeArgList3 :: ([CDerivedDeclarator a] + -> [CDerivedDeclarator a]) + -> Maybe (CDeclarator a) -> Maybe (CDeclarator a) changeArgList3 f (Just (CDeclr a x b c d)) = Just (CDeclr a (f x) b c d) changeArgList :: ([CDerivedDeclarator a] -> [CDerivedDeclarator a]) @@ -665,13 +712,19 @@ changeArgList f (CDeclExt (CDecl xs ys pos)) = (CDeclExt (CDecl xs (changeArgLis setPosOfNode :: Position -> NodeInfo -> NodeInfo setPosOfNode pos n = maybe (mkNodeInfoOnlyPos pos) (mkNodeInfo pos) $ nameOfNode n +setPos :: Position + -> CExternalDeclaration NodeInfo -> CExternalDeclaration NodeInfo setPos pos (CFDefExt (CFunDef xs ys zs c n)) = (CFDefExt (CFunDef xs ys zs c $ setPosOfNode pos n)) setPos pos (CDeclExt (CDecl xs ys n)) = (CDeclExt (CDecl xs ys $ setPosOfNode pos n)) +getArgList1 :: CDeclarator a -> [CDerivedDeclarator a] getArgList1 (CDeclr a xs b c d) = xs +getArgList2 :: [(Maybe (CDeclarator a), b, c)] + -> [CDerivedDeclarator a] getArgList2 ((a,b,c):zs) = getArgList3 a +getArgList3 :: Maybe (CDeclarator a) -> [CDerivedDeclarator a] getArgList3 (Just (CDeclr a [CPtrDeclr [] _] b c d)) = [] -- struct prototype, no fields. getArgList3 (Just (CDeclr a x b c d)) = x @@ -685,20 +738,30 @@ getArgList x = let v=getArgList_ x in trace ("getArgList ("++show (u x)++") = "+ u :: Functor f => f a -> f () u = fmap (const ()) +changeReturnValue :: ([CDeclarationSpecifier a] + -> [CDeclarationSpecifier a]) + -> CExternalDeclaration a -> CExternalDeclaration a changeReturnValue f (CFDefExt (CFunDef xs ys zs c d)) = (CFDefExt (CFunDef (f xs) ys zs c d)) changeReturnValue f (CDeclExt (CDecl xs ys pos)) = (CDeclExt (CDecl (f xs) ys pos)) +getReturnValue :: CExternalDeclaration a + -> [CDeclarationSpecifier a] getReturnValue (CFDefExt (CFunDef xs ys zs c d)) = xs getReturnValue (CDeclExt (CDecl xs ys pos)) = xs +voidReturnType :: [CDeclarationSpecifier NodeInfo] voidReturnType = [ CTypeSpec (CVoidType undefNode) ] +setBody :: CStatement a + -> CExternalDeclaration a -> CExternalDeclaration a 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)) where v = case ys of (Just y,_,_):_ -> y _ -> CDeclr Nothing [] Nothing [] pos +makeStub :: CExternalDeclaration NodeInfo + -> CExternalDeclaration NodeInfo makeStub d = -- @(CDeclExt (CDecl xs ys pos)) = let rval = case getReturnValue d of [ CTypeSpec (CVoidType _) ] -> False -- void function. @@ -762,6 +825,8 @@ voidp = [ CFunDeclr where n = undefNode +stubBody :: String + -> [CExpression NodeInfo] -> Bool -> String -> CStatement NodeInfo stubBody name vs rval msg = CCompound [] [ CBlockStmt @@ -951,15 +1016,20 @@ newtype IncludeStack = IncludeStack } deriving Show +emptyIncludes :: IncludeStack emptyIncludes = IncludeStack Map.empty +openInclude :: FilePath + -> [FilePath] -> IncludeStack -> IncludeStack openInclude fname stack (IncludeStack m) = IncludeStack $ Map.alter go fname m where go Nothing = Just [stack] go (Just s) = Just $ stack : s +findQuoted :: [Char] -> [Char] findQuoted xs = takeWhile (/='"') $ drop 1 $ dropWhile (/='"') xs +includeStack :: B.ByteString -> IncludeStack includeStack bs = foldr go (const emptyIncludes) incs [] where incs = filter (\b -> fmap fst (B.uncons b) == Just '#') $ B.lines bs -- cgit v1.2.3