From 29cb139e8b4939353ca6334cc2540b8a8476b057 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Wed, 13 Mar 2019 09:27:50 -0400 Subject: First successful function transpile. --- monkeypatch.hs | 277 +++++++++++++++++++++++++++++++++++++++++++-------------- 1 file 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 -- cgit v1.2.3