{-# 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.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 -- 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 -- Used by update to add a symbols to the database. sym :: CExternalDeclaration a -> [Maybe Ident] sym (CFDefExt (CFunDef specs m _ _ _)) = [ declrSym m ] sym (CDeclExt (CDecl specs ms _)) = ms >>= \(m,_,_) -> maybe [] (pure . declrSym) m sym _ = [] 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 _ = [] transpile :: CExternalDeclaration a -> Maybe (Q Dec) transpile (CDeclExt (CDecl [ CTypeSpec (CSUType (CStruct CStructTag mbIdent (Just fields) [] _) _) ] [] _) ) | Just struct_name <- capitalize . identToString <$> mbIdent , let typ = mkName struct_name = Just $ returnQ $ DataD [] typ [] Nothing [RecC typ fs] [] where fs = fields >>= transField transpile _ = Nothing 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 ())) {- 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 { selectFunction :: Maybe String , prettyC :: Bool , prettyTree :: Bool , verbose :: Bool , preprocess :: Bool } defopts :: C2HaskellOptions defopts = C2HaskellOptions { selectFunction = Nothing , prettyC = False , prettyTree = False , verbose = False , preprocess = False } parseOptions :: [String] -> C2HaskellOptions -> C2HaskellOptions parseOptions [] opts = opts parseOptions ("-f":f:args) opts = parseOptions args opts { selectFunction = Just f } parseOptions ("-t":args) opts = parseOptions args opts { prettyTree = True } parseOptions ("-p":args) opts = parseOptions args opts { prettyC = True } parseOptions ("--cpp":args) opts = parseOptions args opts { preprocess = True } parseOptions ("-v":args) opts = parseOptions args opts { verbose = True } parseOptions as x = error (show as) 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 let d = case getArgList d0 of oargs:xs -> let args = fst $ makeParameterNames oargs in changeArgList (const $ args:xs) d0 _ -> d0 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 -- 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 selectFunction 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 -- makeParameterNames :: CDerivedDeclarator NodeInfo -> (CDerivedDeclarator NodeInfo,[CExpression NodeInfo]) makeParameterNames :: CDerivedDeclarator n -> (CDerivedDeclarator n,[CExpression n]) makeParameterNames (CFunDeclr (Right (ps, flg)) z2 z3) = case ps of [CDecl [CTypeSpec (CVoidType _)] [] _] -> ( CFunDeclr (Right (ps, flg)) z2 z3 , []) -- void argument list. _ -> ( CFunDeclr (Right (qs, flg)) z2 z3 , map expr qs ) 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 -- CPtrDeclr [] () makeParameterNames x = error $ "makeParameterNames " ++ show (fmap (const ()) 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 findCloser :: (Num a4, Num a3, Num a2, Num a1, Eq a1) => a1 -> (a4, a2, a3) -> [Char] -> (a4, a2, a3) findCloser !1 (l,c,b) ('*':'/':_) = (l,c+2,b+2) findCloser !d (l,c,b) ('*':'/':xs) = findCloser (d - 1) (l,c+2,b+2) xs findCloser !d (l,c,b) ('/':'*':xs) = findCloser (d + 1) (l,c+2,b+2) xs findCloser !d (l,c,b) ('\n':xs) = findCloser d (l+1,1,b+1) xs findCloser !d (l,c,b) (_:xs) = findCloser d (l,c+1,b+1) xs findCloser !d (l,c,b) [] = (l,c,b) mkComment :: a -> b -> c -> (a, b, c) mkComment lin no str = (lin,no,str) parseComments :: (Num col, Num lin) => lin -> col -> [Char] -> [(lin, col, [Char])] parseComments !lin !col = \case ('/':'*':cs) -> let (lcnt,col',bcnt) = findCloser 1 (0,col,0) cs (xs,cs') = case drop (bcnt-2) cs of '*':'/':_ -> second (drop 2) $ splitAt (bcnt-2) cs _ -> splitAt bcnt cs in mkComment lin col xs : parseComments (lin + lcnt) col' cs' ('/':'/':cs) -> let (comment,ds) = break (=='\n') cs in mkComment lin col comment : parseComments (lin + 1) 1 cs ('\n' : cs) -> parseComments (lin+1) 1 cs ( x : cs) -> parseComments lin (col+1) cs [] -> [] 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 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 = 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 = 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 _ | preprocess hopts -- --cpp -> do case prer of Left e -> print e Right bs -> putStrLn $ ppShow $ includeStack $ bs _ | prettyC hopts -- -p -> do either print (\(incs,decls) -> print $ prettyUsingInclude incs decls) r _ | prettyTree hopts -- -t -> do putStrLn $ ppShow $ everywhere (mkT eraseNodeInfo) . snd <$> r _ -> do syms <- linker (cargs ++ reverse fs) fname either print (uncurry $ c2haskell hopts () fname syms) r