path: root/c2haskell.hs

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

import Data.Generics.Aliases
import Data.Generics.Schemes
-- import Debug.Trace
import Control.Monad
import Data.Char
import Data.Data
import Data.List
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 Language.C.System.GCC
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.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 :: CTranslUnit -> Doc
prettyUsingInclude (CTranslUnit edecls _) =
  includeWarning headerFiles
    $$
  vcat (map (either includeHeader pretty) mappedDecls)
  where
    (headerFiles,mappedDecls) = foldr (addDecl . tagIncludedDecls) (Set.empty,[]) edecls
    tagIncludedDecls edecl | maybe False isHeaderFile (fileOfNode edecl) = Left ((posFile . posOf) edecl)
                           | otherwise = Right edecl
    addDecl decl@(Left headerRef) (headerSet, ds)
      | Set.member headerRef headerSet = (headerSet, ds)
      | otherwise = (Set.insert headerRef headerSet, decl : ds)
    addDecl decl (headerSet,ds) = (headerSet, decl : ds)
    includeHeader hFile = text "#include" <+> doubleQuotes (text hFile)
    isHeaderFile = (".h" `isSuffixOf`)
    includeWarning hs | Set.null hs = empty
                      | otherwise = text "/* Warning: The #include directives in this file aren't necessarily correct. */"

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 _ = []


-- 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
                      -> [(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
        trace ("var="++show var) $ return ()
        CDeclr (Just fident) ptrdeclr Nothing [] _ <- maybeToList var
        trace ("fident="++show fident) $ 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 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 = identToString fident
        [ ( 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 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 = sigf hsTransFieldExt

sigf f (CDeclExt (CDecl rs as _))              = f rs as
sigf f (CFDefExt (CFunDef rs cdeclr [] bdy _)) = f rs [(Just cdeclr, Nothing, Nothing)]

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
    , verbose :: Bool
    }

defopts = C2HaskellOptions
    { selectFunction = Nothing
    , prettyC        = False
    , verbose        = False
    }

parseOptions []            opts = opts
parseOptions ("-f":f:args) opts = parseOptions args opts
    { selectFunction = Just f
    }
parseOptions ("-p":args) opts = parseOptions args opts
    { prettyC = True
    }
parseOptions ("-v":args) opts = parseOptions args opts
    { verbose = True
    }

getsig (k,si) = do
    d <- take 1 $ symbolSource si
    let ts = filter notKnown $ map tname $ map unpointer $ concatMap types $ sigf hsTransSig d
        s = sig d
    [(ts,(k,s))]

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 opts cs missings (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
          putStrLn $ "module T where"
          putStrLn $ "import Foreign.Ptr"
          putStrLn $ "import Data.Word"
          putStrLn $ "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
            putStrLn $ "data " ++ t
          forM_ sigs $ \(_,(k,hs)) -> do
            forM_ hs $ \hdecl -> do
                {-
                putStr (commented k)
                putStr $ 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
                putStrLn $ (if isAcceptableImport htyp then id else commented)
                         $ HS.prettyPrint $ (HS.ForImp () (HS.CCall ()) Nothing (Just k)
                                                     (HS.Ident () k)
                                                     htyp)
          forM_ missings $ \sym -> goMissing 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))
                -}
            -}
        Just cfun -> goMissing db cfun

makeAcceptableDecl (HS.TypeDecl a (DHead b (HS.Ident c signame)) ftyp)
                =  (HS.TypeDecl a (DHead b (HS.Ident c signame)) (makeFunctionUseIO $ makeAcceptableImport ftyp))

goMissing db cfun = do
      forM_ (Map.lookup cfun $ syms db) $ \si -> do
        forM_ (take 1 $ symbolSource si) $ \d -> do
                -- putStr $ commented (ppShow (fmap (const ()) d))
                -- putStr $ commented (show $ pretty d)
                -- when (verbose opts) $ print (sig d)
                let ts = filter notKnown $ map tname $ pointers $ concatMap types $ sigf hsTransSig d
                -- forM_ ts $ \t -> putStrLn $ "data " ++ t
                forM_ (sigf hsTransSig d) $ \hs -> do
                putStrLn . 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))))
                        -- putStrLn $ ppShow $ HS.parseDecl "foreign import ccall \"wrapper\" fname :: Spec -> IO (FunPtr Spec)"
                        -- mapM_ (putStrLn . HS.prettyPrint) (importWrapper $ sigf hsTransSig d)
                        putStrLn $ 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))))
                        putStrLn $ HS.prettyPrint $
                                      (HS.ForImp () (HS.CCall ()) Nothing (Just settername)
                                         (HS.Ident () settername)
                                         (TyFun ()
                                            funptr
                                            (TyApp ()
                                               (TyCon () (UnQual () (HS.Ident () "IO")))
                                               (TyCon () (Special () (UnitCon ()))))))


                    htyp -> putStr $ commented $ "Unsupported haskell type: " ++ HS.prettyPrint htyp


readComments fname = parseComments 1 1 <$> readFile fname

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 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 []                 = []

usage :: [String] -> Maybe (C2HaskellOptions, [String], FilePath)
usage args = do
    let fname = last args
    case break (=="--") args of
        (targs,_:cargs0) -> do
            let opts = init cargs0
                cargs = (sanitizeArgs opts)
                hopts = parseOptions targs defopts
            return (hopts,cargs,fname)
        _ -> Nothing

(<&>) :: Functor f => f a -> (a -> b) -> f b
m <&> f = fmap f m

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 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 cargs fname = do
    (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


main :: IO ()
main = do
    self <- getProgName
    args <- getArgs
    let usageString = self ++ " [-v] [-p] [-f <sym>] -- [gcc options] <cfile>"
    let m = usage args
    fromMaybe (putStrLn usageString) $ m <&> \(hopts,cargs,fname) -> do
        r <- parseCFile (newGCC "gcc") Nothing cargs fname
        cs <- readComments fname
        if prettyC hopts -- -p
            then do
                print (fmap prettyUsingInclude r)
            else do
                syms <- linker cargs fname
                either print (c2haskell hopts cs syms) r