From 58a87653cc5f03f8184faa81fa24c2c5eff0429a Mon Sep 17 00:00:00 2001 From: aarne Date: Thu, 20 Sep 2007 22:37:09 +0000 Subject: [PATCH] compiler "gfc" in GF/Devel --- src/GF/Devel/Arch.hs | 89 +++++++ src/GF/Devel/Compile.hs | 218 ++++++++++++++++ src/GF/Devel/GFC.hs | 20 ++ src/GF/Devel/GetGrammar.hs | 54 ++++ src/GF/Devel/GrammarToGFCC.hs | 471 ++++++++++++++++++++++++++++++++++ src/GF/Devel/PrGrammar.hs | 233 +++++++++++++++++ src/GF/Devel/ReadFiles.hs | 356 +++++++++++++++++++++++++ src/GF/Devel/UseIO.hs | 344 +++++++++++++++++++++++++ 8 files changed, 1785 insertions(+) create mode 100644 src/GF/Devel/Arch.hs create mode 100644 src/GF/Devel/Compile.hs create mode 100644 src/GF/Devel/GFC.hs create mode 100644 src/GF/Devel/GetGrammar.hs create mode 100644 src/GF/Devel/GrammarToGFCC.hs create mode 100644 src/GF/Devel/PrGrammar.hs create mode 100644 src/GF/Devel/ReadFiles.hs create mode 100644 src/GF/Devel/UseIO.hs diff --git a/src/GF/Devel/Arch.hs b/src/GF/Devel/Arch.hs new file mode 100644 index 000000000..dedb1b4f5 --- /dev/null +++ b/src/GF/Devel/Arch.hs @@ -0,0 +1,89 @@ +---------------------------------------------------------------------- +-- | +-- Module : Arch +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/05/10 14:55:01 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.8 $ +-- +-- architecture\/compiler dependent definitions for unix\/hbc +----------------------------------------------------------------------------- + +module GF.Devel.Arch ( + myStdGen, prCPU, selectLater, modifiedFiles, ModTime, getModTime,getNowTime, + welcomeArch, laterModTime) where + +import System.Time +import System.Random +import System.CPUTime +import Control.Monad (filterM) +import System.Directory + + +---- import qualified UnicodeF as U --(fudlogueWrite) + +-- architecture/compiler dependent definitions for unix/hbc + +myStdGen :: Int -> IO StdGen --- +--- myStdGen _ = newStdGen --- gives always the same result +myStdGen int0 = do + t0 <- getClockTime + cal <- toCalendarTime t0 + let int = int0 + ctSec cal + fromInteger (div (ctPicosec cal) 10000000) + return $ mkStdGen int + +prCPU :: Integer -> IO Integer +prCPU cpu = do + cpu' <- getCPUTime + putStrLn (show ((cpu' - cpu) `div` 1000000000) ++ " msec") + return cpu' + +welcomeArch :: String +welcomeArch = "This is the system compiled with ghc." + +-- | selects the one with the later modification time of two +selectLater :: FilePath -> FilePath -> IO FilePath +selectLater x y = do + ex <- doesFileExist x + if not ex + then return y --- which may not exist + else do + ey <- doesFileExist y + if not ey + then return x + else do + tx <- getModificationTime x + ty <- getModificationTime y + return $ if tx < ty then y else x + +-- | a file is considered modified also if it has not been read yet +-- +-- new 23\/2\/2004: the environment ofs has just module names +modifiedFiles :: [(FilePath,ModTime)] -> [FilePath] -> IO [FilePath] +modifiedFiles ofs fs = do + filterM isModified fs + where + isModified file = case lookup (justModName file) ofs of + Just to -> do + t <- getModificationTime file + return $ to < t + _ -> return True + + justModName = + reverse . takeWhile (/='/') . tail . dropWhile (/='.') . reverse + +type ModTime = ClockTime + +laterModTime :: ModTime -> ModTime -> Bool +laterModTime = (>) + +getModTime :: FilePath -> IO (Maybe ModTime) +getModTime f = do + b <- doesFileExist f + if b then (getModificationTime f >>= return . Just) else return Nothing + +getNowTime :: IO ModTime +getNowTime = getClockTime diff --git a/src/GF/Devel/Compile.hs b/src/GF/Devel/Compile.hs new file mode 100644 index 000000000..0649760fe --- /dev/null +++ b/src/GF/Devel/Compile.hs @@ -0,0 +1,218 @@ +module GF.Devel.Compile (batchCompile) where + +import GF.Grammar.Grammar +import GF.Infra.Ident +import GF.Infra.Option +import GF.Infra.CompactPrint +import GF.Devel.PrGrammar +import GF.Compile.Update +import GF.Grammar.Lookup +import GF.Infra.Modules +import GF.Devel.ReadFiles +--import GF.Compile.ShellState +--import GF.Compile.MkResource + +-- the main compiler passes +import GF.Devel.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.Compile.GrammarToGFCC ----- +--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.Devel.UseIO +import GF.Devel.Arch + +import Control.Monad +import System.Directory + +batchCompile :: [FilePath] -> IO SourceGrammar +batchCompile files = do + let defOpts = options [emitCode] + Ok (_,gr) <- appIOE $ foldM (compileModule defOpts) emptyCompileEnv files + return gr + +-- | environment variable for grammar search path +gfGrammarPathVar = "GF_GRAMMAR_PATH" + +-- | the environment +type CompileEnv = (Int,SourceGrammar) + +-- | 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 = justInitPath file + ps0 <- ioeIO $ pathListOpts opts fpath + + let ps1 = if (useFileOpt && not useLineOpt) + then (ps0 ++ map (prefixPathName fpath) ps0) + else ps0 + ps <- ioeIO $ extendPathEnv gfLibraryPath gfGrammarPathVar ps1 + let ioeIOIf = if oElem beVerbose opts then ioeIO else (const (return ())) + ioeIOIf $ putStrLn $ "module search path:" +++ show ps ---- + let st = env + let rfs = [] ---- files already in memory and their read times + let file' = if useFileOpt then justFileName 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 + +compileEnvShSt :: CompileEnv -> [ModName] -> CompileEnv +compileEnvShSt env@(_,sgr) fs = (0,sgr) where + sgr = MGrammar [m | m@(i,_) <- modules sgr, notElem (prt i) $ map fileBody fs] + +compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv +compileOne opts env@(_,srcgr) file = do + + let putp s = putPointE opts (s ++ "\n") + 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 = fileSuffix file + let path = justInitPath file + let name = fileBody file + let mos = modules srcgr + + case gf of + + -- for compiled gf, read the file and update environment, also source env + "gfc" -> do + sm0 <- putp ("+ reading" +++ file) $ getSourceModule opts file + sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule mos sm0 + extendCompileEnv env sm + + -- for gf source, do full compilation + _ -> do + + let modu = unsuffixFile file + b1 <- ioeIO $ doesFileExist file + if not b1 + then compileOne opts env $ gfcFile $ modu + else do + + sm0 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ + getSourceModule opts file + (k',sm) <- compileSourceModule opts env sm0 + cm <- putpp " generating code... " $ generateModuleCode opts path sm + + extendCompileEnvInt env (k',sm) + + +compileSourceModule :: Options -> CompileEnv -> + SourceModule -> IOE (Int,SourceModule) +compileSourceModule opts env@(k,gr) mo@(i,mi) = do + + let putp = putPointE opts + putpp = putPointEsil opts + mos = modules gr + + 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:_ <- 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 + + let eenv = emptyEEnv + (mo4,eenv') <- + ---- if oElem "check_only" opts + putpp " optimizing " $ ioeErr $ optimizeModule opts (mos,eenv) 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 SourceModule +generateModuleCode opts path minfo@(name,info) = do + + let pname = prefixPathName path (prt name) + let minfo0 = minfo + let minfo1 = minfo + let minfo2 = minfo + +{- ---- restore optimizations! + 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" + minfo2 <- + if subs + then ioeErr $ elimSubtermsMod minfo1 + else return minfo1 +-} + + let (file,out) = (gfcFile pname, prGrammar (MGrammar [minfo2])) + putp (" wrote file" +++ file) $ ioeIO $ writeFile file $ compactPrint out + + return minfo2 + where + putp = putPointE opts + putpp = putPointEsil opts + isCompilable mi = case mi of + ModMod m -> not $ isModCnc m && mstatus m == MSIncomplete + _ -> True + + +-- auxiliaries + +pathListOpts :: Options -> FileName -> IO [InitPath] +pathListOpts opts file = return $ maybe [file] pFilePaths $ getOptVal opts pathList + +reverseModules (MGrammar ms) = MGrammar $ reverse ms + +emptyCompileEnv :: CompileEnv +emptyCompileEnv = (0,emptyMGrammar) + +extendCompileEnvInt (_,MGrammar ss) (k,sm) = + return (k,MGrammar (sm:ss)) --- reverse later + +extendCompileEnv e@(k,_) sm = extendCompileEnvInt e (k,sm) + + diff --git a/src/GF/Devel/GFC.hs b/src/GF/Devel/GFC.hs new file mode 100644 index 000000000..561d37060 --- /dev/null +++ b/src/GF/Devel/GFC.hs @@ -0,0 +1,20 @@ +module Main where + +import GF.Devel.Compile +import GF.Devel.GrammarToGFCC + +import System + + +main = do + xx <- getArgs + case xx of + "-help":[] -> putStrLn "usage: gfc (--make) FILES" + "--make":fs -> do + gr <- batchCompile fs + putStrLn $ prGrammar2gfcc gr --- +--- writeFile "a.gfcc" $ prGrammar2gfcc gr +--- putStrLn "wrote file a.gfcc" + _ -> do + mapM_ batchCompile (map return xx) + putStrLn "Done." diff --git a/src/GF/Devel/GetGrammar.hs b/src/GF/Devel/GetGrammar.hs new file mode 100644 index 000000000..49546b6ea --- /dev/null +++ b/src/GF/Devel/GetGrammar.hs @@ -0,0 +1,54 @@ +---------------------------------------------------------------------- +-- | +-- Module : GetGrammar +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/15 17:56:13 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.16 $ +-- +-- this module builds the internal GF grammar that is sent to the type checker +----------------------------------------------------------------------------- + +module GF.Devel.GetGrammar where + +import GF.Data.Operations +import qualified GF.Data.ErrM as E ---- + +import GF.Devel.UseIO +import GF.Grammar.Grammar +import GF.Infra.Modules +import GF.Devel.PrGrammar +import qualified GF.Source.AbsGF as A +import GF.Source.SourceToGrammar +---- import Macros +---- import Rename +import GF.Infra.Option +--- import Custom +import GF.Source.ParGF +import qualified GF.Source.LexGF as L + +import GF.Devel.ReadFiles ---- + +import Data.Char (toUpper) +import Data.List (nub) +import Control.Monad (foldM) +import System (system) + +getSourceModule :: Options -> FilePath -> IOE SourceModule +getSourceModule opts file0 = do + file <- case getOptVal opts usePreprocessor of + Just p -> do + let tmp = "_gf_preproc.tmp" + cmd = p +++ file0 ++ ">" ++ tmp + ioeIO $ system cmd + -- ioeIO $ putStrLn $ "preproc" +++ cmd + return tmp + _ -> return file0 + string <- readFileIOE file + let tokens = myLexer string + mo1 <- ioeErr $ {- err2err $ -} pModDef tokens + ioeErr $ transModDef mo1 + diff --git a/src/GF/Devel/GrammarToGFCC.hs b/src/GF/Devel/GrammarToGFCC.hs new file mode 100644 index 000000000..a6dabae1a --- /dev/null +++ b/src/GF/Devel/GrammarToGFCC.hs @@ -0,0 +1,471 @@ +module GF.Devel.GrammarToGFCC (prGrammar2gfcc) where + +import GF.Grammar.Grammar +import qualified GF.Grammar.Lookup as Look + +import qualified GF.Canon.GFCC.AbsGFCC as C +import qualified GF.Canon.GFCC.PrintGFCC as Pr +import qualified GF.Grammar.Abstract as A +import qualified GF.Grammar.Macros as GM +import qualified GF.Infra.Modules as M +import qualified GF.Infra.Option as O + +import GF.Infra.Ident +import GF.Data.Operations +import GF.Text.UTF8 + +import Data.List +import qualified Data.Map as Map +import Debug.Trace ---- + +-- the main function: generate GFCC from GF. + +prGrammar2gfcc :: SourceGrammar-> String +prGrammar2gfcc = Pr.printTree . mkCanon2gfcc + +mkCanon2gfcc :: SourceGrammar -> C.Grammar +mkCanon2gfcc = canon2gfcc . reorder . utf8Conv . canon2canon + +-- This is needed to reorganize the grammar. GFCC has its own back-end optimization. +-- But we need to have the canonical order in tables, created by valOpt + +-- Generate GFCC from GFCM. +-- this assumes a grammar translated by canon2canon + +canon2gfcc :: SourceGrammar -> C.Grammar +canon2gfcc cgr@(M.MGrammar ((a,M.ModMod abm):cms)) = + C.Grm (C.Hdr (i2i a) cs) (C.Abs adefs) cncs where + cs = map (i2i . fst) cms + adefs = [C.Fun f' (mkType ty) (C.Tr (C.AC f') []) | + (f,AbsFun (Yes ty) _) <- tree2list (M.jments abm), let f' = i2i f] + cncs = [C.Cnc (i2i a) (concr abm)] + concr mo = cats mo ++ lindefs mo ++ + optConcrete + [C.Lin (i2i f) (mkTerm tr) | + (f,CncFun _ (Yes tr) _) <- tree2list (M.jments mo)] + cats mo = [C.Lin (i2ic c) (mkCType ty) | + (c,CncCat (Yes ty) _ _) <- tree2list (M.jments mo)] + lindefs mo = [C.Lin (i2id c) (mkTerm tr) | + (c,CncCat _ (Yes tr) _) <- tree2list (M.jments mo)] + +i2i :: Ident -> C.CId +i2i (IC c) = C.CId c +i2ic (IC c) = C.CId ("__" ++ c) -- for lincat of category symbols +i2id (IC c) = C.CId ("_d" ++ c) -- for lindef of category symbols + +mkType :: A.Type -> C.Type +mkType t = case GM.catSkeleton t of + Ok (cs,c) -> C.Typ (map (i2i . snd) cs) (i2i $ snd c) + +mkCType :: Type -> C.Term +mkCType t = case t of + EInt i -> C.C $ fromInteger i + -- record parameter alias - created in gfc preprocessing + RecType [(LIdent "_", i), (LIdent "__", t)] -> C.RP (mkCType i) (mkCType t) + RecType rs -> C.R [mkCType t | (_, t) <- rs] + Table pt vt -> C.R $ replicate (getI (mkCType pt)) $ mkCType vt + _ -> C.S [] ----- TStr + where + getI pt = case pt of + C.C i -> i + C.RP i _ -> getI i + _ -> 1 ----- + +mkTerm :: Term -> C.Term +mkTerm tr = case tr of + Vr (IA (_,i)) -> C.V i + EInt i -> C.C $ fromInteger i + -- record parameter alias - created in gfc preprocessing + R [(LIdent "_", (_,i)), (LIdent "__", (_,t))] -> C.RP (mkTerm i) (mkTerm t) + -- ordinary record + R rs -> C.R [mkTerm t | (_, (_,t)) <- rs] + P t l -> C.P (mkTerm t) (C.C (mkLab l)) + +----- LI x -> C.BV $ i2i x +----- T _ [(PV x, t)] -> C.L (i2i x) (mkTerm t) + + T _ cs -> C.R [mkTerm t | (_,t) <- cs] ------ + V _ cs -> C.R [mkTerm t | t <- cs] + S t p -> C.P (mkTerm t) (mkTerm p) + C s t -> C.S [mkTerm x | x <- [s,t]] + FV ts -> C.FV [mkTerm t | t <- ts] + K s -> C.K (C.KS s) +----- K (KP ss _) -> C.K (C.KP ss []) ---- TODO: prefix variants + Empty -> C.S [] + App _ _ -> prtTrace tr $ C.C 66661 ---- for debugging + Abs _ t -> mkTerm t ---- only on toplevel + _ -> C.S [C.K (C.KS (A.prt tr +++ "66662"))] ---- for debugging + where + mkLab (LIdent l) = case l of + '_':ds -> (read ds) :: Int + _ -> prtTrace tr $ 66663 + +-- return just one module per language + +reorder :: SourceGrammar -> SourceGrammar +reorder cg = M.MGrammar $ + (abs, M.ModMod $ + M.Module M.MTAbstract M.MSComplete [] [] [] adefs): + [(c, M.ModMod $ + M.Module (M.MTConcrete abs) M.MSComplete [] [] [] (sorted2tree js)) + | (c,js) <- cncs] + where + abs = maybe (error "no abstract") id $ M.greatestAbstract cg + mos = M.allModMod cg + adefs = + sorted2tree $ sortBy (\ (f,_) (g,_) -> compare f g) + [finfo | + (i,mo) <- M.allModMod cg, M.isModAbs mo, + finfo <- tree2list (M.jments mo)] + cncs = sortBy (\ (x,_) (y,_) -> compare x y) + [(lang, concr lang) | lang <- M.allConcretes cg abs] + concr la = sortBy (\ (f,_) (g,_) -> compare f g) + [finfo | + (i,mo) <- mos, M.isModCnc mo, elem i (M.allExtends cg la), + finfo <- tree2list (M.jments mo)] + +-- one grammar per language - needed for symtab generation +repartition :: SourceGrammar -> [SourceGrammar] +repartition cg = [M.partOfGrammar cg (lang,mo) | + let abs = maybe (error "no abstract") id $ M.greatestAbstract cg, + let mos = M.allModMod cg, + lang <- M.allConcretes cg abs, + let mo = errVal + (error ("no module found for " ++ A.prt lang)) $ M.lookupModule cg lang + ] + +-- convert to UTF8 if not yet converted +utf8Conv :: SourceGrammar -> SourceGrammar +utf8Conv = M.MGrammar . map toUTF8 . M.modules where + toUTF8 mo = case mo of + (i, M.ModMod m) + ----- | hasFlagCanon (flagCanon "coding" "utf8") mo -> mo + | otherwise -> (i, M.ModMod $ + m{ M.jments = M.jments m ----- +----- mapTree (onSnd (mapInfoTerms (onTokens encodeUTF8))) (M.jments m), + ----- M.flags = setFlag "coding" "utf8" (M.flags m) + } + ) + _ -> mo + + +-- translate tables and records to arrays, parameters and labels to indices + +canon2canon :: SourceGrammar -> SourceGrammar +canon2canon = recollect . map cl2cl . repartition where + recollect = + M.MGrammar . nubBy (\ (i,_) (j,_) -> i==j) . concatMap M.modules + cl2cl cg = tr $ M.MGrammar $ map c2c $ M.modules cg where + c2c (c,m) = case m of + M.ModMod mo@(M.Module _ _ _ _ _ js) -> + (c, M.ModMod $ M.replaceJudgements mo $ mapTree j2j js) + _ -> (c,m) + j2j (f,j) = case j of + CncFun x (Yes tr) z -> (f,CncFun x (Yes (t2t tr)) z) + CncCat (Yes ty) (Yes x) y -> (f,CncCat (Yes (ty2ty ty)) (Yes (t2t x)) y) + _ -> (f,j) + t2t = term2term cg pv + ty2ty = type2type cg pv + pv@(labels,untyps,typs) = paramValues cg + tr = trace $ + (unlines [A.prt c ++ "." ++ unwords (map A.prt l) +++ "=" +++ show i | + ((c,l),i) <- Map.toList labels]) ++ + (unlines [A.prt t +++ "=" +++ show i | + (t,i) <- Map.toList untyps]) ++ + (unlines [A.prt t | + (t,_) <- Map.toList typs]) + +type ParamEnv = + (Map.Map (Ident,[Label]) (Type,Integer), -- numbered labels + Map.Map Term Integer, -- untyped terms to values + Map.Map Type (Map.Map Term Integer)) -- types to their terms to values + +--- gathers those param types that are actually used in lincats and in lin terms +paramValues :: SourceGrammar -> ParamEnv +paramValues cgr = (labels,untyps,typs) where + params = [(ty, errVal [] $ Look.allParamValues cgr ty) | ty <- partyps] + partyps = nub $ [ty | + (_,(_,CncCat (Yes (RecType ls)) _ _)) <- jments, + ty0 <- [ty | (_, ty) <- unlockTyp ls], + ty <- typsFrom ty0 + ] ++ [ + Q m ty | + (m,(ty,ResParam _)) <- jments + ] ++ [ty | + (_,(_,CncFun _ (Yes tr) _)) <- jments, + ty <- err (const []) snd $ appSTM (typsFromTrm tr) [] + ] + typsFrom ty = case ty of + Table p t -> typsFrom p ++ typsFrom t + RecType ls -> RecType (unlockTyp ls) : concat [typsFrom t | (_, t) <- ls] + _ -> [ty] + + typsFromTrm :: Term -> STM [Type] Term + typsFromTrm tr = case tr of + V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr + T (TTyped ty) cs -> updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr + _ -> GM.composOp typsFromTrm tr + + + jments = [(m,j) | (m,mo) <- M.allModMod cgr, j <- tree2list $ M.jments mo] + typs = Map.fromList [(ci,Map.fromList (zip vs [0..])) | (ci,vs) <- params] + untyps = Map.fromList $ concatMap Map.toList [typ | (_,typ) <- Map.toList typs] + lincats = + [(IC cat,[(LIdent "s",GM.typeStr)]) | cat <- ["Int", "Float", "String"]] ++ + [(cat,(unlockTyp ls)) | (_,(cat,CncCat (Yes (RecType ls)) _ _)) <- jments] + labels = Map.fromList $ concat + [((cat,[lab]),(typ,i)): + [((cat,[lab,lab2]),(ty,j)) | + rs <- getRec typ, ((lab2, ty),j) <- zip rs [0..]] + | + (cat,ls) <- lincats, ((lab, typ),i) <- zip ls [0..]] + -- go to tables recursively + ---- TODO: even go to deeper records + where + getRec typ = case typ of + RecType rs -> [rs] + Table _ t -> getRec t + _ -> [] + +type2type :: SourceGrammar -> ParamEnv -> Type -> Type +type2type cgr env@(labels,untyps,typs) ty = case ty of + RecType rs -> + let + rs' = [(mkLab i, t2t t) | + (i,(l, t)) <- zip [0..] (unlockTyp rs)] + in if (any isStrType [t | (_, t) <- rs]) + then RecType rs' + else RecType [(LIdent "_", look ty), (LIdent "__", RecType rs')] + + Table pt vt -> Table (t2t pt) (t2t vt) + Cn _ -> look ty + _ -> ty + where + t2t = type2type cgr env + look ty = EInt $ toInteger $ case Map.lookup ty typs of + Just vs -> length $ Map.assocs vs + _ -> trace ("unknown partype " ++ show ty) 1 ---- 66669 + +term2term :: SourceGrammar -> ParamEnv -> Term -> Term +term2term cgr env@(labels,untyps,typs) tr = case tr of + App _ _ -> mkValCase tr + QC _ _ -> mkValCase tr + R rs -> + let + rs' = [(mkLab i, (Nothing, t2t t)) | + (i,(l,(_,t))) <- zip [0..] (unlock rs)] + in if (any (isStr . trmAss) rs) + then R rs' + else R [(LIdent "_", (Nothing, mkValCase tr)), (LIdent "__",(Nothing,R rs'))] + P t l -> r2r tr + PI t l i -> EInt $ toInteger i + +----- T ti [Cas ps@[PV _] t] -> T ti [Cas ps (t2t t)] + + T (TTyped ty) cs -> V ty [t2t t | (_, t) <- cs] + ---- _ -> K (KS (A.prt tr +++ prtTrace tr "66668")) + V ty ts -> V ty [t2t t | t <- ts] + S t p -> S (t2t t) (t2t p) + _ -> GM.composSafeOp t2t tr + where + t2t = term2term cgr env + + r2r tr@(P (S (V ty ts) v) l) = t2t $ S (V ty [comp (P t l) | t <- ts]) v + + r2r tr@(P p _) = case getLab tr of + Ok (cat,labs) -> P (t2t p) . mkLab $ maybe (prtTrace tr $ 66664) snd $ + Map.lookup (cat,labs) labels + _ -> K ((A.prt tr +++ prtTrace tr "66665")) + + -- this goes recursively into tables (ignored) and records (accumulated) + getLab tr = case tr of + Vr (IA (cat, _)) -> return (identC cat,[]) + P p lab2 -> do + (cat,labs) <- getLab p + return (cat,labs++[lab2]) + S p _ -> getLab p + _ -> Bad "getLab" + + doVar :: Term -> STM [((Type,[Term]),(Term,Term))] Term + doVar tr = case getLab tr of + Ok (cat, lab) -> do + k <- readSTM >>= return . length + let tr' = Vr $ identC $ show k ----- + + let tyvs = case Map.lookup (cat,lab) labels of + Just (ty,_) -> case Map.lookup ty typs of + Just vs -> (ty,[t | + (t,_) <- sortBy (\x y -> compare (snd x) (snd y)) + (Map.assocs vs)]) + _ -> error $ A.prt ty + _ -> error $ A.prt tr + updateSTM ((tyvs, (tr', tr)):) + return tr' + _ -> GM.composOp doVar tr + + mkValCase tr = case appSTM (doVar tr) [] of + Ok (tr', st@(_:_)) -> t2t $ comp $ foldr mkCase tr' st + _ -> valNum tr + + mkCase ((ty,vs),(x,p)) tr = + S (V ty [mkBranch x v tr | v <- vs]) p + mkBranch x t tr = case tr of + _ | tr == x -> t + _ -> GM.composSafeOp (mkBranch x t) tr + + valNum tr = maybe (tryPerm tr) EInt $ Map.lookup tr untyps + where + tryPerm tr = case tr of + R rs -> case Map.lookup (R rs) untyps of + Just v -> EInt v + _ -> valNumFV $ tryVar tr + _ -> valNumFV $ tryVar tr + tryVar tr = case tr of +----- Par c ts -> [Par c ts' | ts' <- combinations (map tryVar ts)] + FV ts -> ts + _ -> [tr] + valNumFV ts = case ts of + [tr] -> EInt 66667 ----K (KS (A.prt tr +++ prtTrace tr "66667")) + _ -> FV $ map valNum ts + isStr tr = case tr of + App _ _ -> False + EInt _ -> False + R rs -> any (isStr . trmAss) rs + FV ts -> any isStr ts + S t _ -> isStr t + Empty -> True + T _ cs -> any isStr [v | (_, v) <- cs] + V _ ts -> any isStr ts + P t r -> case getLab tr of + Ok (cat,labs) -> case + Map.lookup (cat,labs) labels of + Just (ty,_) -> isStrType ty + _ -> True ---- TODO? + _ -> True + _ -> True ---- + trmAss (_,(_, t)) = t + + --- this is mainly needed for parameter record projections + comp t = t ----- $ Look.ccompute cgr [] t + +isStrType ty = case ty of + Sort "Str" -> True + RecType ts -> any isStrType [t | (_, t) <- ts] + Table _ t -> isStrType t + _ -> False + +mkLab k = LIdent (("_" ++ show k)) + +-- remove lock fields; in fact, any empty records and record types +unlock = filter notlock where + notlock (l,(_, t)) = case t of --- need not look at l + R [] -> False + _ -> True +unlockTyp = filter notlock where + notlock (l, t) = case t of --- need not look at l + RecType [] -> False + _ -> True + + +prtTrace tr n = n ----trace ("-- ERROR" +++ A.prt tr +++ show n +++ show tr) n +prTrace tr n = trace ("-- OBSERVE" +++ A.prt tr +++ show n +++ show tr) n + +-- back-end optimization: +-- suffix analysis followed by common subexpression elimination + +optConcrete :: [C.CncDef] -> [C.CncDef] +optConcrete defs = subex + [C.Lin f (optTerm t) | C.Lin f t <- defs] + +-- analyse word form lists into prefix + suffixes +-- suffix sets can later be shared by subex elim + +optTerm :: C.Term -> C.Term +optTerm tr = case tr of + C.R ts@(_:_:_) | all isK ts -> mkSuff $ optToks [s | C.K (C.KS s) <- ts] + C.R ts -> C.R $ map optTerm ts + C.P t v -> C.P (optTerm t) v + C.L x t -> C.L x (optTerm t) + _ -> tr + where + optToks ss = prf : suffs where + prf = pref (head ss) (tail ss) + suffs = map (drop (length prf)) ss + pref cand ss = case ss of + s1:ss2 -> if isPrefixOf cand s1 then pref cand ss2 else pref (init cand) ss + _ -> cand + isK t = case t of + C.K (C.KS _) -> True + _ -> False + mkSuff ("":ws) = C.R (map (C.K . C.KS) ws) + mkSuff (p:ws) = C.W p (C.R (map (C.K . C.KS) ws)) + + +-- common subexpression elimination; see ./Subexpression.hs for the idea + +subex :: [C.CncDef] -> [C.CncDef] +subex js = errVal js $ do + (tree,_) <- appSTM (getSubtermsMod js) (Map.empty,0) + return $ addSubexpConsts tree js + +type TermList = Map.Map C.Term (Int,Int) -- number of occs, id +type TermM a = STM (TermList,Int) a + +addSubexpConsts :: TermList -> [C.CncDef] -> [C.CncDef] +addSubexpConsts tree lins = + let opers = sortBy (\ (C.Lin f _) (C.Lin g _) -> compare f g) + [C.Lin (fid id) trm | (trm,(_,id)) <- list] + in map mkOne $ opers ++ lins + where + mkOne (C.Lin f trm) = (C.Lin f (recomp f trm)) + recomp f t = case Map.lookup t tree of + Just (_,id) | fid id /= f -> C.F $ fid id -- not to replace oper itself + _ -> case t of + C.R ts -> C.R $ map (recomp f) ts + C.S ts -> C.S $ map (recomp f) ts + C.W s t -> C.W s (recomp f t) + C.P t p -> C.P (recomp f t) (recomp f p) + C.RP t p -> C.RP (recomp f t) (recomp f p) + C.L x t -> C.L x (recomp f t) + _ -> t + fid n = C.CId $ "_" ++ show n + list = Map.toList tree + +getSubtermsMod :: [C.CncDef] -> TermM TermList +getSubtermsMod js = do + mapM (getInfo collectSubterms) js + (tree0,_) <- readSTM + return $ Map.filter (\ (nu,_) -> nu > 1) tree0 + where + getInfo get (C.Lin f trm) = do + get trm + return () + +collectSubterms :: C.Term -> TermM () +collectSubterms t = case t of + C.R ts -> do + mapM collectSubterms ts + add t + C.RP u v -> do + collectSubterms v + add t + C.S ts -> do + mapM collectSubterms ts + add t + C.W s u -> do + collectSubterms u + add t + C.P p u -> do + collectSubterms p + collectSubterms u + add t + _ -> return () + where + add t = do + (ts,i) <- readSTM + let + ((count,id),next) = case Map.lookup t ts of + Just (nu,id) -> ((nu+1,id), i) + _ -> ((1, i ), i+1) + writeSTM (Map.insert t (count,id) ts, next) + diff --git a/src/GF/Devel/PrGrammar.hs b/src/GF/Devel/PrGrammar.hs new file mode 100644 index 000000000..44d1c3200 --- /dev/null +++ b/src/GF/Devel/PrGrammar.hs @@ -0,0 +1,233 @@ +---------------------------------------------------------------------- +-- | +-- Module : PrGrammar +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/09/04 11:45:38 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.16 $ +-- +-- AR 7\/12\/1999 - 1\/4\/2000 - 10\/5\/2003 +-- +-- printing and prettyprinting class +-- +-- 8\/1\/2004: +-- Usually followed principle: 'prt_' for displaying in the editor, 'prt' +-- in writing grammars to a file. For some constructs, e.g. 'prMarkedTree', +-- only the former is ever needed. +----------------------------------------------------------------------------- + +module GF.Devel.PrGrammar where + +import GF.Data.Operations +import GF.Data.Zipper +import GF.Grammar.Grammar +import GF.Infra.Modules +import qualified GF.Source.PrintGF as P +import GF.Grammar.Values +import GF.Source.GrammarToSource +--- import GFC (CanonGrammar) --- cycle of modules + +import GF.Infra.Option +import GF.Infra.Ident +import GF.Data.Str + +import Data.List (intersperse) + +class Print a where + prt :: a -> String + -- | printing with parentheses, if needed + prt2 :: a -> String + -- | pretty printing + prpr :: a -> [String] + -- | printing without ident qualifications + prt_ :: a -> String + prt2 = prt + prt_ = prt + prpr = return . prt + +-- 8/1/2004 +--- Usually followed principle: prt_ for displaying in the editor, prt +--- in writing grammars to a file. For some constructs, e.g. prMarkedTree, +--- only the former is ever needed. + +-- | to show terms etc in error messages +prtBad :: Print a => String -> a -> Err b +prtBad s a = Bad (s +++ prt a) + +prGrammar :: SourceGrammar -> String +prGrammar = P.printTree . trGrammar + +prModule :: (Ident, SourceModInfo) -> String +prModule = P.printTree . trModule + +instance Print Term where + prt = P.printTree . trt + prt_ = prExp + +instance Print Ident where + prt = P.printTree . tri + +instance Print Patt where + prt = P.printTree . trp + +instance Print Label where + prt = P.printTree . trLabel + +instance Print MetaSymb where + prt (MetaSymb i) = "?" ++ show i + +prParam :: Param -> String +prParam (c,co) = prt c +++ prContext co + +prContext :: Context -> String +prContext co = unwords $ map prParenth [prt x +++ ":" +++ prt t | (x,t) <- co] + + +-- printing values and trees in editing + +instance Print a => Print (Tr a) where + prt (Tr (n, trees)) = prt n +++ unwords (map prt2 trees) + prt2 t@(Tr (_,args)) = if null args then prt t else prParenth (prt t) + +-- | we cannot define the method prt_ in this way +prt_Tree :: Tree -> String +prt_Tree = prt_ . tree2exp + +instance Print TrNode where + prt (N (bi,at,vt,(cs,ms),_)) = + prBinds bi ++ + prt at +++ ":" +++ prt vt + +++ prConstraints cs +++ prMetaSubst ms + prt_ (N (bi,at,vt,(cs,ms),_)) = + prBinds bi ++ + prt_ at +++ ":" +++ prt_ vt + +++ prConstraints cs +++ prMetaSubst ms + +prMarkedTree :: Tr (TrNode,Bool) -> [String] +prMarkedTree = prf 1 where + prf ind t@(Tr (node, trees)) = + prNode ind node : concatMap (prf (ind + 2)) trees + prNode ind node = case node of + (n, False) -> indent ind (prt_ n) + (n, _) -> '*' : indent (ind - 1) (prt_ n) + +prTree :: Tree -> [String] +prTree = prMarkedTree . mapTr (\n -> (n,False)) + +-- | a pretty-printer for parsable output +tree2string :: Tree -> String +tree2string = unlines . prprTree + +prprTree :: Tree -> [String] +prprTree = prf False where + prf par t@(Tr (node, trees)) = + parIf par (prn node : concat [prf (ifPar t) t | t <- trees]) + prn (N (bi,at,_,_,_)) = prb bi ++ prt_ at + prb [] = "" + prb bi = "\\" ++ concat (intersperse "," (map (prt_ . fst) bi)) ++ " -> " + parIf par (s:ss) = map (indent 2) $ + if par + then ('(':s) : ss ++ [")"] + else s:ss + ifPar (Tr (N ([],_,_,_,_), [])) = False + ifPar _ = True + + +-- auxiliaries + +prConstraints :: Constraints -> String +prConstraints = concat . prConstrs + +prMetaSubst :: MetaSubst -> String +prMetaSubst = concat . prMSubst + +prEnv :: Env -> String +---- prEnv [] = prCurly "" ---- for debugging +prEnv e = concatMap (\ (x,t) -> prCurly (prt x ++ ":=" ++ prt t)) e + +prConstrs :: Constraints -> [String] +prConstrs = map (\ (v,w) -> prCurly (prt v ++ "<>" ++ prt w)) + +prMSubst :: MetaSubst -> [String] +prMSubst = map (\ (m,e) -> prCurly ("?" ++ show m ++ "=" ++ prt e)) + +prBinds bi = if null bi + then [] + else "\\" ++ concat (intersperse "," (map prValDecl bi)) +++ "-> " + where + prValDecl (x,t) = prParenth (prt_ x +++ ":" +++ prt_ t) + +instance Print Val where + prt (VGen i x) = prt x ++ "{-" ++ show i ++ "-}" ---- latter part for debugging + prt (VApp u v) = prt u +++ prv1 v + prt (VCn mc) = prQIdent_ mc + prt (VClos env e) = case e of + Meta _ -> prt_ e ++ prEnv env + _ -> prt_ e ---- ++ prEnv env ---- for debugging + prt VType = "Type" + +prv1 v = case v of + VApp _ _ -> prParenth $ prt v + VClos _ _ -> prParenth $ prt v + _ -> prt v + +instance Print Atom where + prt (AtC f) = prQIdent f + prt (AtM i) = prt i + prt (AtV i) = prt i + prt (AtL s) = prQuotedString s + prt (AtI i) = show i + prt (AtF i) = show i + prt_ (AtC (_,f)) = prt f + prt_ a = prt a + +prQIdent :: QIdent -> String +prQIdent (m,f) = prt m ++ "." ++ prt f + +prQIdent_ :: QIdent -> String +prQIdent_ (_,f) = prt f + +-- | print terms without qualifications +prExp :: Term -> String +prExp e = case e of + App f a -> pr1 f +++ pr2 a + Abs x b -> "\\" ++ prt x +++ "->" +++ prExp b + Prod x a b -> "(\\" ++ prt x +++ ":" +++ prExp a ++ ")" +++ "->" +++ prExp b + Q _ c -> prt c + QC _ c -> prt c + _ -> prt e + where + pr1 e = case e of + Abs _ _ -> prParenth $ prExp e + Prod _ _ _ -> prParenth $ prExp e + _ -> prExp e + pr2 e = case e of + App _ _ -> prParenth $ prExp e + _ -> pr1 e + +-- | option @-strip@ strips qualifications +prTermOpt :: Options -> Term -> String +prTermOpt opts = if oElem nostripQualif opts then prt else prExp + +-- | to get rid of brackets in the editor +prRefinement :: Term -> String +prRefinement t = case t of + Q m c -> prQIdent (m,c) + QC m c -> prQIdent (m,c) + _ -> prt t + +prOperSignature :: (QIdent,Type) -> String +prOperSignature (f, t) = prQIdent f +++ ":" +++ prt t + +-- to look up a constant etc in a search tree + +lookupIdent :: Ident -> BinTree Ident b -> Err b +lookupIdent c t = case lookupTree prt c t of + Ok v -> return v + _ -> prtBad "unknown identifier" c + +lookupIdentInfo :: Module Ident f a -> Ident -> Err a +lookupIdentInfo mo i = lookupIdent i (jments mo) diff --git a/src/GF/Devel/ReadFiles.hs b/src/GF/Devel/ReadFiles.hs new file mode 100644 index 000000000..c316a46d5 --- /dev/null +++ b/src/GF/Devel/ReadFiles.hs @@ -0,0 +1,356 @@ +---------------------------------------------------------------------- +-- | +-- Module : ReadFiles +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/11/11 23:24:34 $ +-- > CVS $Author: aarne $ +-- > CVS $Revision: 1.26 $ +-- +-- Decide what files to read as function of dependencies and time stamps. +-- +-- make analysis for GF grammar modules. AR 11\/6\/2003--24\/2\/2004 +-- +-- to find all files that have to be read, put them in dependency order, and +-- decide which files need recompilation. Name @file.gf@ is returned for them, +-- and @file.gfc@ or @file.gfr@ otherwise. +----------------------------------------------------------------------------- + +module GF.Devel.ReadFiles (-- * Heading 1 + getAllFiles,fixNewlines,ModName,getOptionsFromFile, + -- * Heading 2 + gfcFile,gfFile,gfrFile,isGFC,resModName,isOldFile + ) where + +import GF.Devel.Arch (selectLater, modifiedFiles, ModTime, getModTime,laterModTime) + +import GF.Infra.Option +import GF.Data.Operations +import GF.Devel.UseIO + +import System +import Data.Char +import Control.Monad +import Data.List +import System.Directory + +type ModName = String +type ModEnv = [(ModName,ModTime)] + +getAllFiles :: Options -> [InitPath] -> ModEnv -> FileName -> IOE [FullPath] +getAllFiles opts ps env file = do + + -- read module headers from all files recursively + ds0 <- getImports ps file + let ds = [((snd m,map fst ms),p) | ((m,ms),p) <- ds0] + if oElem beVerbose opts + then ioeIO $ putStrLn $ "all modules:" +++ show (map (fst . fst) ds) + else return () + -- get a topological sorting of files: returns file names --- deletes paths + ds1 <- ioeErr $ either + return + (\ms -> Bad $ "circular modules" +++ + unwords (map show (head ms))) $ topoTest $ map fst ds + + -- associate each file name with its path --- more optimal: save paths in ds1 + let paths = [(f,p) | ((f,_),p) <- ds] + let pds1 = [(p,f) | f <- ds1, Just p <- [lookup f paths]] + if oElem fromSource opts + then return [gfFile (prefixPathName p f) | (p,f) <- pds1] + else do + + + ds2 <- ioeIO $ mapM (selectFormat opts env) pds1 + + let ds4 = needCompile opts (map fst ds0) ds2 + return ds4 + +-- to decide whether to read gf or gfc, or if in env; returns full file path + +data CompStatus = + CSComp -- compile: read gf + | CSRead -- read gfc + | CSEnv -- gfc is in env + | CSEnvR -- also gfr is in env + | CSDont -- don't read at all + | CSRes -- read gfr + deriving (Eq,Show) + +-- for gfc, we also return ModTime to cope with earlier compilation of libs + +selectFormat :: Options -> ModEnv -> (InitPath,ModName) -> + IO (ModName,(InitPath,(CompStatus,Maybe ModTime))) + +selectFormat opts env (p,f) = do + let pf = prefixPathName p f + let mtenv = lookup f env -- Nothing if f is not in env + let rtenv = lookup (resModName f) env + let fromComp = oElem isCompiled opts -- i -gfc + mtgfc <- getModTime $ gfcFile pf + mtgf <- getModTime $ gfFile pf + let stat = case (rtenv,mtenv,mtgfc,mtgf) of + (_,Just tenv,_,_) | fromComp -> (CSEnv, Just tenv) + (_,_,Just tgfc,_) | fromComp -> (CSRead,Just tgfc) + (Just tenv,_,_,Just tgf) | laterModTime tenv tgf -> (CSEnvR,Just tenv) + (_,Just tenv,_,Just tgf) | laterModTime tenv tgf -> (CSEnv, Just tenv) + (_,_,Just tgfc,Just tgf) | laterModTime tgfc tgf -> (CSRead,Just tgfc) + (_,Just tenv,_,Nothing) -> (CSEnv,Just tenv) -- source does not exist + (_,_,_, Nothing) -> (CSRead,Nothing) -- source does not exist + _ -> (CSComp,Nothing) + return $ (f, (p,stat)) + +needCompile :: Options -> + [ModuleHeader] -> + [(ModName,(InitPath,(CompStatus,Maybe ModTime)))] -> [FullPath] +needCompile opts headers sfiles0 = paths $ res $ mark $ iter changed where + + deps = [(snd m,map fst ms) | (m,ms) <- headers] + typ m = maybe MTyOther id $ lookup m [(m,t) | ((t,m),_) <- headers] + uses m = [(n,u) | ((_,n),ms) <- headers, (k,u) <- ms, k==m] + stat0 m = maybe CSComp (fst . snd) $ lookup m sfiles0 + + allDeps = [(m,iterFix add ms) | (m,ms) <- deps] where + add os = [m | o <- os, Just n <- [lookup o deps],m <- n] + + -- only treat reused, interface, or instantiation if needed + sfiles = sfiles0 ---- map relevant sfiles0 + relevant fp@(f,(p,(st,_))) = + let us = uses f + isUsed = not (null us) + in + if not (isUsed && all noComp us) then + fp else + if (elem (typ f) [] ---- MTyIncomplete, MTyIncResource] + || + (isUsed && all isAux us)) then + (f,(p,(CSDont,Nothing))) else + fp + + isAux = flip elem [MUReuse,MUInstance,MUComplete] . snd + noComp = flip elem [CSRead,CSEnv,CSEnvR] . stat0 . fst + + -- mark as to be compiled those whose gfc is earlier than a deeper gfc + sfiles1 = map compTimes sfiles + compTimes fp@(f,(p,(_, Just t))) = + if any (> t) [t' | Just fs <- [lookup f deps], + f0 <- fs, + Just (_,(_,Just t')) <- [lookup f0 sfiles]] + then (f,(p,(CSComp, Nothing))) + else fp + compTimes fp = fp + + -- start with the changed files themselves; returns [ModName] + changed = [f | (f,(_,(CSComp,_))) <- sfiles1] + + -- add other files that depend on some changed file; returns [ModName] + iter np = let new = [f | (f,fs) <- deps, + not (elem f np), any (flip elem np) fs] + in if null new then np else (iter (new ++ np)) + + -- for each module in the full list, compile if depends on what needs compile + -- returns [FullPath] + mark cs = [(f,(path,st)) | + (f,(path,(st0,_))) <- sfiles1, + let st = if (elem f cs) then CSComp else st0] + + + -- if a compilable file depends on a resource, read gfr instead of gfc/env + -- but don't read gfr if already in env (by CSEnvR) + -- Also read res if the option "retain" is present + -- Also, if a "with" file has to be compiled, read its mother file from source + + res cs = map mkRes cs where + mkRes x@(f,(path,st)) | elem st [CSRead,CSEnv] = case typ f of + t | (not (null [m | (m,(_,CSComp)) <- cs, + Just ms <- [lookup m allDeps], elem f ms]) + || oElem retainOpers opts) + -> if elem t [MTyResource,MTyIncResource] + then (f,(path,CSRes)) else + if t == MTyIncomplete + then (f,(path,CSComp)) else + x + _ -> x + mkRes x = x + + + + -- construct list of paths to read + paths cs = [mkName f p st | (f,(p,st)) <- cs, elem st [CSComp, CSRead,CSRes]] + + mkName f p st = mk $ prefixPathName p f where + mk = case st of + CSComp -> gfFile + CSRead -> gfcFile + CSRes -> gfrFile + +isGFC :: FilePath -> Bool +isGFC = (== "gfc") . fileSuffix + +gfcFile :: FilePath -> FilePath +gfcFile = suffixFile "gfc" + +gfrFile :: FilePath -> FilePath +gfrFile = suffixFile "gfr" + +gfFile :: FilePath -> FilePath +gfFile = suffixFile "gf" + +resModName :: ModName -> ModName +resModName = ('#':) + +-- to get imports without parsing the whole files + +getImports :: [InitPath] -> FileName -> IOE [(ModuleHeader,InitPath)] +getImports ps = get [] where + get ds file0 = do + let name = justModuleName file0 ---- fileBody file0 + (p,s) <- tryRead name + let ((typ,mname),imps) = importsOfFile s + let namebody = justFileName name + ioeErr $ testErr (mname == namebody) $ + "module name" +++ mname +++ "differs from file name" +++ namebody + case imps of + _ | elem name (map (snd . fst . fst) ds) -> return ds --- file already read + [] -> return $ (((typ,name),[]),p):ds + _ -> do + let files = map (gfFile . fst) imps + foldM get ((((typ,name),imps),p):ds) files + tryRead name = do + file <- do + let file_gf = gfFile name + b <- doesFileExistPath ps file_gf -- try gf file first + if b then return file_gf else do + let file_gfr = gfrFile name + bb <- doesFileExistPath ps file_gfr -- gfr file next + if bb then return file_gfr else do + return (gfcFile name) -- gfc next + + readFileIfPath ps $ file + + + +-- internal module dep information + +data ModUse = + MUReuse + | MUInstance + | MUComplete + | MUOther + deriving (Eq,Show) + +data ModTyp = + MTyResource + | MTyIncomplete + | MTyIncResource -- interface, incomplete resource + | MTyOther + deriving (Eq,Show) + +type ModuleHeader = ((ModTyp,ModName),[(ModName,ModUse)]) + +importsOfFile :: String -> ModuleHeader +importsOfFile = + getModuleHeader . -- analyse into mod header + filter (not . spec) . -- ignore keywords and special symbols + unqual . -- take away qualifiers + unrestr . -- take away union restrictions + takeWhile (not . term) . -- read until curly or semic + lexs . -- analyse into lexical tokens + unComm -- ignore comments before the headed line + where + term = flip elem ["{",";"] + spec = flip elem ["of", "open","in",":", "->","=", "-","(", ")",",","**","union"] + unqual ws = case ws of + "(":q:ws' -> unqual ws' + w:ws' -> w:unqual ws' + _ -> ws + unrestr ws = case ws of + "[":ws' -> unrestr $ tail $ dropWhile (/="]") ws' + w:ws' -> w:unrestr ws' + _ -> ws + +getModuleHeader :: [String] -> ModuleHeader -- with, reuse +getModuleHeader ws = case ws of + "incomplete":ws2 -> let ((ty,name),us) = getModuleHeader ws2 in + case ty of + MTyResource -> ((MTyIncResource,name),us) + _ -> ((MTyIncomplete,name),us) + "interface":ws2 -> let ((_,name),us) = getModuleHeader ("resource":ws2) in + ((MTyIncResource,name),us) + + "resource":name:ws2 -> case ws2 of + "reuse":m:_ -> ((MTyResource,name),[(m,MUReuse)]) + m:"with":ms -> ((MTyResource,name),(m,MUOther):[(n,MUComplete) | n <- ms]) + ms -> ((MTyResource,name),[(n,MUOther) | n <- ms]) + + "instance":name:m:ws2 -> case ws2 of + "reuse":n:_ -> ((MTyResource,name),(m,MUInstance):[(n,MUReuse)]) + n:"with":ms -> + ((MTyResource,name),(m,MUInstance):(n,MUComplete):[(n,MUOther) | n <- ms]) + ms -> ((MTyResource,name),(m,MUInstance):[(n,MUOther) | n <- ms]) + + "concrete":name:a:ws2 -> case span (/= "with") ws2 of + + (es,_:ms) -> ((MTyOther,name), + [(m,MUOther) | m <- es] ++ + [(n,MUComplete) | n <- ms]) + --- m:"with":ms -> ((MTyOther,name),(m,MUOther):[(n,MUComplete) | n <- ms]) + (ms,[]) -> ((MTyOther,name),[(n,MUOther) | n <- a:ms]) + + _:name:ws2 -> case ws2 of + "reuse":m:_ -> ((MTyOther,name),[(m,MUReuse)]) + ---- m:n:"with":ms -> + ---- ((MTyOther,name),(m,MUInstance):(n,MUOther):[(n,MUComplete) | n <- ms]) + m:"with":ms -> ((MTyOther,name),(m,MUOther):[(n,MUComplete) | n <- ms]) + ms -> ((MTyOther,name),[(n,MUOther) | n <- ms]) + _ -> error "the file is empty" + +unComm s = case s of + '-':'-':cs -> unComm $ dropWhile (/='\n') cs + '{':'-':cs -> dpComm cs + c:cs -> c : unComm cs + _ -> s + +dpComm s = case s of + '-':'}':cs -> unComm cs + c:cs -> dpComm cs + _ -> s + +lexs s = x:xs where + (x,y) = head $ lex s + xs = if null y then [] else lexs y + +-- | options can be passed to the compiler by comments in @--#@, in the main file +getOptionsFromFile :: FilePath -> IO Options +getOptionsFromFile file = do + s <- readFileIfStrict file + let ls = filter (isPrefixOf "--#") $ lines s + return $ fst $ getOptions "-" $ map (unwords . words . drop 3) ls + +-- | check if old GF file +isOldFile :: FilePath -> IO Bool +isOldFile f = do + s <- readFileIfStrict f + let s' = unComm s + return $ not (null s') && old (head (words s')) + where + old = flip elem $ words + "cat category data def flags fun include lin lincat lindef lintype oper param pattern printname rule" + + + +-- | old GF tolerated newlines in quotes. No more supported! +fixNewlines :: String -> String +fixNewlines s = case s of + '"':cs -> '"':mk cs + c :cs -> c:fixNewlines cs + _ -> s + where + mk s = case s of + '\\':'"':cs -> '\\':'"': mk cs + '"' :cs -> '"' :fixNewlines cs + '\n' :cs -> '\\':'n': mk cs + c :cs -> c : mk cs + _ -> s + diff --git a/src/GF/Devel/UseIO.hs b/src/GF/Devel/UseIO.hs new file mode 100644 index 000000000..bd9f47845 --- /dev/null +++ b/src/GF/Devel/UseIO.hs @@ -0,0 +1,344 @@ +---------------------------------------------------------------------- +-- | +-- Module : UseIO +-- Maintainer : AR +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/08/08 09:01:25 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.17 $ +-- +-- (Description of the module) +----------------------------------------------------------------------------- + +module GF.Devel.UseIO where + +import GF.Data.Operations +import GF.Devel.Arch (prCPU) +import GF.Infra.Option +import GF.Today (libdir) + +import System.Directory +import System.IO +import System.IO.Error +import System.Environment +import Control.Monad + +putShow' :: Show a => (c -> a) -> c -> IO () +putShow' f = putStrLn . show . length . show . f + +putIfVerb :: Options -> String -> IO () +putIfVerb opts msg = + if oElem beVerbose opts + then putStrLn msg + else return () + +putIfVerbW :: Options -> String -> IO () +putIfVerbW opts msg = + if oElem beVerbose opts + then putStr (' ' : msg) + else return () + +-- | obsolete with IOE monad +errIO :: a -> Err a -> IO a +errIO = errOptIO noOptions + +errOptIO :: Options -> a -> Err a -> IO a +errOptIO os e m = case m of + Ok x -> return x + Bad k -> do + putIfVerb os k + return e + +prOptCPU :: Options -> Integer -> IO Integer +prOptCPU opts = if (oElem noCPU opts) then (const (return 0)) else prCPU + +putCPU :: IO () +putCPU = do + prCPU 0 + return () + +putPoint :: Show a => Options -> String -> IO a -> IO a +putPoint = putPoint' id + +putPoint' :: Show a => (c -> a) -> Options -> String -> IO c -> IO c +putPoint' f opts msg act = do + let sil x = if oElem beSilent opts then return () else x + ve x = if oElem beVerbose opts then x else return () + ve $ putStrLn msg + a <- act + ve $ putShow' f a + ve $ putCPU + return a + +readFileStrict :: String -> IO String +readFileStrict f = do + s <- readFile f + return $ seq (length s) () + return s + +readFileIf = readFileIfs readFile +readFileIfStrict = readFileIfs readFileStrict + +readFileIfs rf f = catch (rf f) (\_ -> reportOn f) where + reportOn f = do + putStrLnFlush ("File " ++ f ++ " does not exist. Returned empty string") + return "" + +type FileName = String +type InitPath = String +type FullPath = String + +isPathSep :: Char -> Bool +isPathSep c = c == ':' || c == ';' + +isSep :: Char -> Bool +isSep c = c == '/' || c == '\\' + +getFilePath :: [FilePath] -> String -> IO (Maybe FilePath) +getFilePath ps file = getFilePathMsg ("file" +++ file +++ "not found\n") ps file + +getFilePathMsg :: String -> [FilePath] -> String -> IO (Maybe FilePath) +getFilePathMsg msg paths file = get paths where + get [] = putStrFlush msg >> return Nothing + get (p:ps) = do + let pfile = prefixPathName p file + exist <- doesFileExist pfile + if exist then return (Just pfile) else get ps +--- catch (readFileStrict pfile >> return (Just pfile)) (\_ -> get ps) + +readFileIfPath :: [FilePath] -> String -> IOE (FilePath,String) +readFileIfPath paths file = do + mpfile <- ioeIO $ getFilePath paths file + case mpfile of + Just pfile -> do + s <- ioeIO $ readFileStrict pfile + return (justInitPath pfile,s) + _ -> ioeErr $ Bad ("File " ++ file ++ " does not exist.") + +doesFileExistPath :: [FilePath] -> String -> IOE Bool +doesFileExistPath paths file = do + mpfile <- ioeIO $ getFilePathMsg "" paths file + return $ maybe False (const True) mpfile + +-- | first var is lib prefix, second is like class path +-- | path in environment variable has lower priority +extendPathEnv :: String -> String -> [FilePath] -> IO [FilePath] +extendPathEnv lib var ps = do + b <- catch (getEnv lib) (const (return libdir)) -- e.g. GF_LIB_PATH + s <- catch (getEnv var) (const (return "")) -- e.g. GF_GRAMMAR_PATH + let fs = pFilePaths s + let ss = ps ++ fs + liftM concat $ mapM allSubdirs $ ss ++ [b ++ "/" ++ s | s <- ss] + +pFilePaths :: String -> [FilePath] +pFilePaths s = case break isPathSep s of + (f,_:cs) -> f : pFilePaths cs + (f,_) -> [f] + +getFilePaths :: String -> IO [FilePath] +getFilePaths s = do + let ps = pFilePaths s + liftM concat $ mapM allSubdirs ps + +getSubdirs :: FilePath -> IO [FilePath] +getSubdirs p = do + fs <- catch (getDirectoryContents p) (const $ return []) + fps <- mapM getPermissions (map (prefixPathName p) fs) + let ds = [f | (f,p) <- zip fs fps, searchable p, not (take 1 f==".")] + return ds + +allSubdirs :: FilePath -> IO [FilePath] +allSubdirs [] = return [[]] +allSubdirs p = case last p of + '*' -> do + fs <- getSubdirs (init p) + return [prefixPathName (init p) f | f <- fs] + _ -> return [p] + +prefixPathName :: String -> FilePath -> FilePath +prefixPathName p f = case f of + c:_ | isSep c -> f -- do not prefix [Unix style] absolute paths + _ -> case p of + "" -> f + _ -> p ++ "/" ++ f -- note: / actually works on windows + +justInitPath :: FilePath -> FilePath +justInitPath = reverse . drop 1 . dropWhile (not . isSep) . reverse + +nameAndSuffix :: FilePath -> (String,String) +nameAndSuffix file = case span (/='.') (reverse file) of + (_,[]) -> (file,[]) + (xet,deman) -> if any isSep xet + then (file,[]) -- cover cases like "foo.bar/baz" + else (reverse $ drop 1 deman,reverse xet) + +unsuffixFile, fileBody :: FilePath -> String +unsuffixFile = fst . nameAndSuffix +fileBody = unsuffixFile + +fileSuffix :: FilePath -> String +fileSuffix = snd . nameAndSuffix + +justFileName :: FilePath -> String +justFileName = reverse . takeWhile (not . isSep) . reverse + +suffixFile :: String -> FilePath -> FilePath +suffixFile suff file = file ++ "." ++ suff + +justModuleName :: FilePath -> String +justModuleName = fileBody . justFileName + +-- + +getLineWell :: IO String -> IO String +getLineWell ios = + catch getLine (\e -> if (isEOFError e) then ios else ioError e) + +putStrFlush :: String -> IO () +putStrFlush s = putStr s >> hFlush stdout + +putStrLnFlush :: String -> IO () +putStrLnFlush s = putStrLn s >> hFlush stdout + +-- * a generic quiz session + +type QuestionsAndAnswers = [(String, String -> (Integer,String))] + +teachDialogue :: QuestionsAndAnswers -> String -> IO () +teachDialogue qas welc = do + putStrLn $ welc ++++ genericTeachWelcome + teach (0,0) qas + where + teach _ [] = do putStrLn "Sorry, ran out of problems" + teach (score,total) ((question,grade):quas) = do + putStr ("\n" ++ question ++ "\n> ") + answer <- getLine + if (answer == ".") then return () else do + let (result, feedback) = grade answer + score' = score + result + total' = total + 1 + putStr (feedback ++++ "Score" +++ show score' ++ "/" ++ show total') + if (total' > 9 && fromInteger score' / fromInteger total' >= 0.75) + then do putStrLn "\nCongratulations - you passed!" + else teach (score',total') quas + + genericTeachWelcome = + "The quiz is over when you have done at least 10 examples" ++++ + "with at least 75 % success." +++++ + "You can interrupt the quiz by entering a line consisting of a dot ('.').\n" + + +-- * IO monad with error; adapted from state monad + +newtype IOE a = IOE (IO (Err a)) + +appIOE :: IOE a -> IO (Err a) +appIOE (IOE iea) = iea + +ioe :: IO (Err a) -> IOE a +ioe = IOE + +ioeIO :: IO a -> IOE a +ioeIO io = ioe (io >>= return . return) + +ioeErr :: Err a -> IOE a +ioeErr = ioe . return + +instance Monad IOE where + return a = ioe (return (return a)) + IOE c >>= f = IOE $ do + x <- c -- Err a + appIOE $ err ioeBad f x -- f :: a -> IOE a + +ioeBad :: String -> IOE a +ioeBad = ioe . return . Bad + +useIOE :: a -> IOE a -> IO a +useIOE a ioe = appIOE ioe >>= err (\s -> putStrLn s >> return a) return + +foldIOE :: (a -> b -> IOE a) -> a -> [b] -> IOE (a, Maybe String) +foldIOE f s xs = case xs of + [] -> return (s,Nothing) + x:xx -> do + ev <- ioeIO $ appIOE (f s x) + case ev of + Ok v -> foldIOE f v xx + Bad m -> return $ (s, Just m) + +putStrLnE :: String -> IOE () +putStrLnE = ioeIO . putStrLnFlush + +putStrE :: String -> IOE () +putStrE = ioeIO . putStrFlush + +-- this is more verbose +putPointE :: Options -> String -> IOE a -> IOE a +putPointE = putPointEgen (oElem beSilent) + +-- this is less verbose +putPointEsil :: Options -> String -> IOE a -> IOE a +putPointEsil = putPointEgen (not . oElem beVerbose) + +putPointEgen :: (Options -> Bool) -> Options -> String -> IOE a -> IOE a +putPointEgen cond opts msg act = do + let ve x = if cond opts then return () else x + ve $ ioeIO $ putStrFlush msg + a <- act +--- ve $ ioeIO $ putShow' id a --- replace by a statistics command + ve $ ioeIO $ putStrFlush " " +-- ve $ ioeIO $ putCPU + return a + + +-- | forces verbosity +putPointEVerb :: Options -> String -> IOE a -> IOE a +putPointEVerb opts = putPointE (addOption beVerbose opts) + +gfLibraryPath = "GF_LIB_PATH" + +-- ((do {s <- readFile f; return (return s)}) ) +readFileIOE :: FilePath -> IOE (String) +readFileIOE f = ioe $ catch (readFileStrict f >>= return . return) + (\_ -> return (Bad (reportOn f))) where + reportOn f = "File " ++ f ++ " not found." + +-- | like readFileIOE but look also in the GF library if file not found +-- +-- intended semantics: if file is not found, try @\$GF_LIB_PATH\/file@ +-- (even if file is an absolute path, but this should always fail) +-- it returns not only contents of the file, but also the path used +-- +-- FIXME: unix-specific, \/ is \\ on Windows +readFileLibraryIOE :: String -> FilePath -> IOE (FilePath, String) +readFileLibraryIOE ini f = + ioe $ catch ((do {s <- readFileStrict initPath; return (return (initPath,s))})) + (\_ -> tryLibrary ini f) where + tryLibrary :: String -> FilePath -> IO (Err (FilePath, String)) + tryLibrary ini f = + catch (do { + lp <- getLibPath; + s <- readFileStrict (lp ++ f); + return (return (lp ++ f, s)) + }) (\_ -> return (Bad (reportOn f))) + initPath = addInitFilePath ini f + getLibPath :: IO String + getLibPath = do { + lp <- catch (getEnv gfLibraryPath) (const (return libdir)) ; + return (if isSep (last lp) then lp else lp ++ ['/']); + } + reportOn f = "File " ++ f ++ " not found." + libPath ini f = f + addInitFilePath ini file = case file of + c:_ | isSep c -> file -- absolute path name + _ -> ini ++ file -- relative path name + + +-- | example +koeIOE :: IO () +koeIOE = useIOE () $ do + s <- ioeIO $ getLine + s2 <- ioeErr $ mapM (!? 2) $ words s + ioeIO $ putStrLn s2 +