{-# 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,first,second) import Data.Either import Data.Generics.Aliases import Data.Generics.Schemes import Debug.Trace import Control.Monad import qualified Data.ByteString.Char8 as B import Data.Char import Data.Data import Data.List import qualified Data.IntMap as IntMap ;import Data.IntMap (IntMap) import qualified Data.Map as Map ;import Data.Map (Map) import Data.Maybe import qualified Data.Set as Set ;import Data.Set (Set) import Language.C.Data.Ident as C import Language.C as C hiding (prettyUsingInclude) import qualified Language.C as C import Language.C.System.GCC import Language.C.System.Preprocess import Language.C.Data.Position import Language.Haskell.Exts.Parser as HS import Language.Haskell.Exts.Pretty as HS import Language.Haskell.Exts.Syntax as HS import Language.Haskell.TH import Language.Haskell.TH.Ppr import Language.Haskell.TH.Syntax as TH import System.Directory import System.Environment import System.IO import System.Process import System.Exit import Text.PrettyPrint (Doc, doubleQuotes, empty, text, vcat, ($$), (<+>)) import Text.Show.Pretty import Comments -- trace _ = id -- | Pretty print the given tranlation unit, but replace declarations from header files with @#include@ directives. -- -- The resulting file may not compile (because of missing @#define@ directives and similar things), but is very useful -- for testing, as otherwise the pretty printed file will be cluttered with declarations from system headers. prettyUsingInclude :: IncludeStack -> CTranslUnit -> Doc prettyUsingInclude incs (CTranslUnit edecls _) = vcat (map (either includeHeader pretty) $ sortBy sysfst mappedDecls) where (headerFiles,mappedDecls) = foldr (addDecl . tagIncludedDecls) (Set.empty,[]) edecls tagIncludedDecls edecl | maybe False isHeaderFile (fileOfNode edecl) = Left ((includeTopLevel incs . posFile . posOf) edecl) | otherwise = Right edecl addDecl decl@(Left headerRef) (headerSet, ds) | null headerRef || Set.member headerRef headerSet = (headerSet, ds) | otherwise = (Set.insert headerRef headerSet, decl : ds) addDecl decl (headerSet,ds) = (headerSet, decl : ds) includeHeader hFile = text "#include" <+> text hFile isHeaderFile = (".h" `isSuffixOf`) sysfst (Left ('"':a)) (Left ('<':b)) = Prelude.GT sysfst _ _ = Prelude.LT includeTopLevel :: IncludeStack -> FilePath -> [Char] includeTopLevel (IncludeStack incs) f = do stacks <- maybeToList $ Map.lookup f incs stack <- take 1 stacks top <- take 1 $ drop 4 $ reverse (f:stack) if take 1 top == "/" then let ws = groupBy (\_ c -> c /='/') top (xs,ys) = break (=="/include") ws ys' = drop 1 ys in if not (null ys') then '<': drop 1 (concat ys') ++ ">" else '"':top++"\"" else '"':top ++"\"" specs :: CExternalDeclaration a -> [CDeclarationSpecifier a] specs (CFDefExt (CFunDef ss _ _ _ _)) = ss specs (CDeclExt (CDecl ss _ _)) = ss 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 decl) = declnSym decl sym _ = [] isStatic :: CDeclarationSpecifier a -> Bool isStatic (CStorageSpec (CStatic _)) = True isStatic _ = False capitalize :: String -> String capitalize xs = concatMap (cap . drop 1) gs where gs = groupBy (\a b -> b/='_') $ '_':xs cap (c:cs) = toUpper c : cs transField :: CDeclaration t -> [(TH.Name, TH.Bang, TH.Type)] transField (CDecl [CTypeSpec (CTypeDef ctyp _)] vars _) = do let typname = mkName . capitalize . identToString $ ctyp (var,Nothing,Nothing) <- vars CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var let fieldName = mkName $ identToString fident ftyp = case ptrdeclr of [] -> ConT typname [CPtrDeclr [] _] -> AppT (ConT (mkName "Ptr")) (ConT typname) [ (fieldName, Bang NoSourceUnpackedness NoSourceStrictness, ftyp) ] transField (CDecl [CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _)] vars _) | Just typname <- mkName . capitalize . identToString <$> mctyp = do (var,Nothing,Nothing) <- vars CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var let fieldName = mkName $ identToString fident ftyp = case ptrdeclr of [] -> ConT typname [CPtrDeclr [] _] -> AppT (ConT (mkName "Ptr")) (ConT typname) [ (fieldName, Bang NoSourceUnpackedness NoSourceStrictness, ftyp) ] transField _ = [] data Computation st = Computation { compFree :: Map String () , compIntro :: Map String () , comp :: st } deriving (Eq,Ord,Functor) 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 hsopUnit = HS.Con () (Special () (UnitCon ())) infixOp x op y = InfixApp () x (QVarOp () (UnQual () (Symbol () op))) y infixFn x fn y = InfixApp () x (QVarOp () (UnQual () (HS.Ident () fn))) y 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 {- CUnary CAdrOp (CVar _ _) LT) LT CCall (CVar i _) exps _ -} -- Returns a list of statements bringing variables into scope and an -- expression. grokExpression (CVar cv _) = Just $ (,) [] $ Computation { compFree = Map.singleton (identToString cv) () , compIntro = Map.empty , comp = hsvar (identToString cv) } grokExpression (CConst (CIntConst n _)) = Just $ (,) [] $ Computation { compFree = Map.empty , compIntro = Map.empty , comp = Lit () (Int () (getCInteger n) (show n)) } grokExpression (CBinary CNeqOp a b _) = do (as,ca) <- grokExpression a (bs,cb) <- grokExpression b let ss = as ++ bs -- TODO: resolve variable name conflicts return $ (,) ss $ Computation { compFree = compFree ca `Map.union` compFree cb , compIntro = Map.empty , comp = infixOp (comp ca) "/=" (comp cb) } grokExpression (CUnary CAdrOp (CVar cv0 _) _) = do let cv = identToString cv0 hv = "p" ++ cv k = uniqIdentifier "go" (Map.empty {-todo-}) ss = pure Computation { compFree = Map.singleton cv () , compIntro = Map.singleton hv () , comp = Lambda () [hspvar k] $ infixFn (hsvar cv) "withPointer" (Lambda () [hspvar hv] (hsvar k)) } return $ (,) ss Computation { compFree = Map.singleton hv () , compIntro = Map.empty , comp = hsvar hv } grokExpression (CCond cond (Just thn) els _) = do (cs,c) <- grokExpression cond (ts,t) <- grokExpression thn (es,e) <- grokExpression els let tt = foldr applyComputation t ts ee = foldr applyComputation e es return $ (,) cs $ fmap (\cnd -> If () cnd (comp tt) (comp ee)) c { compFree = compFree ee `Map.union` compFree tt `Map.union` compFree c } grokExpression (CSizeofExpr expr _) = do (xs,x) <- grokExpression expr return $ (,) xs $ fmap (App () (hsvar "sizeOf")) x grokExpression (CCast (CDecl [CTypeSpec (CVoidType _)] [] _) expr _) = grokExpression expr grokExpression (CCast (CDecl [ CTypeSpec (CVoidType _) ] [ ( Just (CDeclr Nothing [ CPtrDeclr [] _ ] Nothing [] _) , Nothing , Nothing) ] _) (CConst (CIntConst zero _)) _) | 0 <- getCInteger zero = do return $ (,) [] Computation { compFree = Map.singleton "nullPtr" () , compIntro = Map.empty , comp = hsvar "nullPtr" } grokExpression (CComma exps _) = do gs <- mapM grokExpression exps let ss = concatMap fst gs -- TODO: resolve variable name conflicts cll = foldr1 (\x y -> infixFn x "seq" y) $ map (comp . snd) gs frees = foldr1 Map.union (map (compFree . snd) gs) k = uniqIdentifier "go" frees return $ (,) ss Computation { compFree = frees , compIntro = Map.empty , comp = cll } grokExpression (C.CCall (CVar fn _) exps _) = do gs <- mapM grokExpression exps let ss = concatMap fst gs -- TODO: resolve variable name conflicts hv = "r" ++ identToString fn cll = foldl (App ()) (hsvar (identToString fn)) $ map (comp . snd) gs frees = foldr Map.union (Map.singleton (identToString fn) ()) (map (compFree . snd) gs) k = uniqIdentifier "go" frees s = Computation { compFree = frees , compIntro = Map.singleton hv () , comp = Lambda () [hspvar k] $ infixOp cll ">>=" $ Lambda () [hspvar hv] (hsvar k) } return $ (,) (ss++[s]) Computation { compFree = Map.singleton hv () , compIntro = Map.empty , comp = hsvar hv } grokExpression _ = Nothing grokInitialization _ (Just (CDeclr (Just cv0) _ _ _ _),CInitExpr exp _) = do let v = identToString cv0 (xs,x) <- grokExpression exp let hsexp = fmap (App () (hsvar "return")) x -- Paren () ( ret = flip (foldr applyComputation) xs $ fmap (\exp -> infixOp exp ">>=" $ Lambda () [hspvar v] (hsvar k)) hsexp k = uniqIdentifier "go" (compFree ret) return $ fmap (\exp -> Lambda () [hspvar k] exp) ret grokInitialization ts (Just (CDeclr (Just cv0) _ _ _ _),CInitList exps _) = do let v = identToString cv0 -- let k = uniqIdentifier "go" (varmap [v]) case lefts $ concatMap hsTypeSpec ts of (ident:_) -> do -- TODO: intialize fields. let hident = HS.Ident () $ capitalize $ identToString ident gs <- do forM exps $ \(ms,initexpr) -> do case initexpr of CInitExpr ie _ -> grokExpression ie >>= \g -> return (ms,g) _ -> Nothing let assigns = do (ms,(ss,x)) <- gs let k2 = uniqIdentifier "gopoo" (compFree ret) ret = foldr applyComputation (Computation Map.empty Map.empty (hsvar k2)) (ss ++ cs) cs = do CMemberDesig m _ <- ms let k1 = uniqIdentifier "go" (compFree x) fieldinit = comp x fieldlbl = identToString m return x { comp = Lambda () [hspvar k1] $ infixOp (App () (App () (App () (hsvar "set") (TypeApp () (TyPromoted () (PromotedString () fieldlbl fieldlbl)))) (hsvar v)) fieldinit) ">>" (hsvar k1) } return $ fmap (\exp -> Lambda () [hspvar k2] exp) ret let newstruct = Computation { compFree = Map.empty -- todo , compIntro = Map.singleton v () , comp = Lambda () [hspvar k] $ infixOp (App () (hsvar "newStruct") (TypeApp () (TyCon () (UnQual () hident)))) ">>=" $ Lambda () [hspvar v] (hsvar k) } k = uniqIdentifier "go" Map.empty -- (compFree ret) TODO ret = foldr applyComputation (Computation Map.empty Map.empty (hsvar k)) $ newstruct : assigns return $ fmap (\exp -> Lambda () [hspvar k] exp) ret _ -> Nothing grokInitialization _ _ = Nothing grokStatement :: CCompoundBlockItem a -> Maybe (Computation (HS.Exp ())) grokStatement (CBlockStmt (CReturn (Just exp) _)) = do (xs,x) <- grokExpression exp let k = uniqIdentifier "go" (compFree x `Map.union` compIntro x) x' = fmap (\y -> App () (hsvar "return") y) x return $ fmap (\y -> Lambda () [hspvar k] y) $ foldr applyComputation x' xs 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] $ infixOp (hsvar fn) ">>=" $ Lambda () [hspvar v] (hsvar k) } grokStatement (CBlockStmt (CIf exp (CCompound [] stmts _) Nothing _)) = do (xs,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 $ flip (foldr applyComputation) xs Computation { compFree = compFree x `Map.union` compFree s , compIntro = compIntro s , comp = Lambda () [hspvar k] $ If () (comp x) (comp s) (hsvar k) } -- TODO CStatExpr grokStatement (CBlockStmt (CExpr mexpr _)) = do let (ss,pre) = fromMaybe ([],Computation Map.empty Map.empty id) $ do expr <- mexpr (ss,x) <- grokExpression expr return (ss, fmap (\e -> infixFn e "seq") x) k = uniqIdentifier "go" (compFree s) s = foldr applyComputation (fmap ($ hsvar k) pre) ss return $ fmap (Lambda () [hspvar k]) s grokStatement (CBlockDecl (CDecl (t:ts) (v:vs) _)) = do -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CDeclr i _ initial _ _) -> initial) (v:vs) of -- case mapMaybe (\(cdeclr,_,_) -> cdeclr >>= \(CInitList xs _) -> Just xs) (v:vs) of case mapMaybe (\(i,inits,_) -> fmap ((,) i) inits) (v:vs) of [] -> return Computation { compFree = Map.empty , compIntro = Map.empty , comp = Lambda () [hspvar "go"] $ hsvar "go" } initials -> do gs <- mapM (grokInitialization $ t:ts) initials return $ fmap (\exp -> Lambda () [hspvar "go"] exp) $ foldr applyComputation (Computation Map.empty Map.empty (hsvar "go")) gs grokStatement _ = Nothing isFunctionDecl (CDeclExt (CDecl _ [(Just (CDeclr _ [CFunDeclr _ _ _] _ _ _),_,_)] _)) = True isFunctionDecl (CFDefExt (CFunDef _ _ _ (CCompound [] _ _) _)) = True isFunctionDecl _ = False 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) let mprintHeader = do hh <- listToMaybe h guard (isJust (oSelectFunction o) || isFunctionDecl c) Just $ do -- putStrLn $ show (fmap (const LT) c) putStrLn . HS.prettyPrint $ changeType makeFunctionUseIO hh putStrLn $ unwords (hname:as) ++ " =" cleanTree d = fmap (const LT) $ everywhere (mkT eraseNodeInfo) $ d forM_ mprintHeader $ \printHeader -> do let bdy = concat $ take 1 $ dropWhile null $ map body $ symbolSource sym if oPrettyTree o then do printHeader forM_ bdy $ \d -> putStrLn $ ppShow $ cleanTree 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 -> do printHeader mapM_ (putStrLn . (" "++)) $ lines $ HS.prettyPrint $ comp hask Nothing -> forM_ (oSelectFunction o) $ \_ -> do printHeader forM_ bdy $ \d -> do putStrLn $ " C: " ++ show (pretty d) case grokStatement d of Just hd -> do putStrLn $ "fr: " ++ intercalate " " (Map.keys (compFree hd)) putStrLn $ "HS: " ++ HS.prettyPrint (comp hd) Nothing -> putStrLn $ "??: " ++ ppShow (cleanTree d) putStrLn "" return () isHeaderDecl :: CNode a => a -> Bool isHeaderDecl = maybe False (isSuffixOf ".h") . fileOfNode -- bar :: CExternalDeclaration NodeInfo -> () -- bar (CDeclExt (CDecl xs [] (NodeInfo pos poslen name))) = () data SymbolInformation c = SymbolInformation { symbolLocal :: Bool , symbolStatic :: Bool , symbolSource :: c } deriving (Eq,Ord,Show,Functor) symbolInformation :: SymbolInformation [CExternalDeclaration NodeInfo] symbolInformation = SymbolInformation { symbolLocal = False , symbolStatic = False , symbolSource = mempty } data Transpile c = Transpile { syms :: Map String (SymbolInformation c) } initTranspile :: Transpile c initTranspile = Transpile { syms = Map.empty } -- grokSymbol :: CExternalDeclaration a -> String -> Maybe SymbolInformation -> Maybe SymbolInformation grokSymbol :: CExternalDeclaration NodeInfo -> p -> Maybe (SymbolInformation [CExternalDeclaration NodeInfo]) -> Maybe (SymbolInformation [CExternalDeclaration NodeInfo]) grokSymbol d k msi = let si = fromMaybe symbolInformation msi in Just $ si { symbolLocal = symbolLocal si || not (isHeaderDecl d) , symbolStatic = symbolStatic si || any isStatic (specs d) , symbolSource = d : symbolSource si } update :: CExternalDeclaration NodeInfo -> Transpile [CExternalDeclaration NodeInfo] -> Transpile [CExternalDeclaration NodeInfo] update d transpile = transpile { syms = foldr (\k m -> Map.alter (grokSymbol d k) k m) (syms transpile) $ map (maybe "" identToString) $ sym d } data FunctionSignature t = FunctionSignature { funReturnType :: t , funArgTypes :: [t] } hsMkName :: String -> HS.QName () hsMkName str = HS.UnQual () (foo () str) where foo = HS.Ident -- alternative: HS.Symbol notKnown :: String -> Bool 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 "Word" = False notKnown "Int" = False notKnown "Char" = False notKnown "()" = False notKnown _ = True hsTypeSpec :: CDeclarationSpecifier t -> [Either Ident String] hsTypeSpec (CTypeSpec (CVoidType _)) = [ Right "()" ] hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "size_t" _ _) _)) = [ Right "Word"] 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"] hsTypeSpec (CTypeSpec (CCharType _)) = [ Right "Char"] hsTypeSpec (CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _)) = maybeToList $ fmap Left mctyp hsTypeSpec (CTypeSpec unhandled) = trace ("hsTypeSpec unhandled: "++ show (const () <$> unhandled)) $ [] 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 -> [CDeclarator b] -- c variable declarations -> [ ( (String{-field name-}, HS.Type () {- haskell type -}) , Maybe String{- c type -})] hsTransField ctyps vars = do (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 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 () 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 _) -> map fst $ 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 = maybe ("_") identToString mfident [ ( ( fieldName, ftyp ), mcname ) ] {- transField (CDecl [CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _)] vars _) | Just typname <- mkName . capitalize . identToString <$> mctyp = do (var,Nothing,Nothing) <- vars CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var let fieldName = mkName $ identToString fident ftyp = case ptrdeclr of [] -> ConT typname [CPtrDeclr [] _] -> AppT (ConT (mkName "Ptr")) (ConT typname) [ (fieldName, Bang NoSourceUnpackedness NoSourceStrictness, ftyp) ] hsTransField _ _ = [] -} extractType :: Decl () -> HS.Type () 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] -> [(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 ]) $ map fst $ hsTransField rs as 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" getPtrType :: HS.Type l -> Maybe (HS.Type l) getPtrType (HS.TyApp _ (HS.TyCon _ (HS.UnQual _ (HS.Ident _ "Ptr"))) x) = Just x getPtrType _ = Nothing -- pointers :: [HS.Decl ()] -> [String] pointers :: [HS.Type l] -> [HS.Type l] 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 -> [HS.Decl ()] sig = sigf hsTransFieldExt -- • 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 :: CExternalDeclaration a -> Maybe (CStatement a) body0 (CFDefExt (CFunDef rs cdeclr [] bdy _)) = Just bdy body0 _ = Nothing body :: CExternalDeclaration a -> [CCompoundBlockItem a] body (CFDefExt (CFunDef rs cdeclr [] (CCompound [] bdy _) _)) = bdy body _ = [] data SideEffect = PointerWrite | FunctionCall calls :: Data t => t -> [CExpression NodeInfo] calls = everything (++) (mkQ [] (\case { cc@C.CCall {} -> [cc] ; _ -> [] })) mutations1 :: CExpression a -> [CExpression a] mutations1 e@(CAssign {}) = [e] mutations1 e@(CUnary CPreIncOp _ _) = [e] mutations1 e@(CUnary CPreDecOp _ _) = [e] mutations1 e@(CUnary CPostIncOp _ _) = [e] mutations1 e@(CUnary CPostDecOp _ _) = [e] mutations1 _ = [] mutations :: Data t => t -> [CExpression NodeInfo] mutations = everything (++) (mkQ [] mutations1) -- gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b) -> (forall g. g -> c g) -> a -> c a -- -- gfoldl app con -- -- does is to turn such a value into -- -- con C `app` x_1 `app` x_2 ... `app` x_n commented :: String -> String commented s = unlines $ map ("-- " ++) (lines s) data C2HaskellOptions = C2HaskellOptions { oSelectFunction :: Maybe String , oPrettyC :: Bool , oPrettyTree :: Bool , oVerbose :: Bool , oPreprocess :: Bool , oTranspile :: Bool } defopts :: C2HaskellOptions defopts = C2HaskellOptions { oSelectFunction = Nothing , oPrettyC = False , oPrettyTree = False , oVerbose = False , oPreprocess = False , oTranspile = False } parseOptions :: [String] -> C2HaskellOptions -> C2HaskellOptions 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)] 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 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))] isAcceptableImport :: HS.Type l -> Bool 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 (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.Type l -> HS.Type l 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 enumCases :: CExternalDeclaration a -> [(a, [(Ident, Maybe (CExpression a))])] enumCases (CDeclExt (CDecl xs _ ni)) = do CTypeSpec (CEnumType (CEnum _ (Just cs) _ _) _) <- xs return (ni,cs) lineOfComment (l,_,s) = l + length (lines s) seekComment :: NodeInfo -> [(Int,Int,String)] -> ([(Int,Int,String)],[(Int,Int,String)]) 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 () 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 oSelectFunction opts of Nothing -> do createDirectoryIfMissing False "MonkeyPatch" let fname = ("MonkeyPatch/" ++ modname ++ ".hs") basename f = case break (=='.') $ takeWhile (/='/') $ reverse f of (ext,_:rname) -> reverse rname (rname,_) -> reverse rname modname = capitalize $ basename cmodname stubsname = "MonkeyPatch/" ++ modname ++ "_patch.c" putStrLn $ "writing " ++ fname withFile fname WriteMode $ \haskmod -> do hPutStrLn haskmod "{-# LANGUAGE PatternSynonyms #-}" hPutStrLn haskmod $ "module MonkeyPatch." ++ modname ++" where" hPutStrLn haskmod $ "import Foreign.C.Types" hPutStrLn haskmod $ "import Foreign.Ptr" hPutStrLn haskmod $ "import Data.Word" 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 hPutStrLn haskmod "" forM_ (uniq $ ts ++ sigs2) $ \(t,ct) -> do case ct >>= (`Map.lookup` syms db) of Just si -> case take 1 (symbolSource si) >>= enumCases of [] -> hPutStrLn haskmod $ "data " ++ t (eni,es):_ -> 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 let (_,cs') = seekComment eni cs forM_ (take 1 cs') $ \(_,c,s) -> when (c==1) $ hPutStr haskmod $ commented $ "| " ++ strip s hPutStrLn haskmod $ unwords ["newtype",t,"=",t,"CInt"] forM_ (zip es [0..]) $ \((e,_),n) -> do let r = posRow . posOfNode . nodeInfo $ e case seekComment (nodeInfo e) cs' of (_,(lno,cno,s):_) | lno==r-1 && cno==1 || cno>1 && lno == r -> hPutStr haskmod $ commented $ "| " ++ strip s (_,_:(lno,cno,s):_) | lno==r-1 && cno==1 || cno>1 && lno == r -> hPutStr haskmod $ commented $ "| " ++ strip s (cs,_) | (lno,cno,s):_ <- reverse $ cs , lno==r-1 && cno==1 || cno>1 && lno == r -> hPutStr haskmod $ commented $ "| " ++ strip s x -> hPutStr haskmod $ commented $ "x="++show x hPutStrLn haskmod $ unwords ["pattern",identToString e,"=",t,show n] Nothing -> hPutStrLn haskmod $ "data " ++ t hPutStrLn haskmod "" 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 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)) -- putStr $ commented (show $ pretty d) let typ = (TyCon () (Special () (UnitCon ()))) -- when (null $ sig d) $ putStr $ commented (ppShow (fmap (const ()) d)) forM_ (sig d) $ \hs -> case hs of htyp -> -- putStr $ commented $ "Unsupported haskell type: " ++ HS.prettyPrint htyp -} let htyp = makeFunctionUseIO $ extractType hdecl hPutStrLn haskmod $ (if isAcceptableImport htyp then id else commented) $ HS.prettyPrint $ (HS.ForImp () (HS.CCall ()) Nothing (Just k) (HS.Ident () k) htyp) forM_ missings $ \sym -> goMissing haskmod db sym {- forM_ (Map.lookup sym $ syms db) $ \si -> do 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)) -- putStr $ commented (show $ pretty d) let typ = (TyCon () (Special () (UnitCon ()))) -- when (null $ sig d) $ putStr $ commented (ppShow (fmap (const ()) d)) forM_ (sig d) $ \htyp -> do putStrLn $ HS.prettyPrint htyp -- mapM_ (putStrLn . HS.prettyPrint) (sig d) {- forM_ (body d) $ \stmt -> do putStr $ commented (take 130 $ show (fmap (const ()) stmt)) putStr $ commented (ppShow (fmap (const ()) stmt)) putStrLn $ commented . show . pretty $ stmt putStr $ commented "calls" mapM_ (putStr . commented . show . pretty) (calls (body d)) putStrLn "--" putStr $ commented "mutations" mapM_ (putStr . commented . show . pretty) (mutations (body d)) -} -} putStrLn $ "writing " ++ stubsname withFile stubsname WriteMode $ \stubsfile -> do {- forM_ missings $ \sym -> forM_ (Map.lookup sym$ syms db) $ \si -> do forM_ (take 1 $ symbolSource si) $ \d -> do hPutStrLn stubsfile $ show $ pretty $ makeFunctionPointer d hPutStrLn stubsfile $ show $ pretty $ makeSetter d hPutStrLn stubsfile $ show $ pretty $ makeStub d -} -- mkNodeInfo :: Position -> Name -> NodeInfo let decls = map (setPos $ initPos stubsname) $ do sym <- missings si <- maybeToList $ Map.lookup sym (syms db) d <- take 1 $ symbolSource si [ makeFunctionPointer d, makeSetter d, makeStub d] ns = listify (mkQ False (\ni -> let _ = ni :: C.NodeInfo in True)) decls :: [C.NodeInfo] headerOfNode n = do f <- fileOfNode n case includeTopLevel incs f of "" -> Nothing h -> Just h is = uniq $ mapMaybe headerOfNode ns hPutStrLn stubsfile "#include " hPutStrLn stubsfile $ concatMap (\i -> "#include " ++ i ++ "\n") is hPutStrLn stubsfile $ show $ pretty $ CTranslUnit decls undefNode 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 putStrLn $ show $ pretty $ makeStub d putStrLn $ ppShow $ everywhere (mkT eraseNodeInfo) d -- <$> makeFunctionPointer d -- TODO: make idempotent makeStatic :: [CDeclarationSpecifier NodeInfo] -> [CDeclarationSpecifier NodeInfo] makeStatic xs = CStorageSpec (CStatic undefNode) : xs -- makeStatic xs = CStorageSpec (CStatic ()) : xs makePointer1 :: Maybe (CDeclarator NodeInfo) -> Maybe (CDeclarator NodeInfo) makePointer1 (Just (CDeclr a bs c d e)) = (Just (CDeclr a (p:bs) c d e)) where p = CPtrDeclr [] undefNode -- p = CPtrDeclr [] () makePointer :: [(Maybe (CDeclarator NodeInfo), b, c)] -> [(Maybe (CDeclarator NodeInfo), b, c)] makePointer ((a,b,c):zs) = (makePointer1 a,b,c):zs setNull1 :: Maybe (CInitializer NodeInfo) setNull1 = Just (CInitExpr (CVar (C.Ident "NULL" 0 undefNode) undefNode) undefNode) setNull :: [(a, Maybe (CInitializer NodeInfo), c)] -> [(a, Maybe (CInitializer NodeInfo), c)] setNull ((a,_,b):zs) = (a,setNull1,b):zs makeFunctionPointer :: CExternalDeclaration NodeInfo -> CExternalDeclaration NodeInfo makeFunctionPointer d@(CDeclExt (CDecl xs ys pos)) = changeName ("f_"++) $ CDeclExt (CDecl (makeStatic xs) (setNull $ makePointer ys) pos) makeFunctionPointer d = d changeName2 :: (String -> String) -> Maybe (CDeclarator a) -> Maybe (CDeclarator a) changeName2 f (Just (CDeclr (Just (C.Ident nm n p)) bs c d e)) = (Just (CDeclr (Just (C.Ident (f nm) n p)) bs c d e)) changeName2 f d = d changeName1 :: (String -> String) -> [(Maybe (CDeclarator a), b, c)] -> [(Maybe (CDeclarator a), b, c)] changeName1 f ((a,b,c):zs) = (changeName2 f a,b,c):zs changeName :: (String -> String) -> CExternalDeclaration a -> CExternalDeclaration a changeName f d@(CDeclExt (CDecl xs ys pos)) = CDeclExt (CDecl xs (changeName1 f ys) pos) changeName f d = d makeAcceptableDecl :: Decl () -> Decl () makeAcceptableDecl (HS.TypeDecl a (DHead b (HS.Ident c signame)) ftyp) = (HS.TypeDecl a (DHead b (HS.Ident c signame)) (makeFunctionUseIO $ makeAcceptableImport ftyp)) makeAcceptableDecl (HS.TypeSig a b ftyp) = HS.TypeSig a b (makeFunctionUseIO $ makeAcceptableImport ftyp) makeSetter :: CExternalDeclaration NodeInfo -> CExternalDeclaration NodeInfo makeSetter d = -- @(CDeclExt (CDecl xs ys pos)) = let name = concatMap identToString $ take 1 $ catMaybes $ sym d in setBody (setterBody ("f_"++name)) $ changeReturnValue (const voidReturnType) $ changeArgList (const voidp) $ changeName ("setf_"++) d changeArgList1 :: ([CDerivedDeclarator a] -> [CDerivedDeclarator a]) -> CDeclarator a -> CDeclarator a changeArgList1 f (CDeclr a xs b c d) = CDeclr a (f xs) b c d changeArgList2 :: ([CDerivedDeclarator a] -> [CDerivedDeclarator a]) -> [(Maybe (CDeclarator a), b, c)] -> [(Maybe (CDeclarator a), b, c)] changeArgList2 f ((a,b,c):zs) = (changeArgList3 f a,b,c):zs changeArgList3 :: ([CDerivedDeclarator a] -> [CDerivedDeclarator a]) -> Maybe (CDeclarator a) -> Maybe (CDeclarator a) 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)) setPosOfNode :: Position -> NodeInfo -> NodeInfo setPosOfNode pos n = maybe (mkNodeInfoOnlyPos pos) (mkNodeInfo pos) $ nameOfNode n setPos :: Position -> CExternalDeclaration NodeInfo -> CExternalDeclaration NodeInfo setPos pos (CFDefExt (CFunDef xs ys zs c n)) = (CFDefExt (CFunDef xs ys zs c $ setPosOfNode pos n)) setPos pos (CDeclExt (CDecl xs ys n)) = (CDeclExt (CDecl xs ys $ setPosOfNode pos n)) getArgList1 :: CDeclarator a -> [CDerivedDeclarator a] getArgList1 (CDeclr a xs b c d) = xs getArgList2 :: [(Maybe (CDeclarator a), b, c)] -> [CDerivedDeclarator a] getArgList2 ((a,b,c):zs) = getArgList3 a getArgList3 :: Maybe (CDeclarator a) -> [CDerivedDeclarator 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 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 :: ([CDeclarationSpecifier a] -> [CDeclarationSpecifier a]) -> CExternalDeclaration a -> CExternalDeclaration a 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)) getReturnValue :: CExternalDeclaration a -> [CDeclarationSpecifier a] getReturnValue (CFDefExt (CFunDef xs ys zs c d)) = xs getReturnValue (CDeclExt (CDecl xs ys pos)) = xs voidReturnType :: [CDeclarationSpecifier NodeInfo] voidReturnType = [ CTypeSpec (CVoidType undefNode) ] setBody :: CStatement a -> CExternalDeclaration a -> CExternalDeclaration a 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)) where v = case ys of (Just y,_,_):_ -> y _ -> CDeclr Nothing [] Nothing [] pos makeStub :: CExternalDeclaration NodeInfo -> CExternalDeclaration NodeInfo makeStub d = -- @(CDeclExt (CDecl xs ys pos)) = let rval = case getReturnValue d of [ CTypeSpec (CVoidType _) ] -> False -- void function. _ -> True name = concatMap identToString $ take 1 $ catMaybes $ sym d msg = "undefined: " ++ concatMap (HS.prettyPrint . makeAcceptableDecl) (take 1 $ sig d) ++ "\n" in case getArgList d of oargs:xs -> let (args,vs) = makeParameterNames oargs in setBody (stubBody ("f_"++name) vs rval msg) $ changeArgList (const $ args:xs) d [] -> setBody (stubBody ("f_"++name) [] rval msg) d parameterIdent :: CDeclaration a -> Maybe Ident parameterIdent (CDecl _ xs n) = listToMaybe $ do (Just (CDeclr (Just x) _ _ _ _),_,_) <- xs return x 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 mkp num (CDecl rtyp ((Just (CDeclr Nothing 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 undefNode) [] Nothing [] n),Nothing,Nothing):[]) n) mkp num p = p 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 mkidn :: Show a => a -> NodeInfo -> Ident mkidn num n = C.Ident ("a"++show num) 0 n voidp :: [CDerivedDeclarator NodeInfo] voidp = [ CFunDeclr (Right ( [ CDecl [ CTypeSpec (CVoidType n) ] [ ( Just (CDeclr (Just (C.Ident "p" 0 n)) [ CPtrDeclr [] n ] Nothing [] n) , Nothing , Nothing ) ] n ] , False)) [] n] where n = undefNode stubBody :: String -> [CExpression NodeInfo] -> Bool -> String -> CStatement NodeInfo stubBody name vs rval msg = CCompound [] [ CBlockStmt (CIf (CVar (C.Ident name 0 undefNode) undefNode) (if rval then (CReturn (Just (C.CCall (CVar (C.Ident name 0 undefNode) undefNode) vs undefNode)) undefNode) else (CExpr (Just (C.CCall (CVar (C.Ident name 0 undefNode) undefNode) vs undefNode)) undefNode)) (Just (if rval then CCompound [] [ CBlockStmt printmsg , CBlockStmt (CReturn (Just $ CConst (CIntConst (cInteger 0) undefNode)) undefNode)] undefNode else printmsg)) undefNode) ] undefNode where printmsg = (CExpr (Just (C.CCall (CVar (C.Ident "fputs" 0 undefNode) undefNode) [ CConst (CStrConst (cString msg) undefNode) , CVar (C.Ident "stderr" 0 undefNode) undefNode ] undefNode)) undefNode) setterBody :: String -> CStatement NodeInfo setterBody name = CCompound [] [ CBlockStmt (CExpr (Just (CAssign CAssignOp (CVar (C.Ident name 0 undefNode) undefNode) (CVar (C.Ident "p" 0 undefNode) undefNode) undefNode)) undefNode) ] undefNode 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) $ \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 = 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 let wrapname = "wrap" ++ drop 3 signame settername = "setf" ++ drop 3 signame funptr = (TyApp () (TyCon () (UnQual () (HS.Ident () "FunPtr"))) (TyCon () (UnQual () (HS.Ident () signame)))) -- hPutStrLn haskmod $ ppShow $ HS.parseDecl "foreign import ccall \"wrapper\" fname :: Spec -> IO (FunPtr Spec)" -- mapM_ (hPutStrLn haskmod . HS.prettyPrint) (importWrapper $ sigf hsTransSig d) hPutStrLn haskmod $ HS.prettyPrint $ (HS.ForImp () (HS.CCall ()) Nothing (Just "wrapper") (HS.Ident () wrapname) (TyFun () (TyCon () (UnQual () (HS.Ident () signame))) (TyApp () (TyCon () (UnQual () (HS.Ident () "IO"))) (TyParen () funptr)))) hPutStrLn haskmod $ HS.prettyPrint $ (HS.ForImp () (HS.CCall ()) Nothing (Just settername) (HS.Ident () settername) (TyFun () funptr (TyApp () (TyCon () (UnQual () (HS.Ident () "IO"))) (TyCon () (Special () (UnitCon ())))))) htyp -> hPutStr haskmod $ commented $ "Unsupported haskell type: " ++ HS.prettyPrint htyp readComments :: (Num lin, Num col) => FilePath -> IO [(lin, col, [Char])] readComments fname = parseComments 1 1 <$> readFile fname sanitizeArgs :: [String] -> [String] sanitizeArgs (('-':'M':_):args) = sanitizeArgs args sanitizeArgs (('-':'O':_):args) = sanitizeArgs args sanitizeArgs (('-':'c':_):args) = sanitizeArgs args sanitizeArgs ("-o":args) = sanitizeArgs $ drop 1 args sanitizeArgs (arg:args) = arg : sanitizeArgs args sanitizeArgs [] = [] isModule :: FilePath -> Bool isModule fname = (".c" `isSuffixOf` fname) || (".o" `isSuffixOf` fname) usage :: [String] -> Maybe (C2HaskellOptions, [String], [FilePath]) usage args = case break (=="--") args of (targs,_:cargs0) -> do let (rfs,ropts) = span isModule $ reverse cargs0 opts = reverse ropts cargs = (sanitizeArgs opts) hopts = parseOptions targs defopts return (hopts,cargs,rfs) _ -> Nothing (<&>) :: 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 unquote :: String -> String unquote xs = zipWith const (drop 1 xs) (drop 2 xs) missingSymbols :: String -> [String] missingSymbols s = uniq $ do e <- lines s let (_,us) = break (=="undefined") $ words e if null us then [] else do let q = concat $ take 1 $ reverse us c <- take 1 q guard $ c=='`' || c=='\'' return $ unquote q linker :: [String] -> String -> IO [String] linker cargs fname = do print (cargs,fname) (hin,hout,Just herr,hproc) <- createProcess (proc "gcc" $ cargs ++ [fname]) { std_err = CreatePipe } linkerrs <- hGetContents herr ecode <- waitForProcess hproc case ecode of ExitSuccess -> hPutStrLn stderr $ "Oops: "++fname++" has main() symbol." _ -> return () return $ missingSymbols linkerrs eraseNodeInfo :: NodeInfo -> NodeInfo eraseNodeInfo _ = OnlyPos p (p,0) -- undefNode value doesn't ppShow well. where -- p = nopos -- This is not ppShow friendly. p = position 0 "" 0 0 Nothing newtype IncludeStack = IncludeStack { includes :: Map FilePath [[FilePath]] } deriving Show emptyIncludes :: IncludeStack emptyIncludes = IncludeStack Map.empty openInclude :: FilePath -> [FilePath] -> IncludeStack -> IncludeStack openInclude fname stack (IncludeStack m) = IncludeStack $ Map.alter go fname m where go Nothing = Just [stack] go (Just s) = Just $ stack : s findQuoted :: [Char] -> [Char] findQuoted xs = takeWhile (/='"') $ drop 1 $ dropWhile (/='"') xs includeStack :: B.ByteString -> IncludeStack includeStack bs = foldr go (const emptyIncludes) incs [] where incs = filter (\b -> fmap fst (B.uncons b) == Just '#') $ B.lines bs fp inc = findQuoted $ B.unpack inc -- fno inc = read $ concat $ take 1 $ words $ drop 2 $ B.unpack inc go inc xs stack | "1" `elem` B.words inc = let f = fp inc in openInclude f stack (xs (f : stack)) | "2" `elem` B.words inc = xs (drop 1 stack) | otherwise = xs stack main :: IO () main = do self <- getProgName args <- getArgs let usageString = self ++ " [--cpp | -p | -t ] [-v] [-f ] -- [gcc options] [modules] " let m = usage args fromMaybe (putStrLn usageString) $ m <&> \(hopts,cargs,fname:fs) -> do prer <- runPreprocessor (newGCC "gcc") (rawCppArgs cargs fname) 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) -- putStrLn $ "fname = " ++ fname -- putStrLn $ "includes = " ++ ppShow (fmap fst r) -- cs <- readComments fname case () of _ | 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