import signatures should be IO actions.

1 files changed, 53 insertions, 13 deletions

diff --git a/c2haskell.hs b/c2haskell.hs
index 5602c10..832e613 100644
--- a/c2haskell.hs
+++ b/c2haskell.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns             #-}
+{-# LANGUAGE DeriveFunctor            #-}
 {-# LANGUAGE FlexibleContexts         #-}
 {-# LANGUAGE LambdaCase               #-}
 {-# LANGUAGE NondecreasingIndentation #-}
@@ -59,9 +60,9 @@ prettyUsingInclude (CTranslUnit edecls _) =
                       | otherwise = text "/* Warning: The #include directives in this file aren't necessarily correct. */"
 
 specs :: CExternalDeclaration a -> [CDeclarationSpecifier a]
-specs (CFDefExt (CFunDef specs _ _ _ _)) = specs
-specs (CDeclExt (CDecl specs _ _))       = specs
-specs _                                  = []
+specs (CFDefExt (CFunDef ss _ _ _ _)) = ss
+specs (CDeclExt (CDecl ss _ _))       = ss
+specs _                               = []
 
 declrSym :: CDeclarator t -> Maybe Ident
 declrSym (CDeclr m _ _ _ _) = m
@@ -131,7 +132,7 @@ data SymbolInformation c = SymbolInformation
     , symbolStatic :: Bool
     , symbolSource :: c
     }
- deriving (Eq,Ord,Show)
+ deriving (Eq,Ord,Show,Functor)
 
 symbolInformation = SymbolInformation
     { symbolLocal = False
@@ -178,6 +179,11 @@ hsMkName str = HS.UnQual () (foo () str)
 notKnown "Word8"  = False
 notKnown "Word16" = False
 notKnown "Word32" = False
+notKnown "Word64" = False
+notKnown "Int8"  = False
+notKnown "Int16" = False
+notKnown "Int32" = False
+notKnown "Int64" = False
 notKnown "Bool"   = False
 notKnown "Int"    = False
 notKnown "Char"   = False
@@ -189,6 +195,11 @@ 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 (C.Ident "uint64_t" _ _) _))               = [ Right "Word64"]
+hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "int8_t" _ _) _))                = [ Right "Int8"]
+hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "int16_t" _ _) _))               = [ Right "Int16"]
+hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "int32_t" _ _) _))               = [ Right "Int32"]
+hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "int64_t" _ _) _))               = [ Right "Int64"]
 hsTypeSpec (CTypeSpec (CTypeDef ctyp _))                                   = [ Left ctyp ]
 hsTypeSpec (CTypeSpec (CBoolType _))                                       = [ Right "Bool"]
 hsTypeSpec (CTypeSpec (CIntType  _))                                       = [ Right "Int"]
@@ -274,6 +285,9 @@ pointers decls = do
     d <- decls
     maybeToList $ getPtrType d
 
+unpointer t = case getPtrType t of
+    Nothing -> t
+    Just t' -> t'
 
 sig :: Show t => CExternalDeclaration t -> [HS.Decl ()]
 sig = sigf hsTransFieldExt
@@ -340,17 +354,31 @@ parseOptions ("-v":args) opts = parseOptions args opts
 
 getsig (k,si) = do
     d <- take 1 $ symbolSource si
-    let ts = filter notKnown $ map tname $ pointers $ concatMap types $ sigf hsTransSig d
+    let ts = filter notKnown $ map tname $ map unpointer $ 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
 
+makeFunctionUseIO :: HS.Type () -> HS.Type ()
+makeFunctionUseIO (HS.TyFun a x xs)                                    = (HS.TyFun a x (makeFunctionUseIO xs))
+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.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)
+                   = (HS.TyFun a (TyApp b (TyCon c (UnQual d (HS.Ident e "Ptr"))) x) (makeAcceptableImport xs))
+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
+
+-- c2haskell :: Foldable t => C2HaskellOptions -> p -> t String -> CTranslationUnit NodeInfo -> IO ()
 c2haskell opts cs missings (CTranslUnit edecls _) = do
     let db = foldr update initTranspile edecls
         es = Map.filter (\d -> symbolLocal d && not (symbolStatic d)) (syms db)
@@ -359,9 +387,20 @@ c2haskell opts cs missings (CTranslUnit edecls _) = do
           putStrLn $ "module T where"
           putStrLn $ "import Foreign.Ptr"
           putStrLn $ "import Data.Word"
+          putStrLn $ "import Data.Int"
+          putStrLn $ "-- " ++ show (fmap (fmap (fmap (const ()))) <$> Map.lookup "ip_is_lan" (syms db))
           let sigs = concatMap getsig (Map.toList es)
-              ts = foldr (\t -> Map.insert t ()) Map.empty $ concatMap fst sigs
-          forM_ (Map.keys ts) $ \t -> do
+              sigs2 = concatMap (\s -> do
+                                  x <- maybeToList $ Map.lookup s (syms db)
+                                  (y,_) <- getsig (s,x)
+                                  y)
+                          missings
+              ts = concatMap fst sigs
+          putStrLn $ "-- IP `elem` db = " ++ show (length . symbolSource <$> Map.lookup "IP" (syms db))
+          putStrLn $ "-- IP `elem` sigs2 = " ++ show (elem "IP" sigs2)
+          putStrLn $ "-- ip_is_lan `elem` db = " ++ show (length . symbolSource <$> Map.lookup "ip_is_lan" (syms db))
+          putStrLn $ "-- ip_is_lan `elem` sigs2 = " ++ show (elem "ip_is_lan" sigs2)
+          forM_ (uniq $ ts ++ sigs2) $ \t -> do
             putStrLn $ "data " ++ t
           forM_ sigs $ \(_,(k,hs)) -> do
             forM_ hs $ \hdecl -> do
@@ -377,7 +416,7 @@ c2haskell opts cs missings (CTranslUnit edecls _) = do
                     forM_ (sig d) $ \hs -> case hs of
                         htyp -> -- putStr $ commented $ "Unsupported haskell type: " ++ HS.prettyPrint htyp
                             -}
-                let htyp = extractType hdecl
+                let htyp = makeFunctionUseIO $ extractType hdecl
                 putStrLn $ (if isAcceptableImport htyp then id else commented)
                          $ HS.prettyPrint $ (HS.ForImp () (HS.CCall ()) Nothing (Just k)
                                                      (HS.Ident () k)
@@ -409,6 +448,9 @@ c2haskell opts cs missings (CTranslUnit edecls _) = do
             -}
         Just cfun -> goMissing db cfun
 
+makeAcceptableDecl (HS.TypeDecl a (DHead b (HS.Ident c signame)) ftyp)
+                =  (HS.TypeDecl a (DHead b (HS.Ident c signame)) (makeFunctionUseIO $ makeAcceptableImport ftyp))
+
 goMissing db cfun = do
       forM_ (Map.lookup cfun $ syms db) $ \si -> do
         forM_ (take 1 $ symbolSource si) $ \d -> do
@@ -416,10 +458,9 @@ goMissing db cfun = do
                 -- putStr $ commented (show $ pretty 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_ ts $ \t -> putStrLn $ "data " ++ t
                 forM_ (sigf hsTransSig d) $ \hs -> do
-                putStrLn . HS.prettyPrint $ hs
+                putStrLn . HS.prettyPrint $ makeAcceptableDecl hs
                 case hs of
                     HS.TypeDecl _ (DHead _ (HS.Ident _ signame)) ftyp  -> do
                         let wrapname = "wrap" ++ drop 3 signame
@@ -529,7 +570,6 @@ main = do
     fromMaybe (putStrLn usageString) $ m <&> \(hopts,cargs,fname) -> do
         r <- parseCFile (newGCC "gcc") Nothing cargs fname
         cs <- readComments fname
-        putStrLn $ "----------------------------"
         if prettyC hopts -- -p
             then do
                 print (fmap prettyUsingInclude r)