{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where import Debug.Trace import Control.Arrow (first, left, second) import Control.Monad.Trans.State.Lazy import Data.Bool 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 qualified Data.IntMap as IntMap ;import Data.IntMap (IntMap) import Data.List import qualified Data.Map as Map ;import Data.Map (Map) import Data.Maybe import Data.Ord import qualified Data.Set as Set ;import Data.Set (Set) import qualified Language.C as C ;import Language.C as C hiding (prettyUsingInclude) import Language.C.Data.Ident as C import Language.C.Data.Node as C import Language.C.Data.Position import Language.C.System.GCC import Language.C.System.Preprocess 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.Exit import System.IO import System.Process import Text.PrettyPrint (Doc, doubleQuotes, empty, text, vcat, ($$), (<+>)) import Text.Show.Pretty import Sweeten import GrepNested import Unique {- trace :: p -> a -> a 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 mb :: Functor m => m a -> StateT t m a mb m = StateT $ \s -> fmap (, s) m 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 () , compContinue :: Maybe String -- ^ The identifier name currently used to indicate the "continue;" -- statement. , comp :: st } deriving (Eq,Ord,Functor) instance Applicative Computation where pure = mkcomp mf <*> ma = Computation { compFree = Map.union (compFree mf) (compFree ma) , compIntro = Map.union (compIntro mf) (compIntro ma) , compContinue = (if isJust (compContinue mf) && isJust (compContinue ma) then trace "Warning: incompatible continue symbols." else id) $ mplus (compContinue mf) (compContinue ma) , comp = comp mf $ comp ma } mkcomp :: x -> Computation x mkcomp x = Computation Map.empty Map.empty Nothing x hsvar :: String -> HS.Exp () hsvar v = Var () (UnQual () (HS.Ident () v)) hspvar :: String -> HS.Pat () hspvar v = PVar () (HS.Ident () v) cvarName :: CExpression a -> Maybe String cvarName (CVar (C.Ident n _ _) _) = Just n cvarName _ = Nothing retUnit :: HS.Exp () retUnit = App () (hsvar "return") $ HS.Con () (Special () (UnitCon ())) infixOp :: HS.Exp () -> String -> HS.Exp () -> HS.Exp () infixOp x op y = InfixApp () x (QVarOp () (UnQual () (Symbol () op))) y infixFn :: HS.Exp () -> String -> HS.Exp () -> HS.Exp () infixFn x fn y = InfixApp () x (QVarOp () (UnQual () (HS.Ident () fn))) y data FormalLambda = FormalLambda { formGo :: Unique , formExp :: HS.Exp () } modifyFormal :: (HS.Exp () -> HS.Exp ()) -> FormalLambda -> FormalLambda modifyFormal f (FormalLambda s x) = FormalLambda s (f x) -- modifyLambda f (Lambda l p x) = Lambda l p (f x) modifyOperand1 :: (HS.Exp l -> HS.Exp l) -> HS.Exp l -> HS.Exp l modifyOperand1 f (InfixApp l x op y) = InfixApp l (f x) op y informalize :: FormalLambda -> HS.Exp () informalize (FormalLambda k x) = Lambda () [uniquePattern k] x factorOutFunction :: String -- ^ New function name to factor out. -> [String] -- ^ Arguments to function. -> HS.Exp () -- ^ Body of function. -> HS.Exp () -- ^ Variable name place holder for call sites in template. -> HS.Exp () -- ^ Template containing place-holder call sites. -> HS.Exp () factorOutFunction k vs bdy govar expr = let matchgo v = v==govar subst x | matchgo x = callsite | otherwise = x callsite = foldl (App ()) (hsvar k) $ map hsvar vs pats = map hspvar vs in Let () (BDecls () [FunBind () [HS.Match () (HS.Ident () k) pats (UnGuardedRhs () bdy) Nothing]]) (everywhere (mkT subst) expr) -- Like applyComputation, but creates a let-binding rather than inlining the continuation. multiwayContinuation :: Computation FormalLambda -> Computation (HS.Exp ()) -> Computation (HS.Exp ()) multiwayContinuation a@Computation{ comp = FormalLambda govar exp } b = let k = uniqIdentifier "go" (foldr Map.union Map.empty [compFree a,compIntro a,compFree b,compIntro b]) vs = Map.keys $ compIntro a `Map.intersection` compFree b in Computation { compFree = Map.union (compFree a) (compFree b) Map.\\ compIntro a , compIntro = compIntro a `Map.union` compIntro b , compContinue = Nothing , comp = factorOutFunction k vs (comp b) (uniqueSymbol govar) exp } applyComputation :: Computation FormalLambda -> Computation (HS.Exp ()) -> Computation (HS.Exp ()) applyComputation a@Computation{ comp = FormalLambda govar exp } b = let matchgo v = v==uniqueSymbol govar in case listify matchgo exp of (_:_:_) -> multiwayContinuation a b _ -> Computation { compFree = Map.union (compFree a) (compFree b) Map.\\ compIntro a , compIntro = compIntro a `Map.union` compIntro b , compContinue = Nothing , comp = let subst x | matchgo x = comp b | otherwise = x in everywhere (mkT subst) exp } varmap :: [String] -> Map String () varmap vs = Map.fromList $ map (,()) vs {- CUnary CAdrOp (CVar _ _) LT) LT CCall (CVar i _) exps _ -} renameIntros :: forall v st a. (Typeable st, Data st) => [Computation FormalLambda] -> Computation (HS.Exp st) -> Map String v -> ([Computation FormalLambda], Computation (HS.Exp st)) renameIntros bs cb vs = (bs',cb') where (rs,bs') = unzip $ map go bs cb' = foldr rename2 cb $ concat rs rename2 (x,v) c = let subst p@(Var la (UnQual lc (HS.Ident lb s))) | s==x = Var (la::st) (UnQual lc (HS.Ident lb v)) subst p = p in c { comp = everywhere (mkT subst) (comp c) } go c = let xs = Map.keys (compIntro c) in foldr rename1 ([],c) xs rename1 x (rs,c) = let v = uniqIdentifier x vs subst p@(PVar la (HS.Ident lb s)) | s==x = PVar (la::st) (HS.Ident lb v) subst p = p in if x/=v then (,) ((x,v):rs) c { compIntro = Map.insert v () $ Map.delete x (compIntro c) , comp = (comp c) { formExp = everywhere (mkT subst) (formExp $ comp c) } } else (rs,c) transpileBinOp :: CBinaryOp -> [Char] transpileBinOp = \case CMulOp -> "*" CDivOp -> "/" CRmdOp -> "rem" CAddOp -> "+" CSubOp -> "-" CShlOp -> "shiftL" CShrOp -> "shiftR" CLeOp -> "<" CGrOp -> ">" CLeqOp -> "<=" CGeqOp -> ">=" CEqOp -> "==" CNeqOp -> "/=" CAndOp -> ".&." CXorOp -> "xor" COrOp -> ".|." CLndOp -> "&&" CLorOp -> "||" -- This function decides whether to treat an identifier as a constant or as a -- pointer that must be peeked. isGlobalRef :: FunctionEnvironment -> String -> Bool isGlobalRef fe sym = fromMaybe False $ do SymbolInformation{symbolSource = xs} <- Map.lookup sym (fnExternals fe) forM_ xs $ \x -> do -- Pattern fail for functions and pointers. forM_ (sigf (\_ ds -> ds) x) $ \d -> do CDeclr _ xs _ _ _ <- Just d let func = filter (\case CFunDeclr _ _ _ -> True _ -> False) xs guard $ null func -- Functions are not pointerized. -- trace (sym ++ ": " ++ show xs) $ return () -- ring: [CPtrDeclr [] (NodeInfo ("fetchers/about.c": line 64) (("fetchers/about.c": line 64),4) (Name {nameId = 14030}))] return () return True -- Returns a list of statements bringing variables into scope and an -- expression. grokExpression :: FunctionEnvironment -> CExpression a -> StateT UniqueFactory Maybe ([Computation FormalLambda], Computation (HS.Exp ())) grokExpression fe (CVar cv _) = do let v = identToString cv if isGlobalRef fe v then do k <- StateT $ return . genUnique let s = Computation { compFree = Map.singleton v () , compIntro = Map.singleton hv () , compContinue = Nothing , comp = FormalLambda k $ infixOp (App () (hsvar "peek") (hsvar v)) ">>=" $ Lambda () [hspvar hv] (uniqueSymbol k) } hv = "v" ++ v return $ (,) [s] (mkcomp $ hsvar hv) { compFree = Map.singleton hv () } else return $ (,) [] $ (mkcomp $ hsvar v) { compFree = Map.singleton (identToString cv) () } grokExpression fe (CConst (CIntConst n _)) = return $ (,) [] $ mkcomp $ Lit () (Int () (getCInteger n) (show n)) grokExpression fe (CConst (CStrConst s _)) = return $ (,) [] $ mkcomp $ Lit () (HS.String () (getCString s) (getCString s)) grokExpression fe (CBinary op a b _) = do (as,ca) <- grokExpression fe a (bs0,cb0) <- grokExpression fe b let (bs,cb) = renameIntros bs0 cb0 (foldr Map.union Map.empty $ map compIntro as) ss = as ++ bs hop = transpileBinOp op infx | isLower (head hop) = infixFn | otherwise = infixOp -- trace ("intros("++hop++"): "++show (foldr Map.union Map.empty $ map compIntro as)) $ return () -- TODO: Short-circuit boolean evaluation side-effects. return $ (,) ss $ infx <$> ca <*> pure hop <*> cb grokExpression fe (CUnary CAdrOp (CVar cv0 _) _) = do k <- StateT $ return . genUnique let cv = identToString cv0 hv = "p" ++ cv ss = pure Computation { compFree = Map.singleton cv () , compIntro = Map.singleton hv () , compContinue = Nothing , comp = FormalLambda k $ infixFn (hsvar cv) "withPointer" (Lambda () [hspvar hv] (uniqueSymbol k)) } return $ (,) ss (mkcomp $ hsvar hv) { compFree = Map.singleton hv () } grokExpression fe (CCond cond (Just thn) els _) = do (cs,c) <- grokExpression fe cond (ts,t) <- grokExpression fe thn (es,e) <- grokExpression fe els let tt = foldr applyComputation t ts ee = foldr applyComputation e es return $ (,) cs $ If () <$> c <*> tt <*> ee grokExpression fe (CSizeofExpr expr _) = do (xs,x) <- grokExpression fe expr return $ (,) xs $ fmap (App () (hsvar "sizeOf")) x grokExpression fe (CCast (CDecl [CTypeSpec (CVoidType _)] [] _) expr _) = (grokExpression fe) expr grokExpression fe (CCast (CDecl [ CTypeSpec (CVoidType _) ] [ ( Just (CDeclr Nothing [ CPtrDeclr [] _ ] Nothing [] _) , Nothing , Nothing) ] _) (CConst (CIntConst zero _)) _) | 0 <- getCInteger zero = do return $ (,) [] (mkcomp $ hsvar "nullPtr") { compFree = Map.singleton "nullPtr" () } grokExpression fe (CComma exps _) = do gs <- mapM (grokExpression fe) exps let gs2 = map (\(ss,x) -> foldr applyComputation (App () (hsvar "return") <$> x) ss) gs parn e = Paren () e ps <- mapM (\x -> do k <- StateT $ return . genUnique return $ fmap (\xx -> FormalLambda k (infixOp (parn xx) ">>" (uniqueSymbol k))) x) (init gs2) let s = foldr applyComputation (last gs2) ps hv = "u" k <- StateT $ return . genUnique let s' = fmap (\x -> FormalLambda k (infixOp (parn x) ">>=" (Lambda () [hspvar hv] (uniqueSymbol k)))) s -- TODO: It would be cleaner if I could return only a statement and not an expression. return $ (,) [s'] (mkcomp $ hsvar hv) { compFree = Map.singleton hv () } grokExpression fe (C.CCall fn exps u) = grokCall fe True (C.CCall fn exps u) grokExpression fe (CStatExpr (CCompound idents xs _) _) = do let (y,ys) = splitAt 1 (reverse xs) y' <- case y of [CBlockStmt (CExpr mexp ni)] -> return $ CBlockStmt (CReturn mexp ni) _ -> return (head y) -- Nothing FIXME gs <- mapM (grokStatement fe) (reverse $ y' : ys) let s0 = foldr applyComputation (mkcomp retUnit) gs s1 = fmap (\xp -> Paren () xp) s0 hv = uniqIdentifier "ret" (compFree s1) k <- StateT $ return . genUnique let s = Computation { compFree = compFree s1 , compIntro = Map.singleton hv () , compContinue = Nothing , comp = FormalLambda k $ infixOp (comp s1) ">>=" $ Lambda () [hspvar hv] (uniqueSymbol k) } return $ (,) [s] (mkcomp $ hsvar hv) { compFree = Map.singleton hv () } grokExpression fe (CAssign CAssignOp cvar expr _) = do v <- mb $ cvarName cvar (ss,x) <- grokExpression fe expr k <- StateT $ return . genUnique let s = x { compIntro = Map.singleton v () , comp = FormalLambda k $ infixOp (App () (hsvar "return") (comp x)) ">>=" $ Lambda () [hspvar v] (uniqueSymbol k) } return $ (,) (ss ++ [s]) $ mkcomp (hsvar v) grokExpression fe (CMember cvar fld isptr _) = do v <- mb $ cvarName cvar let fieldlbl = identToString fld hv = v ++ fieldlbl e = App () (App () (hsvar "get") (TypeApp () (TyPromoted () (PromotedString () fieldlbl fieldlbl)))) (hsvar v) e' = (mkcomp e){ compFree = Map.singleton v () } k <- StateT $ return . genUnique let s = (FormalLambda k <$> fmap (($ Lambda () [hspvar hv] (uniqueSymbol k)) . (`infixOp` ">>=")) e') { compIntro = Map.singleton hv () } return $ (,) [s] (mkcomp $ hsvar hv){ compFree = Map.singleton hv () } grokExpression fe _ = mzero grokCall :: FunctionEnvironment -> Bool -> CExpression a -> StateT UniqueFactory Maybe ([Computation FormalLambda], Computation (HS.Exp ())) grokCall fe wantsRet (C.CCall (CVar fn _) exps _) = do gs <- mapM (grokExpression fe) 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) fn' = identToString fn cll = foldl (\f x -> App () <$> f <*> x) (mkcomp $ hsvar fn'){compFree = Map.singleton fn' ()} (map snd gs) k <- StateT $ return . genUnique let s | wantsRet = (fmap (\c -> FormalLambda k $ infixOp c ">>=" $ Lambda () [hspvar hv] (uniqueSymbol k)) cll) { compIntro = Map.singleton hv () } | otherwise = fmap (\c -> FormalLambda k $ infixOp c ">>" (uniqueSymbol k)) cll return $ (,) (ss++[s]) (mkcomp $ hsvar hv) { compFree = Map.singleton hv () } grokCall fe wantsRet (C.CCall fnx@(CMember cvar fld isptr _) exps _) = do -- We're calling a FunPtr so a "dynamic" import will need to be declared. -- We'll assume that a dynCall type class method points to it. -- fun <- dynCall <$> get @fld cvar -- fun arg1 arg2 ... (fss,fn) <- grokExpression fe fnx let getfn = case reverse fss of fnst:fs -> reverse $ (modifyFormal (modifyOperand1 $ infixOp (hsvar "callDyn") "<$>") <$> fnst) : fs [] -> [] gs <- mapM (grokExpression fe) exps let ss = getfn ++ concatMap fst gs -- TODO: resolve variable name conflicts hv = "r" ++ fn' -- cll = foldl (App ()) (hsvar (identToString fn)) $ map (comp . snd) gs -- frees = foldr Map.union (Map.singleton (identToString fn) ()) (map (compFree . snd) gs) fn' = concat (Map.keys $ compFree fn) cll = foldl (\f x -> App () <$> f <*> x) fn (map snd gs) k <- StateT $ return . genUnique let s | wantsRet = (fmap (\c -> FormalLambda k $ infixOp c ">>=" $ Lambda () [hspvar hv] (uniqueSymbol k)) cll) { compIntro = Map.singleton hv () } | otherwise = fmap (\c -> FormalLambda k $ infixOp c ">>" (uniqueSymbol k)) cll return $ (,) (ss++[s]) (mkcomp $ hsvar hv) { compFree = Map.singleton hv () } grokCall _ _ _ = mzero grokInitialization :: Foldable t1 => FunctionEnvironment -> t1 (CDeclarationSpecifier t2) -> (Maybe (CDeclarator a1), CInitializer a2) -> StateT UniqueFactory Maybe (Computation FormalLambda) grokInitialization fe _ (Just (CDeclr (Just cv0) _ _ _ _),CInitExpr exp _) = do let v = identToString cv0 (xs,x) <- grokExpression fe exp let hsexp = fmap (App () (hsvar "return")) x -- Paren () ( k <- StateT $ return . genUnique let ret = flip (foldr applyComputation) xs $ fmap (\exp -> infixOp exp ">>=" $ Lambda () [hspvar v] (uniqueSymbol k)) hsexp return $ fmap (FormalLambda k) ret grokInitialization fe 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 fe) ie >>= \g -> return (ms,g) _ -> mzero assigns <- forM gs $ \(ms,(ss,x)) -> do k2 <- StateT $ return . genUnique cs <- forM (mapMaybe (\case { CMemberDesig m _ -> Just m ; _ -> Nothing}) ms) $ \m -> do k1 <- StateT $ return . genUnique let fieldinit = comp x fieldlbl = identToString m return x { comp = FormalLambda k1 $ infixOp (App () (App () (App () (hsvar "set") (TypeApp () (TyPromoted () (PromotedString () fieldlbl fieldlbl)))) (hsvar v)) fieldinit) ">>" (uniqueSymbol k1) } let ret = foldr applyComputation (mkcomp $ uniqueSymbol k2) (ss ++ cs) return $ fmap (FormalLambda k2) ret k <- StateT $ return . genUnique let newstruct = Computation { compFree = Map.empty -- todo , compIntro = Map.singleton v () , compContinue = Nothing , comp = FormalLambda k $ infixOp (App () (hsvar "newStruct") (TypeApp () (TyCon () (UnQual () hident)))) ">>=" $ Lambda () [hspvar v] (uniqueSymbol k) } ret = foldr applyComputation (mkcomp $ uniqueSymbol k) $ newstruct : assigns return $ fmap (FormalLambda k) ret _ -> mzero grokInitialization _ _ _ = mzero hasBool :: HS.Type () -> Bool hasBool = (1 <=) . gcount (mkQ False (\t -> case t of { HS.Ident () "Bool" -> True; _ -> False })) promote :: Map String (HS.Type ()) -> HS.Exp () -> HS.Exp () promote fe y@(Lit () (Int () n _)) | (n==0 || n==1) && hasBool (fe Map.! "") = HS.Con () $ UnQual () $ HS.Ident () $ case n of 0 -> "False" 1 -> "True" promote _ y = y grokStatement :: FunctionEnvironment -> CCompoundBlockItem a -> StateT UniqueFactory Maybe (Computation FormalLambda) grokStatement fe (CBlockStmt (CReturn (Just exp) _)) = do (xs,x) <- grokExpression fe exp k <- StateT $ return . genUnique let x' = fmap (\y -> App () (hsvar "return") $ promote (fnArgs fe) y) x return $ fmap (\y -> FormalLambda k y) $ foldr applyComputation x' xs grokStatement fe (CBlockStmt (CReturn Nothing _)) = do k <- StateT $ return . genUnique return $ mkcomp $ FormalLambda k retUnit grokStatement fe (CBlockStmt (CCont _)) = do k <- StateT $ return . genUnique return (mkcomp $ FormalLambda k $ hsvar " continue") { compContinue = Just " continue" } grokStatement fe (CBlockStmt (CIf exp thn els _)) = do (xs,x) <- grokExpression fe exp let mkif0 = If () (comp x) (mkif,stmts) <- case (thn,els) of (CCompound [] stmts _, Nothing ) -> return (mkif0, stmts) (stmt , Nothing ) -> return (mkif0, [CBlockStmt stmt]) (CCompound [] stmts _, Just (CExpr Nothing _) ) -> return (mkif0, stmts) (CCompound [] stmts _, Just (CCompound [] [ CBlockStmt (CExpr Nothing _) ] _)) -> return (mkif0, stmts) (CExpr Nothing _ ,Just (CCompound [] stmts _)) -> return (flip mkif0, stmts) (CCompound [] [CBlockStmt (CExpr Nothing _)] _,Just (CCompound [] stmts _)) -> return (flip mkif0, stmts) (CExpr Nothing _ ,Just e@(CExpr (Just _) _)) -> return (flip mkif0, [CBlockStmt e]) (CCompound [] [CBlockStmt (CExpr Nothing _)] _,Just e@(CExpr (Just _) _)) -> return (flip mkif0, [CBlockStmt e]) _ -> trace ("Unhandled if: "++show (fmap (const LT) thn)) $ mzero -- TODO ss <- sequence $ map (grokStatement fe) stmts k <- StateT $ return . genUnique let s = foldr applyComputation (mkcomp $ uniqueSymbol k) ss return $ fmap (FormalLambda k) $ flip (foldr applyComputation) xs Computation { compFree = compFree x `Map.union` compFree s , compIntro = compIntro s , compContinue = Nothing , comp = mkif (comp s) (uniqueSymbol k) } grokStatement fe (CBlockStmt (CExpr (Just (C.CCall (CVar (C.Ident "__assert_fail" _ _) _) xs _)) _)) = do x <- case xs of (CConst (CStrConst msg _):_) -> let s = getCString msg in return $ mkcomp $ Lit () (HS.String () s s) _ -> mzero k <- StateT $ return . genUnique let x' = fmap (\y -> App () (hsvar "error") y) x return $ fmap (FormalLambda k) x' grokStatement fe (CBlockStmt (CExpr (Just (CAssign CAssignOp (CMember cvar fld isptr _) expr _)) _)) = do (xs,x) <- grokExpression fe expr v <- mb $ cvarName cvar k1 <- StateT $ return . genUnique let fieldlbl = identToString fld fieldinit = comp x x' = x { comp = infixOp (App () (App () (App () (hsvar "set") (TypeApp () (TyPromoted () (PromotedString () fieldlbl fieldlbl)))) (hsvar v)) fieldinit) ">>" (uniqueSymbol k1) } return $ fmap (FormalLambda k1) $ foldr applyComputation x' xs grokStatement fe (CBlockStmt (CExpr (Just (C.CCall cvarfun exps a)) _)) = do -- This case is technically not needed, but it makes slightly cleaner output -- by avoiding a bind operation. (ss,_) <- grokCall fe False (C.CCall cvarfun exps a) k <- StateT $ return . genUnique let r = FormalLambda k <$> foldr applyComputation (mkcomp $ uniqueSymbol k) ss return r grokStatement fe (CBlockStmt (CExpr (Just (CAssign CAssignOp cvarnew (C.CCall cvarfun [] _) _)) _)) = do v <- mb $ cvarName cvarnew fn <- mb $ cvarName cvarfun k <- StateT $ return . genUnique return Computation { compFree = Map.singleton fn () , compIntro = Map.singleton v () , compContinue = Nothing , comp = FormalLambda k $ infixOp (hsvar fn) ">>=" $ Lambda () [hspvar v] (uniqueSymbol k) } grokStatement fe (CBlockStmt (CExpr (Just (CUnary CPostIncOp (CMember (CVar cv0 _) fld True _) _)) _)) = do k1 <- StateT $ return . genUnique let fieldlbl = identToString fld v = identToString cv0 return Computation { compFree = varmap [v] , compIntro = Map.empty , compContinue = Nothing , comp = FormalLambda k1 $ infixOp (App () (App () (App () (hsvar "modify") (TypeApp () (TyPromoted () (PromotedString () fieldlbl fieldlbl)))) (hsvar v)) (hsvar "succ")) ">>" (uniqueSymbol k1) } grokStatement fe (CBlockStmt (CExpr mexpr _)) = do -- trace ("CExpr statement: " ++ take 50 (show $ fmap (fmap $ const ()) mexpr)) $ return () (ss,pre) <- maybe (return $ (,) [] $ mkcomp id) (let -- Discard pure value since we are interested only in side-effects. discard = const $ mkcomp id -- Alternate: keep pure-value using `seq` operator. -- keep = fmap (\e -> infixFn e "seq") in (fmap (second discard) . grokExpression fe)) mexpr k <- StateT $ return . genUnique let s = foldr applyComputation (fmap ($ uniqueSymbol k) pre) ss return $ fmap (FormalLambda k) s grokStatement fe (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 k <- StateT $ return . genUnique case mapMaybe (\(i,inits,_) -> fmap ((,) i) inits) (v:vs) of [] -> return $ mkcomp $ FormalLambda k (uniqueSymbol k) initials -> do gs <- mapM (grokInitialization fe $ t:ts) initials k <- StateT $ return . genUnique return $ fmap (FormalLambda k) $ foldr applyComputation (mkcomp $ uniqueSymbol k) gs grokStatement fe (CBlockStmt (CWhile cond (CCompound [] bdy _) isDoWhile _)) = do gs <- mapM (grokStatement fe) bdy (ss,c) <- grokExpression fe cond let g = foldr applyComputation cnt gs -- body of loop cnt = mkcomp $ hsvar " continue" -- k = uniqIdentifier "go" (compFree g `Map.union` compIntro g) loopcall = foldl (App ()) (hsvar "loop") $ map hsvar vs -- c' = fmap (\cnd -> App () (App () (hsvar "when") cnd) (Paren () loopcall)) c c' = fmap (\cnd -> If () cnd (Paren () loopcall) (hsvar "fin")) c x = foldr applyComputation c' ss -- continue function vs = [] -- Map.keys $ compIntro g fin <- StateT $ return . genUnique return $ fmap (FormalLambda fin . factorOutFunction "continue" vs (comp x) (hsvar " continue")) g grokStatement fe _ = mzero isFunctionDecl :: CExternalDeclaration a -> Bool isFunctionDecl (CDeclExt (CDecl _ [(Just (CDeclr _ [CFunDeclr _ _ _] _ _ _),_,_)] _)) = True isFunctionDecl (CFDefExt (CFunDef _ _ _ (CCompound [] _ _) _)) = True isFunctionDecl _ = False cleanTree :: (Functor f, Data (f b)) => f b -> f Ordering cleanTree d = fmap (const LT) $ everywhere (mkT eraseNodeInfo) $ d data SymbolExtent = SymbolExtent { startExtent :: Position, stopExtent :: Position } instance Show SymbolExtent where show (SymbolExtent a b) = "sed -n "++show al++","++show bl++"p "++fn where fn = posFile a al = posRow a bl = posRow b getSymbolExtent :: (CNode a1, Data a2) => SymbolInformation a2 -- ^ Symbol database record (symbolSource must have Postion data in it). -> [a1] -- ^ function body (only used for filename) -> SymbolExtent getSymbolExtent sym bdy = -- TODO: This could probably be a lot more efficient using NodeInfo's PosLength field. let bdy_poss = map (posOfNode . nodeInfo) bdy -- hpos = map (posOfNode . nodeInfo) (symbolSource sym) cmodule = map posFile (take 1 $ filter isSourcePos $ bdy_poss) -- TODO: What if first statement is provided by macro? allposss = listify (\p -> case cmodule of { [f] | isSourcePos p -> posFile p == f ; _ -> isSourcePos p }) (symbolSource sym) :: [Position] start = minimumBy (comparing posRow) allposss stop = maximumBy (comparing posRow) allposss in SymbolExtent start stop lastRowOf :: CNode a => a -> Int lastRowOf x = case getLastTokenPos $ nodeInfo x of (p,len) | isSourcePos p -> posRow p + len _ -> maxBound firstRowOf :: CNode a => a -> Int firstRowOf x = case posOfNode $ nodeInfo x of p | isSourcePos p -> posRow p _ -> minBound columnOf :: CNode a => a -> Int columnOf x = case posOfNode $ nodeInfo x of p | isSourcePos p -> posColumn p _ -> minBound comesBefore :: CNode a => a -> StyledComment -> Bool comesBefore x c = lastRowOf x < commentRow c comesAfter :: CNode a => a -> StyledComment -> Bool comesAfter x c = firstRowOf x > commentRow c insertComment :: Data t => StyledComment -> t -> t insertComment c stmts = everywhere (mkT go) stmts where go :: [CCompoundBlockItem NodeInfo] -> [CCompoundBlockItem NodeInfo] go xs = case span (\a -> comesBefore a c) xs of (a:as,b:bs) | b `comesAfter` c -> a:as ++ mkst c ++ b:bs ([],b:bs) | commentRow c + 1 == firstRowOf b -> mkst c ++ b : bs (as,[]) | (y:ys) <- reverse as, lastRowOf y + 1 == commentRow c -> as ++ mkst c _ -> xs mkst c = let x = rewriteComment c in [CBlockStmt (CExpr (Just x) $ nodeInfo x)] mixComments :: [StyledComment] -> [CCompoundBlockItem NodeInfo] -> [CCompoundBlockItem NodeInfo] mixComments cs stmts = foldr insertComment stmts cs applyDoSyntax' :: Data l => C2HaskellOptions -> HS.Exp l -> HS.Exp l applyDoSyntax' C2HaskellOptions{oSuppressDo=True} x = x applyDoSyntax' _ x = applyDoSyntax x 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 mgroked_sig = do hh <- changeType makeFunctionUseIO <$> listToMaybe h guard (isJust (oSelectFunction o) || isFunctionDecl c) Just hh -- TypeSig () [Ident () "fetch_about_maps_handler"] -- (TyFun () (TyApp () (TyCon () (UnQual () (Ident () "Ptr"))) (TyCon () (UnQual () (Ident () "FetchAboutContext")))) -- (TyApp () (TyCon () (UnQual () (Ident () "IO"))) (TyCon () (UnQual () (Ident () "Bool"))))) -- fetch_about_maps_handler :: Ptr FetchAboutContext -> IO Bool forM_ mgroked_sig $ \hh -> do let printHeader = do -- putStrLn $ show (fmap (const LT) c) -- putStrLn . show $ fnArgs fe putStrLn . HS.prettyPrint $ hh putStrLn $ unwords (hname:as) ++ " =" bdy0 = concat $ take 1 $ dropWhile null $ map body $ symbolSource sym ts = case hh of TypeSig _ _ t -> unfoldr (\case { TyFun _ a b -> Just (a,b) ; b -> Just (b,b) }) t -- careful: infinite list _ -> [] fe = FunctionEnvironment (syms db) $ Map.fromList $ zip (as ++ [""]) ts let extent = getSymbolExtent sym bdy0 cs0 <- readComments (posFile $ startExtent extent) -- TODO: Avoid parsing the same file multiple times. let (_,cs1) = seekComment (startExtent extent) cs0 (cs,_ ) = seekComment (stopExtent extent) cs1 bdy = mixComments (map reflowComment cs) bdy0 if oPrettyTree o then do printHeader forM_ bdy $ \d -> putStrLn $ ppShow $ cleanTree d else do let mhask = (`evalStateT` freshUniques) $ do xs <- mapM (grokStatement fe) bdy return $ foldr applyComputation (mkcomp retUnit) xs case mhask of Just hask -> do printHeader mapM_ (putStrLn . (" "++)) $ lines $ HS.prettyPrint $ applyDoSyntax' o $ comp hask Nothing -> forM_ (oSelectFunction o) $ \_ -> do printHeader forM_ bdy $ \d -> do putStrLn $ " C: " ++ show (pretty d) case grokStatement fe d `evalStateT` freshUniques of Just hd -> do putStrLn $ "fr: " ++ intercalate " " (Map.keys (compFree hd)) putStrLn $ "HS: " ++ HS.prettyPrint (informalize $ comp hd) Nothing -> putStrLn $ "??: " ++ ppShow (cleanTree d) putStrLn "" print extent {- -- Display comments as c functions. forM_ cs $ \c@(_,col,cmt) -> do putStrLn "" let cc = reflowComment c putStrLn $ replicate col ' ' ++ show (commentRow cc,commentCol cc) ++ show (pretty $ rewriteComment cc) -- putStrLn $ replicate col ' ' ++ cmt putStrLn "\n{" forM_ bdy $ \x -> putStrLn $ {- show (firstRowOf x,lastRowOf x) ++ " " ++ -} (show . pretty $ x) 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 FunctionEnvironment = FunctionEnvironment { fnExternals :: Map String (SymbolInformation [CExternalDeclaration NodeInfo]) , fnArgs :: Map String (HS.Type ()) -- ^ Function name arguments and their type. -- The return type is also stored here under the empty string key. } 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 (CDoubleType _)) = [ Right "Double"] 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 :: Show a => [CDerivedDeclarator a] -> HS.Type () -> HS.Type () grok bs b = case bs of [] -> b CArrDeclr [] (CNoArrSize _) _:cs -> HS.TyApp () (HS.TyCon () (hsMkName "Ptr")) (grok cs 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 t = "_unknown(" ++ show (cleanTree t)++")" getPtrType :: HS.Type l -> Maybe (HS.Type l) getPtrType (HS.TyApp _ (HS.TyCon _ (HS.UnQual _ (HS.Ident _ "Ptr"))) x) | isPtrType x = getPtrType x | otherwise = Just x getPtrType _ = Nothing isPtrType :: HS.Type l -> Bool isPtrType (HS.TyApp _ (HS.TyCon _ (HS.UnQual _ (HS.Ident _ "Ptr"))) x) = True isPtrType _ = False -- 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 , oCommentsOnly :: Bool , oSuppressDo :: Bool } defopts :: C2HaskellOptions defopts = C2HaskellOptions { oSelectFunction = Nothing , oPrettyC = False , oPrettyTree = False , oVerbose = False , oPreprocess = False , oTranspile = False , oCommentsOnly = False , oSuppressDo = 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 ("--nodo":args) o = parseOptions args o{ oSuppressDo = True } parseOptions ("--comments":args) o = parseOptions args o{ oCommentsOnly = 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 :: (Int, b, String) -> Int lineOfComment (l,_,s) = l + length (lines s) -- Break a comment list into comments preceding the given node and comments that come after it. seekComment :: Position -> [(Int,Int,String)] -> ([(Int,Int,String)],[(Int,Int,String)]) seekComment pos cs = break (\c -> lineOfComment c>=posRow pos) cs strip :: [Char] -> [Char] 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-1 " ++ 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 (posOfNode 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 (posOfNode $ 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-2 " ++ t ++ "-- (t,ct)="++show (t,ct) 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 $ cleanTree d -- <$> makeFunctionPointer d -- TODO: make idempotent makeStatic :: [CDeclarationSpecifier NodeInfo] -> [CDeclarationSpecifier NodeInfo] makeStatic xs = CStorageSpec (CStatic undefNode) : filter nonStorages xs where nonStorages (CStorageSpec _) = False nonStorages _ = True 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 doesReturnValue :: [CDeclarationSpecifier a] -> Bool doesReturnValue (CTypeSpec (CVoidType _):_) = False doesReturnValue (x:xs) = doesReturnValue xs doesReturnValue [] = True makeStub :: CExternalDeclaration NodeInfo -> CExternalDeclaration NodeInfo makeStub d = -- @(CDeclExt (CDecl xs ys pos)) = let rval = doesReturnValue $ getReturnValue d 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 -- Represent a comment as a C function call, so that it can be preserved in -- syntax tree manipulations. rewriteComment :: StyledComment -> CExpression NodeInfo rewriteComment c = C.CCall (CVar (internalIdent "__cmt") ni) [ CConst (CIntConst (cInteger $ fromIntegral $ fromEnum (commentStyle c)) ni) , CConst (CStrConst (cString $ styledComment c) ni) ] ni where ni = mkNodeInfoOnlyPos $ position 0 "" (commentRow c) (commentCol c) Nothing data CommentStyle = VanillaComment | StarBarComment deriving (Eq,Ord,Enum,Show) data StyledComment = StyledComment { styledComment :: String , commentStyle :: CommentStyle , commentRow :: Int , commentCol :: Int } deriving (Eq,Ord,Show) reflowComment :: (Int,Int,String) -> StyledComment reflowComment (row,col,s) = StyledComment s' (if allstar then StarBarComment else VanillaComment) row col where xs = map (reverse . dropWhile isSpace . reverse) $ lines s ys = reverse $ dropWhile (null . snd) $ reverse $ map (span isSpace) xs countCols '\t' = 8 countCols _ = 1 starred (sp,'*':_) = sum (map countCols sp) == col starred _ = False allstar = all starred (drop 1 ys) unstar (_,'*':xs) | allstar = dropWhile isSpace xs unstar (_,x) = x s' = unwords $ map unstar ys readComments :: Num lin => FilePath -> IO [(lin, Int, [Char])] readComments fname = grepCComments 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 usageString self = unlines [ self ++ " [--cpp | -p | -t | --comments | --tohs ] [--nodo] [-v] [-f ] -- [gcc options] [modules] " , "" , "MODES" , "" , " default Generate a monkey-patchable Haskell interface to given C module." , "" , " --cpp Show Preprocessor include stack (debugging output)." , "" , " -p Preprocess. Output C with expanded macros (includes are NOT expanded)." , "" , " -t Tree. Output language-c parse tree (verbose!)." , "" , " --comments Output information about comment tokens occuring in file." , "" , " --tohs Attempt to translate C into Haskell (works on simple things)." , "" , "OPTIONS" , "" , " -v Verbose output." , "" , " -f Select a single function from the C file rather than the whole of it." , " This affects the default and --tohs modes." , "" , " --nodo In --tohs mode, avoid outputting do-syntax sugar." , "" , "ARGUMENTS" , "" , " [gcc options] Options passed to gcc during preprocessing or linking." , "" , " [modules] Extra modules (.c or .o). When generating stubs, these symbols are excluded." , "" , " The .c module being interfaced or preprocessed." ] main :: IO () main = do self <- getProgName args <- getArgs let m = usage args fromMaybe (putStrLn $ usageString self) $ 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 _ | oCommentsOnly hopts -- --comments -> do cs <- readComments fname forM_ cs $ \c -> do putStrLn $ show c putStrLn $ show (reflowComment c) _ | 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