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

24 files changed, 5418 insertions, 0 deletions

diff --git a/src-3.0/GF/Compile/API.hs b/src-3.0/GF/Compile/API.hs
new file mode 100644
index 000000000..242a9e87a
--- /dev/null
+++ b/src-3.0/GF/Compile/API.hs
@@ -0,0 +1,21 @@
+module GF.Compile.API (batchCompile, compileToGFCC) where
+
+import GF.Devel.Compile
+import GF.Devel.GrammarToGFCC
+import GF.GFCC.OptimizeGFCC
+import GF.GFCC.CheckGFCC
+import GF.GFCC.DataGFCC
+import GF.Infra.Option
+import GF.Devel.UseIO
+
+-- | Compiles a number of source files and builds a 'GFCC' structure for them.
+compileToGFCC :: Options -> [FilePath] -> IOE GFCC
+compileToGFCC opts fs = 
+    do gr <- batchCompile opts fs
+       let name = justModuleName (last fs)
+       gc1 <- putPointE opts "linking ... " $
+                let (abs,gc0) = mkCanon2gfcc opts name gr
+                in ioeIO $ checkGFCCio gc0
+       let opt = if oElem (iOpt "noopt") opts then id else optGFCC
+           par = if oElem (iOpt "noparse") opts then id else addParsers
+       return (par (opt gc1))
diff --git a/src-3.0/GF/Compile/BackOpt.hs b/src-3.0/GF/Compile/BackOpt.hs
new file mode 100644
index 000000000..8356f2ba2
--- /dev/null
+++ b/src-3.0/GF/Compile/BackOpt.hs
@@ -0,0 +1,141 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : BackOpt
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:33 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.6 $
+--
+-- Optimizations on GF source code: sharing, parametrization, value sets.
+--
+-- optimization: sharing branches in tables. AR 25\/4\/2003.
+-- following advice of Josef Svenningsson
+-----------------------------------------------------------------------------
+
+module GF.Compile.BackOpt (shareModule, OptSpec, shareOpt, paramOpt, valOpt, allOpt) where
+
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import qualified GF.Grammar.Macros as C
+import GF.Grammar.PrGrammar (prt)
+import GF.Data.Operations
+import Data.List
+import qualified GF.Infra.Modules as M
+
+type OptSpec = [Integer] ---
+
+doOptFactor :: OptSpec -> Bool
+doOptFactor opt = elem 2 opt
+
+doOptValues :: OptSpec -> Bool
+doOptValues opt = elem 3 opt
+
+shareOpt :: OptSpec
+shareOpt = []
+
+paramOpt :: OptSpec
+paramOpt = [2]
+
+valOpt :: OptSpec
+valOpt = [3]
+
+allOpt :: OptSpec
+allOpt = [2,3]
+
+shareModule :: OptSpec -> (Ident, SourceModInfo) -> (Ident, SourceModInfo)
+shareModule opt (i,m) = case m of
+  M.ModMod (M.Module mt st fs me ops js) -> 
+    (i,M.ModMod (M.Module mt st fs me ops (mapTree (shareInfo opt) js)))
+  _ -> (i,m)
+
+shareInfo opt (c, CncCat ty (Yes t) m) = (c,CncCat ty (Yes (shareOptim opt c t)) m)
+shareInfo opt (c, CncFun kxs (Yes t) m) = (c,CncFun kxs (Yes (shareOptim opt c t)) m)
+shareInfo opt (c, ResOper ty (Yes t)) = (c,ResOper ty (Yes (shareOptim opt c t)))
+shareInfo _ i = i
+
+-- the function putting together optimizations
+shareOptim :: OptSpec -> Ident -> Term -> Term
+shareOptim opt c 
+  | doOptFactor opt && doOptValues opt = values . factor c 0
+  | doOptFactor opt = share . factor c 0
+  | doOptValues opt = values    
+  | otherwise = share
+
+-- we need no counter to create new variable names, since variables are 
+-- local to tables (only true in GFC) ---
+
+share :: Term -> Term
+share t = case t of
+  T ty@(TComp _) cs -> shareT ty [(p, share v) | (p, v) <- cs]
+  _ -> C.composSafeOp share t
+
+ where
+   shareT ty = finalize ty . groupC . sortC
+ 
+   sortC :: [(Patt,Term)] -> [(Patt,Term)]
+   sortC = sortBy $ \a b -> compare (snd a) (snd b)
+
+   groupC :: [(Patt,Term)] -> [[(Patt,Term)]]
+   groupC = groupBy $ \a b -> snd a == snd b
+
+   finalize :: TInfo -> [[(Patt,Term)]] -> Term
+   finalize ty css = TSh ty [(map fst ps, t) | ps@((_,t):_) <- css]
+
+-- do even more: factor parametric branches
+
+factor :: Ident -> Int -> Term -> Term
+factor c i t = case t of
+  T _ [_] -> t
+  T _ []  -> t
+  T (TComp ty) cs -> 
+    T (TTyped ty) $ factors i [(p, factor c (i+1) v) | (p, v) <- cs]
+  _ -> C.composSafeOp (factor c i) t
+ where
+
+   factors i psvs =   -- we know psvs has at least 2 elements
+     let p   = qqIdent c i
+         vs' = map (mkFun p) psvs
+     in if   allEqs vs'
+        then mkCase p vs' 
+        else psvs
+
+   mkFun p (patt, val) = replace (C.patt2term patt) (Vr p) val
+
+   allEqs (v:vs) = all (==v) vs
+
+   mkCase p (v:_) = [(PV p, v)]
+
+--- we hope this will be fresh and don't check... in GFC would be safe
+
+qqIdent c i = identC ("q_" ++ prt c ++ "__" ++ show i)
+
+
+--  we need to replace subterms
+
+replace :: Term -> Term -> Term -> Term
+replace old new trm = case trm of
+  
+  -- these are the important cases, since they can correspond to patterns  
+  QC _ _   | trm == old -> new
+  App t ts | trm == old -> new
+  App t ts              -> App (repl t) (repl ts)
+  R _ | isRec && trm == old -> new
+  _ -> C.composSafeOp repl trm
+ where
+   repl = replace old new
+   isRec = case trm of
+     R _ -> True
+     _ -> False
+
+-- It is very important that this is performed only after case
+-- expansion since otherwise the order and number of values can
+-- be incorrect. Guaranteed by the TComp flag.
+
+values :: Term -> Term
+values t = case t of
+  T ty [(ps,t)]   -> T ty [(ps,values t)] -- don't destroy parametrization
+  T (TComp ty) cs -> V ty [values t | (_, t) <- cs]
+  _ -> C.composSafeOp values t
diff --git a/src-3.0/GF/Compile/CheckGrammar.hs b/src-3.0/GF/Compile/CheckGrammar.hs
new file mode 100644
index 000000000..b33d11017
--- /dev/null
+++ b/src-3.0/GF/Compile/CheckGrammar.hs
@@ -0,0 +1,1078 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : CheckGrammar
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/11 23:24:33 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.31 $
+--
+-- AR 4\/12\/1999 -- 1\/4\/2000 -- 8\/9\/2001 -- 15\/5\/2002 -- 27\/11\/2002 -- 18\/6\/2003
+--
+-- type checking also does the following modifications:
+--
+--  - types of operations and local constants are inferred and put in place
+--
+--  - both these types and linearization types are computed
+--
+--  - tables are type-annotated
+-----------------------------------------------------------------------------
+
+module GF.Compile.CheckGrammar (
+  showCheckModule, justCheckLTerm, allOperDependencies, topoSortOpers) where
+
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Infra.Modules
+import GF.Grammar.Refresh ----
+
+import GF.Grammar.TypeCheck
+import GF.Grammar.Values (cPredefAbs) ---
+
+import GF.Grammar.PrGrammar
+import GF.Grammar.Lookup
+import GF.Grammar.LookAbs
+import GF.Grammar.Macros
+import GF.Grammar.ReservedWords ----
+import GF.Grammar.PatternMatch
+import GF.Grammar.AppPredefined
+import GF.Grammar.Lockfield (isLockLabel)
+
+import GF.Data.Operations
+import GF.Infra.CheckM
+
+import Data.List
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import Control.Monad
+import Debug.Trace ---
+
+
+showCheckModule :: [SourceModule] -> SourceModule -> Err ([SourceModule],String)
+showCheckModule mos m = do
+  (st,(_,msg)) <- checkStart $ checkModule mos m
+  return (st, unlines $ reverse msg)
+
+-- | checking is performed in the dependency order of modules
+checkModule :: [SourceModule] -> SourceModule -> Check [SourceModule]
+checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod of
+
+  ModMod mo@(Module mt st fs me ops js) -> do
+    checkRestrictedInheritance ms (name, mo)
+    js' <- case mt of
+      MTAbstract -> mapMTree (checkAbsInfo gr name) js
+
+      MTTransfer a b -> mapMTree (checkAbsInfo gr name) js
+
+      MTResource -> mapMTree (checkResInfo gr name) js
+
+      MTConcrete a -> do
+        checkErr $ topoSortOpers $ allOperDependencies name js
+        ModMod abs <- checkErr $ lookupModule gr a
+        js1 <- checkCompleteGrammar abs mo
+        mapMTree (checkCncInfo gr name (a,abs)) js1
+
+      MTInterface -> mapMTree (checkResInfo gr name) js
+
+      MTInstance a -> do
+        ModMod abs <- checkErr $ lookupModule gr a
+        -- checkCompleteInstance abs mo -- this is done in Rebuild
+        mapMTree (checkResInfo gr name) js
+
+    return $ (name, ModMod (Module mt st fs me ops js')) : ms
+
+  _ -> return $ (name,mod) : ms
+ where
+   gr  = MGrammar $ (name,mod):ms
+
+-- check if restricted inheritance modules are still coherent
+-- i.e. that the defs of remaining names don't depend on omitted names
+---checkRestrictedInheritance :: [SourceModule] -> SourceModule -> Check ()
+checkRestrictedInheritance mos (name,mo) = do
+  let irs = [ii | ii@(_,mi) <- extend mo, mi /= MIAll]  -- names with restr. inh.
+  let mrs = [((i,m),mi) | (i,ModMod m) <- mos, Just mi <- [lookup i irs]] 
+                             -- the restr. modules themself, with restr. infos
+  mapM_ checkRem mrs
+ where
+   checkRem ((i,m),mi) = do
+     let (incl,excl) = partition (isInherited mi) (map fst (tree2list (jments m)))
+     let incld c   = Set.member c (Set.fromList incl)
+     let illegal c = Set.member c (Set.fromList excl)
+     let illegals = [(f,is) | 
+           (f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)]
+     case illegals of 
+       [] -> return ()
+       cs -> fail $ "In inherited module" +++ prt i ++
+               ", dependence of excluded constants:" ++++
+               unlines ["  " ++ prt f +++ "on" +++ unwords (map prt is) | 
+                              (f,is) <- cs]
+   allDeps = ---- transClosure $ Map.fromList $ 
+             concatMap (allDependencies (const True)) 
+                              [jments m | (_,ModMod m) <- mos]
+   transClosure ds = ds ---- TODO: check in deeper modules
+
+-- | check if a term is typable
+justCheckLTerm :: SourceGrammar -> Term -> Err Term
+justCheckLTerm src t = do
+  ((t',_),_) <- checkStart (inferLType src t)
+  return t'
+
+checkAbsInfo :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info)
+checkAbsInfo st m (c,info) = do
+---- checkReservedId c
+ case info of
+   AbsCat (Yes cont) _ -> mkCheck "category" $ 
+     checkContext st cont ---- also cstrs
+   AbsFun (Yes typ0) md -> do
+    typ <- compAbsTyp [] typ0   -- to calculate let definitions
+    mkCheck "type of function" $ checkTyp st typ 
+    md' <- case md of
+       Yes d -> do
+         let d' = elimTables d
+         mkCheckWarn "definition of function" $ checkEquation st (m,c) d'
+         return $ Yes d'
+       _ -> return md
+    return $ (c,AbsFun (Yes typ) md')
+   _ -> return (c,info)
+ where
+   mkCheck cat ss = case ss of
+     [] -> return (c,info)
+     ["[]"] -> return (c,info) ----
+     _  -> checkErr $ prtBad (unlines ss ++++ "in" +++ cat) c
+   ---- temporary solution when tc of defs is incomplete
+   mkCheckWarn cat ss = case ss of
+     [] -> return (c,info)
+     ["[]"] -> return (c,info) ----
+     _  -> checkWarn (unlines ss ++++ "in" +++ cat +++ prt c) >> return (c,info)
+   compAbsTyp g t = case t of
+     Vr x -> maybe (fail ("no value given to variable" +++ prt x)) return $ lookup x g
+     Let (x,(_,a)) b -> do
+       a' <- compAbsTyp g a
+       compAbsTyp ((x, a'):g) b
+     Prod x a b -> do
+       a' <- compAbsTyp g a
+       b' <- compAbsTyp ((x,Vr x):g) b
+       return $ Prod x a' b'
+     Abs _ _ -> return t
+     _ -> composOp (compAbsTyp g) t
+
+   elimTables e = case e of
+     S t a  -> elimSel (elimTables t) (elimTables a)
+     T _ cs -> Eqs [(elimPatt p, elimTables t) | (p,t) <- cs]
+     _ -> composSafeOp elimTables e
+   elimPatt p = case p of
+     PR lps -> map snd lps
+     _ -> [p]
+   elimSel t a = case a of
+     R fs -> mkApp t (map (snd . snd) fs)
+     _ -> mkApp t [a]
+
+checkCompleteGrammar :: SourceAbs -> SourceCnc -> Check (BinTree Ident Info)
+checkCompleteGrammar abs cnc = do
+  let js = jments cnc
+  let fs = tree2list $ jments abs
+  foldM checkOne js fs
+ where
+   checkOne js i@(c,info) = case info of
+     AbsFun (Yes _) _ -> case lookupIdent c js of
+       Ok _ -> return js
+       _ -> do
+         checkWarn $ "WARNING: no linearization of" +++ prt c
+         return js
+     AbsCat (Yes _) _ -> case lookupIdent c js of
+       Ok (AnyInd _ _) -> return js
+       Ok (CncCat (Yes _) _ _) -> return js
+       Ok (CncCat _ mt mp) -> do
+         checkWarn $ 
+           "Warning: no linearization type for" +++ prt c ++ 
+           ", inserting default {s : Str}" 
+         return $ updateTree (c,CncCat (Yes defLinType) mt mp) js
+       _ -> do
+         checkWarn $ 
+           "Warning: no linearization type for" +++ prt c ++ 
+           ", inserting default {s : Str}" 
+         return $ updateTree (c,CncCat (Yes defLinType) nope nope) js
+     _ -> return js
+
+-- | General Principle: only Yes-values are checked. 
+-- A May-value has always been checked in its origin module.
+checkResInfo :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info)
+checkResInfo gr mo (c,info) = do
+  checkReservedId c
+  case info of
+    ResOper pty pde -> chIn "operation" $ do
+      (pty', pde') <- case (pty,pde) of
+         (Yes ty, Yes de) -> do
+           ty'     <- check ty typeType >>= comp . fst
+           (de',_) <- check de ty'
+           return (Yes ty', Yes de')
+         (_, Yes de) -> do
+           (de',ty') <- infer de
+           return (Yes ty', Yes de')
+         (_,Nope) -> do
+           checkWarn "No definition given to oper"
+           return (pty,pde)
+         _ -> return (pty, pde) --- other cases are uninteresting
+      return (c, ResOper pty' pde')
+
+    ResOverload tysts -> chIn "overloading" $ do
+      tysts' <- mapM (uncurry $ flip check) tysts
+      let tysts2 = [(y,x) | (x,y) <- tysts']
+      --- this can only be a partial guarantee, since matching
+      --- with value type is only possible if expected type is given
+      checkUniq $ 
+        sort [t : map snd xs | (x,_) <- tysts2, Ok (xs,t) <- [typeFormCnc x]]
+      return (c,ResOverload tysts2)
+
+    ResParam (Yes (pcs,_)) -> chIn "parameter type" $ do
+----      mapM ((mapM (computeLType gr . snd)) . snd) pcs
+      mapM_ ((mapM_ (checkIfParType gr . snd)) . snd) pcs
+      ts <- checkErr $ lookupParamValues gr mo c
+      return (c,ResParam (Yes (pcs, Just ts)))
+
+    _ ->  return (c,info)
+ where
+   infer = inferLType gr
+   check = checkLType gr
+   chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":")
+   comp = computeLType gr
+
+   checkUniq xss = case xss of
+     x:y:xs 
+      | x == y -> raise $ "ambiguous for argument list" +++ 
+                         unwords (map (prtType gr) x)  
+      | otherwise -> checkUniq $ y:xs
+     _ -> return ()
+
+
+checkCncInfo :: SourceGrammar -> Ident -> (Ident,SourceAbs) -> 
+                (Ident,Info) -> Check (Ident,Info)
+checkCncInfo gr m (a,abs) (c,info) = do
+  checkReservedId c
+  case info of
+
+    CncFun _ (Yes trm) mpr -> chIn "linearization of" $ do
+      typ        <- checkErr $ lookupFunTypeSrc gr a c
+      cat0       <- checkErr $ valCat typ
+      (cont,val) <- linTypeOfType gr m typ         -- creates arg vars
+      (trm',_)   <- check trm (mkFunType (map snd cont) val)  -- erases arg vars
+      checkPrintname gr mpr
+      cat        <- return $ snd cat0
+      return (c, CncFun (Just (cat,(cont,val))) (Yes trm') mpr)
+                                                   -- cat for cf, typ for pe
+
+    CncCat (Yes typ) mdef mpr -> chIn "linearization type of" $ do
+      checkErr $ lookupCatContextSrc gr a c
+      typ'  <- checkIfLinType gr typ
+      mdef' <- case mdef of
+        Yes def -> do
+          (def',_) <- checkLType gr def (mkFunType [typeStr] typ)
+          return $ Yes def'
+        _ -> return mdef
+      checkPrintname gr mpr
+      return (c,CncCat (Yes typ') mdef' mpr)
+
+    _ -> checkResInfo gr m (c,info)
+
+ where
+   env = gr
+   infer = inferLType gr
+   comp = computeLType gr 
+   check = checkLType gr
+   chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":")
+
+checkIfParType :: SourceGrammar -> Type -> Check ()
+checkIfParType st typ = checkCond ("Not parameter type" +++ prt typ) (isParType typ)
+  where
+   isParType ty = True ----
+{- case ty of
+     Cn typ -> case lookupConcrete st typ of
+       Ok (CncParType _ _ _) -> True
+       Ok (CncOper _ ty' _) -> isParType ty'
+       _ -> False
+     Q p t -> case lookupInPackage st (p,t) of
+       Ok (CncParType _ _ _) -> True
+       _ -> False
+     RecType r -> all (isParType . snd) r
+     _ -> False
+-}
+
+checkIfStrType :: SourceGrammar -> Type -> Check ()
+checkIfStrType st typ = case typ of
+  Table arg val -> do
+    checkIfParType st arg 
+    checkIfStrType st val
+  _ | typ == typeStr -> return ()
+  _ -> prtFail "not a string type" typ
+
+
+checkIfLinType :: SourceGrammar -> Type -> Check Type
+checkIfLinType st typ0 = do
+  typ <- computeLType st typ0
+  case typ of
+    RecType r -> do
+      let (lins,ihs) = partition (isLinLabel .fst) r
+      --- checkErr $ checkUnique $ map fst r
+      mapM_ checkInh ihs
+      mapM_ checkLin lins
+    _ -> prtFail "a linearization type must be a record type instead of" typ
+  return typ
+
+ where
+   checkInh (label,typ) = checkIfParType st typ
+   checkLin (label,typ) = return () ---- checkIfStrType st typ
+
+
+computeLType :: SourceGrammar -> Type -> Check Type
+computeLType gr t = do
+  g0 <- checkGetContext
+  let g = [(x, Vr x) | (x,_) <- g0]
+  checkInContext g $ comp t
+ where
+  comp ty = case ty of
+
+    App (Q (IC "Predef") (IC "Ints")) _ -> return ty ---- shouldn't be needed
+    Q (IC "Predef") (IC "Int")          -> return ty ---- shouldn't be needed
+    Q (IC "Predef") (IC "Float")        -> return ty ---- shouldn't be needed
+    Q (IC "Predef") (IC "Error")        -> return ty ---- shouldn't be needed
+
+    Q m c | elem c [cPredef,cPredefAbs] -> return ty
+    Q m c | elem c [zIdent "Int"] -> 
+      return $ linTypeInt
+    Q m c | elem c [zIdent "Float",zIdent "String"] -> return defLinType ----
+
+    Q m ident -> checkIn ("module" +++ prt m) $ do
+      ty' <- checkErr (lookupResDef gr m ident) 
+      if ty' == ty then return ty else comp ty' --- is this necessary to test?
+
+    Vr ident  -> checkLookup ident -- never needed to compute!
+
+    App f a -> do
+      f' <- comp f
+      a' <- comp a
+      case f' of
+        Abs x b -> checkInContext [(x,a')] $ comp b
+        _ -> return $ App f' a'
+
+    Prod x a b -> do
+      a' <- comp a
+      b' <- checkInContext [(x,Vr x)] $ comp b
+      return $ Prod x a' b'
+
+    Abs x b -> do
+      b' <- checkInContext [(x,Vr x)] $ comp b
+      return $ Abs x b'
+
+    ExtR r s -> do
+      r' <- comp r
+      s' <- comp s
+      case (r',s') of
+        (RecType rs, RecType ss) -> checkErr (plusRecType r' s') >>= comp
+        _ -> return $ ExtR r' s'
+
+    RecType fs -> do
+      let fs' = sortBy (\x y -> compare (fst x) (fst y)) fs
+      liftM RecType $ mapPairsM comp fs'
+
+    _ | ty == typeTok -> return typeStr
+    _ | isPredefConstant ty -> return ty
+
+    _ -> composOp comp ty
+
+checkPrintname :: SourceGrammar -> Perh Term -> Check ()
+checkPrintname st (Yes t) = checkLType st t typeStr >> return ()
+checkPrintname _ _ = return ()
+
+-- | for grammars obtained otherwise than by parsing ---- update!!
+checkReservedId :: Ident -> Check ()
+checkReservedId x = let c = prt x in
+         if isResWord c 
+            then checkWarn ("Warning: reserved word used as identifier:" +++ c)
+            else return ()
+
+-- to normalize records and record types
+labelIndex :: Type -> Label -> Int
+labelIndex ty lab = case ty of
+  RecType ts -> maybe (error ("label index" +++ prt lab)) id $ lookup lab $ labs ts
+  _ -> error $ "label index" +++ prt ty
+ where 
+  labs ts = zip (map fst (sortBy (\ x y -> compare (fst x) (fst y)) ts)) [0..]
+
+-- the underlying algorithms
+
+inferLType :: SourceGrammar -> Term -> Check (Term, Type)
+inferLType gr trm = case trm of
+
+   Q m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident)
+
+   Q m ident -> checks [
+     termWith trm $ checkErr (lookupResType gr m ident) >>= comp
+     ,
+     checkErr (lookupResDef gr m ident) >>= infer
+     ,
+{-
+     do
+       over <- getOverload gr Nothing trm
+       case over of
+         Just trty -> return trty
+         _ -> prtFail "not overloaded" trm
+     ,
+-}
+     prtFail "cannot infer type of constant" trm
+     ]
+
+   QC m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident)
+
+   QC m ident -> checks [
+       termWith trm $ checkErr (lookupResType gr m ident) >>= comp
+       ,
+       checkErr (lookupResDef gr m ident) >>= infer
+       ,
+       prtFail "cannot infer type of canonical constant" trm
+       ]
+
+   Val ty i -> termWith trm $ return ty
+
+   Vr ident -> termWith trm $ checkLookup ident
+
+   Typed e t -> do
+     t' <- comp t
+     check e t'
+     return (e,t')
+
+   App f a -> do
+     over <- getOverload gr Nothing trm
+     case over of
+       Just trty -> return trty
+       _ -> do
+         (f',fty) <- infer f
+         fty' <- comp fty
+         case fty' of
+           Prod z arg val -> do 
+             a' <- justCheck a arg
+             ty <- if isWildIdent z 
+                      then return val
+                      else substituteLType [(z,a')] val
+             return (App f' a',ty) 
+           _ -> raise ("function type expected for"+++ 
+                      prt f +++"instead of" +++ prtType env fty)
+
+   S f x -> do
+     (f', fty) <- infer f
+     case fty of
+       Table arg val -> do
+         x'<- justCheck x arg
+         return (S f' x', val)
+       _ -> prtFail "table lintype expected for the table in" trm
+
+   P t i -> do
+     (t',ty) <- infer t   --- ??
+     ty' <- comp ty
+-----     let tr2 = PI t' i (labelIndex ty' i)
+     let tr2 = P t' i
+     termWith tr2 $ checkErr $ case ty' of
+       RecType ts -> maybeErr ("unknown label" +++ prt i +++ "in" +++ prt ty') $ 
+                     lookup i ts
+       _ -> prtBad ("record type expected for" +++ prt t +++ "instead of") ty'
+   PI t i _ -> infer $ P t i
+
+   R r -> do
+     let (ls,fs) = unzip r
+     fsts <- mapM inferM fs
+     let ts = [ty | (Just ty,_) <- fsts]
+     checkCond ("cannot infer type of record"+++ prt trm) (length ts == length fsts)
+     return $ (R (zip ls fsts), RecType (zip ls ts))
+
+   T (TTyped arg) pts -> do
+     (_,val) <- checks $ map (inferCase (Just arg)) pts
+     check trm (Table arg val)
+   T (TComp arg) pts -> do
+     (_,val) <- checks $ map (inferCase (Just arg)) pts
+     check trm (Table arg val)
+   T ti pts -> do  -- tries to guess: good in oper type inference
+     let pts' = [pt | pt@(p,_) <- pts, isConstPatt p]
+     case pts' of 
+       [] -> prtFail "cannot infer table type of" trm
+----       PInt k : _ -> return $ Ints $ max [i | PInt i <- pts'] 
+       _  -> do 
+         (arg,val) <- checks $ map (inferCase Nothing) pts'
+         check trm (Table arg val)
+   V arg pts -> do
+     (_,val) <- checks $ map infer pts
+     return (trm, Table arg val)
+
+   K s  -> do
+     if elem ' ' s
+        then checkWarn ("WARNING: space in token \"" ++ s ++ 
+                        "\". Lexical analysis may fail.")
+        else return ()
+     return (trm, typeStr)
+
+   EInt i -> return (trm, typeInt)
+
+   EFloat i -> return (trm, typeFloat)
+
+   Empty -> return (trm, typeStr)
+
+   C s1 s2 -> 
+     check2 (flip justCheck typeStr) C s1 s2 typeStr
+
+   Glue s1 s2 -> 
+     check2 (flip justCheck typeStr) Glue s1 s2 typeStr ---- typeTok
+
+---- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007
+   Strs (Cn (IC "#conflict") : ts) -> do
+     trace ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts)) (infer $ head ts)
+--     checkWarn ("WARNING: unresolved constant, could be any of" +++ unwords (map prt ts))
+--     infer $ head ts
+
+   Strs ts -> do
+     ts' <- mapM (\t -> justCheck t typeStr) ts 
+     return (Strs ts', typeStrs)
+
+   Alts (t,aa) -> do
+     t'  <- justCheck t typeStr
+     aa' <- flip mapM aa (\ (c,v) -> do
+        c' <- justCheck c typeStr 
+        v' <- justCheck v typeStrs
+        return (c',v'))
+     return (Alts (t',aa'), typeStr)
+
+   RecType r -> do
+     let (ls,ts) = unzip r
+     ts' <- mapM (flip justCheck typeType) ts 
+     return (RecType (zip ls ts'), typeType)
+
+   ExtR r s -> do
+     (r',rT) <- infer r 
+     rT'     <- comp rT
+     (s',sT) <- infer s
+     sT'     <- comp sT
+
+     let trm' = ExtR r' s'
+     ---- trm'    <- checkErr $ plusRecord r' s'
+     case (rT', sT') of
+       (RecType rs, RecType ss) -> do
+         rt <- checkErr $ plusRecType rT' sT'
+         check trm' rt ---- return (trm', rt)
+       _ | rT' == typeType && sT' == typeType -> return (trm', typeType)
+       _ -> prtFail "records or record types expected in" trm
+
+   Sort _     -> 
+     termWith trm $ return typeType
+
+   Prod x a b -> do
+     a' <- justCheck a typeType
+     b' <- checkInContext [(x,a')] $ justCheck b typeType
+     return (Prod x a' b', typeType)
+
+   Table p t  -> do
+     p' <- justCheck p typeType --- check p partype! 
+     t' <- justCheck t typeType
+     return $ (Table p' t', typeType)
+
+   FV vs -> do
+     (_,ty) <- checks $ map infer vs
+---     checkIfComplexVariantType trm ty
+     check trm ty
+
+   _ -> prtFail "cannot infer lintype of" trm
+
+ where
+   env = gr
+   infer = inferLType env
+   comp = computeLType env 
+
+   check = checkLType env
+   
+   isPredef m = elem m [cPredef,cPredefAbs]
+
+   justCheck ty te = check ty te >>= return . fst
+
+   -- for record fields, which may be typed
+   inferM (mty, t) = do
+     (t', ty') <- case mty of
+       Just ty -> check ty t
+       _ -> infer t
+     return (Just ty',t')
+
+   inferCase mty (patt,term) = do
+     arg  <- maybe (inferPatt patt) return mty
+     cont <- pattContext env arg patt
+     i    <- checkUpdates cont
+     (_,val) <- infer term
+     checkResets i
+     return (arg,val)
+   isConstPatt p = case p of
+     PC _ ps -> True --- all isConstPatt ps
+     PP _ _ ps -> True --- all isConstPatt ps
+     PR ps -> all (isConstPatt . snd) ps
+     PT _ p -> isConstPatt p
+     PString _ -> True
+     PInt _ -> True
+     PFloat _ -> True
+     PChar -> True
+     PSeq p q -> isConstPatt p && isConstPatt q
+     PAlt p q -> isConstPatt p && isConstPatt q
+     PRep p -> isConstPatt p
+     PNeg p -> isConstPatt p
+     PAs _ p -> isConstPatt p
+     _ -> False
+
+   inferPatt p = case p of
+     PP q c ps | q /= cPredef -> checkErr $ lookupResType gr q c >>= valTypeCnc
+     PAs _ p  -> inferPatt p
+     PNeg p   -> inferPatt p
+     PAlt p q -> checks [inferPatt p, inferPatt q]
+     PSeq _ _ -> return $ typeStr
+     PChar    -> return $ typeStr
+     PRep _   -> return $ typeStr
+     _ -> infer (patt2term p) >>= return . snd
+
+
+-- type inference: Nothing, type checking: Just t
+-- the latter permits matching with value type
+getOverload :: SourceGrammar -> Maybe Type -> Term -> Check (Maybe (Term,Type))
+getOverload env@gr mt t = case appForm t of
+     (f@(Q m c), ts) -> case lookupOverload gr m c of
+       Ok typs -> do
+         ttys <- mapM infer ts
+         v <- matchOverload f typs ttys
+         return $ Just v
+       _ -> return Nothing
+     _ -> return Nothing
+ where
+   infer = inferLType env
+   matchOverload f typs ttys = do
+     let (tts,tys) = unzip ttys
+     let vfs = lookupOverloadInstance tys typs
+
+     case [vf | vf@(v,f) <- vfs, matchVal mt v] of
+       [(val,fun)] -> return (mkApp fun tts, val)
+       [] -> raise $ "no overload instance of" +++ prt f +++ 
+         "for" +++ unwords (map (prtType env) tys) +++ "among" ++++ 
+         unlines ["  " ++ unwords (map (prtType env) ty) | (ty,_) <- typs] ++
+         maybe [] (("with value type" +++) . prtType env) mt
+
+      ----  ++++ "DEBUG" +++ unwords (map show tys) +++ ";" 
+      ----  ++++ unlines (map (show . fst) typs) ----
+
+       vfs' -> case [(v,f) | (v,f) <- vfs', noProd v] of
+         [(val,fun)] -> do
+           checkWarn $ "WARNING: overloading of" +++ prt f +++ 
+             "resolved by excluding partial applications:" ++++
+             unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)]
+           return (mkApp fun tts, val)
+
+         _ -> raise $ "ambiguous overloading of" +++ prt f +++
+           "for" +++ unwords (map (prtType env) tys) ++++ "with alternatives" ++++ 
+           unlines [prtType env ty | (ty,_) <- vfs']
+
+   matchVal mt v = elem mt ([Nothing,Just v] ++ unlocked) where
+     unlocked = case v of
+       RecType fs -> [Just $ RecType $ filter (not . isLockLabel . fst) fs]
+       _ -> []
+   ---- TODO: accept subtypes
+   ---- TODO: use a trie
+   lookupOverloadInstance tys typs = 
+     [(mkFunType rest val, t) | 
+       let lt = length tys,
+       (ty,(val,t)) <- typs, length ty >= lt,
+       let (pre,rest) = splitAt lt ty, 
+       pre == tys
+     ]
+
+   noProd ty = case ty of
+     Prod _ _ _ -> False
+     _ -> True
+
+checkLType :: SourceGrammar -> Term -> Type -> Check (Term, Type)
+checkLType env trm typ0 = do
+
+  typ <- comp typ0
+
+  case trm of
+
+    Abs x c -> do
+      case typ of
+        Prod z a b -> do 
+          checkUpdate (x,a)
+          (c',b') <- if isWildIdent z
+                        then check c b
+                        else do
+                          b' <- checkIn "abs" $ substituteLType [(z,Vr x)] b
+                          check c b'
+          checkReset
+          return $ (Abs x c', Prod x a b')
+        _ -> raise $ "product expected instead of" +++ prtType env typ
+
+    App f a -> do
+       over <- getOverload env (Just typ) trm
+       case over of
+         Just trty -> return trty
+         _ -> do
+          (trm',ty') <- infer trm
+          termWith trm' $ checkEq typ ty' trm'
+
+    Q _ _ -> do
+       over <- getOverload env (Just typ) trm
+       case over of
+         Just trty -> return trty
+         _ -> do
+          (trm',ty') <- infer trm
+          termWith trm' $ checkEq typ ty' trm'
+
+    T _ [] ->
+      prtFail "found empty table in type" typ
+    T _ cs -> case typ of 
+      Table arg val -> do 
+        case allParamValues env arg of
+          Ok vs -> do
+            let ps0 = map fst cs
+            ps <- checkErr $ testOvershadow ps0 vs
+            if null ps 
+              then return () 
+              else checkWarn $ "WARNING: patterns never reached:" +++ 
+                               concat (intersperse ", " (map prt ps))
+
+          _ -> return () -- happens with variable types
+        cs' <- mapM (checkCase arg val) cs
+        return (T (TTyped arg) cs', typ)
+      _ -> raise $ "table type expected for table instead of" +++ prtType env typ
+
+    R r -> case typ of --- why needed? because inference may be too difficult
+       RecType rr -> do
+         let (ls,_) = unzip rr        -- labels of expected type
+         fsts <- mapM (checkM r) rr   -- check that they are found in the record
+         return $ (R fsts, typ)       -- normalize record
+
+       _ -> prtFail "record type expected in type checking instead of" typ
+
+    ExtR r s -> case typ of
+       _ | typ == typeType -> do
+         trm' <- comp trm
+         case trm' of
+           RecType _ -> termWith trm $ return typeType
+           ExtR (Vr _) (RecType _) -> termWith trm $ return typeType 
+                                      -- ext t = t ** ...
+           _ -> prtFail "invalid record type extension" trm
+       RecType rr -> do
+         (r',ty,s') <- checks [
+            do (r',ty) <- infer r
+               return (r',ty,s)
+           ,
+            do (s',ty) <- infer s
+               return (s',ty,r)
+            ]
+         case ty of
+           RecType rr1 -> do
+                let (rr0,rr2) = recParts rr rr1
+                r2 <- justCheck r' rr0
+                s2 <- justCheck s' rr2
+                return $ (ExtR r2 s2, typ) 
+           _ -> raise ("record type expected in extension of" +++ prt r +++ 
+                       "but found" +++ prt ty)
+
+       ExtR ty ex -> do
+         r' <- justCheck r ty
+         s' <- justCheck s ex
+         return $ (ExtR r' s', typ) --- is this all?
+
+       _ -> prtFail "record extension not meaningful for" typ
+
+    FV vs -> do
+      ttys <- mapM (flip check typ) vs
+---      checkIfComplexVariantType trm typ
+      return (FV (map fst ttys), typ) --- typ' ?
+
+    S tab arg -> checks [ do
+      (tab',ty) <- infer tab
+      ty'       <- comp ty
+      case ty' of
+        Table p t -> do
+          (arg',val) <- check arg p
+          checkEq typ t trm
+          return (S tab' arg', t)
+        _ -> raise $ "table type expected for applied table instead of" +++ 
+                   prtType env ty'
+     , do
+      (arg',ty) <- infer arg
+      ty'       <- comp ty
+      (tab',_)  <- check tab (Table ty' typ)
+      return (S tab' arg', typ)
+      ]
+    Let (x,(mty,def)) body -> case mty of
+      Just ty -> do
+        (def',ty') <- check def ty
+        checkUpdate (x,ty')
+        body' <- justCheck body typ
+        checkReset
+        return (Let (x,(Just ty',def')) body', typ)
+      _ -> do
+        (def',ty) <- infer def  -- tries to infer type of local constant
+        check (Let (x,(Just ty,def')) body) typ
+
+    _ -> do
+      (trm',ty') <- infer trm
+      termWith trm' $ checkEq typ ty' trm'
+ where
+   cnc = env
+   infer = inferLType env
+   comp = computeLType env 
+
+   check = checkLType env
+   
+   justCheck ty te = check ty te >>= return . fst
+
+   checkEq = checkEqLType env
+
+   recParts rr t = (RecType rr1,RecType rr2) where 
+     (rr1,rr2) = partition (flip elem (map fst t) . fst) rr 
+
+   checkM rms (l,ty) = case lookup l rms of
+     Just (Just ty0,t) -> do
+       checkEq ty ty0 t
+       (t',ty') <- check t ty
+       return (l,(Just ty',t'))
+     Just (_,t) -> do
+       (t',ty') <- check t ty
+       return (l,(Just ty',t'))
+     _ -> prtFail "cannot find value for label" l
+
+   checkCase arg val (p,t) = do
+     cont <- pattContext env arg p
+     i    <- checkUpdates cont
+     t'   <- justCheck t val
+     checkResets i
+     return (p,t')
+
+pattContext :: LTEnv -> Type -> Patt -> Check Context
+pattContext env typ p = case p of
+  PV x | not (isWildIdent x) -> return [(x,typ)]
+  PP q c ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006
+    t <- checkErr $ lookupResType cnc q c
+    (cont,v) <- checkErr $ typeFormCnc t
+    checkCond ("wrong number of arguments for constructor in" +++ prt p) 
+              (length cont == length ps)
+    checkEqLType env typ v (patt2term p)
+    mapM (uncurry (pattContext env)) (zip (map snd cont) ps) >>= return . concat
+  PR r -> do
+    typ' <- computeLType env typ
+    case typ' of
+      RecType t -> do
+        let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]]
+        ----- checkWarn $ prt p ++++ show pts ----- debug
+        mapM (uncurry (pattContext env)) pts >>= return . concat
+      _ -> prtFail "record type expected for pattern instead of" typ'
+  PT t p' -> do
+    checkEqLType env typ t (patt2term p')
+    pattContext env typ p'
+
+  PAs x p -> do
+    g <- pattContext env typ p
+    return $ (x,typ):g
+
+  PAlt p' q -> do
+    g1 <- pattContext env typ p'
+    g2 <- pattContext env typ q
+    let pts = [pt | pt <- g1, notElem pt g2] ++ [pt | pt <- g2, notElem pt g1]
+    checkCond 
+      ("incompatible bindings of" +++ 
+       unwords (nub (map (prt . fst) pts))+++ 
+       "in pattern alterantives" +++ prt p) (null pts) 
+    return g1 -- must be g1 == g2
+  PSeq p q -> do
+    g1 <- pattContext env typ p
+    g2 <- pattContext env typ q
+    return $ g1 ++ g2
+  PRep p' -> noBind typeStr p'
+  PNeg p' -> noBind typ p'
+
+  _ -> return [] ---- check types!
+ where 
+   cnc = env
+   noBind typ p' = do
+    co <- pattContext env typ p'
+    if not (null co)
+      then checkWarn ("no variable bound inside pattern" +++ prt p) 
+           >> return []
+      else return []
+
+-- auxiliaries
+
+type LTEnv = SourceGrammar
+
+termWith :: Term -> Check Type -> Check (Term, Type)
+termWith t ct = do
+  ty <- ct
+  return (t,ty)
+
+-- | light-weight substitution for dep. types
+substituteLType :: Context -> Type -> Check Type
+substituteLType g t = case t of
+  Vr x -> return $ maybe t id $ lookup x g
+  _ -> composOp (substituteLType g) t
+
+-- | compositional check\/infer of binary operations
+check2 :: (Term -> Check Term) -> (Term -> Term -> Term) -> 
+          Term -> Term -> Type -> Check (Term,Type)
+check2 chk con a b t = do
+  a' <- chk a
+  b' <- chk b
+  return (con a' b', t)
+
+checkEqLType :: LTEnv -> Type -> Type -> Term -> Check Type
+checkEqLType env t u trm = do
+  (b,t',u',s) <- checkIfEqLType env t u trm
+  case b of
+    True  -> return t'
+    False -> raise $ s +++ "type of" +++ prt trm +++ 
+                        ": expected:" +++ prtType env t ++++ 
+                        "inferred:" +++ prtType env u
+
+checkIfEqLType :: LTEnv -> Type -> Type -> Term -> Check (Bool,Type,Type,String)
+checkIfEqLType env t u trm = do
+  t' <- comp t 
+  u' <- comp u
+  case t' == u' || alpha [] t' u' of
+    True -> return (True,t',u',[])
+    -- forgive missing lock fields by only generating a warning.
+    --- better: use a flag to forgive? (AR 31/1/2006)
+    _ -> case missingLock [] t' u' of
+      Ok lo -> do
+        checkWarn $ "WARNING: missing lock field" +++ unwords (map prt lo)
+        return (True,t',u',[])
+      Bad s -> return (False,t',u',s)
+
+  where
+
+   -- t is a subtype of u 
+   --- quick hack version of TC.eqVal
+   alpha g t u = case (t,u) of  
+
+     -- error (the empty type!) is subtype of any other type
+     (_,Q (IC "Predef") (IC "Error")) -> True
+
+     -- contravariance
+     (Prod x a b, Prod y c d) -> alpha g c a && alpha ((x,y):g) b d 
+                              
+     -- record subtyping
+     (RecType rs, RecType ts) -> all (\ (l,a) -> 
+                                   any (\ (k,b) -> alpha g a b && l == k) ts) rs
+     (ExtR r s, ExtR r' s') -> alpha g r r' && alpha g s s'
+     (ExtR r s, t) -> alpha g r t || alpha g s t
+
+     -- the following say that Ints n is a subset of Int and of Ints m >= n
+     (App (Q (IC "Predef") (IC "Ints")) (EInt n), 
+        App (Q (IC "Predef") (IC "Ints")) (EInt m)) -> m >= n
+     (App (Q (IC "Predef") (IC "Ints")) (EInt n), 
+        Q (IC "Predef") (IC "Int"))                 -> True ---- check size!
+     
+     (Q (IC "Predef") (IC "Int"),  ---- why this ???? AR 11/12/2005
+        App (Q (IC "Predef") (IC "Ints")) (EInt n)) -> True
+
+     ---- this should be made in Rename
+     (Q  m a, Q  n b) | a == b -> elem m (allExtendsPlus env n) 
+                               || elem n (allExtendsPlus env m)
+                               || m == n --- for Predef
+     (QC m a, QC n b) | a == b -> elem m (allExtendsPlus env n) 
+                               || elem n (allExtendsPlus env m)
+     (QC m a, Q  n b) | a == b -> elem m (allExtendsPlus env n) 
+                               || elem n (allExtendsPlus env m)
+     (Q  m a, QC n b) | a == b -> elem m (allExtendsPlus env n) 
+                               || elem n (allExtendsPlus env m)
+
+     (Table a b,  Table c d)  -> alpha g a c && alpha g b d
+     (Vr x,       Vr y)       -> x == y || elem (x,y) g || elem (y,x) g
+     _                        -> t == u 
+     --- the following should be one-way coercions only. AR 4/1/2001
+                                  || elem t sTypes && elem u sTypes
+                                  || (t == typeType && u == typePType) 
+                                  || (u == typeType && t == typePType) 
+
+   missingLock g t u = case (t,u) of  
+     (RecType rs, RecType ts) -> 
+       let 
+         ls = [l | (l,a) <- rs, 
+                   not (any (\ (k,b) -> alpha g a b && l == k) ts)]
+         (locks,others) = partition isLockLabel ls
+       in case others of
+         _:_ -> Bad $ "missing record fields" +++ unwords (map prt others)
+         _ -> return locks
+     -- contravariance
+     (Prod x a b, Prod y c d) -> do
+        ls1 <- missingLock g c a
+        ls2 <- missingLock g b d
+        return $ ls1 ++ ls2
+
+     _ -> Bad ""
+
+   sTypes = [typeStr, typeTok, typeString]
+   comp = computeLType env
+
+-- printing a type with a lock field lock_C as C
+prtType :: LTEnv -> Type -> String
+prtType env ty = case ty of
+  RecType fs -> case filter isLockLabel $ map fst fs of
+    [lock] -> (drop 5 $ prt lock) --- ++++ "Full form" +++ prt ty
+    _ -> prtt ty
+  Prod x a b -> prtType env a +++ "->" +++ prtType env b
+  _ -> prtt ty
+ where
+   prtt t = prt t
+   ---- use computeLType gr to check if really equal to the cat with lock
+
+
+-- | linearization types and defaults
+linTypeOfType :: SourceGrammar -> Ident -> Type -> Check (Context,Type)
+linTypeOfType cnc m typ = do
+  (cont,cat) <- checkErr $ typeSkeleton typ
+  val  <- lookLin cat
+  args <- mapM mkLinArg (zip [0..] cont)
+  return (args, val)
+ where
+   mkLinArg (i,(n,mc@(m,cat))) = do
+     val  <- lookLin mc
+     let vars = mkRecType varLabel $ replicate n typeStr
+	 symb = argIdent n cat i
+     rec <- checkErr $ errIn ("extending" +++ prt vars +++ "with" +++ prt val) $
+            plusRecType vars val
+     return (symb,rec)
+   lookLin (_,c) = checks [ --- rather: update with defLinType ?
+      checkErr (lookupLincat cnc m c) >>= computeLType cnc
+     ,return defLinType
+     ]
+
+-- | dependency check, detecting circularities and returning topo-sorted list
+
+allOperDependencies :: Ident -> BinTree Ident Info -> [(Ident,[Ident])]
+allOperDependencies m = allDependencies (==m)
+
+allDependencies :: (Ident -> Bool) -> BinTree Ident Info -> [(Ident,[Ident])]
+allDependencies ism b = 
+  [(f, nub (concatMap opty (pts i))) | (f,i) <- tree2list b]
+  where
+    opersIn t = case t of
+      Q n c | ism n -> [c]
+      QC n c | ism n -> [c]
+      _ -> collectOp opersIn t
+    opty (Yes ty) = opersIn ty
+    opty _ = []
+    pts i = case i of
+      ResOper pty pt -> [pty,pt]
+      ResParam (Yes (ps,_)) -> [Yes t | (_,cont) <- ps, (_,t) <- cont]
+      CncCat pty _ _ -> [pty]
+      CncFun _   pt _ -> [pt]  ---- (Maybe (Ident,(Context,Type))
+      AbsFun pty ptr -> [pty] --- ptr is def, which can be mutual
+      AbsCat (Yes co) _ -> [Yes ty | (_,ty) <- co]
+      _              -> []
+
+topoSortOpers :: [(Ident,[Ident])] -> Err [Ident]
+topoSortOpers st = do
+  let eops = topoTest st
+  either 
+    return 
+    (\ops -> Bad ("circular definitions:" +++ unwords (map prt (head ops))))
+    eops
diff --git a/src-3.0/GF/Compile/Compile.hs b/src-3.0/GF/Compile/Compile.hs
new file mode 100644
index 000000000..422df0fd5
--- /dev/null
+++ b/src-3.0/GF/Compile/Compile.hs
@@ -0,0 +1,401 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Compile
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/10/05 20:02:19 $
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.45 $
+--
+-- The top-level compilation chain from source file to gfc\/gfr.
+-----------------------------------------------------------------------------
+
+module GF.Compile.Compile (compileModule, compileEnvShSt, compileOne,
+		CompileEnv, TimedCompileEnv,gfGrammarPathVar,pathListOpts,
+	       getGFEFiles) where
+
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Infra.Option
+import GF.Infra.CompactPrint
+import GF.Grammar.PrGrammar
+import GF.Compile.Update
+import GF.Grammar.Lookup
+import GF.Infra.Modules
+import GF.Infra.ReadFiles
+import GF.Compile.ShellState
+import GF.Compile.MkResource
+---- import MkUnion
+
+-- the main compiler passes
+import GF.Compile.GetGrammar
+import GF.Compile.Extend
+import GF.Compile.Rebuild
+import GF.Compile.Rename
+import GF.Grammar.Refresh
+import GF.Compile.CheckGrammar
+import GF.Compile.Optimize
+import GF.Compile.Evaluate
+import GF.Compile.GrammarToCanon
+--import GF.Devel.GrammarToGFCC -----
+import GF.Devel.OptimizeGF (subexpModule,unsubexpModule)
+import GF.Canon.Share
+import GF.Canon.Subexpressions (elimSubtermsMod,unSubelimModule)
+import GF.UseGrammar.Linear (unoptimizeCanonMod) ----
+
+import qualified GF.Canon.CanonToGrammar as CG
+
+import qualified GF.Canon.GFC as GFC
+import qualified GF.Canon.MkGFC as MkGFC
+import GF.Canon.GetGFC
+
+import GF.Data.Operations
+import GF.Infra.UseIO
+import GF.Text.UTF8 ----
+import GF.System.Arch
+
+import Control.Monad
+import System.Directory
+import System.FilePath
+
+-- | in batch mode: write code in a file
+batchCompile f = liftM fst $ compileModule defOpts emptyShellState f
+  where
+    defOpts = options [emitCode] 
+batchCompileOpt f = liftM fst $ compileModule defOpts emptyShellState f
+  where
+    defOpts = options [emitCode, optimizeCanon] 
+
+batchCompileOld f = compileOld defOpts f
+  where
+    defOpts = options [emitCode] 
+
+-- | compile with one module as starting point
+-- command-line options override options (marked by --#) in the file
+-- As for path: if it is read from file, the file path is prepended to each name.
+-- If from command line, it is used as it is.
+compileModule :: Options -> ShellState -> FilePath -> IOE TimedCompileEnv
+----             IOE (GFC.CanonGrammar, (SourceGrammar,[(String,(FilePath,ModTime))]))
+
+compileModule opts st0 file | 
+     oElem showOld opts || 
+     elem suff [".cf",".ebnf",".gfm"] = do
+  let putp  = putPointE opts
+  let putpp = putPointEsil opts
+  let path = [] ----
+  grammar1 <- case suff of
+    ".cf"   -> putp ("- parsing" +++ suff +++ file) $ getCFGrammar opts file
+    ".ebnf" -> putp ("- parsing" +++ suff +++ file) $ getEBNFGrammar opts file
+    ".gfm"  -> putp ("- parsing" +++ suff +++ file) $ getSourceGrammar opts file
+    _       -> putp ("- parsing old gf" +++ file)   $ getOldGrammar opts file
+  let mods = modules grammar1
+  let env = compileEnvShSt st0 []
+  foldM (comp putpp path) env mods
+ where
+   suff = takeExtensions file
+   comp putpp path env sm0 = do
+     (k',sm,eenv')  <- makeSourceModule opts (fst env) sm0
+     cm  <- putpp "  generating code... " $ generateModuleCode opts path sm
+     ft <- getReadTimes file ---
+     extendCompileEnvInt env (k',sm,cm) eenv' ft
+
+compileModule opts1 st0 file = do
+  opts0 <- ioeIO $ getOptionsFromFile file
+  let useFileOpt = maybe False (const True) $ getOptVal opts0 pathList
+  let useLineOpt = maybe False (const True) $ getOptVal opts1 pathList
+  let opts = addOptions opts1 opts0 
+  let fpath = dropFileName file
+  ps0 <- ioeIO $ pathListOpts opts fpath
+
+  let ps1 = if (useFileOpt && not useLineOpt) 
+              then (ps0 ++ map (combine fpath) ps0)
+              else ps0
+  ps <- ioeIO $ extendPathEnv ps1
+  let ioeIOIf = if oElem beVerbose opts then ioeIO else (const (return ()))
+  ioeIOIf $ putStrLn $ "module search path:" +++ show ps ----
+  let st = st0 --- if useFileOpt then emptyShellState else st0
+  let rfs = [(m,t) | (m,(_,t)) <- readFiles st]
+  let file' = if useFileOpt then takeFileName file else file -- to find file itself
+  files <- getAllFiles opts ps rfs file'
+  ioeIOIf $ putStrLn $ "files to read:" +++ show files ----
+  let names = map justModuleName files
+  ioeIOIf $ putStrLn $ "modules to include:" +++ show names ----
+  let env0 = compileEnvShSt st names
+  (e,mm) <- foldIOE (compileOne opts) env0 files
+  maybe (return ()) putStrLnE mm
+  return e
+
+getReadTimes file = do
+  t <- ioeIO getNowTime
+  let m = justModuleName file
+  return $ (m,(file,t)) : [(resModName m,(file,t)) | not (isGFC file)]
+
+compileEnvShSt :: ShellState -> [ModName] -> TimedCompileEnv
+compileEnvShSt st fs = ((0,sgr,cgr,eenv),fts) where
+  cgr = MGrammar [m | m@(i,_) <- modules (canModules st), notInc i]
+  sgr = MGrammar [m | m@(i,_) <- modules (srcModules st), notIns i]
+  notInc i = notElem (prt i) $ map dropExtension fs
+  notIns i = notElem (prt i) $ map dropExtension fs
+  fts = readFiles st
+  eenv = evalEnv st
+
+pathListOpts :: Options -> FileName -> IO [InitPath]
+pathListOpts opts file = return $ maybe [file] splitInModuleSearchPath $ getOptVal opts pathList
+
+reverseModules (MGrammar ms) = MGrammar $ reverse ms
+
+keepResModules :: Options -> SourceGrammar -> SourceGrammar
+keepResModules opts gr = 
+  if oElem retainOpers opts 
+    then MGrammar $ reverse [(i,mi) | (i,mi@(ModMod m)) <- modules gr, isModRes m]
+    else emptyMGrammar
+
+
+-- | the environment
+type CompileEnv = (Int,SourceGrammar, GFC.CanonGrammar,EEnv)
+
+emptyCompileEnv :: TimedCompileEnv
+emptyCompileEnv = ((0,emptyMGrammar,emptyMGrammar,emptyEEnv),[])
+
+extendCompileEnvInt ((_,MGrammar ss, MGrammar cs,_),fts) (k,sm,cm) eenv ft = 
+  return ((k,MGrammar (sm:ss), MGrammar (cm:cs),eenv),ft++fts) --- reverse later
+
+extendCompileEnv e@((k,_,_,_),_) (sm,cm) = extendCompileEnvInt e (k,sm,cm)
+
+extendCompileEnvCanon ((k,s,c,e),fts) cgr eenv ft = 
+  return ((k,s, MGrammar (modules cgr ++ modules c),eenv),ft++fts)
+
+type TimedCompileEnv = (CompileEnv,[(String,(FilePath,ModTime))])
+
+compileOne :: Options -> TimedCompileEnv -> FullPath -> IOE TimedCompileEnv
+compileOne opts env@((_,srcgr,cancgr0,eenv),_) file = do
+
+  let putp = putPointE opts
+  let putpp = putPointEsil opts
+  let putpOpt v m act
+       | oElem beVerbose opts =  putp v act
+       | oElem beSilent opts  =  putpp v act
+       | otherwise = ioeIO (putStrFlush m) >> act
+
+  let gf   = takeExtensions file
+  let path = dropFileName file
+  let name = dropExtension file
+  let mos  = modules srcgr
+
+  case gf of
+    -- for multilingual canonical gf, just read the file and update environment
+    ".gfcm" -> do
+       cgr <- putp ("+ reading" +++ file) $ getCanonGrammar file
+       ft <- getReadTimes file
+       extendCompileEnvCanon env cgr eenv ft
+
+    -- for canonical gf, read the file and update environment, also source env
+    ".gfc" -> do
+       cm <- putp ("+ reading" +++ file) $ getCanonModule file
+       let cancgr = updateMGrammar (MGrammar [cm]) cancgr0 
+       sm <- ioeErr $ CG.canon2sourceModule $ unoptimizeCanonMod cancgr $ unSubelimModule cm
+       ft <- getReadTimes file
+       extendCompileEnv env (sm, cm) eenv ft
+
+    -- for compiled resource, parse and organize, then update environment
+    ".gfr" -> do
+       sm0 <- putp ("| reading" +++ file) $ getSourceModule opts file
+       let sm1 = unsubexpModule sm0
+       sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule mos sm1
+---- experiment with not optimizing gfr 
+----      sm:_  <- putp "  optimizing " $ ioeErr $ evalModule mos sm1
+       let gfc = gfcFile name 
+       cm  <- putp ("+ reading" +++ gfc) $ getCanonModule gfc
+       ft  <- getReadTimes file
+       extendCompileEnv env (sm,cm) eenv ft
+
+    -- for gf source, do full compilation
+
+    _ -> do
+
+      --- hack fix to a bug in ReadFiles with reused concrete
+
+      let modu = dropExtension file
+      b1 <- ioeIO $ doesFileExist file
+      b2 <- ioeIO $ doesFileExist $ gfrFile modu
+      if not b1
+        then if b2 
+          then compileOne opts env $ gfrFile $ modu 
+          else compileOne opts env $ gfcFile $ modu 
+        else do
+
+       sm0 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $ 
+                                           getSourceModule opts file
+       (k',sm,eenv')  <- makeSourceModule opts (fst env) sm0
+       cm  <- putpp "  generating code... " $ generateModuleCode opts path sm
+       ft <- getReadTimes file
+
+       sm':_ <- case snd sm of
+----         ModMod n | isModRes n -> putp "  optimizing " $ ioeErr $ evalModule mos sm
+         _ -> return [sm]
+
+       extendCompileEnvInt env (k',sm',cm) eenv' ft
+
+-- | dispatch reused resource at early stage
+makeSourceModule :: Options -> CompileEnv -> 
+                    SourceModule -> IOE (Int,SourceModule,EEnv)
+makeSourceModule opts env@(k,gr,can,eenv) mo@(i,mi) = case mi of
+
+  ModMod m -> case mtype m of
+    MTReuse c -> do
+      sm <- ioeErr $ makeReuse gr i (extend m) c
+      let mo2 = (i, ModMod sm)
+          mos = modules gr
+      --- putp "  type checking reused" $ ioeErr $ showCheckModule mos mo2
+      return $ (k,mo2,eenv)
+{- ---- obsolete
+    MTUnion ty imps -> do
+      mo' <- ioeErr $ makeUnion gr i ty imps
+      compileSourceModule opts env mo'
+-}
+
+    _ -> compileSourceModule opts env mo
+  _ -> compileSourceModule opts env mo
+ where
+   putp = putPointE opts
+
+compileSourceModule :: Options -> CompileEnv -> 
+                       SourceModule -> IOE (Int,SourceModule,EEnv)
+compileSourceModule opts env@(k,gr,can,eenv) mo@(i,mi) = do
+
+  let putp  = putPointE opts
+      putpp = putPointEsil opts
+      mos   = modules gr
+
+  if (oElem showOld opts && oElem emitCode opts) 
+    then do
+      let (file,out) = (gfFile (prt i), prGrammar (MGrammar [mo]))
+      putp ("  wrote file" +++ file) $ ioeIO $ writeFile file out
+    else return ()
+
+  mo1   <- ioeErr $ rebuildModule mos mo
+
+  mo1b  <- ioeErr $ extendModule mos mo1
+
+  case mo1b of
+    (_,ModMod n) | not (isCompleteModule n) -> do
+      return (k,mo1b,eenv)   -- refresh would fail, since not renamed
+    _ -> do
+      mo2:_ <- putpp "  renaming " $ ioeErr $ renameModule mos mo1b
+
+      (mo3:_,warnings) <- putpp "  type checking" $ ioeErr $ showCheckModule mos mo2
+      if null warnings then return () else putp warnings $ return ()
+
+      (k',mo3r:_) <- putpp "  refreshing " $ ioeErr $ refreshModule (k,mos) mo3
+
+      (mo4,eenv') <- 
+        ---- if oElem "check_only" opts 
+          putpp "  optimizing " $ ioeErr $ optimizeModule opts (mos,eenv) mo3r
+      return (k',mo4,eenv')
+ where
+   ----   prDebug mo = ioeIO $ putStrLn $ prGrammar $ MGrammar [mo] ---- debug
+   prDebug mo = ioeIO $ print $ length $ lines $ prGrammar $ MGrammar [mo]
+
+generateModuleCode :: Options -> InitPath -> SourceModule -> IOE GFC.CanonModule
+generateModuleCode opts path minfo@(name,info) = do
+
+--- DEPREC
+---  if oElem (iOpt "gfcc") opts
+---    then ioeIO $ putStrLn $ prGrammar2gfcc minfo
+---    else return ()
+
+  let pname = path </> prt name
+  minfo0     <- ioeErr $ redModInfo minfo
+  let oopts  = addOptions opts (iOpts (flagsModule minfo))
+      optims = maybe "all_subs" id $ getOptVal oopts useOptimizer
+      optim  = takeWhile (/='_') optims
+      subs   = drop 1 (dropWhile (/='_') optims) == "subs"
+  minfo1     <- return $ 
+    case optim of
+      "parametrize" -> shareModule paramOpt minfo0  -- parametrization and sharing
+      "values"      -> shareModule valOpt minfo0    -- tables as courses-of-values
+      "share"       -> shareModule shareOpt minfo0  -- sharing of branches
+      "all"         -> shareModule allOpt minfo0    -- first parametrize then values
+      "none"        -> minfo0                       -- no optimization
+      _             -> shareModule shareOpt minfo0  -- sharing; default
+
+  -- do common subexpression elimination if required by flag "subs"
+  minfo' <- 
+    if subs
+      then ioeErr $ elimSubtermsMod minfo1
+      else return minfo1
+
+  -- for resource, also emit gfr. 
+  --- Also for incomplete, to create timestamped gfc/gfr files
+  case info of
+    ModMod m | emitsGFR m && emit && nomulti -> do
+      let rminfo = if isCompilable info 
+                   then subexpModule minfo 
+                   else (name, ModMod emptyModule) 
+      let (file,out) = (gfrFile pname, prGrammar (MGrammar [rminfo]))
+      putp ("  wrote file" +++ file) $ ioeIO $ writeFile file $ compactPrint out
+    _ -> return ()
+  let encode = case getOptVal opts uniCoding of
+        Just "utf8" -> encodeUTF8
+        _ -> id
+  (file,out) <- do
+      code <- return $ MkGFC.prCanonModInfo minfo'
+      return (gfcFile pname, encode code)
+  if emit && nomulti ---- && isCompilable info 
+     then putp  ("  wrote file" +++ file) $ ioeIO $ writeFile file out
+     else putpp ("no need to save module" +++ prt name) $ return ()
+  return minfo'
+ where 
+   putp  = putPointE opts
+   putpp = putPointEsil opts
+
+   emitsGFR m = isModRes m ---- && isCompilable info
+     ---- isModRes m || (isModCnc m && mstatus m == MSIncomplete)
+   isCompilable mi = case mi of
+     ModMod m -> not $ isModCnc m && mstatus m == MSIncomplete 
+     _ -> True
+   nomulti = not $ oElem makeMulti opts
+   emit  = oElem emitCode opts && not (oElem notEmitCode opts)
+
+-- for old GF: sort into modules, write files, compile as usual
+
+compileOld :: Options -> FilePath -> IOE GFC.CanonGrammar
+compileOld opts file = do
+  let putp = putPointE opts
+  grammar1 <- putp ("- parsing old gf" +++ file) $ getOldGrammar opts file
+  files <- mapM writeNewGF $ modules grammar1
+  ((_,_,grammar,_),_) <- foldM (compileOne opts) emptyCompileEnv files
+  return grammar
+
+writeNewGF :: SourceModule -> IOE FilePath
+writeNewGF m@(i,_) = do
+  let file = gfFile $ prt i
+  ioeIO $ writeFile file $ prGrammar (MGrammar [m])
+  ioeIO $ putStrLn $ "wrote file" +++ file
+  return file
+
+--- this function duplicates a lot of code from compileModule.
+--- It does not really belong here either.
+-- It selects those .gfe files that a grammar depends on and that
+-- are younger than corresponding gf
+
+getGFEFiles :: Options -> FilePath -> IO [FilePath]
+getGFEFiles opts1 file = useIOE [] $ do
+  opts0 <- ioeIO $ getOptionsFromFile file
+  let useFileOpt = maybe False (const True) $ getOptVal opts0 pathList
+  let useLineOpt = maybe False (const True) $ getOptVal opts1 pathList
+  let opts = addOptions opts1 opts0 
+  let fpath = dropFileName file
+  ps0 <- ioeIO $ pathListOpts opts fpath
+
+  let ps1 = if (useFileOpt && not useLineOpt) 
+              then (map (combine fpath) ps0)
+              else ps0
+  ps <- ioeIO $ extendPathEnv ps1
+  let file' = if useFileOpt then takeFileName file else file -- to find file itself
+  files <- getAllFiles opts ps [] file'
+  efiles <- ioeIO $ filterM doesFileExist [replaceExtension f "gfe" | f <- files]
+  es <- ioeIO $ mapM (uncurry selectLater) [(f, init f) | f <- efiles] -- init gfe == gf
+  return $ filter ((=='e') . last) es
diff --git a/src-3.0/GF/Compile/Evaluate.hs b/src-3.0/GF/Compile/Evaluate.hs
new file mode 100644
index 000000000..a574fef40
--- /dev/null
+++ b/src-3.0/GF/Compile/Evaluate.hs
@@ -0,0 +1,477 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Evaluate
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/01 15:39:12 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.19 $
+--
+-- Computation of source terms. Used in compilation and in @cc@ command.
+-----------------------------------------------------------------------------
+
+module GF.Compile.Evaluate (appEvalConcrete, EEnv, emptyEEnv) where
+
+import GF.Data.Operations
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Data.Str
+import GF.Grammar.PrGrammar
+import GF.Infra.Modules
+import GF.Infra.Option
+import GF.Grammar.Macros
+import GF.Grammar.Lookup
+import GF.Grammar.Refresh
+import GF.Grammar.PatternMatch
+import GF.Grammar.Lockfield (isLockLabel) ----
+
+import GF.Grammar.AppPredefined
+
+import qualified Data.Map as Map
+
+import Data.List (nub,intersperse)
+import Control.Monad (liftM2, liftM)
+import Debug.Trace
+
+
+data EEnv = EEnv {
+  computd :: Map.Map (Ident,Ident) FTerm,
+  temp :: Int
+  }
+
+emptyEEnv = EEnv Map.empty 0
+
+lookupComputed :: (Ident,Ident) -> STM EEnv (Maybe FTerm)
+lookupComputed mc = do
+  env <- readSTM
+  return $ Map.lookup mc $ computd env
+
+updateComputed :: (Ident,Ident) -> FTerm -> STM EEnv ()
+updateComputed mc t = 
+  updateSTM (\e -> e{computd = Map.insert mc t (computd e)})
+
+getTemp :: STM EEnv Ident
+getTemp = do
+  env <- readSTM
+  updateSTM (\e -> e{temp = temp e + 1})
+  return $ identC ("#" ++ show (temp env))
+
+data FTerm = 
+    FTC Term
+  | FTF (Term -> FTerm)
+
+prFTerm :: Integer -> FTerm -> String
+prFTerm i t = case t of
+  FTC t -> prt t
+  FTF f -> show i +++ "->" +++ prFTerm (i + 1) (f (EInt i))
+
+term2fterm t = case t of
+  Abs x b -> FTF (\t -> term2fterm (subst [(x,t)] b))
+  _ -> FTC t
+
+traceFTerm c ft = ft ----
+----trace ("\n" ++ prt c +++ "=" +++ take 60 (prFTerm 0 ft)) ft
+
+fterm2term :: FTerm -> STM EEnv Term
+fterm2term t = case t of
+  FTC t -> return t
+  FTF f -> do
+    x <- getTemp
+    b <- fterm2term $ f (Vr x)
+    return $ Abs x b
+
+subst g t = case t of
+  Vr x -> maybe t id $ lookup x g
+  _ -> composSafeOp (subst g) t
+
+
+appFTerm :: FTerm -> [Term] -> FTerm
+appFTerm ft ts = case (ft,ts) of
+  (FTF f, x:xs) -> appFTerm (f x) xs 
+  (FTC c, _:_) -> FTC $ foldl App c ts
+  _ -> ft
+
+apps :: Term -> (Term,[Term])
+apps t = case t of
+  App f a -> (f',xs ++ [a]) where (f',xs) = apps f
+  _ -> (t,[])
+
+appEvalConcrete gr bt env = appSTM (evalConcrete gr bt) env
+
+evalConcrete :: SourceGrammar -> BinTree Ident Info -> STM EEnv (BinTree Ident Info)
+evalConcrete gr mo = mapMTree evaldef mo where
+
+  evaldef (f,info) = case info of
+    CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr -> 
+       evalIn ("\nerror in linearization of function" +++ prt f +++ ":") $ 
+      do
+      pde' <- case pde of
+        Yes de -> do
+          liftM yes $ pEval ty de
+        _ -> return pde
+      --- ppr' <-  liftM yes $ evalPrintname gr c ppr pde'
+      return $ (f, CncFun mt pde' ppr) -- only cat in type actually needed
+
+    _ ->  return (f,info)
+
+  pEval (context,val) trm = do ---- errIn ("parteval" +++ prt_ trm) $ do
+    let 
+      vars  = map fst context
+      args  = map Vr vars
+      subst = [(v, Vr v) | v <- vars]
+      trm1  = mkApp trm args
+    trm3 <- recordExpand val trm1 >>= comp subst >>= recomp subst
+    return $ mkAbs vars trm3
+
+  ---- temporary hack to ascertain full evaluation, because of bug in comp
+  recomp g t = if notReady t then comp g t else return t
+  notReady = not . null . redexes
+  redexes t = case t of
+    Q _ _ -> return [()]
+    _ -> collectOp redexes t
+
+  recordExpand typ trm = case unComputed typ of
+    RecType tys -> case trm of
+      FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs]
+      _ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys]
+    _ -> return trm
+
+  comp g t = case t of
+
+    Q (IC "Predef") _ -> return t ----trace ("\nPredef:\n" ++ prt t) $ return t
+
+    Q p c -> do
+      md <- lookupComputed (p,c) 
+      case md of
+        Nothing -> do
+          d  <- lookRes (p,c)
+          updateComputed (p,c) $ traceFTerm c $ term2fterm d
+          return d
+        Just d -> fterm2term d >>= comp g
+    App f a -> case apps t of
+{- ----
+      (h@(QC p c),xs) -> do
+        xs' <- mapM (comp g) xs
+        case lookupValueIndex gr ty t of 
+        Ok v -> return v
+        _ -> return t
+-}
+      (h@(Q p c),xs) | p == IC "Predef" -> do
+        xs' <- mapM (comp g) xs
+        (t',b) <- stmErr $ appPredefined (foldl App h xs')
+        if b then return t' else comp g t'
+      (h@(Q p c),xs) -> do
+        xs' <- mapM (comp g) xs
+        md <- lookupComputed (p,c) 
+        case md of
+          Just ft -> do
+            t <- fterm2term $ appFTerm ft xs'
+            comp g t
+          Nothing -> do
+            d  <- lookRes (p,c)
+            let ft = traceFTerm c $ term2fterm d
+            updateComputed (p,c) ft
+            t' <- fterm2term $ appFTerm ft xs'
+            comp g t'
+      _ -> do
+        f' <- comp g f
+        a' <- comp g a
+        case (f',a') of
+         (Abs x b,_) -> comp (ext x a' g) b
+         (QC _ _,_)  -> returnC $ App f' a'
+         (FV fs, _)  -> mapM (\c -> comp g (App c a')) fs >>= return . variants
+         (_, FV as)  -> mapM (\c -> comp g (App f' c)) as >>= return . variants
+
+         (Alias _ _ d, _) -> comp g (App d a')
+
+         (S (T i cs) e,_) -> prawitz g i (flip App a') cs e
+
+	 _ -> do
+           (t',b) <- stmErr $ appPredefined (App f' a')
+           if b then return t' else comp g t'
+
+
+    Vr x -> do
+       t' <- maybe (prtRaise (
+         "context" +++ show g +++ ": no value given to variable") x) return $ lookup x g
+       case t' of 
+         _ | t == t' -> return t
+         _ -> comp g t'
+
+    Abs x b -> do 
+       b' <- comp (ext x (Vr x) g) b
+       return $ Abs x b'
+
+    Let (x,(_,a)) b -> do
+       a' <- comp g a
+       comp (ext x a' g) b
+
+    Prod x a b -> do
+       a' <- comp g a
+       b' <- comp (ext x (Vr x) g) b
+       return $ Prod x a' b'
+
+    P t l | isLockLabel l -> return $ R [] 
+     ---- a workaround 18/2/2005: take this away and find the reason
+     ---- why earlier compilation destroys the lock field
+
+
+    P t l  -> do
+       t' <- comp g t
+       case t' of
+         FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants
+         R r   -> maybe 
+                   (prtRaise (prt t' ++ ": no value for label") l) (comp g . snd) $ 
+                    lookup l r 
+
+         ExtR a (R b) -> case lookup l b of  ----comp g (P (R b) l) of
+           Just (_,v) -> comp g v
+           _ -> comp g (P a l)
+         ExtR (R a) b -> case lookup l a of  ----comp g (P (R b) l) of
+           Just (_,v) -> comp g v
+           _ -> comp g (P b l)
+
+         S (T i cs) e -> prawitz g i (flip P l) cs e
+
+         _   -> returnC $ P t' l
+
+    S t@(T _ cc) v -> do
+       v'     <- comp g v
+       case v' of
+         FV vs -> do
+           ts' <- mapM (comp g . S t) vs
+           return $ variants ts' 
+         _ -> case matchPattern cc v' of
+           Ok (c,g') -> comp (g' ++ g) c
+           _ | isCan v' -> prtRaise ("missing case" +++ prt v' +++ "in") t 
+           _ -> do
+             t' <- comp g t
+             return $ S t' v' -- if v' is not canonical
+
+    S t v -> do
+       t'     <- comp g t
+       v'     <- comp g v
+       case t' of
+         T _ [(PV IW,c)] -> comp g c           --- an optimization
+         T _ [(PT _ (PV IW),c)] -> comp g c
+
+         T _ [(PV z,c)] -> comp (ext z v' g) c --- another optimization
+         T _ [(PT _ (PV z),c)] -> comp (ext z v' g) c
+
+         FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants
+
+         V ptyp ts -> do
+           vs <- stmErr $ allParamValues gr ptyp
+           ps <- stmErr $ mapM term2patt vs
+           let cc = zip ps ts
+           case v' of
+             FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants
+             _ -> case matchPattern cc v' of
+               Ok (c,g') -> comp (g' ++ g) c
+               _ | isCan v' -> prtRaise ("missing case" +++ prt v' +++ "in") t 
+               _ -> return $ S t' v' -- if v' is not canonical
+
+         T _ cc -> case v' of
+	   FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants
+           _ -> case matchPattern cc v' of
+             Ok (c,g') -> comp (g' ++ g) c
+             _ | isCan v' -> prtRaise ("missing case" +++ prt v' +++ "in") t 
+             _ -> return $ S t' v' -- if v' is not canonical
+
+         Alias _ _ d -> comp g (S d v')
+
+         S (T i cs) e -> prawitz g i (flip S v') cs e
+
+	 _    -> returnC $ S t' v'
+
+     -- normalize away empty tokens
+    K "" -> return Empty
+
+    -- glue if you can
+    Glue x0 y0 -> do
+       x <- comp g x0
+       y <- comp g y0
+       case (x,y) of
+         (Alias _ _ d, y)  -> comp g $ Glue d y
+         (x, Alias _ _ d)  -> comp g $ Glue x d
+
+         (S (T i cs) e, s) -> prawitz g i (flip Glue s) cs e
+         (s, S (T i cs) e) -> prawitz g i (Glue s) cs e
+         (_,Empty)         -> return x
+         (Empty,_)         -> return y
+         (K a, K b)        -> return $ K (a ++ b)
+         (_, Alts (d,vs)) -> do
+----         (K a, Alts (d,vs)) -> do
+            let glx = Glue x
+            comp g $ Alts (glx d, [(glx v,c) | (v,c) <- vs])
+         (Alts _, ka) -> checks [do
+            y' <- stmErr $ strsFromTerm ka
+----         (Alts _, K a) -> checks [do
+            x' <- stmErr $ strsFromTerm x -- this may fail when compiling opers
+            return $ variants [
+              foldr1 C (map K (str2strings (glueStr v u))) | v <- x', u <- y']
+----              foldr1 C (map K (str2strings (glueStr v (str a)))) | v <- x']
+           ,return $ Glue x y
+           ]
+         (FV ks,_)         -> do
+           kys <- mapM (comp g . flip Glue y) ks
+           return $ variants kys
+         (_,FV ks)         -> do
+           xks <- mapM (comp g . Glue x) ks
+           return $ variants xks
+
+         _ -> do
+           mapM_ checkNoArgVars [x,y]
+           r <- composOp (comp g) t
+           returnC r
+
+    Alts _ -> do
+       r <- composOp (comp g) t
+       returnC r
+
+     -- remove empty
+    C a b    -> do
+       a' <- comp g a
+       b' <- comp g b
+       case (a',b') of
+         (Alts _, K a) -> checks [do
+            as <- stmErr $ strsFromTerm a' -- this may fail when compiling opers
+            return $ variants [
+              foldr1 C (map K (str2strings (plusStr v (str a)))) | v <- as]
+            ,
+            return $ C a' b'
+           ]
+         (Empty,_) -> returnC b'
+         (_,Empty) -> returnC a'
+         _     -> returnC $ C a' b'
+
+     -- reduce free variation as much as you can
+    FV ts -> mapM (comp g) ts >>= returnC . variants
+
+     -- merge record extensions if you can
+    ExtR r s -> do
+       r' <- comp g r
+       s' <- comp g s
+       case (r',s') of
+         (Alias _ _ d, _)  -> comp g $ ExtR d s'
+         (_, Alias _ _ d)  -> comp g $ Glue r' d
+
+         (R rs, R ss) -> stmErr $ plusRecord r' s'
+         (RecType rs, RecType ss) -> stmErr $ plusRecType r' s'
+
+         (_, FV ss) -> liftM FV $ mapM (comp g) [ExtR t u | u <- ss]
+
+         _ -> return $ ExtR r' s'
+
+     -- case-expand tables
+     -- if already expanded, don't expand again
+    T i@(TComp _) cs -> do
+       -- if there are no variables, don't even go inside
+       cs' <- {-if (null g) then return cs else-} mapPairsM (comp g) cs
+       return $ T i cs'
+
+     --- this means some extra work; should implement TSh directly
+    TSh i cs -> comp g $ T i [(p,v) | (ps,v) <- cs, p <- ps]
+
+    T i cs -> do
+       pty0 <- stmErr $ getTableType i
+       ptyp <- comp g pty0
+       case allParamValues gr ptyp of
+         Ok vs -> do
+
+           cs'  <- mapM (compBranchOpt g) cs
+           sts  <- stmErr $ mapM (matchPattern cs') vs 
+           ts   <- mapM (\ (c,g') -> comp (g' ++ g) c) sts
+           ps   <- stmErr $ mapM term2patt vs
+           let ps' = ps --- PT ptyp (head ps) : tail ps
+           return $ --- V ptyp ts -- to save space, just course of values
+                    T (TComp ptyp) (zip ps' ts)
+         _ -> do
+           cs' <- mapM (compBranch g) cs
+           return $ T i cs'  -- happens with variable types
+
+     -- otherwise go ahead
+    _ -> composOp (comp g) t >>= returnC
+
+  lookRes (p,c) = case lookupResDefKind gr p c of
+    Ok (t,_) | noExpand p -> return t
+    Ok (t,0) -> comp [] t
+    Ok (t,_) -> return t
+    Bad s -> raise s
+
+  noExpand p = errVal False $ do
+    mo <- lookupModMod gr p
+    return $ case getOptVal (iOpts (flags mo)) useOptimizer of
+      Just "noexpand" -> True
+      _ -> False
+
+  prtRaise s t = raise (s +++ prt t)
+
+  ext x a g = (x,a):g
+
+  returnC = return --- . computed
+
+  variants ts = case nub ts of
+       [t] -> t
+       ts  -> FV ts
+
+  isCan v = case v of
+       Con _    -> True
+       QC _ _   -> True
+       App f a  -> isCan f && isCan a
+       R rs     -> all (isCan . snd . snd) rs
+       _        -> False
+
+  compBranch g (p,v) = do
+       let g' = contP p ++ g
+       v' <- comp g' v
+       return (p,v')
+
+  compBranchOpt g c@(p,v) = case contP p of
+       [] -> return c
+       _ -> compBranch g c
+----       _ -> err (const (return c)) return $ compBranch g c
+
+  contP p = case p of
+       PV x -> [(x,Vr x)]
+       PC _ ps -> concatMap contP ps
+       PP _ _ ps -> concatMap contP ps
+       PT _ p -> contP p
+       PR rs -> concatMap (contP . snd) rs
+
+       PAs x p -> (x,Vr x) : contP p
+
+       PSeq p q -> concatMap contP [p,q]
+       PAlt p q -> concatMap contP [p,q]
+       PRep p   -> contP p
+       PNeg p   -> contP p
+
+       _ -> []
+
+  prawitz g i f cs e = do
+       cs' <- mapM (compBranch g) [(p, f v) | (p,v) <- cs]
+       return $ S (T i cs') e
+
+-- | argument variables cannot be glued
+checkNoArgVars :: Term -> STM EEnv Term
+checkNoArgVars t = case t of
+  Vr (IA _)  -> raise $ glueErrorMsg $ prt t 
+  Vr (IAV _) -> raise $ glueErrorMsg $ prt t 
+  _ -> composOp checkNoArgVars t
+
+glueErrorMsg s = 
+  "Cannot glue (+) term with run-time variable" +++ s ++ "." ++++
+  "Use Prelude.bind instead."
+
+stmErr :: Err a -> STM s a
+stmErr e = stm (\s -> do
+  v <- e
+  return (v,s)
+  )
+
+evalIn :: String -> STM s a -> STM s a
+evalIn msg st = stm $ \s -> case appSTM st s of
+  Bad e -> Bad $ msg ++++ e
+  Ok vs -> Ok vs
diff --git a/src-3.0/GF/Compile/Extend.hs b/src-3.0/GF/Compile/Extend.hs
new file mode 100644
index 000000000..ae87b3e71
--- /dev/null
+++ b/src-3.0/GF/Compile/Extend.hs
@@ -0,0 +1,136 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Extend
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/30 21:08:14 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.18 $
+--
+-- AR 14\/5\/2003 -- 11\/11
+--
+-- The top-level function 'extendModule'
+-- extends a module symbol table by indirections to the module it extends
+-----------------------------------------------------------------------------
+
+module GF.Compile.Extend (extendModule, extendMod
+	      ) where
+
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Grammar.PrGrammar
+import GF.Infra.Modules
+import GF.Compile.Update
+import GF.Grammar.Macros
+import GF.Data.Operations
+
+import Control.Monad
+
+extendModule :: [SourceModule] -> SourceModule -> Err SourceModule
+extendModule ms (name,mod) = case mod of
+
+  ---- Just to allow inheritance in incomplete concrete (which are not
+  ---- compiled anyway), extensions are not built for them.
+  ---- Should be replaced by real control. AR 4/2/2005
+  ModMod m | mstatus m == MSIncomplete && isModCnc m -> return (name,mod)
+
+  ModMod m -> do
+    mod' <- foldM extOne m (extend m) 
+    return (name,ModMod mod') 
+ where
+   extOne mod@(Module mt st fs es ops js) (n,cond) = do
+        (m0,isCompl) <- do
+          m <- lookupModMod  (MGrammar ms) n
+
+          -- test that the module types match, and find out if the old is complete
+          testErr (sameMType (mtype m) mt) 
+                    ("illegal extension type to module" +++ prt name)
+          return (m, isCompleteModule m)
+----       return (m, if (isCompleteModule m) then True else not (isCompleteModule mod))
+
+        -- build extension in a way depending on whether the old module is complete
+        js1 <- extendMod isCompl (n, isInherited cond) name (jments m0) js
+
+        -- if incomplete, throw away extension information
+        let me' = if isCompl then es else (filter ((/=n) . fst) es) 
+        return $ Module mt st fs me' ops js1
+
+-- | When extending a complete module: new information is inserted,
+-- and the process is interrupted if unification fails.
+-- If the extended module is incomplete, its judgements are just copied.
+extendMod :: Bool -> (Ident,Ident -> Bool) -> Ident -> 
+             BinTree Ident Info -> BinTree Ident Info -> 
+             Err (BinTree Ident Info)
+extendMod isCompl (name,cond) base old new = foldM try new $ tree2list old where
+  try t i@(c,_) | not (cond c) = return t
+  try t i@(c,_) = errIn ("constant" +++ prt c) $
+                  tryInsert (extendAnyInfo isCompl name base) indirIf t i
+  indirIf = if isCompl then indirInfo name else id
+
+indirInfo :: Ident -> Info -> Info
+indirInfo n info = AnyInd b n' where 
+  (b,n') = case info of
+    ResValue _ -> (True,n)
+    ResParam _ -> (True,n)
+    AbsFun _ (Yes EData) -> (True,n) 
+    AnyInd b k -> (b,k)
+    _ -> (False,n) ---- canonical in Abs
+
+perhIndir :: Ident -> Perh a -> Perh a
+perhIndir n p = case p of
+  Yes _ -> May n
+  _ -> p
+
+extendAnyInfo :: Bool -> Ident -> Ident -> Info -> Info -> Err Info
+extendAnyInfo isc n o i j = 
+ errIn ("building extension for" +++ prt n +++ "in" +++ prt o) $ case (i,j) of
+  (AbsCat mc1 mf1, AbsCat mc2 mf2) -> 
+    liftM2 AbsCat (updn isc n mc1 mc2) (updn isc n mf1 mf2) --- add cstrs
+  (AbsFun mt1 md1, AbsFun mt2 md2) -> 
+    liftM2 AbsFun (updn isc n mt1 mt2) (updn isc n md1 md2) --- add defs
+  (ResParam mt1, ResParam mt2) -> 
+    liftM ResParam $ updn isc n mt1 mt2
+  (ResValue mt1, ResValue mt2) -> 
+    liftM ResValue $ updn isc n mt1 mt2
+  (ResOper mt1 m1, ResOper mt2 m2) ->           ---- extendResOper n mt1 m1 mt2 m2 
+    liftM2 ResOper (updn isc n mt1 mt2) (updn isc n m1 m2)
+  (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> 
+    liftM3 CncCat (updn isc n mc1 mc2) (updn isc n mf1 mf2) (updn isc n mp1 mp2)
+  (CncFun m mt1 md1, CncFun _ mt2 md2) -> 
+    liftM2 (CncFun m) (updn isc n mt1 mt2) (updn isc n md1 md2)
+
+----  (AnyInd _ _, ResOper _ _) -> return j ----
+
+  (AnyInd b1 m1, AnyInd b2 m2) -> do
+    testErr (b1 == b2) "inconsistent indirection status"
+---- commented out as work-around for a spurious problem in
+---- TestResourceFre; should look at building of completion. 17/11/2004 
+    testErr (m1 == m2) $ 
+      "different sources of indirection: " +++ show m1 +++ show m2
+    return i
+
+  _ -> Bad $ "cannot unify information in" ++++ show i ++++ "and" ++++ show j
+
+--- where
+   
+updn isc n = if isc  then (updatePerhaps n) else (updatePerhapsHard n)
+updc isc n = if True then (updatePerhaps n) else (updatePerhapsHard n)
+
+
+
+{- ---- no more needed: this is done in Rebuild
+-- opers declared in an interface and defined in an instance are a special case
+
+extendResOper n mt1 m1 mt2 m2 = case (m1,m2) of
+  (Nope,_) -> return $ ResOper (strip mt1) m2
+  _ -> liftM2 ResOper (updatePerhaps n mt1 mt2) (updatePerhaps n m1 m2)
+ where
+   strip (Yes t) = Yes $ strp t
+   strip m = m
+   strp t = case t of
+     Q _ c  -> Vr c
+     QC _ c -> Vr c
+     _ -> composSafeOp strp t
+-}
diff --git a/src-3.0/GF/Compile/Flatten.hs b/src-3.0/GF/Compile/Flatten.hs
new file mode 100644
index 000000000..6b25edebb
--- /dev/null
+++ b/src-3.0/GF/Compile/Flatten.hs
@@ -0,0 +1,92 @@
+module Flatten where
+
+import Data.List
+-- import GF.Data.Operations
+
+-- (AR 15/3/2006)
+--
+-- A method for flattening grammars: create many flat rules instead of
+-- a few deep ones. This is generally better for parsins.
+-- The rules are obtained as follows:
+-- 1. write a config file tellinq which constants are variables: format 'c : C'
+-- 2. generate a list of trees with their types: format 't : T'
+-- 3. for each such tree, form a fun rule 'fun fui : X -> Y -> T' and a lin
+--    rule 'lin fui x y = t' where x:X,y:Y is the list of variables in t, as
+--    found in the config file.
+-- 4. You can go on and produce def or transfer rules similar to the lin rules
+--    except for the keyword.
+--
+-- So far this module is used outside gf. You can e.g. generate a list of
+-- trees by 'gt', write it in a file, and then in ghci call
+-- flattenGrammar <Config> <Trees> <OutFile>
+
+type Ident = String ---
+type Term  = String ---
+type Rule  = String ---
+
+type Config = [(Ident,Ident)]
+
+flattenGrammar :: FilePath -> FilePath -> FilePath -> IO ()
+flattenGrammar conff tf out = do
+  conf <- readFile conff >>= return . lines
+  ts   <- readFile tf    >>= return . lines
+  writeFile out $ mkFlatten conf ts
+
+mkFlatten :: [String] -> [String] -> String
+mkFlatten conff = unlines . concatMap getOne . zip [1..] where
+  getOne (k,t) = let (x,y) = mkRules conf ("fu" ++ show k) t in [x,y] 
+  conf = getConfig conff
+
+mkRules :: Config -> Ident -> Term -> (Rule,Rule)
+mkRules conf f t = (fun f ty, lin f (takeWhile (/=':') t)) where
+  args = mkArgs conf ts
+  ty   = concat [a ++ " -> " | a <- map snd args] ++ val
+  (ts,val) = let tt = lexTerm t in (init tt,last tt)
+---  f  = mkIdent t
+  fun c a = unwords   ["  fun", c, ":",a,";"] 
+  lin c a = unwords $ ["  lin", c] ++ map fst args ++ ["=",a,";"] 
+
+mkArgs :: Config -> [Ident] -> [(Ident,Ident)]
+mkArgs conf ids = [(x,ty) | x <- ids, Just ty <- [lookup x conf]]
+
+mkIdent :: Term -> Ident
+mkIdent = map mkChar where
+  mkChar c = case c of
+   '(' -> '6'
+   ')' -> '9'
+   ' ' -> '_'
+   _   -> c
+
+-- to get just the identifiers
+lexTerm :: String -> [String]
+lexTerm ss = case lex ss of
+  [([c],ws)] | isSpec c ->     lexTerm ws
+  [(w@(_:_),ws)]        -> w : lexTerm ws
+  _ -> []
+ where
+   isSpec = flip elem "();:"
+
+
+getConfig :: [String] -> Config
+getConfig = map getOne . filter (not . null) where
+  getOne line = case lexTerm line of
+    v:c:_ -> (v,c)
+
+ex = putStrLn fs where
+  fs = 
+    mkFlatten
+      ["man_N : N", 
+       "sleep_V : V"
+      ] 
+      ["PredVP (DefSg man_N) (UseV sleep_V) : Cl",
+       "PredVP (DefPl man_N) (UseV sleep_V) : Cl"
+      ]
+
+{-
+-- result of ex
+  
+  fun fu1 : N -> V -> Cl ;
+  lin fu1 man_N sleep_V = PredVP (DefSg man_N) (UseV sleep_V)  ;
+  fun fu2 : N -> V -> Cl ;
+  lin fu2 man_N sleep_V = PredVP (DefPl man_N) (UseV sleep_V)  ;
+-}
diff --git a/src-3.0/GF/Compile/GetGrammar.hs b/src-3.0/GF/Compile/GetGrammar.hs
new file mode 100644
index 000000000..294edbf9a
--- /dev/null
+++ b/src-3.0/GF/Compile/GetGrammar.hs
@@ -0,0 +1,146 @@
+----------------------------------------------------------------------
+-- |
+-- 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.Compile.GetGrammar (
+  getSourceModule, getSourceGrammar,
+  getOldGrammar, getCFGrammar, getEBNFGrammar
+		  ) where
+
+import GF.Data.Operations
+import qualified GF.Source.ErrM as E
+
+import GF.Infra.UseIO
+import GF.Grammar.Grammar
+import GF.Infra.Modules
+import GF.Grammar.PrGrammar
+import qualified GF.Source.AbsGF as A
+import GF.Source.SourceToGrammar
+---- import Macros
+---- import Rename
+import GF.Text.UTF8 ----
+import GF.Infra.Option
+--- import Custom
+import GF.Source.ParGF
+import qualified GF.Source.LexGF as L
+
+import GF.CF.CF (rules2CF)
+import GF.CF.PPrCF
+import GF.CF.CFtoGrammar
+import GF.CF.EBNF
+
+import GF.Infra.ReadFiles ----
+
+import Data.Char (toUpper)
+import Data.List (nub)
+import qualified Data.ByteString.Char8 as BS
+import Control.Monad (foldM)
+import System (system)
+import System.FilePath
+
+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
+  string0    <- readFileIOE file
+  let string = case getOptVal opts uniCoding of
+        Just "utf8" -> decodeUTF8 string0
+        _ -> string0
+  let tokens = myLexer (BS.pack string)
+  mo1  <- ioeErr $ pModDef tokens
+  ioeErr $ transModDef mo1
+
+getSourceGrammar :: Options -> FilePath -> IOE SourceGrammar
+getSourceGrammar opts file = do
+  string    <- readFileIOE file
+  let tokens = myLexer (BS.pack string)
+  gr1  <- ioeErr $ pGrammar tokens
+  ioeErr $ transGrammar gr1
+
+
+-- for old GF format with includes
+
+getOldGrammar :: Options -> FilePath -> IOE SourceGrammar
+getOldGrammar opts file = do
+  defs <- parseOldGrammarFiles file
+  let g = A.OldGr A.NoIncl defs
+  let name = takeFileName file
+  ioeErr $ transOldGrammar opts name g
+
+parseOldGrammarFiles :: FilePath -> IOE [A.TopDef]
+parseOldGrammarFiles file = do
+   putStrLnE $ "reading grammar of old format" +++ file
+   (_, g) <- getImports "" ([],[]) file
+   return g  -- now we can throw away includes
+  where 
+   getImports oldInitPath (oldImps, oldG) f = do
+     (path,s) <- readFileLibraryIOE oldInitPath f
+     if not (elem path oldImps) 
+       then do
+         (imps,g) <- parseOldGrammar path
+         foldM (getImports (initFilePath path)) (path : oldImps, g ++ oldG) imps
+       else 
+         return (oldImps, oldG)
+
+parseOldGrammar :: FilePath -> IOE ([FilePath],[A.TopDef])
+parseOldGrammar file = do
+  putStrLnE $ "reading old file" +++ file
+  s <- ioeIO $ readFileIf file
+  A.OldGr incl topdefs <- ioeErr $ pOldGrammar $ oldLexer $ fixNewlines s
+  includes <- ioeErr $ transInclude incl
+  return (includes, topdefs)
+
+----
+
+-- | To resolve the new reserved words: 
+-- change them by turning the final letter to upper case.
+--- There is a risk of clash. 
+oldLexer :: String -> [L.Token]
+oldLexer = map change . L.tokens . BS.pack where
+  change t = case t of
+    (L.PT p (L.TS s)) | elem s newReservedWords -> 
+        (L.PT p (L.TV (init s ++ [toUpper (last s)])))
+    _ -> t
+
+getCFGrammar :: Options -> FilePath -> IOE SourceGrammar
+getCFGrammar opts file = do
+  let mo = takeWhile (/='.') file
+  s    <- ioeIO  $ readFileIf file
+  let files = case words (concat (take 1 (lines s))) of
+        "--":"include":fs -> fs
+        _ -> []
+  ss   <- ioeIO  $ mapM readFileIf files
+  cfs  <- ioeErr $ mapM (pCF mo) $ s:ss
+  defs <- return $ cf2grammar $ rules2CF $ concat cfs
+  let g = A.OldGr A.NoIncl defs
+---  let ma = justModuleName file
+---  let mc = 'C':ma ---
+---  let opts' = addOptions (options [useAbsName ma, useCncName mc]) opts
+  ioeErr $ transOldGrammar opts file g
+
+getEBNFGrammar :: Options -> FilePath -> IOE SourceGrammar
+getEBNFGrammar opts file = do
+  let mo = takeWhile (/='.') file
+  s    <- ioeIO $ readFileIf file
+  defs <- ioeErr $ pEBNFasGrammar s
+  let g = A.OldGr A.NoIncl defs
+---  let ma = justModuleName file
+---  let mc = 'C':ma ---
+---  let opts' = addOptions (options [useAbsName ma, useCncName mc]) opts
+  ioeErr $ transOldGrammar opts file g
diff --git a/src-3.0/GF/Compile/GrammarToCanon.hs b/src-3.0/GF/Compile/GrammarToCanon.hs
new file mode 100644
index 000000000..09c0d3d95
--- /dev/null
+++ b/src-3.0/GF/Compile/GrammarToCanon.hs
@@ -0,0 +1,293 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GrammarToCanon
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/11 23:24:33 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.23 $
+--
+-- Code generator from optimized GF source code to GFC.
+-----------------------------------------------------------------------------
+
+module GF.Compile.GrammarToCanon (showGFC,
+		       redModInfo, redQIdent
+		      ) where
+
+import GF.Data.Operations
+import GF.Data.Zipper
+import GF.Infra.Option
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Grammar.PrGrammar
+import GF.Infra.Modules
+import GF.Grammar.Macros
+import qualified GF.Canon.AbsGFC as G
+import qualified GF.Canon.GFC as C
+import GF.Canon.MkGFC
+---- import Alias
+import qualified GF.Canon.PrintGFC as P
+
+import Control.Monad
+import Data.List (nub,sortBy)
+
+-- compilation of optimized grammars to canonical GF. AR 5/10/2001 -- 12/5/2003
+
+-- | This is the top-level function printing a gfc file
+showGFC :: SourceGrammar -> String
+showGFC = err id id . liftM (P.printTree . grammar2canon) . redGrammar
+
+-- | any grammar, first trying without dependent types
+-- abstract syntax without dependent types
+redGrammar :: SourceGrammar -> Err C.CanonGrammar
+redGrammar (MGrammar gr) = liftM MGrammar $ mapM redModInfo $ filter active gr where
+  active (_,m) = case typeOfModule m of
+    MTInterface -> False
+    _ -> True
+
+redModInfo :: (Ident, SourceModInfo) -> Err (Ident, C.CanonModInfo)
+redModInfo (c,info) = do
+  c'    <- redIdent c
+  info' <- case info of
+    ModMod m -> do
+      let isIncompl = not $ isCompleteModule m
+      (e,os) <- if isIncompl then return ([],[]) else redExtOpen m ----
+      flags <- mapM redFlag $ flags m 
+      (a,mt0) <- case mtype m of
+         MTConcrete a -> do
+           a' <- redIdent a
+           return (a', MTConcrete a') 
+         MTAbstract -> return (c',MTAbstract) --- c' not needed
+         MTResource -> return (c',MTResource) --- c' not needed
+         MTInterface -> return (c',MTResource) ---- not needed
+         MTInstance _ -> return (c',MTResource) --- c' not needed
+         MTTransfer x y -> return (c',MTTransfer (om x) (om y)) --- c' not needed
+
+      --- this generates empty GFC reosurce for interface and incomplete
+      let js = if isIncompl then emptyBinTree else jments m
+          mt = mt0 ---- if isIncompl then MTResource else mt0
+
+      defss <- mapM (redInfo a) $ tree2list $ js
+      let defs0 = concat defss
+      let lgh = length defs0
+      defs  <- return $ sorted2tree $ defs0  -- sorted, but reduced
+      let flags1 = if isIncompl then C.flagIncomplete : flags else flags
+      let flags' = G.Flg (identC "modulesize") (identC ("n"++show lgh)) : flags1
+      return $ ModMod $ Module mt MSComplete flags' e os defs
+  return (c',info')
+ where
+   redExtOpen m = do
+     e' <- case extends m of
+       es -> mapM (liftM inheritAll . redIdent) es
+     os' <- mapM (\o -> case o of 
+              OQualif q _ i -> liftM (OSimple q) (redIdent i)
+              _ -> prtBad "cannot translate unqualified open in" c) $ opens m
+     return (e',nub os')
+   om = oSimple . openedModule --- normalizing away qualif
+
+redInfo :: Ident -> (Ident,Info) -> Err [(Ident,C.Info)]
+redInfo am (c,info) = errIn ("translating definition of" +++ prt c) $ do
+  c' <- redIdent c 
+  case info of
+    AbsCat (Yes cont) pfs -> do
+      let fs = case pfs of
+                 Yes ts -> [(m,c) | Q m c <- ts]
+                 _ -> []
+      returns c' $ C.AbsCat cont fs
+    AbsFun (Yes typ) pdf -> do
+      let df = case pdf of
+                 Yes t -> t  -- definition or "data"
+                 _ -> Eqs [] -- primitive notion
+      returns c' $ C.AbsFun typ df
+    AbsTrans t -> 
+      returns c' $ C.AbsTrans t
+
+    ResParam (Yes (ps,_)) -> do
+      ps' <- mapM redParam ps
+      returns c' $ C.ResPar ps'
+
+    CncCat pty ptr ppr -> case (pty,ptr,ppr) of
+      (Yes ty, Yes (Abs _ t), Yes pr) -> do
+        ty'  <- redCType ty
+        trm' <- redCTerm t
+        pr'  <- redCTerm pr 
+        return [(c', C.CncCat ty' trm' pr')]
+      _ -> prtBad ("cannot reduce rule for") c
+      
+    CncFun mt ptr ppr -> case (mt,ptr,ppr) of
+      (Just (cat,_), Yes trm, Yes pr) -> do
+        cat' <- redIdent cat
+        (xx,body,_) <- termForm trm
+        xx'   <- mapM redArgvar xx
+        body' <- errIn (prt body) $ redCTerm body ---- debug
+        pr'   <- redCTerm pr 
+        return [(c',C.CncFun (G.CIQ am cat') xx' body' pr')]
+      _ -> prtBad ("cannot reduce rule" +++ show info +++ "for") c ---- debug
+
+    AnyInd s b -> do
+      b' <- redIdent b
+      returns c' $ C.AnyInd s b'
+
+    _ -> return [] --- retain some operations
+ where
+   returns f i = return [(f,i)]
+
+redQIdent :: QIdent -> Err G.CIdent
+redQIdent (m,c) = return $ G.CIQ m c
+
+redIdent :: Ident -> Err Ident
+redIdent x 
+  | isWildIdent x = return $ identC "h_" --- needed in declarations
+  | otherwise = return $ identC $ prt x ---
+
+redFlag :: Option -> Err G.Flag
+redFlag (Opt (f,[x])) = return $ G.Flg (identC f) (identC x)
+redFlag o = Bad $ "cannot reduce option" +++ prOpt o
+
+redDecl :: Decl -> Err G.Decl
+redDecl (x,a) = liftM2 G.Decl (redIdent x) (redType a)
+
+redType :: Type -> Err G.Exp
+redType = redTerm
+
+redTerm :: Type -> Err G.Exp
+redTerm t = return $ rtExp t
+
+-- to normalize records and record types
+sortByFst :: Ord a => [(a,b)] -> [(a,b)]
+sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
+
+-- resource
+
+redParam :: Param -> Err G.ParDef
+redParam (c,cont) = do
+  c'    <- redIdent c
+  cont' <- mapM (redCType . snd) cont
+  return $ G.ParD c' cont'
+
+redArgvar :: Ident -> Err G.ArgVar
+redArgvar x = case x of
+  IA (x,i)     -> return $ G.A  (identC x) (toInteger i)
+  IAV (x,b,i) -> return $ G.AB (identC x) (toInteger b) (toInteger i)
+  _ -> Bad $ "cannot reduce" +++ show x +++ "as argument variable"
+
+redLindef :: Term -> Err G.Term
+redLindef t = case t of
+  Abs x b -> redCTerm b ---
+  _ -> redCTerm t
+
+redCType :: Type -> Err G.CType
+redCType t = case t of
+  RecType lbs -> do
+    let (ls,ts) = unzip lbs
+        ls' = map redLabel ls
+    ts' <- mapM redCType ts
+    return $ G.RecType $ map (uncurry G.Lbg) $ sortByFst $ zip ls' ts'
+  Table p v  -> liftM2 G.Table (redCType p) (redCType v)
+  Q m c    -> liftM G.Cn $ redQIdent (m,c)
+  QC m c   -> liftM G.Cn $ redQIdent (m,c)
+
+  App (Q (IC "Predef") (IC "Ints")) (EInt n) -> return $ G.TInts (toInteger n)
+
+  Sort "Str" -> return $ G.TStr
+  Sort "Tok" -> return $ G.TStr
+  _ -> prtBad "cannot reduce to canonical the type" t
+
+redCTerm :: Term -> Err G.Term
+redCTerm t = case t of
+  Vr x -> checkAgain 
+            (liftM G.Arg $ redArgvar x) 
+            (liftM G.LI  $ redIdent x) --- for parametrize optimization
+  App _ s -> do  -- only constructor applications can remain
+    (_,c,xx) <- termForm t
+    xx' <- mapM redCTerm xx
+    case c of
+      QC p c -> liftM2 G.Par (redQIdent (p,c)) (return xx')
+      Q (IC "Predef") (IC "error") -> fail $ "error: " ++ stringFromTerm s
+      _ -> prtBad "expected constructor head instead of" c
+  Q p c  -> liftM G.I (redQIdent (p,c))
+  QC p c -> liftM2 G.Par (redQIdent (p,c)) (return [])
+  R rs     -> do
+    let (ls,tts) = unzip rs
+        ls' = map redLabel ls
+    ts <- mapM (redCTerm . snd) tts
+    return $ G.R $ map (uncurry G.Ass) $ sortByFst $ zip ls' ts
+  RecType [] -> return $ G.R [] --- comes out in parsing
+  P tr l -> do
+    tr' <- redCTerm tr
+    return $ G.P tr' (redLabel l)
+  PI tr l _ -> redCTerm $ P tr l -----
+  T i cs     -> do
+    ty  <- getTableType i
+    ty' <- redCType ty
+    let (ps,ts) = unzip cs
+    ps' <- mapM redPatt ps
+    ts' <- mapM redCTerm ts
+    return $ G.T ty' $ map (uncurry G.Cas) $ zip (map singleton ps') ts'
+  TSh i cs -> do
+    ty  <- getTableType i
+    ty' <- redCType ty
+    let (pss,ts) = unzip cs
+    pss' <- mapM (mapM redPatt) pss
+    ts' <- mapM redCTerm ts
+    return $ G.T ty' $ map (uncurry G.Cas) $ zip pss' ts'
+  V ty ts     -> do
+    ty' <- redCType ty
+    ts' <- mapM redCTerm ts
+    return $ G.V ty' ts'
+  S u v -> liftM2 G.S (redCTerm u) (redCTerm v)
+  K s   -> return $ G.K (G.KS s)
+  EInt i -> return $ G.EInt i
+  EFloat i -> return $ G.EFloat i
+  C u v -> liftM2 G.C (redCTerm u) (redCTerm v)
+  FV ts -> liftM G.FV $ mapM redCTerm ts
+---  Ready ss -> return $ G.Ready [redStr ss] --- obsolete
+
+  Alts (d,vs) -> do ---
+    d'  <- redCTermTok d
+    vs' <- mapM redVariant vs
+    return $ G.K $ G.KP d' vs'
+
+  Empty -> return $ G.E
+
+---  Strs ss -> return $ G.Strs [s | K s <- ss] ---
+
+---- Glue obsolete in canon, should not occur here
+  Glue x y -> redCTerm (C x y)
+
+  _ -> Bad ("cannot reduce term" +++ prt t)
+
+redPatt :: Patt -> Err G.Patt
+redPatt p = case p of
+  PP m c ps -> liftM2 G.PC (redQIdent (m,c)) (mapM redPatt ps) 
+  PR rs -> do
+    let (ls,tts) = unzip rs
+        ls' = map redLabel ls
+    ts <- mapM redPatt tts
+    return $ G.PR $  map (uncurry G.PAss) $ sortByFst $ zip ls' ts
+  PT _ q -> redPatt q
+  PInt i -> return $ G.PI i
+  PFloat i -> return $ G.PF i
+  PV x -> liftM G.PV $ redIdent x --- for parametrize optimization
+  _ -> prtBad "cannot reduce pattern" p
+
+redLabel :: Label -> G.Label
+redLabel (LIdent s) = G.L $ identC s
+redLabel (LVar i)   = G.LV $ toInteger i
+
+redVariant :: (Term, Term) -> Err G.Variant
+redVariant (v,c) = do
+  v' <- redCTermTok v
+  c' <- redCTermTok c
+  return $ G.Var v' c'
+
+redCTermTok :: Term -> Err [String]
+redCTermTok t = case t of
+  K s   -> return [s]
+  Empty -> return []
+  C a b -> liftM2 (++) (redCTermTok a) (redCTermTok b)
+  Strs ss -> return [s | K s <- ss] ---
+  _ -> prtBad "cannot get strings from term" t
+
diff --git a/src-3.0/GF/Compile/MkConcrete.hs b/src-3.0/GF/Compile/MkConcrete.hs
new file mode 100644
index 000000000..d016a7e47
--- /dev/null
+++ b/src-3.0/GF/Compile/MkConcrete.hs
@@ -0,0 +1,154 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : MkConcrete
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 
+-- > CVS $Author: 
+-- > CVS $Revision: 
+--
+-- Compile a gfe file into a concrete syntax by using the parser on a resource grammar.
+-----------------------------------------------------------------------------
+
+module GF.Compile.MkConcrete (mkConcretes) where
+
+import GF.Grammar.Values (Tree,tree2exp)
+import GF.Grammar.PrGrammar (prt_,prModule)
+import GF.Grammar.Grammar --- (Term(..),SourceModule)
+import GF.Grammar.Macros (composSafeOp, composOp, record2subst, zIdent)
+import GF.Compile.ShellState --(firstStateGrammar,stateGrammarWords)
+import GF.Compile.PGrammar (pTerm,pTrm)
+import GF.Compile.Compile
+import GF.Compile.PrOld (stripTerm)
+import GF.Compile.GetGrammar
+import GF.API
+import GF.API.IOGrammar
+import qualified GF.Embed.EmbedAPI as EA
+
+import GF.Data.Operations
+import GF.Infra.UseIO
+import GF.Infra.Option
+import GF.Infra.Modules
+import GF.Infra.ReadFiles
+import GF.System.Arch
+import GF.UseGrammar.Treebank
+
+import System.Directory
+import System.FilePath
+import Data.Char
+import Control.Monad
+import Data.List
+
+-- translate strings into lin rules by parsing in a resource
+-- grammar. AR 2/6/2005
+
+-- Format of rule (on one line):
+--    lin F x y = in C "ssss" ;
+-- Format of resource path (on first line):
+--    --# -resource=PATH
+-- Other lines are copied verbatim.
+-- A sequence of files can be processed with the same resource without
+-- rebuilding the grammar and parser.
+
+-- notice: we use a hand-crafted lexer and parser in order to preserve
+-- the layout and comments in the rest of the file.
+
+mkConcretes :: Options -> [FilePath] -> IO ()
+mkConcretes opts files = do
+  ress <- mapM getResPath files
+  let grps = groupBy (\a b -> fst a == fst b) $ 
+               sortBy (\a b -> compare (fst a) (fst b)) $ zip ress files
+  mapM_ (mkCncGroups opts) [(rp,map snd gs) | gs@((rp,_):_) <- grps]
+
+mkCncGroups opts0 ((res,path),files) = do
+  putStrLnFlush $ "Going to preprocess examples in " ++ unwords files
+  putStrLn $ "Compiling resource " ++ res
+  let opts = addOptions (options [beSilent,pathList path]) opts0
+  let treebank = oElem (iOpt "treebank") opts
+  resf <- useIOE res $ do
+    (fp,_) <- readFileLibraryIOE "" res
+    return fp
+  egr <- appIOE $ shellStateFromFiles opts emptyShellState resf
+  (parser,morpho) <- if treebank then do
+      tb <- err (\_ -> error $ "no treebank of name" +++ path)
+                return
+                (egr >>= flip findTreebank (zIdent path))
+      return (\_ -> flip (,) "Not in treebank" . map pTrm . lookupTreebank tb,
+              isWordInTreebank tb)
+    else do
+      gr  <- err (\s -> putStrLn s >> error "resource grammar rejected") 
+                 (return . firstStateGrammar) egr
+      return 
+            (\cat s -> 
+                errVal ([],"No parse") $ 
+                optParseArgErrMsg (options [newFParser, firstCat cat, beVerbose]) gr s >>=
+                (\ (ts,e) -> return (map tree2exp ts, e)) , 
+            isKnownWord gr)
+  putStrLn "Building parser"
+  mapM_ (mkConcrete parser morpho) files
+
+type Parser = String -> String -> ([Term],String)
+type Morpho = String -> Bool 
+
+getResPath :: FilePath -> IO (String,String)
+getResPath file = do
+  s <- liftM lines $ readFileIf file
+  case filter (not . all isSpace) s of
+    res:path:_ | is "resource" res && is "path"     path -> return (val res, val path)
+    res:path:_ | is "resource" res && is "treebank" path -> return (val res, val path)
+    res:_ | is "resource" res -> return (val res, "")
+    _ -> error 
+           "expected --# -resource=FILE and optional --# -path=PATH or --# -treebank=IDENT"
+ where
+   val = dropWhile (isSpace) . tail . dropWhile (not . (=='='))
+   is tag s = case words s of
+     "--#":w:_ -> isPrefixOf ('-':tag) w
+     _ -> False 
+
+
+mkConcrete :: Parser -> Morpho -> FilePath -> IO ()
+mkConcrete parser morpho file = do
+  src <- appIOE (getSourceModule noOptions file) >>= err error return
+  let (src',msgs) = mkModule parser morpho src
+  let out = addExtension (justModuleName file) "gf"
+  writeFile out $ "-- File generated by GF from " ++ file
+  appendFile out "\n"
+  appendFile out (prModule src')
+  appendFile out "{-\n"
+  appendFile out $ unlines $ filter (not . null) msgs
+  appendFile out "-}\n"
+
+mkModule :: Parser -> Morpho -> SourceModule -> (SourceModule,[String])
+mkModule parser morpho (name,src) = case src of 
+  ModMod m@(Module mt st fs me ops js) ->
+
+    let js1 = jments m
+        (js2,msgs) = err error id $ appSTM (mapMTree mkInfo js1) []
+        mod2 = ModMod $ Module mt st fs me ops $ js2
+    in ((name,mod2), msgs)
+ where
+  mkInfo ni@(name,info) = case info of
+    CncFun mt (Yes trm) ppr -> do
+      trm' <- mkTrm trm
+      return (name, CncFun mt (Yes trm') ppr) 
+    _ -> return ni
+   where
+     mkTrm t = case t of
+       Example (P _ cat) s -> parse cat s t
+       Example (Vr  cat) s -> parse cat s t
+       _ -> composOp mkTrm t
+     parse cat s t = case parser (prt_ cat) s of
+       (tr:[], _) -> do
+         updateSTM ((("PARSED in" +++ prt_ name) : s : [prt_ tr]) ++)
+         return $ stripTerm tr
+       (tr:trs,_) -> do
+         updateSTM ((("AMBIGUOUS in" +++ prt_ name) : s : map prt_ trs) ++)
+         return $ stripTerm tr
+       ([],ms) -> do
+         updateSTM ((("NO PARSE in" +++ prt_ name) : s : ms : [morph s]) ++)
+         return t
+  morph s = case [w | w <- words s, not (morpho w)] of
+    [] -> ""
+    ws -> "unknown words: " ++ unwords ws
diff --git a/src-3.0/GF/Compile/MkResource.hs b/src-3.0/GF/Compile/MkResource.hs
new file mode 100644
index 000000000..10831b5c6
--- /dev/null
+++ b/src-3.0/GF/Compile/MkResource.hs
@@ -0,0 +1,128 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : MkResource
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/30 21:08:14 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.14 $
+--
+-- Compile a gfc module into a "reuse" gfr resource, interface, or instance.
+-----------------------------------------------------------------------------
+
+module GF.Compile.MkResource (makeReuse) where
+
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Infra.Modules
+import GF.Grammar.Macros
+import GF.Grammar.Lockfield
+import GF.Grammar.PrGrammar
+
+import GF.Data.Operations
+
+import Control.Monad
+
+-- | extracting resource r from abstract + concrete syntax.
+-- AR 21\/8\/2002 -- 22\/6\/2003 for GF with modules
+makeReuse :: SourceGrammar -> Ident -> [(Ident,MInclude Ident)] -> 
+             MReuseType Ident -> Err SourceRes
+makeReuse gr r me mrc = do
+  flags <- return [] --- no flags are passed: they would not make sense
+  case mrc of
+    MRResource c -> do
+      (ops,jms) <- mkFull True c
+      return $ Module MTResource MSComplete flags me ops jms
+
+    MRInstance c a -> do
+      (ops,jms) <- mkFull False c
+      return $ Module (MTInstance a) MSComplete flags me ops jms
+
+    MRInterface c -> do
+      mc <- lookupModule gr c
+
+      (ops,jms) <- case mc of 
+        ModMod m -> case mtype m of
+          MTAbstract -> liftM ((,) (opens m)) $ 
+                          mkResDefs True False gr r c me 
+                            (extend m) (jments m) emptyBinTree
+          _ -> prtBad "expected abstract to be the type of" c
+        _ -> prtBad "expected abstract to be the type of" c
+
+      return $ Module MTInterface MSIncomplete flags me ops jms
+
+ where
+    mkFull hasT c = do
+      mc <- lookupModule gr c
+
+      case mc of 
+        ModMod m -> case mtype m of
+          MTConcrete a -> do
+            ma <- lookupModule gr a
+            jmsA <- case ma of 
+               ModMod m' -> return $ jments m'
+               _ -> prtBad "expected abstract to be the type of" a
+            liftM ((,) (opens m)) $ 
+               mkResDefs hasT True gr r a me (extend m) jmsA (jments m)
+          _ -> prtBad "expected concrete to be the type of" c
+        _ -> prtBad "expected concrete to be the type of" c
+
+
+-- | the first  Boolean indicates if the type needs be given
+-- the second Boolean indicates if the definition needs be given
+mkResDefs :: Bool -> Bool -> 
+             SourceGrammar -> Ident -> Ident -> 
+             [(Ident,MInclude Ident)] -> [(Ident,MInclude Ident)] -> 
+             BinTree Ident Info -> BinTree Ident Info -> 
+             Err (BinTree Ident Info)
+mkResDefs hasT isC gr r a mext maext abs cnc = mapMTree (mkOne a maext) abs where
+
+  ifTyped  = yes --- if hasT then yes else const nope --- needed for TC
+  ifCompl  = if isC  then yes else const nope
+  doIf b t = if b then t else return typeType -- latter value not used
+
+  mkOne a mae (f,info) = case info of
+      AbsCat _ _ -> do
+        typ  <- doIf isC $ err (const (return defLinType)) return $ look cnc f
+        typ' <- doIf isC $ lockRecType f typ 
+        return (f, ResOper (ifTyped typeType) (ifCompl typ'))
+      AbsFun (Yes typ0) _ -> do
+        trm <- doIf isC $ look cnc f
+        testErr (not (isHardType typ0)) 
+                ("cannot build reuse for function" +++ prt f +++ ":" +++ prt typ0)
+        typ <- redirTyp True a mae typ0
+        cat <- valCat typ
+        trm' <- doIf isC $ unlockRecord (snd cat) trm 
+        return (f, ResOper (ifTyped typ) (ifCompl trm'))
+      AnyInd b n -> do
+        mo    <- lookupModMod gr n
+        info' <- lookupInfo mo f
+        mkOne n (extend mo) (f,info')
+
+  look cnc f = do
+     info <- lookupTree prt f cnc
+     case info of
+       CncCat (Yes ty) _ _ -> return ty
+       CncCat _ _ _        -> return defLinType
+       CncFun _ (Yes tr) _ -> return tr
+       AnyInd _ n -> do 
+         mo    <- lookupModMod gr n
+         t <- look (jments mo) f
+         redirTyp False n (extend mo) t
+       _ -> prtBad "not enough information to reuse" f
+
+  -- type constant qualifications changed from abstract to resource
+  redirTyp always a mae ty = case ty of
+    Q _ c | always -> return $ Q r c
+    Q n c | n == a || [n] == map fst mae -> return $ Q r c ---- FIX for non-singleton exts
+    _ -> composOp (redirTyp always a mae) ty
+
+-- | no reuse for functions of HO\/dep types
+isHardType t = case t of
+  Prod x a b -> not (isWild x) || isHardType a || isHardType b
+  App _ _    -> True
+  _          -> False  
+ where 
+   isWild x = isWildIdent x || prt x == "h_" --- produced by transl from canon
diff --git a/src-3.0/GF/Compile/MkUnion.hs b/src-3.0/GF/Compile/MkUnion.hs
new file mode 100644
index 000000000..b4b1f40c8
--- /dev/null
+++ b/src-3.0/GF/Compile/MkUnion.hs
@@ -0,0 +1,83 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : MkUnion
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:39 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.7 $
+--
+-- building union of modules.
+-- AR 1\/3\/2004 --- OBSOLETE 15\/9\/2004 with multiple inheritance
+-----------------------------------------------------------------------------
+
+module GF.Compile.MkUnion (makeUnion) where
+
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Infra.Modules
+import GF.Grammar.Macros
+import GF.Grammar.PrGrammar
+
+import GF.Data.Operations
+import GF.Infra.Option
+
+import Data.List
+import Control.Monad
+
+makeUnion :: SourceGrammar -> Ident -> ModuleType Ident -> [(Ident,[Ident])] ->
+             Err SourceModule
+makeUnion gr m ty imps = do
+  ms    <- mapM (lookupModMod gr . fst) imps
+  typ   <- return ty ---- getTyp ms
+  ext   <- getExt [i | Just i <- map extends ms]
+  ops   <- return $ nub $ concatMap opens ms
+  flags <- return $ concatMap flags ms
+  js    <- liftM (buildTree . concat) $ mapM getJments imps
+  return $ (m, ModMod (Module typ MSComplete flags ext ops js))
+
+ where
+   getExt es = case es of
+     [] -> return Nothing
+     i:is -> if all (==i) is then return (Just i) 
+               else Bad "different extended modules in union forbidden"
+   getJments (i,fs) = do
+     m  <- lookupModMod gr i
+     let js = jments m
+     if null fs 
+       then 
+         return (map (unqual i) $ tree2list js) 
+       else do
+         ds <- mapM (flip justLookupTree js) fs
+         return $ map (unqual i) $ zip fs ds
+
+   unqual i (f,d) = curry id f $ case d of
+     AbsCat  pty pts -> AbsCat (qualCo pty) (qualPs pts)
+     AbsFun  pty pt -> AbsFun (qualP pty) (qualP pt)
+     AbsTrans t     -> AbsTrans $ qual t
+     ResOper pty pt -> ResOper (qualP pty) (qualP pt)
+     CncCat  pty pt pp -> CncCat (qualP pty) (qualP pt) (qualP pp)
+     CncFun  mp pt pp -> CncFun (qualLin mp) (qualP pt) (qualP pp) ---- mp
+     ResParam (Yes ps) -> ResParam (yes (map qualParam ps)) 
+     ResValue pty ->  ResValue (qualP pty)
+     _ -> d
+    where
+     qualP pt = case pt of
+       Yes t -> yes $ qual t
+       _ -> pt
+     qualPs pt = case pt of
+       Yes ts -> yes $ map qual ts
+       _ -> pt
+     qualCo pco = case pco of
+       Yes co -> yes $ [(x,qual t) | (x,t) <- co]
+       _ -> pco
+     qual t = case t of
+       Q m c  | m==i -> Cn c
+       QC m c | m==i -> Cn c
+       _ -> composSafeOp qual t
+     qualParam (p,co) = (p,[(x,qual t) | (x,t) <- co])
+     qualLin (Just (c,(co,t))) = (Just (c,([(x,qual t) | (x,t) <- co], qual t)))
+     qualLin Nothing = Nothing
+     
diff --git a/src-3.0/GF/Compile/ModDeps.hs b/src-3.0/GF/Compile/ModDeps.hs
new file mode 100644
index 000000000..8331057d1
--- /dev/null
+++ b/src-3.0/GF/Compile/ModDeps.hs
@@ -0,0 +1,153 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : ModDeps
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/11 23:24:34 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.14 $
+--
+-- Check correctness of module dependencies. Incomplete.
+--
+-- AR 13\/5\/2003
+-----------------------------------------------------------------------------
+
+module GF.Compile.ModDeps (mkSourceGrammar,
+		moduleDeps,
+		openInterfaces,
+		requiredCanModules
+	       ) where
+
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Infra.Option
+import GF.Grammar.PrGrammar
+import GF.Compile.Update
+import GF.Grammar.Lookup
+import GF.Infra.Modules
+
+import GF.Data.Operations
+
+import Control.Monad
+import Data.List
+
+-- | to check uniqueness of module names and import names, the
+-- appropriateness of import and extend types,
+-- to build a dependency graph of modules, and to sort them topologically
+mkSourceGrammar :: [(Ident,SourceModInfo)] -> Err SourceGrammar
+mkSourceGrammar ms = do
+  let ns = map fst ms
+  checkUniqueErr ns
+  mapM (checkUniqueImportNames ns . snd) ms
+  deps    <- moduleDeps ms
+  deplist <- either 
+               return 
+               (\ms -> Bad $ "circular modules" +++ unwords (map show ms)) $ 
+               topoTest deps
+  return $ MGrammar [(m, maybe undefined id $ lookup m ms)  | IdentM m _ <- deplist]
+
+checkUniqueErr ::  (Show i, Eq i) => [i] -> Err ()
+checkUniqueErr ms = do
+  let msg = checkUnique ms
+  if null msg then return () else Bad $ unlines msg
+
+-- | check that import names don't clash with module names
+checkUniqueImportNames :: [Ident] -> SourceModInfo -> Err ()
+checkUniqueImportNames ns mo = case mo of
+  ModMod m -> test [n | OQualif _ n v <- opens m, n /= v]
+  _ -> return () --- Bad $ "bug: ModDeps does not treat" +++ show mo
+ where
+
+  test ms = testErr (all (`notElem` ns) ms)
+                    ("import names clashing with module names among" +++ 
+                       unwords (map prt ms))
+
+type Dependencies = [(IdentM Ident,[IdentM Ident])]
+
+-- | to decide what modules immediately depend on what, and check if the
+-- dependencies are appropriate
+moduleDeps :: [(Ident,SourceModInfo)] -> Err Dependencies
+moduleDeps ms = mapM deps ms where
+  deps (c,mi) = errIn ("checking dependencies of module" +++ prt c) $ case mi of
+    ModMod m -> case mtype m of
+      MTConcrete a -> do
+        aty <- lookupModuleType gr a
+        testErr (aty == MTAbstract) "the of-module is not an abstract syntax" 
+        chDep (IdentM c (MTConcrete a)) 
+              (extends m) (MTConcrete a) (opens m) MTResource
+      t -> chDep (IdentM c t) (extends m) t (opens m) t
+
+  chDep it es ety os oty = do
+    ests <- mapM (lookupModuleType gr) es
+    testErr (all (compatMType ety) ests) "inappropriate extension module type" 
+----    osts <- mapM (lookupModuleType gr . openedModule) os
+----    testErr (all (compatOType oty) osts) "inappropriate open module type"
+    let ab = case it of
+               IdentM _ (MTConcrete a) -> [IdentM a MTAbstract]
+               _ -> [] ---- 
+    return (it, ab ++
+                [IdentM e ety | e <- es] ++ 
+                [IdentM (openedModule o) oty | o <- os])
+
+  -- check for superficial compatibility, not submodule relation etc: what can be extended
+  compatMType mt0 mt = case (mt0,mt) of
+    (MTResource,   MTConcrete _) -> True
+    (MTInstance _, MTConcrete _) -> True
+    (MTInterface,  MTAbstract)   -> True
+    (MTConcrete _, MTConcrete _) -> True
+    (MTInstance _, MTInstance _) -> True
+    (MTReuse _, MTReuse _) -> True
+    (MTInstance _, MTResource) -> True
+    (MTResource, MTInstance _) -> True
+    ---- some more?
+    _ -> mt0 == mt
+  -- in the same way; this defines what can be opened
+  compatOType mt0 mt = case mt0 of
+    MTAbstract     -> mt == MTAbstract
+    MTTransfer _ _ -> mt == MTAbstract
+    _ -> case mt of
+      MTResource -> True
+      MTReuse _ -> True
+      MTInterface -> True
+      MTInstance _ -> True
+      _ -> False      
+
+  gr = MGrammar ms --- hack
+
+openInterfaces :: Dependencies -> Ident -> Err [Ident]
+openInterfaces ds m = do
+  let deps = [(i,ds) | (IdentM i _,ds) <- ds]
+  let more (c,_) = [(i,mt) | Just is <- [lookup c deps], IdentM i mt <- is]
+  let mods = iterFix (concatMap more) (more (m,undefined))
+  return $ [i | (i,MTInterface) <- mods]
+
+-- | this function finds out what modules are really needed in the canonical gr.
+-- its argument is typically a concrete module name
+requiredCanModules :: (Ord i, Show i) => Bool -> MGrammar i f a -> i -> [i]
+requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where
+  exts = allExtends gr c
+  ops  = if isSingle 
+         then map fst (modules gr) 
+         else iterFix (concatMap more) $ exts
+  more i = errVal [] $ do
+    m <- lookupModMod gr i
+    return $ extends m ++ [o | o <- map openedModule (opens m)]
+  notReuse i = errVal True $ do
+    m <- lookupModMod gr i
+    return $ isModRes m -- to exclude reused Cnc and Abs from required
+
+
+{-
+-- to test
+exampleDeps = [
+  (ir "Nat",[ii "Gen", ir "Adj"]),
+  (ir "Adj",[ii "Num", ii "Gen", ir "Nou"]),
+  (ir "Nou",[ii "Cas"])
+  ]
+
+ii s = IdentM (IC s) MTInterface
+ir s = IdentM (IC s) MTResource
+-}
+
diff --git a/src-3.0/GF/Compile/NewRename.hs b/src-3.0/GF/Compile/NewRename.hs
new file mode 100644
index 000000000..cec8ed24f
--- /dev/null
+++ b/src-3.0/GF/Compile/NewRename.hs
@@ -0,0 +1,294 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:41 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.6 $
+--
+-- AR 14\/5\/2003
+--
+-- The top-level function 'renameGrammar' does several things:
+--
+--   - extends each module symbol table by indirections to extended module
+--
+--   - changes unqualified and as-qualified imports to absolutely qualified
+--
+--   - goes through the definitions and resolves names
+--
+-- Dependency analysis between modules has been performed before this pass.
+-- Hence we can proceed by @fold@ing "from left to right".
+-----------------------------------------------------------------------------
+
+module GF.Compile.NewRename (renameSourceTerm, renameModule) where
+
+import GF.Grammar.Grammar
+import GF.Grammar.Values
+import GF.Infra.Modules
+import GF.Infra.Ident
+import GF.Grammar.Macros
+import GF.Grammar.PrGrammar
+import GF.Grammar.AppPredefined
+import GF.Grammar.Lookup
+import GF.Compile.Extend
+import GF.Data.Operations
+
+import Control.Monad
+
+-- | this gives top-level access to renaming term input in the cc command
+renameSourceTerm :: SourceGrammar -> Ident -> Term -> Err Term
+renameSourceTerm g m t = do
+  mo     <- lookupErr m (modules g)
+  let status = (modules g,(m,mo)) --- <- buildStatus g m mo
+  renameTerm status [] t
+
+-- | this is used in the compiler, separately for each module
+renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule]
+renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod of
+  ModMod m@(Module mt st fs me ops js) -> do
+    let js1 = jments m
+    let status = (ms, (name, mod))
+    js2    <- mapMTree (renameInfo status) js1
+    let mod2 = ModMod $ Module mt st fs me (map forceQualif ops) js2
+    return $ (name,mod2) : ms
+
+type Status = ([SourceModule],SourceModule)   --- (StatusTree, [(OpenSpec Ident, StatusTree)])
+
+--- type StatusTree = BinTree (Ident,StatusInfo)
+
+--- type StatusInfo = Ident -> Term
+
+lookupStatusInfo :: Ident -> SourceModule -> Err Term
+lookupStatusInfo c (q,ModMod m) = do
+  i <- lookupTree prt c $ jments m
+  return $ case i of
+    AbsFun _ (Yes EData) -> QC q c
+    ResValue _           -> QC q c
+    ResParam _           -> QC q c
+    AnyInd True n        -> QC n c --- should go further?
+    AnyInd False n       -> Q  n c
+    _                    -> Q  q c
+lookupStatusInfo c (q,_) = prtBad "ModMod expected for" q
+
+lookupStatusInfoMany :: [SourceModule] -> Ident -> Err Term
+lookupStatusInfoMany (m:ms) c = case lookupStatusInfo c m of
+  Ok v -> return v
+  _ -> lookupStatusInfoMany ms c
+lookupStatusInfoMany [] x = 
+  prtBad "renaming failed to find unqualified constant" x
+---- should also give error if stg is found in more than one module
+
+renameIdentTerm :: Status -> Term -> Err Term
+renameIdentTerm env@(imps,act@(_,ModMod this)) t = 
+ errIn ("atomic term" +++ prt t +++ "given" +++ unwords (map (prt . fst) qualifs)) $
+   case t of
+  Vr c -> do
+    f <- err (predefAbs c) return $ lookupStatusInfoMany openeds c
+    return $ f
+  Cn c -> do
+    f <- lookupStatusInfoMany openeds c
+    return $ f
+  Q m' c | m' == cPredef {- && isInPredefined c -} -> return t
+  Q m' c -> do
+    m <- lookupErr m' qualifs
+    f <- lookupStatusInfo c m
+    return $ f
+  QC m' c | m' == cPredef {- && isInPredefined c -} -> return t
+  QC m' c -> do
+    m <- lookupErr m' qualifs
+    f <- lookupStatusInfo c m
+    return $ f
+  _ -> return t
+ where
+   openeds = act : [(m,st) | OSimple _ m <- opens this, Just st <- [lookup m imps]]
+   qualifs = 
+     [(m, (n,st)) | OQualif _ m n <- opens this, Just st <- [lookup n imps]] 
+     ++ 
+     [(m, (m,st)) | OSimple _ m   <- opens this, Just st <- [lookup m imps]] 
+                                -- qualif is always possible
+
+   -- this facility is mainly for BWC with GF1: you need not import PredefAbs
+   predefAbs c s = case c of
+     IC "Int"    -> return $ Q cPredefAbs cInt
+     IC "String" -> return $ Q cPredefAbs cString
+     _ -> Bad s
+
+-- | would it make sense to optimize this by inlining?
+renameIdentPatt :: Status -> Patt -> Err Patt
+renameIdentPatt env p = do
+  let t = patt2term p
+  t' <- renameIdentTerm env t
+  term2patt t'
+
+{- deprec !
+info2status :: Maybe Ident -> (Ident,Info) -> (Ident,StatusInfo)
+info2status mq (c,i) = (c, case i of
+  AbsFun _ (Yes EData) -> maybe Con QC mq
+  ResValue _  -> maybe Con QC mq
+  ResParam _  -> maybe Con QC mq
+  AnyInd True m -> maybe Con (const (QC m)) mq
+  AnyInd False m -> maybe Cn (const (Q m)) mq
+  _           -> maybe Cn  Q mq
+  )
+
+tree2status :: OpenSpec Ident -> BinTree (Ident,Info) -> BinTree (Ident,StatusInfo)
+tree2status o = case o of
+  OSimple _ i   -> mapTree (info2status (Just i))
+  OQualif _ i j -> mapTree (info2status (Just j))
+
+buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Err Status
+buildStatus gr c mo = let mo' = self2status c mo in case mo of
+  ModMod m -> do
+    let gr1 = MGrammar $ (c,mo) : modules gr 
+        ops = [OSimple OQNormal e | e <- allExtendsPlus gr1 c] ++ allOpens m
+    mods <- mapM (lookupModule gr1 . openedModule) ops
+    let sts = map modInfo2status $ zip ops mods    
+    return $ if isModCnc m
+      then (NT, reverse sts) -- the module itself does not define any names
+      else (mo',reverse sts) -- so the empty ident is not needed
+
+modInfo2status :: (OpenSpec Ident,SourceModInfo) -> (OpenSpec Ident, StatusTree)
+modInfo2status (o,i) = (o,case i of
+  ModMod m -> tree2status o (jments m)
+  )
+
+self2status :: Ident -> SourceModInfo -> StatusTree
+self2status c i = mapTree (info2status (Just c)) js where   -- qualify internal
+  js = case i of
+    ModMod m 
+      | isModTrans m -> sorted2tree $ filter noTrans $ tree2list $ jments m 
+      | otherwise -> jments m
+  noTrans (_,d) = case d of  -- to enable other than transfer js in transfer module 
+    AbsTrans _ -> False
+    _ -> True
+-}
+
+forceQualif o = case o of
+  OSimple q i   -> OQualif q i i
+  OQualif q _ i -> OQualif q i i
+  
+renameInfo :: Status -> (Ident,Info) -> Err (Ident,Info)
+renameInfo status (i,info) = errIn ("renaming definition of" +++ prt i) $ 
+                                liftM ((,) i) $ case info of
+  AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco)
+                                  (renPerh (mapM rent) pfs)
+  AbsFun pty ptr -> liftM2 AbsFun (ren pty) (ren ptr)
+  AbsTrans f -> liftM AbsTrans (rent f)
+
+  ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr)
+  ResParam pp -> liftM ResParam (renPerh (mapM (renameParam status)) pp)
+  ResValue t  -> liftM ResValue (ren t)
+  CncCat pty ptr ppr -> liftM3 CncCat (ren pty) (ren ptr) (ren ppr)
+  CncFun mt  ptr ppr -> liftM2 (CncFun mt)      (ren ptr) (ren ppr)
+  _ -> return info
+ where 
+   ren = renPerh rent
+   rent = renameTerm status []
+
+renPerh ren pt = case pt of
+  Yes t -> liftM Yes $ ren t
+  _ -> return pt
+
+renameTerm :: Status -> [Ident] -> Term -> Err Term
+renameTerm env vars = ren vars where
+  ren vs trm = case trm of
+    Abs x b    -> liftM  (Abs x) (ren (x:vs) b)
+    Prod x a b -> liftM2 (Prod x) (ren vs a) (ren (x:vs) b)
+    Typed a b  -> liftM2 Typed (ren vs a) (ren vs b)
+    Vr x      
+      | elem x vs -> return trm
+      | otherwise -> renid trm
+    Cn _   -> renid trm
+    Con _  -> renid trm
+    Q _ _  -> renid trm
+    QC _ _ -> renid trm
+    Eqs eqs -> liftM Eqs $ mapM (renameEquation env vars) eqs
+    T i cs -> do
+      i' <- case i of
+        TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source
+        _ -> return i
+      liftM (T i') $ mapM (renCase vs) cs  
+
+    Let (x,(m,a)) b -> do
+      m' <- case m of
+        Just ty -> liftM Just $ ren vs ty
+        _ -> return m
+      a' <- ren vs a
+      b' <- ren (x:vs) b
+      return $ Let (x,(m',a')) b'
+
+    P t@(Vr r) l                     -- for constant t we know it is projection
+      | elem r vs -> return trm                           -- var proj first
+      | otherwise -> case renid (Q r (label2ident l)) of  -- qualif   second
+          Ok t -> return t
+          _ -> liftM (flip P l) $ renid t                 -- const proj last
+
+    _ -> composOp (ren vs) trm
+
+  renid = renameIdentTerm env
+  renCase vs (p,t) = do
+    (p',vs') <- renpatt p
+    t' <- ren (vs' ++ vs) t
+    return (p',t')
+  renpatt = renamePattern env
+
+-- | vars not needed in env, since patterns always overshadow old vars
+renamePattern :: Status -> Patt -> Err (Patt,[Ident])
+renamePattern env patt = case patt of
+
+  PC c ps -> do
+    c' <- renameIdentTerm env $ Cn c
+    psvss <- mapM renp ps
+    let (ps',vs) = unzip psvss
+    case c' of
+      QC p d -> return (PP p d ps', concat vs)
+      Q  p d -> return (PP p d ps', concat vs) ---- should not happen
+      _ -> prtBad "unresolved pattern" c' ---- (PC c ps', concat vs)
+
+----  PP p c ps -> (PP p c ps',concat vs') where (ps',vs') = unzip $ map renp ps
+
+  PV x -> case renid patt of
+    Ok p -> return (p,[])
+    _    -> return (patt, [x])
+
+  PR r -> do
+    let (ls,ps) = unzip r
+    psvss <- mapM renp ps
+    let (ps',vs') = unzip psvss
+    return (PR (zip ls ps'), concat vs') 
+
+  _ -> return (patt,[])
+
+ where 
+   renp  = renamePattern env
+   renid = renameIdentPatt env
+
+renameParam :: Status -> (Ident, Context) -> Err (Ident, Context)
+renameParam env (c,co) = do
+  co' <- renameContext env co
+  return (c,co')
+
+renameContext :: Status -> Context -> Err Context
+renameContext b = renc [] where
+  renc vs cont = case cont of
+    (x,t) : xts 
+      | isWildIdent x -> do
+          t'   <- ren vs t
+          xts' <- renc vs xts
+          return $ (x,t') : xts'
+      | otherwise -> do
+          t'   <- ren vs t
+          let vs' = x:vs
+          xts' <- renc vs' xts
+          return $ (x,t') : xts'
+    _ -> return cont
+  ren = renameTerm b
+
+-- | vars not needed in env, since patterns always overshadow old vars
+renameEquation :: Status -> [Ident] -> Equation -> Err Equation
+renameEquation b vs (ps,t) = do
+  (ps',vs') <- liftM unzip $ mapM (renamePattern b) ps
+  t'        <- renameTerm b (concat vs' ++ vs) t
+  return (ps',t')
diff --git a/src-3.0/GF/Compile/NoParse.hs b/src-3.0/GF/Compile/NoParse.hs
new file mode 100644
index 000000000..c8f828970
--- /dev/null
+++ b/src-3.0/GF/Compile/NoParse.hs
@@ -0,0 +1,49 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : NoParse
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/14 16:03:41 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.1 $
+--
+-- Probabilistic abstract syntax. AR 30\/10\/2005
+--
+-- (c) Aarne Ranta 2005 under GNU GPL
+--
+-- Contents: decide what lin rules no parser is generated.
+-- Usually a list of noparse idents from 'i -boparse=file'.
+
+-----------------------------------------------------------------------------
+
+module GF.Compile.NoParse (
+  NoParse             -- =  Ident -> Bool
+ ,getNoparseFromFile  -- :: Opts -> IO NoParse
+ ,doParseAll          -- :: NoParse
+  ) where
+
+import GF.Infra.Ident
+import GF.Data.Operations
+import GF.Infra.Option
+
+
+type NoParse = (Ident -> Bool)
+
+doParseAll :: NoParse
+doParseAll = const False
+
+getNoparseFromFile :: Options -> FilePath -> IO NoParse
+getNoparseFromFile opts file = do 
+  let f = maybe file id $ getOptVal opts noparseFile
+  s <- readFile f
+  let tree = buildTree $ flip zip (repeat ()) $ concat $ map getIgnores $ lines s
+  tree `seq` return $ igns tree
+ where
+  igns tree i = isInBinTree i tree
+
+-- where
+getIgnores s = case dropWhile (/="--#") (words s) of
+     _:"noparse":fs -> map identC fs
+     _ -> []
diff --git a/src-3.0/GF/Compile/Optimize.hs b/src-3.0/GF/Compile/Optimize.hs
new file mode 100644
index 000000000..a540ee715
--- /dev/null
+++ b/src-3.0/GF/Compile/Optimize.hs
@@ -0,0 +1,300 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Optimize
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/09/16 13:56:13 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.18 $
+--
+-- Top-level partial evaluation for GF source modules.
+-----------------------------------------------------------------------------
+
+module GF.Compile.Optimize (optimizeModule) where
+
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Infra.Modules
+import GF.Grammar.PrGrammar
+import GF.Grammar.Macros
+import GF.Grammar.Lookup
+import GF.Grammar.Refresh
+import GF.Grammar.Compute
+import GF.Compile.BackOpt
+import GF.Compile.CheckGrammar
+import GF.Compile.Update
+import GF.Compile.Evaluate
+
+import GF.Data.Operations
+import GF.Infra.CheckM
+import GF.Infra.Option
+
+import Control.Monad
+import Data.List
+
+import Debug.Trace
+
+
+-- conditional trace
+
+prtIf :: (Print a) => Bool -> a -> a
+prtIf b t = if b then trace (" " ++ prt t) t else t
+
+-- experimental evaluation, option to import
+oEval = iOpt "eval"
+
+-- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.
+-- only do this for resource: concrete is optimized in gfc form
+optimizeModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> 
+                  (Ident,SourceModInfo) -> Err ((Ident,SourceModInfo),EEnv)
+optimizeModule opts mse@(ms,eenv) mo@(_,mi) = case mi of
+  ModMod m0@(Module mt st fs me ops js) | 
+    st == MSComplete && isModRes m0 && not (oElem oEval oopts)-> do
+      (mo1,_) <- evalModule oopts mse mo
+      let 
+       mo2 = case optim of
+        "parametrize" -> shareModule paramOpt mo1  -- parametrization and sharing
+        "values"      -> shareModule valOpt mo1    -- tables as courses-of-values
+        "share"       -> shareModule shareOpt mo1  -- sharing of branches
+        "all"         -> shareModule allOpt mo1    -- first parametrize then values
+        "none"        -> mo1                       -- no optimization
+        _             -> mo1                       -- none; default for src
+      return (mo2,eenv)
+  _ -> evalModule oopts mse mo
+ where
+   oopts = addOptions opts (iOpts (flagsModule mo))
+   optim = maybe "all" id $ getOptVal oopts useOptimizer
+
+evalModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> (Ident,SourceModInfo) -> 
+               Err ((Ident,SourceModInfo),EEnv)
+evalModule oopts (ms,eenv) mo@(name,mod) = case mod of
+
+  ModMod m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of
+    _ | isModRes m0 && not (oElem oEval oopts) -> do
+      let deps = allOperDependencies name js
+      ids <- topoSortOpers deps
+      MGrammar (mod' : _) <- foldM evalOp gr ids
+      return $ (mod',eenv)
+
+    MTConcrete a | oElem oEval oopts -> do
+      (js0,eenv') <- appEvalConcrete gr js eenv
+      js' <- mapMTree (evalCncInfo oopts gr name a) js0 ---- <- gr0 6/12/2005 
+      return $ ((name, ModMod (Module mt st fs me ops js')),eenv')
+
+    MTConcrete a -> do
+      js' <- mapMTree (evalCncInfo oopts gr name a) js ---- <- gr0 6/12/2005
+      return $ ((name, ModMod (Module mt st fs me ops js')),eenv)
+
+    _ -> return $ ((name,mod),eenv)
+  _ -> return $ ((name,mod),eenv)
+ where
+   gr0 = MGrammar $ ms
+   gr  = MGrammar $ (name,mod) : ms
+
+   evalOp g@(MGrammar ((_, ModMod m) : _)) i = do
+     info  <- lookupTree prt i $ jments m
+     info' <- evalResInfo oopts gr (i,info)
+     return $ updateRes g name i info'
+
+-- | only operations need be compiled in a resource, and this is local to each
+-- definition since the module is traversed in topological order
+evalResInfo :: Options -> SourceGrammar -> (Ident,Info) -> Err Info
+evalResInfo oopts gr (c,info) = case info of
+
+  ResOper pty pde -> eIn "operation" $ do
+    pde' <- case pde of
+       Yes de | optres -> liftM yes $ comp de 
+       _ -> return pde
+    return $ ResOper pty pde'
+
+  _ ->  return info
+ where
+   comp = if optres then computeConcrete gr else computeConcreteRec gr
+   eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
+   optim = maybe "all" id $ getOptVal oopts useOptimizer
+   optres = case optim of
+     "noexpand" -> False
+     _ -> True
+
+
+evalCncInfo :: 
+  Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err (Ident,Info)
+evalCncInfo opts gr cnc abs (c,info) = do
+
+ seq (prtIf (oElem beVerbose opts) c) $ return ()
+
+ errIn ("optimizing" +++ prt c) $ case info of
+
+  CncCat ptyp pde ppr -> do
+    pde' <- case (ptyp,pde) of
+      (Yes typ, Yes de) -> 
+        liftM yes $ pEval ([(strVar, typeStr)], typ) de
+      (Yes typ, Nope)   -> 
+        liftM yes $ mkLinDefault gr typ >>= partEval noOptions gr ([(strVar, typeStr)],typ)
+      (May b, Nope) ->
+        return $ May b
+      _ -> return pde   -- indirection
+
+    ppr' <- liftM yes $ evalPrintname gr c ppr (yes $ K $ prt c)
+
+    return (c, CncCat ptyp pde' ppr')
+
+  CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr -> 
+       eIn ("linearization in type" +++ prt (mkProd (cont,val,[])) ++++ "of function") $ do
+    pde' <- case pde of
+      Yes de | notNewEval -> do
+        liftM yes $ pEval ty de
+
+      _ -> return pde
+    ppr' <-  liftM yes $ evalPrintname gr c ppr pde'
+    return $ (c, CncFun mt pde' ppr') -- only cat in type actually needed
+
+  _ ->  return (c,info)
+ where
+   pEval = partEval opts gr
+   eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
+   notNewEval = not (oElem oEval opts)
+
+-- | the main function for compiling linearizations
+partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term
+partEval opts gr (context, val) trm = errIn ("parteval" +++ prt_ trm) $ do
+  let vars  = map fst context
+      args  = map Vr vars
+      subst = [(v, Vr v) | v <- vars]
+      trm1  = mkApp trm args
+  trm3 <- if globalTable 
+             then etaExpand subst trm1 >>= outCase subst
+             else etaExpand subst trm1
+  return $ mkAbs vars trm3
+
+ where 
+
+   globalTable = oElem showAll opts --- i -all
+
+   comp g t = {- refreshTerm t >>= -} computeTerm gr g t
+
+   etaExpand su t = do
+     t' <- comp su t 
+     case t' of
+       R _ | rightType t' -> comp su t' --- return t' wo noexpand...
+       _ -> recordExpand val t' >>= comp su
+   -- don't eta expand records of right length (correct by type checking)
+   rightType t = case (t,val) of
+     (R rs, RecType ts) -> length rs == length ts
+     _ -> False
+
+   outCase subst t = do
+     pts <- getParams context
+     let (args,ptyps) = unzip $ filter (flip occur t . fst) pts
+     if null args 
+       then return t 
+       else do 
+         let argtyp = RecType $ tuple2recordType ptyps
+         let pvars = map (Vr . zIdent . prt) args -- gets eliminated
+         patt <- term2patt $ R $ tuple2record $ pvars
+         let t' = replace (zip args pvars) t
+         t1 <- comp subst $ T (TTyped argtyp) [(patt, t')]
+         return $ S t1 $ R $ tuple2record args
+
+   --- notice: this assumes that all lin types follow the "old JFP style" 
+   getParams = liftM concat . mapM getParam 
+   getParam (argv,RecType rs) = return 
+     [(P (Vr argv) lab, ptyp) | (lab,ptyp) <- rs,  not (isLinLabel lab)] 
+   ---getParam (_,ty) | ty==typeStr = return [] --- in lindef 
+   getParam (av,ty) = 
+     Bad ("record type expected not" +++ prt ty +++ "for" +++ prt av) 
+     --- all lin types are rec types
+
+   replace :: [(Term,Term)] -> Term -> Term
+   replace reps trm = case trm of  
+     -- this is the important case
+     P _ _ -> maybe trm id $ lookup trm reps
+     _ -> composSafeOp (replace reps) trm
+
+   occur t trm = case trm of
+
+     -- this is the important case
+     P _ _   -> t == trm
+     S x y   -> occur t y || occur t x
+     App f x -> occur t x || occur t f
+     Abs _ f -> occur t f
+     R rs    -> any (occur t) (map (snd . snd) rs)
+     T _ cs  -> any (occur t) (map snd cs)
+     C x y   -> occur t x || occur t y
+     Glue x y -> occur t x || occur t y
+     ExtR x y -> occur t x || occur t y
+     FV ts   -> any (occur t) ts
+     V _ ts   -> any (occur t) ts
+     Let (_,(_,x)) y -> occur t x || occur t y
+     _ -> False
+
+
+-- here we must be careful not to reduce
+--   variants {{s = "Auto" ; g = N} ; {s = "Wagen" ; g = M}}
+--   {s  = variants {"Auto" ; "Wagen"} ; g  = variants {N ; M}} ;
+
+recordExpand :: Type -> Term -> Err Term
+recordExpand typ trm = case unComputed typ of
+  RecType tys -> case trm of
+    FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs]
+    _ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys]
+  _ -> return trm
+
+
+-- | auxiliaries for compiling the resource
+
+mkLinDefault :: SourceGrammar -> Type -> Err Term
+mkLinDefault gr typ = do
+  case unComputed typ of
+    RecType lts -> mapPairsM mkDefField lts >>= (return . Abs strVar . R . mkAssign)
+    _ -> prtBad "linearization type must be a record type, not" typ
+ where
+   mkDefField typ = case unComputed typ of
+     Table p t  -> do
+       t' <- mkDefField t
+       let T _ cs = mkWildCases t'
+       return $ T (TWild p) cs 
+     Sort "Str" -> return $ Vr strVar
+     QC q p     -> lookupFirstTag gr q p
+     RecType r  -> do
+       let (ls,ts) = unzip r
+       ts' <- mapM mkDefField ts
+       return $ R $ [assign l t | (l,t) <- zip ls ts']
+     _ | isTypeInts typ -> return $ EInt 0 -- exists in all as first val
+     _ -> prtBad "linearization type field cannot be" typ
+
+-- | Form the printname: if given, compute. If not, use the computed
+-- lin for functions, cat name for cats (dispatch made in evalCncDef above).
+--- We cannot use linearization at this stage, since we do not know the
+--- defaults we would need for question marks - and we're not yet in canon.
+evalPrintname :: SourceGrammar -> Ident -> MPr -> Perh Term -> Err Term
+evalPrintname gr c ppr lin =
+  case ppr of
+    Yes pr -> comp pr
+    _ -> case lin of
+      Yes t -> return $ K $ clean $ prt $ oneBranch t ---- stringFromTerm
+      _ -> return $ K $ prt c ----
+ where
+   comp = computeConcrete gr
+
+   oneBranch t = case t of
+     Abs _ b   -> oneBranch b
+     R   (r:_) -> oneBranch $ snd $ snd r
+     T _ (c:_) -> oneBranch $ snd c
+     V _ (c:_) -> oneBranch c
+     FV  (t:_) -> oneBranch t
+     C x y     -> C (oneBranch x) (oneBranch y)
+     S x _     -> oneBranch x
+     P x _     -> oneBranch x
+     Alts (d,_) -> oneBranch d
+     _ -> t
+
+  --- very unclean cleaner
+   clean s = case s of
+     '+':'+':' ':cs -> clean cs
+     '"':cs -> clean cs
+     c:cs -> c: clean cs
+     _ -> s
+
diff --git a/src-3.0/GF/Compile/PGrammar.hs b/src-3.0/GF/Compile/PGrammar.hs
new file mode 100644
index 000000000..521f616b5
--- /dev/null
+++ b/src-3.0/GF/Compile/PGrammar.hs
@@ -0,0 +1,77 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : PGrammar
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/25 10:27:12 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.8 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Compile.PGrammar (pTerm, pTrm, pTrms,
+		 pMeta, pzIdent, 
+		 string2ident
+		) where
+
+---import LexGF
+import GF.Source.ParGF
+import GF.Source.SourceToGrammar (transExp)
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import qualified GF.Canon.AbsGFC as A
+import qualified GF.Canon.GFC as G
+import GF.Compile.GetGrammar
+import GF.Grammar.Macros
+import GF.Grammar.MMacros
+
+import GF.Data.Operations
+import qualified Data.ByteString.Char8 as BS
+
+pTerm :: String -> Err Term
+pTerm s = do
+  e <- pExp $ myLexer (BS.pack s)
+  transExp e
+
+pTrm :: String -> Term
+pTrm = errVal (vr (zIdent "x")) . pTerm ---
+
+pTrms :: String -> [Term]
+pTrms = map pTrm . sep [] where
+  sep t cs = case cs of
+    ',' : cs2 -> reverse t : sep [] cs2
+    c   : cs2 -> sep (c:t) cs2
+    _         -> [reverse t]
+
+pTrm' :: String -> [Term]
+pTrm' = err (const []) singleton . pTerm
+
+pMeta :: String -> Integer
+pMeta _ = 0 ---
+
+pzIdent :: String -> Ident
+pzIdent = zIdent
+
+{-
+string2formsAndTerm :: String -> ([Term],Term)
+string2formsAndTerm s = case s of
+    '[':_:_ -> case span (/=']') s of  
+      (x,_:y) -> (pTrms (tail x), pTrm y)
+      _ -> ([],pTrm s)
+    _ -> ([], pTrm s)
+-}
+
+string2ident :: String -> Err Ident
+string2ident s = return $ string2var s
+
+{-
+-- reads the Haskell datatype
+readGrammar :: String -> Err GrammarST
+readGrammar s =  case [x | (x,t) <- reads s, ("","") <- lex t] of
+  [x] -> return x
+  []  -> Bad "no parse of Grammar"
+  _   -> Bad "ambiguous parse of Grammar"
+-}
diff --git a/src-3.0/GF/Compile/PrOld.hs b/src-3.0/GF/Compile/PrOld.hs
new file mode 100644
index 000000000..29920fab6
--- /dev/null
+++ b/src-3.0/GF/Compile/PrOld.hs
@@ -0,0 +1,84 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : PrOld
+-- Maintainer  : GF
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:44 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.8 $
+--
+-- a hack to print gf2 into gf1 readable files
+-- Works only for canonical grammars, printed into GFC. Otherwise we would have
+-- problems with qualified names.
+-- --- printnames are not preserved, nor are lindefs
+-----------------------------------------------------------------------------
+
+module GF.Compile.PrOld (printGrammarOld, stripTerm) where
+
+import GF.Grammar.PrGrammar
+import GF.Canon.CanonToGrammar
+import qualified GF.Canon.GFC as GFC
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Grammar.Macros
+import GF.Infra.Modules
+import qualified GF.Source.PrintGF as P
+import GF.Source.GrammarToSource
+
+import Data.List
+import GF.Data.Operations
+import GF.Infra.UseIO
+
+printGrammarOld :: GFC.CanonGrammar -> String
+printGrammarOld gr = err id id $ do
+  as0 <- mapM canon2sourceModule [im | im@(_,ModMod m) <- modules gr, isModAbs m]
+  cs0 <- mapM canon2sourceModule 
+           [im | im@(_,ModMod m) <- modules gr, isModCnc m || isModRes m]
+  as1 <- return $ concatMap stripInfo $ concatMap (tree2list . js . snd) as0
+  cs1 <- return $ concatMap stripInfo $ concatMap (tree2list . js . snd) cs0
+  return $ unlines $ map prj $ srt as1 ++ srt cs1
+ where
+   js (ModMod m) = jments m
+   srt = sortBy (\ (i,_) (j,_) -> compare i j)
+   prj ii = P.printTree $ trAnyDef ii
+
+stripInfo :: (Ident,Info) -> [(Ident,Info)]
+stripInfo (c,i) = case i of
+  AbsCat   (Yes co) (Yes fs) -> rc $ AbsCat (Yes (stripContext co)) nope
+  AbsFun   (Yes ty) (Yes tr) -> rc $ AbsFun (Yes (stripTerm ty)) (Yes(stripTerm tr))
+  AbsFun   (Yes ty) _ -> rc $ AbsFun (Yes (stripTerm ty)) nope
+  ResParam (Yes (ps,m))       -> rc $ ResParam (Yes ([(c,stripContext co) | (c,co)<- ps],Nothing))
+  CncCat   (Yes ty) _ _ -> rc $
+    CncCat (Yes (stripTerm ty)) nope nope
+  CncFun   _ (Yes tr) _ -> rc $ CncFun Nothing (Yes (stripTerm tr)) nope
+  _ -> []
+ where
+   rc j = [(c,j)]
+
+stripContext co = [(x, stripTerm t) | (x,t) <- co]
+
+stripTerm :: Term -> Term
+stripTerm t = case t of
+  Q _ c -> Vr c
+  QC _ c -> Vr c
+  T ti cs -> T ti' [(stripPattern p, stripTerm c) | (p,c) <- cs] where
+               ti' = case ti of
+                  TTyped ty -> TTyped $ stripTerm ty
+                  TComp ty -> TComp $ stripTerm ty
+                  TWild ty -> TWild $ stripTerm ty
+                  _ -> ti
+----  R [] -> EInt 8      --- GF 1.2 parser doesn't accept empty records 
+----  RecType [] -> Cn (zIdent "Int") ---
+  _ -> composSafeOp stripTerm t
+
+stripPattern p = case p of
+  PC c [] -> PV c
+  PP _ c [] -> PV c
+  PC c ps -> PC c (map stripPattern ps)
+  PP _ c ps -> PC c (map stripPattern ps)
+  PR lps -> PR [(l, stripPattern p) | (l,p) <- lps]
+  PT t p -> PT (stripTerm t) (stripPattern p)
+  _ -> p
+
diff --git a/src-3.0/GF/Compile/Rebuild.hs b/src-3.0/GF/Compile/Rebuild.hs
new file mode 100644
index 000000000..152983b96
--- /dev/null
+++ b/src-3.0/GF/Compile/Rebuild.hs
@@ -0,0 +1,99 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Rebuild
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/30 21:08:14 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.14 $
+--
+-- Rebuild a source module from incomplete and its with-instance.
+-----------------------------------------------------------------------------
+
+module GF.Compile.Rebuild (rebuildModule) where
+
+import GF.Grammar.Grammar
+import GF.Compile.ModDeps
+import GF.Grammar.PrGrammar
+import GF.Grammar.Lookup
+import GF.Compile.Extend
+import GF.Grammar.Macros
+
+import GF.Infra.Ident
+import GF.Infra.Modules
+import GF.Data.Operations
+
+import Data.List (nub)
+
+-- | rebuilding instance + interface, and "with" modules, prior to renaming. 
+-- AR 24/10/2003
+rebuildModule :: [SourceModule] -> SourceModule -> Err SourceModule
+rebuildModule ms mo@(i,mi) = do
+  let gr = MGrammar ms
+----  deps <- moduleDeps ms
+----  is   <- openInterfaces deps i
+  let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005
+  mi'  <- case mi of
+
+    -- add the information given in interface into an instance module
+    ModMod m -> do
+      testErr (null is || mstatus m == MSIncomplete) 
+              ("module" +++ prt i +++ 
+               "has open interfaces and must therefore be declared incomplete") 
+      case mtype m of
+        MTInstance i0 -> do
+          m1 <- lookupModMod gr i0
+          testErr (isModRes m1) ("interface expected instead of" +++ prt i0)
+          m' <- do
+            js' <- extendMod False (i0,const True) i (jments m1) (jments m)
+            --- to avoid double inclusions, in instance I of I0 = J0 ** ...
+            case extends m of
+              [] -> return $ replaceJudgements m js'
+              j0s -> do 
+                m0s <- mapM (lookupModMod gr) j0s
+                let notInM0 c _  = all (not . isInBinTree c . jments) m0s
+                let js2 = filterBinTree notInM0 js'
+                return $ replaceJudgements m js2
+          return $ ModMod m'
+        _ -> return mi
+
+    -- add the instance opens to an incomplete module "with" instances
+    --      ModWith mt stat ext me ops -> do
+    ModWith (Module mt stat fs_ me ops_ js_) (ext,incl) ops -> do
+      let insts = [(inf,inst) | OQualif _ inf inst <- ops]
+      let infs  = map fst insts
+      let stat' = ifNull MSComplete (const MSIncomplete)
+                    [i | i <- is, notElem i infs]
+      testErr (stat' == MSComplete || stat == MSIncomplete) 
+              ("module" +++ prt i +++ "remains incomplete")
+      Module mt0 _ fs me' ops0 js <- lookupModMod gr ext
+      let ops1 = nub $
+                   ops_ ++ -- N.B. js has been name-resolved already
+                   ops ++ [o | o <- ops0, notElem (openedModule o) infs]
+                       ++ [oQualif i i | i <- map snd insts] ----
+                       ++ [oSimple i   | i <- map snd insts] ----
+
+      --- check if me is incomplete
+      let fs1 = fs_ ++ fs                            -- new flags have priority
+      let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c]
+      let js1 = buildTree (tree2list js_ ++ js0)
+      return $ ModMod $ Module mt0 stat' fs1 me ops1 js1 
+                          ---- (mapTree (qualifInstanceInfo insts) js) -- not needed
+
+    _ -> return mi
+  return (i,mi')
+
+checkCompleteInstance :: SourceRes -> SourceRes -> Err ()
+checkCompleteInstance abs cnc = ifNull (return ()) (Bad . unlines) $
+  checkComplete [f | (f, ResOper (Yes _) _) <- abs'] cnc'
+   where
+     abs' = tree2list $ jments abs
+     cnc' = jments cnc
+     checkComplete sought given = foldr ckOne [] sought
+       where
+         ckOne f = if isInBinTree f given 
+                      then id
+                      else (("Error: no definition given to" +++ prt f):)
+
diff --git a/src-3.0/GF/Compile/RemoveLiT.hs b/src-3.0/GF/Compile/RemoveLiT.hs
new file mode 100644
index 000000000..28aae9b84
--- /dev/null
+++ b/src-3.0/GF/Compile/RemoveLiT.hs
@@ -0,0 +1,63 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : RemoveLiT
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:45 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.6 $
+--
+-- remove obsolete (Lin C) expressions before doing anything else. AR 21/6/2003
+--
+-- What the program does is replace the occurrences of Lin C with the actual
+-- definition T given in lincat C = T ; with {s : Str} if no lincat is found.
+-- The procedure is uncertain, if T contains another Lin.
+-----------------------------------------------------------------------------
+
+module GF.Compile.RemoveLiT (removeLiT) where
+
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Infra.Modules
+import GF.Grammar.Macros
+import GF.Grammar.Lookup
+
+import GF.Data.Operations
+
+import Control.Monad
+
+removeLiT :: SourceGrammar -> Err SourceGrammar
+removeLiT gr = liftM MGrammar $ mapM (remlModule gr) (modules gr)
+
+remlModule :: SourceGrammar -> (Ident,SourceModInfo) -> Err (Ident,SourceModInfo)
+remlModule gr mi@(name,mod) = case mod of
+  ModMod (Module mt st fs me ops js) -> do
+    js1 <- mapMTree (remlResInfo gr) js
+    let mod2 = ModMod $ Module mt st fs me ops js1
+    return $ (name,mod2)
+  _ -> return mi
+
+remlResInfo :: SourceGrammar -> (Ident,Info) -> Err (Ident,Info)
+remlResInfo gr mi@(i,info) = case info of
+  ResOper pty ptr    -> liftM ((,) i) $ liftM2 ResOper (ren pty) (ren ptr)
+  CncCat pty ptr ppr -> liftM ((,) i) $ liftM3 CncCat (ren pty) (ren ptr) (ren ppr)
+  CncFun mt  ptr ppr -> liftM ((,) i) $ liftM2 (CncFun mt)      (ren ptr) (ren ppr)
+  _ -> return mi
+ where 
+   ren = remlPerh gr
+
+remlPerh gr pt = case pt of
+  Yes t -> liftM Yes $ remlTerm gr t
+  _ -> return pt
+
+remlTerm :: SourceGrammar -> Term -> Err Term
+remlTerm gr trm = case trm of
+  LiT c -> look c >>= remlTerm gr
+  _ -> composOp (remlTerm gr) trm
+ where
+   look c = err (const $ return defLinType) return $ lookupLincat gr m c
+   m = case [cnc | (cnc,ModMod m) <- modules gr, isModCnc m] of
+     cnc:_ -> cnc   -- actually there is always exactly one
+     _ -> zIdent "CNC" 
diff --git a/src-3.0/GF/Compile/Rename.hs b/src-3.0/GF/Compile/Rename.hs
new file mode 100644
index 000000000..c3fef557b
--- /dev/null
+++ b/src-3.0/GF/Compile/Rename.hs
@@ -0,0 +1,338 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Rename
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/30 18:39:44 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.19 $
+--
+-- AR 14\/5\/2003
+-- The top-level function 'renameGrammar' does several things:
+--
+--   - extends each module symbol table by indirections to extended module
+--
+--   - changes unqualified and as-qualified imports to absolutely qualified
+--
+--   - goes through the definitions and resolves names
+--
+-- Dependency analysis between modules has been performed before this pass.
+-- Hence we can proceed by @fold@ing "from left to right".
+-----------------------------------------------------------------------------
+
+module GF.Compile.Rename (renameGrammar,
+	       renameSourceTerm,
+	       renameModule
+	      ) where
+
+import GF.Grammar.Grammar
+import GF.Grammar.Values
+import GF.Infra.Modules
+import GF.Infra.Ident
+import GF.Grammar.Macros
+import GF.Grammar.PrGrammar
+import GF.Grammar.AppPredefined
+import GF.Grammar.Lookup
+import GF.Compile.Extend
+import GF.Data.Operations
+
+import Control.Monad
+import Data.List (nub)
+import Debug.Trace (trace)
+
+renameGrammar :: SourceGrammar -> Err SourceGrammar
+renameGrammar g = liftM (MGrammar . reverse) $ foldM renameModule [] (modules g)
+
+-- | this gives top-level access to renaming term input in the cc command
+renameSourceTerm :: SourceGrammar -> Ident -> Term -> Err Term
+renameSourceTerm g m t = do
+  mo     <- lookupErr m (modules g)
+  status <- buildStatus g m mo
+  renameTerm status [] t
+
+renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule]
+renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod of
+  ModMod m@(Module mt st fs me ops js) -> do
+    let js1 = jments m
+    status <- buildStatus (MGrammar ms) name mod
+    js2    <- mapMTree (renameInfo status) js1
+    let mod2 = ModMod $ Module mt st fs me (map forceQualif ops) js2
+    return $ (name,mod2) : ms
+
+type Status = (StatusTree, [(OpenSpec Ident, StatusTree)])
+
+type StatusTree = BinTree Ident StatusInfo
+
+type StatusInfo = Ident -> Term
+
+renameIdentTerm :: Status -> Term -> Err Term
+renameIdentTerm env@(act,imps) t = 
+ errIn ("atomic term" +++ prt t +++ "given" +++ unwords (map (prt . fst) qualifs)) $
+   case t of
+  Vr c -> ident predefAbs c
+  Cn c -> ident (\_ s -> Bad s) c
+  Q m' c | m' == cPredef {- && isInPredefined c -} -> return t
+  Q m' c -> do
+    m <- lookupErr m' qualifs
+    f <- lookupTree prt c m
+    return $ f c
+  QC m' c | m' == cPredef {- && isInPredefined c -} -> return t
+  QC m' c -> do
+    m <- lookupErr m' qualifs
+    f <- lookupTree prt c m
+    return $ f c
+  _ -> return t
+ where
+   opens  = [st  | (OSimple _ _,st) <- imps]
+   qualifs = [(m, st) | (OQualif _ m _, st) <- imps] ++ 
+             [(m, st) | (OSimple _ m, st) <- imps] -- qualif is always possible
+
+   -- this facility is mainly for BWC with GF1: you need not import PredefAbs
+   predefAbs c s = case c of
+     IC "Int" -> return $ Q cPredefAbs cInt
+     IC "Float" -> return $ Q cPredefAbs cFloat
+     IC "String" -> return $ Q cPredefAbs cString
+     _ -> Bad s
+
+   ident alt c = case lookupTree prt c act of
+      Ok f -> return $ f c
+      _ -> case lookupTreeManyAll prt opens c of
+        [f] -> return $ f c
+        []  -> alt c ("constant not found:" +++ prt c) 
+        fs -> case nub [f c | f <- fs]  of
+          [tr] -> return tr
+          ts@(t:_) -> trace ("WARNING: conflict" +++ unwords (map prt ts)) (return t)
+----          ts -> return $ Strs $ (cnIC "#conflict") : reverse ts
+            -- a warning will be generated in CheckGrammar, and the head returned
+            -- in next V: 
+            -- Bad $ "conflicting imports:" +++ unwords (map prt ts) 
+
+
+--- | would it make sense to optimize this by inlining?
+renameIdentPatt :: Status -> Patt -> Err Patt
+renameIdentPatt env p = do
+  let t = patt2term p
+  t' <- renameIdentTerm env t
+  term2patt t'
+
+info2status :: Maybe Ident -> (Ident,Info) -> (Ident,StatusInfo)
+info2status mq (c,i) = (c, case i of
+  AbsFun _ (Yes EData) -> maybe Con QC mq
+  ResValue _  -> maybe Con QC mq
+  ResParam _  -> maybe Con QC mq
+  AnyInd True m -> maybe Con (const (QC m)) mq
+  AnyInd False m -> maybe Cn (const (Q m)) mq
+  _           -> maybe Cn  Q mq
+  )
+
+tree2status :: OpenSpec Ident -> BinTree Ident Info -> BinTree Ident StatusInfo
+tree2status o = case o of
+  OSimple _ i   -> mapTree (info2status (Just i))
+  OQualif _ i j -> mapTree (info2status (Just j))
+
+buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Err Status
+buildStatus gr c mo = let mo' = self2status c mo in case mo of
+  ModMod m -> do
+    let gr1 = MGrammar $ (c,mo) : modules gr 
+        ops = [OSimple OQNormal e | e <- allExtends gr1 c] ++ allOpens m
+    mods <- mapM (lookupModule gr1 . openedModule) ops
+    let sts = map modInfo2status $ zip ops mods    
+    return $ if isModCnc m
+      then (emptyBinTree, reverse sts) -- the module itself does not define any names
+      else (mo',reverse sts) -- so the empty ident is not needed
+
+modInfo2status :: (OpenSpec Ident,SourceModInfo) -> (OpenSpec Ident, StatusTree)
+modInfo2status (o,i) = (o,case i of
+  ModMod m -> tree2status o (jments m)
+  )
+
+self2status :: Ident -> SourceModInfo -> StatusTree
+self2status c i = mapTree (info2status (Just c)) js where   -- qualify internal
+  js = case i of
+    ModMod m 
+      | isModTrans m -> sorted2tree $ filter noTrans $ tree2list $ jments m 
+      | otherwise -> jments m
+  noTrans (_,d) = case d of  -- to enable other than transfer js in transfer module 
+    AbsTrans _ -> False
+    _ -> True
+
+forceQualif o = case o of
+  OSimple q i   -> OQualif q i i
+  OQualif q _ i -> OQualif q i i
+  
+renameInfo :: Status -> (Ident,Info) -> Err (Ident,Info)
+renameInfo status (i,info) = errIn ("renaming definition of" +++ prt i) $ 
+                                liftM ((,) i) $ case info of
+  AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco)
+                                  (renPerh (mapM rent) pfs)
+  AbsFun pty ptr -> liftM2 AbsFun (ren pty) (ren ptr)
+  AbsTrans f -> liftM AbsTrans (rent f)
+
+  ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr)
+  ResOverload tysts -> liftM ResOverload $ mapM (pairM rent) tysts
+
+  ResParam (Yes (pp,m)) -> do
+    pp' <- mapM (renameParam status) pp
+    return $ ResParam $ Yes (pp',m)
+  ResValue (Yes (t,m)) -> do
+    t' <- rent t
+    return $ ResValue $ Yes (t',m)
+  CncCat pty ptr ppr -> liftM3 CncCat (ren pty) (ren ptr) (ren ppr)
+  CncFun mt  ptr ppr -> liftM2 (CncFun mt)      (ren ptr) (ren ppr)
+  _ -> return info
+ where 
+   ren = renPerh rent
+   rent = renameTerm status []
+
+renPerh ren pt = case pt of
+  Yes t -> liftM Yes $ ren t
+  _ -> return pt
+
+renameTerm :: Status -> [Ident] -> Term -> Err Term
+renameTerm env vars = ren vars where
+  ren vs trm = case trm of
+    Abs x b    -> liftM  (Abs x) (ren (x:vs) b)
+    Prod x a b -> liftM2 (Prod x) (ren vs a) (ren (x:vs) b)
+    Typed a b  -> liftM2 Typed (ren vs a) (ren vs b)
+    Vr x      
+      | elem x vs -> return trm
+      | otherwise -> renid trm
+    Cn _   -> renid trm
+    Con _  -> renid trm
+    Q _ _  -> renid trm
+    QC _ _ -> renid trm
+    Eqs eqs -> liftM Eqs $ mapM (renameEquation env vars) eqs
+    T i cs -> do
+      i' <- case i of
+        TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source
+        _ -> return i
+      liftM (T i') $ mapM (renCase vs) cs  
+
+    Let (x,(m,a)) b -> do
+      m' <- case m of
+        Just ty -> liftM Just $ ren vs ty
+        _ -> return m
+      a' <- ren vs a
+      b' <- ren (x:vs) b
+      return $ Let (x,(m',a')) b'
+
+    P t@(Vr r) l                     -- for constant t we know it is projection
+      | elem r vs -> return trm                           -- var proj first
+      | otherwise -> case renid (Q r (label2ident l)) of  -- qualif   second
+          Ok t -> return t
+          _ -> case liftM (flip P l) $ renid t of
+            Ok t -> return t                              -- const proj last
+            _ -> prtBad "unknown qualified constant" trm
+
+    EPatt p -> do
+      (p',_) <- renpatt p
+      return $ EPatt p'
+
+    _ -> composOp (ren vs) trm
+
+  renid = renameIdentTerm env
+  renCase vs (p,t) = do
+    (p',vs') <- renpatt p
+    t' <- ren (vs' ++ vs) t
+    return (p',t')
+  renpatt = renamePattern env
+
+-- | vars not needed in env, since patterns always overshadow old vars
+renamePattern :: Status -> Patt -> Err (Patt,[Ident])
+renamePattern env patt = case patt of
+
+  PMacro c -> do
+    c' <- renid $ Vr c
+    case c' of
+      Q p d -> renp $ PM p d
+      _ -> prtBad "unresolved pattern" patt
+
+  PC c ps -> do
+    c' <- renameIdentTerm env $ Cn c
+    case c' of
+      QC p d -> renp $ PP p d ps
+--      Q  p d -> renp $ PP p d ps --- why this? AR 15/3/2008
+      _ -> prtBad "unresolved pattern" c' ---- (PC c ps', concat vs)
+
+  PP p c ps -> do
+
+    (p', c') <- case renameIdentTerm env (QC p c) of
+      Ok (QC p' c') -> return (p',c')
+      _ -> return (p,c) --- temporarily, for bw compat
+    psvss <- mapM renp ps
+    let (ps',vs) = unzip psvss
+    return (PP p' c' ps', concat vs)
+
+  PM p c -> do
+    (p', c') <- case renameIdentTerm env (Q p c) of
+      Ok (Q p' c') -> return (p',c')
+      _ -> prtBad "not a pattern macro" patt
+    return (PM p' c', [])
+
+  PV x -> case renid (Vr x) of
+    Ok (QC m c) -> return (PP m c [],[])
+    _    -> return (patt, [x])
+
+  PR r -> do
+    let (ls,ps) = unzip r
+    psvss <- mapM renp ps
+    let (ps',vs') = unzip psvss
+    return (PR (zip ls ps'), concat vs') 
+
+  PAlt p q -> do
+    (p',vs) <- renp p
+    (q',ws) <- renp q
+    return (PAlt p' q', vs ++ ws)
+
+  PSeq p q -> do
+    (p',vs) <- renp p
+    (q',ws) <- renp q
+    return (PSeq p' q', vs ++ ws)
+
+  PRep p -> do
+    (p',vs) <- renp p
+    return (PRep p', vs)
+
+  PNeg p -> do
+    (p',vs) <- renp p
+    return (PNeg p', vs)
+
+  PAs x p -> do
+    (p',vs) <- renp p
+    return (PAs x p', x:vs)
+
+  _ -> return (patt,[])
+
+ where 
+   renp  = renamePattern env
+   renid = renameIdentTerm env
+
+renameParam :: Status -> (Ident, Context) -> Err (Ident, Context)
+renameParam env (c,co) = do
+  co' <- renameContext env co
+  return (c,co')
+
+renameContext :: Status -> Context -> Err Context
+renameContext b = renc [] where
+  renc vs cont = case cont of
+    (x,t) : xts 
+      | isWildIdent x -> do
+          t'   <- ren vs t
+          xts' <- renc vs xts
+          return $ (x,t') : xts'
+      | otherwise -> do
+          t'   <- ren vs t
+          let vs' = x:vs
+          xts' <- renc vs' xts
+          return $ (x,t') : xts'
+    _ -> return cont
+  ren = renameTerm b
+
+-- | vars not needed in env, since patterns always overshadow old vars
+renameEquation :: Status -> [Ident] -> Equation -> Err Equation
+renameEquation b vs (ps,t) = do
+  (ps',vs') <- liftM unzip $ mapM (renamePattern b) ps
+  t'        <- renameTerm b (concat vs' ++ vs) t
+  return (ps',t')
diff --git a/src-3.0/GF/Compile/ShellState.hs b/src-3.0/GF/Compile/ShellState.hs
new file mode 100644
index 000000000..0e24da601
--- /dev/null
+++ b/src-3.0/GF/Compile/ShellState.hs
@@ -0,0 +1,568 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : ShellState
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/14 16:03:41 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.53 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Compile.ShellState where
+
+import GF.Data.Operations
+import GF.Canon.GFC
+import GF.Canon.AbsGFC
+import GF.GFCC.CId
+--import GF.GFCC.DataGFCC(mkGFCC)
+import GF.GFCC.Macros (lookFCFG)
+import GF.Canon.CanonToGFCC
+import GF.Grammar.Macros
+import GF.Grammar.MMacros
+
+import GF.Canon.Look
+import GF.Canon.Subexpressions
+import GF.Grammar.LookAbs
+import GF.Compile.ModDeps
+import GF.Compile.Evaluate
+import qualified GF.Infra.Modules as M
+import qualified GF.Grammar.Grammar as G
+import qualified GF.Grammar.PrGrammar as P
+import GF.CF.CF
+import GF.CF.CFIdent
+import GF.CF.CanonToCF
+import GF.UseGrammar.Morphology
+import GF.Probabilistic.Probabilistic
+import GF.Compile.NoParse
+import GF.Infra.Option
+import GF.Infra.Ident
+import GF.Infra.UseIO (justModuleName)
+import GF.System.Arch (ModTime)
+
+import qualified Transfer.InterpreterAPI as T
+
+import GF.Formalism.FCFG
+import qualified GF.OldParsing.ConvertGrammar as CnvOld -- OBSOLETE
+import qualified GF.Conversion.GFC as Cnv
+import qualified GF.Conversion.SimpleToFCFG as FCnv
+import qualified GF.Parsing.GFC as Prs
+
+import Control.Monad (mplus)
+import Data.List (nub,nubBy)
+import qualified Data.Map as Map
+import Data.Maybe (fromMaybe)
+
+
+-- AR 11/11/2001 -- 17/6/2003 (for modules) ---- unfinished
+
+-- | multilingual state with grammars and options
+data ShellState = ShSt {
+  abstract   :: Maybe Ident ,        -- ^ pointer to actual abstract, if not empty st
+  concrete   :: Maybe Ident ,        -- ^ pointer to primary concrete
+  concretes  :: [((Ident,Ident),Bool)], -- ^ list of all concretes, and whether active
+  canModules :: CanonGrammar ,       -- ^ compiled abstracts and concretes
+  srcModules :: G.SourceGrammar ,    -- ^ saved resource modules
+  cfs        :: [(Ident,CF)] ,       -- ^ context-free grammars (small, no parameters, very over-generating)
+  abstracts  :: [(Ident,[Ident])],   -- ^ abstracts and their associated concretes
+  mcfgs      :: [(Ident, Cnv.MGrammar)], -- ^ MCFG, converted according to Ljunglöf (2004, ch 3)
+  fcfgs      :: [(Ident, FGrammar)], -- ^ FCFG, optimized MCFG by Krasimir Angelov
+  cfgs       :: [(Ident, Cnv.CGrammar)], -- ^ CFG, converted from mcfg 
+                                         -- (large, with parameters, no-so overgenerating)
+  pInfos     :: [(Ident, Prs.PInfo)], -- ^ parsing information (compiled mcfg&cfg grammars)
+  morphos    :: [(Ident,Morpho)],    -- ^ morphologies
+  treebanks  :: [(Ident,Treebank)],  -- ^ treebanks
+  probss     :: [(Ident,Probs)],     -- ^ probability distributions
+  gloptions  :: Options,             -- ^ global options
+  readFiles  :: [(String,(FilePath,ModTime))],-- ^ files read
+  absCats    :: [(G.Cat,(G.Context,
+                  [(G.Fun,G.Type)],
+                  [((G.Fun,Int),G.Type)]))],   -- ^ cats, (their contexts, 
+                                               -- functions to them,
+                                               -- functions on them)
+  statistics :: [Statistics],         -- ^ statistics on grammars
+  transfers  :: [(Ident,T.Env)],      -- ^ transfer modules
+  evalEnv    :: EEnv                  -- ^ evaluation environment
+  }                             
+
+type Treebank = Map.Map String [String] -- string, trees
+
+actualConcretes :: ShellState -> [((Ident,Ident),Bool)]
+actualConcretes sh = nub [((c,c),b) | 
+  Just a <- [abstract sh],
+  ((c,_),_) <- concretes sh, ----concretesOfAbstract sh a,
+  let b = True -----
+  ]
+
+concretesOfAbstract :: ShellState -> Ident -> [Ident]
+concretesOfAbstract sh a = [c | (b,cs) <- abstracts sh, b == a, c <- cs]
+
+data Statistics = 
+    StDepTypes Bool        -- ^ whether there are dependent types      
+  | StBoundVars [G.Cat]    -- ^ which categories have bound variables
+  ---                      -- etc
+   deriving (Eq,Ord)
+
+emptyShellState :: ShellState
+emptyShellState = ShSt {
+  abstract   = Nothing,
+  concrete   = Nothing,
+  concretes  = [],
+  canModules = M.emptyMGrammar,
+  srcModules = M.emptyMGrammar,
+  cfs        = [],
+  abstracts  = [],
+  mcfgs      = [],
+  fcfgs      = [],
+  cfgs       = [],
+  pInfos     = [],
+  morphos    = [],
+  treebanks  = [],
+  probss     = [],
+  gloptions  = noOptions,
+  readFiles  = [],
+  absCats    = [],
+  statistics = [],
+  transfers  = [],
+  evalEnv    = emptyEEnv
+  }
+
+optInitShellState :: Options -> ShellState
+optInitShellState os = addGlobalOptions os emptyShellState
+
+type Language = Ident
+
+language :: String -> Language
+language = identC
+
+prLanguage :: Language -> String
+prLanguage = prIdent
+
+-- | grammar for one language in a state, comprising its abs and cnc
+data StateGrammar = StGr {
+  absId    :: Ident,
+  cncId    :: Ident,
+  grammar  :: CanonGrammar,
+  cf       :: CF,
+  mcfg     :: Cnv.MGrammar,
+  fcfg     :: FGrammar,
+  cfg      :: Cnv.CGrammar,
+  pInfo    :: Prs.PInfo,
+  morpho   :: Morpho,
+  probs    :: Probs,
+  loptions :: Options
+  }
+
+emptyStateGrammar :: StateGrammar
+emptyStateGrammar = StGr {
+  absId    = identC "#EMPTY", ---
+  cncId    = identC "#EMPTY", ---
+  grammar  = M.emptyMGrammar,
+  cf       = emptyCF,
+  mcfg     = [],
+  fcfg     = ([], Map.empty),
+  cfg      = [],
+  pInfo    = Prs.buildPInfo [] ([], Map.empty) [],
+  morpho   = emptyMorpho,
+  probs    = emptyProbs,
+  loptions = noOptions
+  }
+
+-- analysing shell grammar into parts
+
+stateGrammarST    :: StateGrammar -> CanonGrammar
+stateCF           :: StateGrammar -> CF
+stateMCFG         :: StateGrammar -> Cnv.MGrammar
+stateFCFG         :: StateGrammar -> FGrammar
+stateCFG          :: StateGrammar -> Cnv.CGrammar
+statePInfo        :: StateGrammar -> Prs.PInfo
+stateMorpho       :: StateGrammar -> Morpho
+stateProbs        :: StateGrammar -> Probs
+stateOptions      :: StateGrammar -> Options
+stateGrammarWords :: StateGrammar -> [String]
+stateGrammarLang  :: StateGrammar -> (CanonGrammar, Ident)
+
+stateGrammarST = grammar
+stateCF        = cf
+stateMCFG      = mcfg
+stateFCFG      = fcfg
+stateCFG       = cfg
+statePInfo     = pInfo
+stateMorpho    = morpho
+stateProbs     = probs
+stateOptions   = loptions
+stateGrammarWords = allMorphoWords . stateMorpho
+stateGrammarLang st = (grammar st, cncId st)
+
+---- this should be computed at compile time and stored
+stateHasHOAS :: StateGrammar -> Bool
+stateHasHOAS = hasHOAS . stateGrammarST
+
+cncModuleIdST :: StateGrammar -> CanonGrammar
+cncModuleIdST = stateGrammarST
+
+-- | form a shell state from a canonical grammar
+grammar2shellState :: Options -> (CanonGrammar, G.SourceGrammar) -> Err ShellState 
+grammar2shellState opts (gr,sgr) = 
+  updateShellState opts doParseAll Nothing emptyShellState ((0,sgr,gr,emptyEEnv),[]) --- is 0 safe?
+
+-- | update a shell state from a canonical grammar
+updateShellState :: Options -> NoParse -> Maybe Ident -> ShellState -> 
+   ((Int,G.SourceGrammar,CanonGrammar,EEnv),[(String,(FilePath,ModTime))]) ->
+   Err ShellState 
+updateShellState opts ign mcnc sh ((_,sgr,gr,eenv),rts) = do 
+  let cgr0 = M.updateMGrammar (canModules sh) gr
+
+  -- a0 = abstract of old state
+  -- a1 = abstract of compiled grammar
+
+  let a0 = abstract sh
+  a1 <- return $ case mcnc of
+    Just cnc -> err (const Nothing) Just $ M.abstractOfConcrete cgr0 cnc
+    _ -> M.greatestAbstract cgr0
+
+  -- abstr0 = a1 if it exists
+
+  let (abstr0,isNew) = case (a0,a1) of
+        (Just a,  Just b) | a /= b -> (a1, True)
+        (Nothing, Just _)          -> (a1, True)
+        _                          -> (a0, False)
+
+  let concrs0 = maybe [] (M.allConcretes cgr0) abstr0
+
+  let abstrs = nubBy (\ (x,_) (y,_) -> x == y) $ 
+               maybe id (\a -> ((a,concrs0):)) abstr0 $ abstracts sh
+               
+  let needed = nub $ concatMap (requiredCanModules (length abstrs == 1) cgr0) (maybe [] singleton abstr0 ++ concrs0)
+      purge  = nubBy (\x y -> fst x == fst y) . filter (\(m,mo) -> elem m needed && not (isIncompleteCanon (m,mo)))
+      
+  let cgr = M.MGrammar $ purge $ M.modules cgr0
+
+  let oldConcrs = map (snd . fst) (concretes sh)
+      newConcrs = maybe [] (M.allConcretes gr) abstr0
+      toRetain (c,v) = notElem c newConcrs
+  let complete m = case M.lookupModule gr m of
+        Ok mo -> not $ isIncompleteCanon (m,mo)
+        _ -> False
+        
+  let concrs = filter (\i -> complete i && elem i needed) $ nub $ newConcrs ++ oldConcrs
+      concr0 = ifNull Nothing (return . head) concrs
+      notInrts f = notElem f $ map fst rts
+      subcgr = unSubelimCanon cgr
+  cf's0 <- if (not (oElem (iOpt "docf") opts) &&       -- cf only built with -docf
+               (oElem noCF opts || not (hasHOAS cgr))) -- or HOAS, if not -nocf
+            then return $ map snd $ cfs sh
+            else mapM (canon2cf opts ign subcgr) newConcrs 
+  let cf's = zip newConcrs cf's0 ++ filter toRetain (cfs sh)
+
+  let morphs = [(c,mkMorpho subcgr c) | c <- newConcrs] ++ filter toRetain (morphos sh)
+  let probss = [] -----
+
+
+  let fromGFC       = snd . snd . Cnv.convertGFC opts
+      (mcfgs, cfgs) = unzip $ map (curry fromGFC cgr) concrs
+      gfcc          = canon2gfcc opts cgr ---- UTF8
+      fcfgs         = [(c,g) | c@(IC cn) <- concrs, Just g <- [lookFCFG gfcc (CId cn)]]
+      pInfos        = zipWith3 Prs.buildPInfo mcfgs (map snd fcfgs) cfgs
+      
+  let funs = funRulesOf cgr
+  let cats = allCatsOf cgr
+  let csi  = [(c,(co,
+                  [(fun,typ) | (fun,typ) <- funs, compatType tc typ], 
+                  funsOnTypeFs compatType funs tc))
+                                      | (c,co) <- cats, let tc = cat2val co c]
+  let deps = True ---- not $ null $ allDepCats cgr
+  let binds = [] ---- allCatsWithBind cgr 
+  let src = M.updateMGrammar (srcModules sh) sgr
+
+  return $ ShSt {
+    abstract   = abstr0, 
+    concrete   = concr0, 
+    concretes  = zip (zip concrs concrs) (repeat True),
+    canModules = cgr,
+    srcModules = src,
+    cfs        = cf's,
+    abstracts  = maybe [] (\a -> [(a,concrs)]) abstr0,
+    mcfgs      = zip concrs mcfgs,
+    fcfgs      = fcfgs,
+    cfgs       = zip concrs cfgs,
+    pInfos     = zip concrs pInfos,
+    morphos    = morphs,
+    treebanks  = treebanks sh,
+    probss     = zip concrs probss,
+    gloptions  = gloptions sh, --- opts, -- this would be command-line options
+    readFiles  = [ft | ft@(f,(_,_)) <- readFiles sh, notInrts f] ++ rts,
+    absCats    = csi,
+    statistics = [StDepTypes deps,StBoundVars binds],
+    transfers  = transfers sh,
+    evalEnv    = eenv
+    }            
+
+prShellStateInfo :: ShellState -> String
+prShellStateInfo sh = unlines [
+  "main abstract :    " +++ abstractName sh,
+  "main concrete :    " +++ maybe "(none)" P.prt (concrete sh),
+  "actual concretes : " +++ unwords (map (P.prt . fst . fst) (actualConcretes sh)),
+  "all abstracts :    " +++ unwords (map (P.prt . fst) (abstracts sh)),
+  "all concretes :    " +++ unwords (map (P.prt . fst . fst) (concretes sh)),
+  "canonical modules :" +++ unwords (map (P.prt .fst) (M.modules (canModules sh))),
+  "source modules :   " +++ unwords (map (P.prt .fst) (M.modules (srcModules sh))),
+  "global options :   " +++ prOpts (gloptions sh),
+  "transfer modules : " +++ unwords (map (P.prt . fst) (transfers sh)),
+  "treebanks :        " +++ unwords (map (P.prt . fst) (treebanks sh))
+  ]
+
+abstractName :: ShellState -> String
+abstractName sh = maybe "(none)" P.prt (abstract sh)
+
+-- | throw away those abstracts that are not needed --- could be more aggressive
+filterAbstracts :: [Ident] -> CanonGrammar -> CanonGrammar
+filterAbstracts absts cgr = M.MGrammar (nubBy (\x y -> fst x == fst y) [m | m <- ms, needed m]) where
+  ms = M.modules cgr
+  needed (i,_) = elem i needs
+  needs   = [i | (i,M.ModMod m) <- ms, not (M.isModAbs m) || any (dep i) absts]
+  dep i a = elem i (ext mse a)
+  mse = [(i,me) | (i,M.ModMod m) <- ms, M.isModAbs m, me <- [M.extends m]]
+  ext es a = case lookup a es of
+    Just e -> a : concatMap (ext es) e  ---- FIX multiple exts
+    _ -> []
+
+purgeShellState :: ShellState -> ShellState
+purgeShellState sh = ShSt {
+  abstract   = abstr,
+  concrete   = concrete sh,
+  concretes  = concrs,
+  canModules = M.MGrammar $ filter complete $ purge $ M.modules $ canModules sh,
+  srcModules = M.emptyMGrammar,
+  cfs        = cfs sh,
+  abstracts  = maybe [] (\a -> [(a,map (snd . fst) concrs)]) abstr,
+  mcfgs      = mcfgs sh,
+  fcfgs      = fcfgs sh,
+  cfgs       = cfgs sh,
+  pInfos     = pInfos sh,
+  morphos    = morphos sh,
+  treebanks  = treebanks sh,
+  probss     = probss sh,
+  gloptions  = gloptions sh,
+  readFiles  = [],
+  absCats    = absCats sh,
+  statistics = statistics sh,
+  transfers  = transfers sh,
+  evalEnv    = emptyEEnv
+  }
+ where
+   abstr = abstract sh
+   concrs = [((a,i),b) | ((a,i),b) <- concretes sh, elem i needed]
+   isSingle = length (abstracts sh) == 1
+   needed = nub $ concatMap (requiredCanModules isSingle (canModules sh)) acncs
+   purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst)
+   acncs = maybe [] singleton abstr ++ map (snd . fst) (actualConcretes sh)
+   complete = not . isIncompleteCanon
+
+changeMain :: Maybe Ident -> ShellState -> Err ShellState
+changeMain Nothing (ShSt _ _ cs ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs ee) = 
+  return (ShSt Nothing Nothing [] ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs ee)
+changeMain 
+  (Just c) st@(ShSt _ _ cs ms ss cfs old_pis mcfgs fcfgs cfgs pinfos mos tbs pbs os rs acs s trs ee) = 
+   case lookup c (M.modules ms) of 
+    Just _ -> do
+      a   <- M.abstractOfConcrete ms c
+      let cas = M.allConcretes ms a
+      let cs' = [((c,c),True) | c <- cas]
+      return (ShSt (Just a) (Just c) cs' ms ss cfs old_pis mcfgs fcfgs cfgs
+        pinfos mos tbs pbs os rs acs s trs ee) 
+    _ -> P.prtBad "The state has no concrete syntax named" c
+
+-- | form just one state grammar, if unique, from a canonical grammar
+grammar2stateGrammar :: Options -> CanonGrammar -> Err StateGrammar 
+grammar2stateGrammar opts gr = do 
+  st    <- grammar2shellState opts (gr,M.emptyMGrammar)
+  concr <- maybeErr "no concrete syntax" $ concrete st 
+  return $ stateGrammarOfLang st concr
+
+resourceOfShellState :: ShellState -> Maybe Ident
+resourceOfShellState = M.greatestResource . srcModules
+
+qualifTop :: StateGrammar -> G.QIdent -> G.QIdent
+qualifTop gr (_,c) = (absId gr,c)
+
+stateGrammarOfLang :: ShellState -> Language -> StateGrammar
+stateGrammarOfLang = stateGrammarOfLangOpt True
+
+stateGrammarOfLangOpt :: Bool -> ShellState -> Language -> StateGrammar
+stateGrammarOfLangOpt purg st0 l = StGr {
+  absId    = err (const (identC "Abs")) id  $ M.abstractOfConcrete allCan l, ---
+  cncId    = l,
+  grammar  = allCan,
+  cf       = maybe emptyCF id (lookup l (cfs st)),
+  mcfg     = maybe [] id $ lookup l $ mcfgs st,
+  fcfg     = maybe ([],Map.empty) id $ lookup l $ fcfgs st,
+  cfg      = maybe [] id $ lookup l $ cfgs st,
+  pInfo    = maybe (Prs.buildPInfo [] ([],Map.empty) []) id $ lookup l $ pInfos st,
+  morpho   = maybe emptyMorpho id (lookup l (morphos st)),
+  probs    = maybe emptyProbs id (lookup l (probss st)),
+  loptions = errVal noOptions $ lookupOptionsCan allCan
+  }
+ where
+   st = (if purg then purgeShellState else id) $ errVal st0 $ changeMain (Just l) st0
+   allCan = canModules st
+
+grammarOfLang :: ShellState -> Language -> CanonGrammar
+cfOfLang      :: ShellState -> Language -> CF
+morphoOfLang  :: ShellState -> Language -> Morpho
+probsOfLang   :: ShellState -> Language -> Probs
+optionsOfLang :: ShellState -> Language -> Options
+
+grammarOfLang st = stateGrammarST . stateGrammarOfLang st
+cfOfLang st      = stateCF        . stateGrammarOfLang st
+morphoOfLang st  = stateMorpho    . stateGrammarOfLang st
+probsOfLang st   = stateProbs     . stateGrammarOfLang st
+optionsOfLang st = stateOptions   . stateGrammarOfLang st
+
+removeLang :: Language -> ShellState -> ShellState
+removeLang lang st = purgeShellState $ st{concretes = concs1} where
+  concs1 = filter ((/=lang) . snd . fst) $ concretes st
+
+-- | the last introduced grammar, stored in options, is the default for operations
+firstStateGrammar :: ShellState -> StateGrammar
+firstStateGrammar st = errVal (stateAbstractGrammar st) $ do
+  concr <- maybeErr "no concrete syntax" $ concrete st 
+  return $ stateGrammarOfLang st concr
+
+mkStateGrammar :: ShellState -> Language -> StateGrammar
+mkStateGrammar = stateGrammarOfLang
+
+stateAbstractGrammar :: ShellState -> StateGrammar
+stateAbstractGrammar st = StGr {
+  absId    = maybe (identC "Abs") id (abstract st), ---
+  cncId    = identC "#Cnc", ---
+  grammar  = canModules st, ---- only abstarct ones
+  cf       = emptyCF,
+  mcfg     = [],
+  fcfg     = ([],Map.empty),
+  cfg      = [],
+  pInfo    = Prs.buildPInfo [] ([],Map.empty) [],
+  morpho   = emptyMorpho,
+  probs    = emptyProbs,
+  loptions = gloptions st ----
+  }
+
+
+-- analysing shell state into parts
+
+globalOptions                   :: ShellState -> Options
+allLanguages                    :: ShellState -> [Language]
+allTransfers                    :: ShellState -> [Ident]
+allCategories                   :: ShellState -> [G.Cat]
+allStateGrammars                :: ShellState -> [StateGrammar]
+allStateGrammarsWithNames       :: ShellState -> [(Language, StateGrammar)]
+allGrammarFileNames             :: ShellState -> [String]
+allActiveStateGrammarsWithNames :: ShellState -> [(Language, StateGrammar)]
+allActiveGrammars               :: ShellState -> [StateGrammar]
+
+globalOptions = gloptions
+--allLanguages  = map (fst . fst) . concretes
+allLanguages  = map (snd . fst) . actualConcretes
+allTransfers  = map fst . transfers
+allCategories = map fst . allCatsOf . canModules
+
+allStateGrammars = map snd . allStateGrammarsWithNames
+
+allStateGrammarsWithNames st = 
+  [(c, mkStateGrammar st c) | ((c,_),_) <- actualConcretes st]
+
+allGrammarFileNames st = [prLanguage c ++ ".gf" | ((c,_),_) <- actualConcretes st]
+
+allActiveStateGrammarsWithNames st =   
+  [(c, mkStateGrammar st c) | ((c,_),True) <- concretes st] --- actual
+
+allActiveGrammars = map snd . allActiveStateGrammarsWithNames
+
+pathOfModule :: ShellState -> Ident -> FilePath
+pathOfModule sh m = maybe "module not found" fst $ lookup (P.prt m) $ readFiles sh
+
+-- command-line option -lang=foo overrides the actual grammar in state
+grammarOfOptState :: Options -> ShellState -> StateGrammar
+grammarOfOptState opts st = 
+  maybe (firstStateGrammar st) (stateGrammarOfLang st . language) $ 
+                                               getOptVal opts useLanguage
+
+languageOfOptState :: Options -> ShellState -> Maybe Language
+languageOfOptState opts st = 
+  maybe (concrete st) (return . language) $ getOptVal opts useLanguage
+
+-- | command-line option -cat=foo overrides the possible start cat of a grammar
+firstCatOpts :: Options -> StateGrammar -> CFCat
+firstCatOpts opts sgr = 
+  maybe (stateFirstCat sgr) (string2CFCat (P.prt (absId sgr))) $ 
+    getOptVal opts firstCat
+
+-- | the first cat for random generation
+firstAbsCat :: Options -> StateGrammar -> G.QIdent
+firstAbsCat opts = cfCat2Cat . firstCatOpts opts
+
+-- | Gets the start category for the grammar from the options.
+--   If the startcat is not set in the options, we look
+--   for a flag in the grammar. If there is no flag in the
+--   grammar, S is returned.
+startCatStateOpts :: Options -> StateGrammar -> CFCat
+startCatStateOpts opts sgr = 
+    string2CFCat a (fromMaybe "S" (optsStartCat `mplus` grStartCat))
+  where optsStartCat = getOptVal opts gStartCat
+        grStartCat = getOptVal (stateOptions sgr) gStartCat
+        a = P.prt (absId sgr)
+
+-- | a grammar can have start category as option startcat=foo ; default is S 
+stateFirstCat :: StateGrammar -> CFCat
+stateFirstCat = startCatStateOpts noOptions
+
+stateIsWord :: StateGrammar -> String -> Bool
+stateIsWord sg = isKnownWord (stateMorpho sg)
+
+addProbs :: (Ident,Probs) -> ShellState -> Err ShellState
+addProbs ip@(lang,probs) sh = do
+  let gr = grammarOfLang sh lang
+  probs' <- checkGrammarProbs gr probs
+  let pbs' = (lang,probs') : filter ((/= lang) . fst) (probss sh)
+  return $ sh{probss = pbs'}
+
+addTransfer :: (Ident,T.Env) -> ShellState -> ShellState
+addTransfer it@(i,_) sh = 
+  sh {transfers = it : filter ((/= i) . fst) (transfers sh)}
+
+addTreebanks :: [(Ident,Treebank)] -> ShellState -> ShellState
+addTreebanks its sh = sh {treebanks = its ++ treebanks sh}
+
+findTreebank :: ShellState -> Ident -> Err Treebank
+findTreebank sh i = maybeErr "no treebank found" $ lookup i $ treebanks sh
+
+-- modify state
+
+type ShellStateOper = ShellState -> ShellState
+type ShellStateOperErr = ShellState -> Err ShellState
+
+reinitShellState :: ShellStateOper
+reinitShellState = const emptyShellState
+
+languageOn, languageOff :: Language -> ShellStateOper
+languageOn  = languageOnOff True
+languageOff = languageOnOff False
+
+languageOnOff :: Bool -> Language -> ShellStateOper
+---                                         __________ this is OBSOLETE
+languageOnOff b lang sh = sh {concretes = cs'} where
+  cs' = [if lang==l then (lc,b) else i | i@(lc@(l,c),_) <- concretes sh]
+
+changeOptions :: (Options -> Options) -> ShellStateOper
+---                                      __________ this is OBSOLETE
+changeOptions f sh = sh {gloptions = f (gloptions sh)}
+
+addGlobalOptions :: Options -> ShellStateOper
+addGlobalOptions = changeOptions . addOptions
+
+removeGlobalOptions :: Options -> ShellStateOper
+removeGlobalOptions = changeOptions . removeOptions
+
diff --git a/src-3.0/GF/Compile/Update.hs b/src-3.0/GF/Compile/Update.hs
new file mode 100644
index 000000000..82d7a609e
--- /dev/null
+++ b/src-3.0/GF/Compile/Update.hs
@@ -0,0 +1,135 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Update
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/30 18:39:44 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.8 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Compile.Update (updateRes, buildAnyTree, combineAnyInfos, unifyAnyInfo,
+	       -- * these auxiliaries should be somewhere else 
+	       -- since they don't use the info types
+	       groupInfos, sortInfos, combineInfos, unifyInfos,
+	       tryInsert, unifAbsDefs, unifConstrs
+	      ) where
+
+import GF.Infra.Ident
+import GF.Grammar.Grammar
+import GF.Grammar.PrGrammar
+import GF.Infra.Modules
+
+import GF.Data.Operations
+
+import Data.List
+import Control.Monad
+
+-- | update a resource module by adding a new or changing an old definition
+updateRes :: SourceGrammar -> Ident -> Ident -> Info -> SourceGrammar
+updateRes gr@(MGrammar ms) m i info = MGrammar $ map upd ms where
+  upd (n,mod) 
+    | n /= m = (n,mod)
+    | n == m = case mod of
+       ModMod r -> (m,ModMod $ updateModule r i info)
+       _ -> (n,mod) --- no error msg
+
+-- | combine a list of definitions into a balanced binary search tree
+buildAnyTree :: [(Ident,Info)] -> Err (BinTree Ident Info)
+buildAnyTree ias = do
+  ias' <- combineAnyInfos ias
+  return $ buildTree ias'
+
+
+-- | unifying information for abstract, resource, and concrete
+combineAnyInfos :: [(Ident,Info)] -> Err [(Ident,Info)]
+combineAnyInfos = combineInfos unifyAnyInfo
+
+unifyAnyInfo :: Ident -> Info -> Info -> Err Info
+unifyAnyInfo c i j = errIn ("combining information for" +++ prt c) $ case (i,j) of
+  (AbsCat mc1 mf1, AbsCat mc2 mf2) -> 
+    liftM2 AbsCat (unifPerhaps mc1 mc2) (unifConstrs mf1 mf2) -- adding constrs
+  (AbsFun mt1 md1, AbsFun mt2 md2) -> 
+    liftM2 AbsFun (unifPerhaps mt1 mt2) (unifAbsDefs md1 md2) -- adding defs
+
+  (ResParam mt1, ResParam mt2) -> liftM ResParam $ unifPerhaps mt1 mt2
+  (ResOper mt1 m1, ResOper mt2 m2) -> 
+    liftM2 ResOper (unifPerhaps mt1 mt2) (unifPerhaps m1 m2)
+
+  (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> 
+    liftM3 CncCat (unifPerhaps mc1 mc2) (unifPerhaps mf1 mf2) (unifPerhaps mp1 mp2)
+  (CncFun m mt1 md1, CncFun _ mt2 md2) -> 
+    liftM2 (CncFun m) (unifPerhaps mt1 mt2) (unifPerhaps md1 md2) ---- adding defs
+-- for bw compatibility with unspecified printnames in old GF
+  (CncFun Nothing Nope (Yes pr),_) -> 
+    unifyAnyInfo c (CncCat Nope Nope (Yes pr)) j 
+  (_,CncFun Nothing Nope (Yes pr)) -> 
+    unifyAnyInfo c i (CncCat Nope Nope (Yes pr)) 
+
+  _ -> Bad $ "cannot unify informations in" ++++ show i ++++ "and" ++++ show j
+
+--- these auxiliaries should be somewhere else since they don't use the info types
+
+groupInfos :: Eq a => [(a,b)] -> [[(a,b)]]
+groupInfos = groupBy (\i j -> fst i == fst j)
+
+sortInfos :: Ord a => [(a,b)] -> [(a,b)]
+sortInfos = sortBy (\i j -> compare (fst i) (fst j))
+
+combineInfos :: Ord a => (a -> b -> b -> Err b) -> [(a,b)] -> Err [(a,b)]
+combineInfos f ris = do
+  let riss = groupInfos $ sortInfos ris
+  mapM (unifyInfos f) riss
+
+unifyInfos :: (a -> b -> b -> Err b) -> [(a,b)] -> Err (a,b)
+unifyInfos _ [] = Bad "empty info list"
+unifyInfos unif ris = do
+  let c = fst $ head ris
+  let infos = map snd ris
+  let ([i],is) = splitAt 1 infos 
+  info <- foldM (unif c) i is
+  return (c,info)
+
+
+tryInsert :: Ord a => (b -> b -> Err b) -> (b -> b) ->
+             BinTree a b -> (a,b) -> Err (BinTree a b)
+tryInsert unif indir tree z@(x, info) = case justLookupTree x tree of
+  Ok info0 -> do
+    info1 <- unif info info0
+    return $ updateTree (x,info1) tree 
+  _ -> return $ updateTree (x,indir info) tree
+
+{- ----
+case tree of
+ NT -> return $ BT (x, indir info) NT NT
+ BT c@(a,info0) left right 
+   | x < a  -> do
+       left' <- tryInsert unif indir left z    
+       return $ BT c left' right 
+   | x > a  -> do
+       right' <- tryInsert unif indir right z    
+       return $ BT c left right' 
+   | x == a -> do
+       info' <- unif info info0
+       return $ BT (x,info') left right
+-}
+
+--- addToMaybeList m c = maybe (return c) (\old -> return (c ++ old)) m
+
+unifAbsDefs :: Perh Term -> Perh Term -> Err (Perh Term)
+unifAbsDefs p1 p2 = case (p1,p2) of
+  (Nope, _)  -> return p2
+  (_, Nope)  -> return p1
+  (Yes (Eqs bs), Yes (Eqs ds)) -> return $ yes $ Eqs $ bs ++ ds --- order!
+  _ -> Bad "update conflict for definitions"
+
+unifConstrs :: Perh [Term] -> Perh [Term] -> Err (Perh [Term])
+unifConstrs p1 p2 = case (p1,p2) of
+  (Nope, _)  -> return p2
+  (_, Nope)  -> return p1
+  (Yes bs, Yes ds) -> return $ yes $ bs ++ ds
+  _ -> Bad "update conflict for constructors"
diff --git a/src-3.0/GF/Compile/Wordlist.hs b/src-3.0/GF/Compile/Wordlist.hs
new file mode 100644
index 000000000..3fbc066bd
--- /dev/null
+++ b/src-3.0/GF/Compile/Wordlist.hs
@@ -0,0 +1,108 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Wordlist
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 
+-- > CVS $Author: 
+-- > CVS $Revision: 
+--
+-- Compile a gfwl file (multilingual word list) to an abstract + concretes
+-----------------------------------------------------------------------------
+
+module GF.Compile.Wordlist (mkWordlist) where
+
+import GF.Data.Operations
+import GF.Infra.UseIO
+import Data.List
+import Data.Char
+import System.FilePath
+
+-- read File.gfwl, write File.gf (abstract) and a set of concretes
+-- return the names of the concretes
+
+mkWordlist :: FilePath -> IO [FilePath]
+mkWordlist file = do
+  s <- readFileIf file
+  let abs = dropExtension file
+  let (cnchs,wlist) = pWordlist abs $ filter notComment $ lines s
+  let (gr,grs) = mkGrammars abs cnchs wlist
+  let cncfs = [cnc ++ ".gf" | (cnc,_) <- cnchs]
+  mapM_ (uncurry writeFile) $ (abs ++ ".gf",gr) : zip cncfs grs
+  putStrLn $ "wrote " ++ unwords ((abs ++ ".gf") : cncfs)
+  return cncfs
+
+{-
+-- syntax of files, e.g.
+
+  # Svenska - Franska - Finska  -- names of concretes
+ 
+  berg  - montagne - vuori      -- word entry
+
+-- this creates:
+
+  cat S ; 
+  fun berg_S : S ; 
+  lin berg_S = {s = ["berg"]} ;
+  lin berg_S = {s = ["montagne"]} ;
+  lin berg_S = {s = ["vuori"]} ;
+
+-- support for different categories to be elaborated. The syntax it
+
+  Verb . klättra - grimper / escalader - kiivetä / kiipeillä
+
+-- notice that a word can have several alternative (separator /)
+-- and that an alternative can consist of several words
+-}
+
+type CncHeader = (String,String) -- module name, module header
+
+type Wordlist = [(String, [[String]])] -- cat, variants for each cnc
+
+
+pWordlist :: String -> [String] -> ([CncHeader],Wordlist)
+pWordlist abs ls = (headers,rules) where
+  (hs,rs) = span ((=="#") . take 1) ls
+  headers = map mkHeader $ chunks "-" $ filter (/="#") $ words $ concat hs
+  rules   = map (mkRule   . words) rs
+
+  mkHeader ws = case ws of
+    w:ws2 -> (w, unwords ("concrete":w:"of":abs:"=":ws2))
+  mkRule ws = case ws of
+    cat:".":vs -> (cat, mkWords vs)
+    _          -> ("S", mkWords ws)
+  mkWords = map (map unwords . chunks "/") . chunks "-"
+
+
+mkGrammars :: String -> [CncHeader] -> Wordlist -> (String,[String])
+mkGrammars ab hs wl = (abs,cncs) where
+  abs = unlines $ map unwords $
+    ["abstract",ab,"=","{"]:
+    cats ++
+    funs ++
+    [["}"]]
+
+  cncs = [unlines $ (h ++ " {") : map lin rs ++ ["}"] | ((_,h),rs) <- zip hs rss]
+
+  cats = [["cat",c,";"] | c <- nub $ map fst wl]
+  funs = [["fun", f , ":", c,";"] | (f,c,_) <- wlf]
+
+  wlf = [(ident f c, c, ws) | (c,ws@(f:_)) <- wl]
+
+  rss = [[(f, wss !! i) | (f,_,wss) <- wlf] | i <- [0..length hs - 1]]
+
+  lin (f,ss) = unwords ["lin", f, "=", "{s", "=", val ss, "}", ";"]
+
+  val ss = case ss of
+    [w] -> quote w
+    _   -> "variants {" ++ unwords (intersperse ";" (map quote ss)) ++ "}"
+
+  quote w = "[" ++ prQuotedString w ++ "]" 
+
+  ident f c = concat $ intersperse "_" $ words (head f) ++ [c]
+
+
+notComment s = not (all isSpace s) && take 2 s /= "--"
+