GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3

src-3.0/GF/Devel/Compile/Compile.hs

@@ -0,0 +1,205 @@
+module GF.Devel.Compile.Compile (batchCompile) where
+
+-- the main compiler passes
+import GF.Devel.Compile.GetGrammar
+import GF.Devel.Compile.Extend
+import GF.Devel.Compile.Rename
+import GF.Devel.Compile.CheckGrammar
+import GF.Devel.Compile.Refresh
+import GF.Devel.Compile.Optimize
+import GF.Devel.Compile.Factorize
+
+import GF.Devel.Grammar.Grammar
+import GF.Devel.Grammar.Construct
+import GF.Infra.Ident
+import GF.Devel.Grammar.PrGF
+----import GF.Devel.Grammar.Lookup
+import GF.Devel.Infra.ReadFiles
+
+import GF.Infra.Option ----
+import GF.Data.Operations
+import GF.Devel.UseIO
+import GF.Devel.Arch
+
+import Control.Monad
+import System.Directory
+
+batchCompile :: Options -> [FilePath] -> IO GF
+batchCompile opts files = do
+  let defOpts = addOptions opts (options [emitCode])
+  egr <- appIOE $ foldM (compileModule defOpts) emptyCompileEnv files 
+  case egr of
+    Ok (_,gr) -> return gr
+    Bad s -> error s
+
+-- to output an intermediate stage
+intermOut :: Options -> Option -> String -> IOE ()
+intermOut opts opt s = 
+  if oElem opt opts || oElem (iOpt "show_all") opts
+  then 
+    ioeIO (putStrLn ("\n\n--#" +++ prOpt opt) >> putStrLn s) 
+  else 
+    return ()
+
+prMod :: SourceModule -> String
+prMod = prModule
+
+-- | the environment
+type CompileEnv = (Int,GF)
+
+-- | 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 -> CompileEnv -> FilePath -> IOE CompileEnv
+compileModule opts1 env file = do
+  opts0 <- ioeIO $ getOptionsFromFile file
+  let useFileOpt = maybe False (const True) $ getOptVal opts0 pathList
+  let useLineOpt = maybe False (const True) $ getOptVal opts1 pathList
+  let opts = addOptions opts1 opts0 
+  let fpath = dropFileName file
+  ps0 <- ioeIO $ pathListOpts opts fpath
+
+  let ps1 = if (useFileOpt && not useLineOpt) 
+              then (ps0 ++ map (combine fpath) ps0)
+              else ps0
+  ps <- ioeIO $ extendPathEnv ps1
+  let ioeIOIf = if oElem beVerbose opts then ioeIO else (const (return ()))
+  ioeIOIf $ putStrLn $ "module search path:" +++ show ps ----
+  let sgr = snd env
+  let rfs = [] ---- files already in memory and their read times
+  let file' = if useFileOpt then takeFileName file else file -- find file itself
+  files <- getAllFiles opts ps rfs file'
+  ioeIOIf $ putStrLn $ "files to read:" +++ show files ----
+  let names = map justModuleName files
+  ioeIOIf $ putStrLn $ "modules to include:" +++ show names ----
+  let sgr2 = sgr ----MGrammar [m | m@(i,_) <- modules sgr, 
+                     ----      notElem (prt i) $ map dropExtension names]
+  let env0 = (0,sgr2)
+  (e,mm) <- foldIOE (compileOne opts) env0 files
+  maybe (return ()) putStrLnE mm
+  return e
+
+
+compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
+compileOne opts env@(_,srcgr) file = do
+
+  let putp s = putPointE opts ("\n" ++ s) 
+  let putpp = putPointEsil opts
+  let putpOpt v m act
+       | oElem beVerbose opts =  putp v act
+       | oElem beSilent opts  =  putpp v act
+       | otherwise = ioeIO (putStrFlush ("\n" ++ m)) >> act
+
+  let gf   = takeExtensions file
+  let path = dropFileName file
+  let name = dropExtension file
+  let mos  = gfmodules srcgr
+
+  case gf of
+
+    -- for compiled gf, read the file and update environment
+    -- also undo common subexp optimization, to enable normal computations
+
+    ".gfn" -> do
+       sm0 <- putp ("+ reading" +++ file) $ getSourceModule opts file
+       let sm1 = unsubexpModule sm0
+       sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule srcgr sm1
+       extendCompileEnv env sm
+
+    -- for gf source, do full compilation and generate code
+    _ -> do
+
+      let modu = dropExtension file
+      b1 <- ioeIO $ doesFileExist file
+      if not b1
+        then compileOne opts env $ gfoFile $ modu 
+        else do
+
+       sm0 <- 
+         putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ 
+                                                      getSourceModule opts file
+       (k',sm) <- compileSourceModule opts env sm0
+       let sm1 = sm ---- 
+----             if isConcr sm then shareModule sm else sm -- cannot expand Str
+       if oElem (iOpt "doemit") opts 
+         then putpp "  generating code... " $ generateModuleCode opts path sm1
+         else return ()
+----          -- sm is optimized before generation, but not in the env
+----       let cm2 = unsubexpModule cm
+       extendCompileEnvInt env (k',sm) ---- sm1
+  where
+   isConcr (_,mi) = case mi of
+----     ModMod m -> isModCnc m && mstatus m /= MSIncomplete 
+     _ -> False
+
+
+
+compileSourceModule :: Options -> CompileEnv -> 
+                       SourceModule -> IOE (Int,SourceModule)
+compileSourceModule opts env@(k,gr) mo@(i,mi) = do
+
+  intermOut opts (iOpt "show_gf") (prMod mo)
+
+  let putp  = putPointE opts
+      putpp = putPointEsil opts
+      stopIf n comp m = 
+        if any (\k -> oElem (iOpt (show k)) opts) [1..n] then return m else comp m
+      stopIfV v n comp m = 
+        if any (\k -> oElem (iOpt (show k)) opts) [1..n] then return (m,v) else comp m
+
+  moe <- stopIf 1 (putpp "  extending" . ioeErr . extendModule gr) mo
+  intermOut opts (iOpt "show_extend") (prMod moe)
+
+  mor <- stopIf 2 (putpp "  renaming" . ioeErr . renameModule gr) moe
+  intermOut opts (iOpt "show_rename") (prMod mor)
+
+  (moc,warnings) <- 
+    stopIfV [] 3 (putpp "  type checking" . ioeErr . showCheckModule gr) mor
+  if null warnings then return () else putp warnings $ return ()
+  intermOut opts (iOpt "show_typecheck") (prMod moc)
+
+  (mox,k') <- stopIfV k 4 (putpp "  refreshing " . ioeErr . refreshModule k) moc
+  intermOut opts (iOpt "show_refresh") (prMod mox)
+
+  moo <- stopIf 5 (putpp "  optimizing " . ioeErr . optimizeModule opts gr) mox
+  intermOut opts (iOpt "show_optimize") (prMod moo)
+
+  mof <- stopIf 6 (putpp "  factorizing " . ioeErr . optimizeModule opts gr) moo
+  intermOut opts (iOpt "show_factorize") (prMod mof)
+
+  return (k',moo) ----
+
+
+generateModuleCode :: Options -> InitPath -> SourceModule -> IOE ()
+generateModuleCode opts path minfo@(name,info) = do
+
+  let pname  = combine path (prt name)
+  let minfo0 = minfo 
+  let minfo1 = subexpModule minfo0
+  let minfo2 = minfo1
+
+  let (file,out) = (gfoFile pname, prGF (gfModules [minfo2]))
+  putp ("  wrote file" +++ file) $ ioeIO $ writeFile file $ out
+
+  return () ----- minfo2
+ where 
+   putp  = putPointE opts
+   putpp = putPointEsil opts
+
+-- auxiliaries
+
+pathListOpts :: Options -> FileName -> IO [InitPath]
+pathListOpts opts file = return $ maybe [file] splitInModuleSearchPath $ getOptVal opts pathList
+
+----reverseModules (MGrammar ms) = MGrammar $ reverse ms
+
+emptyCompileEnv :: CompileEnv
+emptyCompileEnv = (0,emptyGF)
+
+extendCompileEnvInt (_,gf) (k,(s,m)) = return (k, addModule s m gf)
+
+extendCompileEnv e@(k,_) sm = extendCompileEnvInt e (k,sm)
+
+