It worked!

1 files 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 <sym>] -- [gcc options] [modules] <cfile>"
     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