changed names of resource-1.3; added a note on homepage on release

15 files changed, 2822 insertions, 0 deletions

diff --git a/src/GF/Grammar/API.hs b/src/GF/Grammar/API.hs
new file mode 100644
index 000000000..182b5e94e
--- /dev/null
+++ b/src/GF/Grammar/API.hs
@@ -0,0 +1,75 @@
+module GF.Grammar.API (
+  Grammar,
+  emptyGrammar,
+  pTerm,
+  prTerm,
+  checkTerm,
+  computeTerm,
+  showTerm,
+  TermPrintStyle(..),
+  pTermPrintStyle
+  ) where
+
+import GF.Source.ParGF
+import GF.Source.SourceToGrammar (transExp)
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Infra.Modules (greatestResource)
+import GF.Compile.GetGrammar
+import GF.Grammar.Macros
+import GF.Grammar.PrGrammar
+
+import GF.Compile.Rename (renameSourceTerm)
+import GF.Compile.CheckGrammar (justCheckLTerm)
+import GF.Compile.Compute (computeConcrete)
+
+import GF.Data.Operations
+import GF.Infra.Option
+
+import qualified Data.ByteString.Char8 as BS
+
+type Grammar = SourceGrammar
+
+emptyGrammar :: Grammar
+emptyGrammar = emptySourceGrammar
+
+pTerm :: String -> Err Term
+pTerm s = do
+  e <- pExp $ myLexer (BS.pack s)
+  transExp e
+
+prTerm :: Term -> String
+prTerm = prt
+
+checkTerm :: Grammar -> Term -> Err Term
+checkTerm gr t = do
+  mo <- maybe (Bad "no source grammar in scope") return $ greatestResource gr
+  checkTermAny gr mo t
+
+checkTermAny :: Grammar -> Ident -> Term -> Err Term
+checkTermAny gr m t = do
+  t1 <- renameSourceTerm gr m t
+  justCheckLTerm gr t1
+
+computeTerm :: Grammar -> Term -> Err Term
+computeTerm = computeConcrete
+
+showTerm :: TermPrintStyle -> Term -> String
+showTerm style t = 
+    case style of
+      TermPrintTable   -> unlines [p +++ s | (p,s) <- prTermTabular t]
+      TermPrintAll     -> unlines [      s | (p,s) <- prTermTabular t]
+      TermPrintUnqual  -> prt_ t
+      TermPrintDefault -> prt t
+
+
+data TermPrintStyle = TermPrintTable | TermPrintAll | TermPrintUnqual | TermPrintDefault
+  deriving (Show,Eq)
+
+pTermPrintStyle s = case s of
+  "table"  -> TermPrintTable
+  "all"    -> TermPrintAll
+  "unqual" -> TermPrintUnqual
+  _        -> TermPrintDefault
+
+
diff --git a/src/GF/Grammar/Abstract.hs b/src/GF/Grammar/Abstract.hs
new file mode 100644
index 000000000..c03783a52
--- /dev/null
+++ b/src/GF/Grammar/Abstract.hs
@@ -0,0 +1,38 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Abstract
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:22:18 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.4 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Grammar.Abstract (
+
+module GF.Grammar.Grammar,
+module GF.Grammar.Values,
+module GF.Grammar.Macros,
+module GF.Infra.Ident,
+module GF.Grammar.MMacros,
+module GF.Grammar.PrGrammar,
+
+Grammar
+
+ ) where
+
+import GF.Grammar.Grammar
+import GF.Grammar.Values
+import GF.Grammar.Macros
+import GF.Infra.Ident
+import GF.Grammar.MMacros
+import GF.Grammar.PrGrammar
+
+type Grammar = SourceGrammar ---
+
+
+
diff --git a/src/GF/Grammar/AppPredefined.hs b/src/GF/Grammar/AppPredefined.hs
new file mode 100644
index 000000000..cfb6baf1d
--- /dev/null
+++ b/src/GF/Grammar/AppPredefined.hs
@@ -0,0 +1,158 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : AppPredefined
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/10/06 14:21:34 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.13 $
+--
+-- Predefined function type signatures and definitions.
+-----------------------------------------------------------------------------
+
+module GF.Grammar.AppPredefined (isInPredefined, typPredefined, appPredefined
+		     ) where
+
+import GF.Infra.Ident
+import GF.Data.Operations
+import GF.Grammar.Predef
+import GF.Grammar.Grammar
+import GF.Grammar.Macros
+import GF.Grammar.PrGrammar (prt,prt_,prtBad)
+import qualified Data.ByteString.Char8 as BS
+
+-- predefined function type signatures and definitions. AR 12/3/2003.
+
+isInPredefined :: Ident -> Bool
+isInPredefined = err (const True) (const False) . typPredefined
+
+typPredefined :: Ident -> Err Type
+typPredefined f
+  | f == cInt       = return typePType
+  | f == cFloat     = return typePType
+  | f == cErrorType = return typeType
+  | f == cInts      = return $ mkFunType [typeInt] typePType
+  | f == cPBool     = return typePType
+  | f == cError     = return $ mkFunType [typeStr] typeError  -- non-can. of empty set
+  | f == cPFalse    = return $ typePBool
+  | f == cPTrue     = return $ typePBool
+  | f == cDp        = return $ mkFunType [typeInt,typeTok] typeTok
+  | f == cDrop      = return $ mkFunType [typeInt,typeTok] typeTok
+  | f == cEqInt     = return $ mkFunType [typeInt,typeInt] typePBool
+  | f == cLessInt   = return $ mkFunType [typeInt,typeInt] typePBool
+  | f == cEqStr     = return $ mkFunType [typeTok,typeTok] typePBool
+  | f == cLength    = return $ mkFunType [typeTok] typeInt
+  | f == cOccur     = return $ mkFunType [typeTok,typeTok] typePBool
+  | f == cOccurs    = return $ mkFunType [typeTok,typeTok] typePBool
+  | f == cPlus      = return $ mkFunType [typeInt,typeInt] (typeInt)
+----  "read"   -> (P : Type) -> Tok -> P
+  | f == cShow      = return $ mkProd -- (P : PType) -> P -> Tok
+    ([(varP,typePType),(identW,Vr varP)],typeStr,[]) 
+  | f == cToStr     = return $ mkProd -- (L : Type)  -> L -> Str
+    ([(varL,typeType),(identW,Vr varL)],typeStr,[]) 
+  | f == cMapStr    = return $ mkProd -- (L : Type)  -> (Str -> Str) -> L -> L
+    ([(varL,typeType),(identW,mkFunType [typeStr] typeStr),(identW,Vr varL)],Vr varL,[])
+  | f == cTake      = return $ mkFunType [typeInt,typeTok] typeTok
+  | f == cTk        = return $ mkFunType [typeInt,typeTok] typeTok
+  | otherwise       = prtBad "unknown in Predef:" f
+
+varL :: Ident
+varL = identC (BS.pack "L")
+
+varP :: Ident
+varP = identC (BS.pack "P")
+
+appPredefined :: Term -> Err (Term,Bool)
+appPredefined t = case t of
+  App f x0 -> do
+   (x,_) <- appPredefined x0
+   case f of
+    -- one-place functions
+    Q mod f | mod == cPredef ->
+      case x of
+        (K s) | f == cLength -> retb $ EInt $ toInteger $ length s
+        _                    -> retb t
+
+    -- two-place functions
+    App (Q mod f) z0 | mod == cPredef -> do
+     (z,_) <- appPredefined z0
+     case (norm z, norm x) of
+      (EInt i, K s)    | f == cDrop    -> retb $ K (drop (fi i) s)
+      (EInt i, K s)    | f == cTake    -> retb $ K (take (fi i) s)
+      (EInt i, K s)    | f == cTk      -> retb $ K (take (max 0 (length s - fi i)) s)
+      (EInt i, K s)    | f == cDp      -> retb $ K (drop (max 0 (length s - fi i)) s)
+      (K s,    K t)    | f == cEqStr   -> retb $ if s == t then predefTrue else predefFalse
+      (K s,    K t)    | f == cOccur   -> retb $ if substring s t then predefTrue else predefFalse
+      (K s,    K t)    | f == cOccurs  -> retb $ if any (flip elem t) s then predefTrue else predefFalse
+      (EInt i, EInt j) | f == cEqInt   -> retb $ if i==j then predefTrue else predefFalse
+      (EInt i, EInt j) | f == cLessInt -> retb $ if i<j  then predefTrue else predefFalse
+      (EInt i, EInt j) | f == cPlus    -> retb $ EInt $ i+j
+      (_,      t)      | f == cShow    -> retb $ foldr C Empty $ map K $ words $ prt t
+      (_,      K s)    | f == cRead    -> retb $ Cn (identC (BS.pack s)) --- because of K, only works for atomic tags
+      (_,      t)      | f == cToStr   -> trm2str t >>= retb
+      _ -> retb t ---- prtBad "cannot compute predefined" t
+
+    -- three-place functions
+    App (App (Q mod f) z0) y0 | mod == cPredef -> do
+     (y,_) <- appPredefined y0
+     (z,_) <- appPredefined z0
+     case (z, y, x) of
+      (ty,op,t) | f == cMapStr -> retf $ mapStr ty op t
+      _ -> retb t ---- prtBad "cannot compute predefined" t
+
+    _ -> retb t ---- prtBad "cannot compute predefined" t
+  _ -> retb t
+                  ---- should really check the absence of arg variables
+ where
+   retb t = return (retc t,True)  -- no further computing needed
+   retf t = return (retc t,False) -- must be computed further
+   retc t = case t of
+     K [] -> t
+     K s  -> foldr1 C (map K (words s))
+     _    -> t
+   norm t = case t of
+     Empty -> K []
+     C u v -> case (norm u,norm v) of
+       (K x,K y) -> K (x +++ y)
+       _ -> t
+     _ -> t
+   fi = fromInteger
+
+-- read makes variables into constants
+
+predefTrue = Q cPredef cPTrue
+predefFalse = Q cPredef cPFalse
+
+substring :: String -> String -> Bool
+substring s t = case (s,t) of
+  (c:cs, d:ds) -> (c == d && substring cs ds) || substring s ds
+  ([],_) -> True
+  _ -> False
+
+trm2str :: Term -> Err Term
+trm2str t = case t of
+  R ((_,(_,s)):_) -> trm2str s
+  T _ ((_,s):_)   -> trm2str s
+  TSh _ ((_,s):_) -> trm2str s
+  V _ (s:_)       -> trm2str s
+  C _ _         -> return $ t
+  K _           -> return $ t
+  S c _         -> trm2str c
+  Empty         -> return $ t
+  _ -> prtBad "cannot get Str from term" t
+
+-- simultaneous recursion on type and term: type arg is essential!
+-- But simplify the task by assuming records are type-annotated
+-- (this has been done in type checking)
+mapStr :: Type -> Term -> Term -> Term
+mapStr ty f t = case (ty,t) of
+  _ | elem ty [typeStr,typeTok] -> App f t
+  (_,        R ts)    -> R [(l,mapField v)   | (l,v) <- ts]
+  (Table a b,T ti cs) -> T ti [(p,mapStr b f v) | (p,v) <- cs]
+  _    -> t 
+ where
+   mapField (mty,te) = case mty of
+     Just ty -> (mty,mapStr ty f te)
+     _ -> (mty,te)
diff --git a/src/GF/Grammar/Grammar.hs b/src/GF/Grammar/Grammar.hs
new file mode 100644
index 000000000..4210358f1
--- /dev/null
+++ b/src/GF/Grammar/Grammar.hs
@@ -0,0 +1,264 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Grammar
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:22:20 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.8 $
+--
+-- GF source abstract syntax used internally in compilation.
+--
+-- AR 23\/1\/2000 -- 30\/5\/2001 -- 4\/5\/2003
+-----------------------------------------------------------------------------
+
+module GF.Grammar.Grammar (SourceGrammar,
+                emptySourceGrammar,                
+		SourceModInfo,
+		SourceModule,
+		SourceAbs,
+		SourceRes,
+		SourceCnc,
+		Info(..),
+                PValues,
+		Perh,
+		MPr,
+		Type,
+		Cat,
+		Fun,
+		QIdent,
+		Term(..),
+		Patt(..),
+		TInfo(..),
+		Label(..),
+		MetaSymb(..),
+		Decl,
+		Context,
+		Equation,
+		Labelling,
+		Assign,
+		Case,
+		Cases,
+		LocalDef,
+		Param,
+		Altern,
+		Substitution,
+		Branch(..),
+		Con,
+		Trm,
+		wildPatt,
+		varLabel, tupleLabel, linLabel, theLinLabel,
+		ident2label, label2ident
+	       ) where
+
+import GF.Data.Str
+import GF.Infra.Ident
+import GF.Infra.Option ---
+import GF.Infra.Modules
+
+import GF.Data.Operations
+
+import qualified Data.ByteString.Char8 as BS
+
+-- | grammar as presented to the compiler
+type SourceGrammar = MGrammar Ident Info
+
+emptySourceGrammar = MGrammar []
+
+type SourceModInfo = ModInfo Ident Info
+
+type SourceModule = (Ident, SourceModInfo)
+
+type SourceAbs = Module Ident Info
+type SourceRes = Module Ident Info
+type SourceCnc = Module Ident Info
+
+-- this is created in CheckGrammar, and so are Val and PVal
+type PValues = [Term]
+
+-- | the constructors are judgements in 
+--
+--   - abstract syntax (/ABS/)
+-- 
+--   - resource (/RES/)
+--
+--   - concrete syntax (/CNC/)
+--
+-- and indirection to module (/INDIR/)
+data Info =                  
+-- judgements in abstract syntax
+   AbsCat   (Perh Context) (Perh [Term])   -- ^ (/ABS/) constructors; must be 'Id' or 'QId'
+ | AbsFun   (Perh Type) (Perh Term)        -- ^ (/ABS/) 'Yes f' = canonical
+ | AbsTrans Term                           -- ^ (/ABS/)
+
+-- judgements in resource
+ | ResParam (Perh ([Param],Maybe PValues)) -- ^ (/RES/)
+ | ResValue (Perh (Type,Maybe Int))        -- ^ (/RES/) to mark parameter constructors for lookup
+ | ResOper  (Perh Type) (Perh Term)        -- ^ (/RES/)
+
+ | ResOverload [Ident] [(Type,Term)]       -- ^ (/RES/) idents: modules inherited
+
+-- judgements in concrete syntax
+ | CncCat  (Perh Type) (Perh Term) MPr     -- ^ (/CNC/) lindef ini'zed, 
+ | CncFun  (Maybe (Ident,(Context,Type))) (Perh Term) MPr  -- (/CNC/) type info added at 'TC'
+
+-- indirection to module Ident
+ | AnyInd Bool Ident                       -- ^ (/INDIR/) the 'Bool' says if canonical
+  deriving (Read, Show)
+
+-- | to express indirection to other module
+type Perh a = Perhaps a Ident
+
+-- | printname
+type MPr = Perhaps Term Ident
+
+type Type = Term
+type Cat  = QIdent
+type Fun  = QIdent
+
+type QIdent = (Ident,Ident)
+
+data Term =
+   Vr Ident             -- ^ variable
+ | Cn Ident             -- ^ constant
+ | Con Ident            -- ^ constructor
+ | EData                -- ^ to mark in definition that a fun is a constructor
+ | Sort Ident           -- ^ basic type
+ | EInt Integer         -- ^ integer literal
+ | EFloat Double        -- ^ floating point literal
+ | K String             -- ^ string literal or token: @\"foo\"@
+ | Empty                -- ^ the empty string @[]@
+
+ | App Term Term        -- ^ application: @f a@
+ | Abs Ident Term       -- ^ abstraction: @\x -> b@
+ | Meta MetaSymb        -- ^ metavariable: @?i@ (only parsable: ? = ?0)
+ | Prod Ident Term Term -- ^ function type: @(x : A) -> B@
+ | Eqs [Equation]       -- ^ abstraction by cases: @fn {x y -> b ; z u -> c}@
+                        -- only used in internal representation
+ | Typed Term Term      -- ^ type-annotated term
+--
+-- /below this, the constructors are only for concrete syntax/
+ | Example Term String  -- ^ example-based term: @in M.C "foo"
+ | RecType [Labelling]  -- ^ record type: @{ p : A ; ...}@
+ | R [Assign]           -- ^ record:      @{ p = a ; ...}@
+ | P Term Label         -- ^ projection:  @r.p@
+ | PI Term Label Int    -- ^ index-annotated projection
+ | ExtR Term Term       -- ^ extension:   @R ** {x : A}@ (both types and terms)
+ 
+ | Table Term Term      -- ^ table type:  @P => A@
+ | T TInfo [Case]       -- ^ table:       @table {p => c ; ...}@
+ | TSh TInfo [Cases]    -- ^ table with disjunctive patters (only back end opt)
+ | V Type [Term]        -- ^ table given as course of values: @table T [c1 ; ... ; cn]@
+ | S Term Term          -- ^ selection:   @t ! p@
+ | Val Type Int         -- ^ parameter value number: @T # i#
+
+ | Let LocalDef Term    -- ^ local definition: @let {t : T = a} in b@
+
+ | Alias Ident Type Term  -- ^ constant and its definition, used in inlining
+
+ | Q  Ident Ident        -- ^ qualified constant from a package
+ | QC Ident Ident        -- ^ qualified constructor from a package
+
+ | C Term Term    -- ^ concatenation: @s ++ t@
+ | Glue Term Term -- ^ agglutination: @s + t@
+
+ | EPatt Patt     -- ^ pattern (in macro definition): # p
+ | EPattType Term -- ^ pattern type: pattern T
+
+ | FV [Term]      -- ^ alternatives in free variation: @variants { s ; ... }@
+
+ | Alts (Term, [(Term, Term)]) -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@
+ | Strs [Term]                 -- ^ conditioning prefix strings: @strs {s ; ...}@
+-- 
+-- /below this, the last three constructors are obsolete/
+ | LiT Ident      -- ^ linearization type
+ | Ready Str      -- ^ result of compiling; not to be parsed ...
+ | Computed Term  -- ^ result of computing: not to be reopened nor parsed
+
+  deriving (Read, Show, Eq, Ord)
+
+data Patt =
+   PC Ident [Patt]        -- ^ constructor pattern: @C p1 ... pn@    @C@ 
+ | PP Ident Ident [Patt]  -- ^ package constructor pattern: @P.C p1 ... pn@    @P.C@ 
+ | PV Ident               -- ^ variable pattern: @x@
+ | PW                     -- ^ wild card pattern: @_@
+ | PR [(Label,Patt)]      -- ^ record pattern: @{r = p ; ...}@  -- only concrete
+ | PString String         -- ^ string literal pattern: @\"foo\"@  -- only abstract
+ | PInt    Integer        -- ^ integer literal pattern: @12@    -- only abstract
+ | PFloat Double          -- ^ float literal pattern: @1.2@    -- only abstract
+ | PT Type Patt           -- ^ type-annotated pattern
+
+ | PVal Type Int          -- ^ parameter value number: @T # i#
+
+ | PAs Ident Patt         -- ^ as-pattern: x@p
+
+ -- regular expression patterns
+ | PNeg Patt              -- ^ negated pattern: -p
+ | PAlt Patt Patt         -- ^ disjunctive pattern: p1 | p2
+ | PSeq Patt Patt         -- ^ sequence of token parts: p + q
+ | PRep Patt              -- ^ repetition of token part: p*
+ | PChar                  -- ^ string of length one: ?
+ | PChars [Char]          -- ^ character list: ["aeiou"]
+ | PMacro Ident           -- #p
+ | PM Ident Ident         -- #m.p
+
+  deriving (Read, Show, Eq, Ord)
+
+-- | to guide computation and type checking of tables
+data TInfo = 
+   TRaw         -- ^ received from parser; can be anything
+ | TTyped Type  -- ^ type annontated, but can be anything
+ | TComp Type   -- ^ expanded
+ | TWild Type   -- ^ just one wild card pattern, no need to expand 
+  deriving (Read, Show, Eq, Ord)
+
+-- | record label
+data Label = 
+    LIdent BS.ByteString
+  | LVar Int
+   deriving (Read, Show, Eq, Ord)
+
+newtype MetaSymb = MetaSymb Int    deriving (Read, Show, Eq, Ord)
+
+type Decl     = (Ident,Term)  -- (x:A)  (_:A)  A
+type Context  = [Decl]        -- (x:A)(y:B)   (x,y:A)   (_,_:A)
+type Equation = ([Patt],Term) 
+
+type Labelling = (Label, Term) 
+type Assign = (Label, (Maybe Type, Term)) 
+type Case = (Patt, Term) 
+type Cases = ([Patt], Term) 
+type LocalDef = (Ident, (Maybe Type, Term))
+
+type Param = (Ident, Context) 
+type Altern = (Term, [(Term, Term)])
+
+type Substitution =  [(Ident, Term)]
+
+-- | branches à la Alfa
+newtype Branch = Branch (Con,([Ident],Term)) deriving (Eq, Ord,Show,Read)
+type Con = Ident ---
+
+varLabel :: Int -> Label
+varLabel = LVar
+
+tupleLabel, linLabel :: Int -> Label
+tupleLabel i = LIdent $! BS.pack ('p':show i)
+linLabel   i = LIdent $! BS.pack ('s':show i)
+
+theLinLabel :: Label
+theLinLabel = LIdent (BS.singleton 's')
+
+ident2label :: Ident -> Label
+ident2label c = LIdent (ident2bs c)
+
+label2ident :: Label -> Ident
+label2ident (LIdent s) = identC s
+label2ident (LVar i)   = identC (BS.pack ('$':show i))
+
+wildPatt :: Patt
+wildPatt = PV identW
+
+type Trm = Term
diff --git a/src/GF/Grammar/Lockfield.hs b/src/GF/Grammar/Lockfield.hs
new file mode 100644
index 000000000..12b78ab9b
--- /dev/null
+++ b/src/GF/Grammar/Lockfield.hs
@@ -0,0 +1,51 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Lockfield
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/11 23:24:34 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.7 $
+--
+-- Creating and using lock fields in reused resource grammars.
+--
+-- AR 8\/2\/2005 detached from 'compile/MkResource'
+-----------------------------------------------------------------------------
+
+module GF.Grammar.Lockfield (lockRecType, unlockRecord, lockLabel, isLockLabel) where
+
+import qualified Data.ByteString.Char8 as BS
+
+import GF.Infra.Ident
+import GF.Grammar.Grammar
+import GF.Grammar.Macros
+import GF.Grammar.PrGrammar
+
+import GF.Data.Operations
+
+lockRecType :: Ident -> Type -> Err Type
+lockRecType c t@(RecType rs) = 
+  let lab = lockLabel c in
+  return $ if elem lab (map fst rs) || elem (prt c) ["String","Int"]
+    then t --- don't add an extra copy of lock field, nor predef cats
+    else RecType (rs ++ [(lockLabel c,  RecType [])])
+lockRecType c t = plusRecType t $ RecType [(lockLabel c,  RecType [])]
+
+unlockRecord :: Ident -> Term -> Err Term
+unlockRecord c ft = do
+  let (xs,t) = termFormCnc ft
+  t' <- plusRecord t $ R [(lockLabel c,  (Just (RecType []),R []))]
+  return $ mkAbs xs t'
+
+lockLabel :: Ident -> Label
+lockLabel c = LIdent $! BS.append lockPrefix (ident2bs c)
+
+isLockLabel :: Label -> Bool
+isLockLabel l = case l of
+  LIdent c -> BS.isPrefixOf lockPrefix c
+  _        -> False
+
+
+lockPrefix = BS.pack "lock_"
diff --git a/src/GF/Grammar/LookAbs.hs b/src/GF/Grammar/LookAbs.hs
new file mode 100644
index 000000000..f9a251eb1
--- /dev/null
+++ b/src/GF/Grammar/LookAbs.hs
@@ -0,0 +1,53 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : LookAbs
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/28 16:42:48 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.14 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Grammar.LookAbs (
+		lookupFunType,
+		lookupCatContext
+	       ) where
+
+import GF.Data.Operations
+import GF.Grammar.Abstract
+import GF.Infra.Ident
+
+import GF.Infra.Modules
+
+import Data.List (nub)
+import Control.Monad
+
+-- | this is needed at compile time
+lookupFunType :: Grammar -> Ident -> Ident -> Err Type
+lookupFunType gr m c = do
+  mi   <- lookupModule gr m
+  case mi of
+    ModMod mo -> do
+      info <- lookupIdentInfo mo c
+      case info of
+        AbsFun (Yes t) _  -> return t
+        AnyInd _ n  -> lookupFunType gr n c
+        _ -> prtBad "cannot find type of" c
+    _ -> Bad $ prt m +++ "is not an abstract module"
+
+-- | this is needed at compile time
+lookupCatContext :: Grammar -> Ident -> Ident -> Err Context
+lookupCatContext gr m c = do
+  mi   <- lookupModule gr m
+  case mi of
+    ModMod mo -> do
+      info <- lookupIdentInfo mo c
+      case info of
+        AbsCat (Yes co) _ -> return co
+        AnyInd _ n  -> lookupCatContext gr n c
+        _ -> prtBad "unknown category" c
+    _ -> Bad $ prt m +++ "is not an abstract module"
diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs
new file mode 100644
index 000000000..a4208b21b
--- /dev/null
+++ b/src/GF/Grammar/Lookup.hs
@@ -0,0 +1,269 @@
+{-# LANGUAGE PatternGuards #-}
+----------------------------------------------------------------------
+-- |
+-- Module      : Lookup
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/10/27 13:21:53 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.15 $
+--
+-- Lookup in source (concrete and resource) when compiling.
+--
+-- lookup in resource and concrete in compiling; for abstract, use 'Look'
+-----------------------------------------------------------------------------
+
+module GF.Grammar.Lookup (
+               lookupResDef,
+               lookupResDefKind,
+	       lookupResType, 
+               lookupOverload,
+	       lookupParams, 
+	       lookupParamValues, 
+	       lookupFirstTag, 
+               lookupValueIndex,
+               lookupIndexValue,
+               allOrigInfos,
+	       allParamValues, 
+	       lookupAbsDef, 
+	       lookupLincat, 
+	       opersForType
+	      ) where
+
+import GF.Data.Operations
+import GF.Grammar.Abstract
+import GF.Infra.Modules
+import GF.Grammar.Predef
+import GF.Grammar.Lockfield
+
+import Data.List (nub,sortBy)
+import Control.Monad
+
+-- whether lock fields are added in reuse
+lock c = lockRecType c -- return
+unlock c = unlockRecord c -- return
+
+lookupResDef :: SourceGrammar -> Ident -> Ident -> Err Term
+lookupResDef gr m c = liftM fst $ lookupResDefKind gr m c
+
+-- 0 = oper, 1 = lin, 2 = canonical. v > 0 means: no need to be recomputed
+lookupResDefKind :: SourceGrammar -> Ident -> Ident -> Err (Term,Int)
+lookupResDefKind gr m c 
+ | isPredefCat c = return (Q cPredefAbs c,2) --- need this in gf3 12/6/2008 
+ | otherwise = look True m c where 
+  look isTop m c = do
+    mi   <- lookupModule gr m
+    case mi of
+      ModMod mo -> do
+        info <- lookupIdentInfoIn mo m c
+        case info of
+          ResOper _ (Yes t) -> return (qualifAnnot m t, 0) 
+          ResOper _ Nope    -> return (Q m c, 0) ---- if isTop then lookExt m c 
+                                 ---- else prtBad "cannot find in exts" c 
+
+          CncCat (Yes ty) _ _ -> liftM (flip (,) 1) $ lock c ty
+          CncCat _ _ _        -> liftM (flip (,) 1) $ lock c defLinType
+          CncFun (Just (cat,_)) (Yes tr) _ -> liftM (flip (,) 1) $ unlock cat tr
+
+          CncFun _ (Yes tr) _ -> liftM (flip (,) 1) (return tr) ---- $ unlock c tr
+
+          AnyInd _ n        -> look False n c
+          ResParam _        -> return (QC m c,2)
+          ResValue _        -> return (QC m c,2)
+          _   -> Bad $ prt c +++ "is not defined in resource" +++ prt m
+      _ -> Bad $ prt m +++ "is not a resource"
+  lookExt m c =
+    checks ([look False n c | n <- allExtensions gr m] ++ [return (Q m c,3)])
+
+lookupResType :: SourceGrammar -> Ident -> Ident -> Err Type
+lookupResType gr m c = do
+  mi   <- lookupModule gr m
+  case mi of
+    ModMod mo -> do
+      info <- lookupIdentInfo mo c
+      case info of
+        ResOper (Yes t) _ -> return $ qualifAnnot m t
+        ResOper (May n) _ -> lookupResType gr n c
+
+        -- used in reused concrete
+        CncCat _ _ _ -> return typeType
+        CncFun (Just (cat,(cont@(_:_),val))) _ _ -> do
+          val' <- lock cat val 
+          return $ mkProd (cont, val', [])
+        CncFun _ _ _      -> lookFunType m m c
+        AnyInd _ n        -> lookupResType gr n c
+        ResParam _        -> return $ typePType
+        ResValue (Yes (t,_))  -> return $ qualifAnnotPar m t
+        _   -> Bad $ prt c +++ "has no type defined in resource" +++ prt m
+    _ -> Bad $ prt m +++ "is not a resource"
+  where
+    lookFunType e m c = do
+          a  <- abstractOfConcrete gr m
+          lookFun e m c a
+    lookFun e m c a = do
+          mu <- lookupModMod gr a
+          info <- lookupIdentInfo mu c
+          case info of
+            AbsFun (Yes ty) _ -> return $ redirectTerm e ty 
+            AbsCat _ _ -> return typeType
+            AnyInd _ n -> lookFun e m c n
+            _ -> prtBad "cannot find type of reused function" c
+
+lookupOverload :: SourceGrammar -> Ident -> Ident -> Err [([Type],(Type,Term))]
+lookupOverload gr m c = do
+    mi   <- lookupModule gr m
+    case mi of
+      ModMod mo -> do
+        info <- lookupIdentInfo mo c
+        case info of
+          ResOverload os tysts -> do
+            tss <- mapM (\x -> lookupOverload gr x c) os
+            return $ [(map snd args,(val,tr)) | 
+                      (ty,tr) <- tysts, Ok (args,val) <- [typeFormCnc ty]] ++ 
+                     concat tss
+
+          AnyInd _ n  -> lookupOverload gr n c
+          _   -> Bad $ prt c +++ "is not an overloaded operation"
+      _ -> Bad $ prt m +++ "is not a resource"
+
+lookupOrigInfo :: SourceGrammar -> Ident -> Ident -> Err Info
+lookupOrigInfo gr m c = do
+    mi   <- lookupModule gr m
+    case mi of
+      ModMod mo -> do
+        info <- lookupIdentInfo mo c
+        case info of
+          AnyInd _ n  -> lookupOrigInfo gr n c
+          i   -> return i
+      _ -> Bad $ prt m +++ "is not run-time module"
+
+lookupParams :: SourceGrammar -> Ident -> Ident -> Err ([Param],Maybe PValues)
+lookupParams gr = look True where 
+  look isTop m c = do
+    mi   <- lookupModule gr m
+    case mi of
+      ModMod mo -> do
+        info <- lookupIdentInfo mo c
+        case info of
+          ResParam (Yes psm) -> return psm
+          AnyInd _ n        -> look False n c
+          _   -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m
+      _ -> Bad $ prt m +++ "is not a resource"
+  lookExt m c =
+    checks [look False n c | n <- allExtensions gr m]
+
+lookupParamValues :: SourceGrammar -> Ident -> Ident -> Err [Term]
+lookupParamValues gr m c = do
+  (ps,mpv) <- lookupParams gr m c
+  case mpv of
+    Just ts -> return ts
+    _ -> liftM concat $ mapM mkPar ps
+ where
+   mkPar (f,co) = do
+     vs <- liftM combinations $ mapM (\ (_,ty) -> allParamValues gr ty) co
+     return $ map (mkApp (QC m f)) vs
+
+lookupFirstTag :: SourceGrammar -> Ident -> Ident -> Err Term
+lookupFirstTag gr m c = do
+  vs <- lookupParamValues gr m c
+  case vs of
+    v:_ -> return v
+    _ -> prtBad "no parameter values given to type" c
+
+lookupValueIndex :: SourceGrammar -> Type -> Term -> Err Term
+lookupValueIndex gr ty tr = do
+  ts <- allParamValues gr ty
+  case lookup tr $ zip ts [0..] of
+    Just i -> return $ Val ty i
+    _ -> Bad $ "no index for" +++ prt tr +++ "in" +++ prt ty
+
+lookupIndexValue :: SourceGrammar -> Type -> Int -> Err Term
+lookupIndexValue gr ty i = do
+  ts <- allParamValues gr ty
+  if i < length ts
+    then return $ ts !! i
+    else Bad $ "no value for index" +++ show i +++ "in" +++ prt ty
+
+allOrigInfos :: SourceGrammar -> Ident -> [(Ident,Info)]
+allOrigInfos gr m = errVal [] $ do
+  mi <- lookupModule gr m
+  case mi of
+    ModMod mo -> return [(c,i) | (c,_) <- tree2list (jments mo), Ok i <- [look c]]
+ where
+   look = lookupOrigInfo gr m
+
+allParamValues :: SourceGrammar -> Type -> Err [Term]
+allParamValues cnc ptyp = case ptyp of
+     _ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]]
+     QC p c -> lookupParamValues cnc p c
+     Q  p c -> lookupResDef cnc p c >>= allParamValues cnc
+     RecType r -> do
+       let (ls,tys) = unzip $ sortByFst r
+       tss <- mapM allPV tys
+       return [R (zipAssign ls ts) | ts <- combinations tss]
+     _ -> prtBad "cannot find parameter values for" ptyp
+  where
+    allPV = allParamValues cnc
+    -- to normalize records and record types
+    sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
+
+qualifAnnot :: Ident -> Term -> Term
+qualifAnnot _ = id
+-- Using this we wouldn't have to annotate constants defined in a module itself.
+-- But things are simpler if we do (cf. Zinc).
+-- Change Rename.self2status to change this behaviour.
+
+-- we need this for lookup in ResVal
+qualifAnnotPar m t = case t of
+  Cn c  -> Q m c
+  Con c -> QC m c
+  _ -> composSafeOp (qualifAnnotPar m) t
+
+lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe Term)
+lookupAbsDef gr m c = errIn ("looking up absdef of" +++ prt c) $ do
+  mi   <- lookupModule gr m
+  case mi of
+    ModMod mo -> do
+      info <- lookupIdentInfo mo c
+      case info of
+        AbsFun _ (Yes t)  -> return $ return t
+        AnyInd _ n  -> lookupAbsDef gr n c
+        _ -> return Nothing
+    _ -> Bad $ prt m +++ "is not an abstract module"
+
+lookupLincat :: SourceGrammar -> Ident -> Ident -> Err Type
+lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
+lookupLincat gr m c = do
+  mi <- lookupModule gr m
+  case mi of
+    ModMod mo -> do
+      info <- lookupIdentInfo mo c
+      case info of
+        CncCat (Yes t) _ _ -> return t
+        AnyInd _ n         -> lookupLincat gr n c
+        _   -> Bad $ prt c +++ "has no linearization type in" +++ prt m
+    _ -> Bad $ prt m +++ "is not concrete"
+
+
+-- The first type argument is uncomputed, usually a category symbol.
+-- This is a hack to find implicit (= reused) opers.
+
+opersForType :: SourceGrammar -> Type -> Type -> [(QIdent,Term)]
+opersForType gr orig val = 
+  [((i,f),ty) | (i,m) <- allModMod gr, (f,ty) <- opers i m val] where
+    opers i m val = 
+      [(f,ty) |
+        (f,ResOper (Yes ty) _) <- tree2list $ jments m,
+        Ok valt <- [valTypeCnc ty],
+        elem valt [val,orig]
+        ] ++
+      let cat = err error snd (valCat orig) in --- ignore module
+      [(f,ty) |
+        Ok a <- [abstractOfConcrete gr i >>= lookupModMod gr],
+        (f, AbsFun (Yes ty0) _) <- tree2list $ jments a,
+        let ty = redirectTerm i ty0,
+        Ok valt  <- [valCat ty],
+        cat == snd valt ---
+        ]
diff --git a/src/GF/Grammar/MMacros.hs b/src/GF/Grammar/MMacros.hs
new file mode 100644
index 000000000..f2a0f2cb2
--- /dev/null
+++ b/src/GF/Grammar/MMacros.hs
@@ -0,0 +1,339 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : MMacros
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/05/10 12:49:13 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.9 $
+--
+-- some more abstractions on grammars, esp. for Edit
+-----------------------------------------------------------------------------
+
+module GF.Grammar.MMacros where
+
+import GF.Data.Operations
+import GF.Data.Zipper
+
+import GF.Grammar.Grammar
+import GF.Grammar.PrGrammar
+import GF.Infra.Ident
+import GF.Compile.Refresh
+import GF.Grammar.Values
+----import GrammarST
+import GF.Grammar.Macros
+
+import Control.Monad
+import qualified Data.ByteString.Char8 as BS
+
+nodeTree :: Tree -> TrNode
+argsTree :: Tree -> [Tree]
+
+nodeTree (Tr (n,_)) = n
+argsTree (Tr (_,ts)) = ts
+
+isFocusNode    :: TrNode -> Bool
+bindsNode      :: TrNode -> Binds
+atomNode       :: TrNode -> Atom
+valNode        :: TrNode -> Val
+constrsNode    :: TrNode -> Constraints
+metaSubstsNode :: TrNode -> MetaSubst
+
+isFocusNode    (N (_,_,_,_,b)) = b
+bindsNode      (N (b,_,_,_,_)) = b
+atomNode       (N (_,a,_,_,_)) = a
+valNode        (N (_,_,v,_,_)) = v
+constrsNode    (N (_,_,_,(c,_),_)) = c
+metaSubstsNode (N (_,_,_,(_,m),_)) = m
+
+atomTree :: Tree -> Atom
+valTree  :: Tree -> Val
+
+atomTree = atomNode . nodeTree 
+valTree  = valNode  . nodeTree
+
+mkNode :: Binds -> Atom -> Val -> (Constraints, MetaSubst) -> TrNode
+mkNode binds atom vtyp cs = N (binds,atom,vtyp,cs,False)
+
+type Var = Ident
+type Meta = MetaSymb
+
+metasTree :: Tree ->  [Meta]
+metasTree = concatMap metasNode . scanTree where
+  metasNode n = [m | AtM m <- [atomNode n]] ++ map fst (metaSubstsNode n)
+
+varsTree :: Tree ->  [(Var,Val)]
+varsTree t = [(x,v) | N (_,AtV x,v,_,_) <- scanTree t]
+
+constrsTree :: Tree -> Constraints
+constrsTree = constrsNode . nodeTree
+
+allConstrsTree :: Tree -> Constraints
+allConstrsTree = concatMap constrsNode . scanTree
+
+changeConstrs :: (Constraints -> Constraints) -> TrNode -> TrNode
+changeConstrs f (N (b,a,v,(c,m),x)) = N (b,a,v,(f c, m),x)
+
+changeMetaSubst :: (MetaSubst -> MetaSubst) -> TrNode -> TrNode
+changeMetaSubst f (N (b,a,v,(c,m),x)) = N (b,a,v,(c, f m),x)
+
+changeAtom :: (Atom -> Atom) -> TrNode -> TrNode
+changeAtom f (N (b,a,v,(c,m),x)) = N (b,f a,v,(c, m),x)
+
+-- * on the way to Edit
+
+uTree :: Tree
+uTree = Tr (uNode, []) -- unknown tree
+
+uNode :: TrNode
+uNode = mkNode [] uAtom uVal ([],[])
+
+
+uAtom :: Atom
+uAtom = AtM meta0
+
+mAtom :: Atom
+mAtom = AtM meta0
+
+uVal :: Val
+uVal = vClos uExp
+
+vClos :: Exp -> Val
+vClos = VClos []
+
+uExp :: Exp
+uExp = Meta meta0
+
+mExp, mExp0 :: Exp
+mExp  = Meta meta0
+mExp0 = mExp
+
+meta2exp :: MetaSymb -> Exp
+meta2exp = Meta
+
+atomC :: Fun -> Atom
+atomC = AtC
+
+funAtom :: Atom -> Err Fun
+funAtom a = case a of
+  AtC f -> return f
+  _ -> prtBad "not function head" a
+
+atomIsMeta :: Atom -> Bool
+atomIsMeta atom = case atom of
+  AtM _ -> True
+  _   -> False
+
+getMetaAtom :: Atom -> Err Meta
+getMetaAtom a = case a of
+  AtM m -> return m
+  _ -> Bad "the active node is not meta"
+
+cat2val :: Context -> Cat -> Val
+cat2val cont cat = vClos $ mkApp (qq cat) [mkMeta i | i <- [1..length cont]]
+
+val2cat :: Val -> Err Cat
+val2cat v = val2exp v >>= valCat
+
+substTerm  :: [Ident] -> Substitution -> Term -> Term
+substTerm ss g c = case c of
+  Vr x        -> maybe c id $ lookup x g
+  App f a     -> App (substTerm ss g f) (substTerm ss g a)
+  Abs x b     -> let y = mkFreshVarX ss x in 
+                   Abs y (substTerm (y:ss) ((x, Vr y):g) b)
+  Prod x a b  -> let y = mkFreshVarX ss x in 
+                   Prod y (substTerm ss g a) (substTerm (y:ss) ((x,Vr y):g) b)
+  _           -> c
+
+metaSubstExp :: MetaSubst -> [(Meta,Exp)]
+metaSubstExp msubst = [(m, errVal (meta2exp m) (val2expSafe v)) | (m,v) <- msubst]
+
+-- * belong here rather than to computation
+
+substitute :: [Var] -> Substitution -> Exp -> Err Exp
+substitute v s = return . substTerm v s
+
+alphaConv :: [Var] -> (Var,Var) -> Exp -> Err Exp ---
+alphaConv oldvars (x,x') = substitute (x:x':oldvars) [(x,Vr x')]
+
+alphaFresh :: [Var] -> Exp -> Err Exp
+alphaFresh vs = refreshTermN $ maxVarIndex vs
+
+-- | done in a state monad
+alphaFreshAll :: [Var] -> [Exp] -> Err [Exp]
+alphaFreshAll vs = mapM $ alphaFresh vs 
+
+-- | for display
+val2exp :: Val -> Err Exp
+val2exp = val2expP False 
+
+-- | for type checking
+val2expSafe :: Val -> Err Exp
+val2expSafe = val2expP True  
+
+val2expP :: Bool -> Val -> Err Exp
+val2expP safe v = case v of
+
+  VClos g@(_:_) e@(Meta _) -> if safe 
+                              then prtBad "unsafe value substitution" v
+                              else substVal g e
+  VClos g e -> substVal g e
+  VApp f c  -> liftM2 App (val2expP safe f) (val2expP safe c)
+  VCn c     -> return $ qq c
+  VGen i x  -> if safe 
+               then prtBad "unsafe val2exp" v
+               else return $ Vr $ x  --- in editing, no alpha conversions presentv
+ where 
+   substVal g e = mapPairsM (val2expP safe) g >>= return . (\s -> substTerm [] s e)
+
+isConstVal :: Val -> Bool
+isConstVal v = case v of
+  VApp f c   -> isConstVal f && isConstVal c
+  VCn _      -> True
+  VClos [] e -> null $ freeVarsExp e  
+  _          -> False --- could be more liberal
+
+mkProdVal :: Binds -> Val -> Err Val ---
+mkProdVal bs v = do 
+  bs' <- mapPairsM val2exp bs
+  v'  <- val2exp v
+  return $ vClos $ foldr (uncurry Prod) v' bs'
+
+freeVarsExp :: Exp -> [Ident]
+freeVarsExp e = case e of
+  Vr x -> [x]
+  App f c -> freeVarsExp f ++ freeVarsExp c
+  Abs x b -> filter (/=x) (freeVarsExp b)
+  Prod x a b -> freeVarsExp a ++ filter (/=x) (freeVarsExp b)
+  _ -> [] --- thus applies to abstract syntax only
+
+ident2string :: Ident -> String
+ident2string = prIdent
+
+tree :: (TrNode,[Tree]) -> Tree
+tree = Tr
+
+eqCat :: Cat -> Cat -> Bool
+eqCat = (==)
+
+addBinds :: Binds -> Tree -> Tree
+addBinds b (Tr (N (b0,at,t,c,x),ts)) = Tr (N (b ++ b0,at,t,c,x),ts)
+
+bodyTree :: Tree -> Tree
+bodyTree (Tr (N (_,a,t,c,x),ts)) = Tr (N ([],a,t,c,x),ts)
+
+refreshMetas :: [Meta] -> Exp -> Exp
+refreshMetas metas = fst . rms minMeta where
+  rms meta trm = case trm of
+    Meta m  -> (Meta meta, nextMeta meta)
+    App f a -> let (f',msf) = rms meta f 
+                   (a',msa) = rms msf a
+               in (App f' a', msa)
+    Prod x a b -> 
+               let (a',msa) = rms meta a 
+                   (b',msb) = rms msa b
+               in (Prod x a' b', msb)
+    Abs x b -> let (b',msb) = rms meta b in (Abs x b', msb)
+    _       -> (trm,meta)
+  minMeta = int2meta $ 
+              if null metas then 0 else (maximum (map metaSymbInt metas) + 1)
+
+ref2exp :: [Var] -> Type -> Ref -> Err Exp
+ref2exp bounds typ ref = do
+  cont <- contextOfType typ
+  xx0  <- mapM (typeSkeleton . snd) cont
+  let (xxs,cs) = unzip [(length hs, c) | (hs,c) <- xx0]
+      args     = [mkAbs xs mExp | i <- xxs, let xs = mkFreshVars i bounds]
+  return $ mkApp ref args
+  -- no refreshment of metas
+  
+-- | invariant: only 'Con' or 'Var'
+type Ref = Exp 
+
+fun2wrap :: [Var] -> ((Fun,Int),Type) -> Exp -> Err Exp
+fun2wrap oldvars ((fun,i),typ) exp = do
+  cont <- contextOfType typ
+  args <- mapM mkArg (zip [0..] (map snd cont))
+  return $ mkApp (qq fun) args
+ where
+  mkArg (n,c) = do
+    cont <- contextOfType c
+    let vars = mkFreshVars (length cont) oldvars
+    return $ mkAbs vars $ if n==i then exp else mExp
+
+-- | weak heuristics: sameness of value category
+compatType :: Val -> Type -> Bool
+compatType v t = errVal True $ do
+  cat1 <- val2cat v
+  cat2 <- valCat t
+  return $ cat1 == cat2
+
+---
+
+mkJustProd :: Context -> Term -> Term
+mkJustProd cont typ = mkProd (cont,typ,[])
+
+int2var :: Int -> Ident
+int2var = identC . BS.pack . ('$':) . show
+
+meta0 :: Meta
+meta0 = int2meta 0
+
+termMeta0 :: Term
+termMeta0 = Meta meta0
+
+identVar :: Term -> Err Ident
+identVar (Vr x) = return x
+identVar _ = Bad "not a variable"
+
+
+-- | light-weight rename for user interaction; also change names of internal vars
+qualifTerm :: Ident -> Term -> Term
+qualifTerm m  = qualif [] where
+  qualif xs t = case t of
+    Abs x b -> let x' = chV x in Abs x' $ qualif (x':xs) b
+    Prod x a b -> Prod x (qualif xs a) $ qualif (x:xs) b
+    Vr x -> let x' = chV x in if (elem x' xs) then (Vr x') else (Q m x) 
+    Cn c  -> Q m c
+    Con c -> QC m c
+    _ -> composSafeOp (qualif xs) t
+  chV x = string2var $ ident2bs x
+    
+string2var :: BS.ByteString -> Ident
+string2var s = case BS.unpack s of
+  c:'_':i -> identV (BS.singleton c) (readIntArg i) ---
+  _       -> identC s
+
+-- | reindex variables so that they tell nesting depth level
+reindexTerm :: Term -> Term
+reindexTerm = qualif (0,[]) where
+  qualif dg@(d,g) t = case t of
+    Abs x b    -> let x' = ind x d in Abs x' $ qualif (d+1, (x,x'):g) b
+    Prod x a b -> let x' = ind x d in Prod x' (qualif dg a) $ qualif (d+1, (x,x'):g) b
+    Vr x       -> Vr $ look x g
+    _ -> composSafeOp (qualif dg) t
+  look x  = maybe x id . lookup x --- if x is not in scope it is unchanged
+  ind x d = identC $ ident2bs x `BS.append` BS.singleton '_' `BS.append` BS.pack (show d)
+
+
+-- this method works for context-free abstract syntax
+-- and is meant to be used in simple embedded GF applications
+
+exp2tree :: Exp -> Err Tree
+exp2tree e = do
+  (bs,f,xs) <- termForm e
+  cont <- case bs of
+    [] -> return []
+    _  -> prtBad "cannot convert bindings in" e
+  at <- case f of
+    Q  m c -> return $ AtC (m,c)
+    QC m c -> return $ AtC (m,c)
+    Meta m -> return $ AtM m
+    K s    -> return $ AtL s
+    EInt n -> return $ AtI n
+    EFloat n -> return $ AtF n
+    _ -> prtBad "cannot convert to atom" f
+  ts <- mapM exp2tree xs
+  return $ Tr (N (cont,at,uVal,([],[]),True),ts)
diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs
new file mode 100644
index 000000000..be03c02a7
--- /dev/null
+++ b/src/GF/Grammar/Macros.hs
@@ -0,0 +1,733 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Macros
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/11 16:38:00 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.24 $
+--
+-- Macros for constructing and analysing source code terms.
+--
+-- operations on terms and types not involving lookup in or reference to grammars
+--
+-- AR 7\/12\/1999 - 9\/5\/2000 -- 4\/6\/2001
+-----------------------------------------------------------------------------
+
+module GF.Grammar.Macros where
+
+import GF.Data.Operations
+import GF.Data.Str
+import GF.Infra.Ident
+import GF.Grammar.Grammar
+import GF.Grammar.Values
+import GF.Grammar.Predef
+import GF.Grammar.PrGrammar
+
+import Control.Monad (liftM, liftM2)
+import Data.Char (isDigit)
+import Data.List (sortBy)
+
+firstTypeForm :: Type -> Err (Context, Type)
+firstTypeForm t = case t of
+  Prod x a b  -> do
+    (x', val) <- firstTypeForm b 
+    return ((x,a):x',val)
+  _ -> return ([],t)
+
+qTypeForm :: Type -> Err (Context, Cat, [Term])
+qTypeForm t = case t of
+  Prod x a b  -> do
+    (x', cat, args) <- qTypeForm b 
+    return ((x,a):x', cat, args)
+  App c a -> do
+    (_,cat, args) <- qTypeForm c
+    return ([],cat,args ++ [a])
+  Q m c ->
+    return ([],(m,c),[]) 
+  QC m c ->
+    return ([],(m,c),[]) 
+  _       -> 
+    prtBad "no normal form of type" t
+
+qq :: QIdent -> Term
+qq (m,c) = Q m c
+
+typeForm :: Type -> Err (Context, Cat, [Term])
+typeForm = qTypeForm ---- no need to distinguish any more
+
+typeFormCnc :: Type -> Err (Context, Type)
+typeFormCnc t = case t of
+  Prod x a b  -> do
+    (x', v) <- typeFormCnc b 
+    return ((x,a):x',v)
+  _ -> return ([],t)
+
+valCat :: Type -> Err Cat
+valCat typ = 
+  do (_,cat,_) <- typeForm typ
+     return cat
+
+valType :: Type -> Err Type
+valType typ = 
+  do (_,cat,xx) <- typeForm typ --- not optimal to do in this way
+     return $ mkApp (qq cat) xx
+
+valTypeCnc :: Type -> Err Type
+valTypeCnc typ = 
+  do (_,ty) <- typeFormCnc typ
+     return ty
+
+typeRawSkeleton :: Type -> Err ([(Int,Type)],Type)
+typeRawSkeleton typ =
+  do (cont,typ) <- typeFormCnc typ
+     args <- mapM (typeRawSkeleton . snd) cont
+     return ([(length c, v) | (c,v) <- args], typ)
+
+type MCat = (Ident,Ident)
+
+getMCat :: Term -> Err MCat
+getMCat t = case t of
+  Q  m c -> return (m,c)
+  QC m c -> return (m,c)
+  Sort c -> return (identW, c)
+  App f _ -> getMCat f
+  _ -> prtBad "no qualified constant" t
+
+typeSkeleton :: Type -> Err ([(Int,MCat)],MCat)
+typeSkeleton typ = do
+  (cont,val) <- typeRawSkeleton typ
+  cont' <- mapPairsM getMCat cont
+  val'  <- getMCat val
+  return (cont',val')
+
+catSkeleton :: Type -> Err ([MCat],MCat)
+catSkeleton typ =
+  do (args,val) <- typeSkeleton typ
+     return (map snd args, val)
+
+funsToAndFrom :: Type -> (MCat, [(MCat,[Int])])
+funsToAndFrom t = errVal undefined $ do ---
+  (cs,v) <- catSkeleton t
+  let cis = zip cs [0..]
+  return $ (v, [(c,[i | (c',i) <- cis, c' == c]) | c <- cs])
+
+typeFormConcrete :: Type -> Err (Context, Type)
+typeFormConcrete t = case t of
+  Prod x a b  -> do 
+    (x', typ) <- typeFormConcrete b 
+    return ((x,a):x', typ)
+  _       -> return ([],t)
+
+isRecursiveType :: Type -> Bool
+isRecursiveType t = errVal False $ do
+  (cc,c) <- catSkeleton t -- thus recursivity on Cat level
+  return $ any (== c) cc
+
+isHigherOrderType :: Type -> Bool
+isHigherOrderType t = errVal True $ do  -- pessimistic choice
+  co <- contextOfType t
+  return $ not $ null [x | (x,Prod _ _ _) <- co]
+
+contextOfType :: Type -> Err Context
+contextOfType typ = case typ of
+  Prod x a b -> liftM ((x,a):) $ contextOfType b
+  _ -> return [] 
+
+unComputed :: Term -> Term
+unComputed t = case t of
+  Computed v -> unComputed v
+  _ -> t --- composSafeOp unComputed t
+
+
+{- 
+--- defined (better) in compile/PrOld
+
+stripTerm :: Term -> Term
+stripTerm t = case t of
+  Q _ c  -> Cn c
+  QC _ c -> Cn c
+  T ti psts -> T ti [(stripPatt p, stripTerm v) | (p,v) <- psts]
+  _ -> composSafeOp stripTerm t
+ where
+   stripPatt p = errVal p $ term2patt $ stripTerm $ patt2term p
+-}
+
+computed :: Term -> Term
+computed = Computed
+
+termForm :: Term -> Err ([(Ident)], Term, [Term])
+termForm t = case t of
+   Abs x b  ->
+     do (x', fun, args) <- termForm b 
+        return (x:x', fun, args)
+   App c a ->
+     do (_,fun, args) <- termForm c
+        return ([],fun,args ++ [a]) 
+   _       -> 
+     return ([],t,[])
+
+termFormCnc :: Term -> ([(Ident)], Term)
+termFormCnc t = case t of
+   Abs x b  -> (x:xs, t') where (xs,t') = termFormCnc b 
+   _        -> ([],t)
+
+appForm :: Term -> (Term, [Term])
+appForm t = case t of
+  App c a -> (fun, args ++ [a]) where (fun, args) = appForm c
+  _       -> (t,[])
+
+varsOfType :: Type -> [Ident]
+varsOfType t = case t of
+  Prod x _ b -> x : varsOfType b
+  _ -> []
+
+mkProdSimple :: Context -> Term -> Term
+mkProdSimple c t = mkProd (c,t,[])
+
+mkProd :: (Context, Term, [Term]) -> Term
+mkProd ([],typ,args) = mkApp typ args
+mkProd ((x,a):dd, typ, args) = Prod x a (mkProd (dd, typ, args))
+
+mkTerm :: ([(Ident)], Term, [Term]) -> Term
+mkTerm (xx,t,aa) = mkAbs xx (mkApp t aa)
+
+mkApp :: Term -> [Term] -> Term
+mkApp = foldl App
+
+mkAbs :: [Ident] -> Term -> Term
+mkAbs xx t = foldr Abs t xx
+
+appCons :: Ident -> [Term] -> Term
+appCons = mkApp . Cn
+
+mkLet :: [LocalDef] -> Term -> Term
+mkLet defs t = foldr Let t defs
+
+mkLetUntyped :: Context -> Term -> Term
+mkLetUntyped defs = mkLet [(x,(Nothing,t)) | (x,t) <- defs]
+
+isVariable :: Term -> Bool
+isVariable (Vr _ ) = True
+isVariable _ = False
+
+eqIdent :: Ident -> Ident -> Bool
+eqIdent = (==)
+
+uType :: Type
+uType = Cn cUndefinedType
+
+assign :: Label -> Term -> Assign
+assign l t = (l,(Nothing,t))
+
+assignT :: Label -> Type -> Term -> Assign
+assignT l a t = (l,(Just a,t))
+
+unzipR :: [Assign] -> ([Label],[Term])
+unzipR r = (ls, map snd ts) where (ls,ts) = unzip r
+
+mkAssign :: [(Label,Term)] -> [Assign]
+mkAssign lts = [assign l t | (l,t) <- lts]
+
+zipAssign :: [Label] -> [Term] -> [Assign]
+zipAssign ls ts = [assign l t | (l,t) <- zip ls ts]
+
+mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))]
+mapAssignM f = mapM (\ (ls,tv) -> liftM ((,) ls) (g tv))
+  where g (t,v) = liftM2 (,) (maybe (return Nothing) (liftM Just . f) t) (f v)
+
+mkRecordN :: Int -> (Int -> Label) -> [Term] -> Term
+mkRecordN int lab typs = R [ assign (lab i) t | (i,t) <- zip [int..] typs]
+
+mkRecord :: (Int -> Label) -> [Term] -> Term
+mkRecord = mkRecordN 0
+
+mkRecTypeN :: Int -> (Int -> Label) -> [Type] -> Type
+mkRecTypeN int lab typs = RecType [ (lab i, t) | (i,t) <- zip [int..] typs]
+
+mkRecType :: (Int -> Label) -> [Type] -> Type
+mkRecType = mkRecTypeN 0
+
+record2subst :: Term -> Err Substitution
+record2subst t = case t of
+  R fs -> return [(identC x, t) | (LIdent x,(_,t)) <- fs]
+  _ -> prtBad "record expected, found" t
+
+typeType, typePType, typeStr, typeTok, typeStrs :: Term
+
+typeType  = Sort cType
+typePType = Sort cPType
+typeStr   = Sort cStr
+typeTok   = Sort cTok
+typeStrs  = Sort cStrs
+
+typeString, typeFloat, typeInt :: Term
+typeInts :: Integer -> Term
+typePBool :: Term
+typeError :: Term
+
+typeString = cnPredef cString
+typeInt = cnPredef cInt
+typeFloat = cnPredef cFloat
+typeInts i = App (cnPredef cInts) (EInt i)
+typePBool = cnPredef cPBool
+typeError = cnPredef cErrorType
+
+isTypeInts :: Term -> Maybe Integer
+isTypeInts (App c (EInt i)) | c == cnPredef cInts = Just i
+isTypeInts _                                      = Nothing
+
+isPredefConstant :: Term -> Bool
+isPredefConstant t = case t of
+  Q mod _ | mod == cPredef || mod == cPredefAbs -> True
+  _                                             -> False
+
+cnPredef :: Ident -> Term
+cnPredef f = Q cPredef f
+
+mkSelects :: Term -> [Term] -> Term
+mkSelects t tt = foldl S t tt
+
+mkTable :: [Term] -> Term -> Term
+mkTable tt t = foldr Table t tt
+
+mkCTable :: [Ident] -> Term -> Term
+mkCTable ids v = foldr ccase v ids where 
+  ccase x t = T TRaw [(PV x,t)]
+
+mkDecl :: Term -> Decl
+mkDecl typ = (identW, typ)
+
+eqStrIdent :: Ident -> Ident -> Bool
+eqStrIdent = (==)
+
+tuple2record :: [Term] -> [Assign]
+tuple2record ts = [assign (tupleLabel i) t | (i,t) <- zip [1..] ts]
+
+tuple2recordType :: [Term] -> [Labelling]
+tuple2recordType ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts]
+
+tuple2recordPatt :: [Patt] -> [(Label,Patt)]
+tuple2recordPatt ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts]
+
+mkCases :: Ident -> Term -> Term
+mkCases x t = T TRaw [(PV x, t)]
+
+mkWildCases :: Term -> Term
+mkWildCases = mkCases identW
+
+mkFunType :: [Type] -> Type -> Type
+mkFunType tt t = mkProd ([(identW, ty) | ty <- tt], t, []) -- nondep prod
+
+plusRecType :: Type -> Type -> Err Type
+plusRecType t1 t2 = case (unComputed t1, unComputed t2) of
+  (RecType r1, RecType r2) -> case
+    filter (`elem` (map fst r1)) (map fst r2) of
+      [] -> return (RecType (r1 ++ r2))
+      ls -> Bad $ "clashing labels" +++ unwords (map prt ls)
+  _ -> Bad ("cannot add record types" +++ prt t1 +++ "and" +++ prt t2) 
+
+plusRecord :: Term -> Term -> Err Term
+plusRecord t1 t2 =
+ case (t1,t2) of
+   (R r1, R r2 ) -> return (R ([(l,v) | -- overshadowing of old fields
+                              (l,v) <- r1, not (elem l (map fst r2)) ] ++ r2))
+   (_,    FV rs) -> mapM (plusRecord t1) rs >>= return . FV
+   (FV rs,_    ) -> mapM (`plusRecord` t2) rs >>= return . FV
+   _ -> Bad ("cannot add records" +++ prt t1 +++ "and" +++ prt t2)
+
+-- | default linearization type
+defLinType :: Type
+defLinType = RecType [(theLinLabel,  typeStr)]
+
+-- | refreshing variables
+mkFreshVar :: [Ident] -> Ident
+mkFreshVar olds = varX (maxVarIndex olds + 1) 
+
+-- | trying to preserve a given symbol
+mkFreshVarX :: [Ident] -> Ident -> Ident
+mkFreshVarX olds x = if (elem x olds) then (varX (maxVarIndex olds + 1)) else x
+
+maxVarIndex :: [Ident] -> Int
+maxVarIndex = maximum . ((-1):) . map varIndex
+
+mkFreshVars :: Int -> [Ident] -> [Ident] 
+mkFreshVars n olds = [varX (maxVarIndex olds + i) | i <- [1..n]]
+
+-- | quick hack for refining with var in editor
+freshAsTerm :: String -> Term
+freshAsTerm s = Vr (varX (readIntArg s))
+
+-- | create a terminal for concrete syntax
+string2term :: String -> Term
+string2term = K
+
+int2term :: Integer -> Term
+int2term = EInt
+
+float2term :: Double -> Term
+float2term = EFloat
+
+-- | create a terminal from identifier
+ident2terminal :: Ident -> Term
+ident2terminal = K . prIdent
+
+symbolOfIdent :: Ident -> String
+symbolOfIdent = prIdent
+
+symid :: Ident -> String
+symid = symbolOfIdent
+
+justIdentOf :: Term -> Maybe Ident
+justIdentOf (Vr x) = Just x
+justIdentOf (Cn x) = Just x
+justIdentOf _ = Nothing
+
+isMeta :: Term -> Bool
+isMeta (Meta _) = True
+isMeta _ = False
+
+mkMeta :: Int -> Term
+mkMeta = Meta . MetaSymb
+
+nextMeta :: MetaSymb -> MetaSymb
+nextMeta = int2meta . succ . metaSymbInt
+
+int2meta :: Int -> MetaSymb
+int2meta = MetaSymb
+
+metaSymbInt :: MetaSymb -> Int
+metaSymbInt (MetaSymb k) = k
+
+freshMeta :: [MetaSymb] -> MetaSymb
+freshMeta ms = MetaSymb (minimum [n | n <- [0..length ms], 
+                                      notElem n (map metaSymbInt ms)])
+
+mkFreshMetasInTrm :: [MetaSymb] -> Trm -> Trm
+mkFreshMetasInTrm metas = fst . rms minMeta where
+  rms meta trm = case trm of
+    Meta m  -> (Meta (MetaSymb meta), meta + 1)
+    App f a -> let (f',msf) = rms meta f 
+                   (a',msa) = rms msf a
+               in (App f' a', msa)
+    Prod x a b -> 
+               let (a',msa) = rms meta a 
+                   (b',msb) = rms msa b
+               in (Prod x a' b', msb)
+    Abs x b -> let (b',msb) = rms meta b in (Abs x b', msb)
+    _       -> (trm,meta)
+  minMeta = if null metas then 0 else (maximum (map metaSymbInt metas) + 1)
+
+-- | decides that a term has no metavariables
+isCompleteTerm :: Term -> Bool
+isCompleteTerm t = case t of
+  Meta _  -> False
+  Abs _ b -> isCompleteTerm b
+  App f a -> isCompleteTerm f && isCompleteTerm a
+  _       -> True 
+
+linTypeStr :: Type
+linTypeStr = mkRecType linLabel [typeStr] -- default lintype {s :: Str}
+
+linAsStr :: String -> Term
+linAsStr s = mkRecord linLabel [K s] -- default linearization {s = s}
+
+term2patt :: Term -> Err Patt
+term2patt trm = case termForm trm of
+  Ok ([], Vr x, []) -> return (PV x)
+  Ok ([], Val ty x, []) -> return (PVal ty x)
+  Ok ([], Con c, aa) -> do
+    aa' <- mapM term2patt aa
+    return (PC c aa')
+  Ok ([], QC p c, aa) -> do
+    aa' <- mapM term2patt aa
+    return (PP p c aa')
+
+  Ok ([], Q p c, []) -> do
+    return (PM p c)
+
+  Ok ([], R r, []) -> do
+    let (ll,aa) = unzipR r
+    aa' <- mapM term2patt aa
+    return (PR (zip ll aa'))
+  Ok ([],EInt i,[]) -> return $ PInt i
+  Ok ([],EFloat i,[]) -> return $ PFloat i
+  Ok ([],K s,   []) -> return $ PString s
+
+--- encodings due to excessive use of term-patt convs. AR 7/1/2005
+  Ok ([], Cn id, [Vr a,b]) | id == cAs -> do
+    b' <- term2patt b
+    return (PAs a b')
+  Ok ([], Cn id, [a]) | id == cNeg  -> do
+    a' <- term2patt a
+    return (PNeg a')
+  Ok ([], Cn id, [a]) | id == cRep -> do
+    a' <- term2patt a
+    return (PRep a')
+  Ok ([], Cn id, []) | id == cRep -> do
+    return PChar
+  Ok ([], Cn id,[K s]) | id == cChars  -> do
+    return $ PChars s
+  Ok ([], Cn id, [a,b]) | id == cSeq -> do
+    a' <- term2patt a
+    b' <- term2patt b
+    return (PSeq a' b')
+  Ok ([], Cn id, [a,b]) | id == cAlt -> do
+    a' <- term2patt a
+    b' <- term2patt b
+    return (PAlt a' b')
+
+  Ok ([], Cn c, []) -> do
+    return (PMacro c)
+
+  _ -> prtBad "no pattern corresponds to term" trm
+
+patt2term :: Patt -> Term
+patt2term pt = case pt of
+  PV x      -> Vr x
+  PW        -> Vr identW             --- not parsable, should not occur
+  PVal t i  -> Val t i
+  PMacro c  -> Cn c
+  PM p c    -> Q p c
+
+  PC c pp   -> mkApp (Con c) (map patt2term pp)
+  PP p c pp -> mkApp (QC p c) (map patt2term pp)
+
+  PR r      -> R [assign l (patt2term p) | (l,p) <- r] 
+  PT _ p    -> patt2term p
+  PInt i    -> EInt i
+  PFloat i  -> EFloat i
+  PString s -> K s 
+
+  PAs x p   -> appCons cAs    [Vr x, patt2term p]            --- an encoding
+  PChar     -> appCons cChar  []                             --- an encoding
+  PChars s  -> appCons cChars [K s]                          --- an encoding
+  PSeq a b  -> appCons cSeq   [(patt2term a), (patt2term b)] --- an encoding
+  PAlt a b  -> appCons cAlt   [(patt2term a), (patt2term b)] --- an encoding
+  PRep a    -> appCons cRep   [(patt2term a)]                --- an encoding
+  PNeg a    -> appCons cNeg   [(patt2term a)]                --- an encoding
+
+
+redirectTerm :: Ident -> Term -> Term
+redirectTerm n t = case t of
+  QC _ f -> QC n f
+  Q _ f  -> Q  n f
+  _ -> composSafeOp (redirectTerm n) t
+
+-- | to gather ultimate cases in a table; preserves pattern list
+allCaseValues :: Term -> [([Patt],Term)]
+allCaseValues trm = case unComputed trm of
+  T _ cs -> [(p:ps, t) | (p,t0) <- cs, (ps,t) <- allCaseValues t0]
+  _      -> [([],trm)]
+
+-- | to get a string from a term that represents a sequence of terminals
+strsFromTerm :: Term -> Err [Str]
+strsFromTerm t = case unComputed t of
+  K s   -> return [str s]
+  Empty -> return [str []]
+  C s t -> do
+    s' <- strsFromTerm s
+    t' <- strsFromTerm t
+    return [plusStr x y | x <- s', y <- t']
+  Glue s t -> do
+    s' <- strsFromTerm s
+    t' <- strsFromTerm t
+    return [glueStr x y | x <- s', y <- t']
+  Alts (d,vs) -> do
+    d0 <- strsFromTerm d
+    v0 <- mapM (strsFromTerm . fst) vs
+    c0 <- mapM (strsFromTerm . snd) vs
+    let vs' = zip v0 c0
+    return [strTok (str2strings def) vars | 
+              def  <- d0,
+              vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] | 
+                                                          vv <- combinations v0]
+           ]
+  FV ts -> mapM strsFromTerm ts >>= return . concat
+  Strs ts -> mapM strsFromTerm ts >>= return . concat  
+  Ready ss -> return [ss]
+  Alias _ _ d -> strsFromTerm d --- should not be needed...
+  _ -> prtBad "cannot get Str from term" t
+
+-- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg
+stringFromTerm :: Term -> String
+stringFromTerm = err id (ifNull "" (sstr . head)) . strsFromTerm
+
+
+-- | to define compositional term functions
+composSafeOp :: (Term -> Term) -> Term -> Term
+composSafeOp op trm = case composOp (mkMonadic op) trm of
+  Ok t -> t
+  _ -> error "the operation is safe isn't it ?"
+ where
+ mkMonadic f = return . f
+
+-- | to define compositional term functions
+composOp :: Monad m => (Term -> m Term) -> Term -> m Term
+composOp co trm = 
+ case trm of
+   App c a -> 
+     do c' <- co c
+        a' <- co a
+        return (App c' a')
+   Abs x b ->
+     do b' <- co b
+        return (Abs x b')
+   Prod x a b -> 
+     do a' <- co a
+        b' <- co b
+        return (Prod x a' b')
+   S c a -> 
+     do c' <- co c
+        a' <- co a
+        return (S c' a')
+   Table a c -> 
+     do a' <- co a
+        c' <- co c
+        return (Table a' c')
+   R r -> 
+     do r' <- mapAssignM co r
+        return (R r')
+   RecType r -> 
+     do r' <- mapPairListM (co . snd) r
+        return (RecType r')
+   P t i ->
+     do t' <- co t
+        return (P t' i)
+   PI t i j ->
+     do t' <- co t
+        return (PI t' i j)
+   ExtR a c -> 
+     do a' <- co a
+        c' <- co c
+        return (ExtR a' c')
+
+   T i cc -> 
+     do cc' <- mapPairListM (co . snd) cc
+        i'  <- changeTableType co i
+        return (T i' cc')
+
+   TSh i cc -> 
+     do cc' <- mapPairListM (co . snd) cc
+        i'  <- changeTableType co i
+        return (TSh i' cc')
+
+   Eqs cc -> 
+     do cc' <- mapPairListM (co . snd) cc
+        return (Eqs cc')
+
+   V ty vs ->
+     do ty' <- co ty
+        vs' <- mapM co vs
+        return (V ty' vs')
+
+   Val ty i ->
+     do ty' <- co ty
+        return (Val ty' i)
+
+   Let (x,(mt,a)) b -> 
+     do a'  <- co a
+        mt' <- case mt of
+                 Just t -> co t >>= (return . Just) 
+                 _ -> return mt
+        b'  <- co b
+        return (Let (x,(mt',a')) b')
+   Alias c ty d -> 
+     do v <- co d
+        ty' <- co ty
+        return $ Alias c ty' v
+   C s1 s2 -> 
+     do v1 <- co s1 
+        v2 <- co s2
+        return (C v1 v2)
+   Glue s1 s2 -> 
+     do v1 <- co s1
+        v2 <- co s2
+        return (Glue v1 v2)
+   Alts (t,aa) ->
+     do t' <- co t
+        aa' <- mapM (pairM co) aa
+        return (Alts (t',aa'))
+   FV ts -> mapM co ts >>= return . FV
+   Strs tt -> mapM co tt >>= return . Strs
+
+   EPattType ty -> 
+     do ty' <- co ty
+        return (EPattType ty')
+
+   _ -> return trm -- covers K, Vr, Cn, Sort, EPatt
+
+getTableType :: TInfo -> Err Type
+getTableType i = case i of
+  TTyped ty -> return ty
+  TComp ty  -> return ty
+  TWild ty  -> return ty
+  _ -> Bad "the table is untyped"
+
+changeTableType :: Monad m => (Type -> m Type) -> TInfo -> m TInfo
+changeTableType co i = case i of
+    TTyped ty -> co ty >>= return . TTyped
+    TComp ty  -> co ty >>= return . TComp
+    TWild ty  -> co ty >>= return . TWild
+    _ -> return i
+
+collectOp :: (Term -> [a]) -> Term -> [a]
+collectOp co trm = case trm of
+  App c a    -> co c ++ co a 
+  Abs _ b    -> co b
+  Prod _ a b -> co a ++ co b 
+  S c a      -> co c ++ co a
+  Table a c  -> co a ++ co c
+  ExtR a c   -> co a ++ co c
+  R r        -> concatMap (\ (_,(mt,a)) -> maybe [] co mt ++ co a) r 
+  RecType r  -> concatMap (co . snd) r 
+  P t i      -> co t
+  T _ cc     -> concatMap (co . snd) cc -- not from patterns --- nor from type annot
+  TSh _ cc   -> concatMap (co . snd) cc -- not from patterns --- nor from type annot
+  V _ cc     -> concatMap co         cc --- nor from type annot
+  Let (x,(mt,a)) b -> maybe [] co mt ++ co a ++ co b
+  C s1 s2    -> co s1 ++ co s2 
+  Glue s1 s2 -> co s1 ++ co s2 
+  Alts (t,aa) -> let (x,y) = unzip aa in co t ++ concatMap co (x ++ y)
+  FV ts      -> concatMap co ts
+  Strs tt    -> concatMap co tt
+  _ -> [] -- covers K, Vr, Cn, Sort, Ready
+
+-- | to find the word items in a term
+wordsInTerm :: Term -> [String]
+wordsInTerm trm = filter (not . null) $ case trm of
+   K s     -> [s]
+   S c _   -> wo c
+   Alts (t,aa) -> wo t ++ concatMap (wo . fst) aa
+   Ready s -> allItems s
+   _       -> collectOp wo trm
+ where wo = wordsInTerm
+
+noExist :: Term
+noExist = FV []
+
+defaultLinType :: Type
+defaultLinType = mkRecType linLabel [typeStr]
+
+metaTerms :: [Term]
+metaTerms = map (Meta . MetaSymb) [0..]
+
+-- | from GF1, 20\/9\/2003
+isInOneType :: Type -> Bool
+isInOneType t = case t of
+  Prod _ a b -> a == b
+  _ -> False
+
+-- normalize records and record types; put s first
+
+sortRec :: [(Label,a)] -> [(Label,a)]
+sortRec = sortBy ordLabel where
+  ordLabel (r1,_) (r2,_) = case (prt r1, prt r2) of
+    ("s",_) -> LT
+    (_,"s") -> GT
+    (s1,s2) -> compare s1 s2
+
+
+
diff --git a/src/GF/Grammar/PatternMatch.hs b/src/GF/Grammar/PatternMatch.hs
new file mode 100644
index 000000000..b96d35b93
--- /dev/null
+++ b/src/GF/Grammar/PatternMatch.hs
@@ -0,0 +1,155 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : PatternMatch
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/10/12 12:38:29 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.7 $
+--
+-- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003
+-----------------------------------------------------------------------------
+
+module GF.Grammar.PatternMatch (matchPattern,
+		     testOvershadow, 
+		     findMatch
+		    ) where
+
+import GF.Data.Operations
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Grammar.Macros
+import GF.Grammar.PrGrammar
+
+import Data.List
+import Control.Monad
+
+
+matchPattern :: [(Patt,Term)] -> Term -> Err (Term, Substitution)
+matchPattern pts term = 
+  if not (isInConstantForm term)
+    then prtBad "variables occur in" term
+  else 
+    errIn ("trying patterns" +++ unwords (intersperse "," (map (prt . fst) pts))) $
+    findMatch [([p],t) | (p,t) <- pts] [term]
+
+testOvershadow :: [Patt] -> [Term] -> Err [Patt]
+testOvershadow pts vs = do
+  let numpts = zip pts [0..]
+  let cases  = [(p,EInt i) | (p,i) <- numpts]
+  ts <- mapM (liftM fst . matchPattern cases) vs
+  return $ [p | (p,i) <- numpts, notElem i [i | EInt i <- ts] ]
+
+findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution)
+findMatch cases terms = case cases of
+   [] -> Bad $"no applicable case for" +++ unwords (intersperse "," (map prt terms))
+   (patts,_):_ | length patts /= length terms -> 
+       Bad ("wrong number of args for patterns :" +++ 
+            unwords (map prt patts) +++ "cannot take" +++ unwords (map prt terms))
+   (patts,val):cc -> case mapM tryMatch (zip patts terms) of
+       Ok substs -> return (val, concat substs)
+       _         -> findMatch cc terms
+
+tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
+tryMatch (p,t) = do 
+  t' <- termForm t
+  trym p t'
+ where
+  isInConstantFormt = True -- tested already
+  trym p t' =
+    case (p,t') of
+      (PVal _ i, (_,Val _ j,_)) 
+          | i == j -> return []
+          | otherwise -> Bad $ "no match of values"
+      (_,(x,Empty,y)) -> trym p (x,K [],y)   -- because "" = [""] = []
+      (PV IW, _) | isInConstantFormt -> return [] -- optimization with wildcard
+      (PV x,  _) | isInConstantFormt -> return [(x,t)]
+      (PString s, ([],K i,[])) | s==i -> return []
+      (PInt s, ([],EInt i,[])) | s==i -> return []
+      (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
+      (PC p pp, ([], Con f, tt)) | 
+            p `eqStrIdent` f && length pp == length tt ->
+         do matches <- mapM tryMatch (zip pp tt)
+            return (concat matches)
+
+      (PP q p pp, ([], QC r f, tt)) | 
+            -- q `eqStrIdent` r &&  --- not for inherited AR 10/10/2005
+            p `eqStrIdent` f && length pp == length tt ->
+         do matches <- mapM tryMatch (zip pp tt)
+            return (concat matches)
+      ---- hack for AppPredef bug
+      (PP q p pp, ([], Q r f, tt)) | 
+            -- q `eqStrIdent` r && --- 
+            p `eqStrIdent` f && length pp == length tt ->
+         do matches <- mapM tryMatch (zip pp tt)
+            return (concat matches)
+
+      (PR r, ([],R r',[])) |
+            all (`elem` map fst r') (map fst r) ->
+         do matches <- mapM tryMatch 
+                            [(p,snd a) | (l,p) <- r, let Just a = lookup l r']
+            return (concat matches)
+      (PT _ p',_) -> trym p' t'
+      (_, ([],Alias _ _ d,[])) -> tryMatch (p,d)
+
+--      (PP (IC "Predef") (IC "CC") [p1,p2], ([],K s, [])) -> do
+
+      (PAs x p',_) -> do
+         subst <- trym p' t'
+         return $ (x,t) : subst
+
+      (PAlt p1 p2,_) -> checks [trym p1 t', trym p2 t']
+
+      (PNeg p',_) -> case tryMatch (p',t) of
+        Bad _ -> return []
+        _ -> prtBad "no match with negative pattern" p
+
+      (PSeq p1 p2, ([],K s, [])) -> do
+         let cuts = [splitAt n s | n <- [0 .. length s]] 
+         matches <- checks [mapM tryMatch [(p1,K s1),(p2,K s2)] | (s1,s2) <- cuts]
+         return (concat matches)
+
+      (PRep p1, ([],K s, [])) -> checks [
+         trym (foldr (const (PSeq p1)) (PString "") 
+           [1..n]) t' | n <- [0 .. length s]
+        ] >>
+        return []
+
+      (PChar,  ([],K [_], [])) -> return []
+      (PChars cs, ([],K [c], [])) | elem c cs -> return []
+
+      _ -> prtBad "no match in case expr for" t
+  
+isInConstantForm :: Term -> Bool
+isInConstantForm trm = case trm of
+    Cn _     -> True
+    Con _    -> True
+    Q _ _    -> True
+    QC _ _   -> True
+    Abs _ _  -> True
+    App c a  -> isInConstantForm c && isInConstantForm a
+    R r      -> all (isInConstantForm . snd . snd) r
+    K _      -> True
+    Empty    -> True
+    Alias _ _ t -> isInConstantForm t
+    EInt _   -> True
+    _       -> False ---- isInArgVarForm trm
+
+varsOfPatt :: Patt -> [Ident]
+varsOfPatt p = case p of
+  PV x -> [x | not (isWildIdent x)]
+  PC _ ps -> concat $ map varsOfPatt ps
+  PP _ _ ps -> concat $ map varsOfPatt ps
+  PR r    -> concat $ map (varsOfPatt . snd) r
+  PT _ q -> varsOfPatt q
+  _ -> []
+
+-- | to search matching parameter combinations in tables
+isMatchingForms :: [Patt] -> [Term] -> Bool
+isMatchingForms ps ts = all match (zip ps ts') where
+  match (PC c cs, (Cn d, ds)) = c == d && isMatchingForms cs ds
+  match _ = True
+  ts' = map appForm ts
+
diff --git a/src/GF/Grammar/PrGrammar.hs b/src/GF/Grammar/PrGrammar.hs
new file mode 100644
index 000000000..c1593dd63
--- /dev/null
+++ b/src/GF/Grammar/PrGrammar.hs
@@ -0,0 +1,279 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : PrGrammar
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/09/04 11:45:38 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.16 $
+--
+-- AR 7\/12\/1999 - 1\/4\/2000 - 10\/5\/2003
+--
+-- printing and prettyprinting class
+--
+-- 8\/1\/2004:
+-- Usually followed principle: 'prt_' for displaying in the editor, 'prt'
+-- in writing grammars to a file. For some constructs, e.g. 'prMarkedTree',
+-- only the former is ever needed.
+-----------------------------------------------------------------------------
+
+module GF.Grammar.PrGrammar (Print(..),
+		  prtBad,
+		  prGrammar, prModule,
+		  prContext, prParam,
+		  prQIdent, prQIdent_,
+		  prRefinement, prTermOpt,
+		  prt_Tree, prMarkedTree, prTree,
+		  tree2string, prprTree,
+		  prConstrs, prConstraints, 
+		  prMetaSubst, prEnv, prMSubst, 
+		  prExp, prOperSignature,
+                  lookupIdent, lookupIdentInfo, lookupIdentInfoIn,
+                  prTermTabular
+		 ) where
+
+import GF.Data.Operations
+import GF.Data.Zipper
+import GF.Grammar.Grammar
+import GF.Infra.Modules
+import qualified GF.Source.PrintGF as P
+import GF.Grammar.Values
+import GF.Source.GrammarToSource
+--- import GFC (CanonGrammar) --- cycle of modules
+
+import GF.Infra.Option
+import GF.Infra.Ident
+import GF.Data.Str
+
+import GF.Infra.CompactPrint
+
+import Data.List (intersperse)
+
+class Print a where
+  prt  :: a -> String
+  -- | printing with parentheses, if needed
+  prt2 :: a -> String
+  -- | pretty printing
+  prpr :: a -> [String]
+  -- | printing without ident qualifications
+  prt_ :: a -> String 
+  prt2 = prt
+  prt_ = prt
+  prpr = return . prt
+
+-- 8/1/2004
+--- Usually followed principle: prt_ for displaying in the editor, prt
+--- in writing grammars to a file. For some constructs, e.g. prMarkedTree,
+--- only the former is ever needed.
+
+-- | to show terms etc in error messages
+prtBad :: Print a => String -> a -> Err b
+prtBad s a = Bad (s +++ prt a)
+
+pprintTree :: P.Print a => a -> String
+pprintTree = compactPrint . P.printTree
+
+prGrammar :: SourceGrammar -> String
+prGrammar = pprintTree . trGrammar
+
+prModule :: (Ident, SourceModInfo) -> String
+prModule  = pprintTree . trModule
+
+instance Print Term where
+  prt = pprintTree . trt
+  prt_ = prExp
+
+instance Print Ident where
+  prt = pprintTree . tri
+
+instance Print Patt where
+  prt = pprintTree . trp
+  prt_ = prt . unqual where
+    unqual p = case p of
+      PP _ c [] -> PV c --- to remove curlies
+      PP _ c ps -> PC c (map unqual ps)
+      PC   c ps -> PC c (map unqual ps)
+      _ -> p ---- records
+
+instance Print Label where
+  prt = pprintTree . trLabel
+
+instance Print MetaSymb where
+  prt (MetaSymb i) = "?" ++ show i
+
+prParam :: Param -> String
+prParam (c,co) = prt c +++ prContext co
+
+prContext :: Context -> String
+prContext co = unwords $ map prParenth [prt x +++ ":" +++ prt t | (x,t) <- co]
+
+-- some GFC notions
+
+instance Print a => Print (Tr a) where
+  prt (Tr (n, trees)) = prt n +++ unwords (map prt2 trees)
+  prt2 t@(Tr (_,args)) = if null args then prt t else prParenth (prt t)
+
+-- | we cannot define the method prt_ in this way 
+prt_Tree :: Tree -> String
+prt_Tree = prt_ . tree2exp
+
+instance Print TrNode where
+  prt (N (bi,at,vt,(cs,ms),_)) = 
+    prBinds bi ++ 
+    prt at +++ ":" +++ prt vt 
+    +++ prConstraints cs +++ prMetaSubst ms
+  prt_ (N (bi,at,vt,(cs,ms),_)) = 
+    prBinds bi ++ 
+    prt_ at +++ ":" +++ prt_ vt 
+    +++ prConstraints cs +++ prMetaSubst ms
+
+prMarkedTree :: Tr (TrNode,Bool) -> [String]
+prMarkedTree = prf 1 where
+  prf ind t@(Tr (node, trees)) = 
+    prNode ind node : concatMap (prf (ind + 2)) trees
+  prNode ind node = case node of
+    (n, False) -> indent ind (prt_ n)
+    (n, _)     -> '*' : indent (ind - 1) (prt_ n)
+
+prTree :: Tree -> [String]
+prTree = prMarkedTree . mapTr (\n -> (n,False))
+
+-- | a pretty-printer for parsable output
+tree2string :: Tree -> String
+tree2string = unlines . prprTree
+
+prprTree :: Tree -> [String]
+prprTree = prf False where
+  prf par t@(Tr (node, trees)) = 
+    parIf par (prn node : concat [prf (ifPar t) t | t <- trees])
+  prn (N (bi,at,_,_,_)) = prb bi ++ prt_ at
+  prb [] = ""
+  prb bi = "\\" ++ concat (intersperse "," (map (prt_ . fst) bi)) ++ " -> "
+  parIf par (s:ss) = map (indent 2) $
+                         if par 
+                            then ('(':s) : ss ++ [")"] 
+                            else s:ss
+  ifPar (Tr (N ([],_,_,_,_), [])) = False
+  ifPar _ = True
+
+
+-- auxiliaries
+
+prConstraints :: Constraints -> String
+prConstraints = concat . prConstrs
+
+prMetaSubst :: MetaSubst -> String
+prMetaSubst = concat . prMSubst
+  
+prEnv :: Env -> String
+---- prEnv [] = prCurly "" ---- for debugging
+prEnv e = concatMap (\ (x,t) -> prCurly (prt x ++ ":=" ++ prt t)) e
+
+prConstrs :: Constraints -> [String]
+prConstrs = map (\ (v,w) -> prCurly (prt v ++ "<>" ++ prt w))
+
+prMSubst :: MetaSubst -> [String]
+prMSubst = map (\ (m,e) -> prCurly ("?" ++ show m ++ "=" ++ prt e))
+
+prBinds bi = if null bi 
+                then [] 
+                else "\\" ++ concat (intersperse "," (map prValDecl bi)) +++ "-> "
+ where
+   prValDecl (x,t) = prParenth (prt_ x +++ ":" +++ prt_ t)
+
+instance Print Val where
+  prt (VGen i x) = prt x ++ "{-" ++ show i ++ "-}" ---- latter part for debugging
+  prt (VApp u v) = prt u +++ prv1 v
+  prt (VCn mc) = prQIdent_ mc
+  prt (VClos env e) = case e of
+    Meta _ -> prt_ e ++ prEnv env
+    _      -> prt_ e ---- ++ prEnv env ---- for debugging
+  prt VType = "Type"
+ 
+prv1 v = case v of
+  VApp _ _  -> prParenth $ prt v
+  VClos _ _ -> prParenth $ prt v
+  _ -> prt v
+
+instance Print Atom where
+  prt (AtC f) = prQIdent f
+  prt (AtM i) = prt i
+  prt (AtV i) = prt i
+  prt (AtL s) = prQuotedString s
+  prt (AtI i) = show i
+  prt (AtF i) = show i
+  prt_ (AtC (_,f)) = prt f 
+  prt_ a = prt a
+
+prQIdent :: QIdent -> String
+prQIdent (m,f) = prt m ++ "." ++ prt f
+
+prQIdent_ :: QIdent -> String
+prQIdent_ (_,f) = prt f
+
+-- | print terms without qualifications
+prExp :: Term -> String
+prExp e = case e of
+  App f a    -> pr1 f +++ pr2 a
+  Abs x b    -> "\\" ++ prt x +++ "->" +++ prExp b
+  Prod x a b -> "(\\" ++ prt x +++ ":" +++ prExp a ++ ")" +++ "->" +++ prExp b
+  Q _ c      -> prt c
+  QC _ c     -> prt c  
+  _ -> prt e
+ where
+   pr1 e = case e of
+     Abs _ _    -> prParenth $ prExp e
+     Prod _ _ _ -> prParenth $ prExp e
+     _ -> prExp e
+   pr2 e = case e of
+     App _ _ -> prParenth $ prExp e
+     _ -> pr1 e
+
+-- | option @-strip@ strips qualifications
+prTermOpt :: Options -> Term -> String
+prTermOpt opts = if PrinterStrip `elem` flag optPrinter opts then prt else prExp
+
+-- | to get rid of brackets in the editor
+prRefinement :: Term -> String
+prRefinement t = case t of
+    Q m c  -> prQIdent (m,c)
+    QC m c -> prQIdent (m,c)
+    _ -> prt t
+
+prOperSignature :: (QIdent,Type) -> String
+prOperSignature (f, t) = prQIdent f +++ ":" +++ prt t
+
+-- to look up a constant etc in a search tree --- why here? AR 29/5/2008
+
+lookupIdent :: Ident -> BinTree Ident b -> Err b
+lookupIdent c t = case lookupTree prt c t of
+  Ok v -> return v
+  _ -> prtBad "unknown identifier" c
+
+lookupIdentInfo :: Module Ident a -> Ident -> Err a
+lookupIdentInfo mo i = lookupIdent i (jments mo)
+
+lookupIdentInfoIn :: Module Ident a -> Ident -> Ident -> Err a
+lookupIdentInfoIn mo m i = 
+  err (\s -> Bad (s +++ "in module" +++ prt m)) return $ lookupIdentInfo mo i
+
+
+--- printing cc command output AR 26/5/2008
+
+prTermTabular :: Term -> [(String,String)]
+prTermTabular = pr where
+  pr t = case t of
+    R rs   -> 
+      [(prt_ lab +++ "." +++ path, str) | (lab,(_,val)) <- rs, (path,str) <- pr val]
+    T _ cs -> 
+      [(prt_ lab +++"=>" +++ path, str) | (lab,   val)  <- cs, (path,str) <- pr val]
+    V _ cs -> 
+      [("#" ++ show i +++"=>" +++ path, str) | (i,val)  <- zip [0..] cs, (path,str) <- pr val]
+    _ -> [([],ps t)]
+  ps t = case t of
+    K s   -> s
+    C s u -> ps s +++ ps u
+    FV ts -> unwords (intersperse "/" (map ps ts))
+    _ -> prt_ t 
diff --git a/src/GF/Grammar/Predef.hs b/src/GF/Grammar/Predef.hs
new file mode 100644
index 000000000..71f152f92
--- /dev/null
+++ b/src/GF/Grammar/Predef.hs
@@ -0,0 +1,177 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GF.Grammar.Predef
+-- Maintainer  : kr.angelov
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- Predefined identifiers and labels which the compiler knows
+----------------------------------------------------------------------
+
+
+module GF.Grammar.Predef
+          ( cType
+          , cPType
+          , cTok
+          , cStr
+          , cStrs
+          , cPredefAbs, cPredef
+          , cInt
+          , cFloat
+          , cString
+          , cInts
+          , cPBool
+          , cErrorType
+          , cOverload
+          , cUndefinedType
+          , isPredefCat
+
+          , cPTrue, cPFalse
+
+          , cLength, cDrop, cTake, cTk, cDp, cEqStr, cOccur
+          , cOccurs, cEqInt, cLessInt, cPlus, cShow, cRead
+          , cToStr, cMapStr, cError
+
+          -- hacks
+          , cMeta, cAs, cChar, cChars, cSeq, cAlt, cRep
+          , cNeg, cCNC, cConflict
+          ) where
+
+import GF.Infra.Ident
+import qualified Data.ByteString.Char8 as BS
+
+cType :: Ident
+cType = identC (BS.pack "Type")
+
+cPType :: Ident
+cPType = identC (BS.pack "PType")
+
+cTok :: Ident
+cTok = identC (BS.pack "Tok")
+
+cStr :: Ident
+cStr = identC (BS.pack "Str")
+
+cStrs :: Ident
+cStrs = identC (BS.pack "Strs")
+
+cPredefAbs :: Ident
+cPredefAbs = identC (BS.pack "PredefAbs")
+
+cPredef :: Ident
+cPredef = identC (BS.pack "Predef")
+
+cInt :: Ident
+cInt = identC (BS.pack "Int")
+
+cFloat :: Ident
+cFloat = identC (BS.pack "Float")
+
+cString :: Ident
+cString = identC (BS.pack "String")
+
+cInts :: Ident
+cInts = identC (BS.pack "Ints")
+
+cPBool :: Ident
+cPBool = identC (BS.pack "PBool")
+
+cErrorType :: Ident
+cErrorType = identC (BS.pack "Error")
+
+cOverload :: Ident
+cOverload = identC (BS.pack "overload")
+
+cUndefinedType :: Ident
+cUndefinedType = identC (BS.pack "UndefinedType")
+
+isPredefCat :: Ident -> Bool
+isPredefCat c = elem c [cInt,cString,cFloat]
+
+cPTrue :: Ident
+cPTrue  = identC (BS.pack "PTrue")
+
+cPFalse :: Ident
+cPFalse = identC (BS.pack "PFalse")
+
+cLength :: Ident
+cLength = identC (BS.pack "length")
+
+cDrop :: Ident
+cDrop = identC (BS.pack "drop")
+
+cTake :: Ident
+cTake = identC (BS.pack "take")
+
+cTk :: Ident
+cTk = identC (BS.pack "tk")
+
+cDp :: Ident
+cDp = identC (BS.pack "dp")
+
+cEqStr :: Ident
+cEqStr = identC (BS.pack "eqStr")
+
+cOccur :: Ident
+cOccur = identC (BS.pack "occur")
+
+cOccurs :: Ident
+cOccurs = identC (BS.pack "occurs")
+
+cEqInt :: Ident
+cEqInt = identC (BS.pack "eqInt")
+
+cLessInt :: Ident
+cLessInt = identC (BS.pack "lessInt")
+
+cPlus :: Ident
+cPlus = identC (BS.pack "plus")
+
+cShow :: Ident
+cShow = identC (BS.pack "show")
+
+cRead :: Ident
+cRead = identC (BS.pack "read")
+
+cToStr :: Ident
+cToStr = identC (BS.pack "toStr")
+
+cMapStr :: Ident
+cMapStr = identC (BS.pack "mapStr")
+
+cError :: Ident
+cError = identC (BS.pack "error")
+
+
+--- hacks: dummy identifiers used in various places
+--- Not very nice!
+
+cMeta :: Ident
+cMeta = identC (BS.singleton '?')
+
+cAs :: Ident
+cAs = identC (BS.singleton '@')
+
+cChar :: Ident
+cChar = identC (BS.singleton '?')
+
+cChars :: Ident
+cChars = identC (BS.pack "[]")
+
+cSeq :: Ident
+cSeq = identC (BS.pack "+")
+
+cAlt :: Ident
+cAlt = identC (BS.pack "|")
+
+cRep :: Ident
+cRep = identC (BS.pack "*")
+
+cNeg :: Ident
+cNeg = identC (BS.pack "-")
+
+cCNC :: Ident
+cCNC = identC (BS.pack "CNC")
+
+cConflict :: Ident
+cConflict = IC (BS.pack "#conflict")
diff --git a/src/GF/Grammar/ReservedWords.hs b/src/GF/Grammar/ReservedWords.hs
new file mode 100644
index 000000000..b440141d6
--- /dev/null
+++ b/src/GF/Grammar/ReservedWords.hs
@@ -0,0 +1,44 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : ReservedWords
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:22:28 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.5 $
+--
+-- reserved words of GF. (c) Aarne Ranta 19\/3\/2002 under Gnu GPL.
+-- modified by Markus Forsberg 9\/4. 
+-- modified by AR 12\/6\/2003 for GF2 and GFC
+-----------------------------------------------------------------------------
+
+module GF.Grammar.ReservedWords (isResWord, isResWordGFC) where
+
+import Data.List
+
+
+isResWord :: String -> Bool
+isResWord s = isInTree s resWordTree
+
+resWordTree :: BTree
+resWordTree = 
+--  mapTree fst $ sorted2tree $ flip zip (repeat ()) $ sort allReservedWords
+--  nowadays obtained from LexGF.hs
+    B "let" (B "data" (B "Type" (B "Str" (B "PType" (B "Lin" N N) N) (B "Tok" (B "Strs" N N) N)) (B "cat" (B "case" (B "abstract" N N) N) (B "concrete" N N))) (B "in" (B "fn" (B "flags" (B "def" N N) N) (B "grammar" (B "fun" N N) N)) (B "instance" (B "incomplete" (B "include" N N) N) (B "interface" N N)))) (B "pre" (B "open" (B "lindef" (B "lincat" (B "lin" N N) N) (B "of" (B "lintype" N N) N)) (B "param" (B "out" (B "oper" N N) N) (B "pattern" N N))) (B "transfer" (B "reuse" (B "resource" (B "printname" N N) N) (B "table" (B "strs" N N) N)) (B "where" (B "variants" (B "union" N N) N) (B "with" N N))))
+
+isResWordGFC :: String -> Bool
+isResWordGFC s = isInTree s $
+  B "of" (B "fun" (B "concrete" (B "cat" (B "abstract" N N) N) (B "flags" N N)) (B "lin" (B "in" N N) (B "lincat" N N))) (B "resource" (B "param" (B "oper" (B "open" N N) N) (B "pre" N N)) (B "table" (B "strs" N N) (B "variants" N N)))
+
+data BTree = N | B String BTree BTree deriving (Show)
+
+isInTree :: String -> BTree -> Bool
+isInTree x tree = case tree of
+ N -> False
+ B a left right 
+   | x < a  -> isInTree x left
+   | x > a  -> isInTree x right
+   | x == a -> True
+
diff --git a/src/GF/Grammar/Unify.hs b/src/GF/Grammar/Unify.hs
new file mode 100644
index 000000000..588c1b306
--- /dev/null
+++ b/src/GF/Grammar/Unify.hs
@@ -0,0 +1,96 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Unify
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:22:31 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.4 $
+--
+-- (c) Petri Mäenpää & Aarne Ranta, 1998--2001
+--
+-- brute-force adaptation of the old-GF program AR 21\/12\/2001 ---
+-- the only use is in 'TypeCheck.splitConstraints'
+-----------------------------------------------------------------------------
+
+module GF.Grammar.Unify (unifyVal) where
+
+import GF.Grammar.Abstract
+
+import GF.Data.Operations
+
+import Data.List (partition)
+
+unifyVal :: Constraints -> Err (Constraints,MetaSubst)
+unifyVal cs0 = do
+  let (cs1,cs2) = partition notSolvable cs0 
+  let (us,vs) = unzip cs1
+  us' <- mapM val2exp us
+  vs' <- mapM val2exp vs
+  let (ms,cs) = unifyAll (zip us' vs') []
+  return (cs1 ++ [(VClos [] t, VClos [] u) | (t,u) <- cs], 
+          [(m,          VClos [] t) | (m,t) <- ms])
+ where
+   notSolvable (v,w) = case (v,w) of -- don't consider nonempty closures
+     (VClos (_:_) _,_) -> True
+     (_,VClos (_:_) _) -> True
+     _ -> False
+
+type Unifier = [(MetaSymb, Trm)]
+type Constrs = [(Trm, Trm)]
+
+unifyAll :: Constrs -> Unifier -> (Unifier,Constrs)
+unifyAll [] g = (g, [])
+unifyAll ((a@(s, t)) : l) g =
+  let (g1, c) = unifyAll l g
+  in case unify s t g1 of
+       Ok g2  -> (g2, c)
+       _      -> (g1, a : c)
+
+unify :: Trm -> Trm -> Unifier -> Err Unifier
+unify e1 e2 g = 
+ case (e1, e2) of 
+  (Meta s, t) -> do
+     tg <- subst_all g t
+     let sg = maybe e1 id (lookup s g)
+     if (sg == Meta s) then extend g s tg else unify sg tg g 
+  (t, Meta s) -> unify e2 e1 g
+  (Q _ a, Q _ b) | (a == b)      -> return g ---- qualif?
+  (QC _ a, QC _ b) | (a == b)    -> return g ----
+  (Vr x, Vr y) | (x == y)        -> return g 
+  (Abs x b, Abs y c)               -> do let c' = substTerm [x] [(y,Vr x)] c 
+                                         unify b c' g
+  (App c a, App d b)            -> case unify c d g of 
+                                     Ok g1 -> unify a b g1 
+                                     _       -> prtBad "fail unify" e1
+  _                             -> prtBad "fail unify" e1
+
+extend :: Unifier -> MetaSymb -> Trm -> Err Unifier
+extend g s t | (t == Meta s) = return g  
+             | occCheck s t  = prtBad "occurs check" t
+             | True          = return ((s, t) : g) 
+
+subst_all :: Unifier -> Trm -> Err Trm
+subst_all s u =
+ case (s,u) of
+  ([], t)  -> return t
+  (a : l, t) -> do
+     t' <- (subst_all l t) --- successive substs - why ?
+     return $ substMetas [a] t'
+
+substMetas :: [(MetaSymb,Trm)] -> Trm -> Trm
+substMetas subst trm = case trm of
+   Meta x -> case lookup x subst of
+     Just t -> t
+     _ -> trm
+   _ -> composSafeOp (substMetas subst) trm
+
+occCheck :: MetaSymb -> Trm -> Bool
+occCheck s u = case u of
+    Meta v  -> s == v
+    App c a -> occCheck s c || occCheck s a
+    Abs x b -> occCheck s b
+    _       -> False
+
diff --git a/src/GF/Grammar/Values.hs b/src/GF/Grammar/Values.hs
new file mode 100644
index 000000000..ab7d874da
--- /dev/null
+++ b/src/GF/Grammar/Values.hs
@@ -0,0 +1,91 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Values
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:22:32 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.7 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Grammar.Values (-- * values used in TC type checking
+	       Exp, Val(..), Env,
+	       -- * annotated tree used in editing
+	       Tree, TrNode(..), Atom(..), Binds, Constraints, MetaSubst,
+	       -- * for TC
+	       valAbsInt, valAbsFloat, valAbsString, vType,
+	       isPredefCat,
+	       eType, tree2exp, loc2treeFocus
+	      ) where
+
+import GF.Data.Operations
+import GF.Data.Zipper
+
+import GF.Infra.Ident
+import GF.Grammar.Grammar
+import GF.Grammar.Predef
+
+-- values used in TC type checking
+
+type Exp = Term
+
+data Val = VGen Int Ident | VApp Val Val | VCn QIdent | VType | VClos Env Exp 
+  deriving (Eq,Show)
+
+type Env = [(Ident,Val)]
+
+-- annotated tree used in editing
+
+type Tree = Tr TrNode
+
+newtype TrNode = N (Binds,Atom,Val,(Constraints,MetaSubst),Bool) 
+  deriving (Eq,Show)
+
+data Atom = 
+  AtC Fun | AtM MetaSymb | AtV Ident | AtL String | AtI Integer | AtF Double
+  deriving (Eq,Show)
+
+type Binds = [(Ident,Val)]
+type Constraints = [(Val,Val)]
+type MetaSubst = [(MetaSymb,Val)]
+
+-- for TC
+
+valAbsInt :: Val
+valAbsInt = VCn (cPredefAbs, cInt)
+
+valAbsFloat :: Val
+valAbsFloat = VCn (cPredefAbs, cFloat)
+
+valAbsString :: Val
+valAbsString = VCn (cPredefAbs, cString)
+
+vType :: Val
+vType = VType
+
+eType :: Exp
+eType = Sort cType
+
+tree2exp :: Tree -> Exp
+tree2exp (Tr (N (bi,at,_,_,_),ts)) = foldr Abs (foldl App at' ts') bi' where
+  at' = case at of
+    AtC (m,c) -> Q m c
+    AtV i -> Vr i
+    AtM m -> Meta m
+    AtL s -> K s
+    AtI s -> EInt s
+    AtF s -> EFloat s
+  bi' = map fst bi
+  ts' = map tree2exp ts
+
+loc2treeFocus :: Loc TrNode -> Tree
+loc2treeFocus (Loc (Tr (a,ts),p)) = 
+  loc2tree (Loc (Tr (mark a, map (mapTr nomark) ts), mapPath nomark p)) 
+ where 
+   (mark, nomark) = (\(N (a,b,c,d,_)) -> N(a,b,c,d,True), 
+                     \(N (a,b,c,d,_)) -> N(a,b,c,d,False))
+