First successful function transpile.

1 files changed, 209 insertions, 68 deletions

diff --git a/monkeypatch.hs b/monkeypatch.hs
index fc26093..c09fcc7 100644
--- a/monkeypatch.hs
+++ b/monkeypatch.hs
@@ -92,10 +92,14 @@ specs _                               = []
 declrSym :: CDeclarator t -> Maybe Ident
 declrSym (CDeclr m _ _ _ _) = m
 
+declnSym :: CDeclaration a  -> [Maybe Ident]
+declnSym (CDecl specs ms _) = ms >>= \(m,_,_) -> maybe [] (pure . declrSym) m
+declnSym _                  = []
+
 -- Used by update to add a symbols to the database.
 sym :: CExternalDeclaration a -> [Maybe Ident]
 sym (CFDefExt (CFunDef specs m _ _ _)) = [ declrSym m ]
-sym (CDeclExt (CDecl specs ms _))      = ms >>= \(m,_,_) -> maybe [] (pure . declrSym) m
+sym (CDeclExt decl)                    = declnSym decl
 sym _                                  = []
 
 isStatic :: CDeclarationSpecifier a -> Bool
@@ -133,19 +137,141 @@ 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) [] _)
-                                _) ]
-                           []
-                            _) )
-    | Just struct_name <- capitalize . identToString <$> mbIdent
-    , let typ = mkName struct_name
-    = Just $ returnQ $ DataD [] typ [] Nothing [RecC typ fs] []
-        where fs = fields >>= transField
-
-transpile _ = Nothing
+data Computation st = Computation
+    { compFree  :: Map String ()
+    , compIntro :: Map String ()
+    , comp      :: st
+    }
+ deriving (Eq,Ord,Functor)
 
+grokExpression (CVar cv _) = Just Computation
+    { compFree  = Map.singleton (identToString cv) ()
+    , compIntro = Map.empty
+    , comp      = hsvar (identToString cv)
+    }
+grokExpression (CBinary CNeqOp a b _) = do
+    ca <- grokExpression a
+    cb <- grokExpression b
+    return Computation
+        { compFree  = compFree ca `Map.union` compFree cb
+        , compIntro = Map.empty
+        , comp      = InfixApp () (comp ca) hsopNeq (comp cb)
+        }
+grokExpression _ = Nothing
+
+
+hsvar :: String -> HS.Exp ()
+hsvar v = Var () (UnQual () (HS.Ident () v))
+
+hspvar :: String -> HS.Pat ()
+hspvar v = PVar () (HS.Ident () v)
+
+cvarName (CVar (C.Ident n _ _) _) = Just n
+cvarName _                        = Nothing
+
+hsopApp = QVarOp () (UnQual () (Symbol () "$"))
+
+hsopBind = QVarOp () (UnQual () (Symbol () ">>="))
+
+hsopNeq = QVarOp () (UnQual () (Symbol () "/="))
+
+hsopUnit = HS.Con () (Special () (UnitCon ()))
+
+
+
+
+applyComputation :: Computation (HS.Exp ()) -> Computation (HS.Exp ()) -> Computation (HS.Exp ())
+applyComputation a@Computation{ comp = (Lambda () [PVar () govar] exp) } b =
+    let matchgo (Var () (UnQual () v)) = v==govar
+        matchgo _                      = False
+    in case listify matchgo exp of
+        (_:_:_) -> error "TODO: Multiple go-refs; make let binding."
+        _       -> Computation
+            { compFree  = Map.union (compFree a) (compFree b) Map.\\ compIntro a
+            , compIntro = compIntro a `Map.union` compIntro b
+            , comp      = let subst x | matchgo x   = comp b
+                                      | otherwise   = x
+                          in everywhere (mkT subst) exp
+            }
+applyComputation a b = a
+
+varmap :: [String] -> Map String ()
+varmap vs = Map.fromList $ map (,()) vs
+
+
+grokStatement :: CCompoundBlockItem a -> Maybe (Computation (HS.Exp ()))
+grokStatement (CBlockStmt (CReturn (Just exp) _)) = do
+    x <- grokExpression exp
+    let k = uniqIdentifier "go" (compFree x `Map.union` compIntro x)
+    return $ fmap (\y -> Lambda () [hspvar k] $ App () (hsvar "return") y) x
+
+grokStatement (CBlockStmt (CExpr (Just
+                (CAssign CAssignOp cvarnew
+                    (C.CCall cvarfun [] _) _)) _)) = do
+    v <- cvarName cvarnew
+    fn <- cvarName cvarfun
+    let k = uniqIdentifier "go" (varmap [v,fn])
+    return Computation
+        { compFree = Map.singleton fn ()
+        , compIntro = Map.singleton v ()
+        , comp = Lambda () [hspvar k]
+            $ InfixApp () (hsvar fn) hsopBind
+            $ Lambda () [hspvar v] (hsvar k)
+        }
+grokStatement (CBlockStmt (CIf exp (CCompound [] stmts _) Nothing _)) = do
+    x <- grokExpression exp
+    ss <- sequence $ map grokStatement stmts
+    let s = foldr applyComputation (Computation Map.empty Map.empty (hsvar k)) ss
+        k = uniqIdentifier "go" (Map.union (compFree x) (compFree s))
+    return Computation
+        { compFree = compFree x `Map.union` compFree s
+        , compIntro = compIntro s
+        , comp = Lambda () [hspvar k] $ If () (comp x) (comp s) (hsvar k)
+        }
+grokStatement (CBlockDecl (CDecl (t:_) (v:vs) _)) = do
+    return Computation
+        { compFree  = Map.empty
+        , compIntro = Map.empty
+        , comp      = Lambda () [hspvar "go"] $ hsvar "go"
+        }
+grokStatement _ = Nothing
+
+
+transpile :: C2HaskellOptions -> FilePath -> IncludeStack -> CTranslationUnit NodeInfo -> IO ()
+transpile o fname incs (CTranslUnit edecls _) = do
+    let db = foldr update initTranspile edecls
+        locals = case oSelectFunction o of
+            Just sel -> maybe Map.empty (Map.singleton sel) $ Map.lookup sel (syms db)
+            Nothing  -> Map.filter symbolLocal (syms db)
+    forM_ (Map.toList locals) $ \(hname,sym) -> do
+        -- putStrLn $ "symbol " ++ hname ++ " sym="++show (length $ symbolSource sym)
+        forM_ (getsig ((),sym)) $ \(ns,(_,h,c)) -> do
+            -- putStrLn $ "getsig " ++ show c
+            -- CDerivedDeclarator n0’ with actual type ‘CExternalDeclaration NodeInfo
+            let as = do
+                        a <- getArgList c
+                        m <- case makeParameterNamesM a of
+                            Just (CFunDeclr (Right (ps,_)) _ _, _) -> map declnSym ps
+                            _ -> []
+                        i <- m
+                        maybe [] (return . identToString) i
+            -- mapM_ (putStrLn . show . pretty) (symbolSource sym)
+            forM_ (take 1 h) $ \hh -> do
+                putStrLn . HS.prettyPrint $ changeType makeFunctionUseIO hh
+            putStrLn $ unwords (hname:as) ++ " ="
+            let bdy = concat $ take 1 $ dropWhile null $ map body $ symbolSource sym
+            if oPrettyTree o
+                then forM_ bdy $ \d -> putStrLn $ ppShow $ everywhere (mkT eraseNodeInfo) $ d
+                else do
+                    let mhask = do
+                            xs <- sequence $ map grokStatement bdy
+                            return $ foldr applyComputation (Computation Map.empty Map.empty hsopUnit) xs
+                    case mhask of
+                        Just hask -> mapM_ (putStrLn . ("  "++)) $ lines $ HS.prettyPrint $ comp hask
+                        Nothing -> forM_ bdy $ \d -> do
+                                    putStrLn . show . pretty $ d
+                                    mapM_ (putStrLn . HS.prettyPrint . comp) (grokStatement d)
+    return ()
 
 isHeaderDecl :: CNode a => a -> Bool
 isHeaderDecl = maybe False (isSuffixOf ".h") . fileOfNode
@@ -307,6 +433,11 @@ extractType (HS.TypeDecl _ _ ftyp) = ftyp
 extractType (HS.TypeSig _ _ ftyp)  = ftyp
 extractType _                      = TyCon () (Special () (UnitCon ()))
 
+changeType :: (HS.Type a -> HS.Type a) -> Decl a -> Decl a
+changeType f (HS.TypeDecl a b ftyp) = HS.TypeDecl a b (f ftyp)
+changeType f (HS.TypeSig a b ftyp)  = HS.TypeSig a b (f ftyp)
+changeType f x                      = x
+
 {-
 hsTransFieldExt :: Show b =>
                          [CDeclarationSpecifier b]
@@ -418,40 +549,34 @@ commented :: String -> String
 commented s = unlines $ map ("-- " ++) (lines s)
 
 data C2HaskellOptions = C2HaskellOptions
-    { selectFunction :: Maybe String
-    , prettyC        :: Bool
-    , prettyTree     :: Bool
-    , verbose        :: Bool
-    , preprocess    :: Bool
+    { oSelectFunction :: Maybe String
+    , oPrettyC        :: Bool
+    , oPrettyTree     :: Bool
+    , oVerbose        :: Bool
+    , oPreprocess     :: Bool
+    , oTranspile      :: Bool
     }
 
 defopts :: C2HaskellOptions
 defopts = C2HaskellOptions
-    { selectFunction = Nothing
-    , prettyC        = False
-    , prettyTree     = False
-    , verbose        = False
-    , preprocess     = False
+    { oSelectFunction = Nothing
+    , oPrettyC        = False
+    , oPrettyTree     = False
+    , oVerbose        = False
+    , oPreprocess     = False
+    , oTranspile      = False
     }
 
 parseOptions :: [String] -> C2HaskellOptions -> C2HaskellOptions
-parseOptions []            opts = opts
-parseOptions ("-f":f:args) opts = parseOptions args opts
-    { selectFunction = Just f
-    }
-parseOptions ("-t":args) opts = parseOptions args opts
-    { prettyTree = True
-    }
-parseOptions ("-p":args) opts = parseOptions args opts
-    { prettyC = True
-    }
-parseOptions ("--cpp":args) opts = parseOptions args opts
-    { preprocess = True
-    }
-parseOptions ("-v":args) opts = parseOptions args opts
-    { verbose = True
-    }
-parseOptions as x = error (show as)
+parseOptions []              o = o
+parseOptions ("-f":f:args)   o = parseOptions args o{ oSelectFunction = Just f }
+parseOptions ("-t":args)     o = parseOptions args o{ oPrettyTree = True }
+parseOptions ("-p":args)     o = parseOptions args o{ oPrettyC = True }
+parseOptions ("--cpp":args)  o = parseOptions args o{ oPreprocess = True }
+parseOptions ("-v":args)     o = parseOptions args o{ oVerbose = True }
+parseOptions ("--tohs":args) o = parseOptions args o{ oTranspile = True }
+parseOptions as              o = error (show as)
+
 
 tnames :: Show b =>
           CExternalDeclaration b -> [(String, Maybe String)]
@@ -465,11 +590,12 @@ getsig :: (a, SymbolInformation [CExternalDeclaration NodeInfo])
                       , 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 = tnames d
+    d <- case getArgList d0 of
+            oargs:xs -> case makeParameterNamesM oargs of
+                            Just (args,_) -> [changeArgList (const $ args:xs) d0]
+                            Nothing       -> []
+            _        -> [d0]
+    let ts = tnames d
         s = sig d
     [(ts,(k,s,d))]
 
@@ -508,6 +634,13 @@ seekComment ni cs = break (\c -> lineOfComment c>=posRow (posOfNode ni)) cs
 
 strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 
+
+data GStatement x = GStatement
+    { gsTopDoc  :: String
+    , gsSideDoc :: String
+    , gstatemnt :: x
+    }
+
 -- c2haskell :: Foldable t => C2HaskellOptions -> p -> t String -> CTranslationUnit NodeInfo -> IO ()
 c2haskell :: C2HaskellOptions
                    -> p1 -> FilePath -> [String] -> IncludeStack -> CTranslationUnit NodeInfo -> IO ()
@@ -515,7 +648,7 @@ 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
+    case oSelectFunction opts of
         Nothing -> do
           createDirectoryIfMissing False "MonkeyPatch"
           let fname = ("MonkeyPatch/" ++ modname ++ ".hs")
@@ -808,12 +941,10 @@ parameterIdent (CDecl _ xs n) = listToMaybe $ do
     (Just (CDeclr (Just x) _ _ _ _),_,_) <- xs
     return x
 
-
--- 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 )
+makeParameterNamesM :: CDerivedDeclarator n -> Maybe (CDerivedDeclarator n,[CExpression n])
+makeParameterNamesM (CFunDeclr (Right (ps, flg)) z2 z3) = case ps of
+    [CDecl [CTypeSpec (CVoidType _)] [] _] -> Just ( CFunDeclr (Right (ps, flg)) z2 z3 , []) -- void argument list.
+    _                                      -> Just ( CFunDeclr (Right (qs, flg)) z2 z3 , map expr qs )
  where
     -- TODO: ensure uniqueness of generated parameter names
     qs = zipWith mkp [0..] ps
@@ -822,8 +953,11 @@ 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)
+makeParameterNamesM _ = Nothing
+
+-- makeParameterNames :: CDerivedDeclarator NodeInfo -> (CDerivedDeclarator NodeInfo,[CExpression NodeInfo])
+makeParameterNames :: CDerivedDeclarator n -> (CDerivedDeclarator n,[CExpression n])
+makeParameterNames x = fromMaybe (error $ "makeParameterNames " ++ show (fmap (const ()) x)) $ makeParameterNamesM x
 
 expr :: CDeclaration a -> CExpression a
 expr (CDecl rtyp ((Just (CDeclr (Just i) typ x ys z),a,b):xs) n) = CVar i n
@@ -1003,6 +1137,13 @@ usage args =
 (<&>) :: Functor f => f a -> (a -> b) -> f b
 m <&> f = fmap f m
 
+uniqIdentifier :: String -> Map String a -> String
+uniqIdentifier n emap = head $ dropWhile (`Map.member` emap) ns
+ where
+    ns = n : map ((n ++) . show) [1 ..]
+
+
+-- | Remove duplicates from a collection.
 uniq :: (Ord k, Foldable t) => t k -> [k]
 uniq xs = Map.keys $ foldr (\x m -> Map.insert x () m) Map.empty xs
 
@@ -1078,7 +1219,8 @@ main = do
     let m = usage args
     fromMaybe (putStrLn usageString) $ m <&> \(hopts,cargs,fname:fs) -> do
         prer <- runPreprocessor (newGCC "gcc") (rawCppArgs cargs fname)
-        let r = do
+        let r :: Either (Either ExitCode ParseError) (IncludeStack, CTranslUnit)
+            r = do
                 pre <- left Left $ prer
                 c <- left Right $ parseC pre (initPos fname)
                 return (includeStack pre,c)
@@ -1086,17 +1228,16 @@ main = do
         -- putStrLn $ "includes = " ++ ppShow (fmap fst r)
         -- cs <- readComments fname
         case () of
-            _ | preprocess hopts -- --cpp
-                -> do
-                case prer of
-                    Left e -> print e
-                    Right bs -> putStrLn $ ppShow $ includeStack $ bs
-            _ | prettyC hopts -- -p
-                 -> do
-                either print (\(incs,decls) -> print $ prettyUsingInclude incs decls) r
-            _ | prettyTree hopts -- -t
-                 -> do
-                putStrLn $ ppShow $ everywhere (mkT eraseNodeInfo) . snd <$> r
+            _ | oPreprocess hopts -- --cpp
+                 -> case prer of
+                        Left e -> print e
+                        Right bs -> putStrLn $ ppShow $ includeStack $ bs
+            _ | oPrettyC hopts -- -p
+                 -> either print (\(incs,decls) -> print $ prettyUsingInclude incs decls) r
+            _ | oPrettyTree hopts && not (oTranspile hopts) -- -t
+                 -> putStrLn $ ppShow $ everywhere (mkT eraseNodeInfo) . snd <$> r
+            _ | oTranspile hopts -- --tohs
+                 -> either print (uncurry $ transpile hopts fname) r
             _    -> do
-                syms <- linker (cargs ++ reverse fs) fname
-                either print (uncurry $ c2haskell hopts () fname syms) r
+                    syms <- linker (cargs ++ reverse fs) fname
+                    either print (uncurry $ c2haskell hopts () fname syms) r