Hugs.hs

------------------------------------------------------------------
-- |
-- Module      :  Yhc.Core.FrontEnd.Hugs
-- Copyright   :  (c) Dmitry Golubovsky, 2007              
-- License     :  BSD-style
-- 
-- Maintainer  :  golubovsky@gmail.com
-- Stability   :  experimental
-- Portability :  portable
-- 
--
--
-- Hugs Core to Yhc Core converter (via parsing).
------------------------------------------------------------------

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.Annotations
import Yhc.Core.FrontEnd.Hugs.PrimTable

import Yhc.Core.Extra
import qualified Data.Map as M

-- |Toplevel parser: reads in a given single Hugs Core file,
-- starts the module parser with empty state. The function
-- returns either a parse error or an individual Yhc Core in memory.
-- Due to the Hugs specifics, individual Yhc Core modules are not
-- usable, so it is recommended to use the 'linkHugsCore' function
-- unless anything special is needed.

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

-- |Hugs Core Linker: reads in all *.cor files from the given directories
-- and produces a linked .yca object ready to save in a file. 
-- Names of reachability roots are picked from the arguments,
-- and they should be fully qualified names with
-- semicolons separating module name from function name.
-- If an empty list is provided, all \"main\" functions
-- found in all modules will be used as roots. If none exists,
-- error will be reported. Error will also be reported if parsing
-- of any of the files, or final linking results in an error.

linkHugsCore :: [FilePath] -- ^directories where *.cor files reside
             -> [CoreFuncName] -- ^reachability roots
             -> String -- ^name of the new Core
             -> 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