Founding the newly structured GF2.0 cvs archive.

14 files changed, 1730 insertions, 0 deletions

diff --git a/src/GF/Canon/AbsGFC.hs b/src/GF/Canon/AbsGFC.hs
new file mode 100644
index 000000000..361c59d34
--- /dev/null
+++ b/src/GF/Canon/AbsGFC.hs
@@ -0,0 +1,160 @@
+module AbsGFC where
+
+import Ident --H
+
+-- Haskell module generated by the BNF converter, except --H
+
+-- newtype Ident = Ident String deriving (Eq,Ord,Show) --H
+data Canon =
+   Gr [Module]
+  deriving (Eq,Ord,Show)
+
+data Module =
+   Mod ModType Extend Open [Flag] [Def]
+  deriving (Eq,Ord,Show)
+
+data ModType =
+   MTAbs Ident
+ | MTCnc Ident Ident
+ | MTRes Ident
+  deriving (Eq,Ord,Show)
+
+data Extend =
+   Ext Ident
+ | NoExt
+  deriving (Eq,Ord,Show)
+
+data Open =
+   NoOpens
+ | Opens [Ident]
+  deriving (Eq,Ord,Show)
+
+data Flag =
+   Flg Ident Ident
+  deriving (Eq,Ord,Show)
+
+data Def =
+   AbsDCat Ident [Decl] [CIdent]
+ | AbsDFun Ident Exp Exp
+ | ResDPar Ident [ParDef]
+ | ResDOper Ident CType Term
+ | CncDCat Ident CType Term Term
+ | CncDFun Ident CIdent [ArgVar] Term Term
+ | AnyDInd Ident Status Ident
+  deriving (Eq,Ord,Show)
+
+data ParDef =
+   ParD Ident [CType]
+  deriving (Eq,Ord,Show)
+
+data Status =
+   Canon
+ | NonCan
+  deriving (Eq,Ord,Show)
+
+data CIdent =
+   CIQ Ident Ident
+  deriving (Eq,Ord,Show)
+
+data Exp =
+   EApp Exp Exp
+ | EProd Ident Exp Exp
+ | EAbs Ident Exp
+ | EAtom Atom
+ | EEq [Equation]
+  deriving (Eq,Ord,Show)
+
+data Sort =
+   SType
+  deriving (Eq,Ord,Show)
+
+data Equation =
+   Equ [APatt] Exp
+  deriving (Eq,Ord,Show)
+
+data APatt =
+   APC CIdent [APatt]
+ | APV Ident
+ | APS String
+ | API Integer
+ | APW
+  deriving (Eq,Ord,Show)
+
+data Atom =
+   AC CIdent
+ | AD CIdent
+ | AV Ident
+ | AM Integer
+ | AS String
+ | AI Integer
+ | AT Sort
+  deriving (Eq,Ord,Show)
+
+data Decl =
+   Decl Ident Exp
+  deriving (Eq,Ord,Show)
+
+data CType =
+   RecType [Labelling]
+ | Table CType CType
+ | Cn CIdent
+ | TStr
+  deriving (Eq,Ord,Show)
+
+data Labelling =
+   Lbg Label CType
+  deriving (Eq,Ord,Show)
+
+data Term =
+   Arg ArgVar
+ | I CIdent
+ | Con CIdent [Term]
+ | LI Ident
+ | R [Assign]
+ | P Term Label
+ | T CType [Case]
+ | S Term Term
+ | C Term Term
+ | FV [Term]
+ | K Tokn
+ | E
+  deriving (Eq,Ord,Show)
+
+data Tokn =
+   KS String
+ | KP [String] [Variant]
+  deriving (Eq,Ord,Show)
+
+data Assign =
+   Ass Label Term
+  deriving (Eq,Ord,Show)
+
+data Case =
+   Cas [Patt] Term
+  deriving (Eq,Ord,Show)
+
+data Variant =
+   Var [String] [String]
+  deriving (Eq,Ord,Show)
+
+data Label =
+   L Ident
+ | LV Integer
+  deriving (Eq,Ord,Show)
+
+data ArgVar =
+   A Ident Integer
+ | AB Ident Integer Integer
+  deriving (Eq,Ord,Show)
+
+data Patt =
+   PC CIdent [Patt]
+ | PV Ident
+ | PW
+ | PR [PattAssign]
+  deriving (Eq,Ord,Show)
+
+data PattAssign =
+   PAss Label Patt
+  deriving (Eq,Ord,Show)
+
diff --git a/src/GF/Canon/CMacros.hs b/src/GF/Canon/CMacros.hs
new file mode 100644
index 000000000..8c1841fcc
--- /dev/null
+++ b/src/GF/Canon/CMacros.hs
@@ -0,0 +1,234 @@
+module CMacros where
+
+import AbsGFC
+import GFC
+import qualified Ident as A ---- no need to qualif? 21/9
+import PrGrammar
+import Str
+
+import Operations
+
+import Char
+import Monad
+
+-- macros for concrete syntax in GFC that do not need lookup in a grammar
+
+markFocus :: Term -> Term
+markFocus = markSubterm "[*" "*]"
+
+markSubterm :: String -> String -> Term -> Term
+markSubterm beg end t = case t of
+  R rs -> R $ map markField rs 
+  T ty cs -> T ty [Cas p (mark v) | Cas p v <- cs]
+  _    -> foldr1 C [tK beg, t, tK end]  -- t : Str guaranteed?
+ where
+   mark = markSubterm beg end
+   markField lt@(Ass l t) = if isLinLabel l then (Ass l (mark t)) else lt
+   isLinLabel (L (A.IC s)) = case s of ----
+      's':cs -> all isDigit cs
+      _ -> False
+
+tK :: String -> Term
+tK = K . KS
+
+term2patt :: Term -> Err Patt
+term2patt trm = case trm of
+  Con c aa -> do
+    aa' <- mapM term2patt aa
+    return (PC c aa')
+  R r -> do
+    let (ll,aa) = unzip [(l,a) | Ass l a <- r]
+    aa' <- mapM term2patt aa
+    return (PR (map (uncurry PAss) (zip ll aa')))
+  LI x -> return $ PV x
+  _ -> prtBad "no pattern corresponds to term" trm
+
+patt2term :: Patt -> Term
+patt2term p = case p of
+  PC x ps -> Con x (map patt2term ps)
+  PV x    -> LI x
+  PW      -> anyTerm ----
+  PR pas  -> R [ Ass lbl (patt2term q) | PAss lbl q <- pas ]
+
+anyTerm :: Term
+anyTerm  = LI (A.identC "_") --- should not happen
+
+matchPatt cs0 trm = term2patt trm >>= match cs0 where
+  match cs t = 
+    case cs of
+      Cas ps b  :_ | elem t ps -> return b 
+      _:cs'                    -> match cs' t
+      []                       -> Bad $ "pattern not found for" +++ prt t 
+              +++ "among" ++++ unlines (map prt cs0)  ---- debug 
+
+defLinType :: CType
+defLinType = RecType [Lbg (L (A.identC "s")) TStr]
+
+defLindef :: Term
+defLindef = R [Ass (L (A.identC "s")) (Arg (A (A.identC "str") 0))]
+
+strsFromTerm :: Term -> Err [Str]
+strsFromTerm t = case t of
+  K (KS s) -> return [str s]
+  K (KP d vs) -> return $ [Str [TN d [(s,v) | Var s v <- vs]]]
+  C s t -> do
+    s' <- strsFromTerm s
+    t' <- strsFromTerm t
+    return [plusStr x y | x <- s', y <- t']
+  FV ts -> liftM concat $ mapM strsFromTerm ts
+  E -> return [str []]
+  _ -> return [str ("BUG[" ++ prt t ++ "]")] ---- debug
+----  _ -> prtBad "cannot get Str from term " t
+
+-- recursively collect all branches in a table
+allInTable :: Term -> [Term]
+allInTable t =  case t of
+  T _ ts -> concatMap (\ (Cas _ v) -> allInTable v) ts --- expand ?
+  _    -> [t]
+
+-- to gather s-fields; assumes term in normal form, preserves label
+allLinFields :: Term -> Err [[(Label,Term)]]
+allLinFields trm = case trm of
+----  R rs  -> return [[(l,t) | (l,(Just ty,t)) <- rs, isStrType ty]] -- good
+  R rs  -> return [[(l,t) | Ass l t <- rs, isLinLabel l]] ---- bad
+  FV ts -> do
+    lts <- mapM allLinFields ts
+    return $ concat lts
+  _ -> prtBad "fields can only be sought in a record not in" trm
+
+---- deprecated
+isLinLabel l = case l of
+     L (A.IC ('s':cs)) | all isDigit cs -> True
+     _ -> False
+
+-- to gather ultimate cases in a table; preserves pattern list
+allCaseValues :: Term -> [([Patt],Term)]
+allCaseValues trm = case trm of
+  T _ cs -> [(p:ps, t) | Cas pp t0 <- cs, p <- pp, (ps,t) <- allCaseValues t0]
+  _      -> [([],trm)]
+
+-- to gather all linearizations; assumes normal form, preserves label and args
+allLinValues :: Term -> Err [[(Label,[([Patt],Term)])]]
+allLinValues trm = do
+  lts <- allLinFields trm
+  mapM (mapPairsM (return . allCaseValues)) lts
+
+redirectIdent n f@(CIQ _ c) = CIQ n c
+
+
+{- ---- to be removed 21/9
+-- to analyse types and terms into eta normal form
+
+typeForm :: Exp -> Err (Context, Exp, [Exp])
+typeForm e = do
+  (cont,val) <- getContext e
+  (cat,args) <- getArgs val
+  return (cont,cat,args)
+
+getContext :: Exp -> Err (Context, Exp)
+getContext e = case e of
+  EProd x a b -> do
+    (g,b') <- getContext b
+    return ((x,a):g,b')
+  _ -> return ([],e)
+
+valAtom :: Exp -> Err Atom
+valAtom e = do
+  (_,val,_) <- typeForm e
+  case val of
+    EAtom a -> return a
+    _ -> prtBad "atom expected instead of" val
+ 
+valCat :: Exp -> Err CIdent
+valCat e = do
+  a <- valAtom e
+  case a of
+    AC c -> return c
+    _ -> prtBad "cat expected instead of" a
+
+termForm :: Exp -> Err ([A.Ident], Exp, [Exp])
+termForm e = do
+  (cont,val) <- getBinds e
+  (cat,args) <- getArgs val
+  return (cont,cat,args)
+
+getBinds :: Exp -> Err ([A.Ident], Exp)
+getBinds e = case e of
+  EAbs x b -> do
+    (g,b') <- getBinds b
+    return (x:g,b')
+  _ -> return ([],e)
+
+getArgs :: Exp -> Err (Exp,[Exp])
+getArgs = get [] where
+  get xs e = case e of
+    EApp f a -> get (a:xs) f
+    _ -> return (e, reverse xs)
+
+-- the inverses of these
+
+mkProd :: Context -> Exp -> Exp
+mkProd c e = foldr (uncurry EProd) e c
+
+mkApp :: Exp -> [Exp] -> Exp
+mkApp = foldl EApp
+
+mkAppAtom :: Atom -> [Exp] -> Exp
+mkAppAtom a = mkApp (EAtom a)
+
+mkAppCons :: CIdent -> [Exp] -> Exp
+mkAppCons c = mkAppAtom $ AC c
+
+mkType :: Context -> Exp -> [Exp] -> Exp
+mkType c e xs = mkProd c $ mkApp e xs
+
+mkAbs :: Context -> Exp -> Exp
+mkAbs c e = foldr EAbs e $ map fst c
+
+mkTerm :: Context -> Exp -> [Exp] -> Exp
+mkTerm c e xs = mkAbs c $ mkApp e xs
+
+mkAbsR :: [A.Ident] -> Exp -> Exp
+mkAbsR c e = foldr EAbs e c
+
+mkTermR :: [A.Ident] -> Exp -> [Exp] -> Exp
+mkTermR c e xs = mkAbsR c $ mkApp e xs
+
+-- this is used to create heuristic menus
+eqCatId :: Cat -> Atom -> Bool
+eqCatId (CIQ _ c) b = case b of
+  AC (CIQ _ d) -> c == d
+  AD (CIQ _ d) -> c == d
+  _ -> False
+
+-- a very weak notion of "compatible value category"
+compatCat :: Cat -> Type -> Bool
+compatCat c t = case t of
+  EAtom b  -> eqCatId c b
+  EApp f _  -> compatCat c f
+  _ -> False
+
+-- this is the way an atomic category looks as a type
+
+cat2type :: Cat -> Type
+cat2type = EAtom . AC
+
+compatType :: Type -> Type -> Bool
+compatType t = case t of
+  EAtom (AC c) -> compatCat c
+  _ -> (t ==)
+
+type Fun = CIdent
+type Cat = CIdent
+type Type = Exp
+
+mkFun, mkCat :: String -> String -> Fun
+mkFun m f = CIQ (A.identC m) (A.identC f)
+mkCat = mkFun
+
+mkFunC, mkCatC :: String -> Fun
+mkFunC s = let (m,f) = span (/= '.') s in mkFun m (drop 1 f)
+mkCatC = mkFunC
+
+-}
+
diff --git a/src/GF/Canon/CanonToGrammar.hs b/src/GF/Canon/CanonToGrammar.hs
new file mode 100644
index 000000000..550dc37a4
--- /dev/null
+++ b/src/GF/Canon/CanonToGrammar.hs
@@ -0,0 +1,167 @@
+module CanonToGrammar where
+
+import AbsGFC
+import GFC
+import MkGFC
+---import CMacros
+import qualified Modules as M
+import qualified Option  as O
+import qualified Grammar as G
+import qualified Macros  as F
+
+import Ident
+import Operations
+
+import Monad
+
+-- a decompiler. AR 12/6/2003
+
+canon2sourceModule :: CanonModule -> Err G.SourceModule
+canon2sourceModule (i,mi) = do
+  i'    <- redIdent i 
+  info' <- case mi of
+    M.ModMod m -> do
+      (e,os) <- redExtOpen m
+      flags  <- mapM redFlag $ M.flags m 
+      (abstr,mt)  <- case M.mtype m of
+          M.MTConcrete a -> do
+            a' <- redIdent a
+            return (a', M.MTConcrete a') 
+          M.MTAbstract -> return (i',M.MTAbstract) --- c' not needed
+          M.MTResource -> return (i',M.MTResource) --- c' not needed
+      defs   <- mapMTree redInfo $ M.jments m
+      return $ M.ModMod $ M.Module mt flags e os defs
+    _ -> Bad $ "cannot decompile module type"
+  return (i',info')
+ where
+   redExtOpen m = do
+     e' <- case M.extends m of
+       Just e -> liftM Just $ redIdent e
+       _ -> return Nothing
+     os' <- mapM (\ (M.OSimple i) -> liftM (\i -> M.OQualif i i) (redIdent i)) $ 
+                 M.opens m
+     return (e',os')
+
+redInfo :: (Ident,Info) -> Err (Ident,G.Info)
+redInfo (c,info) = errIn ("decompiling abstract" +++ show c) $ do
+  c' <- redIdent c 
+  info' <- case info of
+    AbsCat cont fs -> do
+      return $ G.AbsCat (Yes cont) (Yes fs)
+    AbsFun typ df -> do
+      return $ G.AbsFun (Yes typ) (Yes df)
+
+    ResPar par -> liftM (G.ResParam . Yes) $ mapM redParam par
+
+    CncCat pty ptr ppr -> do
+      ty'  <- redCType pty
+      trm' <- redCTerm ptr
+      ppr' <- redCTerm ppr 
+      return $ G.CncCat (Yes ty') (Yes trm') (Yes ppr')      
+    CncFun (CIQ abstr cat) xx body ppr -> do
+      xx'   <- mapM redArgVar xx
+      body' <- redCTerm body
+      ppr'  <- redCTerm ppr
+      return $ G.CncFun Nothing (Yes (F.mkAbs xx' body')) (Yes ppr')
+
+    AnyInd b c -> liftM (G.AnyInd b) $ redIdent c
+
+  return (c',info')
+
+redQIdent :: CIdent -> Err G.QIdent
+redQIdent (CIQ m c) = liftM2 (,) (redIdent m) (redIdent c)
+
+redIdent :: Ident -> Err Ident
+redIdent = return
+
+redFlag :: Flag -> Err O.Option
+redFlag (Flg f x) = return $ O.Opt (prIdent f,[prIdent x])
+
+redDecl :: Decl -> Err G.Decl
+redDecl (Decl x a) = liftM2 (,) (redIdent x) (redTerm a)
+
+redType :: Exp -> Err G.Type
+redType = redTerm
+
+redTerm :: Exp -> Err G.Term
+redTerm t = return $ trExp t
+
+-- resource
+
+redParam (ParD c cont) = do
+  c'    <- redIdent c
+  cont' <- mapM redCType cont
+  return $ (c', [(IW,t) | t <- cont'])
+
+-- concrete syntax
+
+redCType :: CType -> Err G.Type
+redCType t = case t of
+  RecType lbs -> do
+    let (ls,ts) = unzip [(l,t) | Lbg l t <- lbs]
+        ls' = map redLabel ls
+    ts' <- mapM redCType ts
+    return $ G.RecType $ zip ls' ts'
+  Table p v  -> liftM2 G.Table (redCType p) (redCType v)
+  Cn mc  -> liftM (uncurry G.QC) $ redQIdent mc
+  TStr -> return $ F.typeStr
+
+redCTerm :: Term -> Err G.Term
+redCTerm x = case x of
+  Arg argvar  -> liftM G.Vr $ redArgVar argvar
+  I cident  -> liftM (uncurry G.Q) $ redQIdent cident
+  Con cident terms  -> liftM2 F.mkApp 
+                         (liftM (uncurry G.QC) $ redQIdent cident) 
+                         (mapM redCTerm terms)
+  LI id  -> liftM G.Vr $ redIdent id
+  R assigns  -> do
+    let (ls,ts) = unzip [(l,t) | Ass l t <- assigns]
+    let ls' = map redLabel ls
+    ts' <- mapM redCTerm ts
+    return $ G.R [(l,(Nothing,t)) | (l,t) <- zip ls' ts']
+  P term label  -> liftM2 G.P (redCTerm term) (return $ redLabel label)
+  T ctype cases  -> do
+    ctype' <- redCType ctype
+    let (ps,ts) = unzip [(p,t) | Cas ps t <- cases, p <- ps] --- destroys sharing
+    ps' <- mapM redPatt ps
+    ts' <- mapM redCTerm ts                   --- duplicates work for shared rhss
+    let tinfo = case ps' of
+                  [G.PV _] -> G.TTyped ctype'
+                  _ -> G.TComp ctype'
+    return $ G.T tinfo $ zip ps' ts'
+  S term0 term  -> liftM2 G.S (redCTerm term0) (redCTerm term)
+  C term0 term  -> liftM2 G.C (redCTerm term0) (redCTerm term)
+  FV terms  -> liftM G.FV $ mapM redCTerm terms
+  K (KS str) -> return $ G.K str
+  E  -> return $ G.Empty
+  K (KP d vs)  -> return $ 
+                    G.Alts (tList d,[(tList s, G.Strs $ map G.K v) | Var s v <- vs])
+ where
+   tList ss = case ss of --- this should be in Macros
+     [] -> G.Empty
+     _ -> foldr1 G.C $ map G.K ss
+
+failure x = Bad $ "not yet" +++ show x ----
+
+redArgVar :: ArgVar -> Err Ident
+redArgVar x = case x of
+  A x i -> return $ IA (prIdent x, fromInteger i)
+  AB x b i -> return $ IAV (prIdent x, fromInteger b, fromInteger i)
+
+redLabel :: Label -> G.Label
+redLabel (L x) = G.LIdent $ prIdent x
+redLabel (LV i) = G.LVar $ fromInteger i
+
+redPatt :: Patt -> Err G.Patt
+redPatt p = case p of
+  PV x -> liftM G.PV $ redIdent x
+  PC mc ps -> do
+    (m,c) <- redQIdent mc
+    liftM (G.PP m c) (mapM redPatt ps) 
+  PR rs -> do
+    let (ls,ts) = unzip [(l,t) | PAss l t <- rs]
+        ls' = map redLabel ls
+    ts <- mapM redPatt ts
+    return $ G.PR $ zip ls' ts
+  _ -> Bad $ "cannot recompile pattern" +++ show p
+
diff --git a/src/GF/Canon/GFC.hs b/src/GF/Canon/GFC.hs
new file mode 100644
index 000000000..63b697a35
--- /dev/null
+++ b/src/GF/Canon/GFC.hs
@@ -0,0 +1,48 @@
+module GFC where
+
+import AbsGFC
+import PrintGFC
+import qualified Abstract as A
+
+import Ident
+import Option
+import Zipper
+import Operations
+import qualified Modules as M
+
+import Char
+
+-- canonical GF. AR 10/9/2002 -- 9/5/2003 -- 21/9
+
+type Context = [(Ident,Exp)]
+
+type CanonGrammar = M.MGrammar Ident Flag Info
+
+type CanonModInfo = M.ModInfo Ident Flag Info
+
+type CanonModule = (Ident, CanonModInfo)
+
+type CanonAbs = M.Module Ident Option Info
+
+data Info = 
+   AbsCat  A.Context [A.Fun]
+ | AbsFun  A.Type A.Term
+
+ | ResPar  [ParDef]
+ | ResOper CType Term     -- global constant
+ | CncCat  CType Term Printname
+ | CncFun  CIdent [ArgVar] Term Printname
+ | AnyInd Bool Ident
+  deriving (Show)
+
+type Printname = Term
+
+-- some printing ----
+
+{-
+prCanonModInfo :: (Ident,CanonModInfo) -> String
+prCanonModInfo = printTree . info2mod
+
+prGrammar :: CanonGrammar -> String
+prGrammar = printTree . grammar2canon
+-}
diff --git a/src/GF/Canon/GetGFC.hs b/src/GF/Canon/GetGFC.hs
new file mode 100644
index 000000000..225b0712a
--- /dev/null
+++ b/src/GF/Canon/GetGFC.hs
@@ -0,0 +1,22 @@
+module GetGFC where
+
+import Operations
+import ParGFC
+import GFC
+import MkGFC
+import Modules
+import GetGrammar (err2err) ---
+import UseIO
+
+getCanonModule :: FilePath -> IOE CanonModule
+getCanonModule file = do
+  gr <- getCanonGrammar file
+  case modules gr of
+    [m] -> return m
+    _ -> ioeErr $ Bad "expected exactly one module in a file"
+
+getCanonGrammar :: FilePath -> IOE CanonGrammar
+getCanonGrammar file = do
+  s <- ioeIO $ readFileIf file
+  c <- ioeErr $ err2err $ pCanon $ myLexer s
+  return $ canon2grammar c
diff --git a/src/GF/Canon/LexGFC.hs b/src/GF/Canon/LexGFC.hs
new file mode 100644
index 000000000..56048dce3
--- /dev/null
+++ b/src/GF/Canon/LexGFC.hs
@@ -0,0 +1,105 @@
+
+module LexGFC where
+
+import Alex
+import ErrM
+
+pTSpec p = PT p . TS    
+
+ident  p = PT p . eitherResIdent TV 
+
+string p = PT p . TL . unescapeInitTail 
+
+int    p = PT p . TI    
+
+
+data Tok =
+   TS String     -- reserved words
+ | TL String     -- string literals
+ | TI String     -- integer literals
+ | TV String     -- identifiers
+ | TD String     -- double precision float literals
+ | TC String     -- character literals
+
+ deriving (Eq,Show)
+
+data Token = 
+   PT  Posn Tok
+ | Err Posn
+  deriving Show
+
+tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
+tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
+tokenPos _ = "end of file"
+
+prToken t = case t of
+  PT _ (TS s) -> s
+  PT _ (TI s) -> s
+  PT _ (TV s) -> s
+  PT _ (TD s) -> s
+  PT _ (TC s) -> s
+  _ -> show t
+
+tokens:: String -> [Token]
+tokens inp = scan tokens_scan inp
+
+tokens_scan:: Scan Token
+tokens_scan = load_scan (tokens_acts,stop_act) tokens_lx
+        where
+        stop_act p ""  = []
+        stop_act p inp = [Err p]
+
+eitherResIdent :: (String -> Tok) -> String -> Tok
+eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where
+  isResWord s = isInTree s $
+    B "lin" (B "concrete" (B "abstract" (B "Type" (B "Str" N N) N) (B "cat" N N)) (B "fun" (B "flags" (B "data" N N) N) (B "in" N N))) (B "param" (B "open" (B "of" (B "lincat" N N) N) (B "oper" N N)) (B "table" (B "resource" (B "pre" N 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
+
+unescapeInitTail :: String -> String
+unescapeInitTail = unesc . tail where
+  unesc s = case s of
+    '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs
+    '\\':'n':cs  -> '\n' : unesc cs
+    '\\':'t':cs  -> '\t' : unesc cs
+    '"':[]    -> []
+    c:cs      -> c : unesc cs
+    _         -> []
+
+tokens_acts = [("ident",ident),("int",int),("pTSpec",pTSpec),("string",string)]
+
+tokens_lx :: [(Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))]
+tokens_lx = [lx__0_0,lx__1_0,lx__2_0,lx__3_0,lx__4_0,lx__5_0,lx__6_0,lx__7_0,lx__8_0,lx__9_0,lx__10_0,lx__11_0]
+lx__0_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__0_0 = (False,[],-1,(('\t','\255'),[('\t',1),('\n',1),('\v',1),('\f',1),('\r',1),(' ',1),('!',6),('"',8),('$',6),('(',6),(')',6),('*',2),('+',5),(',',6),('-',3),('.',6),('/',6),('0',11),('1',11),('2',11),('3',11),('4',11),('5',11),('6',11),('7',11),('8',11),('9',11),(':',6),(';',6),('<',6),('=',4),('>',6),('?',6),('@',6),('A',7),('B',7),('C',7),('D',7),('E',7),('F',7),('G',7),('H',7),('I',7),('J',7),('K',7),('L',7),('M',7),('N',7),('O',7),('P',7),('Q',7),('R',7),('S',7),('T',7),('U',7),('V',7),('W',7),('X',7),('Y',7),('Z',7),('[',6),('\\',6),(']',6),('_',6),('a',7),('b',7),('c',7),('d',7),('e',7),('f',7),('g',7),('h',7),('i',7),('j',7),('k',7),('l',7),('m',7),('n',7),('o',7),('p',7),('q',7),('r',7),('s',7),('t',7),('u',7),('v',7),('w',7),('x',7),('y',7),('z',7),('{',6),('|',6),('}',6),('\192',7),('\193',7),('\194',7),('\195',7),('\196',7),('\197',7),('\198',7),('\199',7),('\200',7),('\201',7),('\202',7),('\203',7),('\204',7),('\205',7),('\206',7),('\207',7),('\208',7),('\209',7),('\210',7),('\211',7),('\212',7),('\213',7),('\214',7),('\216',7),('\217',7),('\218',7),('\219',7),('\220',7),('\221',7),('\222',7),('\223',7),('\224',7),('\225',7),('\226',7),('\227',7),('\228',7),('\229',7),('\230',7),('\231',7),('\232',7),('\233',7),('\234',7),('\235',7),('\236',7),('\237',7),('\238',7),('\239',7),('\240',7),('\241',7),('\242',7),('\243',7),('\244',7),('\245',7),('\246',7),('\248',7),('\249',7),('\250',7),('\251',7),('\252',7),('\253',7),('\254',7),('\255',7)]))
+lx__1_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__1_0 = (True,[(0,"",[],Nothing,Nothing)],-1,(('\t',' '),[('\t',1),('\n',1),('\v',1),('\f',1),('\r',1),(' ',1)]))
+lx__2_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__2_0 = (False,[],-1,(('*','*'),[('*',6)]))
+lx__3_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__3_0 = (False,[],-1,(('>','>'),[('>',6)]))
+lx__4_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__4_0 = (True,[(1,"pTSpec",[],Nothing,Nothing)],-1,(('>','>'),[('>',6)]))
+lx__5_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__5_0 = (True,[(1,"pTSpec",[],Nothing,Nothing)],-1,(('+','+'),[('+',6)]))
+lx__6_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__6_0 = (True,[(1,"pTSpec",[],Nothing,Nothing)],-1,(('0','0'),[]))
+lx__7_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__7_0 = (True,[(2,"ident",[],Nothing,Nothing)],-1,(('\'','\255'),[('\'',7),('0',7),('1',7),('2',7),('3',7),('4',7),('5',7),('6',7),('7',7),('8',7),('9',7),('A',7),('B',7),('C',7),('D',7),('E',7),('F',7),('G',7),('H',7),('I',7),('J',7),('K',7),('L',7),('M',7),('N',7),('O',7),('P',7),('Q',7),('R',7),('S',7),('T',7),('U',7),('V',7),('W',7),('X',7),('Y',7),('Z',7),('_',7),('a',7),('b',7),('c',7),('d',7),('e',7),('f',7),('g',7),('h',7),('i',7),('j',7),('k',7),('l',7),('m',7),('n',7),('o',7),('p',7),('q',7),('r',7),('s',7),('t',7),('u',7),('v',7),('w',7),('x',7),('y',7),('z',7),('\192',7),('\193',7),('\194',7),('\195',7),('\196',7),('\197',7),('\198',7),('\199',7),('\200',7),('\201',7),('\202',7),('\203',7),('\204',7),('\205',7),('\206',7),('\207',7),('\208',7),('\209',7),('\210',7),('\211',7),('\212',7),('\213',7),('\214',7),('\216',7),('\217',7),('\218',7),('\219',7),('\220',7),('\221',7),('\222',7),('\223',7),('\224',7),('\225',7),('\226',7),('\227',7),('\228',7),('\229',7),('\230',7),('\231',7),('\232',7),('\233',7),('\234',7),('\235',7),('\236',7),('\237',7),('\238',7),('\239',7),('\240',7),('\241',7),('\242',7),('\243',7),('\244',7),('\245',7),('\246',7),('\248',7),('\249',7),('\250',7),('\251',7),('\252',7),('\253',7),('\254',7),('\255',7)]))
+lx__8_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__8_0 = (False,[],8,(('\n','\\'),[('\n',-1),('"',10),('\\',9)]))
+lx__9_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__9_0 = (False,[],-1,(('"','t'),[('"',8),('\'',8),('\\',8),('n',8),('t',8)]))
+lx__10_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__10_0 = (True,[(3,"string",[],Nothing,Nothing)],-1,(('0','0'),[]))
+lx__11_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__11_0 = (True,[(4,"int",[],Nothing,Nothing)],-1,(('0','9'),[('0',11),('1',11),('2',11),('3',11),('4',11),('5',11),('6',11),('7',11),('8',11),('9',11)]))
+
diff --git a/src/GF/Canon/Look.hs b/src/GF/Canon/Look.hs
new file mode 100644
index 000000000..a71d024c2
--- /dev/null
+++ b/src/GF/Canon/Look.hs
@@ -0,0 +1,141 @@
+module Look where
+
+import AbsGFC
+import GFC
+import PrGrammar
+import CMacros
+----import Values
+import MMacros
+import qualified Modules as M
+
+import Operations
+
+import Monad
+import List
+
+-- lookup in GFC. AR 2003
+
+-- linearization lookup
+
+lookupCncInfo :: CanonGrammar -> CIdent -> Err Info
+lookupCncInfo gr f@(CIQ m c) = do
+  mt <- M.lookupModule gr m
+  case mt of
+    M.ModMod a -> errIn ("module" +++ prt m) $ 
+                  lookupTree prt c $ M.jments a 
+    _ -> prtBad "not concrete module" m
+
+lookupLin :: CanonGrammar -> CIdent -> Err Term
+lookupLin gr f = do
+  info <- lookupCncInfo gr f
+  case info of
+    CncFun _ _ t _ -> return t
+    CncCat _ t _ -> return t
+    AnyInd _ n -> lookupLin gr $ redirectIdent n f
+
+lookupResInfo :: CanonGrammar -> CIdent -> Err Info
+lookupResInfo gr f@(CIQ m c) = do
+  mt <- M.lookupModule gr m
+  case mt of
+    M.ModMod a -> lookupTree prt c $ M.jments a 
+    _ -> prtBad "not resource module" m
+
+lookupGlobal :: CanonGrammar -> CIdent -> Err Term
+lookupGlobal gr f = do
+  info <- lookupResInfo gr f
+  case info of
+    ResOper _ t -> return t
+    AnyInd _ n -> lookupGlobal gr $ redirectIdent n f
+    _ -> prtBad "cannot find global" f
+
+lookupParamValues :: CanonGrammar -> CIdent -> Err [Term]
+lookupParamValues gr pt@(CIQ m _) = do
+  info <- lookupResInfo gr pt
+  case info of
+    ResPar ps -> liftM concat $ mapM mkPar ps
+    AnyInd _ n -> lookupParamValues gr $ redirectIdent n pt
+    _ -> prtBad "cannot find parameter type" pt
+ where
+   mkPar (ParD f co) = do
+     vs <- liftM combinations $ mapM (allParamValues gr) co
+     return $ map (Con (CIQ m f)) vs
+
+-- this is needed since param type can also be a record type
+
+allParamValues :: CanonGrammar -> CType -> Err [Term]
+allParamValues cnc ptyp = case ptyp of
+  Cn pc -> lookupParamValues cnc pc
+  RecType r -> do
+    let (ls,tys) = unzip [(l,t) | Lbg l t <- r]
+    tss <- mapM allPV tys
+    return [R (map (uncurry Ass) (zip ls ts)) | ts <- combinations tss]
+  _ -> prtBad "cannot possibly find parameter values for" ptyp
+ where
+   allPV = allParamValues cnc
+
+-- runtime computation on GFC objects
+
+ccompute :: CanonGrammar -> [Term] -> Term -> Err Term
+ccompute cnc = comp [] 
+ where
+  comp g xs t = case t of
+    Arg (A _ i)    -> errIn ("argument list") $ xs !? fromInteger i
+    Arg (AB _ _ i) -> errIn ("argument list for binding") $ xs !? fromInteger i
+    I c     -> look c 
+    LI c    -> lookVar c g
+
+    -- short-cut computation of selections: compute the table only if needed
+    S u v   -> do
+      u' <- compt u
+      case u' of
+        T _ [Cas [PW] b] -> compt b  
+        T _ [Cas [PV x] b] -> do
+          v' <- compt v
+          comp ((x,v') : g) xs b  
+        T _ cs -> do
+          v' <- compt v
+          if noVar v' 
+             then matchPatt cs v' >>= compt
+             else return $ S u' v'
+
+        _      -> liftM (S u') $ compt v
+
+    P u l  -> do
+      u' <- compt u
+      case u' of
+        R rs -> maybe (Bad ("unknown label" +++ prt l +++ "in" +++ prt u'))
+                      return $ 
+                        lookup l [ (x,y) | Ass x y <- rs]
+        _    -> return $ P u' l
+    FV ts    -> liftM FV (mapM compt ts)
+    C E b    -> compt b
+    C a E    -> compt a
+    C a b    -> do
+      a' <- compt a
+      b' <- compt b
+      return $ case (a',b') of
+        (E,_) -> b'
+        (_,E) -> a'
+        _     -> C a' b'
+    R rs     -> liftM (R . map (uncurry Ass)) $ 
+                  mapPairsM compt [(l,r) | Ass l r <- rs]
+
+    -- only expand the table when the table is really needed: use expandLin
+    T ty rs -> liftM (T ty . map (uncurry Cas)) $ 
+                  mapPairsM compt [(l,r) | Cas l r <- rs]
+
+    Con c xs -> liftM (Con c) $ mapM compt xs
+
+    _        -> return t  
+   where
+     compt = comp g xs
+     look c = lookupGlobal cnc c
+
+     lookVar c co = case lookup c co of
+       Just t -> return t
+       _ -> return $ LI c --- Bad $ "unknown local variable" +++ prt c --- 
+
+     noVar v = case v of
+       LI _ -> False
+       R rs -> all noVar [t | Ass _ t <- rs]
+       _    -> True --- other cases?
diff --git a/src/GF/Canon/MkGFC.hs b/src/GF/Canon/MkGFC.hs
new file mode 100644
index 000000000..d7641ca21
--- /dev/null
+++ b/src/GF/Canon/MkGFC.hs
@@ -0,0 +1,121 @@
+module MkGFC where
+
+import GFC
+import AbsGFC
+import qualified Abstract as A
+import PrGrammar
+
+import Ident
+import Operations
+import qualified Modules as M
+
+prCanonModInfo :: CanonModule -> String
+prCanonModInfo = prt . info2mod
+
+canon2grammar :: Canon -> CanonGrammar
+canon2grammar (Gr modules) = M.MGrammar $ map mod2info modules where
+  mod2info m = case m of
+    Mod mt e os flags defs -> 
+      let defs' = buildTree $ map def2info defs
+          (a,mt') = case mt of
+            MTAbs a -> (a,M.MTAbstract)
+            MTRes a -> (a,M.MTResource)
+            MTCnc a x -> (a,M.MTConcrete x)
+      in (a,M.ModMod (M.Module mt' flags (ee e) (oo os) defs'))
+  ee (Ext m) = Just m
+  ee _ = Nothing
+  oo (Opens ms) = map M.OSimple ms
+  oo _ = []
+
+grammar2canon :: CanonGrammar -> Canon
+grammar2canon (M.MGrammar modules) = Gr $ map info2mod modules 
+
+info2mod m = case m of
+    (a, M.ModMod (M.Module mt flags me os defs)) -> 
+      let defs' = map info2def $ tree2list defs 
+          mt'   = case mt of
+             M.MTAbstract -> MTAbs a
+             M.MTResource -> MTRes a
+             M.MTConcrete x -> MTCnc a x
+      in
+        Mod mt' (gfcE me) (gfcO os) flags defs'
+ where
+  gfcE = maybe NoExt Ext
+  gfcO os = if null os then NoOpens else Opens [m | M.OSimple m <- os]
+
+
+-- these translations are meant to be trivial
+
+defs2infos = sorted2tree . map def2info
+
+def2info d = case d of
+  AbsDCat c cont fs -> (c,AbsCat (trCont cont) (trFs fs))
+  AbsDFun c ty df   -> (c,AbsFun (trExp ty) (trExp df))
+  ResDPar c    df   -> (c,ResPar df)
+  ResDOper c ty df  -> (c,ResOper ty df)
+  CncDCat c ty df pr   -> (c, CncCat ty df pr)
+  CncDFun f c xs li pr -> (f, CncFun c xs li pr)
+  AnyDInd c b m        -> (c, AnyInd (b == Canon) m)
+
+-- from file to internal
+
+trCont cont = [(x,trExp t) | Decl x t <- cont]
+
+trFs = map trQIdent
+
+trExp t = case t of
+  EProd x a b -> A.Prod x (trExp a) (trExp b)
+  EAbs  x   b -> A.Abs  x (trExp b)
+  EApp  f a   -> A.App  (trExp f)  (trExp a)
+  EEq _       -> A.Eqs [] ---- eqs
+  _    -> trAt t
+ where
+  trAt (EAtom t) = case t of
+    AC c   -> (uncurry A.Q)  $ trQIdent c
+    AD c   -> (uncurry A.QC) $ trQIdent c
+    AV v   -> A.Vr v
+    AM i   -> A.Meta $ A.MetaSymb $ fromInteger i
+    AT s   -> A.Sort $ prt s
+    AS s   -> A.K s
+    AI i   -> A.EInt $ fromInteger i
+
+trQIdent (CIQ m c) = (m,c)
+
+-- from internal to file
+
+infos2defs = map info2def . tree2list
+
+info2def d = case d of
+  (c,AbsCat cont fs)    -> AbsDCat c (rtCont cont) (rtFs fs)
+  (c,AbsFun ty df)      -> AbsDFun c (rtExp ty) (rtExp df)
+  (c,ResPar    df)      -> ResDPar c df
+  (c,ResOper ty df)     -> ResDOper c ty df
+  (c,CncCat ty df pr)   -> CncDCat c ty df pr
+  (f,CncFun c xs li pr) -> CncDFun f c xs li pr
+  (c,AnyInd b m)        -> AnyDInd c (if b then Canon else NonCan) m
+
+rtCont cont = [Decl (rtIdent x) (rtExp t) | (x,t) <- cont]
+
+rtFs = map rtQIdent
+
+rtExp t = case t of
+  A.Prod x a b -> EProd (rtIdent x) (rtExp a) (rtExp b)
+  A.Abs  x   b -> EAbs  (rtIdent x) (rtExp b)
+  A.App  f a   -> EApp  (rtExp f) (rtExp a)
+  A.Eqs _      -> EEq [] ---- eqs
+  _ -> EAtom $ rtAt t
+ where
+  rtAt t = case t of
+    A.Q m c        -> AC $ rtQIdent (m,c)
+    A.QC m c       -> AD $ rtQIdent (m,c)
+    A.Vr v         -> AV v
+    A.Meta i       -> AM $ toInteger $ A.metaSymbInt i
+    A.Sort "Type"  -> AT SType
+    A.K s          -> AS s
+    A.EInt i       -> AI $ toInteger i
+    _ -> error $ "MkGFC.rt not defined for" +++ show t
+
+rtQIdent (m,c) = CIQ (rtIdent m) (rtIdent c)
+rtIdent x 
+  | isWildIdent x = identC "h_" --- needed in declarations
+  | otherwise = identC $ prt x ---
diff --git a/src/GF/Canon/PrExp.hs b/src/GF/Canon/PrExp.hs
new file mode 100644
index 000000000..6052f9a7f
--- /dev/null
+++ b/src/GF/Canon/PrExp.hs
@@ -0,0 +1,36 @@
+module PrExp where
+
+import AbsGFC
+import GFC
+
+import Operations
+
+-- some printing
+
+-- print trees without qualifications
+
+prExp :: Exp -> String
+prExp e = case e of
+  EApp f a   -> pr1 f +++ pr2 a
+  EAbsR x b  -> "\\" ++ prtt x +++ "->" +++ prExp b
+  EAbs x _ b -> prExp $ EAbsR x b
+  EProd x a b -> "(\\" ++ prtt x +++ ":" +++ prExp a ++ ")" +++ "->" +++ prExp b
+  EAtomR a   -> prAtom a
+  EAtom a _  -> prAtom a
+  _ -> prtt e
+ where
+   pr1 e = case e of
+     EAbsR _ _   -> prParenth $ prExp e
+     EAbs _ _ _  -> prParenth $ prExp e
+     EProd _ _ _ -> prParenth $ prExp e
+     _ -> prExp e
+   pr2 e = case e of
+     EApp _ _ -> prParenth $ prExp e
+     _ -> pr1 e
+
+prAtom a = case a of
+  AC c -> prCIdent c
+  AD c -> prCIdent c
+  _ -> prtt a
+
+prCIdent (CIQ _ c) = prtt c
diff --git a/src/GF/Canon/PrintGFC.hs b/src/GF/Canon/PrintGFC.hs
new file mode 100644
index 000000000..c4f2e7d62
--- /dev/null
+++ b/src/GF/Canon/PrintGFC.hs
@@ -0,0 +1,319 @@
+module PrintGFC where
+
+-- pretty-printer generated by the BNF converter, except handhacked spacing --H
+
+import Ident --H
+import AbsGFC
+import Char
+
+-- the top-level printing method
+printTree :: Print a => a -> String
+printTree = render . prt 0
+
+-- you may want to change render and parenth
+
+render :: [String] -> String
+render = rend 0 where
+  rend i ss = case ss of
+    "NEW"    :ts -> realnew   $ rend i ts --H
+    "<"      :ts -> cons "<"  $ rend i ts --H
+    "$"      :ts -> cons "$"  $ rend i ts --H
+    "?"      :ts -> cons "?"  $ rend i ts --H
+    "["      :ts -> cons "["  $ rend i ts
+    "("      :ts -> cons "("  $ rend i ts
+    "{"      :ts -> cons "{"  $ new (i+1) $ rend (i+1) ts
+    "}" : ";":ts -> new (i-1) $ space "}" $ cons ";" $ new (i-1) $ rend (i-1) ts
+    "}"      :ts -> new (i-1) $ cons "}" $ new (i-1) $ rend (i-1) ts
+    ";"      :ts -> cons ";"  $ new i $ rend i ts
+    t  : "," :ts -> cons t    $ space "," $ rend i ts
+    t  : ")" :ts -> cons t    $ cons ")"  $ rend i ts
+    t  : "]" :ts -> cons t    $ cons "]"  $ rend i ts
+    t  : ">" :ts -> cons t    $ cons ">"  $ rend i ts --H
+    t  : "." :ts -> cons t    $ cons "."  $ rend i ts --H
+    t        :ts -> realspace t   $ rend i ts --H
+    _            -> ""
+  cons s t  = s ++ t
+  space t s = t ++ " " ++ s --H
+  realspace t s = if null s then t else t ++ " " ++ s --H
+  new i s   = s      --H '\n' : replicate (2*i) ' ' ++ dropWhile isSpace s
+  realnew s = '\n':s --H
+
+parenth :: [String] -> [String]
+parenth ss = ["("] ++ ss ++ [")"]
+
+-- the printer class does the job
+class Print a where
+  prt :: Int -> a -> [String]
+  prtList :: [a] -> [String]
+  prtList = concat . map (prt 0)
+
+instance Print a => Print [a] where
+  prt _ = prtList
+
+instance Print Integer where
+  prt _ = (:[]) . show
+
+instance Print Double where
+  prt _ = (:[]) . show
+
+instance Print Char where
+  prt _ s = ["'" ++ mkEsc s ++ "'"]
+  prtList s = ["\"" ++ concatMap mkEsc s ++ "\""]
+
+mkEsc s = case s of
+  _ | elem s "\\\"'" -> '\\':[s]
+  '\n' -> "\\n"
+  '\t' -> "\\t"
+  _ -> [s]
+
+prPrec :: Int -> Int -> [String] -> [String]
+prPrec i j = if j<i then parenth else id
+
+
+instance Print Ident where
+  prt _ i = [prIdent i]
+  prtList es = case es of
+   [] -> (concat [])
+   [x] -> (concat [prt 0 x])
+   x:xs -> (concat [prt 0 x , [","] , prt 0 xs])
+
+
+
+instance Print Canon where
+  prt i e = case e of
+   Gr modules -> prPrec i 0 (concat [prt 0 modules])
+
+
+instance Print Module where
+  prt i e = case e of
+   Mod modtype extend open flags defs -> prPrec i 0 (concat [prt 0 modtype , ["="] , prt 0 extend , prt 0 open , ["{"] , prt 0 flags , prt 0 defs , ["}"]])
+
+  prtList es = case es of
+   [] -> (concat [])
+   x:xs -> (concat [prt 0 x , prt 0 xs])
+
+instance Print ModType where
+  prt i e = case e of
+   MTAbs id -> prPrec i 0 (concat [["abstract"] , prt 0 id])
+   MTCnc id0 id -> prPrec i 0 (concat [["concrete"] , prt 0 id0 , ["of"] , prt 0 id])
+   MTRes id -> prPrec i 0 (concat [["resource"] , prt 0 id])
+
+
+instance Print Extend where
+  prt i e = case e of
+   Ext id -> prPrec i 0 (concat [prt 0 id , ["**"]])
+   NoExt  -> prPrec i 0 (concat [])
+
+
+instance Print Open where
+  prt i e = case e of
+   NoOpens  -> prPrec i 0 (concat [])
+   Opens ids -> prPrec i 0 (concat [["open"] , prt 0 ids , ["in"]])
+
+
+instance Print Flag where
+  prt i e = case e of
+   Flg id0 id -> prPrec i 0 (concat [["flags"] , prt 0 id0 , ["="] , prt 0 id])
+
+  prtList es = case es of
+   [] -> (concat [])
+   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
+
+instance Print Def where
+  prt i e = case e of
+   AbsDCat id decls cidents -> prPrec i 0 (concat [["cat"] , prt 0 id , ["["] , prt 0 decls , ["]"] , ["="] , prt 0 cidents])
+   AbsDFun id exp0 exp -> prPrec i 0 (concat [["fun"] , prt 0 id , [":"] , prt 0 exp0 , ["="] , prt 0 exp])
+   ResDPar id pardefs -> prPrec i 0 (concat [["param"] , prt 0 id , ["="] , prt 0 pardefs])
+   ResDOper id ctype term -> prPrec i 0 (concat [["oper"] , prt 0 id , [":"] , prt 0 ctype , ["="] , prt 0 term])
+   CncDCat id ctype term0 term -> prPrec i 0 (concat [["lincat"] , prt 0 id , ["="] , prt 0 ctype , ["="] , prt 0 term0 , [";"] , prt 0 term])
+   CncDFun id cident argvars term0 term -> prPrec i 0 (concat [["lin"] , prt 0 id , [":"] , prt 0 cident , ["="] , ["\\"] , prt 0 argvars , ["->"] , prt 0 term0 , [";"] , prt 0 term])
+   AnyDInd id0 status id -> prPrec i 0 (concat [prt 0 id0 , prt 0 status , ["in"] , prt 0 id])
+
+  prtList es = case es of
+   [] -> (concat [])
+   x:xs -> (concat [prt 0 x , [";","NEW"] , prt 0 xs]) --H
+
+instance Print ParDef where
+  prt i e = case e of
+   ParD id ctypes -> prPrec i 0 (concat [prt 0 id , prt 0 ctypes])
+
+  prtList es = case es of
+   [] -> (concat [])
+   [x] -> (concat [prt 0 x])
+   x:xs -> (concat [prt 0 x , ["|"] , prt 0 xs])
+
+instance Print Status where
+  prt i e = case e of
+   Canon  -> prPrec i 0 (concat [["data"]])
+   NonCan  -> prPrec i 0 (concat [])
+
+
+instance Print CIdent where
+  prt i e = case e of
+   CIQ id0 id -> prPrec i 0 (concat [prt 0 id0 , ["."] , prt 0 id])
+
+  prtList es = case es of
+   [] -> (concat [])
+   x:xs -> (concat [prt 0 x , prt 0 xs])
+
+instance Print Exp where
+  prt i e = case e of
+   EApp exp0 exp -> prPrec i 1 (concat [prt 1 exp0 , prt 2 exp])
+   EProd id exp0 exp -> prPrec i 0 (concat [["("] , prt 0 id , [":"] , prt 0 exp0 , [")"] , ["->"] , prt 0 exp])
+   EAtom atom -> prPrec i 2 (concat [prt 0 atom])
+   EAbs id exp -> prPrec i 0 (concat [["\\"] , prt 0 id , ["->"] , prt 0 exp])
+   EEq equations -> prPrec i 0 (concat [["{"] , prt 0 equations , ["}"]])
+
+instance Print Sort where
+  prt i e = case e of
+   SType  -> prPrec i 0 (concat [["Type"]])
+
+instance Print Equation where
+  prt i e = case e of
+   Equ apatts exp -> prPrec i 0 (concat [prt 0 apatts , ["->"] , prt 0 exp])
+
+  prtList es = case es of
+   [] -> (concat [])
+   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
+
+instance Print APatt where
+  prt i e = case e of
+   APC cident apatts -> prPrec i 0 (concat [["("] , prt 0 cident , prt 0 apatts , [")"]])
+   APV id -> prPrec i 0 (concat [prt 0 id])
+   APS str -> prPrec i 0 (concat [prt 0 str])
+   API n -> prPrec i 0 (concat [prt 0 n])
+   APW  -> prPrec i 0 (concat [["_"]])
+
+  prtList es = case es of
+   [x] -> (concat [prt 0 x])
+   x:xs -> (concat [prt 0 x , prt 0 xs])
+
+instance Print Atom where
+  prt i e = case e of
+   AC cident -> prPrec i 0 (concat [prt 0 cident])
+   AD cident -> prPrec i 0 (concat [["<"] , prt 0 cident , [">"]])
+   AV id -> prPrec i 0 (concat [["$"] , prt 0 id])
+   AM n -> prPrec i 0 (concat [["?"] , prt 0 n])
+   AS str -> prPrec i 0 (concat [prt 0 str])
+   AI n -> prPrec i 0 (concat [prt 0 n])
+   AT sort -> prPrec i 0 (concat [prt 0 sort])
+
+
+instance Print Decl where
+  prt i e = case e of
+   Decl id exp -> prPrec i 0 (concat [prt 0 id , [":"] , prt 0 exp])
+
+  prtList es = case es of
+   [] -> (concat [])
+   [x] -> (concat [prt 0 x])
+   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
+
+instance Print CType where
+  prt i e = case e of
+   RecType labellings -> prPrec i 0 (concat [["{"] , prt 0 labellings , ["}"]])
+   Table ctype0 ctype -> prPrec i 0 (concat [["("] , prt 0 ctype0 , ["=>"] , prt 0 ctype , [")"]])
+   Cn cident -> prPrec i 0 (concat [prt 0 cident])
+   TStr  -> prPrec i 0 (concat [["Str"]])
+
+  prtList es = case es of
+   [] -> (concat [])
+   x:xs -> (concat [prt 0 x , prt 0 xs])
+
+instance Print Labelling where
+  prt i e = case e of
+   Lbg label ctype -> prPrec i 0 (concat [prt 0 label , [":"] , prt 0 ctype])
+
+  prtList es = case es of
+   [] -> (concat [])
+   [x] -> (concat [prt 0 x])
+   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
+
+instance Print Term where
+  prt i e = case e of
+   Arg argvar -> prPrec i 2 (concat [prt 0 argvar])
+   I cident -> prPrec i 2 (concat [prt 0 cident])
+   Con cident terms -> prPrec i 2 (concat [["<"] , prt 0 cident , prt 2 terms , [">"]])
+   LI id -> prPrec i 2 (concat [["$"] , prt 0 id])
+   R assigns -> prPrec i 2 (concat [["{"] , prt 0 assigns , ["}"]])
+   P term label -> prPrec i 1 (concat [prt 2 term , ["."] , prt 0 label])
+   T ctype cases -> prPrec i 1 (concat [["table"] , prt 0 ctype , ["{"] , prt 0 cases , ["}"]])
+   S term0 term -> prPrec i 1 (concat [prt 1 term0 , ["!"] , prt 2 term])
+   C term0 term -> prPrec i 0 (concat [prt 0 term0 , ["++"] , prt 1 term])
+   FV terms -> prPrec i 1 (concat [["variants"] , ["{"] , prt 2 terms , ["}"]])
+   K tokn -> prPrec i 2 (concat [prt 0 tokn])
+   E  -> prPrec i 2 (concat [["["] , ["]"]])
+
+  prtList es = case es of
+   [] -> (concat [])
+   x:xs -> (concat [prt 2 x , prt 2 xs])
+
+instance Print Tokn where
+  prt i e = case e of
+   KS str -> prPrec i 0 (concat [prt 0 str])
+   KP strs variants -> prPrec i 0 (concat [["["] , ["pre"] , prt 0 strs , ["{"] , prt 0 variants , ["}"] , ["]"]])
+
+
+instance Print Assign where
+  prt i e = case e of
+   Ass label term -> prPrec i 0 (concat [prt 0 label , ["="] , prt 0 term])
+
+  prtList es = case es of
+   [] -> (concat [])
+   [x] -> (concat [prt 0 x])
+   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
+
+instance Print Case where
+  prt i e = case e of
+   Cas patts term -> prPrec i 0 (concat [prt 0 patts , ["=>"] , prt 0 term])
+
+  prtList es = case es of
+   [] -> (concat [])
+   [x] -> (concat [prt 0 x])
+   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
+
+instance Print Variant where
+  prt i e = case e of
+   Var strs0 strs -> prPrec i 0 (concat [prt 0 strs0 , ["/"] , prt 0 strs])
+
+  prtList es = case es of
+   [] -> (concat [])
+   [x] -> (concat [prt 0 x])
+   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
+
+instance Print Label where
+  prt i e = case e of
+   L id -> prPrec i 0 (concat [prt 0 id])
+   LV n -> prPrec i 0 (concat [["$"] , prt 0 n])
+
+
+instance Print ArgVar where
+  prt i e = case e of
+   A id n -> prPrec i 0 (concat [prt 0 id , ["@"] , prt 0 n])
+   AB id n0 n -> prPrec i 0 (concat [prt 0 id , ["+"] , prt 0 n0 , ["@"] , prt 0 n])
+
+  prtList es = case es of
+   [] -> (concat [])
+   [x] -> (concat [prt 0 x])
+   x:xs -> (concat [prt 0 x , [","] , prt 0 xs])
+
+instance Print Patt where
+  prt i e = case e of
+   PC cident patts -> prPrec i 0 (concat [["("] , prt 0 cident , prt 0 patts , [")"]])
+   PV id -> prPrec i 0 (concat [prt 0 id])
+   PW  -> prPrec i 0 (concat [["_"]])
+   PR pattassigns -> prPrec i 0 (concat [["{"] , prt 0 pattassigns , ["}"]])
+
+  prtList es = case es of
+   [] -> (concat [])
+   x:xs -> (concat [prt 0 x , prt 0 xs])
+
+instance Print PattAssign where
+  prt i e = case e of
+   PAss label patt -> prPrec i 0 (concat [prt 0 label , ["="] , prt 0 patt])
+
+  prtList es = case es of
+   [] -> (concat [])
+   [x] -> (concat [prt 0 x])
+   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
+
+
diff --git a/src/GF/Canon/Share.hs b/src/GF/Canon/Share.hs
new file mode 100644
index 000000000..fc4d82b06
--- /dev/null
+++ b/src/GF/Canon/Share.hs
@@ -0,0 +1,116 @@
+module Share (shareModule, OptSpec, basicOpt, fullOpt) where
+
+import AbsGFC
+import Ident
+import GFC
+import qualified CMacros as C
+import Operations
+import List
+import qualified Modules as M
+
+-- optimization: sharing branches in tables. AR 25/4/2003
+-- following advice of Josef Svenningsson
+
+type OptSpec = [Integer] ---
+doOptFactor opt = elem 2 opt
+basicOpt = []
+fullOpt = [2]
+
+shareModule :: OptSpec -> (Ident, CanonModInfo) -> (Ident, CanonModInfo)
+shareModule opt (i,m) = case m of
+  M.ModMod (M.Module mt fs me ops js) -> 
+    (i,M.ModMod (M.Module mt fs me ops (mapTree (shareInfo opt) js)))
+  _ -> (i,m)
+
+shareInfo opt (c, CncCat ty t m) = (c, CncCat ty (shareOpt opt t) m)
+shareInfo opt (c, CncFun k xs t m) = (c, CncFun k xs (shareOpt opt t) m)
+shareInfo _ i = i
+
+-- the function putting together optimizations
+shareOpt :: OptSpec -> Term -> Term
+shareOpt opt 
+  | doOptFactor opt = share . factor 0
+  | otherwise = share
+
+-- we need no counter to create new variable names, since variables are 
+-- local to tables
+
+share :: Term -> Term
+share t = case t of
+  T ty cs  -> shareT ty [(p, share v) | Cas ps v <- cs, p <- ps]  -- only substant.
+  R lts -> R [Ass l (share t) | Ass l t <- lts]
+  P t l -> P (share t) l
+  S t a -> S (share t) (share a)
+  C t a -> C (share t) (share a)
+  FV ts -> FV (map share ts)
+
+  _ -> t  -- including D, which is always born shared
+
+ where
+   shareT ty = finalize ty . groupC . sortC
+ 
+   sortC :: [(Patt,Term)] -> [(Patt,Term)]
+   sortC = sortBy $ \a b -> compare (snd a) (snd b)
+
+   groupC :: [(Patt,Term)] -> [[(Patt,Term)]]
+   groupC = groupBy $ \a b -> snd a == snd b
+
+   finalize :: CType -> [[(Patt,Term)]] -> Term
+   finalize ty css = T ty [Cas (map fst ps) t | ps@((_,t):_) <- css]
+
+
+-- do even more: factor parametric branches
+
+factor :: Int -> Term -> Term
+factor i t = case t of
+  T _ [_] -> t
+  T _ []  -> t
+  T ty cs -> T ty $ factors i [Cas [p] (factor (i+1) v) | Cas ps v <- cs, p <- ps]
+  R lts   -> R [Ass l (factor i t) | Ass l t <- lts]
+  P t l   -> P (factor i t) l
+  S t a   -> S (factor i t) (factor i a)
+  C t a   -> C (factor i t) (factor i a)
+  FV ts   -> FV (map (factor i) ts)
+
+  _ -> t
+ where
+
+   factors i psvs =   -- we know psvs has at least 2 elements
+     let p   = pIdent i
+         vs' = map (mkFun p) psvs
+     in if   allEqs vs'
+        then mkCase p vs' 
+        else psvs
+
+   mkFun p (Cas [patt] val) = replace (C.patt2term patt) (LI p) val
+
+   allEqs (v:vs) = all (==v) vs
+
+   mkCase p (v:_) = [Cas [PV p] v]
+
+pIdent i = identC ("p__" ++ show i)
+
+
+--  we need to replace subterms
+
+replace :: Term -> Term -> Term -> Term
+replace old new trm = case trm of
+  T ty cs -> T ty [Cas p (repl v) | Cas p v <- cs]
+  P t l   -> P (repl t) l
+  S t a   -> S (repl t) (repl a)
+  C t a   -> C (repl t) (repl a)
+  FV ts   -> FV (map repl ts)
+  
+  -- these are the important cases, since they can correspond to patterns  
+  Con c ts | trm == old -> new
+  Con c ts            -> Con c (map repl ts)
+  R _ | isRec && trm == old -> new
+  R lts   -> R [Ass l (repl t) | Ass l t <- lts]
+
+  _ -> trm
+ where
+   repl = replace old new
+   isRec = case trm of
+     R _ -> True
+     _ -> False
+
diff --git a/src/GF/Canon/SkelGFC.hs b/src/GF/Canon/SkelGFC.hs
new file mode 100644
index 000000000..e75b66636
--- /dev/null
+++ b/src/GF/Canon/SkelGFC.hs
@@ -0,0 +1,199 @@
+module SkelGFC where
+
+import Ident
+
+-- Haskell module generated by the BNF converter
+
+import AbsGFC
+import ErrM
+type Result = Err String
+
+failure :: Show a => a -> Result
+failure x = Bad $ "Undefined case: " ++ show x
+
+transIdent :: Ident -> Result
+transIdent x = case x of
+  _  -> failure x
+
+
+transCanon :: Canon -> Result
+transCanon x = case x of
+  Gr modules  -> failure x
+
+
+transModule :: Module -> Result
+transModule x = case x of
+  Mod modtype extend open flags defs  -> failure x
+
+
+transModType :: ModType -> Result
+transModType x = case x of
+  MTAbs id  -> failure x
+  MTCnc id0 id  -> failure x
+  MTRes id  -> failure x
+
+
+transExtend :: Extend -> Result
+transExtend x = case x of
+  Ext id  -> failure x
+  NoExt  -> failure x
+
+
+transOpen :: Open -> Result
+transOpen x = case x of
+  NoOpens  -> failure x
+  Opens ids  -> failure x
+
+
+transFlag :: Flag -> Result
+transFlag x = case x of
+  Flg id0 id  -> failure x
+
+
+transDef :: Def -> Result
+transDef x = case x of
+  AbsDCat id decls cidents  -> failure x
+  AbsDFun id exp0 exp  -> failure x
+  ResDPar id pardefs  -> failure x
+  ResDOper id ctype term  -> failure x
+  CncDCat id ctype term0 term  -> failure x
+  CncDFun id cident argvars term0 term  -> failure x
+  AnyDInd id0 status id  -> failure x
+
+
+transParDef :: ParDef -> Result
+transParDef x = case x of
+  ParD id ctypes  -> failure x
+
+
+transStatus :: Status -> Result
+transStatus x = case x of
+  Canon  -> failure x
+  NonCan  -> failure x
+
+
+transCIdent :: CIdent -> Result
+transCIdent x = case x of
+  CIQ id0 id  -> failure x
+
+
+transExp :: Exp -> Result
+transExp x = case x of
+  EApp exp0 exp  -> failure x
+  EProd id exp0 exp  -> failure x
+  EAbs id exp  -> failure x
+  EAtom atom  -> failure x
+  EEq equations  -> failure x
+
+
+transSort :: Sort -> Result
+transSort x = case x of
+  SType  -> failure x
+
+
+transEquation :: Equation -> Result
+transEquation x = case x of
+  Equ apatts exp  -> failure x
+
+
+transAPatt :: APatt -> Result
+transAPatt x = case x of
+  APC cident apatts  -> failure x
+  APV id  -> failure x
+  APS str  -> failure x
+  API n  -> failure x
+  APW  -> failure x
+
+
+transAtom :: Atom -> Result
+transAtom x = case x of
+  AC cident  -> failure x
+  AD cident  -> failure x
+  AV id  -> failure x
+  AM n  -> failure x
+  AS str  -> failure x
+  AI n  -> failure x
+  AT sort  -> failure x
+
+
+transDecl :: Decl -> Result
+transDecl x = case x of
+  Decl id exp  -> failure x
+
+
+transCType :: CType -> Result
+transCType x = case x of
+  RecType labellings  -> failure x
+  Table ctype0 ctype  -> failure x
+  Cn cident  -> failure x
+  TStr  -> failure x
+
+
+transLabelling :: Labelling -> Result
+transLabelling x = case x of
+  Lbg label ctype  -> failure x
+
+
+transTerm :: Term -> Result
+transTerm x = case x of
+  Arg argvar  -> failure x
+  I cident  -> failure x
+  Con cident terms  -> failure x
+  LI id  -> failure x
+  R assigns  -> failure x
+  P term label  -> failure x
+  T ctype cases  -> failure x
+  S term0 term  -> failure x
+  C term0 term  -> failure x
+  FV terms  -> failure x
+  K tokn  -> failure x
+  E  -> failure x
+
+
+transTokn :: Tokn -> Result
+transTokn x = case x of
+  KS str  -> failure x
+  KP strs variants  -> failure x
+
+
+transAssign :: Assign -> Result
+transAssign x = case x of
+  Ass label term  -> failure x
+
+
+transCase :: Case -> Result
+transCase x = case x of
+  Cas patts term  -> failure x
+
+
+transVariant :: Variant -> Result
+transVariant x = case x of
+  Var strs0 strs  -> failure x
+
+
+transLabel :: Label -> Result
+transLabel x = case x of
+  L id  -> failure x
+  LV n  -> failure x
+
+
+transArgVar :: ArgVar -> Result
+transArgVar x = case x of
+  A id n  -> failure x
+  AB id n0 n  -> failure x
+
+
+transPatt :: Patt -> Result
+transPatt x = case x of
+  PC cident patts  -> failure x
+  PV id  -> failure x
+  PW  -> failure x
+  PR pattassigns  -> failure x
+
+
+transPattAssign :: PattAssign -> Result
+transPattAssign x = case x of
+  PAss label patt  -> failure x
+
+
+
diff --git a/src/GF/Canon/TestGFC.hs b/src/GF/Canon/TestGFC.hs
new file mode 100644
index 000000000..2210f4df3
--- /dev/null
+++ b/src/GF/Canon/TestGFC.hs
@@ -0,0 +1,25 @@
+-- automatically generated by BNF Converter
+module TestGFC where 
+
+import LexGFC
+import ParGFC
+import SkelGFC
+import PrintGFC
+import AbsGFC
+
+import ErrM
+
+type ParseFun a = [Token] -> Err a
+
+myLLexer = myLexer
+
+runFile :: (Print a, Show a) => ParseFun a -> FilePath -> IO()
+runFile p f = readFile f >>= run p
+
+run :: (Print a, Show a) => ParseFun a -> String -> IO()
+run p s = case (p (myLLexer s)) of
+           Bad s    -> do  putStrLn "\nParse Failed...\n"
+                           putStrLn s
+           Ok  tree -> do putStrLn "\nParse Successful!"
+                          putStrLn $ "\n[Abstract Syntax]\n\n" ++ show tree
+                          putStrLn $ "\n[Linearized tree]\n\n" ++ printTree tree
diff --git a/src/GF/Canon/Unlex.hs b/src/GF/Canon/Unlex.hs
new file mode 100644
index 000000000..f665f4c85
--- /dev/null
+++ b/src/GF/Canon/Unlex.hs
@@ -0,0 +1,37 @@
+module Unlex where
+
+import Operations
+import Str
+
+import Char
+import List (isPrefixOf)
+
+-- elementary text postprocessing. AR 21/11/2001
+
+formatAsText :: String -> String
+formatAsText = unwords . format . cap . words where
+  format ws = case ws of
+    w : c : ww | major c -> (w ++ c)      : format (cap ww)
+    w : c : ww | minor c -> (w ++ c)      : format ww
+    c     : ww | para  c -> "\n\n"        : format ww
+    w     : ww           -> w             : format ww
+    [] -> []
+  cap (p:(c:cs):ww) | para p = p : (toUpper c : cs) : ww
+  cap ((c:cs):ww) = (toUpper c : cs) : ww
+  cap [] = []
+  major = flip elem (map (:[]) ".!?") 
+  minor = flip elem (map (:[]) ",:;")
+  para  = (=="<p>") 
+
+unlex :: [Str] -> String
+unlex = formatAsText . performBinds . concat . map sstr . take 1 ----
+
+-- modified from GF/src/Text by adding hyphen
+performBinds :: String -> String
+performBinds = unwords . format . words where
+  format ws = case ws of
+    w : "-"  : u : ws -> format ((w ++ "-" ++ u) : ws)
+    w : "&+" : u : ws -> format ((w ++ u) : ws)
+    w : ws            -> w : format ws
+    []                -> []
+