Founding the newly structured GF2.0 cvs archive.

src/GF/Compile/Compile.hs

@@ -0,0 +1,207 @@
+module Compile where
+
+import Grammar
+import Ident
+import Option
+import PrGrammar
+import Update
+import Lookup
+import Modules
+import ModDeps
+import ReadFiles
+import ShellState
+import MkResource
+
+-- the main compiler passes
+import GetGrammar
+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
+
+compileModule :: Options -> ShellState -> FilePath -> 
+                 IOE (GFC.CanonGrammar, (SourceGrammar,[(FilePath,ModTime)]))
+compileModule opts st file = do
+  let ps   = pathListOpts opts
+  ioeIO $ print ps ----
+  let putp = putPointE opts
+  let rfs  = readFiles st
+  files <- getAllFiles ps rfs file
+  ioeIO $ print files ----
+  let names = map (fileBody . justFileName) files
+  ioeIO $ print 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
+             [(f,t) | f <- files]))   -- pass on the time of creation
+
+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) <- modules gr, isResourceModule mi]
+    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)
+
+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 canonical gf, just read the file and update environment
+    "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)
+    _ -> 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
+
+  mo2:_ <- putp "  renaming " $ ioeErr $ renameModule mos mo
+
+  (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)
+
+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 | mtype m == MTResource && 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 emit && nomulti 
+     then ioeIO $ writeFile file out >> putStr ("  wrote file" +++ file)
+     else return ()
+  return minfo'
+ where 
+   nomulti = not $ oElem makeMulti opts
+   emit  = oElem emitCode 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 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
+