path: root/c2haskell.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns             #-}
{-# LANGUAGE DeriveFunctor            #-}
{-# LANGUAGE FlexibleContexts         #-}
{-# LANGUAGE LambdaCase               #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE QuasiQuotes              #-}
{-# LANGUAGE TemplateHaskell          #-}

import Control.Arrow (left)
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 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 (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
    { symbolLocal = False
    , symbolStatic = False
    , symbolSource = mempty
    }

data Transpile c = Transpile
    { syms :: Map String (SymbolInformation c)
    }

initTranspile = Transpile
    { syms = Map.empty
    }

-- grokSymbol :: CExternalDeclaration a -> String -> Maybe SymbolInformation -> Maybe SymbolInformation
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 "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 "Int"    = False
notKnown "Char"   = False
notKnown "()"     = False
notKnown _        = True

hsTypeSpec :: CDeclarationSpecifier t -> [Either Ident String]
hsTypeSpec (CTypeSpec (CVoidType _)) = [ Right "()" ]
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 -}) ]
hsTransField ctyps vars
    = do
        typname <- hsMkName . either (capitalize . identToString) id <$> (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 [] _ = 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 _) -> 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 ) ]
{-
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 (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 ])
                                        $ hsTransField rs as

hsTransSig rs as = concatMap (\(fieldName,ftyp)-> [ HS.TypeDecl () (DHead () (HS.Ident () ("Sig_" ++ fieldName))) ftyp ])
                                        $ hsTransField rs as

types (HS.TypeDecl _ _ typ) = primtypes typ

primtypes (HS.TyFun _ a b) = primtypes a ++ primtypes b
primtypes t = [t]

tname (HS.TyCon () (HS.UnQual () (HS.Ident () str))) = str
tname _                                              = "_unkonwn"

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

unpointer t = case getPtrType t of
    Nothing -> t
    Just t' -> t'

-- sig :: Show t => CExternalDeclaration t -> [HS.Decl ()]
sig :: CExternalDeclaration NodeInfo -> [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 (CFDefExt (CFunDef rs cdeclr [] bdy _)) = Just bdy
body0 _                                       = Nothing

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 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
    { selectFunction = Nothing
    , prettyC        = False
    , prettyTree     = False
    , verbose        = False
    , preprocess     = False
    }

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)

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 = filter notKnown $ map tname $ map unpointer $ concatMap types $ sigf hsTransSig d
        s = sig d
    [(ts,(k,s,d))]

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.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

-- 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
        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/t_stubs.c" -- todo
          putStrLn $ "writing " ++ fname
          withFile fname  WriteMode $ \haskmod -> do
          hPutStrLn haskmod $ "module MonkeyPatch." ++ modname ++" where"
          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)
              sigs2 = concatMap (\s -> do
                                  x <- maybeToList $ Map.lookup s (syms db)
                                  (y,_) <- getsig (s,x)
                                  y)
                          missings
              ts = concatMap fst sigs
          putStrLn $ "-- IP `elem` db = " ++ show (length . symbolSource <$> Map.lookup "IP" (syms db))
          putStrLn $ "-- IP `elem` sigs2 = " ++ show (elem "IP" sigs2)
          putStrLn $ "-- ip_is_lan `elem` db = " ++ show (length . symbolSource <$> Map.lookup "ip_is_lan" (syms db))
          putStrLn $ "-- ip_is_lan `elem` sigs2 = " ++ show (elem "ip_is_lan" sigs2)
          forM_ (uniq $ ts ++ sigs2) $ \t -> do
            hPutStrLn haskmod $ "data " ++ t
          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 <stdio.h>"
          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 (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,_,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 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 f ((a,b,c):zs) = (changeName2 f a,b,c):zs

changeName f d@(CDeclExt (CDecl xs ys pos)) = CDeclExt (CDecl xs (changeName1 f ys) pos)
changeName f d                              = d

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 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 f (CDeclr a xs b c d) = CDeclr a (f xs) b c d

changeArgList2 f ((a,b,c):zs) = (changeArgList3 f a,b,c):zs

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 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 (CDeclr a xs b c d) = xs

getArgList2 ((a,b,c):zs) = getArgList3 a

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

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 (CFDefExt (CFunDef xs ys zs c d)) = xs
getReturnValue (CDeclExt (CDecl xs ys pos))      = xs

voidReturnType = [ CTypeSpec (CVoidType undefNode) ]

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 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

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 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 = filter notKnown $ map tname $ pointers $ concatMap types $ sigf hsTransSig d
                -- forM_ ts $ \t -> putStrLn $ "data " ++ t
                forM_ (sigf hsTransSig d) $ \hs -> 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') = 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 Map.empty

openInclude fname stack (IncludeStack m) = IncludeStack $ Map.alter go fname m
 where
    go Nothing  = Just [stack]
    go (Just s) = Just $ stack : s

findQuoted xs = takeWhile (/='"') $ drop 1 $ dropWhile (/='"') xs

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 <sym>] -- [gcc options] [modules] <cfile>"
    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 cs fname syms) r