path: root/monkeypatch.hs

{-# 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 (left,first,second)
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 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 Data.Ord
import qualified Data.Set           as Set
         ;import Data.Set           (Set)
import Language.C.Data.Ident        as C
import Language.C.Data.Node         as C
import Language.C                   as C hiding (prettyUsingInclude)
import qualified Language.C         as C
import Language.C.System.GCC
import Language.C.System.Preprocess
import Language.C.Data.Position
import Language.Haskell.Exts.Parser as HS
import Language.Haskell.Exts.Pretty as HS
import Language.Haskell.Exts.Syntax as HS
import Language.Haskell.TH
import Language.Haskell.TH.Ppr
import Language.Haskell.TH.Syntax   as TH
import System.Directory
import System.Environment
import System.IO
import System.Process
import System.Exit
import Text.PrettyPrint             (Doc, doubleQuotes, empty, text, vcat, ($$),
                                     (<+>))
import Text.Show.Pretty

import Sweeten
import GrepNested

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

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 :: String
                                 , formExp :: HS.Exp ()
                                 }

informalize :: FormalLambda -> HS.Exp ()
informalize (FormalLambda k x) = Lambda () [hspvar k] x

applyComputation :: Computation FormalLambda -> Computation (HS.Exp ()) -> Computation (HS.Exp ())
applyComputation a@Computation{ comp = FormalLambda govar exp } b =
    let matchgo (Var () (UnQual () (HS.Ident () v))) = v==govar
        matchgo _                                    = False
    in case listify matchgo exp of
        (_:_:_) -> error "TODO: Multiple go-refs; make let binding."
        _       -> Computation
            { compFree     = Map.union (compFree a) (compFree b) Map.\\ compIntro a
            , compIntro    = compIntro a `Map.union` compIntro b
            , 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
                  -> Maybe ([Computation FormalLambda], Computation (HS.Exp ()))
grokExpression fe (CVar cv _) =
    let v = identToString cv
    in Just $
        if isGlobalRef fe v
            then let k = uniqIdentifier "go" (varmap [v,hv])
                     s = Computation
                            { compFree     = Map.singleton v ()
                            , compIntro    = Map.singleton hv ()
                            , compContinue = Nothing
                            , comp         = FormalLambda k
                                               $ infixOp (App () (hsvar "peek") (hsvar v)) ">>="
                                               $ Lambda () [hspvar hv] (hsvar k)
                            }
                     hv = "v" ++ v
                 in (,) [s] (mkcomp $ hsvar hv)
                            { compFree  = Map.singleton hv ()
                            }
            else (,) [] $ (mkcomp $ hsvar v)
                { compFree  = Map.singleton (identToString cv) ()
                }
grokExpression fe (CConst (CIntConst n _)) =
    Just $ (,) [] $ mkcomp $ Lit () (Int () (getCInteger n) (show n))
grokExpression fe (CConst (CStrConst s _)) =
    Just $ (,) [] $ 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
    let cv = identToString cv0
        hv = "p" ++ cv
        k = uniqIdentifier "go" (Map.empty {-todo-})
        ss = pure Computation
                { compFree = Map.singleton cv ()
                , compIntro = Map.singleton hv ()
                , compContinue = Nothing
                , comp = FormalLambda k
                            $ infixFn (hsvar cv)
                                      "withPointer"
                                      (Lambda () [hspvar hv] (hsvar 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 = map (\x -> let k = uniqIdentifier "go" (compFree x)
                         in fmap (\xx -> FormalLambda k (infixOp (parn xx) ">>" (hsvar k))) x)
                 (init gs2)
        s = foldr applyComputation (last gs2) ps
        hv = "u"
        k = uniqIdentifier "go" (compFree s)
        s' = fmap (\x ->  FormalLambda k (infixOp (parn x) ">>=" (Lambda () [hspvar hv] (hsvar 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 (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 = uniqIdentifier "go" (compFree s)
        s = (fmap (\c -> FormalLambda k $ infixOp c ">>=" $ Lambda () [hspvar hv] (hsvar k)) cll)
                { compIntro = Map.singleton hv ()
                }
    return $ (,) (ss++[s]) (mkcomp $ hsvar hv)
        { compFree  = Map.singleton hv ()
        }
grokExpression fe (CStatExpr (CCompound idents xs _) _) = do
    let (y,ys) = splitAt 1 (reverse xs)
    y' <- case y of
                [CBlockStmt (CExpr mexp ni)] -> Just $ CBlockStmt (CReturn mexp ni)
                _                            -> Just (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 = uniqIdentifier "go" (compFree s1)
        s = Computation
                { compFree = compFree s1
                , compIntro = Map.singleton hv ()
                , compContinue = Nothing
                , comp = FormalLambda k
                            $ infixOp (comp s1) ">>="
                                $ Lambda () [hspvar hv] (hsvar k)
                }
    return $ (,) [s] (mkcomp $ hsvar hv)
        { compFree  = Map.singleton hv ()
        }
grokExpression fe (CAssign CAssignOp cvar expr _) = do
    v <- cvarName cvar
    (ss,x) <- grokExpression fe expr
    let k = uniqIdentifier "go" (Map.insert v () $ foldr (\s m -> compFree s `Map.union` compIntro s `Map.union` m) Map.empty ss)
        s = x
            { compIntro = Map.singleton v ()
            , comp = FormalLambda k
                $ infixOp (App () (hsvar "return") (comp x)) ">>="
                    $ Lambda () [hspvar v] (hsvar k)
            }
    return $ (,) (ss ++ [s]) $ mkcomp (hsvar v)
grokExpression fe _ = Nothing


grokInitialization :: Foldable t1 =>
                      FunctionEnvironment
                      -> t1 (CDeclarationSpecifier t2)
                      -> (Maybe (CDeclarator a1), CInitializer a2)
                      -> 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 () (
        ret = flip (foldr applyComputation) xs $
                fmap (\exp -> infixOp exp ">>="
                                $ Lambda () [hspvar v] (hsvar k)) hsexp
        k = uniqIdentifier "go" (compFree ret)
    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)
                        _              -> Nothing
            let assigns = do
                    (ms,(ss,x)) <- gs
                    let k2 = uniqIdentifier "gopoo" (compFree ret)
                        ret = foldr applyComputation (mkcomp $ hsvar k2) (ss ++ cs)
                        cs = do
                            CMemberDesig m _ <- ms
                            let k1 = uniqIdentifier "go" (compFree x)
                                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) ">>" (hsvar k1)
                                }
                    return $ fmap (FormalLambda k2) ret
            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] (hsvar k)
                        }
                k = uniqIdentifier "go" Map.empty -- (compFree ret) TODO
                ret = foldr applyComputation (mkcomp $ hsvar k) $ newstruct : assigns
            return $ fmap (FormalLambda k) ret
        _ -> Nothing
grokInitialization _ _ _ = Nothing

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 -> Maybe (Computation FormalLambda)
grokStatement fe (CBlockStmt (CReturn (Just exp) _)) = do
    (xs,x) <- grokExpression fe exp
    let k = uniqIdentifier "go" (compFree x `Map.union` compIntro x)
        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 _)) =
    Just $ mkcomp $ FormalLambda "go" retUnit
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                                               ) -> Just (mkif0, stmts)
        (stmt                , Nothing                                               ) -> Just (mkif0, [CBlockStmt stmt])
        (CCompound [] stmts _, Just (CExpr Nothing _)                                ) -> Just (mkif0, stmts)
        (CCompound [] stmts _, Just (CCompound [] [ CBlockStmt (CExpr Nothing _) ] _)) -> Just (mkif0, stmts)

        (CExpr Nothing _                              ,Just (CCompound [] stmts _)) -> Just (flip mkif0, stmts)
        (CCompound [] [CBlockStmt (CExpr Nothing _)] _,Just (CCompound [] stmts _)) -> Just (flip mkif0, stmts)
        (CExpr Nothing _                              ,Just e@(CExpr (Just _) _))   -> Just (flip mkif0, [CBlockStmt e])
        (CCompound [] [CBlockStmt (CExpr Nothing _)] _,Just e@(CExpr (Just _) _))   -> Just (flip mkif0, [CBlockStmt e])

        _ -> trace ("Unhandled if: "++show (fmap (const LT) thn)) $ Nothing -- TODO

    ss <- sequence $ map (grokStatement fe) stmts
    let s = foldr applyComputation (mkcomp $ hsvar k) ss
        k = uniqIdentifier "go" (Map.union (compFree x) (compFree s))
    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) (hsvar 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 Just $ mkcomp $ Lit () (HS.String () s s)
            _                            -> Nothing
    let k = uniqIdentifier "go" (compFree x `Map.union` compIntro x)
        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 <- cvarName cvar
    let fieldlbl = identToString fld
        k1 = uniqIdentifier "go" (compFree x)
        fieldinit = comp x
        x' = x
            { comp = infixOp
                            (App () (App () (App () (hsvar "set")
                                               (TypeApp () (TyPromoted () (PromotedString () fieldlbl fieldlbl))))
                                            (hsvar v))
                                    fieldinit) ">>" (hsvar k1)
            }
    return $ fmap (FormalLambda k1) $ foldr applyComputation x' xs
grokStatement fe (CBlockStmt (CExpr (Just
                    (C.CCall cvarfun exps _)) _)) = do
    -- This case is technically not needed, but it makes slightly cleaner output
    -- by avoiding a bind operation.
    fn <- cvarName cvarfun
    gs <- mapM (grokExpression fe) exps
    let k = uniqIdentifier "go" (compFree s1)
        cll = foldl (\f x -> App () <$> f <*> x) (mkcomp $ hsvar fn){compFree = Map.singleton fn ()} $ map snd gs
        s1 = fmap (`infixOp` ">>") cll
        s = s1 <*> mkcomp (hsvar k)
        x = foldr applyComputation s $ concatMap fst gs
    return $ fmap (FormalLambda k) x
grokStatement fe (CBlockStmt (CExpr (Just
                (CAssign CAssignOp cvarnew
                    (C.CCall cvarfun [] _) _)) _)) = do
    v <- cvarName cvarnew
    fn <- cvarName cvarfun
    let k = uniqIdentifier "go" (varmap [v,fn])
    return Computation
        { compFree = Map.singleton fn ()
        , compIntro = Map.singleton v ()
        , compContinue = Nothing
        , comp = FormalLambda k
            $ infixOp (hsvar fn) ">>="
                $ Lambda () [hspvar v] (hsvar k)
        }
grokStatement fe (CBlockStmt (CExpr (Just (CUnary CPostIncOp (CMember (CVar cv0 _) fld True _) _)) _)) = do
    let k1 = uniqIdentifier "go" (varmap [fieldlbl,v])
        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")) ">>" (hsvar k1)
            }
grokStatement fe (CBlockStmt (CExpr mexpr _)) = do
    (ss,pre) <- maybe (Just $ (,) [] $ 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
    let k = uniqIdentifier "go" (compFree s)
        s = foldr applyComputation (fmap ($ hsvar 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
    case mapMaybe (\(i,inits,_) -> fmap ((,) i) inits) (v:vs) of
        [] -> return $ mkcomp $ FormalLambda "go" $ hsvar "go"
        initials -> do
            gs <- mapM (grokInitialization fe $ t:ts) initials
            return $ fmap (FormalLambda "go")
                        $ foldr applyComputation (mkcomp $ hsvar "go") gs
grokStatement fe _ = Nothing

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 = 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 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 (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 <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 $ 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

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