module Yhc.Core.FrontEnd.Hugs (
parseHugsCore,
linkHugsCore,
module Yhc.Core.FrontEnd.Hugs.PrimTable)
where
import Control.Monad
import System.FilePath
import Text.ParserCombinators.Parsec
import System.Directory
import System.IO
import Yhc.Core.FrontEnd.Hugs.ParseUtil
import Yhc.Core.FrontEnd.Hugs.LinkUtil
import Yhc.Core.FrontEnd.Hugs.UnDict
import Yhc.Core.FrontEnd.Hugs.PrimTable
import Yhc.Core.Extra
import qualified Data.Map as M
parseHugsCore :: FilePath -> IO (Either ParseError Core)
parseHugsCore f = do
let emptyst = PState {
modName = ""
,funName = ""
,fbStack = [0]
,counter = 0
,autoFuncs = []
}
inp <- readFile f
return $ runParser pModule emptyst f inp
linkHugsCore :: [FilePath]
-> [CoreFuncName]
-> String
-> IO Core
linkHugsCore dirs roots0 outcore= do
dcs <- mapM getDirectoryContents dirs
let fdcs = zipWith prepdir dirs dcs
prepdir d fs = map (d </>) fs
hcfs = (filter (\f -> takeExtension f == ".cor") . concat) fdcs
cores <- mapM (\f -> do hPutStr stderr $ "Parsing module " ++ f ++ " ... "
ec <- parseHugsCore f
case ec of
Left e -> error ("linkHugsCore: " ++ show e)
Right c -> hPutStrLn stderr "done" >> return c) hcfs
let mcore = mergeCores (dropExtension outcore) cores
mains = [x | x <- map coreFuncName (coreFuncs mcore), dropModule x == "main"]
roots = roots0 ++ mains
roots' = "SEL_ELEM" : roots
when (null roots) $ error "linkHugsCore: no reachability roots were specified or found"
let opts_all = coreReachable roots' .
unDict . coreCaseElim . coreSimplify .
fixCasePats . removeRecursiveLet .
mapPrims . mapFuns . mapDatas . mapCons . fixCore
let fmcore = opts_all mcore
return fmcore