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

9 files changed, 2156 insertions, 0 deletions

diff --git a/src-3.0/GF/Devel/Grammar/AppPredefined.hs b/src-3.0/GF/Devel/Grammar/AppPredefined.hs
new file mode 100644
index 000000000..c8d2988fd
--- /dev/null
+++ b/src-3.0/GF/Devel/Grammar/AppPredefined.hs
@@ -0,0 +1,166 @@
+----------------------------------------------------------------------
+-- |
+-- 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.Devel.Grammar.AppPredefined (
+  isInPredefined, 
+  typPredefined, 
+  appPredefined
+  ) where
+
+import GF.Devel.Grammar.Grammar
+import GF.Devel.Grammar.Construct
+import GF.Devel.Grammar.Macros
+import GF.Devel.Grammar.PrGF (prt,prt_,prtBad)
+import GF.Infra.Ident
+
+import GF.Data.Operations
+
+
+-- 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 c@(IC f) = case f of
+  "Int"    -> return typePType
+  "Float"  -> return typePType
+  "Error"  -> return typeType
+  "Ints"   -> return $ mkFunType [cnPredef "Int"] typePType
+  "PBool"  -> return typePType
+  "error"  -> return $ mkFunType [typeStr] (cnPredef "Error")  -- non-can. of empty set
+  "PFalse" -> return $ cnPredef "PBool"
+  "PTrue"  -> return $ cnPredef "PBool"
+  "dp"     -> return $ mkFunType [cnPredef "Int",typeStr] typeStr
+  "drop"   -> return $ mkFunType [cnPredef "Int",typeStr] typeStr
+  "eqInt"  -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool")
+  "lessInt"-> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "PBool")
+  "eqStr"  -> return $ mkFunType [typeStr,typeStr] (cnPredef "PBool")
+  "length" -> return $ mkFunType [typeStr] (cnPredef "Int")
+  "occur"  -> return $ mkFunType [typeStr,typeStr] (cnPredef "PBool")
+  "occurs" -> return $ mkFunType [typeStr,typeStr] (cnPredef "PBool")
+  "plus"   -> return $ mkFunType [cnPredef "Int",cnPredef "Int"] (cnPredef "Int")
+----  "read"   -> (P : Type) -> Tok -> P
+  "show"   -> return $ mkProds -- (P : PType) -> P -> Tok
+    ([(identC "P",typePType),(wildIdent,Vr (identC "P"))],typeStr,[]) 
+  "toStr"  -> return $ mkProds -- (L : Type)  -> L -> Str
+    ([(identC "L",typeType),(wildIdent,Vr (identC "L"))],typeStr,[]) 
+  "mapStr" -> 
+    let ty = identC "L" in
+    return $ mkProds -- (L : Type)  -> (Str -> Str) -> L -> L
+    ([(ty,typeType),(wildIdent,mkFunType [typeStr] typeStr),(wildIdent,Vr ty)],Vr ty,[]) 
+  "take"   -> return $ mkFunType [cnPredef "Int",typeStr] typeStr
+  "tk"     -> return $ mkFunType [cnPredef "Int",typeStr] typeStr
+  _        -> prtBad "unknown in Predef:" c
+
+typPredefined c = prtBad "unknown in Predef:" c
+
+mkProds (cont,t,xx) = foldr (uncurry Prod) (mkApp t xx) cont
+
+appPredefined :: Term -> Err (Term,Bool)
+appPredefined t = case t of
+
+  App f x0 -> do
+   (x,_) <- appPredefined x0
+   case f of
+    -- one-place functions
+    Q (IC "Predef") (IC f) -> case (f, x) of
+      ("length", K s) -> retb $ EInt $ toInteger $ length s
+      _ -> retb t ---- prtBad "cannot compute predefined" t
+
+    -- two-place functions
+    App (Q (IC "Predef") (IC f)) z0 -> do
+     (z,_) <- appPredefined z0
+     case (f, norm z, norm x) of
+      ("drop", EInt i, K s) -> retb $ K (drop (fi i) s)
+      ("take", EInt i, K s) -> retb $ K (take (fi i) s)
+      ("tk",   EInt i, K s) -> retb $ K (take (max 0 (length s - fi i)) s)
+      ("dp",   EInt i, K s) -> retb $ K (drop (max 0 (length s - fi i)) s)
+      ("eqStr",K s,    K t) -> retb $ if s == t then predefTrue else predefFalse
+      ("occur",K s,    K t) -> retb $ if substring s t then predefTrue else predefFalse
+      ("occurs",K s,   K t) -> retb $ if any (flip elem t) s then predefTrue else predefFalse
+      ("eqInt",EInt i, EInt j) -> retb $ if i==j then predefTrue else predefFalse
+      ("lessInt",EInt i, EInt j) -> retb $ if i<j then predefTrue else predefFalse
+      ("plus", EInt i, EInt j) -> retb $ EInt $ i+j
+      ("show", _, t) -> retb $ foldr C Empty $ map K $ words $ prt t
+      ("read", _, K s) -> retb $ str2tag s --- because of K, only works for atomic tags
+      ("toStr", _, t) -> trm2str t >>= retb
+
+      _ -> retb t ---- prtBad "cannot compute predefined" t
+
+    -- three-place functions
+    App (App (Q (IC "Predef") (IC f)) z0) y0 -> do
+     (y,_) <- appPredefined y0
+     (z,_) <- appPredefined z0
+     case (f, z, y, x) of
+      ("mapStr",ty,op,t) -> 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 (t,True)  -- no further computing needed
+   retf t = return (t,False) -- must be computed further
+   norm t = case t of
+     Empty -> K []
+     _ -> t
+   fi = fromInteger
+
+-- read makes variables into constants
+
+str2tag :: String -> Term
+str2tag s = case s of
+----  '\'' : cs -> mkCn $ pTrm $ init cs
+  _ -> Con $ IC s ---
+ where
+   mkCn t = case t of
+     Vr i -> Con i
+     App c a -> App (mkCn c) (mkCn a)
+     _ -> t
+
+
+predefTrue = Q (IC "Predef") (IC "PTrue")
+predefFalse = Q (IC "Predef") (IC "PFalse")
+
+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
+  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,typeStr] -> 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-3.0/GF/Devel/Grammar/Compute.hs b/src-3.0/GF/Devel/Grammar/Compute.hs
new file mode 100644
index 000000000..5e465c160
--- /dev/null
+++ b/src-3.0/GF/Devel/Grammar/Compute.hs
@@ -0,0 +1,380 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Compute
+-- 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.Devel.Grammar.Compute (
+  computeTerm,
+  computeTermCont,
+  computeTermRec
+  ) where
+
+import GF.Devel.Grammar.Grammar
+import GF.Devel.Grammar.Construct
+import GF.Devel.Grammar.Macros
+import GF.Devel.Grammar.Lookup
+import GF.Devel.Grammar.PrGF
+import GF.Devel.Grammar.PatternMatch
+import GF.Devel.Grammar.AppPredefined
+
+import GF.Infra.Ident
+import GF.Infra.Option
+
+--import GF.Grammar.Refresh
+--import GF.Grammar.Lockfield (isLockLabel) ----
+
+import GF.Data.Str ----
+import GF.Data.Operations
+
+import Data.List (nub,intersperse)
+import Control.Monad (liftM2, liftM)
+
+-- | computation of concrete syntax terms into normal form
+-- used mainly for partial evaluation
+computeTerm :: GF -> Term -> Err Term
+computeTerm g t = {- refreshTerm t >>= -} computeTermCont g [] t
+computeTermRec g t = {- refreshTerm t >>= -} computeTermOpt True g [] t
+
+computeTermCont :: GF -> Substitution -> Term -> Err Term
+computeTermCont = computeTermOpt False
+
+-- rec=True is used if it cannot be assumed that looked-up constants
+-- have already been computed (mainly with -optimize=noexpand in .gfr)
+
+computeTermOpt :: Bool -> GF -> Substitution -> Term -> Err Term
+computeTermOpt rec gr = comp where
+
+   comp g t = ---- errIn ("subterm" +++ prt t) $ --- for debugging 
+              case t of
+
+     Q (IC "Predef") _ -> return t
+     Q p c -> look p c 
+
+     -- if computed do nothing
+     ---- Computed t' -> return $ unComputed t'
+
+     Vr x -> do
+       t' <- maybe (prtBad ("no value for 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'
+
+     -- beta-convert
+     App f a -> do
+       f' <- comp g f
+       a' <- comp g a
+       case (f',a') of
+         (Abs x b, FV as) -> 
+           mapM (\c -> comp (ext x c g) b) as >>= return . variants
+         (_, FV as)  -> mapM (\c -> comp g (App f' c)) as >>= return . variants
+         (FV fs, _)  -> mapM (\c -> comp g (App c a')) fs >>= return . variants
+         (Abs x b,_) -> comp (ext x a' g) b
+         (QC _ _,_)  -> returnC $ App f' a'
+
+         (S (T i cs) e,_) -> prawitz g i (flip App a') cs e
+         (S (V i cs) e,_) -> prawitzV g i (flip App a') cs e
+
+	 _ -> do
+           (t',b) <- appPredefined (App f' a')
+           if b then return t' else comp g t'
+
+     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 (prtBad "no value for label" l) (comp g . snd) $ 
+                    lookup l $ reverse r 
+
+         ExtR a (R b) ->                 
+           case comp g (P (R b) l) of
+             Ok v -> return v
+             _ -> comp g (P a l)
+
+--- { - --- this is incorrect, since b can contain the proper value
+         ExtR (R a) b ->                 -- NOT POSSIBLE both a and b records!
+           case comp g (P (R a) l) of
+             Ok v -> return v
+             _ -> comp g (P b l)
+--- - } ---
+
+
+         S (T i cs) e -> prawitz g i (flip P l) cs e
+         S (V i cs) e -> prawitzV g i (flip P l) cs e
+
+         _   -> returnC $ P t' l
+
+     PI t l i -> comp g $ P t l -----
+
+     S t@(T ti cc) v -> do
+       v'     <- comp g v
+       case v' of
+         FV vs -> do
+           ts' <- mapM (comp g . S t) vs
+           return $ variants ts' 
+         _ -> case ti of
+{-
+           TComp _  -> do
+             case term2patt v' of
+               Ok p' -> case lookup p' cc of
+                 Just u -> comp g u
+                 _ -> do
+                   t' <- comp g t
+                   return $ S t' v' -- if v' is not canonical
+               _ -> do
+                  t' <- comp g t
+                  return $ S t' v'
+-}
+           _ -> case matchPattern cc v' of
+             Ok (c,g') -> comp (g' ++ g) c
+             _ | isCan v' -> prtBad ("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'     <- case t of
+---- why not? ResFin.Agr "has no values"
+----        T (TComp _) _ -> return t
+----        V _ _ -> return t
+        _ -> comp g t
+
+      v'     <- comp g v
+
+      case v' of
+       FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants        
+       _ -> case t' of
+         FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants
+
+         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
+
+         -- course-of-values table: look up by index, no pattern matching needed
+         V ptyp ts -> do
+           vs <- allParamValues gr ptyp
+           case lookup v' (zip vs [0 .. length vs - 1]) of
+             Just i -> comp g $ ts !! i
+-----             _ -> prtBad "selection" $ S t' v' -- debug
+             _ -> return $ S t' v' -- if v' is not canonical
+
+         T (TComp _) cs -> do
+           case term2patt v' of
+             Ok p' -> case lookup p' cs of
+               Just u -> comp g u
+               _ -> return $ S t' v' -- if v' is not canonical
+             _ -> return $ S t' v'
+
+         T _ cc -> case matchPattern cc v' of
+             Ok (c,g') -> comp (g' ++ g) c
+             _ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t 
+             _ -> return $ S t' v' -- if v' is not canonical
+
+
+         S (T i cs) e -> prawitz g i (flip S v') cs e
+         S (V i cs) e -> prawitzV 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
+         (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
+
+         (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
+         (S (V i cs) e, s) -> prawitzV g i (flip Glue s) cs e
+         (s, S (V i cs) e) -> prawitzV 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' <- strsFromTerm ka
+----         (Alts _, K a) -> checks [do
+            x' <- 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
+           ]
+         (C u v,_) -> comp g $ C u (Glue v y)
+
+         _ -> 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 <- 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
+         (R rs, R ss) -> plusRecord r' s'
+         (RecType rs, RecType ss) -> plusRecType r' s'
+         _ -> return $ ExtR r' s'
+
+     -- case-expand tables
+     -- if already expanded, don't expand again
+     T i@(TComp ty) 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 $ V ty (map snd cs')
+       return $ T i cs'
+
+     T i cs -> do
+       pty0 <- errIn (prt t) $ getTableType i
+       ptyp <- comp g pty0
+       case allParamValues gr ptyp of
+         Ok vs -> do
+
+           cs'  <- mapM (compBranchOpt g) cs  ---- why is this needed??
+           sts  <- mapM (matchPattern cs') vs 
+           ts   <- mapM (\ (c,g') -> comp (g' ++ g) c) sts
+           ps   <- mapM term2patt vs
+           let ps' = ps --- PT ptyp (head ps) : tail ps
+----           return $ V ptyp ts -- to save space ---- why doesn't this work??
+           return $ 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
+
+    where
+
+     look p c
+       | rec       = lookupOperDef gr p c >>= comp []
+       | otherwise = lookupOperDef gr p c
+
+{-
+     look p c = case lookupResDefKind gr p c of
+       Ok (t,_) | noExpand p || rec -> 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
+-}
+
+     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
+       _ -> 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
+     prawitzV g i f cs e = do
+       cs' <- mapM (comp g) [(f v) | v <- cs]
+       return $ S (V i cs') e
+
+-- | argument variables cannot be glued
+checkNoArgVars :: Term -> Err Term
+checkNoArgVars t = case t of
+  Vr (IA _)  -> Bad $ glueErrorMsg $ prt t 
+  Vr (IAV _) -> Bad $ glueErrorMsg $ prt t 
+  _ -> composOp checkNoArgVars t
+
+glueErrorMsg s = 
+  "Cannot glue (+) term with run-time variable" +++ s ++ "." ++++
+  "Use Prelude.bind instead."
diff --git a/src-3.0/GF/Devel/Grammar/Construct.hs b/src-3.0/GF/Devel/Grammar/Construct.hs
new file mode 100644
index 000000000..5b4215843
--- /dev/null
+++ b/src-3.0/GF/Devel/Grammar/Construct.hs
@@ -0,0 +1,221 @@
+module GF.Devel.Grammar.Construct where
+
+import GF.Devel.Grammar.Grammar
+import GF.Infra.Ident
+
+import GF.Data.Operations
+
+import Control.Monad
+import Data.Map
+import Debug.Trace (trace)
+
+------------------
+-- abstractions on Grammar, constructing objects
+------------------
+
+-- abstractions on GF
+
+emptyGF :: GF
+emptyGF = GF Nothing [] empty empty
+
+type SourceModule = (Ident,Module)
+
+listModules :: GF -> [SourceModule]
+listModules = assocs.gfmodules
+
+addModule :: Ident -> Module -> GF -> GF
+addModule c m gf = gf {gfmodules = insert c m (gfmodules gf)}
+
+gfModules :: [(Ident,Module)] -> GF
+gfModules ms = emptyGF {gfmodules = fromList ms}
+
+-- abstractions on Module
+
+emptyModule :: Module
+emptyModule = Module MTGrammar True [] [] [] [] empty empty
+
+isCompleteModule :: Module -> Bool
+isCompleteModule = miscomplete
+
+isInterface :: Module -> Bool
+isInterface m = case mtype m of
+  MTInterface -> True
+  MTAbstract -> True
+  _ -> False
+
+interfaceName :: Module -> Maybe Ident
+interfaceName mo = case mtype mo of
+  MTInstance i -> return i
+  MTConcrete i -> return i
+  _ -> Nothing
+
+listJudgements :: Module -> [(Ident,Judgement)]
+listJudgements = assocs . mjments
+
+isInherited :: MInclude -> Ident -> Bool
+isInherited mi i = case mi of
+  MIExcept is -> notElem i is
+  MIOnly is -> elem i is
+  _ -> True
+
+-- abstractions on Judgement
+
+isConstructor :: Judgement -> Bool
+isConstructor j = jdef j == EData
+
+isLink :: Judgement -> Bool
+isLink j = jform j == JLink
+
+-- constructing judgements from parse tree
+
+emptyJudgement :: JudgementForm -> Judgement
+emptyJudgement form = Judgement form meta meta meta (identC "#") 0 where
+  meta = Meta 0
+
+addJType :: Type -> Judgement -> Judgement
+addJType tr ju = ju {jtype = tr}
+
+addJDef :: Term -> Judgement -> Judgement
+addJDef tr ju = ju {jdef = tr}
+
+addJPrintname :: Term -> Judgement -> Judgement
+addJPrintname tr ju = ju {jprintname = tr}
+
+linkInherited :: Bool -> Ident -> Judgement
+linkInherited can mo = (emptyJudgement JLink){
+  jlink = mo,
+  jdef = if can then EData else Meta 0
+  }
+
+absCat :: Context -> Judgement
+absCat co = addJType (mkProd co typeType) (emptyJudgement JCat)
+
+absFun :: Type -> Judgement
+absFun ty = addJType ty (emptyJudgement JFun)
+
+cncCat :: Type -> Judgement
+cncCat ty = addJType ty (emptyJudgement JLincat)
+
+cncFun :: Term -> Judgement
+cncFun tr = addJDef tr (emptyJudgement JLin)
+
+resOperType :: Type -> Judgement
+resOperType ty = addJType ty (emptyJudgement JOper)
+
+resOperDef :: Term -> Judgement
+resOperDef tr = addJDef tr (emptyJudgement JOper)
+
+resOper :: Type -> Term -> Judgement
+resOper ty tr = addJDef tr (resOperType ty)
+
+resOverload :: [(Type,Term)] -> Judgement
+resOverload tts = resOperDef (Overload tts)
+
+-- param p = ci gi  is encoded as p : ((ci : gi) -> p) -> Type
+-- we use EData instead of p to make circularity check easier  
+resParam :: Ident -> [(Ident,Context)] -> Judgement
+resParam p cos = addJDef (EParam (Con p) cos) (addJType typePType (emptyJudgement JParam))
+
+-- to enable constructor type lookup:
+-- create an oper for each constructor p = c g, as c : g -> p = EData
+paramConstructors :: Ident -> [(Ident,Context)] -> [(Ident,Judgement)]
+paramConstructors p cs = [(c,resOper (mkProd co (Con p)) EData) | (c,co) <- cs]
+
+-- unifying contents of judgements
+
+---- used in SourceToGF; make error-free and informative
+unifyJudgements j k = case unifyJudgement j k of
+  Ok l -> l
+  Bad s -> error s
+
+unifyJudgement :: Judgement -> Judgement -> Err Judgement
+unifyJudgement old new = do
+  testErr (jform old == jform new) "different judment forms"
+  [jty,jde,jpri] <- mapM unifyField [jtype,jdef,jprintname]
+  return $ old{jtype = jty, jdef = jde, jprintname = jpri}
+ where
+   unifyField field = unifyTerm (field old) (field new)
+   unifyTerm oterm nterm = case (oterm,nterm) of
+     (Meta _,t) -> return t
+     (t,Meta _) -> return t
+     _ -> do
+       if (nterm /= oterm) 
+          then (trace (unwords ["illegal update of",show oterm,"to",show nterm]) 
+                (return ()))
+          else return () ---- to recover from spurious qualification conflicts
+----       testErr (nterm == oterm) 
+----               (unwords ["illegal update of",prt oterm,"to",prt nterm])
+       return nterm
+
+updateJudgement :: Ident -> Ident -> Judgement -> GF -> Err GF
+updateJudgement m c ju gf = do
+  mo  <- maybe (Bad (show m)) return $ Data.Map.lookup m $ gfmodules gf
+  let mo' = mo {mjments = insert c ju (mjments mo)}
+  return $ gf {gfmodules = insert m mo' (gfmodules gf)}
+
+-- abstractions on Term
+
+type Cat  = QIdent
+type Fun  = QIdent
+type QIdent = (Ident,Ident)
+
+-- | branches à la Alfa
+newtype Branch = Branch (Con,([Ident],Term)) deriving (Eq, Ord,Show,Read)
+type Con = Ident ---
+
+varLabel :: Int -> Label
+varLabel = LVar
+
+wildPatt :: Patt
+wildPatt = PW
+
+type Trm = Term
+
+mkProd :: Context -> Type -> Type
+mkProd = flip (foldr (uncurry Prod))
+
+-- type constants
+
+typeType :: Type
+typeType = Sort "Type"
+
+typePType :: Type
+typePType = Sort "PType"
+
+typeStr :: Type
+typeStr = Sort "Str"
+
+typeTok :: Type      ---- deprecated
+typeTok = Sort "Tok"  
+
+cPredef :: Ident
+cPredef = identC "Predef"
+
+cPredefAbs :: Ident
+cPredefAbs = identC "PredefAbs"
+
+typeString, typeFloat, typeInt :: Term
+typeInts :: Integer -> Term
+
+typeString = constPredefRes "String"
+typeInt = constPredefRes "Int"
+typeFloat = constPredefRes "Float"
+typeInts i = App (constPredefRes "Ints") (EInt i)
+
+isTypeInts :: Term -> Bool
+isTypeInts ty = case ty of
+  App c _ -> c == constPredefRes "Ints"
+  _ -> False
+
+cnPredef = constPredefRes
+
+constPredefRes :: String -> Term
+constPredefRes s = Q (IC "Predef") (identC s)
+
+isPredefConstant :: Term -> Bool
+isPredefConstant t = case t of
+  Q (IC "Predef") _ -> True
+  Q (IC "PredefAbs") _ -> True
+  _ -> False
+
+
diff --git a/src-3.0/GF/Devel/Grammar/GFtoSource.hs b/src-3.0/GF/Devel/Grammar/GFtoSource.hs
new file mode 100644
index 000000000..292f5b826
--- /dev/null
+++ b/src-3.0/GF/Devel/Grammar/GFtoSource.hs
@@ -0,0 +1,223 @@
+module GF.Devel.Grammar.GFtoSource ( 
+  trGrammar,
+  trModule,
+  trAnyDef,
+  trLabel,
+  trt, 
+  tri, 
+  trp
+  ) where
+
+
+import GF.Devel.Grammar.Grammar
+import GF.Devel.Grammar.Construct
+import GF.Devel.Grammar.Macros (contextOfType)
+import qualified GF.Devel.Compile.AbsGF as P
+import GF.Infra.Ident
+
+import GF.Data.Operations
+
+import qualified Data.Map as Map
+
+-- From internal source syntax to BNFC-generated (used for printing).
+-- | AR 13\/5\/2003
+--
+-- translate internal to parsable and printable source
+
+trGrammar :: GF -> P.Grammar
+trGrammar = P.Gr . map trModule . listModules -- no includes
+
+trModule :: (Ident,Module) -> P.ModDef
+trModule (i,mo) = P.MModule compl typ body where
+    compl = case isCompleteModule mo of
+      False -> P.CMIncompl
+      _ -> P.CMCompl
+    i' = tri i
+    typ = case mtype mo of
+      MTGrammar -> P.MGrammar i'
+      MTAbstract -> P.MAbstract i'
+      MTConcrete a -> P.MConcrete i' (tri a)
+      MTInterface -> P.MInterface i'
+      MTInstance a -> P.MInstance i' (tri a)
+    body = P.MBody 
+             (trExtends (mextends mo)) 
+             (mkOpens (map trOpen (mopens mo)))
+             (concatMap trAnyDef [(c,j) | (c,j) <- listJudgements mo] ++ 
+                        map trFlag (Map.assocs (mflags mo)))
+
+trExtends :: [(Ident,MInclude)] -> P.Extend
+trExtends [] = P.NoExt 
+trExtends es = (P.Ext $ map tre es) where
+  tre (i,c) = case c of 
+    MIAll       -> P.IAll   (tri i)
+    MIOnly is   -> P.ISome  (tri i) (map tri is)
+    MIExcept is -> P.IMinus (tri i) (map tri is)
+
+trOpen :: (Ident,Ident) -> P.Open
+trOpen (i,j) = P.OQual (tri i) (tri j)
+
+mkOpens ds = if null ds then P.NoOpens else P.OpenIn ds
+
+trAnyDef :: (Ident,Judgement) -> [P.TopDef]
+trAnyDef (i,ju) = let 
+   i' = mkName i
+   i0 = tri i 
+ in case jform ju of
+  JCat -> [P.DefCat [P.SimpleCatDef i0 []]] ---- (map trDecl co)]]
+  JFun -> [P.DefFun [P.FDecl [i'] (trt (jtype ju))]] 
+    ---- ++ case pt of
+    ---- Yes t -> [P.DefDef [P.DDef [mkName i'] (trt t)]]
+    ---- _ -> []
+  ----  JFun ty EData -> [P.DefFunData [P.FunDef [i'] (trt ty)]]
+  JParam -> [P.DefPar [
+    P.ParDefDir i0 [
+      P.ParConstr (tri c) (map trDecl co) | let EParam _ cos = jdef ju, (c,co) <- cos]
+    ]] 
+  JOper -> case jdef ju of 
+    Overload tysts -> 
+      [P.DefOper [P.DDef [i'] (
+        P.EApp (P.EPIdent $ ppIdent "overload") 
+          (P.ERecord [P.LDFull [i0] (trt ty) (trt fu) | (ty,fu) <- tysts]))]]
+    tr -> [P.DefOper [trDef i (jtype ju) tr]]
+  JLincat -> [P.DefLincat [P.DDef [i'] (trt (jtype ju))]] 
+  ---- CncCat pty ptr ppr -> 
+  ----  [P.DefLindef [trDef i' pty ptr]] 
+    ---- ++ [P.DefPrintCat [P.DDef [mkName i] (trt pr)] | Yes pr <- [ppr]]
+  JLin -> 
+    [P.DefLin [trDef i (Meta 0) (jdef ju)]] 
+    ---- ++ [P.DefPrintFun [P.DDef [mkName i] (trt pr)] | Yes pr <- [ppr]]
+  JLink -> []
+
+trDef :: Ident -> Type -> Term -> P.Def
+trDef i pty ptr = case (pty,ptr) of
+  (Meta _, Meta _) -> P.DDef  [mkName i] (P.EMeta) ---
+  (_,      Meta _) -> P.DDecl [mkName i] (trPerh pty)
+  (Meta _,      _) -> P.DDef  [mkName i] (trPerh ptr)
+  (_,           _) -> P.DFull [mkName i] (trPerh pty) (trPerh ptr)
+
+trPerh p = case p of
+  Meta _ -> P.EMeta
+  _ -> trt p
+
+trFlag :: (Ident,String) -> P.TopDef
+trFlag (f,x) = P.DefFlag [P.DDef [mkName f] (P.EString x)]
+
+trt :: Term -> P.Exp 
+trt trm = case trm of
+    Vr s -> P.EPIdent $ tri s
+----    Cn s -> P.ECons $ tri s
+    Con s -> P.EConstr $ tri s
+    Sort s -> P.ESort $ case s of
+      "Type" -> P.Sort_Type
+      "PType" -> P.Sort_PType
+      "Tok" -> P.Sort_Tok
+      "Str" -> P.Sort_Str
+      "Strs" -> P.Sort_Strs
+      _ -> error $ "not yet sort " +++ show trm ----
+
+    App c a -> P.EApp (trt c) (trt a)
+    Abs x b -> P.EAbstr [trb x] (trt b)
+    Eqs pts -> P.EEqs [P.Equ (map trp ps) (trt t) | (ps,t) <- pts]
+    Meta m  -> P.EMeta
+    Prod x a b | isWildIdent x -> P.EProd (P.DExp (trt a)) (trt b)
+    Prod x a b -> P.EProd (P.DDec [trb x] (trt a)) (trt b)
+
+    Example t s -> P.EExample (trt t) s
+    R [] -> P.ETuple [] --- to get correct parsing when read back
+    R r -> P.ERecord $ map trAssign r
+    RecType r -> P.ERecord $ map trLabelling r
+    ExtR x y -> P.EExtend (trt x) (trt y)
+    P t l -> P.EProj (trt t) (trLabel l)
+    PI t l _ -> P.EProj (trt t) (trLabel l)
+    Q t l -> P.EQCons (tri t) (tri l)
+    QC t l -> P.EQConstr (tri t) (tri l)
+    T (TTyped ty) cc -> P.ETTable (trt ty) (map trCase cc)
+    T (TComp ty) cc -> P.ETTable (trt ty) (map trCase cc)
+    T (TWild ty) cc -> P.ETTable (trt ty) (map trCase cc)
+    T _ cc -> P.ETable (map trCase cc)
+    V ty cc -> P.EVTable (trt ty) (map trt cc)
+
+    Typed tr ty -> P.ETyped (trt tr) (trt ty)
+    Table x v -> P.ETType (trt x) (trt v)
+    S f x -> P.ESelect  (trt f) (trt x)
+    Let (x,(ma,b)) t -> 
+      P.ELet [maybe (P.LDDef x' b') (\ty -> P.LDFull x' (trt ty) b')  ma] (trt t)
+                          where 
+                            b' = trt b
+                            x' = [tri x]
+    Empty -> P.EEmpty
+    K [] -> P.EEmpty
+    K a -> P.EString a
+    C a b -> P.EConcat (trt a) (trt b)
+
+    EInt i -> P.EInt i
+    EFloat i -> P.EFloat i
+
+    EPatt p -> P.EPatt (trp p)
+    EPattType t -> P.EPattType (trt t)
+
+    Glue a b -> P.EGlue (trt a) (trt b)
+    Alts (t, tt) -> P.EPre (trt t) [P.Alt (trt v) (trt c) | (v,c) <- tt]
+    FV ts -> P.EVariants $ map trt ts
+    EData -> P.EData
+    EParam t _ -> trt t
+
+    _ -> error $ "not yet" +++ show trm ----
+
+trp :: Patt -> P.Patt
+trp p = case p of
+    PChar -> P.PChar
+    PChars s -> P.PChars s
+    PM m c -> P.PM (tri m) (tri c)
+    PW -> P.PW
+    PV s | isWildIdent s -> P.PW
+    PV s -> P.PV $ tri s
+    PC c [] -> P.PCon $ tri c
+    PC c a -> P.PC (tri c) (map trp a)
+    PP p c [] -> P.PQ (tri p) (tri c)
+    PP p c a -> P.PQC (tri p) (tri c) (map trp a)
+    PR r -> P.PR [P.PA [trLabelIdent l] (trp p) | (l,p) <- r]
+    PString s -> P.PStr s
+    PInt i -> P.PInt i
+    PFloat i -> P.PFloat i
+    PT t p -> trp p ---- prParenth (prt p +++ ":" +++ prt t)
+
+    PAs  x p -> P.PAs (tri x) (trp p)
+
+    PAlt p q -> P.PDisj (trp p) (trp q)
+    PSeq p q -> P.PSeq (trp p) (trp q)
+    PRep p   -> P.PRep (trp p)
+    PNeg p   -> P.PNeg (trp p)
+
+
+trAssign (lab, (mty, t)) = maybe (P.LDDef x t') (\ty -> P.LDFull x (trt ty) t') mty
+  where 
+    t' = trt t
+    x  = [trLabelIdent lab]
+
+trLabelling (lab,ty) = P.LDDecl [trLabelIdent lab] (trt ty)
+
+trCase  (patt, trm) = P.Case (trp patt) (trt trm)
+trCases (patts,trm) = P.Case (foldl1 P.PDisj (map trp patts)) (trt trm)
+
+trDecl (x,ty) = P.DDDec [trb x] (trt ty)
+
+tri :: Ident -> P.PIdent
+tri i = ppIdent (prIdent i)
+
+ppIdent i = P.PIdent ((0,0),i)
+  
+trb i = if isWildIdent i then P.BWild else P.BPIdent (tri i)
+
+trLabel :: Label -> P.Label
+trLabel i = case i of
+  LIdent s -> P.LPIdent $ ppIdent s
+  LVar i -> P.LVar $ toInteger i
+
+trLabelIdent i = ppIdent $ case i of
+  LIdent s -> s
+  LVar i -> "v" ++ show i --- should not happen
+
+mkName :: Ident -> P.Name
+mkName = P.PIdentName . tri
+
diff --git a/src-3.0/GF/Devel/Grammar/Grammar.hs b/src-3.0/GF/Devel/Grammar/Grammar.hs
new file mode 100644
index 000000000..df5a3907e
--- /dev/null
+++ b/src-3.0/GF/Devel/Grammar/Grammar.hs
@@ -0,0 +1,172 @@
+module GF.Devel.Grammar.Grammar where
+
+import GF.Infra.Ident
+
+import GF.Data.Operations
+
+import Data.Map
+
+
+------------------
+-- definitions  --
+------------------
+
+data GF = GF {
+  gfabsname   :: Maybe Ident ,
+  gfcncnames  :: [Ident] ,
+  gflags      :: Map Ident String ,   -- value of a global flag
+  gfmodules   :: Map Ident Module
+  }
+
+data Module = Module {
+  mtype       :: ModuleType,
+  miscomplete :: Bool,
+  minterfaces :: [(Ident,Ident)],           -- non-empty for functors 
+  minstances  :: [((Ident,MInclude),[(Ident,Ident)])], -- non-empty for inst'ions
+  mextends    :: [(Ident,MInclude)],
+  mopens      :: [(Ident,Ident)],           -- used name, original name
+  mflags      :: Map Ident String,
+  mjments     :: Map Ident Judgement
+  }
+
+data ModuleType =
+    MTAbstract
+  | MTConcrete Ident
+  | MTInterface
+  | MTInstance Ident
+  | MTGrammar 
+  deriving Eq
+
+data MInclude =
+    MIAll
+  | MIExcept [Ident]
+  | MIOnly [Ident]
+
+type Indirection = (Ident,Bool) -- module of origin, whether canonical
+
+data Judgement = Judgement {
+  jform :: JudgementForm,  -- cat      fun   lincat  lin     oper    param
+  jtype :: Type,           -- context  type  lincat  -       type    PType
+  jdef  :: Term,           -- lindef   def   lindef  lin     def     constrs
+  jprintname :: Term,      -- -        -     prname  prname  -       -
+  jlink :: Ident,   -- if inherited, the supermodule name, else #
+  jposition :: Int  -- line number where def begins
+  } 
+  deriving Show
+
+data JudgementForm =
+    JCat
+  | JFun
+  | JLincat
+  | JLin
+  | JOper
+  | JParam
+  | JLink
+  deriving (Eq,Show)
+
+type Type = Term
+
+data Term =
+   Vr Ident             -- ^ variable
+ | Con Ident            -- ^ constructor
+ | EData                -- ^ to mark in definition that a fun is a constructor
+ | Sort String          -- ^ predefined 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 ; ...}@
+ | V Type [Term]        -- ^ 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@
+
+ | Q  Ident Ident       -- ^ qualified constant from a module
+ | QC Ident Ident       -- ^ qualified constructor from a module
+
+ | C Term Term          -- ^ concatenation: @s ++ t@
+ | Glue Term Term       -- ^ agglutination: @s + t@
+
+ | EPatt Patt
+ | EPattType Term
+
+ | EParam Term [(Ident,Context)] -- to encode parameter constructor sets
+
+ | FV [Term]            -- ^ free variation: @variants { s ; ... }@
+
+ | Alts (Term, [(Term, Term)]) -- ^ prefix-dependent: @pre {t ; s\/c ; ...}@
+
+ | Overload [(Type,Term)]
+
+  deriving (Read, Show, Eq, Ord)
+
+data Patt =
+   PC Ident [Patt]        -- ^ constructor pattern: @C p1 ... pn@    @C@ 
+ | PP Ident Ident [Patt]  -- ^ qualified constr patt: @P.C p1 ... pn@    @P.C@ 
+ | PV Ident               -- ^ variable pattern: @x@
+ | PW                     -- ^ wild card pattern: @_@
+ | PR [(Label,Patt)]      -- ^ record pattern: @{r = p ; ...}@
+ | PString String         -- ^ string literal pattern: @\"foo\"@
+ | PInt    Integer        -- ^ integer literal pattern: @12@
+ | PFloat Double          -- ^ float literal pattern: @1.2@
+ | PT Type Patt           -- ^ type-annotated pattern
+ | 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 String          -- ^ list of characters: ["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 annotated, 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 String
+  | LVar Int
+   deriving (Read, Show, Eq, Ord)
+
+type MetaSymb = Int
+
+type Decl         = (Ident,Term)  -- (x:A)  (_:A)  A
+type Context      = [Decl]        -- (x:A)(y:B)   (x,y:A)   (_,_:A)
+type Substitution = [(Ident, Term)]
+type Equation     = ([Patt],Term) 
+
+type Labelling = (Label, Term) 
+type Assign    = (Label, (Maybe Type, Term)) 
+type Case      = (Patt, Term) 
+type LocalDef  = (Ident, (Maybe Type, Term))
+
diff --git a/src-3.0/GF/Devel/Grammar/Lookup.hs b/src-3.0/GF/Devel/Grammar/Lookup.hs
new file mode 100644
index 000000000..689996760
--- /dev/null
+++ b/src-3.0/GF/Devel/Grammar/Lookup.hs
@@ -0,0 +1,168 @@
+module GF.Devel.Grammar.Lookup where
+
+import GF.Devel.Grammar.Grammar
+import GF.Devel.Grammar.Construct
+import GF.Devel.Grammar.Macros
+import GF.Devel.Grammar.PrGF
+import GF.Infra.Ident
+
+import GF.Data.Operations
+
+import Control.Monad (liftM)
+import Data.Map
+import Data.List (sortBy) ----
+
+-- look up fields for a constant in a grammar
+
+lookupJField :: (Judgement -> a) -> GF -> Ident -> Ident -> Err a
+lookupJField field gf m c = do
+  j <- lookupJudgement gf m c
+  return $ field j
+
+lookupJForm :: GF -> Ident -> Ident -> Err JudgementForm
+lookupJForm = lookupJField jform
+
+-- the following don't (need to) check that the jment form is adequate
+ 
+lookupCatContext :: GF -> Ident -> Ident -> Err Context
+lookupCatContext gf m c = do
+  ty <- lookupJField jtype gf m c
+  return $ contextOfType ty
+
+lookupFunType :: GF -> Ident -> Ident -> Err Term
+lookupFunType = lookupJField jtype 
+
+lookupLin :: GF -> Ident -> Ident -> Err Term
+lookupLin = lookupJField jdef
+
+lookupLincat :: GF -> Ident -> Ident -> Err Term
+lookupLincat = lookupJField jtype
+
+lookupOperType :: GF -> Ident -> Ident -> Err Term
+lookupOperType gr m c = do
+  ju <- lookupJudgement gr m c
+  case jform ju of
+    JParam -> return typePType
+    _ -> case jtype ju of
+      Meta _ -> fail ("no type given to " ++ prIdent m ++ "." ++ prIdent c)
+      ty -> return ty
+---- can't be just lookupJField jtype 
+
+lookupOperDef :: GF -> Ident -> Ident -> Err Term
+lookupOperDef = lookupJField jdef
+
+lookupOverload :: GF -> Ident -> Ident -> Err [([Type],(Type,Term))]
+lookupOverload gr m c = do
+  tr <- lookupJField jdef gr m c
+  case tr of
+    Overload tysts -> return 
+      [(lmap snd args,(val,tr)) | (ty,tr) <- tysts, let (args,val) = prodForm ty]
+    _   -> Bad $ prt c +++ "is not an overloaded operation"
+
+lookupParams :: GF -> Ident -> Ident -> Err [(Ident,Context)]
+lookupParams gf m c = do
+  EParam _ ty <- lookupJField jdef gf m c
+  return ty
+
+lookupParamConstructor :: GF -> Ident -> Ident -> Err Type
+lookupParamConstructor = lookupJField jtype
+
+lookupParamValues :: GF -> Ident -> Ident -> Err [Term]
+lookupParamValues gf m c = do
+  ps <- lookupParams gf m c
+  liftM concat $ mapM mkPar ps
+ where
+   mkPar (f,co) = do
+     vs <- liftM combinations $ mapM (\ (_,ty) -> allParamValues gf ty) co
+     return $ lmap (mkApp (QC m f)) vs
+
+lookupFlags :: GF -> Ident -> [(Ident,String)]
+lookupFlags gf m = errVal [] $ do
+  mo <- lookupModule gf m
+  return $ toList $ mflags mo
+
+allParamValues :: GF -> Type -> Err [Term]
+allParamValues cnc ptyp = case ptyp of
+     App (Q (IC "Predef") (IC "Ints")) (EInt n) -> 
+       return [EInt i | i <- [0..n]]
+     QC p c -> lookupParamValues cnc p c
+     Q  p c -> lookupParamValues cnc p c ----
+
+     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))
+
+abstractOfConcrete :: GF -> Ident -> Err Ident
+abstractOfConcrete gf m = do
+  mo <- lookupModule gf m
+  case mtype mo of
+    MTConcrete a -> return a
+    MTInstance a -> return a
+    MTGrammar -> return m
+    _ -> prtBad "not concrete module" m
+
+allOrigJudgements :: GF -> Ident -> [(Ident,Judgement)]
+allOrigJudgements gf m = errVal [] $ do
+  mo <- lookupModule gf m
+  return [ju | ju@(_,j) <- listJudgements mo, jform j /= JLink]
+
+allConcretes :: GF -> Ident -> [Ident]
+allConcretes gf m = 
+  [c | (c,mo) <- toList (gfmodules gf), mtype mo == MTConcrete m]
+
+-- | select just those modules that a given one depends on, including itself
+partOfGrammar :: GF -> (Ident,Module) -> GF
+partOfGrammar gr (i,mo) = gr {
+  gfmodules = fromList [m | m@(j,_) <- mos, elem j modsFor]
+  } 
+  where
+    mos = toList $ gfmodules gr
+    modsFor = i : allDepsModule gr mo
+
+allDepsModule :: GF -> Module -> [Ident]
+allDepsModule gr m = iterFix add os0 where
+  os0 = depPathModule m
+  add os = [m | o <- os, Just n <- [llookup o mods], m <- depPathModule n]
+  mods = toList $ gfmodules gr
+
+-- | initial dependency list
+depPathModule :: Module -> [Ident]
+depPathModule mo = fors ++ lmap fst (mextends mo) ++ lmap snd (mopens mo) where
+  fors = case mtype mo of
+    MTConcrete i   -> [i]
+    MTInstance i   -> [i]
+    _              -> []
+
+-- infrastructure for lookup
+    
+lookupModule :: GF -> Ident -> Err Module
+lookupModule gf m = do
+  maybe (raiseIdent "module not found:" m) return $ mlookup m (gfmodules gf)
+
+-- this finds the immediate definition, which can be a link
+lookupIdent :: GF -> Ident -> Ident -> Err Judgement
+lookupIdent gf m c = do
+  mo <- lookupModule gf m
+  maybe (raiseIdent "constant not found:" c) return $ mlookup c (mjments mo)
+
+-- this follows the link
+lookupJudgement :: GF -> Ident -> Ident -> Err Judgement
+lookupJudgement gf m c = do
+  ju <- lookupIdent gf m c
+  case jform ju of
+    JLink -> lookupJudgement gf (jlink ju) c
+    _ -> return ju
+
+mlookup = Data.Map.lookup
+
+raiseIdent msg i = raise (msg +++ prIdent i)
+
+lmap = Prelude.map
+llookup = Prelude.lookup
+
diff --git a/src-3.0/GF/Devel/Grammar/Macros.hs b/src-3.0/GF/Devel/Grammar/Macros.hs
new file mode 100644
index 000000000..1a7a3582c
--- /dev/null
+++ b/src-3.0/GF/Devel/Grammar/Macros.hs
@@ -0,0 +1,434 @@
+module GF.Devel.Grammar.Macros where
+
+import GF.Devel.Grammar.Grammar
+import GF.Devel.Grammar.Construct
+import GF.Infra.Ident
+
+import GF.Data.Str
+import GF.Data.Operations
+
+import qualified Data.Map as Map
+import Control.Monad (liftM,liftM2)
+
+
+-- analyse types and terms
+
+contextOfType :: Type -> Context
+contextOfType ty = co where (co,_,_) = typeForm ty
+
+typeForm :: Type -> (Context,Term,[Term])
+typeForm t = (co,f,a) where
+  (co,t2) = prodForm t
+  (f,a) = appForm t2
+
+termForm :: Term -> ([Ident],Term,[Term])
+termForm t = (co,f,a) where
+  (co,t2) = absForm t
+  (f,a) = appForm t2
+
+prodForm :: Type -> (Context,Term)
+prodForm t = case t of
+  Prod x ty val -> ((x,ty):co,t2) where (co,t2) = prodForm val
+  _ -> ([],t)
+
+absForm :: Term -> ([Ident],Term)
+absForm t = case t of
+  Abs x val -> (x:co,t2) where (co,t2) = absForm val
+  _ -> ([],t)
+
+
+appForm :: Term -> (Term,[Term])
+appForm tr = (f,reverse xs) where 
+  (f,xs) = apps tr
+  apps t = case t of
+    App f a -> (f2,a:a2) where (f2,a2) = appForm f
+    _ -> (t,[])
+
+valCat :: Type -> Err (Ident,Ident)
+valCat typ = case typeForm typ of
+  (_,Q m c,_) -> return (m,c)
+
+typeRawSkeleton :: Type -> Err ([(Int,Type)],Type)
+typeRawSkeleton typ = do
+  let (cont,typ) = prodForm typ
+  args <- mapM (typeRawSkeleton . snd) cont
+  return ([(length c, v) | (c,v) <- args], typ)
+
+type MCat = (Ident,Ident)
+
+sortMCat :: String -> MCat
+sortMCat s = (identC "_", identC s)
+
+--- hack for Editing.actCat in empty state
+errorCat :: MCat
+errorCat = (identC "?", identC "?")
+
+getMCat :: Term -> Err MCat
+getMCat t = case t of
+  Q  m c -> return (m,c)
+  QC m c -> return (m,c)
+  Sort s -> return $ sortMCat s
+  App f _ -> getMCat f
+  _ -> error $ "no qualified constant" +++ show t
+
+typeSkeleton :: Type -> Err ([(Int,MCat)],MCat)
+typeSkeleton typ = do
+  (cont,val) <- typeRawSkeleton typ
+  cont' <- mapPairsM getMCat cont
+  val'  <- getMCat val
+  return (cont',val')
+
+-- construct types and terms
+
+mkFunType :: [Type] -> Type -> Type
+mkFunType tt t = mkProd ([(wildIdent, ty) | ty <- tt]) t -- nondep prod
+
+mkApp :: Term -> [Term] -> Term
+mkApp = foldl App
+
+mkAbs :: [Ident] -> Term -> Term
+mkAbs xs t = foldr Abs t xs
+
+mkCTable :: [Ident] -> Term -> Term
+mkCTable ids v = foldr ccase v ids where 
+  ccase x t = T TRaw [(PV x,t)]
+
+appCons :: Ident -> [Term] -> Term
+appCons = mkApp . Con
+
+appc :: String -> [Term] -> Term
+appc = appCons . identC
+
+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]
+
+tupleLabel :: Int -> Label
+tupleLabel i = LIdent $ "p" ++ show i
+
+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
+
+mkDecl :: Term -> Decl
+mkDecl typ = (wildIdent, typ)
+
+mkLet :: [LocalDef] -> Term -> Term
+mkLet defs t = foldr Let t defs
+
+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
+
+plusRecType :: Type -> Type -> Err Type
+plusRecType t1 t2 = case (t1, 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 show ls)
+  _ -> Bad ("cannot add record types" +++ show t1 +++ "and" +++ show 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" +++ show t1 +++ "and" +++ show t2)
+
+zipAssign :: [Label] -> [Term] -> [Assign]
+zipAssign ls ts = [assign l t | (l,t) <- zip ls ts]
+
+
+defLinType :: Type
+defLinType = RecType [(LIdent "s",  typeStr)]
+
+meta0 :: Term
+meta0 = Meta 0
+
+ident2label :: Ident -> Label
+ident2label c = LIdent (prIdent c)
+
+label2ident :: Label -> Ident
+label2ident (LIdent c) = identC c
+
+----label2ident :: Label -> Ident
+----label2ident = identC . prLabel
+
+-- to apply a term operation to every term in a judgement, module, grammar
+
+termOpGF :: Monad m => (Term -> m Term) -> GF -> m GF
+termOpGF f = moduleOpGF (termOpModule f) 
+
+moduleOpGF :: Monad m => (Module -> m Module) -> GF -> m GF
+moduleOpGF f g = do 
+  ms <- mapMapM f (gfmodules g)
+  return g {gfmodules = ms}
+
+termOpModule :: Monad m => (Term -> m Term) -> Module -> m Module
+termOpModule f = judgementOpModule fj where
+  fj = termOpJudgement f
+   
+judgementOpModule :: Monad m => (Judgement -> m Judgement) -> Module -> m Module
+judgementOpModule f m = do 
+  mjs <- mapMapM f (mjments m)
+  return m {mjments = mjs}
+
+entryOpModule :: Monad m => 
+                 (Ident -> Judgement -> m Judgement) -> Module -> m Module
+entryOpModule f m = do 
+  mjs <- liftM Map.fromAscList $ mapm $ Map.assocs $ mjments m
+  return $ m {mjments = mjs}
+ where
+  mapm = mapM (\ (i,j) -> liftM ((,) i) (f i j)) 
+   
+termOpJudgement :: Monad m => (Term -> m Term) -> Judgement -> m Judgement
+termOpJudgement f j = do 
+  jtyp <- f (jtype j)
+  jde <- f (jdef j)
+  jpri <- f (jprintname j)
+  return $ j {
+    jtype = jtyp,
+    jdef = jde,
+    jprintname = jpri
+    }
+
+-- | 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 monadic 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')
+   Eqs cc -> 
+     do cc' <- mapPairListM (co . snd) cc
+        return (Eqs cc')
+   EParam ty cos -> 
+     do ty' <- co ty
+        cos' <- mapPairListM (mapPairListM (co . snd) . snd) cos
+        return (EParam ty' cos')
+   V ty vs ->
+     do ty' <- co ty
+        vs' <- mapM co vs
+        return (V ty' vs')
+   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')
+   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
+   Overload tts -> do
+     tts' <- mapM (pairM co) tts
+     return $ Overload tts'
+
+   EPattType ty -> 
+     do ty' <- co ty
+        return (EPattType ty')
+
+   _ -> return trm -- covers K, Vr, Cn, Sort
+
+
+---- should redefine using composOp
+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
+  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
+  _ -> [] -- covers K, Vr, Cn, Sort, Ready
+
+--- just aux to composOp?
+
+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)
+
+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
+
+
+patt2term :: Patt -> Term
+patt2term pt = case pt of
+  PV x      -> Vr x
+  PW        -> Vr wildIdent             --- not parsable, should not occur
+  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   -> appc "@" [Vr x, patt2term p]            --- an encoding
+  PSeq a b  -> appc "+" [(patt2term a), (patt2term b)] --- an encoding
+  PAlt a b  -> appc "|" [(patt2term a), (patt2term b)] --- an encoding
+  PRep a    -> appc "*" [(patt2term a)]                --- an encoding
+  PNeg a    -> appc "-" [(patt2term a)]                --- an encoding
+
+
+term2patt :: Term -> Err Patt
+term2patt trm = case Ok (termForm trm) of
+  Ok ([], Vr x, []) -> return (PV x)
+  Ok ([], QC p c, aa) -> do
+    aa' <- mapM term2patt aa
+    return (PP p c aa')
+  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 ([], Con (IC "@"), [Vr a,b]) -> do
+    b' <- term2patt b
+    return (PAs a b')
+  Ok ([], Con (IC "-"), [a]) -> do
+    a' <- term2patt a
+    return (PNeg a')
+  Ok ([], Con (IC "*"), [a]) -> do
+    a' <- term2patt a
+    return (PRep a')
+  Ok ([], Con (IC "+"), [a,b]) -> do
+    a' <- term2patt a
+    b' <- term2patt b
+    return (PSeq a' b')
+  Ok ([], Con (IC "|"), [a,b]) -> do
+    a' <- term2patt a
+    b' <- term2patt b
+    return (PAlt a' b')
+
+  Ok ([], Con c, aa) -> do
+    aa' <- mapM term2patt aa
+    return (PC c aa')
+
+  _ -> Bad $ "no pattern corresponds to term" +++ show trm
+
+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"
+
+-- | to get a string from a term that represents a sequence of terminals
+strsFromTerm :: Term -> Err [Str]
+strsFromTerm t = case 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
+  _ -> Bad $ "cannot get Str from term" +++ show t
+
+
+
+---- given in lib?
+
+mapMapM :: (Monad m, Ord k) => (v -> m v) -> Map.Map k v -> m (Map.Map k v)
+mapMapM f = 
+  liftM Map.fromAscList . mapM (\ (x,y) -> liftM ((,) x) $ f y) . Map.assocs 
+
diff --git a/src-3.0/GF/Devel/Grammar/PatternMatch.hs b/src-3.0/GF/Devel/Grammar/PatternMatch.hs
new file mode 100644
index 000000000..ec64d7802
--- /dev/null
+++ b/src-3.0/GF/Devel/Grammar/PatternMatch.hs
@@ -0,0 +1,146 @@
+----------------------------------------------------------------------
+-- |
+-- 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.Devel.Grammar.PatternMatch (matchPattern,
+		     testOvershadow, 
+		     findMatch
+		    ) where
+
+
+import GF.Devel.Grammar.Grammar
+import GF.Devel.Grammar.Macros
+import GF.Devel.Grammar.PrGF
+import GF.Infra.Ident
+
+import GF.Data.Operations
+
+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 
+  let t' = termForm t
+  trym p t'
+ where
+  isInConstantFormt = True -- tested already
+  trym p t' =
+    case (p,t') of
+      (_,(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'
+
+--      (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
+
+eqStrIdent = (==) ----  
+
+isInConstantForm :: Term -> Bool
+isInConstantForm trm = case trm of
+    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
+    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
+  _ -> []
+
diff --git a/src-3.0/GF/Devel/Grammar/PrGF.hs b/src-3.0/GF/Devel/Grammar/PrGF.hs
new file mode 100644
index 000000000..221a0ac61
--- /dev/null
+++ b/src-3.0/GF/Devel/Grammar/PrGF.hs
@@ -0,0 +1,246 @@
+----------------------------------------------------------------------
+-- |
+-- 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 - 4/12/2007
+--
+-- printing and prettyprinting class for source grammar
+--
+-- 8\/1\/2004:
+-- Usually followed principle: 'prt_' for displaying in the editor, 'prt'
+-- in writing grammars to a file. For some constructs, e.g. 'prMarkedTree',
+-- only the former is ever needed.
+-----------------------------------------------------------------------------
+
+module GF.Devel.Grammar.PrGF where
+
+import qualified GF.Devel.Compile.PrintGF as P
+import GF.Devel.Grammar.GFtoSource
+import GF.Devel.Grammar.Grammar
+import GF.Devel.Grammar.Construct
+----import GF.Grammar.Values
+
+----import GF.Infra.Option
+import GF.Infra.Ident
+import GF.Infra.CompactPrint
+----import GF.Data.Str
+
+import GF.Data.Operations
+----import GF.Data.Zipper
+
+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.
+
+cprintTree :: P.Print a => a -> String
+cprintTree = compactPrint . P.printTree
+
+-- | to show terms etc in error messages
+prtBad :: Print a => String -> a -> Err b
+prtBad s a = Bad (s +++ prt a)
+
+prGF :: GF -> String
+prGF = cprintTree . trGrammar
+
+instance Print GF where
+  prt = cprintTree . trGrammar
+
+prModule :: SourceModule -> String
+prModule = cprintTree . trModule
+
+instance Print Judgement where
+  prt j = cprintTree $ trAnyDef (wildIdent, j)
+----  prt_ = prExp
+
+instance Print Term where
+  prt = cprintTree . trt
+----  prt_ = prExp
+
+instance Print Ident where
+  prt = cprintTree . tri
+
+instance Print Patt where
+  prt = P.printTree . trp
+
+instance Print Label where
+  prt = P.printTree . trLabel
+
+{-
+instance Print MetaSymb where
+  prt (MetaSymb i) = "?" ++ show i
+
+prParam :: Param -> String
+prParam (c,co) = prt c +++ prContext co
+
+prContext :: Context -> String
+prContext co = unwords $ map prParenth [prt x +++ ":" +++ prt t | (x,t) <- co]
+
+
+-- printing values and trees in editing
+
+instance Print a => Print (Tr a) where
+  prt (Tr (n, trees)) = prt n +++ unwords (map prt2 trees)
+  prt2 t@(Tr (_,args)) = if null args then prt t else prParenth (prt t)
+
+-- | we cannot define the method prt_ in this way 
+prt_Tree :: Tree -> String
+prt_Tree = prt_ . tree2exp
+
+instance Print TrNode where
+  prt (N (bi,at,vt,(cs,ms),_)) = 
+    prBinds bi ++ 
+    prt at +++ ":" +++ prt vt 
+    +++ prConstraints cs +++ prMetaSubst ms
+  prt_ (N (bi,at,vt,(cs,ms),_)) = 
+    prBinds bi ++ 
+    prt_ at +++ ":" +++ prt_ vt 
+    +++ prConstraints cs +++ prMetaSubst ms
+
+prMarkedTree :: Tr (TrNode,Bool) -> [String]
+prMarkedTree = prf 1 where
+  prf ind t@(Tr (node, trees)) = 
+    prNode ind node : concatMap (prf (ind + 2)) trees
+  prNode ind node = case node of
+    (n, False) -> indent ind (prt_ n)
+    (n, _)     -> '*' : indent (ind - 1) (prt_ n)
+
+prTree :: Tree -> [String]
+prTree = prMarkedTree . mapTr (\n -> (n,False))
+
+-- | a pretty-printer for parsable output
+tree2string :: Tree -> String
+tree2string = unlines . prprTree
+
+prprTree :: Tree -> [String]
+prprTree = prf False where
+  prf par t@(Tr (node, trees)) = 
+    parIf par (prn node : concat [prf (ifPar t) t | t <- trees])
+  prn (N (bi,at,_,_,_)) = prb bi ++ prt_ at
+  prb [] = ""
+  prb bi = "\\" ++ concat (intersperse "," (map (prt_ . fst) bi)) ++ " -> "
+  parIf par (s:ss) = map (indent 2) $
+                         if par 
+                            then ('(':s) : ss ++ [")"] 
+                            else s:ss
+  ifPar (Tr (N ([],_,_,_,_), [])) = False
+  ifPar _ = True
+
+
+-- auxiliaries
+
+prConstraints :: Constraints -> String
+prConstraints = concat . prConstrs
+
+prMetaSubst :: MetaSubst -> String
+prMetaSubst = concat . prMSubst
+  
+prEnv :: Env -> String
+---- prEnv [] = prCurly "" ---- for debugging
+prEnv e = concatMap (\ (x,t) -> prCurly (prt x ++ ":=" ++ prt t)) e
+
+prConstrs :: Constraints -> [String]
+prConstrs = map (\ (v,w) -> prCurly (prt v ++ "<>" ++ prt w))
+
+prMSubst :: MetaSubst -> [String]
+prMSubst = map (\ (m,e) -> prCurly ("?" ++ show m ++ "=" ++ prt e))
+
+prBinds bi = if null bi 
+                then [] 
+                else "\\" ++ concat (intersperse "," (map prValDecl bi)) +++ "-> "
+ where
+   prValDecl (x,t) = prParenth (prt_ x +++ ":" +++ prt_ t)
+
+instance Print Val where
+  prt (VGen i x) = prt x ++ "{-" ++ show i ++ "-}" ---- latter part for debugging
+  prt (VApp u v) = prt u +++ prv1 v
+  prt (VCn mc) = prQIdent_ mc
+  prt (VClos env e) = case e of
+    Meta _ -> prt_ e ++ prEnv env
+    _      -> prt_ e ---- ++ prEnv env ---- for debugging
+  prt VType = "Type"
+ 
+prv1 v = case v of
+  VApp _ _  -> prParenth $ prt v
+  VClos _ _ -> prParenth $ prt v
+  _ -> prt v
+
+instance Print Atom where
+  prt (AtC f) = prQIdent f
+  prt (AtM i) = prt i
+  prt (AtV i) = prt i
+  prt (AtL s) = prQuotedString s
+  prt (AtI i) = show i
+  prt (AtF i) = show i
+  prt_ (AtC (_,f)) = prt f 
+  prt_ a = prt a
+
+prQIdent :: QIdent -> String
+prQIdent (m,f) = prt m ++ "." ++ prt f
+
+prQIdent_ :: QIdent -> String
+prQIdent_ (_,f) = prt f
+
+-- | print terms without qualifications
+prExp :: Term -> String
+prExp e = case e of
+  App f a    -> pr1 f +++ pr2 a
+  Abs x b    -> "\\" ++ prt x +++ "->" +++ prExp b
+  Prod x a b -> "(\\" ++ prt x +++ ":" +++ prExp a ++ ")" +++ "->" +++ prExp b
+  Q _ c      -> prt c
+  QC _ c     -> prt c  
+  _ -> prt e
+ where
+   pr1 e = case e of
+     Abs _ _    -> prParenth $ prExp e
+     Prod _ _ _ -> prParenth $ prExp e
+     _ -> prExp e
+   pr2 e = case e of
+     App _ _ -> prParenth $ prExp e
+     _ -> pr1 e
+
+-- | option @-strip@ strips qualifications
+prTermOpt :: Options -> Term -> String
+prTermOpt opts = if oElem nostripQualif opts then prt else prExp
+
+-- | to get rid of brackets in the editor
+prRefinement :: Term -> String
+prRefinement t = case t of
+    Q m c  -> prQIdent (m,c)
+    QC m c -> prQIdent (m,c)
+    _ -> prt t
+
+prOperSignature :: (QIdent,Type) -> String
+prOperSignature (f, t) = prQIdent f +++ ":" +++ prt t
+
+-- to look up a constant etc in a search tree
+
+lookupIdent :: Ident -> BinTree Ident b -> Err b
+lookupIdent c t = case lookupTree prt c t of
+  Ok v -> return v
+  _ -> prtBad "unknown identifier" c
+
+lookupIdentInfo :: Module Ident f a -> Ident -> Err a
+lookupIdentInfo mo i = lookupIdent i (jments mo)
+-}