compiler "gfc" in GF/Devel

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

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)
+
+

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."

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
+

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)
+

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)

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 
+

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
+