module Ivory.Compile.C.Modules where
import Paths_ivory_backend_c (version)
import qualified Text.PrettyPrint.Mainland as PP
import Text.PrettyPrint.Mainland
import qualified Ivory.Language.Syntax.AST as I
import Ivory.Compile.C.Gen
import Ivory.Compile.C.Types
import Data.Char (toUpper)
import Data.Version (showVersion)
import Control.Applicative ((<$>))
import qualified Data.Set as S
import Control.Monad
import System.FilePath.Posix ((<.>))
import MonadLib (put,runM)
showModule :: CompileUnits -> [[String]]
showModule m =
[ mk "// Sources:\n" (sources m)
, mk "// Header:\n" (headers m)
, mk "// Externs:\n" (S.empty, externs m)
]
where
mk _ (_,[]) = []
mk str (incls,units) = str : pp (map includeDef (S.toList incls) ++ units)
pp = map (show . ppr)
compilerVersion :: String
compilerVersion = showVersion version
topComments :: Doc
topComments = text "/* This file has been autogenerated by Ivory" </>
text " * Compiler version " <+> text compilerVersion </>
text " */"
writeHdr :: Bool
-> FilePath
-> (Includes, Sources)
-> String
-> IO ()
writeHdr True f s unitname = toFile f $ renderHdr s unitname
writeHdr False f s unitname = toFileQuiet f $ renderHdr s unitname
renderHdr :: (Includes, Sources) -> String -> String
renderHdr s unitname = PP.displayS (PP.render width guardedHeader) ""
where
width = 80
guardedHeader = stack [ topComments
, topGuard
, topExternC
, ppr (defs s)
, botExternC
, botGuard
]
topGuard = text "#ifndef" <+> guardName PP.</> text "#define"
<+> guardName
botGuard = text "#endif" <+> text "/*" <+> guardName <+> text "*/"
unitname' = map (\c -> if c == '-' then '_' else c) unitname
guardName = text "__" <> text (toUpper <$> unitname') <> text "_H__"
topExternC = stack $ text <$> [ "#ifdef __cplusplus"
, "extern \"C\" {"
, "#endif"]
botExternC = stack $ text <$> [ "#ifdef __cplusplus"
, "}"
, "#endif"]
defs (incls,us) = map includeDef (S.toList incls) ++ us
writeSrc :: Bool
-> FilePath
-> (Includes, Sources)
-> IO ()
writeSrc verbose f s = vToFile f (renderSrc s)
where
vToFile = if verbose then toFile else toFileQuiet
renderSrc :: (Includes, Sources) -> String
renderSrc s = PP.displayS (PP.render width srcdoc) ""
where
width = 80
srcdoc = topComments </> out
defs (incls,us) = map includeDef (S.toList incls) ++ us
out = stack $ punctuate line $ map ppr $ defs s
toFileQuiet :: FilePath -> String -> IO ()
toFileQuiet f v = writeFile f v
toFile :: FilePath -> String -> IO ()
toFile f v = do
putStr $ "Writing to file " ++ f ++ "..."
toFileQuiet f v
putStrLn " Done."
runOpt :: (I.Proc -> I.Proc) -> I.Module -> I.Module
runOpt opt m =
m { I.modProcs = procs' }
where
procs' = procs { I.public = map' I.public, I.private = map' I.private }
procs = I.modProcs m
map' acc = map opt (acc procs)
compileModule :: I.Module -> CompileUnits
compileModule I.Module { I.modName = nm
, I.modDepends = deps
, I.modHeaders = hdrs
, I.modExterns = exts
, I.modImports = imports
, I.modProcs = procs
, I.modStructs = structs
, I.modAreas = areas
, I.modAreaImports = ais
}
= CompileUnits
{ unitName = nm
, sources = sources res
, headers = headers res
, externs = externs res
}
where
res = compRes comp
compRes = (snd . runM . unCompile)
unitHdr = LocalInclude (nm <.> "h")
comp = do
let c = compRes comp0
unless (null (snd (headers c))) (putSrcInc unitHdr)
Compile (put c)
comp0 :: Compile
comp0 = do
putHdrInc (LocalInclude "ivory.h")
mapM_ (putHdrInc . LocalInclude . ((<.> "h"))) (S.toList deps)
mapM_ (putHdrInc . SysInclude) (S.toList hdrs)
mapM_ (compileStruct Public) (I.public structs)
mapM_ (compileStruct Private) (I.private structs)
mapM_ compileExtern exts
mapM_ fromImport imports
mapM_ (extractAreaProto Public) (I.public areas)
mapM_ (extractAreaProto Private) (I.private areas)
mapM_ (compileArea Public) (I.public areas)
mapM_ (compileArea Private) (I.private areas)
mapM_ compileAreaImport ais
mapM_ (extractProto Public) (I.public procs)
mapM_ (extractProto Private) (I.private procs)
mapM_ compileUnit (I.public procs ++ I.private procs)
fromImport :: I.Import -> Compile
fromImport p = putSrcInc (SysInclude (I.importFile p))
outputProcSyms :: [I.Module] -> IO ()
outputProcSyms mods = putStrLn $ unwords $ concatMap go mods
where
go :: I.Module -> [String]
go m = map I.procSym (pub ++ priv)
where I.Visible pub priv = I.modProcs m