* getsig: Keep original c-names for haskell types.

* Remove trailing closer from comment parser result.
* Upper bound for base dependency.

2 files changed, 77 insertions, 29 deletions

diff --git a/monkeypatch.cabal b/monkeypatch.cabal
index 4c66cb7..21146e4 100644
--- a/monkeypatch.cabal
+++ b/monkeypatch.cabal
@@ -54,7 +54,7 @@ executable monkeypatch
   main-is:             monkeypatch.hs
   -- other-modules:
   -- other-extensions:
-  build-depends:       base ^>=4.10.1.0
+  build-depends:       base >=4.10.1.0  && <=4.12
                      , containers ^>=0.5.10.2
                      , language-c
                      , haskell-src-exts
diff --git a/monkeypatch.hs b/monkeypatch.hs
index 7c9d75d..ac67afa 100644
--- a/monkeypatch.hs
+++ b/monkeypatch.hs
@@ -1,17 +1,18 @@
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE BangPatterns             #-}
 {-# LANGUAGE DeriveFunctor            #-}
 {-# LANGUAGE FlexibleContexts         #-}
 {-# LANGUAGE LambdaCase               #-}
 {-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE OverloadedStrings        #-}
 {-# LANGUAGE QuasiQuotes              #-}
 {-# LANGUAGE TemplateHaskell          #-}
+{-# LANGUAGE TupleSections            #-}
 module Main where
 
-import Control.Arrow (left)
+import Control.Arrow (left,first,second)
 import Data.Generics.Aliases
 import Data.Generics.Schemes
--- import Debug.Trace
+import Debug.Trace
 import Control.Monad
 import qualified Data.ByteString.Char8 as B
 import Data.Char
@@ -45,7 +46,7 @@ import Text.PrettyPrint             (Doc, doubleQuotes, empty, text, vcat, ($$),
                                      (<+>))
 import Text.Show.Pretty
 
-trace _ = id
+-- trace _ = id
 
 -- | Pretty print the given tranlation unit, but replace declarations from header files with @#include@ directives.
 --
@@ -247,16 +248,19 @@ hsTransField :: Show b =>
                       [CDeclarationSpecifier b] -- c structure name
                       -- -> [(Maybe (CDeclarator b), Maybe (CInitializer b), Maybe (CExpression b))] -- c variable declarations
                       -> [CDeclarator b] -- c variable declarations
-                      -> [(String{-field name-}, HS.Type () {- haskell type -}) ]
+                      -> [ ( (String{-field name-}, HS.Type () {- haskell type -})
+                           , Maybe String{- c type -})]
 hsTransField ctyps vars
     = do
-        typname <- hsMkName . either (capitalize . identToString) id <$> (hsTypeSpec =<< ctyps)
+        (mcname,typname) <- second hsMkName . either ((\s -> (Just s,capitalize s)) . identToString)
+                                                     (Nothing,)
+                                                     <$> (hsTypeSpec =<< ctyps)
         trace ("typname="++show typname) $ return ()
         -- (var,Nothing,Nothing) <- vars
         var <- vars
         trace ("var="++show var) $ return ()
         -- CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var
-        let CDeclr mfident ptrdeclr Nothing [] _ = var -- TODO: Look into: Irrefutable pattern failed (ctox/toxcore/DHT.c)
+        let CDeclr mfident ptrdeclr Nothing ignored_attrs _ = var -- TODO: Look into: Irrefutable pattern failed (ctox/toxcore/DHT.c)
         -- let CDeclr mfident ptrdeclr _ _ _ = var
         trace ("fident="++show mfident) $ return ()
         trace ("ptrdeclr="++show ptrdeclr) $ return ()
@@ -265,7 +269,7 @@ hsTransField ctyps vars
                 []                               -> 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 $ concatMap fieldInfo as) args
+                    let (as,ts) = unzip $ concatMap (\(CDecl rs as _) -> map fst $ hsTransField rs $ concatMap fieldInfo as) args
                         b0 = case p of
                                CPtrDeclr [] _:cs -> HS.TyApp () (HS.TyCon () (hsMkName "Ptr")) (grok cs b)
                                []                -> b
@@ -273,7 +277,7 @@ hsTransField ctyps vars
                 _                                -> HS.TyCon () (hsMkName $ show $ map (fmap (const ())) ptrdeclr)
             ftyp = grok ptrdeclr btyp
             fieldName = maybe ("_") identToString mfident
-        [ ( fieldName, ftyp ) ]
+        [ ( ( fieldName, ftyp ), mcname ) ]
 {-
 transField (CDecl [CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _)] vars _)
     | Just typname <- mkName . capitalize . identToString <$> mctyp
@@ -302,16 +306,23 @@ hsTransFieldExt :: Show b =>
 hsTransFieldExt :: Show b =>
                          [CDeclarationSpecifier b] -> [CDeclarator b] -> [Decl ()]
 hsTransFieldExt rs as = concatMap (\(fieldName,ftyp)-> [ HS.TypeSig () [ HS.Ident () fieldName ] ftyp ])
-                                        $ hsTransField rs as
+                                        $ map fst $ hsTransField rs as
 
-hsTransSig rs as = concatMap (\(fieldName,ftyp)-> [ HS.TypeDecl () (DHead () (HS.Ident () ("Sig_" ++ fieldName))) ftyp ])
+hsTransSig :: Show b =>
+                    [CDeclarationSpecifier b] -> [CDeclarator b] -> [(Decl (),Maybe String)]
+hsTransSig rs as = map (\((fieldName,ftyp),ctyp) -> ( HS.TypeDecl () (DHead () (HS.Ident () ("Sig_" ++ fieldName))) ftyp, ctyp ))
                                         $ hsTransField rs as
 
+-- Extract argument types from a haskell function type declaration.
+types :: Decl l -> [HS.Type l]
 types (HS.TypeDecl _ _ typ) = primtypes typ
 
+primtypes :: HS.Type l -> [HS.Type l]
 primtypes (HS.TyFun _ a b) = primtypes a ++ primtypes b
 primtypes t = [t]
 
+-- Haskell type name as string.
+tname :: HS.Type () -> String
 tname (HS.TyCon () (HS.UnQual () (HS.Ident () str))) = str
 tname _                                              = "_unkonwn"
 
@@ -324,12 +335,15 @@ pointers decls = do
     d <- decls
     maybeToList $ getPtrType d
 
+-- If it's a haskell Ptr type, then return the pointed type.
+-- Otherwise, no op.
+unpointer :: HS.Type l -> HS.Type l
 unpointer t = case getPtrType t of
     Nothing -> t
     Just t' -> t'
 
 -- sig :: Show t => CExternalDeclaration t -> [HS.Decl ()]
-sig :: CExternalDeclaration NodeInfo -> [Decl ()]
+sig :: CExternalDeclaration NodeInfo -> [HS.Decl ()]
 sig = sigf hsTransFieldExt
 
 -- • Couldn't match expected type ‘CDerivedDeclarator a        -> (Maybe (CDeclarator a), Maybe (CInitializer a), Maybe (CExpression a))’
@@ -422,13 +436,21 @@ parseOptions ("-v":args) opts = parseOptions args opts
     }
 parseOptions as x = error (show as)
 
+tnames d = filter (notKnown . fst) $ map (first $ tname . unpointer) $ concatMap (\(t,c) -> map (,c) (types t)) $ sigf hsTransSig d
+
+
+getsig :: (a, SymbolInformation [CExternalDeclaration NodeInfo])
+                -> [([(String,Maybe String)] -- List of haskell/c type names to define
+                    , ( a
+                      , [Decl ()]                        -- haskell declaration
+                      , CExternalDeclaration NodeInfo))] -- c declaration (with fixups)
 getsig (k,si) = do
     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
+        ts = tnames d
         s = sig d
     [(ts,(k,s,d))]
 
@@ -452,11 +474,17 @@ 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 (CDeclExt (CDecl xs _ ni)) = do
+    CTypeSpec (CEnumType (CEnum _ (Just cs))) <- xs
+    return (ni,cs)
+
+
 -- c2haskell :: Foldable t => C2HaskellOptions -> p -> t String -> CTranslationUnit NodeInfo -> IO ()
 c2haskell :: C2HaskellOptions
                    -> p1 -> FilePath -> [String] -> IncludeStack -> CTranslationUnit NodeInfo -> IO ()
 c2haskell opts cs cmodname missings incs (CTranslUnit edecls _) = do
     let db = foldr update initTranspile edecls
+        {- exported symbols in this module -}
         es = Map.filter (\d -> symbolLocal d && not (symbolStatic d)) (syms db)
     case selectFunction opts of
         Nothing -> do
@@ -475,18 +503,28 @@ c2haskell opts cs cmodname missings incs (CTranslUnit edecls _) = do
           hPutStrLn haskmod $ "import Data.Int"
           putStrLn $ "-- " ++ show (fmap (fmap (fmap (const ()))) <$> Map.lookup "ip_is_lan" (syms db))
           let sigs = concatMap getsig (Map.toList es)
+              {- referenced haskell type names by missing symbols -}
               sigs2 = concatMap (\s -> do
                                   x <- maybeToList $ Map.lookup s (syms db)
                                   (y,_) <- getsig (s,x)
                                   y)
                           missings
+              {- referenced haskell type names by all exported symbols -}
               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
+          hPutStrLn haskmod ""
+          forM_ (uniq $ ts ++ sigs2) $ \(t,ct) -> do
+            case ct >>= (`Map.lookup` syms db) of
+                Just si -> do
+                    let symfile :: Maybe FilePath
+                        symfile = (listToMaybe (symbolSource si) >>= fileOfNode)
+                    hPutStrLn haskmod $ "-- " ++ show symfile
+                    mapM_ (hPutStrLn haskmod . commented . show . pretty) $ symbolSource si
+                    cs <- maybe (return []) readComments symfile
+                    mapM_ (hPutStrLn haskmod . commented . ppShow) $ cs
+                    mapM_ (hPutStrLn haskmod . commented . ppShow) $ symbolSource si
+                Nothing -> return ()
             hPutStrLn haskmod $ "data " ++ t
+          hPutStrLn haskmod ""
           forM_ sigs $ \(_,(k,hs,d)) -> do
             forM_ hs $ \hdecl -> do
                 {-
@@ -634,11 +672,18 @@ getArgList1 (CDeclr a xs b c d) = xs
 
 getArgList2 ((a,b,c):zs) = getArgList3 a
 
+getArgList3 (Just (CDeclr a [CPtrDeclr [] _] b c d)) = [] -- struct prototype, no fields.
 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
+
 getArgList :: CExternalDeclaration a -> [CDerivedDeclarator a]
-getArgList (CFDefExt (CFunDef xs ys zs c d)) = getArgList1 ys
-getArgList (CDeclExt (CDecl xs ys pos))      = getArgList2 ys
+getArgList x = let v=getArgList_ x in trace ("getArgList ("++show (u x)++") = "++show (fmap u v)) v
+ where
+    u :: Functor f => f a -> f ()
+    u = fmap (const ())
 
 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))
@@ -686,6 +731,8 @@ makeParameterNames (CFunDeclr (Right (ps, flg)) z2 z3) = case ps of
     mkp num (CDecl rtyp [] n)
           = (CDecl rtyp ((Just (CDeclr (Just $ mkidn num undefNode) [] Nothing [] n),Nothing,Nothing):[]) n)
     mkp num p = p
+-- CPtrDeclr [] ()
+makeParameterNames x = error $ "makeParameterNames " ++ show (fmap (const ()) x)
 
 expr :: CDeclaration a -> CExpression a
 expr (CDecl rtyp ((Just (CDeclr (Just i) typ x ys z),a,b):xs) n) = CVar i n
@@ -777,9 +824,9 @@ goMissing haskmod db cfun = do
                         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
+                let ts = tnames d
+                -- forM_ ts $ \(t,_) -> putStrLn $ "data " ++ t
+                forM_ (sigf hsTransSig d) $ \(hs,ctypname) -> do
                 hPutStrLn haskmod . HS.prettyPrint $ makeAcceptableDecl hs
                 case hs of
                     HS.TypeDecl _ (DHead _ (HS.Ident _ signame)) ftyp  -> do
@@ -810,8 +857,7 @@ goMissing haskmod db cfun = do
                     htyp -> hPutStr haskmod $ commented $ "Unsupported haskell type: " ++ HS.prettyPrint htyp
 
 
-readComments :: (Num lin, Num col) =>
-                      FilePath -> IO [(lin, col, [Char])]
+readComments :: (Num lin, Num col) => FilePath -> IO [(lin, col, [Char])]
 readComments fname = parseComments 1 1 <$> readFile fname
 
 findCloser :: (Num a4, Num a3, Num a2, Num a1, Eq a1) =>
@@ -829,7 +875,9 @@ 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
+                        (xs,cs') = case drop (bcnt-2) cs of
+                            '*':'/':_ -> second (drop 2) $ splitAt (bcnt-2) cs
+                            _         -> splitAt bcnt cs
                     in mkComment lin col xs : parseComments (lin + lcnt) col' cs'
     ('/':'/':cs) -> let (comment,ds) = break (=='\n') cs
                     in mkComment lin col comment : parseComments (lin + 1) 1 cs
@@ -938,7 +986,7 @@ main = do
                 return (includeStack pre,c)
         -- putStrLn $ "fname = " ++ fname
         -- putStrLn $ "includes = " ++ ppShow (fmap fst r)
-        cs <- readComments fname
+        -- cs <- readComments fname
         case () of
             _ | preprocess hopts -- --cpp
                 -> do
@@ -953,4 +1001,4 @@ main = do
                 putStrLn $ ppShow $ everywhere (mkT eraseNodeInfo) . snd <$> r
             _    -> do
                 syms <- linker (cargs ++ reverse fs) fname
-                either print (uncurry $ c2haskell hopts cs fname syms) r
+                either print (uncurry $ c2haskell hopts () fname syms) r