Signatures.

1 files changed, 71 insertions, 1 deletions

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