path: root/c2haskell.hs

{-# LANGUAGE BangPatterns             #-}
{-# 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.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 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 specs _ _ _ _)) = specs
specs (CDeclExt (CDecl specs _ _))       = specs
specs _                                  = []

declrSym :: CDeclarator t -> Maybe Ident
declrSym (CDeclr m _ _ _ _) = m

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)

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

hsTypeSpec :: CDeclarationSpecifier t -> [String]
hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "uint8_t" _ _) _))                = ["Word8"]
hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "uint16_t" _ _) _))               = ["Word16"]
hsTypeSpec (CTypeSpec (CTypeDef (C.Ident "uint32_t" _ _) _))               = ["Word32"]
hsTypeSpec (CTypeSpec (CTypeDef ctyp _))                                   = [capitalize . identToString $ ctyp]
hsTypeSpec (CTypeSpec (CBoolType _))                                       = ["Bool"]
hsTypeSpec (CTypeSpec (CIntType  _))                                       = ["Int"]
hsTypeSpec (CTypeSpec (CCharType _))                                       = ["Char"]
hsTypeSpec (CTypeSpec (CSUType (CStruct CStructTag mctyp Nothing [] _) _)) = maybeToList $ fmap (capitalize . identToString) mctyp
hsTypeSpec (CTypeSpec unhandled)                                           = trace ("hsTypeSpec unhandled: "++ show (const () <$> unhandled))
                                                                              $ []
hsTypeSpec _                                                               = []

-- hsTransField :: [CDeclarationSpecifier t3] -> [(Maybe (CDeclarator t2), Maybe t1, Maybe t)] -> [HS.Decl ()]
hsTransField ctyps vars
    = do
        typname <- hsMkName <$> (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 _] -> let (as,ts) = unzip $ concatMap (\(CDecl rs as _) -> hsTransField rs as) args
                                                          in foldr (HS.TyFun ()) b 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 _ _ = []
-}

hsTransFieldExt rs as = concatMap (\(fieldName,ftyp)-> [ HS.TypeSig () [ HS.Ident () fieldName ] ftyp ])
                                        $ hsTransField rs as

sig (CDeclExt (CDecl rs as _))              = hsTransFieldExt rs as
sig (CFDefExt (CFunDef rs cdeclr [] bdy _)) = hsTransFieldExt 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
    }

c2haskell opts cs (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 -> forM_ (Map.toList es) $ \(k,si) -> do
            putStrLn ""
            putStrLn (commented k)
            forM_ (symbolSource si) $ \d -> do
                putStr $ commented (ppShow (fmap (const ()) d))
                putStr $ commented (show $ pretty d)
                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 -> do
            forM_ (symbolSource $ syms db Map.! cfun) $ \d -> do
                -- putStr $ commented (ppShow (fmap (const ()) d))
                -- putStr $ commented (show $ pretty d)
                when (verbose opts) $ print (sig d)
                mapM_ (putStrLn . HS.prettyPrint) (sig d)


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

m <&> f = fmap f m

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
        putStrLn $ "----------------------------"
        if prettyC hopts -- -p
            then do
                print (fmap prettyUsingInclude r)
            else do
                either print (c2haskell hopts cs) r