path: root/src/GF/Compile/Compile.hs

module Compile where

import Grammar
import Ident
import Option
import PrGrammar
import Update
import Lookup
import Modules
import ReadFiles
import ShellState
import MkResource
import MkUnion

-- the main compiler passes
import GetGrammar
import Extend
import Rebuild
import Rename
import Refresh
import CheckGrammar
import Optimize
import GrammarToCanon
import Share

import qualified CanonToGrammar as CG

import qualified GFC
import qualified MkGFC
import GetGFC

import Operations
import UseIO
import Arch

import Monad

-- in batch mode: write code in a file

batchCompile f = liftM fst $ compileModule defOpts emptyShellState f
  where
    defOpts = options [beVerbose, emitCode] 
batchCompileOpt f = liftM fst $ compileModule defOpts emptyShellState f
  where
    defOpts = options [beVerbose, emitCode, optimizeCanon] 

batchCompileOld f = compileOld defOpts f
  where
    defOpts = options [beVerbose, emitCode] 

-- compile with one module as starting point
-- command-line options override options (marked by --#) in the file
-- As for path: if it is read from file, the file path is prepended to each name.
-- If from command line, it is used as it is.

compileModule :: Options -> ShellState -> FilePath -> 
                 IOE (GFC.CanonGrammar, (SourceGrammar,[(FilePath,ModTime)]))

compileModule opts st0 file | oElem showOld opts || fileSuffix file == "cf" = do
  let putp = putPointE opts
  let path = [] ----
  grammar1 <- if fileSuffix file == "cf"
                then putp ("- parsing cf" +++ file) $ getCFGrammar opts file
                else putp ("- parsing old gf" +++ file) $ getOldGrammar opts file
  let mods = modules grammar1
  let env = compileEnvShSt st0 []
  (_,sgr,cgr) <- foldM (comp putp path) env mods
  return $ (reverseModules cgr,       -- to preserve dependency order
            (reverseModules sgr,[]))
 where
   comp putp path env sm0 = do
     (k',sm)  <- makeSourceModule opts env sm0
     cm  <- putp "  generating code... " $ generateModuleCode opts path sm
     extendCompileEnvInt env (k',sm,cm)

compileModule opts1 st0 file = do
  opts0 <- ioeIO $ getOptionsFromFile file
  let useFileOpt = maybe False (const True) $ getOptVal opts0 pathList
  let opts = addOptions opts1 opts0 
  let ps0  = pathListOpts opts
  let fpath = justInitPath file
  let ps = if useFileOpt 
             then (map (prefixPathName fpath) ps0)
             else ps0
  ioeIO $ putStrLn $ "module search path:" +++ show ps ----
  let putp = putPointE opts
  let st = st0 --- if useFileOpt then emptyShellState else st0
  let rfs = readFiles st
  let file' = if useFileOpt then justFileName file else file -- to find file itself
  files <- getAllFiles ps rfs file'
  ioeIO $ putStrLn $ "files to read:" +++ show files ----
  let names = map justModuleName files
  ioeIO $ putStrLn $ "modules to include:" +++ show names ----
  let env0 = compileEnvShSt st names
  (_,sgr,cgr) <- foldM (compileOne opts) env0 files
  t <- ioeIO getNowTime
  return $ (reverseModules cgr,       -- to preserve dependency order
            (reverseModules sgr, --- keepResModules opts sgr, --- keep all so far
             [(justModuleName f,t) | f <- files]   -- pass on the time of reading
          ++ [(resModName (justModuleName f),t)    -- also #file if file.(gf|gfr)
                                   | f <- files, not (isGFC f)]))
compileEnvShSt :: ShellState -> [ModName] -> CompileEnv
compileEnvShSt st fs = (0,sgr,cgr) where
  cgr = MGrammar [m | m@(i,_) <- modules (canModules st), notInc i]
  sgr = MGrammar [m | m@(i,_) <- modules (srcModules st), notIns i]
  notInc i = notElem (prt i) $ map fileBody fs
  notIns i = notElem (prt i) $ map fileBody fs

pathListOpts :: Options -> [InitPath]
pathListOpts opts = maybe [""] pFilePaths $ getOptVal opts pathList

reverseModules (MGrammar ms) = MGrammar $ reverse ms

keepResModules :: Options -> SourceGrammar -> SourceGrammar
keepResModules opts gr = 
  if oElem retainOpers opts 
    then MGrammar $ reverse [(i,mi) | (i,mi@(ModMod m)) <- modules gr, isModRes m]
    else emptyMGrammar


-- the environment

type CompileEnv = (Int,SourceGrammar, GFC.CanonGrammar)

emptyCompileEnv :: CompileEnv
emptyCompileEnv = (0,emptyMGrammar,emptyMGrammar)

extendCompileEnvInt (_,MGrammar ss, MGrammar cs) (k,sm,cm) = 
  return (k,MGrammar (sm:ss), MGrammar (cm:cs)) --- reverse later

extendCompileEnv (k,s,c) (sm,cm) = extendCompileEnvInt (k,s,c) (k,sm,cm)

extendCompileEnvCanon (k,s,c) cgr = 
  return (k,s, MGrammar (modules cgr ++ modules c))

compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
compileOne opts env file = do

  let putp = putPointE opts
  let gf   = fileSuffix file
  let path = justInitPath file
  let name = fileBody file

  case gf of
    -- for multilingual canonical gf, just read the file and update environment
    "gfcm" -> do
       cgr <- putp ("+ reading" +++ file) $ getCanonGrammar file
       extendCompileEnvCanon env cgr

    -- for canonical gf, read the file and update environment, also source env
    "gfc" -> do
       cm <- putp ("+ reading" +++ file) $ getCanonModule file
       sm <- ioeErr $ CG.canon2sourceModule cm
       extendCompileEnv env (sm, cm)

    -- for compiled resource, parse and organize, then update environment
    "gfr" -> do
       sm0  <- putp ("| parsing" +++ file) $ getSourceModule file
       let mos = case env of (_,gr,_) -> modules gr
       sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule mos sm0
       let gfc = gfcFile name 
       cm <- putp ("+ reading" +++ gfc) $ getCanonModule gfc
       extendCompileEnv env (sm,cm)

    -- for gf source, do full compilation
    _ -> do
       sm0 <- putp ("- parsing" +++ file) $ getSourceModule file
       (k',sm)  <- makeSourceModule opts env sm0
       cm  <- putp "  generating code... " $ generateModuleCode opts path sm
       extendCompileEnvInt env (k',sm,cm)

-- dispatch reused resource at early stage

makeSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule)
makeSourceModule opts env@(k,gr,can) mo@(i,mi) = case mi of

  ModMod m -> case mtype m of
    MTReuse c -> do
      sm <- ioeErr $ makeReuse gr i (extends m) c
      let mo2 = (i, ModMod sm)
          mos = modules gr
      --- putp "  type checking reused" $ ioeErr $ showCheckModule mos mo2
      return $ (k,mo2)
    MTUnion ty imps -> do
      mo' <- ioeErr $ makeUnion gr i ty imps
      compileSourceModule opts env mo'
    _ -> compileSourceModule opts env mo
  _ -> compileSourceModule opts env mo
 where
   putp = putPointE opts

compileSourceModule :: Options -> CompileEnv -> 
                       SourceModule -> IOE (Int,SourceModule)
compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do

  let putp = putPointE opts
      mos  = modules gr

  if (oElem showOld opts && oElem emitCode opts) 
    then do
      let (file,out) = (gfFile (prt i), prGrammar (MGrammar [mo]))
      ioeIO $ writeFile file out >> putStr ("  wrote file" +++ file)
    else return ()

  mo1   <- ioeErr $ rebuildModule mos mo

  mo1b  <- ioeErr $ extendModule mos mo1

  case mo1b of
    (_,ModMod n) | not (isCompleteModule n) -> do
      return (k,mo1b)   -- refresh would fail, since not renamed
    _ -> do
      mo2:_ <- putp "  renaming " $ ioeErr $ renameModule mos mo1b

      (mo3:_,warnings) <- putp "  type checking" $ ioeErr $ showCheckModule mos mo2
      putStrE warnings

      (k',mo3r:_) <- ioeErr $ refreshModule (k,mos) mo3

      mo4:_ <- putp "  optimizing " $ ioeErr $ evalModule mos mo3r

      return (k',mo4)
 where
   ----   prDebug mo = ioeIO $ putStrLn $ prGrammar $ MGrammar [mo] ---- debug
   prDebug mo = ioeIO $ print $ length $ lines $ prGrammar $ MGrammar [mo]

generateModuleCode :: Options -> InitPath -> SourceModule -> IOE GFC.CanonModule
generateModuleCode opts path minfo@(name,info) = do
  let pname = prefixPathName path (prt name)
  minfo0     <- ioeErr $ redModInfo minfo
  minfo'     <- return $ if optim 
                then shareModule fullOpt minfo0   -- parametrization and sharing
                else shareModule basicOpt minfo0  -- sharing only

  -- for resource, also emit gfr
  case info of
    ModMod m | emitsGFR m && emit && nomulti -> do
      let (file,out) = (gfrFile pname, prGrammar (MGrammar [minfo]))
      ioeIO $ writeFile file out >> putStr ("  wrote file" +++ file)
    _ -> return ()
  (file,out) <- do
      code <- return $ MkGFC.prCanonModInfo minfo'
      return (gfcFile pname, code)
  if isCompilable info && emit && nomulti 
     then ioeIO $ writeFile file out >> putStr ("  wrote file" +++ file)
     else ioeIO $ putStrFlush $ "no need to save module" +++ prt name
  return minfo'
 where 
   emitsGFR m = isModRes m && isCompilable info
     ---- isModRes m || (isModCnc m && mstatus m == MSIncomplete)
   isCompilable mi = case mi of
     ModMod m -> not $ isModCnc m && mstatus m == MSIncomplete 
     _ -> True
   nomulti = not $ oElem makeMulti opts
   emit  = oElem emitCode opts && not (oElem notEmitCode opts)
   optim = oElem optimizeCanon opts

-- for old GF: sort into modules, write files, compile as usual

compileOld :: Options -> FilePath -> IOE GFC.CanonGrammar
compileOld opts file = do
  let putp = putPointE opts
  grammar1 <- putp ("- parsing old gf" +++ file) $ getOldGrammar opts file
  files <- mapM writeNewGF $ modules grammar1
  (_,_,grammar) <- foldM (compileOne opts) emptyCompileEnv files
  return grammar

writeNewGF :: SourceModule -> IOE FilePath
writeNewGF m@(i,_) = do
  let file = gfFile $ prt i
  ioeIO $ writeFile file $ prGrammar (MGrammar [m])
  ioeIO $ putStrLn $ "wrote file" +++ file
  return file