diff options
Diffstat (limited to 'src-2.9/GF/Compile/Compile.hs')
| -rw-r--r-- | src-2.9/GF/Compile/Compile.hs | 401 |
1 files changed, 0 insertions, 401 deletions
diff --git a/src-2.9/GF/Compile/Compile.hs b/src-2.9/GF/Compile/Compile.hs deleted file mode 100644 index 422df0fd5..000000000 --- a/src-2.9/GF/Compile/Compile.hs +++ /dev/null @@ -1,401 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Compile --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/05 20:02:19 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.45 $ --- --- The top-level compilation chain from source file to gfc\/gfr. ------------------------------------------------------------------------------ - -module GF.Compile.Compile (compileModule, compileEnvShSt, compileOne, - CompileEnv, TimedCompileEnv,gfGrammarPathVar,pathListOpts, - getGFEFiles) where - -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Option -import GF.Infra.CompactPrint -import GF.Grammar.PrGrammar -import GF.Compile.Update -import GF.Grammar.Lookup -import GF.Infra.Modules -import GF.Infra.ReadFiles -import GF.Compile.ShellState -import GF.Compile.MkResource ----- import MkUnion - --- the main compiler passes -import GF.Compile.GetGrammar -import GF.Compile.Extend -import GF.Compile.Rebuild -import GF.Compile.Rename -import GF.Grammar.Refresh -import GF.Compile.CheckGrammar -import GF.Compile.Optimize -import GF.Compile.Evaluate -import GF.Compile.GrammarToCanon ---import GF.Devel.GrammarToGFCC ----- -import GF.Devel.OptimizeGF (subexpModule,unsubexpModule) -import GF.Canon.Share -import GF.Canon.Subexpressions (elimSubtermsMod,unSubelimModule) -import GF.UseGrammar.Linear (unoptimizeCanonMod) ---- - -import qualified GF.Canon.CanonToGrammar as CG - -import qualified GF.Canon.GFC as GFC -import qualified GF.Canon.MkGFC as MkGFC -import GF.Canon.GetGFC - -import GF.Data.Operations -import GF.Infra.UseIO -import GF.Text.UTF8 ---- -import GF.System.Arch - -import Control.Monad -import System.Directory -import System.FilePath - --- | in batch mode: write code in a file -batchCompile f = liftM fst $ compileModule defOpts emptyShellState f - where - defOpts = options [emitCode] -batchCompileOpt f = liftM fst $ compileModule defOpts emptyShellState f - where - defOpts = options [emitCode, optimizeCanon] - -batchCompileOld f = compileOld defOpts f - where - defOpts = options [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 TimedCompileEnv ----- IOE (GFC.CanonGrammar, (SourceGrammar,[(String,(FilePath,ModTime))])) - -compileModule opts st0 file | - oElem showOld opts || - elem suff [".cf",".ebnf",".gfm"] = do - let putp = putPointE opts - let putpp = putPointEsil opts - let path = [] ---- - grammar1 <- case suff of - ".cf" -> putp ("- parsing" +++ suff +++ file) $ getCFGrammar opts file - ".ebnf" -> putp ("- parsing" +++ suff +++ file) $ getEBNFGrammar opts file - ".gfm" -> putp ("- parsing" +++ suff +++ file) $ getSourceGrammar opts file - _ -> putp ("- parsing old gf" +++ file) $ getOldGrammar opts file - let mods = modules grammar1 - let env = compileEnvShSt st0 [] - foldM (comp putpp path) env mods - where - suff = takeExtensions file - comp putpp path env sm0 = do - (k',sm,eenv') <- makeSourceModule opts (fst env) sm0 - cm <- putpp " generating code... " $ generateModuleCode opts path sm - ft <- getReadTimes file --- - extendCompileEnvInt env (k',sm,cm) eenv' ft - -compileModule opts1 st0 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 st = st0 --- if useFileOpt then emptyShellState else st0 - let rfs = [(m,t) | (m,(_,t)) <- readFiles st] - let file' = if useFileOpt then takeFileName file else file -- to 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 env0 = compileEnvShSt st names - (e,mm) <- foldIOE (compileOne opts) env0 files - maybe (return ()) putStrLnE mm - return e - -getReadTimes file = do - t <- ioeIO getNowTime - let m = justModuleName file - return $ (m,(file,t)) : [(resModName m,(file,t)) | not (isGFC file)] - -compileEnvShSt :: ShellState -> [ModName] -> TimedCompileEnv -compileEnvShSt st fs = ((0,sgr,cgr,eenv),fts) 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 dropExtension fs - notIns i = notElem (prt i) $ map dropExtension fs - fts = readFiles st - eenv = evalEnv st - -pathListOpts :: Options -> FileName -> IO [InitPath] -pathListOpts opts file = return $ maybe [file] splitInModuleSearchPath $ 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,EEnv) - -emptyCompileEnv :: TimedCompileEnv -emptyCompileEnv = ((0,emptyMGrammar,emptyMGrammar,emptyEEnv),[]) - -extendCompileEnvInt ((_,MGrammar ss, MGrammar cs,_),fts) (k,sm,cm) eenv ft = - return ((k,MGrammar (sm:ss), MGrammar (cm:cs),eenv),ft++fts) --- reverse later - -extendCompileEnv e@((k,_,_,_),_) (sm,cm) = extendCompileEnvInt e (k,sm,cm) - -extendCompileEnvCanon ((k,s,c,e),fts) cgr eenv ft = - return ((k,s, MGrammar (modules cgr ++ modules c),eenv),ft++fts) - -type TimedCompileEnv = (CompileEnv,[(String,(FilePath,ModTime))]) - -compileOne :: Options -> TimedCompileEnv -> FullPath -> IOE TimedCompileEnv -compileOne opts env@((_,srcgr,cancgr0,eenv),_) file = do - - let putp = putPointE opts - let putpp = putPointEsil opts - let putpOpt v m act - | oElem beVerbose opts = putp v act - | oElem beSilent opts = putpp v act - | otherwise = ioeIO (putStrFlush m) >> act - - let gf = takeExtensions file - let path = dropFileName file - let name = dropExtension file - let mos = modules srcgr - - case gf of - -- for multilingual canonical gf, just read the file and update environment - ".gfcm" -> do - cgr <- putp ("+ reading" +++ file) $ getCanonGrammar file - ft <- getReadTimes file - extendCompileEnvCanon env cgr eenv ft - - -- for canonical gf, read the file and update environment, also source env - ".gfc" -> do - cm <- putp ("+ reading" +++ file) $ getCanonModule file - let cancgr = updateMGrammar (MGrammar [cm]) cancgr0 - sm <- ioeErr $ CG.canon2sourceModule $ unoptimizeCanonMod cancgr $ unSubelimModule cm - ft <- getReadTimes file - extendCompileEnv env (sm, cm) eenv ft - - -- for compiled resource, parse and organize, then update environment - ".gfr" -> do - sm0 <- putp ("| reading" +++ file) $ getSourceModule opts file - let sm1 = unsubexpModule sm0 - sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule mos sm1 ----- experiment with not optimizing gfr ----- sm:_ <- putp " optimizing " $ ioeErr $ evalModule mos sm1 - let gfc = gfcFile name - cm <- putp ("+ reading" +++ gfc) $ getCanonModule gfc - ft <- getReadTimes file - extendCompileEnv env (sm,cm) eenv ft - - -- for gf source, do full compilation - - _ -> do - - --- hack fix to a bug in ReadFiles with reused concrete - - let modu = dropExtension file - b1 <- ioeIO $ doesFileExist file - b2 <- ioeIO $ doesFileExist $ gfrFile modu - if not b1 - then if b2 - then compileOne opts env $ gfrFile $ modu - else compileOne opts env $ gfcFile $ modu - else do - - sm0 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ - getSourceModule opts file - (k',sm,eenv') <- makeSourceModule opts (fst env) sm0 - cm <- putpp " generating code... " $ generateModuleCode opts path sm - ft <- getReadTimes file - - sm':_ <- case snd sm of ----- ModMod n | isModRes n -> putp " optimizing " $ ioeErr $ evalModule mos sm - _ -> return [sm] - - extendCompileEnvInt env (k',sm',cm) eenv' ft - --- | dispatch reused resource at early stage -makeSourceModule :: Options -> CompileEnv -> - SourceModule -> IOE (Int,SourceModule,EEnv) -makeSourceModule opts env@(k,gr,can,eenv) mo@(i,mi) = case mi of - - ModMod m -> case mtype m of - MTReuse c -> do - sm <- ioeErr $ makeReuse gr i (extend m) c - let mo2 = (i, ModMod sm) - mos = modules gr - --- putp " type checking reused" $ ioeErr $ showCheckModule mos mo2 - return $ (k,mo2,eenv) -{- ---- obsolete - 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,EEnv) -compileSourceModule opts env@(k,gr,can,eenv) mo@(i,mi) = do - - let putp = putPointE opts - putpp = putPointEsil opts - mos = modules gr - - if (oElem showOld opts && oElem emitCode opts) - then do - let (file,out) = (gfFile (prt i), prGrammar (MGrammar [mo])) - putp (" wrote file" +++ file) $ ioeIO $ writeFile file out - else return () - - mo1 <- ioeErr $ rebuildModule mos mo - - mo1b <- ioeErr $ extendModule mos mo1 - - case mo1b of - (_,ModMod n) | not (isCompleteModule n) -> do - return (k,mo1b,eenv) -- refresh would fail, since not renamed - _ -> do - mo2:_ <- putpp " renaming " $ ioeErr $ renameModule mos mo1b - - (mo3:_,warnings) <- putpp " type checking" $ ioeErr $ showCheckModule mos mo2 - if null warnings then return () else putp warnings $ return () - - (k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3 - - (mo4,eenv') <- - ---- if oElem "check_only" opts - putpp " optimizing " $ ioeErr $ optimizeModule opts (mos,eenv) mo3r - return (k',mo4,eenv') - 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 - ---- DEPREC ---- if oElem (iOpt "gfcc") opts ---- then ioeIO $ putStrLn $ prGrammar2gfcc minfo ---- else return () - - let pname = path </> prt name - minfo0 <- ioeErr $ redModInfo minfo - let oopts = addOptions opts (iOpts (flagsModule minfo)) - optims = maybe "all_subs" id $ getOptVal oopts useOptimizer - optim = takeWhile (/='_') optims - subs = drop 1 (dropWhile (/='_') optims) == "subs" - minfo1 <- return $ - case optim of - "parametrize" -> shareModule paramOpt minfo0 -- parametrization and sharing - "values" -> shareModule valOpt minfo0 -- tables as courses-of-values - "share" -> shareModule shareOpt minfo0 -- sharing of branches - "all" -> shareModule allOpt minfo0 -- first parametrize then values - "none" -> minfo0 -- no optimization - _ -> shareModule shareOpt minfo0 -- sharing; default - - -- do common subexpression elimination if required by flag "subs" - minfo' <- - if subs - then ioeErr $ elimSubtermsMod minfo1 - else return minfo1 - - -- for resource, also emit gfr. - --- Also for incomplete, to create timestamped gfc/gfr files - case info of - ModMod m | emitsGFR m && emit && nomulti -> do - let rminfo = if isCompilable info - then subexpModule minfo - else (name, ModMod emptyModule) - let (file,out) = (gfrFile pname, prGrammar (MGrammar [rminfo])) - putp (" wrote file" +++ file) $ ioeIO $ writeFile file $ compactPrint out - _ -> return () - let encode = case getOptVal opts uniCoding of - Just "utf8" -> encodeUTF8 - _ -> id - (file,out) <- do - code <- return $ MkGFC.prCanonModInfo minfo' - return (gfcFile pname, encode code) - if emit && nomulti ---- && isCompilable info - then putp (" wrote file" +++ file) $ ioeIO $ writeFile file out - else putpp ("no need to save module" +++ prt name) $ return () - return minfo' - where - putp = putPointE opts - putpp = putPointEsil opts - - 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) - --- 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 - ---- this function duplicates a lot of code from compileModule. ---- It does not really belong here either. --- It selects those .gfe files that a grammar depends on and that --- are younger than corresponding gf - -getGFEFiles :: Options -> FilePath -> IO [FilePath] -getGFEFiles opts1 file = useIOE [] $ 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 (map (combine fpath) ps0) - else ps0 - ps <- ioeIO $ extendPathEnv ps1 - let file' = if useFileOpt then takeFileName file else file -- to find file itself - files <- getAllFiles opts ps [] file' - efiles <- ioeIO $ filterM doesFileExist [replaceExtension f "gfe" | f <- files] - es <- ioeIO $ mapM (uncurry selectLater) [(f, init f) | f <- efiles] -- init gfe == gf - return $ filter ((=='e') . last) es |