Founding the newly structured GF2.0 cvs archive.

162 files changed, 25569 insertions, 0 deletions

diff --git a/bin/jgf2 b/bin/jgf2
new file mode 100644
index 000000000..ca83e4edc
--- /dev/null
+++ b/bin/jgf2
@@ -0,0 +1,12 @@
+#! /bin/sh
+
+# change the value of GFHOME to the directory where you have the gf binary
+GFHOME=/home/aarne/GF2/bin
+       # /.../chalmers.se/fs/cab/cs/.users/markus/home/GF1
+
+JGUILIB=$GFHOME/java/
+GF=$GFHOME/gf2+
+JGUI=GFEditor
+
+java -cp $JGUILIB $JGUI "$GF -java $*"
+
diff --git a/grammars/logic/Arithm.gf b/grammars/logic/Arithm.gf
new file mode 100644
index 000000000..e3ae706a4
--- /dev/null
+++ b/grammars/logic/Arithm.gf
@@ -0,0 +1,63 @@
+abstract Arithm = Logic ** {
+
+-- arithmetic
+fun 
+  Nat, Real  : Dom ;
+  zero : Elem Nat ;
+  succ : Elem Nat -> Elem Nat ;
+  
+  trunc : Elem Real -> Elem Nat ;
+
+  EqNat : (m,n : Elem Nat) -> Prop ;
+  LtNat : (m,n : Elem Nat) -> Prop ;
+  Div   : (m,n : Elem Nat) -> Prop ;
+  Even  : Elem Nat -> Prop ;
+  Odd   : Elem Nat -> Prop ;
+  Prime : Elem Nat -> Prop ;
+
+  one  : Elem Nat ;
+  two  : Elem Nat ;
+  sum  : (m,n : Elem Nat) -> Elem Nat ;
+  prod : (m,n : Elem Nat) -> Elem Nat ;
+
+  evax1 : Proof (Even zero) ;
+  evax2 : (n : Elem Nat) -> Proof (Even n) -> Proof (Odd (succ n)) ;
+  evax3 : (n : Elem Nat) -> Proof (Odd n)  -> Proof (Even (succ n)) ;
+  eqax1 : Proof (EqNat zero zero) ;
+  eqax2 : (m,n : Elem Nat) -> Proof (EqNat m n) -> Proof (EqNat (succ m) (succ n)) ;
+
+  IndNat : (C : Elem Nat -> Prop) -> 
+             Proof (C zero) -> 
+             ((x : Elem Nat) -> Proof (C x) -> Proof (C (succ x))) -> 
+                Proof (Univ Nat C) ;
+
+def 
+  one = succ zero ;
+  two = succ one ;
+  sum m zero = m ;
+  sum m (succ n) = succ (sum m n) ;
+  prod m zero = zero ;
+  prod m (succ n) = sum (prod m n) m ;
+  LtNat m n = Exist Nat (\x -> EqNat n (sum m (succ x))) ;
+  Div m n = Exist Nat (\x -> EqNat m (prod x n)) ;
+  Prime n = Conj 
+              (LtNat one n) 
+              (Univ Nat (\x -> Impl (Conj (LtNat one x) (Div n x)) (EqNat x n))) ;
+
+fun ex1 : Text ;
+def ex1 = 
+  ThmWithProof 
+    (Univ Nat (\x -> Disj (Even x) (Odd x))) 
+    (IndNat 
+       (\x -> Disj (Even x) (Odd x)) 
+       (DisjIl (Even zero) (Odd zero) evax1) 
+       (\x -> \h -> DisjE (Even x) (Odd x) (Disj (Even (succ x)) (Odd (succ x))) 
+         (Hypo (Disj (Even x) (Odd x)) h) 
+         (\a -> DisjIr (Even (succ x)) (Odd (succ x)) 
+            (evax2 x (Hypo (Even x) a))) 
+         (\b -> DisjIl (Even (succ x)) (Odd (succ x)) 
+            (evax3 x (Hypo (Odd x) b))
+         )
+       )
+     ) ;
+} ;
diff --git a/grammars/logic/ArithmEng.gf b/grammars/logic/ArithmEng.gf
new file mode 100644
index 000000000..8c78132ea
--- /dev/null
+++ b/grammars/logic/ArithmEng.gf
@@ -0,0 +1,40 @@
+concrete ArithmEng of Arithm = LogicEng ** open LogicResEng in {
+
+lin
+  Nat = {s = nomReg "number"} ;
+  zero = ss "zero" ;
+  succ = fun1 "successor" ;
+
+  EqNat = adj2 ["equal to"] ;
+  LtNat = adj2 ["smaller than"] ;
+  Div   = adj2 ["divisible by"] ;
+  Even  = adj1 "even" ;
+  Odd   = adj1 "odd" ;
+  Prime = adj1 "prime" ;
+
+  one = ss "one" ;
+  two = ss "two" ;
+  sum = fun2 "sum" ;
+  prod = fun2 "product" ;
+
+  evax1 = ss ["by the first axiom of evenness , zero is even"] ;
+  evax2 n c = {s = 
+    c.s ++ [". By the second axiom of evenness , the successor of"] ++ 
+    n.s ++ ["is odd"]} ;
+  evax3 n c = {s = 
+    c.s ++ [". By the third axiom of evenness , the successor of"] ++ 
+    n.s ++ ["is even"]} ;
+  eqax1 = ss ["by the first axiom of equality , zero is equal to zero"] ;
+  eqax2 m n c = {s = 
+    c.s ++ [". By the second axiom of equality , the successor of"] ++ m.s ++ 
+    ["is equal to the successor of"] ++ n.s} ;
+  IndNat C d e = {s = 
+    ["we proceed by induction . For the basis ,"] ++ d.s ++ 
+    [". For the induction step, consider a number"] ++ C.$0 ++ 
+    ["and assume"] ++ C.s ++ "(" ++ e.$1 ++ ")" ++ "." ++ e.s ++ 
+    ["Hence, for all numbers"] ++ C.$0 ++ "," ++ C.s} ;
+
+  ex1 = ss ["The first theorem and its proof ."] ;
+
+} ;
+
diff --git a/grammars/logic/Logic.gf b/grammars/logic/Logic.gf
new file mode 100644
index 000000000..334592946
--- /dev/null
+++ b/grammars/logic/Logic.gf
@@ -0,0 +1,82 @@
+-- many-sorted predicate calculus
+-- AR 1999, revised 2001
+
+abstract Logic = {
+
+flags startcat=Prop ; -- this is what you want to parse
+
+cat 
+  Prop ;       -- proposition
+  Dom ;        -- domain of quantification
+  Elem Dom ;   -- individual element of a domain
+  Proof Prop ; -- proof of a proposition
+  Text ;       -- theorem with proof etc. 
+
+fun 
+  -- texts
+  Statement : Prop -> Text ;
+  ThmWithProof : (A : Prop) -> Proof A -> Text ;
+  ThmWithTrivialProof : (A : Prop) -> Proof A -> Text ;
+
+  -- logically complex propositions
+  Disj : (A,B : Prop) -> Prop ;
+  Conj : (A,B : Prop) -> Prop ;
+  Impl : (A,B : Prop) -> Prop ;
+  Abs  : Prop ;
+  Neg  : Prop -> Prop ;
+
+  Univ  : (A : Dom) -> (Elem A -> Prop) -> Prop ;
+  Exist : (A : Dom) -> (Elem A -> Prop) -> Prop ;
+
+  -- progressive implication à la type theory
+  ImplP : (A : Prop) -> (Proof A -> Prop) -> Prop ;
+
+  -- inference rules
+  ConjI  : (A,B : Prop) -> Proof A -> Proof B -> Proof (Conj A B) ;
+  ConjEl : (A,B : Prop) -> Proof (Conj A B) -> Proof A ;
+  ConjEr : (A,B : Prop) -> Proof (Conj A B) -> Proof B ;
+  DisjIl : (A,B : Prop) -> Proof A -> Proof (Disj A B) ;
+  DisjIr : (A,B : Prop) -> Proof B -> Proof (Disj A B) ;
+  DisjE  : (A,B,C : Prop) -> Proof (Disj A B) -> 
+              (Proof A -> Proof C) -> (Proof B -> Proof C) -> Proof C ;
+  ImplI  : (A,B : Prop) -> (Proof A -> Proof B) -> Proof (Impl A B) ;
+  ImplE  : (A,B : Prop) -> Proof (Impl A B) -> Proof A -> Proof B ;
+  NegI   : (A : Prop) -> (Proof A -> Proof Abs) -> Proof (Neg A) ;
+  NegE   : (A : Prop) -> Proof (Neg A) -> Proof A -> Proof Abs ;
+  AbsE   : (C : Prop) -> Proof Abs -> Proof C ;
+
+  UnivI  : (A : Dom) -> (B : Elem A -> Prop) -> 
+              ((x : Elem A) -> Proof (B x)) -> Proof (Univ A B) ;
+  UnivE  : (A : Dom) -> (B : Elem A -> Prop) -> 
+              Proof (Univ A B) -> (a : Elem A) -> Proof (B a) ;
+  ExistI : (A : Dom) -> (B : Elem A -> Prop) -> 
+              (a : Elem A) -> Proof (B a) -> Proof (Exist A B) ;
+  ExistE : (A : Dom) -> (B : Elem A -> Prop) -> (C : Prop) -> 
+              Proof (Exist A B) -> ((x : Elem A) -> Proof (B x) -> Proof C) -> 
+              Proof C ;
+
+  -- use a hypothesis
+  Hypo : (A : Prop) -> Proof A -> Proof A ;
+
+  -- pronoun
+  Pron : (A : Dom) -> Elem A -> Elem A ;
+
+data
+  Proof = ConjI | DisjIl | DisjIr ;
+
+def 
+  -- proof normalization
+  ConjEl _ _ (ConjI _ _ a _) = a ;
+  ConjEr _ _ (ConjI _ _ _ b) = b ;
+  DisjE _ _ _ (DisjIl _ _ a) d _ = d a ;
+  DisjE _ _ _ (DisjIr _ _ b) _ e = e b ;
+  ImplE _ _ (ImplI _ _ b) a = b a ;
+  NegE _ (NegI _ b) a = b a ;
+  UnivE _ _ (UnivI _ _ b) a = b a ;
+  ExistE _ _ _ (ExistI _ _ a b) d = d a b ;
+
+  -- Hypo and Pron are identities
+  Hypo _ a = a ;
+  Pron _ a = a ;
+
+} ;
diff --git a/grammars/logic/LogicEng.gf b/grammars/logic/LogicEng.gf
new file mode 100644
index 000000000..3b823fcb0
--- /dev/null
+++ b/grammars/logic/LogicEng.gf
@@ -0,0 +1,59 @@
+concrete LogicEng of Logic = open LogicResEng in {
+
+flags lexer=vars ; unlexer=text ;
+
+lincat 
+  Dom = {s : Num => Str} ;
+  Prop, Elem = {s : Str} ;
+
+lin 
+Statement A = {s = A.s ++ "."} ;
+ThmWithProof A a = {s = ["Theorem ."] ++ A.s ++ [". <p> Proof ."] ++ a.s ++ "."} ;
+ThmWithTrivialProof A a = 
+  {s = "Theorem" ++ "." ++ A.s ++ [". <p> Proof . Trivial ."]} ;
+Disj A B = {s = A.s ++ "or" ++ B.s} ;
+Conj A B = {s = A.s ++ "and" ++ B.s} ;
+Impl A B = {s = "if" ++ A.s ++ "then" ++ B.s} ;
+Univ A B = {s = ["for all"] ++ A.s ! pl ++ B.$0 ++ "," ++ B.s} ;
+Exist A B =
+  {s = ["there exists"] ++ indef ++ A.s ! sg ++ B.$0 ++ ["such that"] ++ B.s} ;
+Abs = {s = ["we have a contradiction"]} ;
+Neg A = {s = ["it is not the case that"] ++ A.s} ;
+ImplP A B = {s = "if" ++ A.s ++ "then" ++ B.s} ;
+ConjI A B a b = {s = a.s ++ "." ++ b.s ++ [". Hence"] ++ A.s ++ "and" ++ B.s} ;
+ConjEl A B c = {s = c.s ++ [". A fortiori ,"] ++ A.s} ;
+ConjEr A B c = {s = c.s ++ [". A fortiori ,"] ++ B.s} ;
+DisjIl A B a = {s = a.s ++ [". A fortiori ,"] ++ A.s ++ "or" ++ B.s} ;
+DisjIr A B b = {s = b.s ++ [". A fortiori ,"] ++ A.s ++ "or" ++ B.s} ;
+DisjE A B C c d e = {s = 
+  c.s ++ 
+  [". There are two possibilities . First , assume"] ++ 
+  A.s ++ "(" ++ d.$0 ++ ")" ++ "." ++ d.s ++ 
+  [". Second , assume"] ++ B.s ++ "(" ++ e.$0 ++ ")" ++ "." ++ e.s ++ 
+  [". Thus"] ++ C.s ++ ["in both cases"]} ;
+ImplI A B b = {s = 
+  "assume" ++ A.s ++ "(" ++ b.$0 ++ ")" ++ "." ++ 
+  b.s ++ [". Hence , if"] ++ A.s ++ "then" ++ B.s} ;
+ImplE A B c a = {s = a.s ++ [". But"] ++ c.s ++ [". Hence"] ++ B.s} ;
+NegI A b = {s = 
+  "assume" ++ A.s ++ "(" ++ b.$0 ++ ")" ++ "." ++ b.s ++ 
+  [". Hence, it is not the case that"] ++ A.s} ;
+NegE A c a =
+  {s = a.s ++ [". But"] ++ c.s ++ [". We have a contradiction"]} ;
+UnivI A B b = {s = 
+  ["consider an arbitrary"] ++ A.s ! sg ++ b.$0 ++ "." ++ b.s ++ 
+  [". Hence, for all"] ++ A.s ! pl ++ B.$0 ++ "," ++ B.s} ;
+UnivE A B c a =
+  {s = c.s ++ [". Hence"] ++ B.s ++ "for" ++ B.$0 ++ ["set to"] ++ a.s} ;
+ExistI A B a b = {s = 
+  b.s ++ [". Hence, there exists"] ++ indef ++ 
+  A.s ! sg ++ B.$0 ++ ["such that"] ++ B.s} ;
+ExistE A B C c d = {s = 
+  c.s ++ [". Consider an arbitrary"] ++ d.$0 ++ 
+  ["and assume that"] ++ B.s ++ "(" ++ d.$1 ++ ")" ++ "." ++ d.s ++ 
+  [". Hence"] ++ C.s ++ ["independently of"] ++ d.$0} ;
+AbsE C c = {s = c.s ++ [". We may conclude"] ++ C.s} ;
+Hypo A a = {s = ["by the hypothesis"] ++ a.s ++ "," ++ A.s} ;
+Pron _ _ = {s = "it"} ;
+
+} ;
diff --git a/grammars/logic/LogicResEng.gf b/grammars/logic/LogicResEng.gf
new file mode 100644
index 000000000..94866bf05
--- /dev/null
+++ b/grammars/logic/LogicResEng.gf
@@ -0,0 +1,27 @@
+resource LogicResEng = {
+
+param Num = sg | pl  ;
+
+oper 
+  
+  ss  : Str -> {s : Str} = \s -> {s = s} ;
+
+  nomReg : Str -> Num => Str = \s -> table {sg => s ; pl => s + "s"} ;
+
+  indef : Str = pre {"a" ; "an" / strs {"a" ; "e" ; "i" ; "o"}} ;
+
+  LinElem : Type = {s : Str} ;
+  LinProp : Type = {s : Str} ;
+
+  adj1 : Str -> LinElem -> LinProp = 
+    \adj,x -> ss (x.s ++ "is" ++ adj) ;
+  adj2 : Str -> LinElem -> LinElem -> LinProp = 
+    \adj,x,y -> ss (x.s ++ "is" ++ adj ++ y.s) ;
+
+  fun1 : Str -> LinElem -> LinElem = 
+    \f,x -> ss ("the" ++ f ++ "of" ++ x.s) ;
+  fun2 : Str -> LinElem -> LinElem -> LinElem = 
+    \f,x,y -> ss ("the" ++ f ++ "of" ++ x.s ++ "and" ++ y.s) ;
+
+
+} ;
diff --git a/grammars/prelude/Coordination.gf b/grammars/prelude/Coordination.gf
new file mode 100644
index 000000000..d8265e3c2
--- /dev/null
+++ b/grammars/prelude/Coordination.gf
@@ -0,0 +1,105 @@
+resource Coordination = {
+
+param
+  ListSize = TwoElem | ManyElem ;
+
+oper 
+  SS = {s : Str} ; ----
+
+  ListX = {s1,s2 : Str} ;
+
+  twoStr : (x,y : Str) -> ListX = \x,y -> 
+    {s1 = x ; s2 = y} ; 
+  consStr : Str -> ListX -> Str -> ListX = \comma,xs,x -> 
+    {s1 = xs.s1 ++ comma ++ xs.s2 ; s2 = x } ; 
+
+  twoSS : (_,_ : SS) -> ListX = \x,y -> 
+    twoStr x.s y.s ;
+  consSS : Str -> ListX -> SS -> ListX = \comma,xs,x -> 
+    consStr comma xs x.s ;
+
+  Conjunction : Type = SS ;
+  ConjunctionDistr : Type = {s1 : Str ; s2 : Str} ;
+
+  conjunctX : Conjunction -> ListX -> Str = \or,xs ->
+    xs.s1 ++ or.s ++ xs.s2 ;
+
+  conjunctDistrX : ConjunctionDistr -> ListX -> Str = \or,xs ->
+    or.s1 ++ xs.s1 ++ or.s2 ++ xs.s2 ;
+
+  -- all this lifted to tables
+
+  ListTable : Type -> Type = \P -> {s1,s2 : P => Str} ; 
+
+  twoTable : (P : Type) -> (_,_ : {s : P => Str}) -> ListTable P = \_,x,y ->
+    {s1 = x.s ; s2 = y.s} ; 
+
+  consTable : (P : Type) -> Str -> ListTable P -> {s : P => Str} -> ListTable P = 
+    \P,c,xs,x ->
+    {s1 = table P {o => xs.s1 ! o ++ c ++ xs.s2 ! o} ; s2 = x.s} ; 
+
+  conjunctTable : (P : Type) -> Conjunction -> ListTable P -> {s : P => Str} = 
+    \P,or,xs ->
+    {s = table P {p => xs.s1 ! p ++ or.s ++ xs.s2 ! p}} ;
+
+  conjunctDistrTable : 
+    (P : Type) -> ConjunctionDistr -> ListTable P -> {s : P => Str} = \P,or,xs ->
+    {s = table P {p => or.s1++ xs.s1 ! p ++ or.s2 ++ xs.s2 ! p}} ;
+
+  -- ... and to two- and three-argument tables: how clumsy! ---
+
+  ListTable2 : Type -> Type -> Type = \P,Q -> 
+    {s1,s2 : P => Q => Str} ; 
+
+  twoTable2 : (P,Q : Type) -> (_,_ : {s : P => Q => Str}) -> ListTable2 P Q = 
+    \_,_,x,y ->
+    {s1 = x.s ; s2 = y.s} ; 
+
+  consTable2 : 
+    (P,Q : Type) -> Str -> ListTable2 P Q -> {s : P => Q => Str} -> ListTable2 P Q =
+     \P,Q,c,xs,x ->
+    {s1 = table P {p => table Q {q => xs.s1 ! p ! q ++ c ++ xs.s2 ! p! q}} ; 
+     s2 = x.s
+    } ; 
+
+  conjunctTable2 : 
+    (P,Q : Type) -> Conjunction -> ListTable2 P Q -> {s : P => Q => Str} = 
+    \P,Q,or,xs ->
+    {s = table P {p => table Q {q => xs.s1 ! p ! q ++ or.s ++ xs.s2 ! p ! q}}} ;
+
+  conjunctDistrTable2 : 
+    (P,Q : Type) -> ConjunctionDistr -> ListTable2 P Q -> {s : P => Q => Str} = 
+    \_,_,or,xs ->
+    {s = 
+    table {p => table {q => or.s1++ xs.s1 ! p ! q ++ or.s2 ++ xs.s2 ! p ! q}}} ;
+
+  ListTable3 : Type -> Type -> Type -> Type = \P,Q,R -> 
+    {s1,s2 : P => Q => R => Str} ; 
+
+  twoTable3 : (P,Q,R : Type) -> (_,_ : {s : P => Q => R => Str}) -> 
+              ListTable3 P Q R = 
+    \_,_,_,x,y ->
+    {s1 = x.s ; s2 = y.s} ; 
+
+  consTable3 : 
+    (P,Q,R : Type) -> Str -> ListTable3 P Q R -> {s : P => Q => R => Str} -> 
+         ListTable3 P Q R =
+     \P,Q,R,c,xs,x ->
+    {s1 = \\p,q,r => xs.s1 ! p ! q ! r ++ c ++ xs.s2 ! p ! q ! r ; 
+     s2 = x.s
+    } ; 
+
+  conjunctTable3 : 
+    (P,Q,R : Type) -> Conjunction -> ListTable3 P Q R -> {s : P => Q => R => Str} = 
+    \P,Q,R,or,xs ->
+    {s = \\p,q,r => xs.s1 ! p ! q ! r ++ or.s ++ xs.s2 ! p ! q ! r} ;
+
+  conjunctDistrTable3 : 
+    (P,Q,R : Type) -> ConjunctionDistr -> ListTable3 P Q R -> 
+       {s : P => Q => R => Str} = 
+    \P,Q,R,or,xs ->
+    {s = \\p,q,r => or.s1++ xs.s1 ! p ! q ! r ++ or.s2 ++ xs.s2 ! p ! q ! r} ;
+
+  comma = "," ;
+
+} ;
diff --git a/grammars/prelude/Predef.gf b/grammars/prelude/Predef.gf
new file mode 100644
index 000000000..a91681af6
--- /dev/null
+++ b/grammars/prelude/Predef.gf
@@ -0,0 +1,25 @@
+-- predefined functions for concrete syntax, defined in AppPredefined.hs
+
+resource Predef = {
+
+  -- this type is for internal use only
+  param PBool = PTrue | PFalse ;
+
+  -- these operations have their definitions in AppPredefined.hs
+  oper Int : Type = variants {} ; ----
+
+  oper length : Tok ->        Int  = variants {} ;
+  oper drop   : Int -> Tok -> Tok  = variants {} ;
+  oper take   : Int -> Tok -> Tok  = variants {} ;
+  oper tk     : Int -> Tok -> Tok  = variants {} ;
+  oper dp     : Int -> Tok -> Tok  = variants {} ;
+  oper eqInt  : Int -> Int -> PBool = variants {} ; 
+  oper plus   : Int -> Int -> Int  = variants {} ;
+
+  oper eqStr  : Tok -> Tok -> PBool   = variants {} ; 
+  oper eqTok  : (P : Type) -> P -> P -> PBool = variants {} ; 
+  oper show   : (P : Type) -> P -> Tok = variants {} ; 
+  oper read   : (P : Type) -> Tok -> P = variants {} ; 
+
+  } ;
+
diff --git a/grammars/prelude/Prelude.gf b/grammars/prelude/Prelude.gf
new file mode 100644
index 000000000..f5903d7ec
--- /dev/null
+++ b/grammars/prelude/Prelude.gf
@@ -0,0 +1,83 @@
+-- language-independent prelude facilities
+
+resource Prelude = open (Predef = Predef) in {
+
+oper
+-- to construct records and tables
+  SS  : Type = {s : Str} ;
+  ss  : Str -> SS = \s -> {s = s} ;
+  ss2 : (_,_ : Str) -> SS = \x,y -> ss (x ++ y) ;
+  ss3 : (_,_ ,_: Str) -> SS = \x,y,z -> ss (x ++ y ++ z) ;
+
+  cc2 : (_,_ : SS) -> SS = \x,y -> ss (x.s ++ y.s) ;
+
+  SS1 : Type -> Type = \P -> {s : P => Str} ;
+  ss1 : (A : Type) -> Str -> SS1 A = \A,s -> {s = table {_ => s}} ;
+
+  SP1 : Type -> Type = \P -> {s : Str ; p : P} ;
+  sp1 : (A : Type) -> Str -> A -> SP1 A = \_,s,a -> {s = s ; p = a} ;
+
+  nonExist : Str = variants {} ;
+
+  optStr : Str -> Str = \s -> variants {s ; []} ;
+
+  constTable : (A,B : Type) -> B -> A => B = \_,_,b -> \\_ => b ;
+  constStr   : (A : Type) -> Str -> A => Str = \A -> constTable A Str ;
+
+  infixSS   : Str  -> SS -> SS -> SS = \f,x,y -> ss (x.s ++ f ++ y.s) ;
+  prefixSS  : Str        -> SS -> SS = \f,x   -> ss (f ++ x.s) ;
+  postfixSS : Str        -> SS -> SS = \f,x   -> ss (x.s ++ f) ;
+  embedSS   : Str -> Str -> SS -> SS = \f,g,x -> ss (f ++ x.s ++ g) ;
+
+-- discontinuous
+  SD2 = {s1,s2 : Str} ;
+  sd2 : (_,_ : Str) -> SD2 = \x,y -> {s1 = x ; s2 = y} ;
+
+-- parentheses
+  paren : Str -> Str = \s -> "(" ++ s ++ ")" ;
+  parenss : SS -> SS = \s -> ss (paren s.s) ;
+
+-- free order between two strings
+  bothWays : Str -> Str -> Str = \x,y -> variants {x ++ y ; y ++ x} ;
+
+-- parametric order between two strings
+  preOrPost : Bool -> Str -> Str -> Str = \pr,x,y -> 
+    if_then_else Str pr (x ++ y) (y ++ x) ;
+
+-- Booleans
+
+ param Bool = True | False ;
+
+oper
+  if_then_else : (A : Type) -> Bool -> A -> A -> A = \_,c,d,e -> 
+    case c of {
+      True => d ;  ---- should not need to qualify
+      False => e
+     } ;
+
+  andB : (_,_ : Bool) -> Bool = \a,b -> if_then_else Bool a b False ;
+  orB  : (_,_ : Bool) -> Bool = \a,b -> if_then_else Bool a True b ;
+  notB : Bool         -> Bool = \a   -> if_then_else Bool a False True ;
+
+
+-- zero, one, two, or more (elements in a list etc)
+
+param
+  ENumber = E0 | E1 | E2 | Emore ;
+
+oper
+  eNext : ENumber -> ENumber = \e -> case e of {
+    E0 => E1 ; E1 => E2 ; _ => Emore} ;
+
+  -- these were defined in Predef before
+  oper isNil : Tok -> Bool = \b -> pbool2bool (Predef.eqStr [] b) ;
+
+  oper ifTok : (A : Type) -> Tok -> Tok -> A -> A -> A = \A,t,u,a,b ->
+      case Predef.eqStr t u of {Predef.PTrue => a ; Predef.PFalse => b} ;
+
+  -- so we need an interface
+  oper pbool2bool : Predef.PBool -> Bool = \b -> case b of {
+    Predef.PFalse => False ; Predef.PTrue => True
+    } ;
+
+} ;
diff --git a/grammars/resource/abstract/Database.gf b/grammars/resource/abstract/Database.gf
new file mode 100644
index 000000000..d261e3e11
--- /dev/null
+++ b/grammars/resource/abstract/Database.gf
@@ -0,0 +1,36 @@
+abstract Database = {
+
+flags startcat=Query ;
+
+cat 
+  Query ; Phras ; Statement ; Question ;
+  Noun ; Subject ; Value ; Property ; Relation ; Comparison ; Name ;
+  Feature ;
+
+fun 
+  LongForm  : Phras -> Query ;
+  ShortForm : Phras -> Query ;
+
+  WhichAre  : Noun -> Property    -> Phras ;
+  IsThere   : Noun                -> Phras ;
+  AreThere  : Noun                -> Phras ;
+  IsIt      : Subject -> Property -> Phras ; 
+  WhatIs    : Value               -> Phras ;
+
+  MoreThan   : Comparison -> Subject -> Property ;
+  TheMost    : Comparison -> Noun -> Value ;
+  Relatively : Comparison -> Noun -> Property ;
+
+  RelatedTo  : Relation -> Subject -> Property ;
+
+  Individual : Name -> Subject ;
+  AllN       : Noun -> Subject ;
+  Any        : Noun -> Subject ;
+  MostN      : Noun -> Subject ;
+  EveryN     : Noun -> Subject ;
+
+  FeatureOf  : Feature -> Subject -> Subject ;
+  ValueOf    : Feature -> Name -> Value ;
+
+  WithProperty : Noun -> Property -> Noun ;
+} ;
diff --git a/grammars/resource/abstract/PredefAbs.gf b/grammars/resource/abstract/PredefAbs.gf
new file mode 100644
index 000000000..ccd214fd4
--- /dev/null
+++ b/grammars/resource/abstract/PredefAbs.gf
@@ -0,0 +1,4 @@
+abstract PredefAbs = {
+  cat String ; Int ;
+} ;
+
diff --git a/grammars/resource/abstract/ResAbs.gf b/grammars/resource/abstract/ResAbs.gf
new file mode 100644
index 000000000..aba5ca216
--- /dev/null
+++ b/grammars/resource/abstract/ResAbs.gf
@@ -0,0 +1,266 @@
+--1 Abstract Syntax for Multilingual Resource Grammar
+--
+-- Aarne Ranta 2002 -- 2003
+--
+-- Although concrete syntax differs a lot between different languages,
+-- many structures can be found that are common, on a certain level
+-- of abstraction. What we will present in the following is an abstract 
+-- syntax that has been successfully defined for English, French, German, 
+-- Italian, Russian, and Swedish. It has been applied to define language
+-- fragments on technical or near-to-technical domains: database queries,
+-- video recorder dialogue systems, software specifications, and a 
+-- health-related phrase book.
+--
+-- To use the resource in applications, you need the following 
+-- $cat$ and $fun$ rules in $oper$ form, completed by taking the
+-- $lincat$ and $lin$ judgements of a particular language. There is 
+-- a GF command for making this translation automatically.
+
+--2 Categories
+--
+-- The categories of this resource grammar are mostly 'standard' categories
+-- of linguistics. Their is no claim that they correspond to semantic categories
+-- definable in type theory: to define such correspondences it the business
+-- of applications grammars.
+--
+-- Categories that may look special are $Adj2$, $Fun$, and $TV$. They are all
+-- instances of endowing another category with a complement, which can be either
+-- a direct object (whose case may vary) or a prepositional phrase. This, together
+-- with the category $Adv$, removes the need of a category of 
+-- 'prepositional phrases', which is too language-dependent to make sense
+-- on this level of abstraction.
+--
+
+abstract ResAbs = {
+
+--3 Nouns and noun phrases
+--
+
+cat
+  N ;      -- simple common noun,    e.g. "car"
+  CN ;     -- common noun phrase,    e.g. "red car", "car that John owns"
+  NP ;     -- noun phrase,           e.g. "John", "all cars", "you"
+  PN ;     -- proper name,           e.g. "John", "New York"
+  Det ;    -- determiner,            e.g. "every", "all"
+  Fun ;    -- function word,         e.g. "mother (of)"
+  Fun2 ;   -- two-place function,    e.g. "flight (from) (to)"
+
+--3 Adjectives and adjectival phrases
+--
+
+  Adj1 ;   -- one-place adjective,   e.g. "even"
+  Adj2 ;   -- two-place adjective,   e.g. "divisible (by)"
+  AdjDeg ; -- degree adjective,      e.g. "big/bigger/biggest"
+  AP ;     -- adjective phrase,      e.g. "divisible by two", "bigger than John"
+
+--3 Verbs and verb phrases
+--
+
+  V ;      -- one-place verb,        e.g. "walk"
+  TV ;     -- two-place verb,        e.g. "love", "wait (for)", "switch on"
+  VS ;     -- sentence-compl. verb   e.g. "say", "prove"
+  VP ;     -- verb phrase,           e.g. "switch the light on"
+
+--3 Adverbials
+--
+
+  AdV ;    -- adverbial              e.g. "now", "in the house"
+  AdA ;    -- ad-adjective           e.g. "very"
+  AdS ;    -- sentence adverbial     e.g. "therefore", "otherwise"
+
+--3 Sentences and relative clauses
+--
+
+  S ;      -- sentence,              e.g. "John walks"
+  Slash ;  -- sentence without NP,   e.g. "John waits for (...)"
+  RP ;     -- relative pronoun,      e.g. "which", "the mother of whom"
+  RC ;     -- relative clause,       e.g. "who walks", "that I wait for"
+
+--3 Questions and imperatives
+--
+
+  IP ;     -- interrogative pronoun, e.g. "who", "whose mother", "which yellow car"
+  IAdv ;   -- interrogative adverb., e.g. "when", "why" 
+  Qu ;     -- question,              e.g. "who walks"
+  Imp ;    -- imperative,            e.g. "walk!"
+
+--3 Coordination and subordination
+--
+
+  Conj ;   -- conjunction,           e.g. "and"
+  ConjD ;  -- distributed conj.      e.g. "both - and"
+  Subj ;   -- subjunction,           e.g. "if", "when"
+
+  ListS ;  -- list of sentences
+  ListAP ; -- list of adjectival phrases
+  ListNP ; -- list of noun phrases
+
+--3 Complete utterances
+--
+
+  Phr ;    -- full phrase,           e.g. "John walks.","Who walks?", "Wait for me!"
+  Text ;   -- sequence of phrases    e.g. "One is odd. Therefore, two is even."
+
+--2 Rules
+--
+-- This set of rules is minimal, in the sense defining the simplest combinations
+-- of categories and of not having redundant rules.
+-- When the resource grammar is used as a library, it will often be useful to
+-- access it through an intermediate library that defines more rules as 
+-- combinations of the ones below.
+
+--3 Nouns and noun phrases
+--
+
+fun 
+  UseN : N -> CN ;                         -- "car"
+  ModAdj : AP -> CN -> CN ;                -- "red car"
+  DetNP : Det -> CN -> NP ;                -- "every car"
+  IndefOneNP, IndefManyNP : CN -> NP ;     -- "a car", "cars"
+  DefOneNP, DefManyNP : CN -> NP ;         -- "the car", "the cars"
+  ModGenOne, ModGenMany : NP -> CN -> NP ; -- "John's car", "John's cars"
+  UsePN : PN -> NP ;                       -- "John"
+  UseFun : Fun -> CN ;                     -- "successor"
+  AppFun : Fun -> NP -> CN ;               -- "successor of zero"
+  AppFun2 : Fun2 -> NP -> Fun ;            -- "flight from Paris"
+  CNthatS : CN -> S -> CN ;                -- "idea that the Earth is flat"
+
+--3 Adjectives and adjectival phrases
+--
+
+  AdjP1 : Adj1 -> AP ;                     -- "red"
+  ComplAdj : Adj2 -> NP -> AP ;            -- "divisible by two"
+  PositAdjP : AdjDeg -> AP ;               -- "old"
+  ComparAdjP : AdjDeg -> NP -> AP ;        -- "older than John"
+  SuperlNP : AdjDeg -> CN -> NP ;          -- "the oldest man"
+
+--3 Verbs and verb phrases
+--
+
+  PosV, NegV : V -> VP ;                   -- "walk", "doesn't walk"
+  PosA, NegA : AP -> VP ;                  -- "is old", "isn't old"
+  PosCN, NegCN : CN -> VP ;                -- "is a man", "isn't a man"
+  PosTV, NegTV : TV -> NP -> VP ;          -- "sees John", "doesn't see John"
+  PosPassV, NegPassV : V -> VP ;           -- "is seen", "is not seen"
+  PosNP, NegNP : NP -> VP ;                -- "is John", "is not John"
+  PosVS, NegVS : VS -> S -> VP ;           -- "says that I run", "doesn't say..."
+
+--3 Adverbials
+--
+
+  AdvVP : VP -> AdV -> VP ;                -- "always walks", "walks in the park" 
+  LocNP : NP -> AdV ;                      -- "in London"
+  AdvCN : CN -> AdV -> CN ;                -- "house in London", "house today"
+
+  AdvAP : AdA -> AP -> AP ;                -- "very good"
+
+
+--3 Sentences and relative clauses
+--
+
+  PredVP : NP -> VP -> S ;                     -- "John walks"
+  PosSlashTV, NegSlashTV : NP -> TV -> Slash ; -- "John sees", "John doesn's see"
+  OneVP : VP -> S ;                            -- "one walks"
+
+  IdRP : RP ;                              -- "which"
+  FunRP : Fun -> RP -> RP ;                -- "the successor of which"
+  RelVP : RP -> VP -> RC ;                 -- "who walks"
+  RelSlash : RP -> Slash -> RC ;           -- "that I wait for"/"for which I wait" 
+  ModRC : CN -> RC -> CN ;                 -- "man who walks"
+  RelSuch : S -> RC ;                      -- "such that it is even"
+
+--3 Questions and imperatives
+--
+
+  WhoOne, WhoMany : IP ;                   -- "who (is)", "who (are)"
+  WhatOne, WhatMany : IP ;                 -- "what (is)", "what (are)"
+  FunIP : Fun -> IP -> IP ;                -- "the mother of whom"
+  NounIPOne, NounIPMany : CN -> IP ;       -- "which car", "which cars"
+
+  QuestVP : NP -> VP -> Qu ;               -- "does John walk"
+  IntVP : IP -> VP -> Qu ;                 -- "who walks"
+  IntSlash : IP -> Slash -> Qu ;           -- "whom does John see"
+  QuestAdv : IAdv -> NP -> VP -> Qu ;      -- "why do you walk"
+
+  ImperVP : VP -> Imp ;                    -- "be a man"
+
+  IndicPhrase : S -> Phr ;                 -- "I walk."
+  QuestPhrase : Qu -> Phr ;                -- "Do I walk?"
+  ImperOne, ImperMany : Imp -> Phr ;       -- "Be a man!", "Be men!"
+
+  AdvS : AdS -> S -> Phr ;                 -- "Therefore, 2 is prime."
+
+--3 Coordination
+--
+-- We consider "n"-ary coordination, with "n" > 1. To this end, we have introduced
+-- a *list category* $ListX$ for each category $X$ whose expressions we want to
+-- conjoin. Each list category has two constructors, the base case being $TwoX$.
+
+-- We have not defined coordination of all possible categories here,
+-- since it can be tricky in many languages. For instance, $VP$ coordination
+-- is linguistically problematic in German because $VP$ is a discontinuous
+-- category.
+
+  ConjS  : Conj -> ListS -> S ;            -- "John walks and Mary runs"
+  ConjAP : Conj -> ListAP -> AP ;          -- "even and prime"
+  ConjNP : Conj -> ListNP -> NP ;          -- "John or Mary"
+
+  ConjDS  : ConjD -> ListS -> S ;          -- "either John walks or Mary runs"
+  ConjDAP : ConjD -> ListAP -> AP ;        -- "both even and prime"
+  ConjDNP : ConjD -> ListNP -> NP ;        -- "either John or Mary"
+
+  TwoS  : S -> S -> ListS ;
+  ConsS : ListS -> S -> ListS ;
+
+  TwoAP  : AP -> AP -> ListAP ;
+  ConsAP : ListAP -> AP -> ListAP ;
+
+  TwoNP  : NP -> NP -> ListNP ;
+  ConsNP : ListNP -> NP -> ListNP ;
+
+--3 Subordination
+--
+-- Subjunctions are different from conjunctions, but form
+-- a uniform category among themselves.
+
+  SubjS     : Subj -> S -> S -> S ;        -- "if 2 is odd, 3 is even"
+  SubjImper : Subj -> S -> Imp -> Imp ;    -- "if it is hot, use a glove!"
+  SubjQu    : Subj -> S -> Qu -> Qu ;      -- "if you are new, who are you?"
+
+--2 One-word utterances
+--
+-- These are, more generally, *one-phrase utterances*. The list below
+-- is very incomplete.
+
+  PhrNP : NP -> Phr ;                      -- "Some man.", "John."
+  PhrOneCN, PhrManyCN : CN -> Phr ;        -- "A car.", "Cars."
+  PhrIP : IAdv -> Phr ;                    -- "Who?"
+  PhrIAdv : IAdv -> Phr ;                  -- "Why?"
+
+--2 Text formation
+--
+-- A text is a sequence of phrases. It is defined like a non-empty list.
+  
+  OnePhr  : Phr -> Text ;
+  ConsPhr : Phr -> Text -> Text ;
+
+--2 Examples of structural words
+-- 
+-- Here we have some words belonging to closed classes and appearing
+-- in all languages we have considered.
+-- Sometimes they are not really meaningful, e.g. $TheyNP$ in French
+-- should really be replaced by masculine and feminine variants.
+
+  EveryDet, AllDet, WhichDet, MostDet : Det ; -- every, all, which, most
+  INP, ThouNP, HeNP, SheNP, ItNP : NP ;       -- personal pronouns in singular
+  WeNP, YeNP, TheyNP : NP ;                   -- personal pronouns in plural
+  YouNP : NP ;                                -- the polite you
+  WhenIAdv,WhereIAdv,WhyIAdv,HowIAdv : IAdv ; -- when, where, why, how
+  AndConj, OrConj : Conj ;                    -- and, or
+  BothAnd, EitherOr, NeitherNor : ConjD ;     -- both-and, either-or, neither-nor
+  IfSubj, WhenSubj : Subj ;                   -- if, when
+  PhrYes, PhrNo : Phr ;                       -- yes, no
+  VeryAdv, TooAdv : AdA ;                     -- very, too
+  OtherwiseAdv, ThereforeAdv : AdS ;          -- therefore, otherwise            
+} ;
+
diff --git a/grammars/resource/abstract/Restaurant.gf b/grammars/resource/abstract/Restaurant.gf
new file mode 100644
index 000000000..5c4ae4681
--- /dev/null
+++ b/grammars/resource/abstract/Restaurant.gf
@@ -0,0 +1,15 @@
+abstract Restaurant = Database ** {
+
+fun 
+  Restaurant, Bar : Noun ;
+  French, Italian, Indian, Japanese : Property ;
+  address, phone, priceLevel : Feature ;
+  Cheap, Expensive : Comparison ;
+
+  WhoRecommend : Name -> Phras ;
+  WhoHellRecommend : Name -> Phras ;
+
+  
+-- examples of restaurant names
+  LucasCarton : Name ;
+} ;
diff --git a/grammars/resource/abstract/TestAbs.gf b/grammars/resource/abstract/TestAbs.gf
new file mode 100644
index 000000000..c07ac4968
--- /dev/null
+++ b/grammars/resource/abstract/TestAbs.gf
@@ -0,0 +1,15 @@
+abstract TestAbs = ResAbs ** {
+
+-- a random sample of lexicon to test resource grammar with
+
+fun
+  Big, Small, Old, Young : AdjDeg ; 
+  Man, Woman, Car, House, Light : N ;
+  Walk, Run : V ;
+  Send, Wait, Love, SwitchOn, SwitchOff : TV ;
+  Say, Prove : VS ;
+  Mother, Uncle : Fun ;
+  Connection : Fun2 ;
+  Well, Always : AdV ;
+  John, Mary : PN ;
+} ;
diff --git a/grammars/resource/english/DatabaseEng.gf b/grammars/resource/english/DatabaseEng.gf
new file mode 100644
index 000000000..9d94e69ed
--- /dev/null
+++ b/grammars/resource/english/DatabaseEng.gf
@@ -0,0 +1,51 @@
+concrete DatabaseEng of Database = open Prelude,Syntax,English,Predication,Paradigms,DatabaseRes in {
+
+flags lexer=text ; unlexer=text ;
+
+lincat 
+  Phras      = SS1 Bool ;            -- long or short form
+  Subject    = NP ;
+  Noun       = CN ;  
+  Property   = AP ;
+  Comparison = AdjDeg ;
+  Relation   = Adj2 ;
+  Feature    = Fun ;
+  Value      = NP ;
+  Name       = ProperName ;
+
+lin
+  LongForm  sent = ss (sent.s ! True ++ "?") ;
+  ShortForm sent = ss (sent.s ! False ++ "?") ;
+
+  WhichAre A B = mkSent (defaultQuestion (IntVP (NounIPMany A) (PosA B)))
+                        (defaultNounPhrase (IndefManyNP (ModAdj B A))) ;
+
+  IsIt Q A   = mkSentSame (defaultQuestion (QuestVP Q (PosA A))) ;
+
+  MoreThan   = ComparAdjP ;
+  TheMost    = SuperlNP ;
+  Relatively C _  = PositAdjP C ; 
+
+  RelatedTo  = ComplAdj ;
+
+  FeatureOf = appFun1 ;
+  ValueOf F V = appFun1 F (UsePN V) ;
+
+  WithProperty A B = ModAdj B A ;
+
+  Individual = UsePN ;
+
+  AllN = DetNP AllDet ;
+  MostN = DetNP MostDet ;
+  EveryN = DetNP EveryDet ;
+
+-- only these are language-dependent
+
+  Any = detNounPhrase anyPlDet ; ---
+
+  IsThere A  = mkSentPrel ["is there"]  (defaultNounPhrase (IndefOneNP A)) ;
+  AreThere A = mkSentPrel ["are there"] (defaultNounPhrase (IndefManyNP A)) ;
+
+  WhatIs V   = mkSentPrel ["what is"] (defaultNounPhrase V) ;
+
+} ;
diff --git a/grammars/resource/english/DatabaseEngRes.gf b/grammars/resource/english/DatabaseEngRes.gf
new file mode 100644
index 000000000..e00501a47
--- /dev/null
+++ b/grammars/resource/english/DatabaseEngRes.gf
@@ -0,0 +1,11 @@
+resource DatabaseEngRes = open Prelude in {
+oper
+  mkSent : SS -> SS -> SS1 Bool = \long, short -> 
+    {s = table {b => if_then_else Str b long.s short.s}} ;
+
+  mkSentPrel : Str -> SS -> SS1 Bool = \prel, matter -> 
+    mkSent (ss (prel ++ matter.s)) matter ;
+
+  mkSentSame : SS -> SS1 Bool = \s -> 
+    mkSent s s ;
+} ;
diff --git a/grammars/resource/english/English.gf b/grammars/resource/english/English.gf
new file mode 100644
index 000000000..45b64d72f
--- /dev/null
+++ b/grammars/resource/english/English.gf
@@ -0,0 +1 @@
+resource English = reuse ResEng ;
diff --git a/grammars/resource/english/Morpho.gf b/grammars/resource/english/Morpho.gf
new file mode 100644
index 000000000..52779cd11
--- /dev/null
+++ b/grammars/resource/english/Morpho.gf
@@ -0,0 +1,150 @@
+--1 A Simple English Resource Morphology
+--
+-- Aarne Ranta 2002
+--
+-- This resource morphology contains definitions needed in the resource
+-- syntax. It moreover contains the most usual inflectional patterns.
+--
+-- We use the parameter types and word classes defined in $types.Eng.gf$.
+
+resource Morpho = Types ** open Prelude in {
+
+--2 Nouns
+--
+-- For conciseness and abstraction, we define a worst-case macro for
+-- noun inflection. It is used for defining special case that
+-- only need one string as argument.
+
+oper
+  mkNoun  : (_,_,_,_ : Str) -> CommonNoun = 
+    \man,men, mans, mens -> {s = table {
+       Sg => table {Nom => man ; Gen => mans} ;
+       Pl => table {Nom => men ; Gen => mens}
+      }} ;
+
+  nounReg : Str -> CommonNoun = \dog -> 
+    mkNoun dog (dog + "s") (dog + "'s") (dog + "s'");
+
+  nounS   : Str -> CommonNoun = \kiss -> 
+    mkNoun kiss (kiss + "es") (kiss + "'s") (kiss + "es'") ;
+
+  nounY   : Str -> CommonNoun = \fl -> 
+    mkNoun (fl + "y") (fl + "ies") (fl + "y's") (fl + "ies'") ;
+
+--3 Proper names
+--
+-- Regular proper names are inflected with "'s" in the genitive.
+
+  nameReg : Str -> ProperName = \john -> 
+    {s = table {Nom => john ; Gen => john + "'s"}} ;
+
+
+--2 Pronouns
+--
+-- Here we define personal and relative pronouns.
+
+  mkPronoun : (_,_,_,_ : Str) -> Number -> Person -> Pronoun = \I,me,my,mine,n,p -> 
+    {s = table {NomP => I ; AccP => me ; GenP => my ; GenSP => mine} ; 
+     n = n ; p = p} ;
+
+  pronI = mkPronoun "I" "me" "my" "mine" Sg P1 ;
+  pronYouSg = mkPronoun "you" "you" "your" "yours" Sg P2 ; -- verb form still OK
+  pronHe = mkPronoun "he" "him" "his" "his" Sg P3 ;
+  pronShe = mkPronoun "she" "her" "her" "hers" Sg P3 ;
+
+  pronWe = mkPronoun "we" "us" "our" "ours" Pl P1 ;
+  pronYouPl = mkPronoun "you" "you" "your" "yours" Pl P2 ;
+  pronThey = mkPronoun "they" "them" "their" "theirs" Pl P3 ;
+
+-- Relative pronouns in the accusative have the 'no pronoun' variant.
+-- The simple pronouns do not really depend on number.
+
+  relPron : RelPron = {s = table {
+    NoHum => \\_ => table {
+      NomP => variants {"that" ; "which"} ;
+      AccP => variants {"that" ; "which" ; []} ;
+      GenP => variants {"whose"} ;
+      GenSP => variants {"which"}
+      } ;
+    Hum => \\_ => table {
+      NomP => variants {"that" ; "who"} ;
+      AccP => variants {"that" ; "who" ; "whom" ; []} ;
+      GenP => variants {"whose"} ;
+      GenSP => variants {"whom"}
+      }
+    }
+  } ;
+
+
+--3 Determiners
+--
+-- We have just a heuristic definition of the indefinite article.
+-- There are lots of exceptions: consonantic "e" ("euphemism"), consonantic
+-- "o" ("one-sided"), vocalic "u" ("umbrella").
+
+  artIndef = pre {"a" ; 
+                  "an" / strs {"a" ; "e" ; "i" ; "o" ; "A" ; "E" ; "I" ; "O" }} ;
+
+  artDef = "the" ;
+
+--2 Adjectives
+--
+-- For the comparison of adjectives, three forms are needed in the worst case.
+
+  mkAdjDegr : (_,_,_ : Str) -> AdjDegr = \good,better,best -> 
+    {s = table {Pos => good ; Comp => better ; Sup => best}} ;
+
+  adjDegrReg : Str -> AdjDegr = \long ->
+    mkAdjDegr long (long + "er") (long + "est") ;
+
+  adjDegrY : Str -> AdjDegr = \lovel ->
+    mkAdjDegr (lovel + "y") (lovel + "ier") (lovel + "iest") ;
+
+-- Many adjectives are 'inflected' by adding a comparison word.
+
+  adjDegrLong : Str -> AdjDegr = \ridiculous ->
+    mkAdjDegr ridiculous ("more" ++ ridiculous) ("most" ++ ridiculous) ;
+
+-- simple adjectives are just strings
+
+  simpleAdj : Str -> Adjective = ss ;
+
+--3 Verbs
+--
+-- Except for "be", the worst case needs two forms.
+
+  mkVerbP3 : (_,_: Str) -> VerbP3 = \goes,go -> 
+    {s = table {InfImp => go ; Indic P3 => goes ; Indic _ => go}} ;
+
+  regVerbP3 : Str -> VerbP3 = \walk -> 
+    mkVerbP3 (walk + "s") walk ;
+
+  verbP3s   : Str -> VerbP3 = \kiss -> 
+    mkVerbP3 (kiss + "es") kiss ;
+
+  verbP3y   : Str -> VerbP3 = \fl -> 
+    mkVerbP3 (fl + "ies") (fl + "y") ;
+
+  verbP3Have = mkVerbP3 "has" "have" ;
+
+  verbP3Do   = verbP3s "do" ;
+
+  verbBe : VerbP3 = {s = table {
+    InfImp => "be" ; 
+    Indic P1 => "am" ; 
+    Indic P2 => "are" ;
+    Indic P3 => "is"
+    }} ;
+
+  verbPart : VerbP3 -> Particle -> Verb = \v,p ->
+    v ** {s1 = p} ;
+
+  verbNoPart : VerbP3 -> Verb = \v -> verbPart v [] ;
+
+-- The optional negation contraction is a useful macro e.g. for "do".
+
+  contractNot : Str -> Str = \is -> variants {is ++ "not" ; is + "n't"} ;
+
+  dont = contractNot (verbP3Do.s ! InfImp) ;
+} ;
+
diff --git a/grammars/resource/english/Paradigms.gf b/grammars/resource/english/Paradigms.gf
new file mode 100644
index 000000000..65e5c1297
--- /dev/null
+++ b/grammars/resource/english/Paradigms.gf
@@ -0,0 +1,229 @@
+--1 English Lexical Paradigms
+--
+-- Aarne Ranta 2003
+--
+-- This is an API to the user of the resource grammar 
+-- for adding lexical items. It give shortcuts for forming
+-- expressions of basic categories: nouns, adjectives, verbs.
+-- 
+-- Closed categories (determiners, pronouns, conjunctions) are
+-- accessed through the resource syntax API, $resource.Abs.gf$. 
+--
+-- The main difference with $morpho.Eng.gf$ is that the types
+-- referred to are compiled resource grammar types. We have moreover
+-- had the design principle of always having existing forms as string
+-- arguments of the paradigms, not stems.
+--
+-- The following modules are presupposed:
+
+resource Paradigms = open (Predef=Predef), Prelude, Syntax, English in {
+
+--2 Parameters 
+--
+-- To abstract over gender names, we define the following identifiers.
+
+oper
+  human    : Gender ;
+  nonhuman : Gender ;
+
+-- To abstract over number names, we define the following.
+
+  singular : Number ;
+  plural   : Number ;
+
+
+--2 Nouns
+
+-- Worst case: give all four forms and the semantic gender.
+-- In practice the worst case is just: give singular and plural nominative.
+
+oper
+  mkN  : (man,men,man's,men's : Str) -> Gender -> N ;
+  nMan : (man,men : Str) -> Gender -> N ;
+
+-- Regular nouns, nouns ending with "s", "y", or "o", and nouns with the same
+-- plural form as the singular.
+
+  nReg   : Str -> Gender -> N ;   -- dog, dogs
+  nKiss  : Str -> Gender -> N ;   -- kiss, kisses
+  nFly   : Str -> Gender -> N ;   -- fly, flies
+  nHero  : Str -> Gender -> N ;   -- hero, heroes (= nKiss !)
+  nSheep : Str -> Gender -> N ;   -- sheep, sheep
+  
+-- These use general heuristics, that recognizes the last letter. *N.B* it 
+-- does not get right with "boy", "rush", since it only looks at one letter.
+
+  nHuman    : Str -> N ;  -- gambler/actress/nanny
+  nNonhuman : Str -> N ;  -- dog/kiss/fly
+
+-- Nouns used as functions need a preposition. The most common is "of".
+
+  mkFun : N -> Preposition -> Fun ;
+
+  funHuman    : Str -> Fun ;  -- the father/mistress/daddy of 
+  funNonhuman : Str -> Fun ;  -- the successor/address/copy of 
+
+-- Proper names, with their regular genitive.
+
+  pnReg : (John : Str) -> PN ;          -- John, John's
+
+-- The most common cases on the top level havee shortcuts.
+-- The regular "y"/"s" variation is taken into account in $CN$.
+
+  cnNonhuman : Str -> CN ;
+  cnHuman    : Str -> CN ;
+  npReg      : Str -> NP ;
+
+
+--2 Adjectives
+
+-- Non-comparison one-place adjectives just have one form.
+
+  mkAdj1 : (even : Str) -> Adj1 ;
+ 
+-- Two-place adjectives need a preposition as second argument.
+
+  mkAdj2 : (divisible, by : Str) -> Adj2 ;
+
+-- Comparison adjectives have three forms. The common irregular
+-- cases are ones ending with "y" and a consonant that is duplicated.
+
+  mkAdjDeg : (good,better,best : Str) -> AdjDeg ;
+
+  aReg        : (long  : Str) -> AdjDeg ;      -- long, longer, longest
+  aHappy      : (happy : Str) -> AdjDeg ;      -- happy, happier, happiest
+  aFat        : (fat   : Str) -> AdjDeg ;      -- fat, fatter, fattest
+  aRidiculous : (ridiculous : Str) -> AdjDeg ; -- -/more/most ridiculous
+
+-- On top level, there are adjectival phrases. The most common case is
+-- just to use a one-place adjective.
+
+  apReg : Str -> AP ;
+
+
+--2 Verbs
+--
+-- The fragment only has present tense so far, but in all persons.
+-- Except for "be", the worst case needs two forms: the infinitive and
+-- the third person singular.
+
+  mkV   : (go, goes : Str) -> V ;
+
+  vReg  : (walk : Str) -> V ;  -- walk, walks
+  vKiss : (kiss : Str) -> V ;  -- kiss, kisses
+  vFly  : (fly  : Str) -> V ;  -- fly, flies
+  vGo   : (go   : Str) -> V ;  -- go, goes (= vKiss !)
+
+-- This generic function recognizes the special cases where the last
+-- character is "y", "s", or "z". It is not right for "finish" and "convey".
+
+  vGen : Str -> V ; -- walk/kiss/fly
+
+-- The verbs "be" and "have" are special.
+
+  vBe   : V ;
+  vHave : V ;
+
+-- Verbs with a particle.
+
+  vPart    : (go, goes, up : Str) -> V ;
+  vPartReg : (get,      up : Str) -> V ;    
+
+-- Two-place verbs, and the special case with direct object.
+-- Notice that a particle can already be included in $V$.
+
+  mkTV  : V -> Str -> TV ;              -- look for, kill
+
+  tvGen    : (look, for : Str) -> TV ;  -- look for, talk about
+  tvDir    : V                 -> TV ;  -- switch off
+  tvGenDir : (kill      : Str) -> TV ;  -- kill
+
+-- Regular two-place verbs with a particle.
+
+  tvPartReg : Str -> Str -> Str -> TV ; -- get, along, with
+
+-- The definitions should not bother the user of the API. So they are
+-- hidden from the document.
+--.
+
+  human = Hum ; 
+  nonhuman = NoHum ;
+  -- singular defined in types.Eng
+  -- plural defined in types.Eng
+
+  nominative = Nom ;
+
+  mkN = \man,men,man's,men's,g -> mkNoun man men man's men's ** {g = g} ;
+  nReg = addGenN nounReg ;
+  nKiss = addGenN nounS ;
+  nFly = \fly -> addGenN nounY (Predef.tk 1 fly) ;
+  nMan = \man,men -> mkN man men (man + "'s") (men + "'s") ;
+  nHero = nKiss ;
+  nSheep = \sheep -> nMan sheep sheep ;
+
+  nHuman = \s -> nGen s Hum ;
+  nNonhuman = \s -> nGen s NoHum ;
+
+  nGen : Str -> Gender -> N = \fly,g -> let {
+      fl  = Predef.tk 1 fly ; 
+      y   = Predef.dp 1 fly ; 
+      eqy = ifTok (Str -> Gender -> N) y
+    } in
+    eqy "y" nFly  (
+    eqy "s" nKiss (
+    eqy "z" nKiss (
+            nReg))) fly g ;
+
+  mkFun = \n,p -> n ** {s2 = p} ;
+  funNonhuman = \s -> mkFun (nNonhuman s) "of" ;
+  funHuman = \s -> mkFun (nHuman s) "of" ;
+
+  pnReg = nameReg ;
+
+  cnNonhuman = \s -> UseN (nGen s nonhuman) ;
+  cnHuman = \s -> UseN (nGen s human) ;
+  npReg = \s -> UsePN (pnReg s) ;  
+
+  addGenN : (Str -> CommonNoun) -> Str -> Gender -> N = \f -> 
+    \s,g -> f s ** {g = g} ;
+
+  mkAdj1 = simpleAdj ;
+  mkAdj2 = \s,p -> simpleAdj s ** {s2 = p} ;
+  mkAdjDeg = mkAdjDegr ;
+  aReg = adjDegrReg ;
+  aHappy = \happy -> adjDegrY (Predef.tk 1 happy) ;
+  aFat = \fat -> let {fatt = fat + Predef.dp 1 fat} in 
+         mkAdjDeg fat (fatt + "er") (fatt + "est") ;
+  aRidiculous = adjDegrLong ;
+  apReg = \s -> AdjP1 (mkAdj1 s) ;
+
+  mkV = \go,goes -> verbNoPart (mkVerbP3 goes go) ;
+  vReg = \run -> mkV run (run + "s") ;
+  vKiss = \kiss -> mkV kiss (kiss + "es") ;
+  vFly = \fly -> mkV fly (Predef.tk 1 fly + "ies") ;
+  vGo = vKiss ;
+
+  vGen = \fly -> let {
+      fl  = Predef.tk 1 fly ; 
+      y   = Predef.dp 1 fly ; 
+      eqy = ifTok (Str -> V) y
+    } in
+    eqy "y" vFly  (
+    eqy "s" vKiss (
+    eqy "z" vKiss (
+            vReg))) fly ;
+
+  vPart = \go, goes, up -> verbPart (mkVerbP3 goes go) up ;
+  vPartReg = \get, up -> verbPart (regVerbP3 get) up ;
+
+  mkTV = \v,p -> v ** {s3 = p} ;
+  tvPartReg = \get, along, with -> mkTV (vPartReg get along) with ;
+
+  vBe = verbBe ;
+  vHave = mkV "have" "has" ;
+
+  tvGen = \s,p -> mkTV (vGen s) p ;
+  tvDir = \v -> mkTV v [] ;
+  tvGenDir = \s -> tvDir (vGen s) ;
+
+} ;
diff --git a/grammars/resource/english/Predication.gf b/grammars/resource/english/Predication.gf
new file mode 100644
index 000000000..cc92c465f
--- /dev/null
+++ b/grammars/resource/english/Predication.gf
@@ -0,0 +1,83 @@
+
+--1 A Small Predication Library
+--
+-- (c) Aarne Ranta 2003 under Gnu GPL.
+--
+-- This library is built on a language-independent API of
+-- resource grammars. It has a common part, the type signatures
+-- (defined here), and language-dependent parts. The user of
+-- the library should only have to look at the type signatures.
+
+resource Predication = open English in {
+
+-- We first define a set of predication patterns.
+
+oper
+  predV1 : V -> NP -> S ;             -- one-place verb: "John walks"
+  predV2 : TV -> NP -> NP -> S ;      -- two-place verb: "John loves Mary"
+  predVColl : V -> NP -> NP -> S ;    -- collective verb: "John and Mary fight"
+  predA1 : Adj1 -> NP -> S ;          -- one-place adjective: "John is old"
+  predA2 : Adj2 -> NP -> NP -> S ;    -- two-place adj: "John is married to Mary"
+  predAComp : AdjDeg -> NP -> NP -> S ; -- compar adj: "John is older than Mary"
+  predAColl : Adj1 -> NP -> NP -> S ; -- collective adj: "John and Mary are married"
+  predN1 : N -> NP -> S ;             -- one-place noun: "John is a man"
+  predN2 : Fun -> NP -> NP -> S ;     -- two-place noun: "John is a lover of Mary"
+  predNColl : N -> NP -> NP -> S ;    -- collective noun: "John and Mary are lovers"
+
+-- Individual-valued function applications.
+
+  appFun1 : Fun -> NP -> NP ;          -- one-place function: "the successor of x"
+  appFunColl : Fun -> NP -> NP -> NP ; -- collective function: "the sum of x and y"
+
+-- Families of types, expressed by common nouns depending on arguments.
+
+  appFam1 : Fun -> NP -> CN ;          -- one-place family: "divisor of x"
+  appFamColl : Fun -> NP -> NP -> CN ; -- collective family: "path between x and y"
+
+-- Type constructor, similar to a family except that the argument is a type.
+
+  constrTyp1 : Fun -> CN -> CN ;
+
+-- Logical connectives on two sentences.
+
+  conjS : S -> S -> S ;
+  disjS : S -> S -> S ;
+  implS : S -> S -> S ;
+
+-- As an auxiliary, we need two-place conjunction of names ("John and Mary"), 
+-- used in collective predication.
+
+  conjNP : NP -> NP -> NP ;
+
+
+-----------------------------
+
+---- what follows should be an implementation of the preceding
+
+oper
+  predV1 = \F, x -> PredVP x (PosV F) ;
+  predV2 = \F, x, y -> PredVP x (PosTV F y) ;
+  predVColl = \F, x, y -> PredVP (conjNP x y) (PosV F) ;
+  predA1 = \F, x -> PredVP x (PosA F) ;
+  predA2 = \F, x, y -> PredVP x (PosA (ComplAdj F y)) ;
+  predAComp = \F, x, y -> PredVP x (PosA (ComparAdjP F y)) ;
+  predAColl = \F, x, y -> PredVP (conjNP x y) (PosA F) ;
+  predN1 = \F, x -> PredVP x (PosCN (UseN F)) ;
+  predN2 = \F, x, y -> PredVP x (PosCN (AppFun F y)) ;
+  predNColl = \F, x, y -> PredVP (conjNP x y) (PosCN (UseN F)) ;
+
+  appFun1 = \f, x -> DefOneNP (AppFun f x) ;
+  appFunColl = \f, x, y -> DefOneNP (AppFun f (conjNP x y)) ;
+
+  appFam1 = \F, x -> AppFun F x ;
+  appFamColl = \F, x, y -> AppFun F (conjNP x y) ;
+
+  conjS = \A, B -> ConjS AndConj (TwoS A B) ;
+  disjS = \A, B -> ConjS OrConj (TwoS A B) ;
+  implS = \A, B -> SubjS IfSubj A B ;
+
+  constrTyp1 = \F, A -> AppFun F (IndefManyNP A) ;
+
+  conjNP = \x, y -> ConjNP AndConj (TwoNP x y) ;
+
+} ;
diff --git a/grammars/resource/english/ResEng.gf b/grammars/resource/english/ResEng.gf
new file mode 100644
index 000000000..412bcfae7
--- /dev/null
+++ b/grammars/resource/english/ResEng.gf
@@ -0,0 +1,195 @@
+--1 The Top-Level English Resource Grammar
+--
+-- Aarne Ranta 2002 -- 2003
+--
+-- This is the English concrete syntax of the multilingual resource
+-- grammar. Most of the work is done in the file $syntax.Eng.gf$.
+-- However, for the purpose of documentation, we make here explicit the
+-- linearization types of each category, so that their structures and
+-- dependencies can be seen.
+-- Another substantial part are the linearization rules of some
+-- structural words.
+--
+-- The users of the resource grammar should not look at this file for the
+-- linearization rules, which are in fact hidden in the document version.
+-- They should use $resource.Abs.gf$ to access the syntactic rules.
+-- This file can be consulted in those, hopefully rare, occasions in which
+-- one has to know how the syntactic categories are
+-- implemented. The parameter types are defined in $types.Eng.gf$.
+
+concrete ResEng of ResAbs = open Prelude, Syntax in {
+
+flags 
+  startcat=Phr ; 
+  parser=chart ;
+
+lincat 
+  N      = CommNoun ;         
+      -- = {s : Number => Case => Str}
+  CN     = CommNounPhrase ;   
+      -- = CommNoun ** {g : Gender}
+  NP     = {s : NPForm => Str ; n : Number ; p : Person} ;
+  PN     = {s : Case => Str} ;
+  Det    = {s : Str ; n : Number} ;
+  Fun    = CommNounPhrase ** {s2 : Preposition} ;
+
+  Adj1   = Adjective ; 
+      -- = {s : Str}
+  Adj2   = Adjective ** {s2 : Preposition} ;
+  AdjDeg = {s : Degree => Str} ;
+  AP     = Adjective ** {p : Bool} ;
+
+  V      = Verb ; 
+      -- = {s : VForm => Str ; s1 : Particle}
+  VP     = {s : VForm => Str ; s2 : Number => Str ; isAux : Bool} ;
+  TV     = Verb ** {s3 : Preposition} ;
+  VS     = Verb ;
+
+  AdV    = {s : Str ; isPost : Bool} ;
+
+  S      = {s : Str} ; 
+  Slash  = {s : Bool => Str ; s2 : Preposition} ;
+  RP     = {s : Gender => Number => NPForm => Str} ;
+  RC     = {s : Gender => Number => Str} ;
+
+  IP     = {s : NPForm => Str ; n : Number} ;
+  Qu     = {s : QuestForm => Str} ;
+  Imp    = {s : Number => Str} ;
+  Phr    = {s : Str} ;
+
+  Conj   = {s : Str ; n : Number} ;
+  ConjD  = {s1 : Str ; s2 : Str ; n : Number} ;
+
+  ListS  = {s1 : Str ; s2 : Str} ;
+  ListAP = {s1 : Str ; s2 : Str ; p : Bool} ;
+  ListNP = {s1,s2 : NPForm => Str ; n : Number ; p : Person} ;
+
+--.
+
+lin 
+  UseN = noun2CommNounPhrase ;
+  ModAdj = modCommNounPhrase ;
+  ModGenOne = npGenDet singular ;
+  ModGenMany = npGenDet plural ;
+  UsePN = nameNounPhrase ;
+  UseFun = funAsCommNounPhrase ;
+  AppFun = appFunComm ;
+  AdjP1 = adj2adjPhrase ;
+  ComplAdj = complAdj ;
+  PositAdjP = positAdjPhrase ;
+  ComparAdjP = comparAdjPhrase ;
+  SuperlNP = superlNounPhrase ;
+
+  DetNP = detNounPhrase ;
+  IndefOneNP = indefNounPhrase singular ;
+  IndefManyNP = indefNounPhrase plural ;
+  DefOneNP = defNounPhrase singular ;
+  DefManyNP = defNounPhrase plural ;
+
+  PredVP = predVerbPhrase ;
+  PosV = predVerb True ;
+  NegV = predVerb False ;
+  PosA = predAdjective True ;
+  NegA = predAdjective False ;
+  PosCN = predCommNoun True ;
+  NegCN = predCommNoun False ;
+  PosTV = complTransVerb True ;
+  NegTV = complTransVerb False ;
+  PosNP = predNounPhrase True ;
+  NegNP = predNounPhrase False ;
+  PosVS = complSentVerb True ;
+  NegVS = complSentVerb False ;
+
+
+  AdvVP = adVerbPhrase ;
+  LocNP = locativeNounPhrase ;
+  AdvCN = advCommNounPhrase ;
+
+  PosSlashTV = slashTransVerb True ;
+  NegSlashTV = slashTransVerb False ;
+
+  IdRP = identRelPron ;
+  FunRP = funRelPron ;
+  RelVP = relVerbPhrase ;
+  RelSlash = relSlash ;
+  ModRC = modRelClause ;
+  RelSuch = relSuch ;
+
+  WhoOne = intPronWho singular ;
+  WhoMany = intPronWho plural ;
+  WhatOne = intPronWhat singular ;
+  WhatMany = intPronWhat plural ;
+  FunIP = funIntPron ;
+  NounIPOne = nounIntPron singular ;
+  NounIPMany = nounIntPron plural ;
+
+  QuestVP = questVerbPhrase ;
+  IntVP = intVerbPhrase ;
+  IntSlash = intSlash ;
+  QuestAdv = questAdverbial ;
+
+  ImperVP = imperVerbPhrase ;
+
+  IndicPhrase = indicUtt ;
+  QuestPhrase = interrogUtt ;
+  ImperOne = imperUtterance singular ;
+  ImperMany = imperUtterance plural ;
+
+lin
+  TwoS = twoSentence ;
+  ConsS = consSentence ;
+  ConjS = conjunctSentence ;
+  ConjDS = conjunctDistrSentence ;
+
+  TwoAP = twoAdjPhrase ;
+  ConsAP = consAdjPhrase ;
+  ConjAP = conjunctAdjPhrase ;
+  ConjDAP = conjunctDistrAdjPhrase ;
+
+  TwoNP = twoNounPhrase ;
+  ConsNP = consNounPhrase ;
+  ConjNP = conjunctNounPhrase ;
+  ConjDNP = conjunctDistrNounPhrase ;
+
+  SubjS = subjunctSentence ;
+  SubjImper = subjunctImperative ;
+  SubjQu = subjunctQuestion ;
+
+  PhrNP = useNounPhrase ;
+  PhrOneCN = useCommonNounPhrase singular ;
+  PhrManyCN = useCommonNounPhrase plural ;
+  PhrIP ip = ip ;
+  PhrIAdv ia = ia ;
+
+
+lin
+  INP    = pronI ;
+  ThouNP = pronYouSg ;
+  HeNP   = pronHe ;
+  SheNP  = pronShe ;
+  WeNP   = pronWe ;
+  YeNP   = pronYouPl ;
+  YouNP  = pronYouSg ;
+  TheyNP = pronThey ;
+
+  EveryDet = everyDet ; 
+  AllDet   = allDet ; 
+  WhichDet = whichDet ;
+  MostDet  = mostDet ;
+
+  HowIAdv = ss "how" ;
+  WhenIAdv = ss "when" ;
+  WhereIAdv = ss "where" ;
+  WhyIAdv = ss "why" ;
+
+  AndConj = ss "and" ** {n = Pl} ;
+  OrConj = ss "or" ** {n = Sg} ;
+  BothAnd = sd2 "both" "and" ** {n = Pl} ;
+  EitherOr = sd2 "either" "or" ** {n = Sg} ;
+  NeitherNor = sd2 "neither" "nor" ** {n = Sg} ;
+  IfSubj = ss "if" ;
+  WhenSubj = ss "when" ;
+
+  PhrYes = ss "Yes." ;
+  PhrNo = ss "No." ;
+} ;
diff --git a/grammars/resource/english/RestaurantEng.gf b/grammars/resource/english/RestaurantEng.gf
new file mode 100644
index 000000000..00a9392f0
--- /dev/null
+++ b/grammars/resource/english/RestaurantEng.gf
@@ -0,0 +1,25 @@
+concrete RestaurantEng of Restaurant = 
+  DatabaseEng ** open Prelude,Paradigms,DatabaseRes in {
+
+lin 
+  Restaurant = cnNonhuman "restaurant" ;
+  Bar = cnNonhuman "bar" ;
+  French = apReg "French" ;
+  Italian = apReg "Italian" ;
+  Indian = apReg "Indian" ;
+  Japanese = apReg "Japanese" ;
+
+  address = funNonhuman "address" ;
+  phone = funNonhuman ["number"] ;  --- phone
+  priceLevel = funNonhuman ["level"] ; --- price
+
+  Cheap = aReg "cheap" ;
+  Expensive = aRidiculous "expensive" ;
+
+  WhoRecommend rest = mkSentSame (ss (["who recommended"] ++ rest.s ! nominative)) ;
+  WhoHellRecommend rest = 
+    mkSentSame (ss (["who the hell recommended"] ++ rest.s ! nominative)) ;
+
+  LucasCarton = pnReg ["Lucas Carton"] ;
+
+} ;
diff --git a/grammars/resource/english/Syntax.gf b/grammars/resource/english/Syntax.gf
new file mode 100644
index 000000000..994b8722b
--- /dev/null
+++ b/grammars/resource/english/Syntax.gf
@@ -0,0 +1,848 @@
+--1 A Small English Resource Syntax
+--
+-- Aarne Ranta 2002
+--
+-- This resource grammar contains definitions needed to construct 
+-- indicative, interrogative, and imperative sentences in English.
+--
+-- The following files are presupposed:
+
+resource Syntax = Morpho ** open Prelude, (CO = Coordination) in {
+
+--2 Common Nouns
+--
+-- Simple common nouns are defined as the type $CommNoun$ in $morpho.Deu.gf$.
+
+--3 Common noun phrases
+
+-- To the common nouns of morphology,
+-- we add natural gender (human/nonhuman) which is needed in syntactic
+-- combinations (e.g. "man who runs" - "program which runs").
+
+oper
+  CommNoun = CommonNoun ** {g : Gender} ;
+
+  CommNounPhrase = CommNoun ;
+
+  noun2CommNounPhrase : CommNoun -> CommNounPhrase = \man ->
+    man ;
+
+  cnGen : CommonNoun -> Gender -> CommNoun = \cn,g ->
+    cn ** {g = g} ;
+
+  cnHum : CommonNoun -> CommNoun = \cn ->
+    cnGen cn Hum ;
+  cnNoHum : CommonNoun -> CommNoun = \cn ->
+    cnGen cn NoHum ;
+
+--2 Noun phrases
+--
+-- The worst case is pronouns, which have inflection in the possessive forms. 
+-- Proper names are a special case.
+
+  NounPhrase : Type = Pronoun ;
+
+  nameNounPhrase : ProperName -> NounPhrase = \john -> 
+    {s = \\c => john.s ! toCase c ; n = Sg ; p = P3} ;
+
+--2 Determiners
+--
+-- Determiners are inflected according to the nouns they determine.
+-- The determiner is not inflected.
+  Determiner : Type = {s : Str ; n : Number} ;
+
+  detNounPhrase : Determiner -> CommNounPhrase -> NounPhrase = \every, man -> 
+    {s = \\c => every.s ++ man.s ! every.n ! toCase c ; 
+     n = every.n ; 
+     p = P3
+    } ;
+
+  mkDeterminer : Number -> Str -> Determiner = \n,det -> 
+    {s = det ; 
+     n = n
+    } ;
+
+  everyDet = mkDeterminer Sg "every" ;
+  allDet   = mkDeterminer Pl "all" ;
+  mostDet  = mkDeterminer Pl "most" ;
+  aDet     = mkDeterminer Sg artIndef ;
+  plDet    = mkDeterminer Pl [] ;
+  theSgDet = mkDeterminer Sg "the" ;
+  thePlDet = mkDeterminer Pl "the" ;
+  anySgDet = mkDeterminer Sg "any" ;
+  anyPlDet = mkDeterminer Pl "any" ;
+
+  whichSgDet = mkDeterminer Sg "which" ;
+  whichPlDet = mkDeterminer Pl "which" ;
+
+  whichDet = whichSgDet ; --- API
+
+  indefNoun : Number -> CommNoun -> Str = \n,man -> 
+    (indefNounPhrase n man).s ! NomP ;
+
+  indefNounPhrase : Number -> CommNounPhrase -> NounPhrase = \n,man -> 
+    {s = \\c => case n of {
+                       Sg => artIndef ++ man.s ! n ! toCase c ; 
+                       Pl => man.s ! n ! toCase c
+                       } ;
+     n = n ; p = P3
+    } ;
+
+  defNounPhrase : Number -> CommNounPhrase -> NounPhrase = \n,car -> 
+    {s = \\c => artDef ++ car.s ! n ! toCase c ; n = n ; p = P3} ;
+
+-- Genitives of noun phrases can be used like determiners, to build noun phrases.
+-- The number argument makes the difference between "my house" - "my houses".
+--
+-- We have the variation "the car of John / the car of John's / John's car"
+
+  npGenDet : Number -> NounPhrase -> CommNounPhrase -> NounPhrase = 
+    \n,john,car -> 
+      {s = \\c => variants {
+             artDef ++ car.s ! n ! Nom ++ "of" ++ john.s ! GenSP ; 
+             john.s ! GenP ++ car.s ! n ! toCase c
+             } ;
+       n = n ; 
+       p = P3
+      } ;
+
+-- *Bare plural noun phrases* like "men", "good cars", are built without a 
+-- determiner word.
+
+  plurDet : CommNounPhrase -> NounPhrase = \cn -> 
+    {s = \\c => cn.s ! plural ! toCase c ; 
+     p = P3 ; 
+     n = Pl
+    } ;
+
+
+--2 Adjectives
+--
+-- Adjectival phrases have a parameter $p$ telling if they are prefixed ($True$) or 
+-- postfixed (complex APs). 
+
+  AdjPhrase : Type = Adjective ** {p : Bool} ;
+
+  adj2adjPhrase : Adjective -> AdjPhrase = \new -> new ** {p = True} ;
+
+  simpleAdjPhrase : Str -> AdjPhrase = \French ->
+    adj2adjPhrase (simpleAdj French) ;
+
+--3 Comparison adjectives
+--
+-- Each of the comparison forms has a characteristic use:
+--
+-- Positive forms are used alone, as adjectival phrases ("big").
+
+  positAdjPhrase : AdjDegr -> AdjPhrase = \big -> 
+    adj2adjPhrase (ss (big.s ! Pos)) ;
+
+-- Comparative forms are used with an object of comparison, as
+-- adjectival phrases ("bigger then you").
+
+  comparAdjPhrase : AdjDegr -> NounPhrase -> AdjPhrase = \big, you ->
+    {s = big.s ! Comp ++ "than" ++ you.s ! NomP ; 
+     p = False
+    } ;
+
+-- Superlative forms are used with a modified noun, picking out the
+-- maximal representative of a domain ("the biggest house").
+
+  superlNounPhrase : AdjDegr -> CommNoun -> NounPhrase = \big, house ->
+    {s = \\c => "the" ++ big.s ! Sup ++ house.s ! Sg ! toCase c ; 
+     n = Sg ; 
+     p = P3
+    } ;
+
+
+--3 Two-place adjectives
+--
+-- A two-place adjective is an adjective with a preposition used before
+-- the complement.
+
+  Preposition = Str ;
+
+  AdjCompl = Adjective ** {s2 : Preposition} ;
+
+  complAdj : AdjCompl -> NounPhrase -> AdjPhrase = \related,john ->
+    {s = related.s ++ related.s2 ++ john.s ! AccP ; 
+     p = False
+    } ;
+
+
+--3 Modification of common nouns
+--
+-- The two main functions of adjective are in predication ("John is old")
+-- and in modification ("an old man"). Predication will be defined
+-- later, in the chapter on verbs.
+--
+-- Modification must pay attention to pre- and post-noun
+-- adjectives: "big car"/"car bigger than X"
+
+  modCommNounPhrase : AdjPhrase -> CommNounPhrase -> CommNounPhrase = \big, car -> 
+    {s = \\n => if_then_else (Case => Str) big.p 
+           (\\c => big.s ++ car.s ! n ! c)
+           (table {Nom => car.s ! n ! Nom ++ big.s ; Gen => variants {}}) ;
+     g = car.g
+    } ;
+
+
+--2 Function expressions
+
+-- A function expression is a common noun together with the
+-- preposition prefixed to its argument ("mother of x").
+-- The type is analogous to two-place adjectives and transitive verbs.
+
+  Function = CommNounPhrase ** {s2 : Preposition} ;
+
+-- The application of a function gives, in the first place, a common noun:
+-- "mother/mothers of John". From this, other rules of the resource grammar 
+-- give noun phrases, such as "the mother of John", "the mothers of John",
+-- "the mothers of John and Mary", and "the mother of John and Mary" (the
+-- latter two corresponding to distributive and collective functions,
+-- respectively). Semantics will eventually tell when each
+-- of the readings is meaningful.
+
+  appFunComm : Function -> NounPhrase -> CommNounPhrase = \mother,john -> 
+    {s = \\n => table {
+            Gen => nonExist ;
+            _ => mother.s ! n ! Nom ++ mother.s2 ++ john.s ! GenSP 
+            } ;
+     g = mother.g
+    } ;
+
+-- It is possible to use a function word as a common noun; the semantics is
+-- often existential or indexical.
+
+  funAsCommNounPhrase : Function -> CommNounPhrase = 
+    noun2CommNounPhrase ;
+
+-- The following is an aggregate corresponding to the original function application
+-- producing "John's mother" and "the mother of John". It does not appear in the
+-- resource grammar API any longer.
+
+  appFun : Bool -> Function -> NounPhrase -> NounPhrase = \coll, mother,john -> 
+    let {n = john.n ; nf = if_then_else Number coll Sg n} in 
+    variants {
+      defNounPhrase nf (appFunComm mother john) ;
+      npGenDet nf john mother
+      } ;      
+
+-- The commonest case is functions with the preposition  "of".
+
+  funOf : CommNoun -> Function = \mother -> 
+    mother ** {s2 = "of"} ;
+
+  funOfReg : Str -> Gender -> Function = \mother,g -> 
+    funOf (nounReg mother ** {g = g}) ;
+
+
+
+--2 Verbs
+--
+--3 Verb phrases
+--
+-- Verb phrases are discontinuous: the two parts of a verb phrase are
+-- (s) an inflected verb, (s2) infinitive and complement.
+-- For instance: "doesn't" - "walk" ; "isn't" - "old" ; "is" - "a man"
+-- There's also a parameter telling if the verb is an auxiliary:
+-- this is needed in question.
+
+  VerbPhrase = VerbP3 ** {s2 : Number => Str ; isAux : Bool} ;
+
+-- From the inflection table, we selecting the finite form as function 
+-- of person and number:
+
+  indicVerb : VerbP3 -> Person -> Number -> Str = \v,p,n -> case n of {
+    Sg => v.s ! Indic p ;
+    Pl => v.s ! Indic P2
+    } ;
+
+-- A simple verb can be made into a verb phrase with an empty complement.
+-- There are two versions, depending on if we want to negate the verb.
+-- N.B. negation is *not* a function applicable to a verb phrase, since
+-- double negations with "don't" are not grammatical.
+
+  predVerb : Bool -> Verb -> VerbPhrase = \b,walk ->
+    if_then_else VerbPhrase b 
+      {s = \\v => walk.s ! v ++ walk.s1 ;
+       s2 = \\_ => [] ; 
+       isAux = False
+      }
+      {s  = \\v => contractNot (verbP3Do.s ! v) ; 
+       s2 = \\_ => walk.s ! InfImp ++ walk.s1 ;
+       isAux = True
+      } ;
+
+-- Sometimes we want to extract the verb part of a verb phrase.
+
+  verbOfPhrase : VerbPhrase -> VerbP3 = \v -> {s = v.s} ;
+
+-- Verb phrases can also be formed from adjectives ("is old"),
+-- common nouns ("is a man"), and noun phrases ("ist John").
+-- The third rule is overgenerating: "is every man" has to be ruled out
+-- on semantic grounds.
+
+  predAdjective : Bool -> Adjective -> VerbPhrase = \b,old ->
+    {s = beOrNotBe b ;
+     s2 = \\_ => old.s ;
+     isAux = True
+    } ;
+
+  predCommNoun : Bool -> CommNoun -> VerbPhrase = \b,man ->
+    {s = beOrNotBe b ;
+     s2 = \\n => indefNoun n man ;
+     isAux = True
+    } ;
+
+  predNounPhrase : Bool -> NounPhrase -> VerbPhrase = \b,john ->
+    {s = beOrNotBe b ;
+     s2 = \\_ => john.s ! NomP ;
+     isAux = True
+    } ;
+
+-- We use an auxiliary giving all forms of "be".
+
+  beOrNotBe : Bool -> (VForm => Str) = \b -> 
+    if_then_else (VForm => Str) b 
+      verbBe.s
+      (table {
+        InfImp   => contractNot "do" ++ "be" ;
+        Indic P1 => "am" ++ "not" ;
+        v        => contractNot (verbBe.s ! v)
+        }) ;
+
+--3 Transitive verbs
+--
+-- Transitive verbs are verbs with a preposition for the complement,
+-- in analogy with two-place adjectives and functions.
+-- One might prefer to use the term "2-place verb", since
+-- "transitive" traditionally means that the inherent preposition is empty.
+-- Such a verb is one with a *direct object*.
+
+  TransVerb : Type = Verb ** {s3 : Preposition} ;
+
+-- The rule for using transitive verbs is the complementization rule.
+-- Particles produce free variation: before or after the complement 
+-- ("I switch on the TV" / "I switch the TV on").
+
+  complTransVerb : Bool -> TransVerb -> NounPhrase -> VerbPhrase = 
+    \b,lookat,john ->
+    let {lookatjohn = bothWays lookat.s1 (lookat.s3 ++ john.s ! AccP)} in
+    if_then_else VerbPhrase b 
+      {s = lookat.s ; 
+       s2 = \\_ => lookatjohn ; 
+       isAux = False}
+      {s = \\v => contractNot (verbP3Do.s ! v) ; 
+       s2 = \\_ => lookat.s ! InfImp ++ lookatjohn ;
+       isAux = True} ;
+
+
+-- Verbs that take direct object and a  particle:
+  mkTransVerbPart : VerbP3 -> Str -> TransVerb = \turn,off -> 
+    {s = turn.s ; s1 = off ; s3 = []} ;
+
+-- Verbs that take prepositional object, no particle:
+  mkTransVerb : VerbP3 -> Str -> TransVerb = \wait,for -> 
+    {s = wait.s ; s1 = [] ; s3 = for} ;
+
+-- Verbs that take direct object, no particle:
+  mkTransVerbDir : VerbP3 -> TransVerb = \love -> 
+    mkTransVerbPart love [] ;
+
+
+--2 Adverbials
+--
+-- Adverbials are not inflected (we ignore comparison, and treat
+-- compared adverbials as separate expressions; this could be done another way).
+-- We distinguish between post- and pre-verbal adverbs.
+
+  Adverb : Type = SS ** {isPost : Bool} ;
+
+  advPre  : Str -> Adverb = \seldom -> ss seldom ** {isPost = False} ;
+  advPost : Str -> Adverb = \well   -> ss well   ** {isPost = True} ;
+
+-- N.B. this rule generates the cyclic parsing rule $VP#2 ::= VP#2$
+-- and cannot thus be parsed.
+
+  adVerbPhrase : VerbPhrase -> Adverb -> VerbPhrase = \sings, well ->
+    let {postp = orB well.isPost sings.isAux} in
+    {
+     s = \\v => (if_then_else Str postp [] well.s) ++ sings.s ! v ;
+     s2 = \\n => sings.s2 ! n ++ (if_then_else Str postp well.s []) ;
+     isAux = sings.isAux
+    } ;
+
+-- Adverbials are typically generated by prefixing prepositions.
+-- The rule for creating locative noun phrases by the preposition "in"
+-- is a little shaky, since other prepositions may be preferred ("on", "at").
+
+  prepPhrase : Preposition -> NounPhrase -> Adverb = \on, it ->
+    advPost (on ++ it.s ! AccP) ;
+
+  locativeNounPhrase : NounPhrase -> Adverb = 
+    prepPhrase "in" ;
+
+-- This is a source of the "mann with a telescope" ambiguity, and may produce
+-- strange things, like "cars always" (while "cars today" is OK).
+-- Semantics will have to make finer distinctions among adverbials.
+--
+-- N.B. the genitive case created in this way would not make sense.
+
+  advCommNounPhrase : CommNounPhrase -> Adverb -> CommNounPhrase = \car,today ->
+   {s = \\n => table {
+      Nom => car.s ! n ! Nom ++ today.s ; 
+      Gen => nonExist
+      } ;
+    g = car.g
+   } ;
+
+
+--2 Sentences
+--
+-- Sentences are not inflected in this fragment of English without tense.
+
+  Sentence : Type = SS ;
+
+-- This is the traditional $S -> NP VP$ rule. It takes care of
+-- agreement between subject and verb. Recall that the VP may already
+-- contain negation. 
+
+  predVerbPhrase : NounPhrase -> VerbPhrase -> Sentence = \john,walks ->
+    ss (john.s ! NomP ++ indicVerb (verbOfPhrase walks) john.p john.n ++ 
+        walks.s2 ! john.n) ;
+
+
+-- This is a macro for simultaneous predication and complementization.
+
+  predTransVerb : Bool -> NounPhrase -> TransVerb -> NounPhrase -> Sentence = 
+    \b,you,see,john -> 
+    predVerbPhrase you (complTransVerb b see john) ;
+
+
+--3 Sentence-complement verbs
+--
+-- Sentence-complement verbs take sentences as complements.
+
+  SentenceVerb : Type = Verb ;
+
+-- To generate "says that John walks" / "doesn't say that John walks":
+
+  complSentVerb : Bool -> SentenceVerb -> Sentence -> VerbPhrase = 
+    \b,say,johnruns ->
+    let {thatjohnruns = optStr "that" ++ johnruns.s} in
+    if_then_else VerbPhrase b 
+      {s  = say.s ; 
+       s2 = \\_ => thatjohnruns ; 
+       isAux = False}
+      {s  = \\v => contractNot (verbP3Do.s ! v) ; 
+       s2 = \\_ => say.s ! InfImp ++ thatjohnruns ;
+       isAux = True} ;
+
+
+--2 Sentences missing noun phrases
+--
+-- This is one instance of Gazdar's *slash categories*, corresponding to his
+-- $S/NP$.
+-- We cannot have - nor would we want to have - a productive slash-category former.
+-- Perhaps a handful more will be needed.
+--
+-- Notice that the slash category has a similar relation to sentences as
+-- transitive verbs have to verbs: it's like a *sentence taking a complement*.
+-- However, we need something more to distinguish its use in direct questions:
+-- not just "you see" but ("whom") "do you see".
+--
+-- The particle always follows the verb, but the preposition can fly:
+-- "whom you make it up with" / "with whom you make it up".
+
+  SentenceSlashNounPhrase = {s : Bool => Str ; s2 : Preposition} ;
+
+  slashTransVerb : Bool -> NounPhrase -> TransVerb -> SentenceSlashNounPhrase = 
+    \b,You,lookat ->
+    let {you   = You.s ! NomP ;
+         looks = indicVerb {s = lookat.s} You.p You.n ;
+         look  = lookat.s ! InfImp ;
+         do    = indicVerb verbP3Do You.p You.n ;
+         dont  = contractNot do ;
+         up    = lookat.s1
+        } in
+    {s  = table {
+            True  => if_then_else Str b do dont ++ you ++ look ++ up ; 
+            False => you ++ if_then_else Str b looks (dont ++ look) ++ up
+            } ;
+     s2 = lookat.s3   
+    } ;
+
+
+--2 Relative pronouns and relative clauses
+--
+-- As described in $types.Eng.gf$, relative pronouns are inflected in 
+-- gender (human/nonhuman), number, and case.
+--
+-- We get the simple relative pronoun ("who"/"which"/"whom"/"whose"/"that"/$""$)
+-- from $morpho.Eng.gf$.
+
+  identRelPron : RelPron = relPron ;
+
+  funRelPron : Function -> RelPron -> RelPron = \mother,which -> 
+    {s = \\g,n,c => "the" ++ mother.s ! n ! Nom ++ 
+                    mother.s2 ++ which.s ! g ! n ! GenSP
+    } ;
+
+-- Relative clauses can be formed from both verb phrases ("who walks") and
+-- slash expressions ("whom you see", "on which you sit" / "that you sit on"). 
+
+  RelClause : Type = {s : Gender => Number => Str} ;
+
+  relVerbPhrase : RelPron -> VerbPhrase -> RelClause = \who,walks ->
+    {s = \\g, n => who.s ! g ! n ! NomP ++ 
+                   indicVerb (verbOfPhrase walks) P3 n ++ walks.s2 ! n
+    } ;
+
+  relSlash : RelPron -> SentenceSlashNounPhrase -> RelClause = \who,yousee ->
+    {s = \\g,n => 
+           let {youSee = yousee.s ! False} in
+           variants {
+             who.s ! g ! n ! AccP ++ youSee ++ yousee.s2 ;
+             yousee.s2 ++ who.s ! g ! n ! GenSP ++ youSee
+             }
+    } ;
+
+-- A 'degenerate' relative clause is the one often used in mathematics, e.g.
+-- "number x such that x is even".
+
+  relSuch : Sentence -> RelClause = \A ->
+    {s = \\_,_ => "such" ++ "that" ++ A.s} ;
+
+-- The main use of relative clauses is to modify common nouns.
+-- The result is a common noun, out of which noun phrases can be formed
+-- by determiners. No comma is used before these relative clause.
+
+  modRelClause : CommNounPhrase -> RelClause -> CommNounPhrase = \man,whoruns ->
+    {s = \\n,c => man.s ! n ! c ++ whoruns.s ! man.g ! n ;
+     g = man.g
+    } ;
+
+
+--2 Interrogative pronouns
+--
+-- If relative pronouns are adjective-like, interrogative pronouns are
+-- noun-phrase-like. 
+
+  IntPron : Type = {s : NPForm => Str ; n : Number} ; 
+
+-- In analogy with relative pronouns, we have a rule for applying a function
+-- to a relative pronoun to create a new one. 
+
+  funIntPron : Function -> IntPron -> IntPron = \mother,which -> 
+    {s = \\c => "the" ++ mother.s ! which.n ! Nom ++ mother.s2 ++ which.s ! GenSP ;
+     n = which.n
+    } ;
+
+-- There is a variety of simple interrogative pronouns:
+-- "which house", "who", "what".
+
+  nounIntPron : Number -> CommNounPhrase -> IntPron = \n, car ->
+    {s = \\c => "which" ++ car.s ! n ! toCase c ; 
+     n = n
+    } ; 
+
+  intPronWho : Number -> IntPron = \num -> {
+    s = table {
+      NomP  => "who" ;
+      AccP  => variants {"who" ; "whom"} ;
+      GenP  => "whose" ;
+      GenSP => "whom"
+      } ;
+    n = num
+  } ;
+
+  intPronWhat : Number -> IntPron = \num -> {
+    s = table {
+      GenP  => "what's" ;
+      _ => "what"
+      } ;
+    n = num
+  } ;
+
+
+--2 Utterances
+
+-- By utterances we mean whole phrases, such as 
+-- 'can be used as moves in a language game': indicatives, questions, imperative,
+-- and one-word utterances. The rules are far from complete.
+--
+-- N.B. we have not included rules for texts, which we find we cannot say much
+-- about on this level. In semantically rich GF grammars, texts, dialogues, etc, 
+-- will of course play an important role as categories not reducible to utterances.
+-- An example is proof texts, whose semantics show a dependence between premises
+-- and conclusions. Another example is intersentential anaphora.
+
+  Utterance = SS ;
+  
+  indicUtt : Sentence -> Utterance = \x -> ss (x.s ++ ".") ;
+  interrogUtt : Question -> Utterance = \x -> ss (x.s ! DirQ ++ "?") ;
+
+
+--2 Questions
+--
+-- Questions are either direct ("are you happy") or indirect 
+-- ("if/whether you are happy").
+
+param 
+  QuestForm = DirQ | IndirQ ;
+
+oper
+  Question = SS1 QuestForm ;
+
+--3 Yes-no questions 
+--
+-- Yes-no questions are used both independently 
+-- ("does John walk" / "if John walks")
+-- and after interrogative adverbials 
+-- ("why does John walk" / "why John walks").
+-- 
+-- It is economical to handle with all these cases by the one
+-- rule, $questVerbPhrase'$. The word ("ob" / "whether") never appears
+-- if there is an adverbial.
+
+  questVerbPhrase : NounPhrase -> VerbPhrase -> Question = 
+    questVerbPhrase' False ;
+
+  questVerbPhrase' : Bool -> NounPhrase -> VerbPhrase -> Question = 
+    \adv,john,walk ->
+    {s = table {
+      DirQ   => if_then_else Str walk.isAux 
+                  (indicVerb (verbOfPhrase walk) john.p john.n ++
+                   john.s ! NomP ++ walk.s2 ! john.n) 
+                  (indicVerb verbP3Do john.p john.n ++ 
+                   john.s ! NomP ++ walk.s ! InfImp ++ walk.s2 ! john.n) ;
+      IndirQ => if_then_else Str adv [] (variants {"if" ; "whether"}) ++ 
+                (predVerbPhrase john walk).s
+      }
+    } ;
+
+
+
+--3 Wh-questions
+--
+-- Wh-questions are of two kinds: ones that are like $NP - VP$ sentences,
+-- others that are line $S/NP - NP$ sentences.
+
+  intVerbPhrase : IntPron -> VerbPhrase -> Question = \who,walk ->
+    {s = \\_ => who.s ! NomP ++ indicVerb (verbOfPhrase walk) P3 who.n ++ 
+                walk.s2 ! who.n 
+    } ;
+
+  intSlash : IntPron -> SentenceSlashNounPhrase -> Question = \who,yousee ->
+    {s = \\q =>
+           let {youSee = case q of {
+                  DirQ   => yousee.s ! True ; 
+                  IndirQ => yousee.s ! False
+                  }
+           } in
+           variants {
+             who.s ! AccP ++ youSee ++ yousee.s2 ;
+             yousee.s2 ++ who.s ! GenSP ++ youSee
+             } 
+    } ;
+
+--3 Interrogative adverbials
+--
+-- These adverbials will be defined in the lexicon: they include
+-- "when", "where", "how", "why", etc, which are all invariant one-word
+-- expressions. In addition, they can be formed by adding prepositions
+-- to interrogative pronouns, in the same way as adverbials are formed
+-- from noun phrases. 
+
+  IntAdverb = SS ;
+
+  prepIntAdverb : Preposition -> IntPron -> IntAdverb = \at, whom ->
+    ss (at ++ whom.s ! AccP) ;
+
+-- A question adverbial can be applied to anything, and whether this makes
+-- sense is a semantic question.
+
+  questAdverbial : IntAdverb -> NounPhrase -> VerbPhrase -> Question = 
+    \why, you, walk ->
+    {s = \\q => why.s ++ (questVerbPhrase' True you walk).s ! q} ;
+
+
+--2 Imperatives
+--
+-- We only consider second-person imperatives. 
+
+  Imperative = SS1 Number ;
+
+  imperVerbPhrase : VerbPhrase -> Imperative = \walk -> 
+    {s = \\n => walk.s ! InfImp ++ walk.s2 ! n} ;
+
+  imperUtterance : Number -> Imperative -> Utterance = \n,I ->
+    ss (I.s ! n ++ "!") ;
+
+
+--2 Coordination
+--
+-- Coordination is to some extent orthogonal to the rest of syntax, and
+-- has been treated in a generic way in the module $CO$ in the file
+-- $coordination.gf$. The overall structure is independent of category,
+-- but there can be differences in parameter dependencies.
+--
+--3 Conjunctions
+--
+-- Coordinated phrases are built by using conjunctions, which are either
+-- simple ("and", "or") or distributed ("both - and", "either - or").
+--
+-- The conjunction has an inherent number, which is used when conjoining
+-- noun phrases: "John and Mary are..." vs. "John or Mary is..."; in the
+-- case of "or", the result is however plural if any of the disjuncts is.
+
+  Conjunction = CO.Conjunction ** {n : Number} ;
+  ConjunctionDistr = CO.ConjunctionDistr ** {n : Number} ;
+
+--3 Coordinating sentences
+--
+-- We need a category of lists of sentences. It is a discontinuous
+-- category, the parts corresponding to 'init' and 'last' segments
+-- (rather than 'head' and 'tail', because we have to keep track of the slot between
+-- the last two elements of the list). A list has at least two elements.
+
+  ListSentence : Type = SD2 ;
+
+  twoSentence : (_,_ : Sentence) -> ListSentence = CO.twoSS ;
+
+  consSentence : ListSentence -> Sentence -> ListSentence =
+    CO.consSS CO.comma ;
+
+-- To coordinate a list of sentences by a simple conjunction, we place
+-- it between the last two elements; commas are put in the other slots,
+-- e.g. "du rauchst, er trinkt und ich esse".
+
+  conjunctSentence : Conjunction -> ListSentence -> Sentence = \c,xs ->
+    ss (CO.conjunctX c xs) ;
+
+-- To coordinate a list of sentences by a distributed conjunction, we place
+-- the first part (e.g. "either") in front of the first element, the second
+-- part ("or") between the last two elements, and commas in the other slots.
+-- For sentences this is really not used.
+
+  conjunctDistrSentence : ConjunctionDistr -> ListSentence -> Sentence = 
+    \c,xs ->
+    ss (CO.conjunctDistrX c xs) ;
+
+--3 Coordinating adjective phrases
+--
+-- The structure is the same as for sentences. The result is a prefix adjective
+-- if and only if all elements are prefix.
+
+  ListAdjPhrase : Type = SD2 ** {p : Bool} ;
+
+  twoAdjPhrase : (_,_ : AdjPhrase) -> ListAdjPhrase = \x,y ->
+    CO.twoStr x.s y.s ** {p = andB x.p y.p} ;
+
+  consAdjPhrase : ListAdjPhrase -> AdjPhrase -> ListAdjPhrase =  \xs,x ->
+    CO.consStr CO.comma xs x.s ** {p = andB xs.p x.p} ;
+
+  conjunctAdjPhrase : Conjunction -> ListAdjPhrase -> AdjPhrase = \c,xs ->
+    ss (CO.conjunctX c xs) ** {p = xs.p} ;
+
+  conjunctDistrAdjPhrase : ConjunctionDistr -> ListAdjPhrase -> AdjPhrase = 
+    \c,xs ->
+    ss (CO.conjunctDistrX c xs) ** {p = xs.p} ;
+
+
+--3 Coordinating noun phrases
+--
+-- The structure is the same as for sentences. The result is either always plural
+-- or plural if any of the components is, depending on the conjunction.
+
+  ListNounPhrase : Type = {s1,s2 : NPForm => Str ; n : Number ; p : Person} ;
+
+  twoNounPhrase : (_,_ : NounPhrase) -> ListNounPhrase = \x,y ->
+    CO.twoTable NPForm x y ** {n = conjNumber x.n y.n ; p = conjPerson x.p y.p} ;
+
+  consNounPhrase : ListNounPhrase -> NounPhrase -> ListNounPhrase =  \xs,x ->
+    CO.consTable NPForm CO.comma xs x ** 
+       {n = conjNumber xs.n x.n ; p = conjPerson xs.p x.p} ;
+
+  conjunctNounPhrase : Conjunction -> ListNounPhrase -> NounPhrase = \c,xs ->
+    CO.conjunctTable NPForm c xs ** {n = conjNumber c.n xs.n ; p = xs.p} ;
+
+  conjunctDistrNounPhrase : ConjunctionDistr -> ListNounPhrase -> NounPhrase = 
+    \c,xs ->
+    CO.conjunctDistrTable NPForm c xs ** {n = conjNumber c.n xs.n ; p = xs.p} ;
+
+-- We have to define a calculus of numbers of persons. For numbers,
+-- it is like the conjunction with $Pl$ corresponding to $False$.
+
+  conjNumber : Number -> Number -> Number = \m,n -> case <m,n> of {
+    <Sg,Sg> => Sg ;
+    _ => Pl 
+    } ;
+
+-- For persons, we let the latter argument win ("either you or I am absent"
+-- but "either I or you are absent"). This is not quite clear.
+
+  conjPerson : Person -> Person -> Person = \_,p -> 
+    p ;
+
+
+
+--2 Subjunction
+--
+-- Subjunctions ("when", "if", etc) 
+-- are a different way to combine sentences than conjunctions.
+-- The main clause can be a sentences, an imperatives, or a question,
+-- but the subjoined clause must be a sentence.
+--
+-- There are uniformly two variant word orders, e.g. 
+-- "if you smoke I get angry"
+-- and "I get angry if you smoke".
+
+  Subjunction = SS ;
+
+  subjunctSentence : Subjunction -> Sentence -> Sentence -> Sentence = 
+    \if, A, B -> 
+    ss (subjunctVariants if A.s B.s) ;
+
+  subjunctImperative : Subjunction -> Sentence -> Imperative -> Imperative = 
+    \if, A, B -> 
+    {s = \\n => subjunctVariants if A.s (B.s ! n)} ;
+
+  subjunctQuestion : Subjunction -> Sentence -> Question -> Question = 
+    \if, A, B ->
+    {s = \\q => subjunctVariants if A.s (B.s ! q)} ;
+
+  subjunctVariants : Subjunction -> Str -> Str -> Str = \if,A,B ->
+    variants {if.s ++ A ++ "," ++ B ; B ++ "," ++ if.s ++ A} ;
+
+
+--2 One-word utterances
+-- 
+-- An utterance can consist of one phrase of almost any category, 
+-- the limiting case being one-word utterances. These
+-- utterances are often (but not always) in what can be called the
+-- default form of a category, e.g. the nominative.
+-- This list is far from exhaustive.
+
+  useNounPhrase : NounPhrase -> Utterance = \john ->
+    postfixSS "." (defaultNounPhrase john) ;
+
+  useCommonNounPhrase : Number -> CommNounPhrase -> Utterance = \n,car -> 
+    useNounPhrase (indefNounPhrase n car) ;
+
+  useRegularName : SS -> NounPhrase = \john -> 
+    nameNounPhrase (nameReg john.s) ;
+
+-- Here are some default forms.
+
+  defaultNounPhrase : NounPhrase -> SS = \john -> 
+    ss (john.s ! NomP) ;
+
+  defaultQuestion : Question -> SS = \whoareyou ->
+    ss (whoareyou.s ! DirQ) ;
+
+  defaultSentence : Sentence -> Utterance = \x -> 
+    x ;
+
+} ;
diff --git a/grammars/resource/english/TestEng.gf b/grammars/resource/english/TestEng.gf
new file mode 100644
index 000000000..57d81d173
--- /dev/null
+++ b/grammars/resource/english/TestEng.gf
@@ -0,0 +1,36 @@
+concrete TestEng of TestAbs = ResEng ** open Syntax in {
+
+flags startcat=Phr ; lexer=text ; parser=chart ; unlexer=text ;
+
+-- a random sample from the lexicon
+
+lin
+  Big = mkAdjDegr "big" "bigger" "biggest";
+  Small = adjDegrReg "small" ;
+  Old = adjDegrReg "old" ;
+  Young = adjDegrReg "young" ;
+  Man = cnHum (mkNoun "man" "men" "man's" "men's") ;
+  Woman = cnHum (mkNoun "woman" "women" "woman's" "women's") ;
+  Car = cnNoHum (nounReg "car") ;
+  House = cnNoHum (nounReg "house") ;
+  Light = cnNoHum (nounReg "light") ;
+  Walk = verbNoPart (regVerbP3 "walk") ;
+  Run = verbNoPart (regVerbP3 "run") ;
+  Say = verbNoPart (regVerbP3 "say") ;
+  Prove = verbNoPart (regVerbP3 "prove") ; 
+  Send = mkTransVerbDir (regVerbP3 "send") ;
+  Love = mkTransVerbDir (regVerbP3 "love") ;
+  Wait = mkTransVerb (regVerbP3 "wait") "for" ;
+  Mother = funOfReg "mother" Hum ;
+  Uncle = funOfReg "uncle" Hum ;
+
+  Always = advPre "always" ;
+  Well = advPost "well" ;
+
+  SwitchOn  = mkTransVerbPart (verbP3s "switch") "on" ;
+  SwitchOff = mkTransVerbPart (verbP3s "switch") "off" ;
+
+  John = nameReg "John" ;
+  Mary = nameReg "Mary" ;
+
+} ;
diff --git a/grammars/resource/english/Types.gf b/grammars/resource/english/Types.gf
new file mode 100644
index 000000000..a43ffd81b
--- /dev/null
+++ b/grammars/resource/english/Types.gf
@@ -0,0 +1,101 @@
+--1 English Word Classes and Morphological Parameters
+--
+-- This is a resource module for English morphology, defining the
+-- morphological parameters and word classes of English. It is aimed
+-- to be complete w.r.t. the description of word forms.
+-- However, it only includes those parameters that are needed for
+-- analysing individual words: such parameters are defined in syntax modules.
+--
+-- we use the language-independent prelude.
+
+resource Types = open Prelude in {
+
+--
+--2 Enumerated parameter types 
+--
+-- These types are the ones found in school grammars.
+-- Their parameter values are atomic.
+
+param 
+  Number = Sg | Pl ;
+  Gender = NoHum | Hum ;
+  Case   = Nom | Gen ;
+  Person = P1 | P2 | P3 ;
+  Degree = Pos | Comp | Sup ;
+
+-- For data abstraction, we define
+
+oper 
+  singular = Sg ;
+  plural = Pl ;
+
+--2 Word classes and hierarchical parameter types
+--
+-- Real parameter types (i.e. ones on which words and phrases depend) 
+-- are often hierarchical. The alternative would be cross-products of
+-- simple parameters, but this would usually overgenerate.
+--
+
+--3 Common nouns
+--
+-- Common nouns are inflected in number and case.
+
+  CommonNoun : Type = {s : Number => Case => Str} ;
+
+
+--
+--3 Adjectives
+--
+-- The major division is between the comparison degrees, but it
+-- is also good to leave room for adjectives that cannon be compared.
+-- Such adjectives are simply strings.
+
+  Adjective : Type = SS ;
+  AdjDegr = SS1 Degree ;
+
+--3 Verbs
+--
+-- We limit the grammar so far to verbs in infinitive-imperative or present tense.
+-- The present tense is made to depend on person, which correspond to forms
+-- in the singular; plural forms are uniformly equal to the 2nd person singular.
+
+param
+  VForm = InfImp | Indic Person ;
+
+oper
+  VerbP3 : Type = SS1 VForm ;
+
+-- A full verb can moreover have a particle.
+
+  Particle : Type = Str ;
+  Verb = VerbP3 ** {s1 : Particle} ; 
+
+--
+--3 Pronouns
+--
+-- For pronouns, we need four case forms: "I" - "me" - "my" - "mine".
+
+param
+  NPForm = NomP | AccP | GenP | GenSP ; 
+
+oper
+  Pronoun  : Type = {s : NPForm => Str ; n : Number ; p : Person} ;
+
+-- Coercions between pronoun cases and ordinaty cases.
+
+  toCase  : NPForm -> Case = \c -> case c of {GenP => Gen ; _ => Nom} ;
+  toNPForm : Case -> NPForm = \c -> case c of {Gen  => GenP ; _ => NomP} ; ---
+
+--3 Proper names
+--
+-- Proper names only need two cases.
+
+  ProperName : Type = SS1 Case ;
+
+--3 Relative pronouns
+--
+-- Relative pronouns are inflected in gender (human/nonhuman), number, and case.
+
+  RelPron : Type = {s : Gender => Number => NPForm => Str} ;
+} ;
+
diff --git a/grammars/resource/german/DatabaseDeu.gf b/grammars/resource/german/DatabaseDeu.gf
new file mode 100644
index 000000000..a7a8f278e
--- /dev/null
+++ b/grammars/resource/german/DatabaseDeu.gf
@@ -0,0 +1,52 @@
+concrete DatabaseDeu of Database = 
+  open Prelude,Syntax,Deutsch,Predication,Paradigms,DatabaseRes in {
+
+flags lexer=text ; unlexer=text ;
+
+lincat 
+  Phras      = SS1 Bool ;            -- long or short form
+  Subject    = NP ;
+  Noun       = CN ;  
+  Property   = AP ;
+  Comparison = AdjDeg ;
+  Relation   = Adj2 ;
+  Feature    = Fun ;
+  Value      = NP ;
+  Name       = ProperName ;
+
+lin
+  LongForm  sent = ss (sent.s ! True ++ "?") ;
+  ShortForm sent = ss (sent.s ! False ++ "?") ;
+
+  WhichAre A B = mkSent (defaultQuestion (IntVP (NounIPMany A) (PosA B)))
+                        (defaultNounPhrase (IndefManyNP (ModAdj B A))) ;
+
+  IsIt Q A   = mkSentSame (defaultQuestion (QuestVP Q (PosA A))) ;
+
+  MoreThan   = ComparAdjP ;
+  TheMost    = SuperlNP ;
+  Relatively C _  = PositAdjP C ; 
+
+  RelatedTo  = ComplAdj ;
+
+  FeatureOf = appFun1 ;
+  ValueOf F V = appFun1 F (UsePN V) ;
+
+  WithProperty A B = ModAdj B A ;
+
+  Individual = nameNounPhrase ;
+
+  AllN = DetNP AllDet ;
+  MostN = DetNP MostDet ;
+  EveryN = DetNP EveryDet ;
+
+-- only these are language-dependent
+
+  Any = detNounPhrase einDet ;
+
+  IsThere A  = mkSentPrel ["gibt es"] (defaultNounPhrase (IndefOneNP A)) ;
+  AreThere A = mkSentPrel ["gibt es"] (defaultNounPhrase (IndefManyNP A)) ;
+
+  WhatIs V   = mkSentPrel ["was ist"] (defaultNounPhrase V) ;
+
+} ;
diff --git a/grammars/resource/german/DatabaseRes.gf b/grammars/resource/german/DatabaseRes.gf
new file mode 100644
index 000000000..57bac16ac
--- /dev/null
+++ b/grammars/resource/german/DatabaseRes.gf
@@ -0,0 +1,11 @@
+resource DatabaseRes = open Prelude in {
+oper
+  mkSent : SS -> SS -> SS1 Bool = \long, short -> 
+    {s = table {b => if_then_else Str b long.s short.s}} ;
+
+  mkSentPrel : Str -> SS -> SS1 Bool = \prel, matter -> 
+    mkSent (ss (prel ++ matter.s)) matter ;
+
+  mkSentSame : SS -> SS1 Bool = \s -> 
+    mkSent s s ;
+} ;
diff --git a/grammars/resource/german/Deutsch.gf b/grammars/resource/german/Deutsch.gf
new file mode 100644
index 000000000..4a91ad219
--- /dev/null
+++ b/grammars/resource/german/Deutsch.gf
@@ -0,0 +1 @@
+resource Deutsch = reuse ResDeu ;
diff --git a/grammars/resource/german/Logical.gf b/grammars/resource/german/Logical.gf
new file mode 100644
index 000000000..3347ae129
--- /dev/null
+++ b/grammars/resource/german/Logical.gf
@@ -0,0 +1,23 @@
+-- Slightly ad hoc and formal negation and connectives.
+
+resource Logical = Predication ** open Deutsch, Paradigms in {
+
+  oper
+    negS : S -> S ;         -- es ist nicht der Fall, dass S
+    univS : CN -> S -> S ;  -- für alle CNs gilt es, dass S
+    existS : CN -> S -> S ; -- es gibt ein CN derart, dass S
+    existManyS : CN -> S -> S ; -- es gibt CNs derart, dass S
+--.
+
+    negS = \A -> 
+      PredVP ItNP (NegNP (DefOneNP (CNthatS (UseN (nRaum "Fall" "Fälle")) A))) ;
+    univS = \A,B ->
+      PredVP ItNP (AdvVP (PosVS (mkV "gelten" "gilt" "gelte" "gegolten") B)
+                    (mkPP accusative "für" (DetNP AllDet A))) ;
+    existS = \A,B ->
+      PredVP ItNP (PosTV (tvDir (mkV "geben" "gibt" "gib" "gegeben"))
+                     (IndefOneNP (ModRC A (RelSuch B)))) ;
+    existManyS = \A,B ->
+     PredVP ItNP (PosTV (tvDir (mkV "geben" "gibt" "gib" "gegeben"))
+                    (IndefManyNP (ModRC A (RelSuch B)))) ;
+} ;
diff --git a/grammars/resource/german/Morpho.gf b/grammars/resource/german/Morpho.gf
new file mode 100644
index 000000000..f286bc3b7
--- /dev/null
+++ b/grammars/resource/german/Morpho.gf
@@ -0,0 +1,399 @@
+--1 A Simple German Resource Morphology
+--
+-- Aarne Ranta 2002
+--
+-- This resource morphology contains definitions needed in the resource
+-- syntax. It moreover contains the most usual inflectional patterns.
+--
+-- We use the parameter types and word classes defined in $types.Deu.gf$.
+
+resource Morpho = Types ** open (Predef=Predef), Prelude in {
+
+--2 Nouns
+--
+-- For conciseness and abstraction, we define a method for
+-- generating a case-dependent table from a list of four forms.
+
+oper
+  caselist : (_,_,_,_ : Str) -> Case => Str = \n,a,d,g -> table {
+    Nom => n ; Acc => a ; Dat => d ; Gen => g} ;
+
+-- The *worst-case macro* for common nouns needs six forms: all plural forms
+-- are always the same except for the dative.
+
+  mkNoun  : (_,_,_,_,_,_ : Str) -> Gender -> CommNoun = 
+    \mann, mannen, manne, mannes, männer, männern, g -> {s = table {
+       Sg => caselist mann mannen manne mannes ;
+       Pl => caselist männer männer männern männer
+       } ; g = g} ;
+
+-- But we never need all the six forms at the same time. Often
+-- we need just two, three, or four forms.
+
+  mkNoun4 : (_,_,_,_ : Str) -> Gender -> CommNoun = \kuh,kuhes,kühe,kühen ->
+      mkNoun kuh kuh kuh kuhes kühe kühen ;
+
+  mkNoun3 : (_,_,_ : Str) -> Gender -> CommNoun = \kuh,kühe,kühen ->
+      mkNoun kuh kuh kuh kuh kühe kühen ;
+
+  mkNoun2n : (_,_ : Str) -> Gender -> CommNoun = \zahl, zahlen -> 
+      mkNoun3 zahl zahlen zahlen ;
+
+  mkNoun2es : (_,_ : Str) -> Gender -> CommNoun = \wort, wörter -> 
+      mkNoun wort wort wort (wort + "es") wörter (wörter + "n") ;
+
+  mkNoun2s : (_,_ : Str) -> Gender -> CommNoun = \vater, väter -> 
+      mkNoun vater vater vater (vater + "s") väter (väter + "n") ;
+
+  mkNoun2ses : (_,_ : Str) -> Gender -> CommNoun = \wort,wörter -> 
+      mkNoun wort wort wort (wort + variants {"es" ; "s"}) wörter (wörter + "n") ;
+
+-- Here are the school grammar declensions with their commonest variations.
+-- Unfortunately we cannot define *Umlaut* in GF, but have to give two forms.
+--
+-- First declension, with plural "en"/"n", including weak masculins:
+
+  declN1  : Str -> CommNoun = \zahl  -> 
+    mkNoun2n zahl  (zahl + "en") Fem ;
+
+  declN1e : Str -> CommNoun = \stufe -> 
+    mkNoun2n stufe (stufe + "n") Fem ;  
+
+  declN1M : Str -> CommNoun = \junge -> let {jungen = junge + "n"} in
+    mkNoun junge jungen jungen jungen jungen jungen Masc ;
+
+  declN1eM : Str -> CommNoun = \soldat -> let {soldaten = soldat + "en"} in
+    mkNoun soldat soldaten soldaten soldaten soldaten soldaten Masc ;
+
+-- Second declension, with plural "e":
+
+  declN2  : Str -> CommNoun = \punkt -> 
+    mkNoun2es punkt (punkt+"e") Masc ;
+
+  declN2i  : Str -> CommNoun = \onkel -> 
+    mkNoun2s onkel onkel Masc ;
+
+  declN2u : (_,_ : Str) -> CommNoun = \raum,räume -> 
+    mkNoun2es raum räume Masc ;
+
+  declN2uF : (_,_ : Str) -> CommNoun = \kuh,kühe -> 
+    mkNoun3 kuh kühe (kühe + "n") Fem ;
+
+-- Third declension, with plural "er":
+
+  declN3  : Str -> CommNoun = \punkt -> 
+    mkNoun2es punkt (punkt+"er") Neut ;
+
+  declN3u : (_,_ : Str) -> CommNoun = \buch,bücher -> 
+    mkNoun2ses buch bücher Neut ;
+
+  declN3uS : (_,_ : Str) -> CommNoun = \haus,häuser -> 
+    mkNoun2es haus häuser Neut ;
+
+-- Plural with "s":
+
+  declNs : Str -> CommNoun = \restaurant -> 
+    mkNoun3 restaurant (restaurant+"s") (restaurant+"s") Neut ;
+
+
+--2 Pronouns
+--
+-- Here we define personal and relative pronouns.
+-- All personal pronouns, except "ihr", conform to the simple
+-- pattern $mkPronPers$.
+
+  ProPN = {s : NPForm => Str ; n : Number ; p : Person} ;
+
+  mkPronPers : (_,_,_,_,_ : Str) -> Number -> Person -> ProPN = 
+    \ich,mich,mir,meines,mein,n,p -> {
+      s = table {
+        NPCase c    => caselist ich mich mir meines ! c ;
+        NPPoss gn c => mein + pronEnding ! gn ! c
+        } ;
+      n = n ;
+      p = p
+      } ;
+
+  pronEnding : GenNum => Case => Str = table {
+    GSg Masc => caselist ""  "en" "em" "es" ;
+    GSg Fem  => caselist "e" "e"  "er" "er" ;
+    GSg Neut => caselist ""  ""   "em" "es" ;
+    GPl      => caselist "e"  "e" "en" "er"
+    } ;
+
+  pronIch  = mkPronPers "ich" "mich" "mir"   "meines" "mein"  Sg P1 ;
+  pronDu   = mkPronPers "du"  "dich" "dir"   "deines" "dein"  Sg P2 ;
+  pronEr   = mkPronPers "er"  "ihn"  "ihm"   "seines" "sein"  Sg P3 ;
+  pronSie  = mkPronPers "sie" "sie"  "ihr"   "ihres"  "ihr"   Sg P3 ;
+  pronEs   = mkPronPers "es"  "es"   "ihm"   "seines" "sein"  Sg P3 ;
+  pronWir  = mkPronPers "wir" "uns"  "uns"   "unser"  "unser" Pl P1 ;
+
+  pronSiePl = mkPronPers "sie" "sie"  "ihnen" "ihrer"  "ihr"   Pl P3 ;
+  pronSSie  = mkPronPers "Sie" "Sie"  "Ihnen" "Ihrer"  "Ihr"   Pl P3 ; ---
+
+-- We still have wrong agreement with the complement of the polite "Sie":
+-- it is in plural, like the verb, although it should be in singular.
+
+-- The peculiarity with "ihr" is the presence of "e" in forms without an ending.
+
+  pronIhr  = 
+     {s = table {
+        NPPoss (GSg Masc) Nom => "euer" ;
+        NPPoss (GSg Neut) Nom => "euer" ;
+        NPPoss (GSg Neut) Acc => "euer" ;
+        pf => (mkPronPers "ihr" "euch" "euch"  "euer"  "eur"  Pl P2).s ! pf
+        } ;
+      n = Pl ;
+      p = P2
+      } ;
+
+-- Relative pronouns are like the definite article, except in the genitive and
+-- the plural dative. The function $artDef$ will be defined right below.
+
+  RelPron : Type = {s : GenNum => Case => Str} ;
+
+  relPron : RelPron = {s = \\gn,c => 
+    case <gn,c> of {
+      <GSg Fem,Gen> => "deren" ;
+      <GSg g,Gen>   => "dessen" ;
+      <GPl,Dat>     => "denen" ;
+      <GPl,Gen>     => "deren" ;
+      _ => artDef ! gn ! c
+    } 
+  } ;
+
+
+--2 Articles
+--
+-- Here are all forms the indefinite and definite article.
+-- The indefinite article is like a large class of pronouns.
+-- The definite article is more peculiar; we don't try to
+-- subsume it to any general rule.
+
+  artIndef : Gender => Case => Str = \\g,c => "ein" + pronEnding ! GSg g ! c ;
+
+  artDef : GenNum => Case => Str = table {
+    GSg Masc => caselist "der" "den" "dem" "des" ;
+    GSg Fem  => caselist "die" "die" "der" "der" ;
+    GSg Neut => caselist "das" "das" "dem" "des" ;
+    GPl      => caselist "die" "die" "den" "der"
+    } ;
+
+
+--2 Adjectives
+--
+-- As explained in $types.Deu.gf$, it
+-- would be superfluous to use the cross product of gender and number,
+-- since there is no gender distinction in the plural. But it is handy to have
+-- a function that constructs gender-number complexes.
+  
+  gNumber : Gender -> Number -> GenNum = \g,n -> 
+    case n of {
+      Sg => GSg g ;
+      Pl => GPl
+      } ;
+
+-- It's also handy to have a function that finds out the number from such a complex.
+
+  numGenNum : GenNum -> Number = \gn -> 
+    case gn of {
+      GSg _ => Sg ;
+      GPl => Pl
+      } ;
+
+-- This function costructs parameters in the complex type of adjective forms.
+
+  aMod : Adjf -> Gender -> Number -> Case -> AForm = \a,g,n,c -> 
+    AMod a (gNumber g n) c ;
+
+-- The worst-case macro for adjectives (positive degree) only needs
+-- two forms.
+  
+  mkAdjective : (_,_ : Str) -> Adjective = \böse,bös -> {s = table {
+    APred => böse ;
+    AMod Strong (GSg Masc) c => 
+      caselist (bös+"er") (bös+"en") (bös+"em") (bös+"es") ! c ;
+    AMod Strong (GSg Fem) c => 
+      caselist (bös+"e") (bös+"e") (bös+"er") (bös+"er") ! c ;
+    AMod Strong (GSg Neut) c => 
+      caselist (bös+"es") (bös+"es") (bös+"em") (bös+"es") ! c ;
+    AMod Strong GPl c => 
+      caselist (bös+"e") (bös+"e") (bös+"en") (bös+"er") ! c ;
+    AMod Weak (GSg g) c => case <g,c> of {
+      <_,Nom>    => bös+"e" ;
+      <Masc,Acc> => bös+"en" ;
+      <_,Acc>    => bös+"e" ;
+      _          => bös+"en" } ;
+    AMod Weak GPl c => bös+"en"
+    }} ;
+
+-- Here are some classes of adjectives:
+ 
+  adjReg   : Str -> Adjective = \gut -> mkAdjective gut gut ;
+  adjE     : Str -> Adjective = \bös -> mkAdjective (bös+"e") bös ;
+  adjEr    : Str -> Adjective = \teu -> mkAdjective (teu+"er") (teu+"r") ;
+  adjInvar : Str -> Adjective = \prima -> {s = table {_ => prima}} ;
+
+-- The first three classes can be recognized from the end of the word, depending
+-- on if it is "e", "er", or something else.
+
+  adjGen : Str -> Adjective = \gut -> let {
+    er  = Predef.dp 2 gut ;
+    teu = Predef.tk 2 gut ;
+    e   = Predef.dp 1 gut ;
+    bös = Predef.tk 1 gut
+  } in
+  ifTok Adjective er "er" (adjEr  teu) (
+  ifTok Adjective e  "e"  (adjE   bös) (
+                          (adjReg gut))) ;
+
+
+-- The comparison of adjectives needs three adjectives in the worst case.
+
+  mkAdjComp : (_,_,_ : Adjective) -> AdjComp = \gut,besser,best -> 
+    {s = table {Pos => gut.s ; Comp => besser.s ; Sup => best.s}} ;
+
+-- It can be done by just three strings, if each of the comparison
+-- forms taken separately is a regular adjective.
+
+  adjCompReg3 : (_,_,_ : Str) -> AdjComp = \gut,besser,best ->
+    mkAdjComp (adjReg gut) (adjReg besser) (adjReg best) ;
+
+-- If also the comparison forms are regular, one string is enough.
+
+  adjCompReg : Str -> AdjComp = \billig ->
+    adjCompReg3 billig (billig+"er") (billig+"st") ;
+
+
+--2 Verbs
+--
+-- We limit ourselves to verbs in present tense infinitive, indicative, 
+-- and imperative, and past participle. Other forms will be introduced later.
+--
+-- The worst-case macro needs three forms: the infinitive, the third person
+-- singular indicative, and the second person singular imperative. 
+-- We take care of the special cases "ten", "sen", "ln", "rn".
+--
+-- A famous law about Germanic languages says that plural first and third person
+-- are similar.
+
+  mkVerbum : (_,_,_,_ : Str) -> Verbum = \geben, gib, gb, gegeben -> 
+    let {
+       en = Predef.dp 2 geben ;
+       geb = ifTok Tok (Predef.tk 1 en) "e" (Predef.tk 2 geben)(Predef.tk 1 geben) ;
+       gebt = ifTok Tok (Predef.dp 1 geb) "t" (geb + "et") (geb + "t") ;
+       gibst = ifTok Tok (Predef.dp 1 gib) "s" (gib + "t") (gib + "st") ;
+       gegebener = (adjReg gegeben).s
+    } in table {
+           VInf       => geben ;
+           VInd Sg P1 => geb + "e" ;
+           VInd Sg P2 => gibst ;
+           VInd Sg P3 => gib + "t" ;
+           VInd Pl P2 => gebt ;
+           VInd Pl _  => geben ; -- the famous law
+           VImp Sg    => gb ;
+           VImp Pl    => gebt ;
+           VPart a    => gegebener ! a
+           } ;
+
+-- Regular verbs:
+
+  regVerb : Str -> Verbum = \legen ->
+    let {lege = ifTok Tok (Predef.dp 3 legen) "ten" (Predef.tk 1 legen) (
+                ifTok Tok (Predef.dp 2 legen) "en"  (Predef.tk 2 legen) (
+                                                     Predef.tk 1 legen))} in
+    mkVerbum legen lege lege ("ge" + (lege + "t")) ;
+
+-- Verbs ending with "t"; now recognized in $mkVerbum$.
+
+  verbWarten : Str -> Verbum = regVerb ;
+
+-- Verbs with Umlaut in the second and third person singular and imperative:
+
+  verbSehen : Str -> Str -> Str -> Verbum = \sehen, sieht, gesehen -> 
+    let {sieh = Predef.tk 1 sieht} in mkVerbum sehen sieh sieh gesehen ;
+
+-- Verbs with Umlaut in the second and third person singular but not imperative:
+
+  verbLaufen : Str -> Str -> Str -> Verbum = \laufen, läuft, gelaufen -> 
+    let {läuf = Predef.tk 1 läuft ; laufe = Predef.tk 1 laufen} 
+    in mkVerbum laufen läuf laufe gelaufen ;
+
+-- The verb "be":
+
+  verbumSein : Verbum = let {
+    gewesen = (adjReg "gewesen").s
+  } in
+  table {
+    VInf       => "sein" ;
+    VInd Sg P1 => "bin" ;
+    VInd Sg P2 => "bist" ;
+    VInd Sg P3 => "ist" ;
+    VInd Pl P2 => "seid" ;
+    VInd Pl _  => "sind" ;
+    VImp Sg    => "sei" ;
+    VImp Pl    => "seiet" ;
+    VPart a    => gewesen ! a
+    } ;
+
+-- The verb "have":
+
+  verbumHaben :  Verbum = let {
+    haben = (regVerb "haben")
+    } in 
+    table {
+      VInd Sg P2 => "hast" ;
+      VInd Sg P3 => "hat" ;
+      v          => haben ! v
+      } ;
+
+-- The verb "become", used as the passive auxiliary:
+
+  verbumWerden :  Verbum = let {
+    werden = regVerb "werden" ;
+    geworden = (adjReg "geworden").s
+    } in 
+    table {
+      VInd Sg P2 => "wirst" ;
+      VInd Sg P3 => "wird" ;
+      VPart a    => geworden ! a ;
+      v          => werden ! v
+      } ;
+
+-- A *full verb* ($Verb$) consists of the inflection forms ($Verbum$) and
+-- a *particle* (e.g. "aus-sehen"). Simple verbs are the ones that have no 
+-- such particle.
+
+  mkVerb : Verbum -> Particle -> Verb = \v,p -> {s = v ; s2 = p} ;
+
+  mkVerbSimple : Verbum -> Verb = \v -> mkVerb v [] ;
+
+  verbSein = mkVerbSimple verbumSein ;
+  verbHaben = mkVerbSimple verbumHaben ;
+  verbWerden = mkVerbSimple verbumWerden ;
+
+{-
+  -- tests for optimizer
+  verbumSein2 : Verbum = 
+  table {
+    VInf       => "sein" ;
+    VInd Sg P1 => "bin" ;
+    VInd Sg P2 => "bist" ;
+    VInd Sg P3 => "ist" ;
+    VInd Pl P2 => "seid" ;
+    VInd Pl _  => "sind" ;
+    VImp Sg    => "sei" ;
+    VImp Pl    => "seiet" ;
+    VPart a    => (adjReg "gewesen").s ! a
+    } ;
+
+  verbumHaben2 :  Verbum = 
+    table {
+      VInd Sg P2 => "hast" ;
+      VInd Sg P3 => "hat" ;
+      v          => regVerb "haben" ! v
+      } ;
+-}
+
+} ;
+
diff --git a/grammars/resource/german/Paradigms.gf b/grammars/resource/german/Paradigms.gf
new file mode 100644
index 000000000..d31e3fecd
--- /dev/null
+++ b/grammars/resource/german/Paradigms.gf
@@ -0,0 +1,300 @@
+--1 German Lexical Paradigms
+--
+-- Aarne Ranta 2003
+--
+-- This is an API to the user of the resource grammar 
+-- for adding lexical items. It give shortcuts for forming
+-- expressions of basic categories: nouns, adjectives, verbs.
+-- 
+-- Closed categories (determiners, pronouns, conjunctions) are
+-- accessed through the resource syntax API, $resource.Abs.gf$. 
+--
+-- The main difference with $morpho.Deu.gf$ is that the types
+-- referred to are compiled resource grammar types. We have moreover
+-- had the design principle of always having existing forms as string
+-- arguments of the paradigms, not stems.
+--
+-- The following modules are presupposed:
+
+resource Paradigms = open (Predef=Predef), Prelude, (Morpho=Morpho), Syntax, Deutsch in {
+
+
+--2 Parameters 
+--
+-- To abstract over gender names, we define the following identifiers.
+
+oper
+  masculine : Gender ;
+  feminine  : Gender ;
+  neuter    : Gender ;
+
+-- To abstract over case names, we define the following.
+
+  nominative : Case ;
+  accusative : Case ;
+  dative     : Case ;
+  genitive   : Case ;
+
+-- To abstract over number names, we define the following.
+
+  singular : Number ;
+  plural   : Number ;
+
+
+--2 Nouns
+
+-- Worst case: give all four singular forms, two plural forms (others + dative),
+-- and the gender.
+
+  mkN  : (_,_,_,_,_,_ : Str) -> Gender -> N ; 
+                                 -- mann, mann, manne, mannes, männer, männern
+
+-- Often it is enough with singular and plural nominatives, and singular
+-- genitive. The plural dative
+-- is computed by the heuristic that it is the same as the nominative this
+-- ends with "n" or "s", otherwise "n" is added.
+
+  nGen : Str -> Str -> Str ->  Gender -> N ; -- punkt,punktes,punkt
+  
+-- Here are some common patterns. Singular nominative or two nominatives are needed.
+-- Two forms are needed in case of Umlaut, which would be complicated to define.
+-- For the same reason, we have separate patterns for multisyllable stems.
+-- 
+-- The weak masculine pattern $nSoldat$ avoids duplicating the final "e".
+
+  nRaum   : (_,_ : Str) -> N ;    -- Raum, (Raumes,) Räume (masc)
+  nTisch  : Str -> N ;            -- Tisch, (Tisches, Tische) (masc)
+  nVater  : (_,_ : Str) -> N ;    -- Vater, (Vaters,) Väter (masc)
+  nFehler : Str -> N ;            -- Fehler, (fehlers, Fehler) (masc)
+  nSoldat : Str -> N ;            -- Soldat (, Soldaten) ; Kunde (, Kunden) (masc)
+
+-- Neuter patterns. 
+
+  nBuch   : (_,_ : Str) -> N ;    -- Buch, (Buches, Bücher) (neut)
+  nMesser : Str -> N ;            -- Messer, (Messers, Messer) (neut)
+  nAuto   : Str -> N ;            -- Auto, (Autos, Autos) (neut)
+
+-- Feminine patterns. Duplicated "e" is avoided in $nFrau$.
+
+  nHand   : (_,_ : Str) -> N ;    -- Hand, Hände; Mutter, Mütter (fem)
+  nFrau   : Str -> N ;            -- Frau (, Frauen) ; Wiese (, Wiesen) (fem)
+
+
+-- Nouns used as functions need a preposition. The most common is "von".
+
+  mkFun  : N -> Preposition -> Case -> Fun ;
+  funVon : N -> Fun ;
+
+-- Proper names, with their possibly
+-- irregular genitive. The regular genitive is  "s", omitted after "s".
+
+  mkPN  : (karolus, karoli : Str) -> PN ; -- karolus, karoli
+  pnReg : (Johann : Str) -> PN ;          -- Johann, Johanns ; Johannes, Johannes
+
+-- On the top level, it is maybe $CN$ that is used rather than $N$, and
+-- $NP$ rather than $PN$.
+
+  mkCN  : N -> CN ;
+  mkNP  : (karolus,karoli : Str) -> NP ;
+
+  npReg : Str -> NP ;   -- Johann, Johanns
+
+-- In some cases, you may want to make a complex $CN$ into a function.
+
+  mkFunCN  : CN -> Preposition -> Case -> Fun ;
+  funVonCN : CN -> Fun ;
+
+
+--2 Adjectives
+
+-- Non-comparison one-place adjectives need two forms in the worst case:
+-- the one in predication and the one before the ending "e".
+
+  mkAdj1 : (teuer,teur : Str) -> Adj1 ;
+
+-- Invariable adjective are a special case.
+
+  adjInvar : Str -> Adj1 ;          -- prima
+
+-- The following heuristic recognizes the the end of the word, and builds
+-- the second form depending on if it is "e", "er", or something else.
+-- N.B. a contraction is made with "er", which works for "teuer" but not
+-- for "bitter".
+
+  adjGen : Str -> Adj1 ;            -- gut; teuer; böse
+
+-- Two-place adjectives need a preposition and a case as extra arguments.
+
+  mkAdj2 : Adj1 -> Str -> Case -> Adj2 ;  -- teilbar, durch, acc
+
+-- Comparison adjectives may need three adjective, corresponding to the
+-- three comparison forms. 
+
+  mkAdjDeg : (gut,besser,best : Adj1) -> AdjDeg ;
+
+-- In many cases, each of these adjectives is itself regular. Then we only
+-- need three strings. Notice that contraction with "er" is not performed
+-- ("bessere", not "bessre").
+
+  aDeg3 : (gut,besser,best : Str) -> AdjDeg ;
+
+-- In the completely regular case, the comparison forms are constructed by
+-- the endings "er" and "st".
+
+  aReg : Str -> AdjDeg ;    -- billig, billiger, billigst
+
+-- The past participle of a verb can be used as an adjective.
+
+  aPastPart : V -> Adj1 ;   -- gefangen
+
+-- On top level, there are adjectival phrases. The most common case is
+-- just to use a one-place adjective. The variation in $adjGen$ is taken
+-- into account.
+
+  apReg : Str -> AP ;
+
+
+--2 Verbs
+--
+-- The fragment only has present tense so far, but in all persons.
+-- It also has the infinitive and the past participles.
+-- The worst case macro needs four forms: : the infinitive and 
+-- the third person singular (where Umlaut may occur), the singular imperative,
+-- and the past participle.
+-- 
+-- The function recognizes if the stem ends with "s" or "t" and performs the
+-- appropriate contractions.
+
+  mkV : (_,_,_,_ : Str) -> V ;   -- geben, gibt, gib, gegeben
+
+-- Regular verbs are those where no Umlaut occurs.
+
+  vReg  : Str -> V ;         -- kommen
+
+-- The verbs 'be' and 'have' are special.
+
+  vSein  : V ;
+  vHaben : V ;
+
+-- Verbs with a detachable particle, with regular ones as a special case.
+
+  vPart    :  (_,_,_,_,_ : Str) -> V ;     -- sehen, sieht, sieh, gesehen, aus
+  vPartReg :  (_,_     : Str) -> V ;       -- bringen, um
+
+-- Two-place verbs, and the special case with direct object. Notice that
+-- a particle can be included in a $V$.
+
+  mkTV     : V   -> Str -> Case -> TV ;  -- hören, zu, dative
+
+  tvReg    : Str -> Str -> Case -> TV ;  -- hören, zu, dative
+  tvDir    : V -> TV ;                   -- umbringen
+  tvDirReg : Str -> TV ;                 -- lieben
+
+--2 Adverbials
+--
+-- Adverbials for modifying verbs, adjectives, and sentences can be formed 
+-- from strings.
+
+  mkAdV : Str -> AdV ;
+  mkAdA : Str -> AdA ;
+  mkAdS : Str -> AdS ;
+
+-- Prepositional phrases are another productive form of adverbials.
+
+  mkPP : Case -> Str -> NP -> AdV ;
+
+-- The definitions should not bother the user of the API. So they are
+-- hidden from the document.
+--.
+
+
+  masculine = Masc ;
+  feminine  = Fem ;
+  neuter = Neut ;
+  nominative = Nom ;
+  accusative = Acc ;
+  dative = Dat ;
+  genitive = Gen ;
+  -- singular defined in Types
+  -- plural defined in Types
+
+  mkN = mkNoun ;
+
+  nGen = \punkt, punktes, punkte, g -> let {
+      e   = Predef.dp 1 punkte ; 
+      eqy = ifTok (Gender -> N) e ;
+      noN = mkNoun4 punkt punktes punkte punkte
+    } in
+    eqy "n" noN (
+    eqy "s" noN (
+            mkNoun4 punkt punktes punkte (punkte+"n"))) g ;
+
+  nRaum = \raum, räume -> nGen raum (raum + "es") räume masculine ;
+  nTisch = \tisch -> 
+    mkNoun4 tisch (tisch + "es") (tisch + "e") (tisch +"en") masculine ;
+  nVater = \vater, väter -> nGen vater (vater + "s") väter masculine ;
+  nFehler = \fehler -> nVater fehler fehler ;
+
+  nSoldat = \soldat -> let {
+     e = Predef.dp 1 soldat ; 
+     soldaten = ifTok Tok e "e" (soldat + "n") (soldat + "en")
+    } in
+    mkN soldat soldaten soldaten soldaten soldaten soldaten masculine ;
+
+  nBuch = \buch, bücher -> nGen buch (buch + "es") bücher neuter ;
+  nMesser = \messer -> nGen messer (messer + "s") messer neuter ;
+  nAuto = \auto -> let {autos = auto + "s"} in 
+          mkNoun4 auto autos autos autos neuter ;
+
+  nHand = \hand, hände -> nGen hand hand hände feminine ;
+
+  nFrau = \frau -> let {
+     e = Predef.dp 1 frau ; 
+     frauen = ifTok Tok e "e" (frau + "n") (frau + "en")
+    } in
+    mkN frau frau frau frau frauen frauen feminine ;
+
+  mkFun = \n -> mkFunCN (n2n n) ;
+  funVon = \n -> funVonCN (n2n n) ;
+
+  mkPN = \karolus, karoli -> {s = table {Gen => karoli ; _ => karolus}} ;
+  pnReg = \horst -> 
+    mkPN horst (ifTok Tok (Predef.dp 1 horst) "s" horst (horst + "s")) ;
+
+  mkCN = UseN ;
+  mkNP = \x,y -> UsePN (mkPN x y) ;
+  npReg = \s -> UsePN (pnReg s) ;
+
+  mkFunCN = mkFunC ;
+  funVonCN = funVonC ;
+
+  mkAdj1 = mkAdjective ;
+  adjInvar = Morpho.adjInvar ;
+  adjGen = Morpho.adjGen ;
+  mkAdj2 = \a,p,c -> a ** {s2 = p ; c = c} ;
+
+  mkAdjDeg = mkAdjComp ;
+  aDeg3 = adjCompReg3 ;
+  aReg = adjCompReg ;
+  aPastPart = \v -> {s = table AForm {a => v.s ! VPart a}} ; 
+  apReg = \s -> AdjP1 (adjGen s) ;
+
+  mkV = \sehen, sieht, sieh, gesehen -> 
+    mkVerbSimple (mkVerbum sehen sieht sieh gesehen) ;
+  vReg = \s -> mkVerbSimple (regVerb s) ;
+  vSein = verbSein ;
+  vHaben = verbHaben ;
+  vPart = \sehen, sieht, sieh, gesehen, aus -> 
+    mkVerb (mkVerbum sehen sieht sieh gesehen) aus ;
+  vPartReg = \sehen, aus -> mkVerb (regVerb sehen) aus ;
+
+  mkTV = mkTransVerb ;
+  tvReg = \hören, zu, dat -> mkTV (vReg hören) zu dat ;
+  tvDir = \v -> mkTV v [] accusative ;
+  tvDirReg = \v -> tvReg v [] accusative ; 
+
+  mkAdV = ss ;
+  mkPP = prepPhrase ;
+  mkAdA = ss ;
+  mkAdS = ss ;
+} ;
diff --git a/grammars/resource/german/Predication.gf b/grammars/resource/german/Predication.gf
new file mode 100644
index 000000000..9c05cc69b
--- /dev/null
+++ b/grammars/resource/german/Predication.gf
@@ -0,0 +1,87 @@
+
+--1 A Small Predication Library
+--
+-- (c) Aarne Ranta 2003 under Gnu GPL.
+--
+-- This library is built on a language-independent API of
+-- resource grammars. It has a common part, the type signatures
+-- (defined here), and language-dependent parts. The user of
+-- the library should only have to look at the type signatures.
+
+resource Predication = open Deutsch in {
+
+-- We first define a set of predication patterns.
+
+oper
+  predV1 : V -> NP -> S ;             -- one-place verb: "John walks"
+  predV2 : TV -> NP -> NP -> S ;      -- two-place verb: "John loves Mary"
+  predVColl : V -> NP -> NP -> S ;    -- collective verb: "John and Mary fight"
+  predA1 : Adj1 -> NP -> S ;          -- one-place adjective: "John is old"
+  predA2 : Adj2 -> NP -> NP -> S ;    -- two-place adj: "John is married to Mary"
+  predAComp : AdjDeg -> NP -> NP -> S ; -- compar adj: "John is older than Mary"
+  predAColl : Adj1 -> NP -> NP -> S ; -- collective adj: "John and Mary are married"
+  predN1 : N -> NP -> S ;             -- one-place noun: "John is a man"
+  predN2 : Fun -> NP -> NP -> S ;     -- two-place noun: "John is a lover of Mary"
+  predNColl : N -> NP -> NP -> S ;    -- collective noun: "John and Mary are lovers"
+
+-- Individual-valued function applications.
+
+  appFun1 : Fun -> NP -> NP ;          -- one-place function: "the successor of x"
+  appFun2 : Fun -> NP -> NP -> NP ;    -- two-place function: "the line from x to y"
+  appFunColl : Fun -> NP -> NP -> NP ; -- collective function: "the sum of x and y"
+
+-- Families of types, expressed by common nouns depending on arguments.
+
+  appFam1 : Fun -> NP -> CN ;          -- one-place family: "divisor of x"
+  appFam2 : Fun -> NP -> NP -> CN ;    -- two-place family: "line from x to y"
+  appFamColl : Fun -> NP -> NP -> CN ; -- collective family: "path between x and y"
+
+-- Type constructor, similar to a family except that the argument is a type.
+
+  constrTyp1 : Fun -> CN -> CN ;
+
+-- Logical connectives on two sentences.
+
+  conjS : S -> S -> S ;
+  disjS : S -> S -> S ;
+  implS : S -> S -> S ;
+
+-- As an auxiliary, we need two-place conjunction of names ("John and Mary"), 
+-- used in collective predication.
+
+  conjNP : NP -> NP -> NP ;
+
+
+-----------------------------
+
+---- what follows should be an implementation of the preceding
+
+oper
+  predV1 = \F, x -> PredVP x (PosV F) ;
+  predV2 = \F, x, y -> PredVP x (PosTV F y) ;
+  predVColl = \F, x, y -> PredVP (conjNP x y) (PosV F) ;
+  predA1 = \F, x -> PredVP x (PosA F) ;
+  predA2 = \F, x, y -> PredVP x (PosA (ComplAdj F y)) ;
+  predAComp = \F, x, y -> PredVP x (PosA (ComparAdjP F y)) ;
+  predAColl = \F, x, y -> PredVP (conjNP x y) (PosA F) ;
+  predN1 = \F, x -> PredVP x (PosCN (UseN F)) ;
+  predN2 = \F, x, y -> PredVP x (PosCN (AppFun F y)) ;
+  predNColl = \F, x, y -> PredVP (conjNP x y) (PosCN (UseN F)) ;
+
+  appFun1 = \f, x -> DefOneNP (AppFun f x) ;
+  appFun2 = \f, x, y -> DefOneNP (AppFun (AppFun2 f x) y) ;
+  appFunColl = \f, x, y -> DefOneNP (AppFun f (conjNP x y)) ;
+
+  appFam1 = \F, x -> AppFun F x ;
+  appFam2 = \F, x, y -> AppFun (AppFun2 F x) y ;
+  appFamColl = \F, x, y -> AppFun F (conjNP x y) ;
+
+  conjS = \A, B -> ConjS AndConj (TwoS A B) ;
+  disjS = \A, B -> ConjS OrConj (TwoS A B) ;
+  implS = \A, B -> SubjS IfSubj A B ;
+
+  constrTyp1 = \F, A -> AppFun F (IndefManyNP A) ;
+
+  conjNP = \x, y -> ConjNP AndConj (TwoNP x y) ;
+
+} ;
diff --git a/grammars/resource/german/ResDeu.gf b/grammars/resource/german/ResDeu.gf
new file mode 100644
index 000000000..dd2b160b3
--- /dev/null
+++ b/grammars/resource/german/ResDeu.gf
@@ -0,0 +1,217 @@
+--1 The Top-Level German Resource Grammar
+--
+-- Aarne Ranta 2002 -- 2003
+--
+-- This is the German concrete syntax of the multilingual resource
+-- grammar. Most of the work is done in the file $syntax.Deu.gf$.
+-- However, for the purpose of documentation, we make here explicit the
+-- linearization types of each category, so that their structures and
+-- dependencies can be seen.
+-- Another substantial part are the linearization rules of some
+-- structural words.
+--
+-- The users of the resource grammar should not look at this file for the
+-- linearization rules, which are in fact hidden in the document version.
+-- They should use $resource.Abs.gf$ to access the syntactic rules.
+-- This file can be consulted in those, hopefully rare, occasions in which
+-- one has to know how the syntactic categories are
+-- implemented. The parameter types are defined in $Types.gf$.
+
+concrete ResDeu of ResAbs = open Prelude, Syntax in {
+
+flags 
+  startcat=Phr ; 
+  parser=chart ;
+
+lincat 
+  CN     = CommNounPhrase ; 
+      -- = {s : Adjf => Number => Case => Str ; g : Gender} ;
+  N      = CommNoun ;
+      -- = {s : Number => Case => Str ; g : Gender} ; 
+  NP     = NounPhrase ;
+      -- = {s : NPForm => Str ; n : Number ; p : Person ; pro : Bool} ;
+  PN     = ProperName ;
+      -- = {s : Case => Str} ;
+  Det    = {s : Gender => Case => Str ; n : Number ; a : Adjf} ;
+  Fun    = Function ;
+      -- = CommNounPhrase ** {s2 : Preposition ; c : Case} ;
+  Fun2   = Function ** {s3 : Preposition ; c2 : Case} ;
+
+  Adj1   = Adjective ;
+      -- = {s : AForm => Str} ;
+  Adj2   = Adjective ** {s2 : Preposition ; c : Case} ;
+  AdjDeg = {s : Degree => AForm => Str} ;
+  AP     = Adjective ** {p : Bool} ;
+
+  V      = Verb ; 
+      -- = {s : VForm => Str ; s2 : Particle} ;
+  VP     = Verb ** {s3 : Number => Str} ;
+  TV     = Verb ** {s3 : Preposition ; c : Case} ;
+  VS     = Verb ;
+  AdV    = {s : Str} ;
+
+  S      = Sentence ;
+      -- = {s : Order => Str} ; 
+  Slash  = Sentence ** {s2 : Preposition ; c : Case} ;
+
+  RP     = {s : GenNum => Case => Str} ;
+  RC     = {s : GenNum => Str} ;
+
+  IP     = ProperName ** {n : Number} ;
+  Qu     = {s : QuestForm => Str} ;
+  Imp    = {s : Number => Str} ;
+  Phr    = {s : Str} ;
+  Text   = {s : Str} ;
+
+  Conj   = {s : Str ; n : Number} ;
+  ConjD  = {s1,s2 : Str ; n : Number} ;
+
+  ListS  = {s1,s2 : Order => Str} ; 
+  ListAP = {s1,s2 : AForm => Str ; p : Bool} ;
+  ListNP = {s1,s2 : NPForm => Str ; n : Number ; p : Person ; pro : Bool} ;
+
+--.
+
+lin 
+  UseN = noun2CommNounPhrase ;
+  ModAdj = modCommNounPhrase ;
+  ModGenOne = npGenDet singular ;
+  ModGenMany = npGenDet plural ;
+  UsePN = nameNounPhrase ;
+  UseFun = funAsCommNounPhrase ;
+  AppFun = appFunComm ;
+  AppFun2 = appFun2 ;
+  AdjP1 = adj2adjPhrase ;
+  ComplAdj = complAdj ;
+  PositAdjP = positAdjPhrase ;
+  ComparAdjP = comparAdjPhrase ;
+  SuperlNP = superlNounPhrase ;
+
+  DetNP = detNounPhrase ;
+  IndefOneNP = indefNounPhrase singular ;
+  IndefManyNP = indefNounPhrase plural ;
+  DefOneNP = defNounPhrase singular ;
+  DefManyNP = defNounPhrase plural ;
+
+  CNthatS = nounThatSentence ;
+
+  PredVP = predVerbPhrase ;
+  PosV = predVerb True ;
+  NegV = predVerb False ;
+  PosA = predAdjective True ;
+  NegA = predAdjective False ;
+  PosCN = predCommNoun True ;
+  NegCN = predCommNoun False ;
+  PosTV = complTransVerb True ;
+  NegTV = complTransVerb False ;
+  PosPassV = passVerb True ;
+  NegPassV = passVerb False ;
+  PosNP = predNounPhrase True ;
+  NegNP = predNounPhrase False ;
+  PosVS = complSentVerb True ;
+  NegVS = complSentVerb False ;
+
+  AdvVP = adVerbPhrase ;
+  LocNP = locativeNounPhrase ;
+  AdvCN = advCommNounPhrase ;
+  AdvAP = advAdjPhrase ;
+
+  PosSlashTV = slashTransVerb True ;
+  NegSlashTV = slashTransVerb False ;
+  OneVP = predVerbPhrase (nameNounPhrase {s = \\_ => "man"}) ;
+
+  IdRP = identRelPron ;
+  FunRP = funRelPron ;
+  RelVP = relVerbPhrase ;
+  RelSlash = relSlash ;
+  ModRC = modRelClause ;
+  RelSuch = relSuch ;
+
+  WhoOne = intPronWho singular ;
+  WhoMany = intPronWho plural ;
+  WhatOne = intPronWhat singular ;
+  WhatMany = intPronWhat plural ;
+  FunIP = funIntPron ;
+  NounIPOne = nounIntPron singular ;
+  NounIPMany = nounIntPron plural ;
+
+  QuestVP = questVerbPhrase ;
+  IntVP = intVerbPhrase ;
+  IntSlash = intSlash ;
+  QuestAdv = questAdverbial ;
+
+  ImperVP = imperVerbPhrase ;
+
+  IndicPhrase = indicUtt ;
+  QuestPhrase = interrogUtt ;
+  ImperOne = imperUtterance singular ;
+  ImperMany = imperUtterance plural ;
+
+  AdvS = advSentence ;
+
+lin
+  TwoS = twoSentence ;
+  ConsS = consSentence ;
+  ConjS = conjunctSentence ;
+  ConjDS = conjunctDistrSentence ;
+
+  TwoAP = twoAdjPhrase ;
+  ConsAP = consAdjPhrase ;
+  ConjAP = conjunctAdjPhrase ;
+  ConjDAP = conjunctDistrAdjPhrase ;
+
+  TwoNP = twoNounPhrase ;
+  ConsNP = consNounPhrase ;
+  ConjNP = conjunctNounPhrase ;
+  ConjDNP = conjunctDistrNounPhrase ;
+
+  SubjS = subjunctSentence ;
+  SubjImper = subjunctImperative ;
+  SubjQu = subjunctQuestion ;
+
+  PhrNP = useNounPhrase ;
+  PhrOneCN = useCommonNounPhrase singular ;
+  PhrManyCN = useCommonNounPhrase plural ;
+  PhrIP ip = ip ;
+  PhrIAdv ia = ia ;
+
+  OnePhr p = p ;
+  ConsPhr = cc2 ;
+
+  INP    = pronNounPhrase pronIch ;
+  ThouNP = pronNounPhrase pronDu ;
+  HeNP   = pronNounPhrase pronEr ;
+  SheNP  = pronNounPhrase pronSie ; 
+  ItNP   = pronNounPhrase pronEs ; 
+  WeNP   = pronNounPhrase pronWir ;
+  YeNP   = pronNounPhrase pronIhr ;
+  TheyNP = pronNounPhrase pronSiePl ;
+
+  YouNP  = pronNounPhrase pronSSie ;
+
+  EveryDet = jederDet ; 
+  AllDet   = alleDet ; 
+  WhichDet = welcherDet ;
+  MostDet  = meistDet ;
+
+  HowIAdv   = ss "wie" ;
+  WhenIAdv  = ss "wann" ;
+  WhereIAdv = ss "war" ;
+  WhyIAdv   = ss "warum" ;
+
+  AndConj  = ss "und" ** {n = Pl} ;
+  OrConj   = ss "oder" ** {n = Sg} ;
+  BothAnd  = sd2 "sowohl" ["als auch"] ** {n = Pl} ;
+  EitherOr = sd2 "entweder" "oder" ** {n = Sg} ;
+  NeitherNor = sd2 "weder" "noch" ** {n = Sg} ;
+  IfSubj   = ss "wenn" ;
+  WhenSubj = ss "wenn" ;
+
+  PhrYes = ss ["Ja ."] ;
+  PhrNo = ss ["Nein ."] ;
+
+  VeryAdv = ss "sehr" ;
+  TooAdv = ss "zu" ;
+  OtherwiseAdv = ss "sonst" ;
+  ThereforeAdv = ss "deshalb" ;
+} ;
diff --git a/grammars/resource/german/RestaurantDeu.gf b/grammars/resource/german/RestaurantDeu.gf
new file mode 100644
index 000000000..3a6d6f8d6
--- /dev/null
+++ b/grammars/resource/german/RestaurantDeu.gf
@@ -0,0 +1,24 @@
+concrete RestaurantDeu of Restaurant = 
+  DatabaseDeu ** open Prelude,Paradigms,Deutsch,DatabaseRes in {
+
+lin 
+  Restaurant = UseN (nAuto "Restaurant") ;
+  Bar = UseN (nAuto "Bar") ; --- ??
+  French = apReg "Französisch" ;
+  Italian = apReg "Italienisch" ;
+  Indian = apReg "Indisch" ;
+  Japanese = apReg "Japanisch" ;
+
+  address = funVon (nFrau "Adresse") ;
+  phone = funVon (nFrau "Rufnummer") ; ----
+  priceLevel = funVon (nFrau "Preisstufe") ;
+
+  Cheap = aReg "billig" ;
+  Expensive = aDeg3 "teuer" "teurer" "teurest" ;
+
+  WhoRecommend rest = mkSentSame (ss2 ["wer empfiehlt"] (rest.s ! accusative)) ;
+  WhoHellRecommend rest = 
+    mkSentSame (ss2 ["wer zum Teufel empfiehlt"] (rest.s ! accusative)) ;
+
+  LucasCarton = mkPN ["Lucas Carton"] ["Lucas Cartons"] ;
+} ;
diff --git a/grammars/resource/german/Syntax.gf b/grammars/resource/german/Syntax.gf
new file mode 100644
index 000000000..904cd1903
--- /dev/null
+++ b/grammars/resource/german/Syntax.gf
@@ -0,0 +1,891 @@
+--1 A Small German Resource Syntax
+--
+-- Aarne Ranta 2002
+--
+-- This resource grammar contains definitions needed to construct 
+-- indicative, interrogative, and imperative sentences in German.
+--
+-- The following modules are presupposed:
+
+resource Syntax = Morpho ** open Prelude, (CO = Coordination) in {
+
+--2 Common Nouns
+--
+-- Simple common nouns are defined as the type $CommNoun$ in $morpho.Deu.gf$.
+
+--3 Common noun phrases
+
+-- The need for this more complex type comes from the variation in the way in
+-- which a modifying adjective is inflected after different determiners.
+-- We use the $Adjf$ parameter for this ($Strong$/$Weak$).
+
+oper
+
+  CommNounPhrase : Type = {s : Adjf => Number => Case => Str ; g : Gender} ;
+
+  noun2CommNounPhrase : CommNoun -> CommNounPhrase = \haus ->
+    {s = \\_ => haus.s ; g = haus.g} ;
+
+  n2n = noun2CommNounPhrase ;
+
+
+
+--2 Noun phrases
+--
+-- The worst case is pronouns, which have inflection in the possessive
+-- forms. Other noun phrases express all possessive forms with the genitive case.
+-- The parameter $pro$ tells if the $NP$ is a pronoun, which is needed in e.g.
+-- genitive constructions.
+
+  NounPhrase : Type = {
+    s : NPForm => Str ; 
+    n : Number ; 
+    p : Person ; 
+    pro : Bool
+    } ;
+
+  pronNounPhrase : ProPN -> NounPhrase = \ich -> 
+    ich ** {pro = True} ;
+
+  caseNP : NPForm -> Case = \np -> case np of {
+    NPCase c   => c ;
+    NPPoss _ _ => Gen
+    } ;
+
+  normalNounPhrase : (Case => Str) -> Number -> NounPhrase = \cs,n ->
+    {s = \\c => cs ! caseNP c ;
+     n = n ;
+     p = P3 ;    -- third person
+     pro = False -- not a pronoun
+    } ;
+
+-- Proper names are a simple kind of noun phrases. They can usually
+-- be constructed from strings in a regular way.
+
+  ProperName : Type = {s : Case => Str} ;
+
+  nameNounPhrase : ProperName -> NounPhrase = \john -> 
+    {s = \\np => john.s ! caseNP np ; n = Sg ; p = P3 ; pro = False} ;
+
+  mkProperName : Str -> ProperName = \horst ->
+    {s = table {Gen => horst + "s" ; _ => horst}} ;
+
+--2 Determiners
+--
+-- Determiners are inflected according to the nouns they determine.
+-- The determiner determines the number and adjectival form from the determiner.
+
+  Determiner : Type = {s : Gender => Case => Str ; n : Number ; a : Adjf} ;
+
+  detNounPhrase : Determiner -> CommNounPhrase -> NounPhrase = \ein, mann -> 
+    {s = \\c => let {nc = caseNP c} in 
+            ein.s ! mann.g ! nc ++ mann.s ! adjfCas ein.a nc ! ein.n ! nc ;
+     p = P3 ; 
+     n = ein.n ;
+     pro = False
+     } ;
+
+-- The adjectival form after a determiner depends both on the inferent form
+-- and on the case ("ein alter Mann" but "einem alten Mann").
+
+  adjfCas : Adjf -> Case -> Adjf = \a,c -> case <a,c> of {
+    <Strong,Nom> => Strong ;
+    <Strong,Acc> => Strong ;
+    _ => Weak
+    } ;
+
+-- The following macros are sufficient to define most determiners,
+-- as shown by the examples that follow.
+
+  DetSg = Gender => Case => Str ;
+  DetPl = Case => Str ;
+
+  mkDeterminerSg :  DetSg -> Adjf -> Determiner = \ein, a -> 
+    {s = ein ; n = Sg ; a = a} ;
+
+  mkDeterminerPl :  DetPl -> Adjf -> Determiner = \alle, a -> 
+    {s = \\_ => alle ; n = Pl ; a = a} ;
+
+  detLikeAdj : Str -> Determiner = \jed -> mkDeterminerSg
+    (\\g,c => (adjReg jed).s ! AMod Strong (GSg g) c) Weak ;
+
+  jederDet = detLikeAdj "jed" ;
+  alleDet = mkDeterminerPl (caselist "alle" "alle" "allen" "aller") Weak ;
+  einDet = mkDeterminerSg artIndef Strong ;
+  derDet = mkDeterminerSg (table {g => artDef ! GSg g}) Weak ;
+  dieDet = mkDeterminerPl (artDef ! GPl) Weak ;
+
+  meistDet = mkDeterminerPl (table {c => artDef ! GPl ! c ++ "meisten"}) Weak ;
+  welcherDet = detLikeAdj "welch" ;
+  welcheDet = mkDeterminerPl (caselist "welche" "welche" "welchen" "welcher") Weak ;
+
+-- Choose "welcher"/"welche"
+
+  welchDet : Number -> Determiner = \n -> 
+    case n of {Sg => welcherDet ; Pl => welcheDet} ;
+
+-- Genitives of noun phrases can be used like determiners, to build noun phrases.
+-- The number argument makes the difference between "mein Haus" - "meine Häuser".
+--
+-- If the 'owner' is a pronoun, only one form is available "mein Haus".
+-- In other cases, two variants are available: "Johanns Haus" / "das Haus Johanns".
+
+  npGenDet : Number -> NounPhrase -> CommNounPhrase -> NounPhrase = \n,haus,Wein -> 
+   let {
+     hauses  : Case   => Str = \\c => haus.s ! NPPoss (gNumber Wein.g n) c ;
+     wein    : NPForm => Str = \\c => Wein.s ! Strong ! n ! caseNP c ;
+     derwein : NPForm => Str = (defNounPhrase n Wein).s
+     }
+   in
+    {s = \\c => variants {
+                  hauses ! caseNP c ++ wein ! c ;
+                  if_then_else Str haus.pro
+                    nonExist 
+                    (derwein ! c ++ hauses ! Nom) -- the case does not matter
+                  } ;
+     p = P3 ;
+     n = n ;
+     pro = False
+     } ;
+
+-- *Bare plural noun phrases* like "Männer", "gute Häuser", are built without a 
+-- determiner word.
+
+  plurDet : CommNounPhrase -> NounPhrase = \cn -> 
+    normalNounPhrase (cn.s ! Strong ! Pl) Pl ;
+
+-- Macros for indef/def Sg/Pl noun phrases are needed in many places even
+-- if they might not be constituents.
+
+  indefNounPhrase : Number -> CommNounPhrase -> NounPhrase = \n,haus -> case n of {
+    Sg => detNounPhrase einDet haus ;
+    Pl => plurDet haus
+    } ;
+
+  defNounPhrase : Number -> CommNounPhrase -> NounPhrase = \n,haus -> case n of {
+    Sg => detNounPhrase derDet haus ;
+    Pl => detNounPhrase dieDet haus
+    } ;
+
+  indefNoun : Number -> CommNounPhrase -> Str = \n, mann -> case n of {
+    Sg => (detNounPhrase einDet mann).s ! NPCase Nom ; 
+    Pl => (plurDet mann).s ! NPCase Nom
+    } ;
+
+-- Constructions like "die Idee, dass zwei gerade ist" are formed at the
+-- first place as common nouns, so that one can also have "ein Vorschlag, dass...".
+
+  nounThatSentence : CommNounPhrase -> Sentence -> CommNounPhrase = \idee,x -> 
+    {s = \\a,n,c => idee.s ! a! n ! c ++ [", dass"] ++ x.s ! Sub ; 
+     g = idee.g
+    } ;
+
+--2 Adjectives
+--
+-- Adjectival phrases have a parameter $p$ telling if postposition is 
+-- allowed (complex APs). 
+
+  AdjPhrase : Type = Adjective ** {p : Bool} ;
+
+  adj2adjPhrase : Adjective -> AdjPhrase = \ny -> ny ** {p = False} ;
+
+--3 Comparison adjectives
+--
+-- The type is defined in $types.Deu.gf$.
+
+  AdjDegr : Type = AdjComp ;
+
+-- Each of the comparison forms has a characteristic use:
+--
+-- Positive forms are used alone, as adjectival phrases ("jung").
+
+  positAdjPhrase : AdjDegr -> AdjPhrase = \jung ->
+    {s = jung.s ! Pos ; p = False} ;
+
+-- Comparative forms are used with an object of comparison, as
+-- adjectival phrases ("besser als Rolf").
+
+  comparAdjPhrase : AdjDegr -> NounPhrase -> AdjPhrase = \besser,rolf ->
+    {s = \\a => besser.s ! Comp ! a ++ "als" ++ rolf.s ! NPCase Nom ;
+     p = True
+    } ;
+
+-- Superlative forms are used with a common noun, picking out the
+-- maximal representative of a domain ("der Jüngste Mann").
+
+  superlNounPhrase : AdjDegr -> CommNounPhrase -> NounPhrase = \best,mann ->
+    let {gen = mann.g} in
+    {s = \\c => let {nc = caseNP c} in
+                artDef ! gNumber gen Sg ! nc ++ 
+                best.s ! Sup ! aMod Weak gen Sg nc ++
+                mann.s ! Weak ! Sg ! nc ; 
+     p = P3 ; 
+     n = Sg ;
+     pro = False
+    } ;
+
+--3 Two-place adjectives
+--
+-- A two-place adjective is an adjective with a preposition used before
+-- the complement, and the complement case.
+
+  AdjCompl = Adjective ** {s2 : Preposition ; c : Case} ;
+
+  complAdj : AdjCompl -> NounPhrase -> AdjPhrase = \verwandt,dich ->
+    {s = \\a => 
+            bothWays (verwandt.s ! a) (verwandt.s2 ++ dich.s ! NPCase verwandt.c) ;
+     p = True
+    } ;
+
+--3 Modification of common nouns
+--
+-- The two main functions of adjective are in predication ("Johann ist jung")
+-- and in modification ("ein junger Mann"). Predication will be defined
+-- later, in the chapter on verbs.
+--
+-- Modification must pay attention to pre- and post-noun
+-- adjectives: "gutes Haus"; "besseres als X haus" / "haus besseres als X"
+
+  modCommNounPhrase : AdjPhrase -> CommNounPhrase -> CommNounPhrase = \gut,haus ->
+    {s = \\a,n,c => let {
+             gutes = gut.s ! aMod a haus.g n c ; 
+             Haus  = haus.s ! a ! n ! c
+             } in
+           if_then_else Str gut.p (bothWays gutes Haus) (gutes ++ Haus) ;
+     g = haus.g} ;
+
+--2 Function expressions
+
+-- A function expression is a common noun together with the
+-- preposition prefixed to its argument ("Mutter von x").
+-- The type is analogous to two-place adjectives and transitive verbs.
+
+  Function = CommNounPhrase ** {s2 : Preposition ; c : Case} ;
+
+-- The application of a function gives, in the first place, a common noun:
+-- "Mutter/Mütter von Johann". From this, other rules of the resource grammar 
+-- give noun phrases, such as "die Mutter von Johann", "die Mütter von Johann",
+-- "die Mütter von Johann und Maria", and "die Mutter von Johann und Maria" (the
+-- latter two corresponding to distributive and collective functions,
+-- respectively). Semantics will eventually tell when each
+-- of the readings is meaningful.
+
+  appFunComm : Function -> NounPhrase -> CommNounPhrase = \mutter,uwe -> 
+      {s = \\a,n,c => mutter.s ! a ! n ! c ++ mutter.s2 ++ uwe.s ! NPCase mutter.c ;
+       g = mutter.g
+      } ;
+
+-- It is possible to use a function word as a common noun; the semantics is
+-- often existential or indexical.
+
+  funAsCommNounPhrase : Function -> CommNounPhrase = \x -> x ; 
+
+-- The following is an aggregate corresponding to the original function application
+-- producing "Johanns Mutter" and "die Mutter von Johann". It does not appear in the
+-- resource grammar API any longer.
+
+  appFun : Bool -> Function -> NounPhrase -> NounPhrase = \coll, mutter, uwe ->
+    let {n = uwe.n ; g = mutter.g ; nf = if_then_else Number coll Sg n} in 
+    variants {
+      defNounPhrase nf (appFunComm mutter uwe) ;
+      npGenDet nf uwe mutter
+      } ;
+
+-- The commonest cases are functions with "von" and functions with Genitive.
+
+  mkFunC : CommNounPhrase -> Preposition -> Case -> Function = \f,p,c ->
+    f ** {s2 = p ; c = c} ;
+
+  funVonC : CommNounPhrase -> Function = \wert -> 
+    mkFunC wert "von" Dat ;
+
+  funGenC : CommNounPhrase -> Function = \wert -> 
+    mkFunC wert [] Gen ;
+
+-- Two-place functions add one argument place.
+
+  Function2 = Function ** {s3 : Preposition ; c2 : Case} ;
+
+-- There application starts by filling the first place.
+
+  appFun2 : Function2 -> NounPhrase -> Function = \flug, paris ->
+    {s  = \\a,n,c => flug.s ! a ! n ! c ++ flug.s2 ++ paris.s ! NPCase flug.c ;
+     g  = flug.g ;
+     s2 = flug.s3 ;
+     c  = flug.c2
+    } ;
+
+
+--2 Verbs
+--
+--3 Verb phrases
+--
+-- Verb phrases are discontinuous: the parts of a verb phrase are
+-- (s) an inflected verb, (s2) particle, and 
+-- (s3) negation and complement. This discontinuity is needed in sentence formation
+-- to account for word order variations.
+
+  VerbPhrase = Verb ** {s3 : Number => Str} ; 
+
+-- A simple verb can be made into a verb phrase with an empty complement.
+-- There are two versions, depending on if we want to negate the verb.
+-- N.B. negation is *not* a function applicable to a verb phrase, since
+-- double negations with "nicht" are not grammatical.
+
+  predVerb : Bool -> Verb -> VerbPhrase = \b,aussehen -> 
+    aussehen ** {
+     s3 = \\_ => negation b
+     } ;
+
+  negation : Bool -> Str = \b -> if_then_else Str b [] "nicht" ;
+
+-- Sometimes we want to extract the verb part of a verb phrase.
+
+  verbOfPhrase : VerbPhrase -> Verb = \v -> {s = v.s ; s2 = v.s2} ;
+
+-- Verb phrases can also be formed from adjectives ("ist gut"),
+-- common nouns ("ist ein Mann"), and noun phrases ("ist der jüngste Mann").
+-- The third rule is overgenerating: "ist jeder Mann" has to be ruled out
+-- on semantic grounds.
+
+  predAdjective : Bool -> Adjective -> VerbPhrase = \b,gut ->
+    verbSein ** {
+      s3 = \\_ => negation b ++ gut.s ! APred
+      } ;
+
+  predCommNoun : Bool -> CommNounPhrase -> VerbPhrase = \b,man ->
+    verbSein ** {
+      s3 = \\n => negation b ++ indefNoun n man
+     } ;
+
+  predNounPhrase : Bool -> NounPhrase -> VerbPhrase = \b,dermann ->
+    verbSein ** {
+      s3 = \\n => negation b ++ dermann.s ! NPCase Nom
+     } ;
+
+--3 Transitive verbs
+--
+-- Transitive verbs are verbs with a preposition for the complement,
+-- in analogy with two-place adjectives and functions.
+-- One might prefer to use the term "2-place verb", since
+-- "transitive" traditionally means that the inherent preposition is empty.
+-- Such a verb is one with a *direct object* - which may still be accusative,
+-- dative, or genitive.
+
+  TransVerb = Verb ** {s3 : Preposition ; c : Case} ; 
+
+  mkTransVerb : Verb -> Preposition -> Case -> TransVerb =
+    \v,p,c -> v ** {s3 = p ; c = c} ;
+
+-- The rule for using transitive verbs is the complementization rule:
+
+  complTransVerb : Bool -> TransVerb -> NounPhrase -> VerbPhrase = 
+    \b,warten,dich ->
+    let {
+      aufdich = warten.s3 ++ dich.s ! NPCase warten.c ;
+      nicht = negation b
+      } in
+    {s  = warten.s ; 
+     s2 = warten.s2 ; 
+     s3 = \\_ => bothWays aufdich nicht
+    } ;
+
+-- Transitive verbs with accusative objects can be used passively. 
+-- The function does not check that the verb is transitive.
+-- Therefore, the function can also be used for "es wird gelaufen", etc.
+
+  passVerb : Bool -> Verb -> VerbPhrase = \b,lieben ->
+    {s  = verbumWerden ; 
+     s2 = [] ; 
+     s3 = \\_ => negation b ++ lieben.s ! VPart APred
+    } ;
+
+
+--2 Adverbials
+--
+-- Adverbials are not inflected (we ignore comparison, and treat
+-- compared adverbials as separate expressions; this could be done another way).
+
+  Adverb : Type = SS ;
+
+  mkAdverb : Str -> Adverb = ss ;
+
+  adVerbPhrase : VerbPhrase -> Adverb -> VerbPhrase = \spielt, gut ->
+    {s  = spielt.s ; 
+     s2 = spielt.s2 ;
+     s3 = \\n => spielt.s3 ! n ++ gut.s 
+    } ;
+
+  advAdjPhrase : Adverb -> AdjPhrase -> AdjPhrase = \sehr, gut ->
+    {s = \\a => sehr.s ++ gut.s ! a ;
+     p = gut.p
+    } ;
+
+-- Adverbials are typically generated by prefixing prepositions.
+-- The rule for creating locative noun phrases by the preposition "in"
+-- is a little shaky, since other prepositions may be preferred ("an", "auf").
+
+  prepPhrase : Case -> Preposition -> NounPhrase -> Adverb = \c,auf,ihm ->
+    ss (auf ++ ihm.s ! NPCase c) ;
+ 
+  locativeNounPhrase : NounPhrase -> Adverb = 
+    prepPhrase Dat "in" ;
+
+-- This is a source of the "Mann mit einem Teleskop" ambiguity, and may produce
+-- strange things, like "Autos immer" (while "Autos heute" is OK).
+-- Semantics will have to make finer distinctions among adverbials.
+
+  advCommNounPhrase : CommNounPhrase -> Adverb -> CommNounPhrase = \haus,heute ->
+    {s = \\a, n, c => haus.s ! a ! n ! c ++ heute.s ;
+     g = haus.g} ;    
+
+
+
+--2 Sentences
+--
+-- Sentences depend on a *word order parameter* selecting between main clause,
+-- inverted, and subordinate clause.
+
+  Sentence : Type = SS1 Order ;
+
+-- This is the traditional $S -> NP VP$ rule. It takes care of both
+-- word order and agreement.
+
+  predVerbPhrase : NounPhrase -> VerbPhrase -> Sentence = 
+    \Ich,LiebeDichNichtAus -> 
+    let {
+      ich   = Ich.s ! NPCase Nom ; 
+      liebe = LiebeDichNichtAus.s ! VInd Ich.n Ich.p ;
+      aus   = LiebeDichNichtAus.s2 ;
+      dichnichtgut = LiebeDichNichtAus.s3 ! Ich.n
+    } in
+    {s = table {
+       Main => ich ++ liebe ++ dichnichtgut ++ aus ;
+       Inv  => liebe ++ ich ++ dichnichtgut ++ aus ;
+       Sub  => ich ++ dichnichtgut ++ aus ++ liebe
+       }
+    } ;
+
+--3 Sentence-complement verbs
+--
+-- Sentence-complement verbs take sentences as complements.
+
+  SentenceVerb : Type = Verb ;
+
+  complSentVerb : Bool -> SentenceVerb -> Sentence -> VerbPhrase = \b,sage,duisst ->
+    sage **
+    {s3 = \\_ => negation b ++ "," ++ "dass" ++ duisst.s ! Sub} ;
+
+
+--2 Sentences missing noun phrases
+--
+-- This is one instance of Gazdar's *slash categories*, corresponding to his
+-- $S/NP$.
+-- We cannot have - nor would we want to have - a productive slash-category former.
+-- Perhaps a handful more will be needed.
+--
+-- Notice that the slash category has the same relation to sentences as
+-- transitive verbs have to verbs: it's like a *sentence taking a complement*.
+
+  SentenceSlashNounPhrase : Type = Sentence ** {s2 : Preposition ; c : Case} ;
+
+  slashTransVerb : Bool -> NounPhrase -> TransVerb -> SentenceSlashNounPhrase = 
+    \b, Ich, sehen -> 
+    let {
+      ich   = Ich.s ! NPCase Nom ; 
+      sehe  = sehen.s ! VInd Ich.n P3 ;
+      aus   = sehen.s2 ;
+      nicht = negation b
+    } in
+    {s = table {
+       Main => ich ++ sehe ++ nicht ++ aus ;  
+       Inv  => sehe ++ ich ++ nicht ++ aus ;
+       Sub  => ich ++ nicht ++ aus ++ sehe
+       } ;
+     s2 = sehen.s3 ; 
+     c = sehen.c
+    } ;
+
+--2 Relative pronouns and relative clauses
+--
+-- Relative pronouns are inflected in
+-- gender, number, and case just like adjectives.
+
+oper
+  identRelPron : RelPron = relPron ;
+
+  funRelPron : Function -> RelPron -> RelPron = \wert, der -> 
+    {s = \\gn,c => let {nu = numGenNum gn} in
+           artDef ! gNumber wert.g nu ! c ++ wert.s ! Weak ! nu ! c ++  
+           wert.s2 ++ der.s ! gn ! wert.c
+    } ;
+
+-- Relative clauses can be formed from both verb phrases ("der schläft") and
+-- slash expressions ("den ich sehe", "auf dem ich sitze"). 
+
+  RelClause : Type = {s : GenNum => Str} ;
+
+  relVerbPhrase : RelPron -> VerbPhrase -> RelClause = \der, geht ->
+    {s = \\gn => (predVerbPhrase (normalNounPhrase (der.s ! gn) (numGenNum gn))
+                                 geht
+                 ).s ! Sub
+    } ;
+
+  relSlash : RelPron -> SentenceSlashNounPhrase -> RelClause = \den, ichSehe ->
+    {s = \\gn => ichSehe.s2 ++ den.s ! gn ! ichSehe.c ++ ichSehe.s ! Sub
+    } ;
+
+-- A 'degenerate' relative clause is the one often used in mathematics, e.g.
+-- "Zahl x derart, dass x gerade ist".
+
+  relSuch : Sentence -> RelClause = \A ->
+    {s = \\_ => "derart" ++ "dass" ++ A.s ! Sub} ;
+
+-- The main use of relative clauses is to modify common nouns.
+-- The result is a common noun, out of which noun phrases can be formed
+-- by determiners. A comma is used before the relative clause.
+
+  modRelClause : CommNounPhrase -> RelClause -> CommNounPhrase = \mann,dergeht ->
+    {s = \\a,n,c => mann.s ! a ! n ! c ++ "," ++ dergeht.s ! gNumber mann.g n ;
+     g = mann.g
+    } ;
+
+
+--2 Interrogative pronouns
+--
+-- If relative pronouns are adjective-like, interrogative pronouns are
+-- noun-phrase-like. We use a simplified type, since we don't need the possessive
+-- forms.
+
+  IntPron : Type = ProperName ** {n : Number} ; 
+
+-- In analogy with relative pronouns, we have a rule for applying a function
+-- to a relative pronoun to create a new one. 
+
+  funIntPron : Function -> IntPron -> IntPron = \wert, wer ->
+    let {n = wer.n} in 
+    {s = \\c => 
+           artDef ! gNumber wert.g n ! c ++ wert.s ! Weak ! n ! c ++  
+           wert.s2 ++ wer.s ! wert.c ;
+     n = n
+    } ;
+
+-- There is a variety of simple interrogative pronouns:
+-- "welches Haus", "wer", "was".
+
+  nounIntPron : Number -> CommNounPhrase -> IntPron = \n,cn ->
+    let {np = detNounPhrase (welchDet n) cn} in
+      {s = \\c => np.s ! NPCase c ;
+       n = np.n} ;
+
+  intPronWho : Number -> IntPron = \num -> {
+    s = caselist "wer" "wen" "wem" "weren" ;
+    n = num
+  } ;
+
+  intPronWhat : Number -> IntPron = \num -> {
+    s = caselist "was" "was" nonExist nonExist ; ---
+    n = num
+  } ;
+
+
+
+--2 Utterances
+
+-- By utterances we mean whole phrases, such as 
+-- 'can be used as moves in a language game': indicatives, questions, imperative,
+-- and one-word utterances. The rules are far from complete.
+--
+-- N.B. we have not included rules for texts, which we find we cannot say much
+-- about on this level. In semantically rich GF grammars, texts, dialogues, etc, 
+-- will of course play an important role as categories not reducible to utterances.
+-- An example is proof texts, whose semantics show a dependence between premises
+-- and conclusions. Another example is intersentential anaphora.
+
+  Utterance = SS ;
+  
+  indicUtt : Sentence -> Utterance = \x -> ss (x.s ! Main ++ ".") ;
+  interrogUtt : Question -> Utterance = \x -> ss (x.s ! DirQ ++ "?") ;
+
+
+--2 Questions
+--
+-- Questions are either direct ("bist du müde") or indirect 
+-- ("ob du müde bist").
+
+param 
+  QuestForm = DirQ | IndirQ ;
+
+oper
+  Question = SS1 QuestForm ;
+
+--3 Yes-no questions 
+--
+-- Yes-no questions are used both independently ("bist du müde")
+-- and after interrogative adverbials ("warum bist du müde").
+-- It is economical to handle with these two cases by the one
+-- rule, $questVerbPhrase'$. The only difference is if "ob" appears
+-- in the indirect form.
+
+  questVerbPhrase : NounPhrase -> VerbPhrase -> Question = 
+    questVerbPhrase' False ;
+
+  questVerbPhrase' : Bool -> NounPhrase -> VerbPhrase -> Question = 
+    \adv, du,gehst ->
+    let {dugehst = (predVerbPhrase du gehst).s} in
+    {s = table {
+      DirQ   => dugehst ! Inv ;
+      IndirQ => (if_then_else Str adv [] "ob") ++ dugehst ! Sub
+      }
+    } ;
+
+
+--3 Wh-questions
+--
+-- Wh-questions are of two kinds: ones that are like $NP - VP$ sentences,
+-- others that are line $S/NP - NP$ sentences.
+
+  intVerbPhrase : IntPron -> VerbPhrase -> Question = \Wer,geht ->
+    let {wer : NounPhrase = normalNounPhrase Wer.s Wer.n ;
+         wergeht : Sentence = predVerbPhrase wer geht
+        } in
+    {s = table {
+      DirQ   => wergeht.s ! Main ;
+      IndirQ => wergeht.s ! Sub 
+      }
+    } ;
+
+  intSlash : IntPron -> SentenceSlashNounPhrase -> Question = \wer, ichSehe ->
+    let {zuwen = ichSehe.s2 ++ wer.s ! ichSehe.c} in
+    {s = table {
+      DirQ   => zuwen ++ ichSehe.s ! Inv ;
+      IndirQ => zuwen ++ ichSehe.s ! Sub
+      } 
+    } ;
+
+
+--3 Interrogative adverbials
+--
+-- These adverbials will be defined in the lexicon: they include
+-- "wann", "war", "wie", "warum", etc, which are all invariant one-word
+-- expressions. In addition, they can be formed by adding prepositions
+-- to interrogative pronouns, in the same way as adverbials are formed
+-- from noun phrases. 
+
+  IntAdverb = SS ;
+
+  prepIntAdverb : Case -> Preposition -> IntPron -> IntAdverb =\ c,auf,wem ->
+    ss (auf ++ wem.s ! c) ;
+
+-- A question adverbial can be applied to anything, and whether this makes
+-- sense is a semantic question.
+
+  questAdverbial : IntAdverb -> NounPhrase -> VerbPhrase -> Question = 
+    \wie, du, tust ->
+    {s = \\q => wie.s ++ (questVerbPhrase du tust).s ! q} ;
+
+
+--2 Imperatives
+--
+-- We only consider second-person imperatives. No polite "Sie" form so far.
+
+  Imperative = SS1 Number ;
+
+  imperVerbPhrase : VerbPhrase -> Imperative = \komm -> 
+    {s = \\n => komm.s ! VImp n ++ komm.s3 ! n ++ komm.s2} ;  
+
+  imperUtterance : Number -> Imperative -> Utterance = \n,I ->
+    ss (I.s ! n ++ "!") ;
+
+--2 Sentence adverbials
+--
+-- This class covers adverbials such as "sonst", "folgelich", which are prefixed
+-- to a sentence to form a phrase; the sentence gets inverted word order.
+
+  advSentence : Adverb -> Sentence -> Utterance = \sonst,ist1gerade ->
+    ss (sonst.s ++ ist1gerade.s ! Inv ++ ".") ;
+
+--2 Coordination
+--
+-- Coordination is to some extent orthogonal to the rest of syntax, and
+-- has been treated in a generic way in the module $CO$ in the file
+-- $coordination.gf$. The overall structure is independent of category,
+-- but there can be differences in parameter dependencies.
+--
+--3 Conjunctions
+--
+-- Coordinated phrases are built by using conjunctions, which are either
+-- simple ("und", "oder") or distributed ("sowohl - als auch", "entweder - oder").
+--
+-- The conjunction has an inherent number, which is used when conjoining
+-- noun phrases: "John und Mary sind..." vs. "John oder Mary ist..."; in the
+-- case of "oder", the result is however plural if any of the disjuncts is.
+
+  Conjunction = CO.Conjunction ** {n : Number} ;
+  ConjunctionDistr = CO.ConjunctionDistr ** {n : Number} ;
+
+
+--3 Coordinating sentences
+--
+-- We need a category of lists of sentences. It is a discontinuous
+-- category, the parts corresponding to 'init' and 'last' segments
+-- (rather than 'head' and 'tail', because we have to keep track of the slot between
+-- the last two elements of the list). A list has at least two elements.
+
+  ListSentence : Type = {s1,s2 : Order => Str} ; 
+
+  twoSentence : (_,_ : Sentence) -> ListSentence = 
+    CO.twoTable Order ;
+
+  consSentence : ListSentence -> Sentence -> ListSentence = 
+    CO.consTable Order CO.comma ;
+
+-- To coordinate a list of sentences by a simple conjunction, we place
+-- it between the last two elements; commas are put in the other slots,
+-- e.g. "du rauchst, er trinkt und ich esse".
+
+  conjunctSentence : Conjunction -> ListSentence -> Sentence = 
+    CO.conjunctTable Order ;
+
+-- To coordinate a list of sentences by a distributed conjunction, we place
+-- the first part (e.g. "entweder") in front of the first element, the second
+-- part ("oder") between the last two elements, and commas in the other slots.
+-- For sentences this is really not used.
+
+  conjunctDistrSentence : ConjunctionDistr -> ListSentence -> Sentence = 
+    CO.conjunctDistrTable Order ;
+
+--3 Coordinating adjective phrases
+--
+-- The structure is the same as for sentences. The result is a prefix adjective
+-- if and only if all elements are prefix.
+
+  ListAdjPhrase : Type = 
+    {s1,s2 : AForm => Str ; p : Bool} ;
+
+  twoAdjPhrase : (_,_ : AdjPhrase) -> ListAdjPhrase = \x,y ->
+    CO.twoTable AForm x y ** {p = andB x.p y.p} ;
+  consAdjPhrase : ListAdjPhrase -> AdjPhrase -> ListAdjPhrase =  \xs,x ->
+    CO.consTable AForm CO.comma xs x ** {p = andB xs.p x.p} ;
+
+  conjunctAdjPhrase : Conjunction -> ListAdjPhrase -> AdjPhrase = \c,xs ->
+    CO.conjunctTable AForm c xs ** {p = xs.p} ;
+
+  conjunctDistrAdjPhrase : ConjunctionDistr -> ListAdjPhrase -> AdjPhrase = \c,xs ->
+    CO.conjunctDistrTable AForm c xs ** {p = xs.p} ;
+
+
+
+--3 Coordinating noun phrases
+--
+-- The structure is the same as for sentences. The result is either always plural
+-- or plural if any of the components is, depending on the conjunction.
+-- The result is a pronoun if all components are.
+
+  ListNounPhrase : Type = 
+    {s1,s2 : NPForm => Str ; n : Number ; p : Person ; pro : Bool} ;
+
+  twoNounPhrase : (_,_ : NounPhrase) -> ListNounPhrase = \x,y ->
+    CO.twoTable NPForm x y ** 
+    {n = conjNumber x.n y.n ; p = conjPerson x.p y.p ; pro = andB x.pro y.pro} ;
+
+  consNounPhrase : ListNounPhrase -> NounPhrase -> ListNounPhrase =  \xs,x ->
+    CO.consTable NPForm CO.comma xs x ** 
+    {n = conjNumber xs.n x.n ; p = conjPerson xs.p x.p ; pro = andB xs.pro x.pro} ;
+
+  conjunctNounPhrase : Conjunction -> ListNounPhrase -> NounPhrase = \c,xs ->
+    CO.conjunctTable NPForm c xs ** 
+    {n = conjNumber c.n xs.n ; p = xs.p ; pro = xs.pro} ;
+
+  conjunctDistrNounPhrase : ConjunctionDistr -> ListNounPhrase -> NounPhrase = 
+    \c,xs ->
+    CO.conjunctDistrTable NPForm c xs ** 
+    {n = conjNumber c.n xs.n ; p = xs.p ; pro = xs.pro} ;
+
+-- We have to define a calculus of numbers of persons. For numbers,
+-- it is like the conjunction with $Pl$ corresponding to $False$.
+
+  conjNumber : Number -> Number -> Number = \m,n -> case <m,n> of {
+    <Sg,Sg> => Sg ;
+    _ => Pl 
+    } ;
+
+-- For persons, we go in the descending order:
+-- "ich und dich sind stark", "er oder du bist stark".
+-- This is not always quite clear.
+
+  conjPerson : Person -> Person -> Person = \p,q -> case <p,q> of {
+    <P3,P3> => P3 ;
+    <P1,_>  => P1 ;
+    <_,P1>  => P1 ;
+    _       => P2
+    } ;
+
+
+--2 Subjunction
+--
+-- Subjunctions ("wenn", "falls", etc) 
+-- are a different way to combine sentences than conjunctions.
+-- The main clause can be a sentences, an imperatives, or a question,
+-- but the subjoined clause must be a sentence.
+
+  Subjunction = SS ;
+
+  subjunctSentence : Subjunction -> Sentence -> Sentence -> Sentence = \if, A, B ->
+    let {As = A.s ! Sub} in 
+    {s = table {
+           Main => variants {if.s ++ As ++ "," ++ B.s ! Inv ; 
+                             B.s ! Main ++ "," ++ if.s ++ As} ;
+           o    => B.s ! o ++ "," ++ if.s ++ As
+           } 
+     } ;
+
+  subjunctImperative : Subjunction -> Sentence -> Imperative -> Imperative = 
+    \if, A, B -> 
+    {s = \\n => subjunctVariants if A (B.s ! n)} ;
+
+  subjunctQuestion : Subjunction -> Sentence -> Question -> Question = \if, A, B ->
+    {s = \\q => subjunctVariants if A (B.s ! q)} ;
+
+-- There are uniformly two variant word orders, e.g. 
+-- "wenn du rauchst, werde ish böse"
+-- and "ich werde böse, wenn du rauchst".
+
+  subjunctVariants : Subjunction -> Sentence -> Str -> Str = \if,A,B ->
+    let {As = A.s ! Sub} in 
+    variants {if.s ++ As ++ "," ++ B ; B ++ "," ++ if.s ++ As} ;
+
+
+--2 One-word utterances
+-- 
+-- An utterance can consist of one phrase of almost any category, 
+-- the limiting case being one-word utterances. These
+-- utterances are often (but not always) in what can be called the
+-- default form of a category, e.g. the nominative.
+-- This list is far from exhaustive.
+
+  useNounPhrase : NounPhrase -> Utterance = \john ->
+    postfixSS "." (defaultNounPhrase john) ;
+  useCommonNounPhrase : Number -> CommNounPhrase -> Utterance = \n,car -> 
+    useNounPhrase (indefNounPhrase n car) ;
+
+-- Here are some default forms.
+
+  defaultNounPhrase : NounPhrase -> SS = \john -> 
+    ss (john.s ! NPCase Nom) ;
+
+  defaultQuestion : Question -> SS = \whoareyou ->
+    ss (whoareyou.s ! DirQ) ;
+
+  defaultSentence : Sentence -> Utterance = \x -> ss (x.s ! Main) ;
+
+--3 Puzzle
+--
+-- Adding some lexicon, we can generate the sentence
+--
+-- "der grösste alte Mann ist nicht ein Auto auf die Mutter von dem Männer warten"
+--
+-- which looks completely ungrammatical! What you should do to decipher it is
+-- put parentheses around "auf die Mutter von dem".
+
+} ;
diff --git a/grammars/resource/german/TestDeu.gf b/grammars/resource/german/TestDeu.gf
new file mode 100644
index 000000000..e09b60d1f
--- /dev/null
+++ b/grammars/resource/german/TestDeu.gf
@@ -0,0 +1,39 @@
+concrete TestDeu of TestAbs = ResDeu ** open Syntax in {
+
+flags startcat=Phr ; lexer=text ; parser=chart ; unlexer=text ;
+
+-- a random sample from the lexicon
+
+lin
+  Big = adjCompReg3 "gross" "grösser" "grösst";
+  Small = adjCompReg "klein" ;
+  Old = adjCompReg3 "alt" "älter" "ältest";
+  Young = adjCompReg3 "jung" "jünger" "jüngst";
+  Man = declN2u "Mann" "Männer" ;
+  Woman = declN1 "Frau" ;
+  Car = declNs "Auto" ;
+  House = declN3uS "Haus" "Häuser" ;
+  Light = declN3 "Licht" ;
+  Walk = mkVerbSimple (verbLaufen "gehen" "geht" "gegangen") ;
+  Run = mkVerbSimple (verbLaufen "laufen" "läuft" "gelaufen") ; 
+  Say = mkVerbSimple (regVerb "sagen") ;
+  Prove = mkVerbSimple (regVerb "beweisen") ;
+  Send = mkTransVerb (mkVerbSimple (verbLaufen "senden" "sendet" "gesandt")) [] Acc;
+  Love = mkTransVerb (mkVerbSimple (regVerb "lieben")) [] Acc ;
+  Wait =  mkTransVerb (mkVerbSimple (verbWarten "warten")) "auf" Acc ;
+  Mother = mkFunC (n2n (declN2uF "Mutter" "Mütter")) "von" Dat ;
+  Uncle = mkFunC (n2n (declN2i "Onkel")) "von" Dat ;
+  Connection = mkFunC (n2n (declN1 "Verbindung")) "von" Dat ** 
+                                     {s3 = "nach" ; c2 = Dat} ;
+
+  Always = mkAdverb "immer" ;
+  Well = mkAdverb "gut" ;
+
+  SwitchOn  = mkTransVerb (mkVerb (verbWarten "schalten") "auf") [] Acc  ;
+  SwitchOff = mkTransVerb (mkVerb (verbWarten "schalten") "aus") [] Acc  ;
+
+  John = mkProperName "Johann" ;
+  Mary = mkProperName "Maria" ;
+
+} ;
+
diff --git a/grammars/resource/german/Types.gf b/grammars/resource/german/Types.gf
new file mode 100644
index 000000000..d597223cd
--- /dev/null
+++ b/grammars/resource/german/Types.gf
@@ -0,0 +1,98 @@
+--1 German Word Classes and Morphological Parameters
+--
+-- This is a resource module for German morphology, defining the
+-- morphological parameters and word classes of German. It is so far only
+-- complete w.r.t. the syntax part of the resource grammar.
+-- It does not include those parameters that are not needed for
+-- analysing individual words: such parameters are defined in syntax modules.
+--
+
+resource Types = open Prelude in {
+
+--2 Enumerated parameter types 
+--
+-- These types are the ones found in school grammars.
+-- Their parameter values are atomic.
+
+param 
+  Number = Sg | Pl ;
+  Gender = Masc | Fem | Neut ;
+  Person = P1 | P2 | P3 ;
+  Case   = Nom | Acc | Dat | Gen ;
+  Adjf   = Strong | Weak ;          -- the main division in adjective declension
+  Order  = Main | Inv | Sub ;       -- word order: direct, indirect, subordinate
+
+-- For abstraction and API compatibility, we define two synonyms:
+
+oper 
+  singular = Sg ; 
+  plural = Pl ;
+
+--2 Word classes and hierarchical parameter types
+--
+-- Real parameter types (i.e. ones on which words and phrases depend) 
+-- are mostly hierarchical. The alternative is cross-products of
+-- simple parameters, but this cannot be always used since it overgenerates.
+--
+
+--3 Common nouns
+--
+-- Common nouns are inflected in number and case and they have an inherent gender.
+
+  CommNoun : Type = {s : Number => Case => Str ; g : Gender} ;
+
+--3 Pronouns
+--
+-- Pronouns are an example - the worst-case one of noun phrases,
+-- which are properly defined in $syntax.Deu.gf$.
+-- Their inflection tables has, in addition to the normal genitive,
+-- the possessive forms, which are inflected like determiners.
+
+param
+  NPForm = NPCase Case | NPPoss GenNum Case ;
+
+--3 Adjectives
+--
+-- Adjectives are a very complex class, and the full table has as many as
+-- 99 different forms. The major division is between the comparison degrees.
+-- There is no gender distinction in the plural, 
+-- and the predicative forms ("X ist Adj") are not inflected.
+
+param
+  GenNum = GSg Gender | GPl ;
+  AForm  = APred | AMod Adjf GenNum Case ;  
+
+oper
+  Adjective : Type = {s : AForm => Str} ;
+  AdjComp : Type = {s : Degree => AForm => Str} ;
+
+-- Comparison of adjectives:
+
+param Degree = Pos | Comp | Sup ;
+
+--3 Verbs 
+--
+-- We have a reduced conjugation with only the present tense infinitive, 
+-- indicative, and imperative forms, and past participles.
+
+param VForm = VInf | VInd Number Person | VImp Number | VPart AForm ;
+
+oper Verbum : Type = VForm => Str ;
+
+-- On the general level, we have to account for composite verbs as well, 
+-- such as "aus" + "sehen" etc.
+
+  Particle = Str ;
+
+  Verb = {s : Verbum ; s2 : Particle} ;
+
+
+--2 Prepositions
+--
+-- We define prepositions simply as strings. Thus we do not capture the
+-- contractions "vom", "ins", etc. To define them in GF grammar we would need
+-- to introduce a parameter system, which we postpone.
+
+  Preposition = Str ;
+
+} ;
diff --git a/grammars/resource/swedish/Morpho.gf b/grammars/resource/swedish/Morpho.gf
new file mode 100644
index 000000000..d7b2c66fa
--- /dev/null
+++ b/grammars/resource/swedish/Morpho.gf
@@ -0,0 +1,1039 @@
+--1 A Simple Swedish Resource Morphology
+--
+-- Aarne Ranta 2002
+--
+-- This resource morphology contains definitions needed in the resource
+-- syntax. It moreover contains copies of the most usual inflectional patterns
+-- as defined in functional morphology (in the Haskell file $RulesSw.hs$).
+--
+-- We use the parameter types and word classes defined for morphology.
+
+resource Morpho = Types ** open Prelude in {
+
+-- The indefinite and definite article
+oper
+  artIndef = table {Utr => "en" ; Neutr => "ett"} ;
+
+  artDef : Bool => GenNum => Str = table {
+    True => table {
+      ASg Utr => "den" ;
+      ASg Neutr => "det" ;              -- det gamla huset
+      APl => variants {"de" ; "dom"}
+      } ;
+    False => table {_ => []}            -- huset
+    } ;
+
+-- A simplified verb category: present tense only.
+oper
+  verbVara = {s = table {Infinit => "vara" ; Indicat => "är" ; Imperat => "var"}} ;
+  verbHava = {s = table {Infinit => "ha" ; Indicat => "har" ; Imperat => "ha"}} ;
+
+-- Prepositions are just strings.
+  Preposition = Str ;
+
+-- Relative pronouns have a special case system. $RPrep$ is the form used
+-- after a preposition (e.g. "det hus i vilket jag bor").
+param
+  RelCase = RNom | RAcc | RGen | RPrep ;
+
+oper
+  relPronForms : RelCase => GenNum => Str = table {
+    RNom  => \\_ => "som" ;
+    RAcc  => \\_ => variants {"som" ; []} ;
+    RGen  => \\_ => "vars" ;
+    RPrep => pronVilken
+    } ;
+  
+  pronVilken = table {
+      ASg Utr   => "vilken" ; 
+      ASg Neutr => "vilket" ; 
+      APl       => "vilka"
+      } ;
+
+  pronSådan = table {
+      ASg Utr   => "sådan" ; 
+      ASg Neutr => "sådant" ; 
+      APl       => "sådana"
+      } ;
+
+-- What follows are machine-generated inflection paradigms from functional 
+-- morphology. Hence they are low-level paradigms, without any 
+-- abstractions or generalizations: the Haskell code is better in these respects.
+-- 
+-- The variable names are selected in such a way that the paradigms can be read
+-- as inflection tables of certain words.
+
+oper sApa : Str -> Subst = \ap -> 
+ {s = table {
+    SF Sg Indef Nom => ap + "a" ;
+    SF Sg Indef Gen => ap + "as" ;
+    SF Sg Def Nom => ap + "an" ;
+    SF Sg Def Gen => ap + "ans" ;
+    SF Pl Indef Nom => ap + "or" ;
+    SF Pl Indef Gen => ap + "ors" ;
+    SF Pl Def Nom => ap + "orna" ;
+    SF Pl Def Gen => ap + "ornas"
+    } ;
+  h1 = Utr
+  } ;
+
+oper sBil : Str -> Subst = \bil -> 
+ {s = table {
+    SF Sg Indef Nom => bil ;
+    SF Sg Indef Gen => bil + "s" ;
+    SF Sg Def Nom => bil + "en" ;
+    SF Sg Def Gen => bil + "ens" ;
+    SF Pl Indef Nom => bil + "ar" ;
+    SF Pl Indef Gen => bil + "ars" ;
+    SF Pl Def Nom => bil + "arna" ;
+    SF Pl Def Gen => bil + "arnas"
+    } ;
+  h1 = Utr
+  } ;
+
+oper sPojke : Str -> Subst = \pojk -> 
+ {s = table {
+    SF Sg Indef Nom => pojk + "e" ;
+    SF Sg Indef Gen => pojk + "es" ;
+    SF Sg Def Nom => pojk + "en" ;
+    SF Sg Def Gen => pojk + "ens" ;
+    SF Pl Indef Nom => pojk + "ar" ;
+    SF Pl Indef Gen => pojk + "ars" ;
+    SF Pl Def Nom => pojk + "arna" ;
+    SF Pl Def Gen => pojk + "arnas"
+    } ;
+  h1 = Utr
+  } ;
+
+oper sNyckel : Str -> Subst = \nyck -> 
+ {s = table {
+    SF Sg Indef Nom => nyck + "el" ;
+    SF Sg Indef Gen => nyck + "els" ;
+    SF Sg Def Nom => nyck + "eln" ;
+    SF Sg Def Gen => nyck + "elns" ;
+    SF Pl Indef Nom => nyck + "lar" ;
+    SF Pl Indef Gen => nyck + "lars" ;
+    SF Pl Def Nom => nyck + "larna" ;
+    SF Pl Def Gen => nyck + "larnas"
+    } ;
+  h1 = Utr
+  } ;
+
+oper sKam : Str -> Subst = \kam -> 
+ {s = table {
+    SF Sg Indef Nom => kam ;
+    SF Sg Indef Gen => kam + "s" ;
+    SF Sg Def Nom => kam + "men" ;
+    SF Sg Def Gen => kam + "mens" ;
+    SF Pl Indef Nom => kam + "mar" ;
+    SF Pl Indef Gen => kam + "mars" ;
+    SF Pl Def Nom => kam + "marna" ;
+    SF Pl Def Gen => kam + "marnas"
+    } ;
+  h1 = Utr
+  } ;
+
+oper sSak : Str -> Subst = \sak -> 
+ {s = table {
+    SF Sg Indef Nom => sak ;
+    SF Sg Indef Gen => sak + "s" ;
+    SF Sg Def Nom => sak + "en" ;
+    SF Sg Def Gen => sak + "ens" ;
+    SF Pl Indef Nom => sak + "er" ;
+    SF Pl Indef Gen => sak + "ers" ;
+    SF Pl Def Nom => sak + "erna" ;
+    SF Pl Def Gen => sak + "ernas"
+    } ;
+  h1 = Utr
+  } ;
+
+oper sNivå : Str -> Subst = \nivå -> 
+ {s = table {
+    SF Sg Indef Nom => nivå ;
+    SF Sg Indef Gen => nivå + "s" ;
+    SF Sg Def Nom => nivå + "n" ;
+    SF Sg Def Gen => nivå + "ns" ;
+    SF Pl Indef Nom => nivå + "er" ;
+    SF Pl Indef Gen => nivå + "ers" ;
+    SF Pl Def Nom => nivå + "erna" ;
+    SF Pl Def Gen => nivå + "ernas"
+    } ;
+  h1 = Utr
+  } ;
+
+oper sParti : Str -> Subst = \parti -> 
+ {s = table {
+    SF Sg Indef Nom => parti ;
+    SF Sg Indef Gen => parti + "s" ;
+    SF Sg Def Nom => parti + "et" ;
+    SF Sg Def Gen => parti + "ets" ;
+    SF Pl Indef Nom => parti + "er" ;
+    SF Pl Indef Gen => parti + "ers" ;
+    SF Pl Def Nom => parti + "erna" ;
+    SF Pl Def Gen => parti + "ernas"
+    } ;
+  h1 = Neutr
+  } ;
+
+oper sMuseum : Str -> Subst = \muse -> 
+ {s = table {
+    SF Sg Indef Nom => muse + "um" ;
+    SF Sg Indef Gen => muse + "ums" ;
+    SF Sg Def Nom => muse + "et" ;
+    SF Sg Def Gen => muse + "ets" ;
+    SF Pl Indef Nom => muse + "er" ;
+    SF Pl Indef Gen => muse + "ers" ;
+    SF Pl Def Nom => muse + "erna" ;
+    SF Pl Def Gen => muse + "ernas"
+    } ;
+  h1 = Neutr
+  } ;
+
+oper sRike : Str -> Subst = \rike -> 
+ {s = table {
+    SF Sg Indef Nom => rike ;
+    SF Sg Indef Gen => rike + "s" ;
+    SF Sg Def Nom => rike + "t" ;
+    SF Sg Def Gen => rike + "ts" ;
+    SF Pl Indef Nom => rike + "n" ;
+    SF Pl Indef Gen => rike + "ns" ;
+    SF Pl Def Nom => rike + "na" ;
+    SF Pl Def Gen => rike + "nas"
+    } ;
+  h1 = Neutr
+  } ;
+
+oper sLik : Str -> Subst = \lik -> 
+ {s = table {
+    SF Sg Indef Nom => lik ;
+    SF Sg Indef Gen => lik + "s" ;
+    SF Sg Def Nom => lik + "et" ;
+    SF Sg Def Gen => lik + "ets" ;
+    SF Pl Indef Nom => lik ;
+    SF Pl Indef Gen => lik + "s" ;
+    SF Pl Def Nom => lik + "en" ;
+    SF Pl Def Gen => lik + "ens"
+    } ;
+  h1 = Neutr
+  } ;
+
+oper sRum : Str -> Subst = \rum -> 
+ {s = table {
+    SF Sg Indef Nom => rum ;
+    SF Sg Indef Gen => rum + "s" ;
+    SF Sg Def Nom => rum + "met" ;
+    SF Sg Def Gen => rum + "mets" ;
+    SF Pl Indef Nom => rum ;
+    SF Pl Indef Gen => rum + "s" ;
+    SF Pl Def Nom => rum + "men" ;
+    SF Pl Def Gen => rum + "mens"
+    } ;
+  h1 = Neutr
+  } ;
+
+oper sHus : Str -> Subst = \hus -> 
+ {s = table {
+    SF Sg Indef Nom => hus ;
+    SF Sg Indef Gen => hus ;
+    SF Sg Def Nom => hus + "et" ;
+    SF Sg Def Gen => hus + "ets" ;
+    SF Pl Indef Nom => hus ;
+    SF Pl Indef Gen => hus ;
+    SF Pl Def Nom => hus + "en" ;
+    SF Pl Def Gen => hus + "ens"
+    } ;
+  h1 = Neutr
+  } ;
+
+oper sPapper : Str -> Subst = \papp -> 
+ {s = table {
+    SF Sg Indef Nom => papp + "er" ;
+    SF Sg Indef Gen => papp + "ers" ;
+    SF Sg Def Nom => papp + "ret" ;
+    SF Sg Def Gen => papp + "rets" ;
+    SF Pl Indef Nom => papp + "er" ;
+    SF Pl Indef Gen => papp + "ers" ;
+    SF Pl Def Nom => papp + "ren" ;
+    SF Pl Def Gen => papp + "rens"
+    } ;
+  h1 = Neutr
+  } ;
+
+oper sNummer : Str -> Subst = \num -> 
+ {s = table {
+    SF Sg Indef Nom => num + "mer" ;
+    SF Sg Indef Gen => num + "mers" ;
+    SF Sg Def Nom => num + "ret" ;
+    SF Sg Def Gen => num + "rets" ;
+    SF Pl Indef Nom => num + "mer" ;
+    SF Pl Indef Gen => num + "mers" ;
+    SF Pl Def Nom => num + "ren" ;
+    SF Pl Def Gen => num + "rens"
+    } ;
+  h1 = Neutr
+  } ;
+
+oper sKikare : Str -> Subst = \kikar -> 
+ {s = table {
+    SF Sg Indef Nom => kikar + "e" ;
+    SF Sg Indef Gen => kikar + "es" ;
+    SF Sg Def Nom => kikar + "en" ;
+    SF Sg Def Gen => kikar + "ens" ;
+    SF Pl Indef Nom => kikar + "e" ;
+    SF Pl Indef Gen => kikar + "es" ;
+    SF Pl Def Nom => kikar + "na" ;
+    SF Pl Def Gen => kikar + "nas"
+    } ;
+  h1 = Utr
+  } ;
+
+oper sProgram : Str -> Subst = \program -> 
+ {s = table {
+    SF Sg Indef Nom => program ;
+    SF Sg Indef Gen => program + "s" ;
+    SF Sg Def Nom => program + "met" ;
+    SF Sg Def Gen => program + "mets" ;
+    SF Pl Indef Nom => program ;
+    SF Pl Indef Gen => program + "s" ;
+    SF Pl Def Nom => program + "men" ;
+    SF Pl Def Gen => program + "mens"
+    } ;
+  h1 = Neutr
+  } ;
+
+oper aFin : Str -> Adj = \fin -> 
+ {s = table {
+    AF (Posit (Strong (ASg Utr))) Nom => fin ;
+    AF (Posit (Strong (ASg Utr))) Gen => fin + "s" ;
+    AF (Posit (Strong (ASg Neutr))) Nom => fin + "t" ;
+    AF (Posit (Strong (ASg Neutr))) Gen => fin + "ts" ;
+    AF (Posit (Strong APl)) Nom => fin + "a" ;
+    AF (Posit (Strong APl)) Gen => fin + "as" ;
+    AF (Posit (Weak (AxSg NoMasc))) Nom => fin + "a" ;
+    AF (Posit (Weak (AxSg NoMasc))) Gen => fin + "as" ;
+    AF (Posit (Weak (AxSg Masc))) Nom => fin + "e" ;
+    AF (Posit (Weak (AxSg Masc))) Gen => fin + "es" ;
+    AF (Posit (Weak AxPl)) Nom => fin + "a" ;
+    AF (Posit (Weak AxPl)) Gen => fin + "as" ;
+    AF Compar Nom => fin + "are" ;
+    AF Compar Gen => fin + "ares" ;
+    AF (Super SupStrong) Nom => fin + "ast" ;
+    AF (Super SupStrong) Gen => fin + "asts" ;
+    AF (Super SupWeak) Nom => fin + "aste" ;
+    AF (Super SupWeak) Gen => fin + "astes"
+    }
+  } ;
+
+oper aFager : Str -> Adj = \fag -> 
+ {s = table {
+    AF (Posit (Strong (ASg Utr))) Nom => fag + "er" ;
+    AF (Posit (Strong (ASg Utr))) Gen => fag + "ers" ;
+    AF (Posit (Strong (ASg Neutr))) Nom => fag + "ert" ;
+    AF (Posit (Strong (ASg Neutr))) Gen => fag + "erts" ;
+    AF (Posit (Strong APl)) Nom => fag + "era" ;
+    AF (Posit (Strong APl)) Gen => fag + "eras" ;
+    AF (Posit (Weak (AxSg NoMasc))) Nom => fag + "era" ;
+    AF (Posit (Weak (AxSg NoMasc))) Gen => fag + "eras" ;
+    AF (Posit (Weak (AxSg Masc))) Nom => fag + "ere" ;
+    AF (Posit (Weak (AxSg Masc))) Gen => fag + "eres" ;
+    AF (Posit (Weak AxPl)) Nom => fag + "era" ;
+    AF (Posit (Weak AxPl)) Gen => fag + "eras" ;
+    AF Compar Nom => fag + "erare" ;
+    AF Compar Gen => fag + "erares" ;
+    AF (Super SupStrong) Nom => fag + "erast" ;
+    AF (Super SupStrong) Gen => fag + "erasts" ;
+    AF (Super SupWeak) Nom => fag + "eraste" ;
+    AF (Super SupWeak) Gen => fag + "erastes"
+    }
+  } ;
+
+oper aGrund : Str -> Adj = \grun -> 
+ {s = table {
+    AF (Posit (Strong (ASg Utr))) Nom => grun + "d" ;
+    AF (Posit (Strong (ASg Utr))) Gen => grun + "ds" ;
+    AF (Posit (Strong (ASg Neutr))) Nom => grun + "t" ;
+    AF (Posit (Strong (ASg Neutr))) Gen => grun + "ts" ;
+    AF (Posit (Strong APl)) Nom => grun + "da" ;
+    AF (Posit (Strong APl)) Gen => grun + "das" ;
+    AF (Posit (Weak (AxSg NoMasc))) Nom => grun + "da" ;
+    AF (Posit (Weak (AxSg NoMasc))) Gen => grun + "das" ;
+    AF (Posit (Weak (AxSg Masc))) Nom => grun + "de" ;
+    AF (Posit (Weak (AxSg Masc))) Gen => grun + "des" ;
+    AF (Posit (Weak AxPl)) Nom => grun + "da" ;
+    AF (Posit (Weak AxPl)) Gen => grun + "das" ;
+    AF Compar Nom => grun + "dare" ;
+    AF Compar Gen => grun + "dares" ;
+    AF (Super SupStrong) Nom => grun + "dast" ;
+    AF (Super SupStrong) Gen => grun + "dasts" ;
+    AF (Super SupWeak) Nom => grun + "daste" ;
+    AF (Super SupWeak) Gen => grun + "dastes"
+    }
+  } ;
+
+oper aVid : Str -> Adj = \vi -> 
+ {s = table {
+    AF (Posit (Strong (ASg Utr))) Nom => vi + "d" ;
+    AF (Posit (Strong (ASg Utr))) Gen => vi + "ds" ;
+    AF (Posit (Strong (ASg Neutr))) Nom => vi + "tt" ;
+    AF (Posit (Strong (ASg Neutr))) Gen => vi + "tts" ;
+    AF (Posit (Strong APl)) Nom => vi + "da" ;
+    AF (Posit (Strong APl)) Gen => vi + "das" ;
+    AF (Posit (Weak (AxSg NoMasc))) Nom => vi + "da" ;
+    AF (Posit (Weak (AxSg NoMasc))) Gen => vi + "das" ;
+    AF (Posit (Weak (AxSg Masc))) Nom => vi + "de" ;
+    AF (Posit (Weak (AxSg Masc))) Gen => vi + "des" ;
+    AF (Posit (Weak AxPl)) Nom => vi + "da" ;
+    AF (Posit (Weak AxPl)) Gen => vi + "das" ;
+    AF Compar Nom => vi + "dare" ;
+    AF Compar Gen => vi + "dares" ;
+    AF (Super SupStrong) Nom => vi + "dast" ;
+    AF (Super SupStrong) Gen => vi + "dasts" ;
+    AF (Super SupWeak) Nom => vi + "daste" ;
+    AF (Super SupWeak) Gen => vi + "dastes"
+    }
+  } ;
+
+oper aVaken : Str -> Adj = \vak -> 
+ {s = table {
+    AF (Posit (Strong (ASg Utr))) Nom => vak + "en" ;
+    AF (Posit (Strong (ASg Utr))) Gen => vak + "ens" ;
+    AF (Posit (Strong (ASg Neutr))) Nom => vak + "et" ;
+    AF (Posit (Strong (ASg Neutr))) Gen => vak + "ets" ;
+    AF (Posit (Strong APl)) Nom => vak + "na" ;
+    AF (Posit (Strong APl)) Gen => vak + "nas" ;
+    AF (Posit (Weak (AxSg NoMasc))) Nom => vak + "na" ;
+    AF (Posit (Weak (AxSg NoMasc))) Gen => vak + "nas" ;
+    AF (Posit (Weak (AxSg Masc))) Nom => vak + "ne" ;
+    AF (Posit (Weak (AxSg Masc))) Gen => vak + "nes" ;
+    AF (Posit (Weak AxPl)) Nom => vak + "na" ;
+    AF (Posit (Weak AxPl)) Gen => vak + "nas" ;
+    AF Compar Nom => vak + "nare" ;
+    AF Compar Gen => vak + "nares" ;
+    AF (Super SupStrong) Nom => vak + "nast" ;
+    AF (Super SupStrong) Gen => vak + "nasts" ;
+    AF (Super SupWeak) Nom => vak + "naste" ;
+    AF (Super SupWeak) Gen => vak + "nastes"
+    }
+  } ;
+
+oper aKorkad : Str -> Adj = \korka -> 
+ {s = table {
+    AF (Posit (Strong (ASg Utr))) Nom => korka + "d" ;
+    AF (Posit (Strong (ASg Utr))) Gen => korka + "ds" ;
+    AF (Posit (Strong (ASg Neutr))) Nom => korka + "t" ;
+    AF (Posit (Strong (ASg Neutr))) Gen => korka + "ts" ;
+    AF (Posit (Strong APl)) Nom => korka + "de" ;
+    AF (Posit (Strong APl)) Gen => korka + "des" ;
+    AF (Posit (Weak (AxSg NoMasc))) Nom => korka + "de" ;
+    AF (Posit (Weak (AxSg NoMasc))) Gen => korka + "des" ;
+    AF (Posit (Weak (AxSg Masc))) Nom => korka + "de" ;
+    AF (Posit (Weak (AxSg Masc))) Gen => korka + "des" ;
+    AF (Posit (Weak AxPl)) Nom => korka + "de" ;
+    AF (Posit (Weak AxPl)) Gen => korka + "des" ;
+    AF Compar Nom => variants {} ;
+    AF Compar Gen => variants {} ;
+    AF (Super SupStrong) Nom => variants {} ;
+    AF (Super SupStrong) Gen => variants {} ;
+    AF (Super SupWeak) Nom => variants {} ;
+    AF (Super SupWeak) Gen => variants {}
+    }
+  } ;
+
+oper aAbstrakt : Str -> Adj = \abstrakt -> 
+ {s = table {
+    AF (Posit (Strong (ASg Utr))) Nom => abstrakt ;
+    AF (Posit (Strong (ASg Utr))) Gen => abstrakt + "s" ;
+    AF (Posit (Strong (ASg Neutr))) Nom => abstrakt ;
+    AF (Posit (Strong (ASg Neutr))) Gen => abstrakt + "s" ;
+    AF (Posit (Strong APl)) Nom => abstrakt + "a" ;
+    AF (Posit (Strong APl)) Gen => abstrakt + "as" ;
+    AF (Posit (Weak (AxSg NoMasc))) Nom => abstrakt + "a" ;
+    AF (Posit (Weak (AxSg NoMasc))) Gen => abstrakt + "as" ;
+    AF (Posit (Weak (AxSg Masc))) Nom => abstrakt + "e" ;
+    AF (Posit (Weak (AxSg Masc))) Gen => abstrakt + "es" ;
+    AF (Posit (Weak AxPl)) Nom => abstrakt + "a" ;
+    AF (Posit (Weak AxPl)) Gen => abstrakt + "as" ;
+    AF Compar Nom => abstrakt + "are" ;
+    AF Compar Gen => abstrakt + "ares" ;
+    AF (Super SupStrong) Nom => abstrakt + "ast" ;
+    AF (Super SupStrong) Gen => abstrakt + "asts" ;
+    AF (Super SupWeak) Nom => abstrakt + "aste" ;
+    AF (Super SupWeak) Gen => abstrakt + "astes"
+    }
+  } ;
+
+oper vTala : Str -> Verbum = \tal -> 
+ {s = table {
+    VF (Pres Ind Act) => tal + "ar" ;
+    VF (Pres Ind Pass) => tal + "as" ;
+    VF (Pres Cnj Act) => tal + "e" ;
+    VF (Pres Cnj Pass) => tal + "es" ;
+    VF (Pret Ind Act) => tal + "ade" ;
+    VF (Pret Ind Pass) => tal + "ades" ;
+    VF (Pret Cnj Act) => tal + "ade" ;
+    VF (Pret Cnj Pass) => tal + "ades" ;
+    VF Imper => tal + "a" ;
+    VI (Inf Act) => tal + "a" ;
+    VI (Inf Pass) => tal + "as" ;
+    VI (Supin Act) => tal + "at" ;
+    VI (Supin Pass) => tal + "ats" ;
+    VI (PtPres Nom) => tal + "ande" ;
+    VI (PtPres Gen) => tal + "andes" ;
+    VI (PtPret (Strong (ASg Utr)) Nom) => tal + "ad" ;
+    VI (PtPret (Strong (ASg Utr)) Gen) => tal + "ads" ;
+    VI (PtPret (Strong (ASg Neutr)) Nom) => tal + "at" ;
+    VI (PtPret (Strong (ASg Neutr)) Gen) => tal + "ats" ;
+    VI (PtPret (Strong APl) Nom) => tal + "ade" ;
+    VI (PtPret (Strong APl) Gen) => tal + "ades" ;
+    VI (PtPret (Weak (AxSg NoMasc)) Nom) => tal + "ade" ;
+    VI (PtPret (Weak (AxSg NoMasc)) Gen) => tal + "ades" ;
+    VI (PtPret (Weak (AxSg Masc)) Nom) => tal + "ade" ;
+    VI (PtPret (Weak (AxSg Masc)) Gen) => tal + "ades" ;
+    VI (PtPret (Weak AxPl) Nom) => tal + "ade" ;
+    VI (PtPret (Weak AxPl) Gen) => tal + "ades"
+    }
+  } ;
+
+oper vLeka : Str -> Verbum = \lek -> 
+ {s = table {
+    VF (Pres Ind Act) => lek + "er" ;
+    VF (Pres Ind Pass) => variants {lek + "s" ; lek + "es"} ;
+    VF (Pres Cnj Act) => lek + "e" ;
+    VF (Pres Cnj Pass) => lek + "es" ;
+    VF (Pret Ind Act) => lek + "te" ;
+    VF (Pret Ind Pass) => lek + "tes" ;
+    VF (Pret Cnj Act) => lek + "te" ;
+    VF (Pret Cnj Pass) => lek + "tes" ;
+    VF Imper => lek ;
+    VI (Inf Act) => lek + "a" ;
+    VI (Inf Pass) => lek + "as" ;
+    VI (Supin Act) => lek + "t" ;
+    VI (Supin Pass) => lek + "ts" ;
+    VI (PtPres Nom) => lek + "ande" ;
+    VI (PtPres Gen) => lek + "andes" ;
+    VI (PtPret (Strong (ASg Utr)) Nom) => lek + "t" ;
+    VI (PtPret (Strong (ASg Utr)) Gen) => lek + "ts" ;
+    VI (PtPret (Strong (ASg Neutr)) Nom) => lek + "t" ;
+    VI (PtPret (Strong (ASg Neutr)) Gen) => lek + "ts" ;
+    VI (PtPret (Strong APl) Nom) => lek + "ta" ;
+    VI (PtPret (Strong APl) Gen) => lek + "tas" ;
+    VI (PtPret (Weak (AxSg NoMasc)) Nom) => lek + "ta" ;
+    VI (PtPret (Weak (AxSg NoMasc)) Gen) => lek + "tas" ;
+    VI (PtPret (Weak (AxSg Masc)) Nom) => lek + "te" ;
+    VI (PtPret (Weak (AxSg Masc)) Gen) => lek + "tes" ;
+    VI (PtPret (Weak AxPl) Nom) => lek + "ta" ;
+    VI (PtPret (Weak AxPl) Gen) => lek + "tas"
+    }
+  } ;
+
+oper vTyda : Str -> Verbum = \ty -> 
+ {s = table {
+    VF (Pres Ind Act) => ty + "der" ;
+    VF (Pres Ind Pass) => variants {ty + "ds" ; ty + "des"} ;
+    VF (Pres Cnj Act) => ty + "de" ;
+    VF (Pres Cnj Pass) => ty + "des" ;
+    VF (Pret Ind Act) => ty + "dde" ;
+    VF (Pret Ind Pass) => ty + "ddes" ;
+    VF (Pret Cnj Act) => ty + "dde" ;
+    VF (Pret Cnj Pass) => ty + "ddes" ;
+    VF Imper => ty + "d" ;
+    VI (Inf Act) => ty + "da" ;
+    VI (Inf Pass) => ty + "das" ;
+    VI (Supin Act) => ty + "tt" ;
+    VI (Supin Pass) => ty + "tts" ;
+    VI (PtPres Nom) => ty + "dande" ;
+    VI (PtPres Gen) => ty + "dandes" ;
+    VI (PtPret (Strong (ASg Utr)) Nom) => ty + "dd" ;
+    VI (PtPret (Strong (ASg Utr)) Gen) => ty + "dds" ;
+    VI (PtPret (Strong (ASg Neutr)) Nom) => ty + "tt" ;
+    VI (PtPret (Strong (ASg Neutr)) Gen) => ty + "tts" ;
+    VI (PtPret (Strong APl) Nom) => ty + "dda" ;
+    VI (PtPret (Strong APl) Gen) => ty + "ddas" ;
+    VI (PtPret (Weak (AxSg NoMasc)) Nom) => ty + "dda" ;
+    VI (PtPret (Weak (AxSg NoMasc)) Gen) => ty + "ddas" ;
+    VI (PtPret (Weak (AxSg Masc)) Nom) => ty + "dde" ;
+    VI (PtPret (Weak (AxSg Masc)) Gen) => ty + "ddes" ;
+    VI (PtPret (Weak AxPl) Nom) => ty + "dda" ;
+    VI (PtPret (Weak AxPl) Gen) => ty + "ddas"
+    }
+  } ;
+
+oper vVända : Str -> Verbum = \vän -> 
+ {s = table {
+    VF (Pres Ind Act) => vän + "der" ;
+    VF (Pres Ind Pass) => variants {vän + "ds" ; vän + "des"} ;
+    VF (Pres Cnj Act) => vän + "de" ;
+    VF (Pres Cnj Pass) => vän + "des" ;
+    VF (Pret Ind Act) => vän + "de" ;
+    VF (Pret Ind Pass) => vän + "des" ;
+    VF (Pret Cnj Act) => vän + "de" ;
+    VF (Pret Cnj Pass) => vän + "des" ;
+    VF Imper => vän + "d" ;
+    VI (Inf Act) => vän + "da" ;
+    VI (Inf Pass) => vän + "das" ;
+    VI (Supin Act) => vän + "t" ;
+    VI (Supin Pass) => vän + "ts" ;
+    VI (PtPres Nom) => vän + "dande" ;
+    VI (PtPres Gen) => vän + "dandes" ;
+    VI (PtPret (Strong (ASg Utr)) Nom) => vän + "d" ;
+    VI (PtPret (Strong (ASg Utr)) Gen) => vän + "ds" ;
+    VI (PtPret (Strong (ASg Neutr)) Nom) => vän + "t" ;
+    VI (PtPret (Strong (ASg Neutr)) Gen) => vän + "ts" ;
+    VI (PtPret (Strong APl) Nom) => vän + "da" ;
+    VI (PtPret (Strong APl) Gen) => vän + "das" ;
+    VI (PtPret (Weak (AxSg NoMasc)) Nom) => vän + "da" ;
+    VI (PtPret (Weak (AxSg NoMasc)) Gen) => vän + "das" ;
+    VI (PtPret (Weak (AxSg Masc)) Nom) => vän + "de" ;
+    VI (PtPret (Weak (AxSg Masc)) Gen) => vän + "des" ;
+    VI (PtPret (Weak AxPl) Nom) => vän + "da" ;
+    VI (PtPret (Weak AxPl) Gen) => vän + "das"
+    }
+  } ;
+
+oper vByta : Str -> Verbum = \by -> 
+ {s = table {
+    VF (Pres Ind Act) => by + "ter" ;
+    VF (Pres Ind Pass) => variants {by + "ts" ; by + "tes"} ;
+    VF (Pres Cnj Act) => by + "te" ;
+    VF (Pres Cnj Pass) => by + "tes" ;
+    VF (Pret Ind Act) => by + "tte" ;
+    VF (Pret Ind Pass) => by + "ttes" ;
+    VF (Pret Cnj Act) => by + "tte" ;
+    VF (Pret Cnj Pass) => by + "ttes" ;
+    VF Imper => by + "t" ;
+    VI (Inf Act) => by + "ta" ;
+    VI (Inf Pass) => by + "tas" ;
+    VI (Supin Act) => by + "tt" ;
+    VI (Supin Pass) => by + "tts" ;
+    VI (PtPres Nom) => by + "tande" ;
+    VI (PtPres Gen) => by + "tandes" ;
+    VI (PtPret (Strong (ASg Utr)) Nom) => by + "tt" ;
+    VI (PtPret (Strong (ASg Utr)) Gen) => by + "tts" ;
+    VI (PtPret (Strong (ASg Neutr)) Nom) => by + "tt" ;
+    VI (PtPret (Strong (ASg Neutr)) Gen) => by + "tts" ;
+    VI (PtPret (Strong APl) Nom) => by + "tta" ;
+    VI (PtPret (Strong APl) Gen) => by + "ttas" ;
+    VI (PtPret (Weak (AxSg NoMasc)) Nom) => by + "tta" ;
+    VI (PtPret (Weak (AxSg NoMasc)) Gen) => by + "ttas" ;
+    VI (PtPret (Weak (AxSg Masc)) Nom) => by + "tte" ;
+    VI (PtPret (Weak (AxSg Masc)) Gen) => by + "ttes" ;
+    VI (PtPret (Weak AxPl) Nom) => by + "tta" ;
+    VI (PtPret (Weak AxPl) Gen) => by + "ttas"
+    }
+  } ;
+
+oper vGömma : Str -> Verbum = \göm -> 
+ {s = table {
+    VF (Pres Ind Act) => göm + "mer" ;
+    VF (Pres Ind Pass) => variants {göm + "s" ; göm + "mes"} ;
+    VF (Pres Cnj Act) => göm + "me" ;
+    VF (Pres Cnj Pass) => göm + "mes" ;
+    VF (Pret Ind Act) => göm + "de" ;
+    VF (Pret Ind Pass) => göm + "des" ;
+    VF (Pret Cnj Act) => göm + "de" ;
+    VF (Pret Cnj Pass) => göm + "des" ;
+    VF Imper => göm ;
+    VI (Inf Act) => göm + "ma" ;
+    VI (Inf Pass) => göm + "mas" ;
+    VI (Supin Act) => göm + "t" ;
+    VI (Supin Pass) => göm + "ts" ;
+    VI (PtPres Nom) => göm + "mande" ;
+    VI (PtPres Gen) => göm + "mandes" ;
+    VI (PtPret (Strong (ASg Utr)) Nom) => göm + "d" ;
+    VI (PtPret (Strong (ASg Utr)) Gen) => göm + "ds" ;
+    VI (PtPret (Strong (ASg Neutr)) Nom) => göm + "t" ;
+    VI (PtPret (Strong (ASg Neutr)) Gen) => göm + "ts" ;
+    VI (PtPret (Strong APl) Nom) => göm + "da" ;
+    VI (PtPret (Strong APl) Gen) => göm + "das" ;
+    VI (PtPret (Weak (AxSg NoMasc)) Nom) => göm + "da" ;
+    VI (PtPret (Weak (AxSg NoMasc)) Gen) => göm + "das" ;
+    VI (PtPret (Weak (AxSg Masc)) Nom) => göm + "de" ;
+    VI (PtPret (Weak (AxSg Masc)) Gen) => göm + "des" ;
+    VI (PtPret (Weak AxPl) Nom) => göm + "da" ;
+    VI (PtPret (Weak AxPl) Gen) => göm + "das"
+    }
+  } ;
+
+oper vHyra : Str -> Verbum = \hyr -> 
+ {s = table {
+    VF (Pres Ind Act) => hyr ;
+    VF (Pres Ind Pass) => variants {hyr + "s" ; hyr + "es"} ;
+    VF (Pres Cnj Act) => hyr + "e" ;
+    VF (Pres Cnj Pass) => hyr + "es" ;
+    VF (Pret Ind Act) => hyr + "de" ;
+    VF (Pret Ind Pass) => hyr + "des" ;
+    VF (Pret Cnj Act) => hyr + "de" ;
+    VF (Pret Cnj Pass) => hyr + "des" ;
+    VF Imper => hyr ;
+    VI (Inf Act) => hyr + "a" ;
+    VI (Inf Pass) => hyr + "as" ;
+    VI (Supin Act) => hyr + "t" ;
+    VI (Supin Pass) => hyr + "ts" ;
+    VI (PtPres Nom) => hyr + "ande" ;
+    VI (PtPres Gen) => hyr + "andes" ;
+    VI (PtPret (Strong (ASg Utr)) Nom) => hyr + "d" ;
+    VI (PtPret (Strong (ASg Utr)) Gen) => hyr + "ds" ;
+    VI (PtPret (Strong (ASg Neutr)) Nom) => hyr + "t" ;
+    VI (PtPret (Strong (ASg Neutr)) Gen) => hyr + "ts" ;
+    VI (PtPret (Strong APl) Nom) => hyr + "da" ;
+    VI (PtPret (Strong APl) Gen) => hyr + "das" ;
+    VI (PtPret (Weak (AxSg NoMasc)) Nom) => hyr + "da" ;
+    VI (PtPret (Weak (AxSg NoMasc)) Gen) => hyr + "das" ;
+    VI (PtPret (Weak (AxSg Masc)) Nom) => hyr + "de" ;
+    VI (PtPret (Weak (AxSg Masc)) Gen) => hyr + "des" ;
+    VI (PtPret (Weak AxPl) Nom) => hyr + "da" ;
+    VI (PtPret (Weak AxPl) Gen) => hyr + "das"
+    }
+  } ;
+
+oper vTåla : Str -> Verbum = \tål -> 
+ {s = table {
+    VF (Pres Ind Act) => tål ;
+    VF (Pres Ind Pass) => variants {tål + "s" ; tål + "es"} ;
+    VF (Pres Cnj Act) => tål + "e" ;
+    VF (Pres Cnj Pass) => tål + "es" ;
+    VF (Pret Ind Act) => tål + "de" ;
+    VF (Pret Ind Pass) => tål + "des" ;
+    VF (Pret Cnj Act) => tål + "de" ;
+    VF (Pret Cnj Pass) => tål + "des" ;
+    VF Imper => tål ;
+    VI (Inf Act) => tål + "a" ;
+    VI (Inf Pass) => tål + "as" ;
+    VI (Supin Act) => tål + "t" ;
+    VI (Supin Pass) => tål + "ts" ;
+    VI (PtPres Nom) => tål + "ande" ;
+    VI (PtPres Gen) => tål + "andes" ;
+    VI (PtPret (Strong (ASg Utr)) Nom) => tål + "d" ;
+    VI (PtPret (Strong (ASg Utr)) Gen) => tål + "ds" ;
+    VI (PtPret (Strong (ASg Neutr)) Nom) => tål + "t" ;
+    VI (PtPret (Strong (ASg Neutr)) Gen) => tål + "ts" ;
+    VI (PtPret (Strong APl) Nom) => tål + "da" ;
+    VI (PtPret (Strong APl) Gen) => tål + "das" ;
+    VI (PtPret (Weak (AxSg NoMasc)) Nom) => tål + "da" ;
+    VI (PtPret (Weak (AxSg NoMasc)) Gen) => tål + "das" ;
+    VI (PtPret (Weak (AxSg Masc)) Nom) => tål + "de" ;
+    VI (PtPret (Weak (AxSg Masc)) Gen) => tål + "des" ;
+    VI (PtPret (Weak AxPl) Nom) => tål + "da" ;
+    VI (PtPret (Weak AxPl) Gen) => tål + "das"
+    }
+  } ;
+
+oper vFinna : (_,_,_ : Str) -> Verbum = \finn, fann, funn -> 
+ {s = table {
+    VF (Pres Ind Act) => finn + "er" ;
+    VF (Pres Ind Pass) => variants {finn + "s" ; finn + "es"} ;
+    VF (Pres Cnj Act) => finn + "e" ;
+    VF (Pres Cnj Pass) => finn + "es" ;
+    VF (Pret Ind Act) => fann ;
+    VF (Pret Ind Pass) => fann + "s" ;
+    VF (Pret Cnj Act) => funn + "e" ;
+    VF (Pret Cnj Pass) => funn + "es" ;
+    VF Imper => finn ;
+    VI (Inf Act) => finn + "a" ;
+    VI (Inf Pass) => finn + "as" ;
+    VI (Supin Act) => funn + "it" ;
+    VI (Supin Pass) => funn + "its" ;
+    VI (PtPres Nom) => finn + "ande" ;
+    VI (PtPres Gen) => finn + "andes" ;
+    VI (PtPret (Strong (ASg Utr)) Nom) => funn + "en" ;
+    VI (PtPret (Strong (ASg Utr)) Gen) => funn + "ens" ;
+    VI (PtPret (Strong (ASg Neutr)) Nom) => funn + "et" ;
+    VI (PtPret (Strong (ASg Neutr)) Gen) => funn + "ets" ;
+    VI (PtPret (Strong APl) Nom) => funn + "a" ;
+    VI (PtPret (Strong APl) Gen) => funn + "as" ;
+    VI (PtPret (Weak (AxSg NoMasc)) Nom) => funn + "a" ;
+    VI (PtPret (Weak (AxSg NoMasc)) Gen) => funn + "as" ;
+    VI (PtPret (Weak (AxSg Masc)) Nom) => funn + "e" ;
+    VI (PtPret (Weak (AxSg Masc)) Gen) => funn + "es" ;
+    VI (PtPret (Weak AxPl) Nom) => funn + "a" ;
+    VI (PtPret (Weak AxPl) Gen) => funn + "as"
+    }
+  } ;
+
+-- machine-generated exceptional inflection tables from rules.Swe.gf
+
+oper mor_1 : Subst = 
+ {s = table {
+    SF Sg Indef Nom => variants {"mor" ; "moder"} ;
+    SF Sg Indef Gen => variants {"mors" ; "moders"} ;
+    SF Sg Def Nom => "modern" ;
+    SF Sg Def Gen => "moderns" ;
+    SF Pl Indef Nom => "mödrar" ;
+    SF Pl Indef Gen => "mödrars" ;
+    SF Pl Def Nom => "mödrarna" ;
+    SF Pl Def Gen => "mödrarnas"
+    } ;
+  h1 = Utr
+  } ;
+
+oper farbror_8 : Subst = 
+ {s = table {
+    SF Sg Indef Nom => variants {"farbror" ; "farbroder"} ;
+    SF Sg Indef Gen => variants {"farbrors" ; "farbroders"} ;
+    SF Sg Def Nom => "farbrodern" ;
+    SF Sg Def Gen => "farbroderns" ;
+    SF Pl Indef Nom => "farbröder" ;
+    SF Pl Indef Gen => "farbröders" ;
+    SF Pl Def Nom => "farbröderna" ;
+    SF Pl Def Gen => "farbrödernas"
+    } ;
+  h1 = Utr
+  } ;
+
+oper gammal_16 : Adj = 
+ {s = table {
+    AF (Posit (Strong (ASg Utr))) Nom => "gammal" ;
+    AF (Posit (Strong (ASg Utr))) Gen => "gammals" ;
+    AF (Posit (Strong (ASg Neutr))) Nom => "gammalt" ;
+    AF (Posit (Strong (ASg Neutr))) Gen => "gammalts" ;
+    AF (Posit (Strong APl)) Nom => "gamla" ;
+    AF (Posit (Strong APl)) Gen => "gamlas" ;
+    AF (Posit (Weak (AxSg NoMasc))) Nom => "gamla" ;
+    AF (Posit (Weak (AxSg NoMasc))) Gen => "gamlas" ;
+    AF (Posit (Weak (AxSg Masc))) Nom => "gamle" ;
+    AF (Posit (Weak (AxSg Masc))) Gen => "gamles" ;
+    AF (Posit (Weak AxPl)) Nom => "gamla" ;
+    AF (Posit (Weak AxPl)) Gen => "gamlas" ;
+    AF Compar Nom => "äldre" ;
+    AF Compar Gen => "äldres" ;
+    AF (Super SupStrong) Nom => "äldst" ;
+    AF (Super SupStrong) Gen => "äldsts" ;
+    AF (Super SupWeak) Nom => "äldsta" ;
+    AF (Super SupWeak) Gen => "äldstas"
+    }
+  } ;
+
+
+oper stor_25 : Adj = 
+ {s = table {
+    AF (Posit (Strong (ASg Utr))) Nom => "stor" ;
+    AF (Posit (Strong (ASg Utr))) Gen => "stors" ;
+    AF (Posit (Strong (ASg Neutr))) Nom => "stort" ;
+    AF (Posit (Strong (ASg Neutr))) Gen => "storts" ;
+    AF (Posit (Strong APl)) Nom => "stora" ;
+    AF (Posit (Strong APl)) Gen => "storas" ;
+    AF (Posit (Weak (AxSg NoMasc))) Nom => "stora" ;
+    AF (Posit (Weak (AxSg NoMasc))) Gen => "storas" ;
+    AF (Posit (Weak (AxSg Masc))) Nom => "store" ;
+    AF (Posit (Weak (AxSg Masc))) Gen => "stores" ;
+    AF (Posit (Weak AxPl)) Nom => "stora" ;
+    AF (Posit (Weak AxPl)) Gen => "storas" ;
+    AF Compar Nom => "större" ;
+    AF Compar Gen => "störres" ;
+    AF (Super SupStrong) Nom => "störst" ;
+    AF (Super SupStrong) Gen => "störsts" ;
+    AF (Super SupWeak) Nom => "största" ;
+    AF (Super SupWeak) Gen => "störstas"
+    }
+  } ;
+
+oper ung_29 : Adj = 
+ {s = table {
+    AF (Posit (Strong (ASg Utr))) Nom => "ung" ;
+    AF (Posit (Strong (ASg Utr))) Gen => "ungs" ;
+    AF (Posit (Strong (ASg Neutr))) Nom => "ungt" ;
+    AF (Posit (Strong (ASg Neutr))) Gen => "ungts" ;
+    AF (Posit (Strong APl)) Nom => "unga" ;
+    AF (Posit (Strong APl)) Gen => "ungas" ;
+    AF (Posit (Weak (AxSg NoMasc))) Nom => "unga" ;
+    AF (Posit (Weak (AxSg NoMasc))) Gen => "ungas" ;
+    AF (Posit (Weak (AxSg Masc))) Nom => "unge" ;
+    AF (Posit (Weak (AxSg Masc))) Gen => "unges" ;
+    AF (Posit (Weak AxPl)) Nom => "unga" ;
+    AF (Posit (Weak AxPl)) Gen => "ungas" ;
+    AF Compar Nom => "yngre" ;
+    AF Compar Gen => "yngres" ;
+    AF (Super SupStrong) Nom => "yngst" ;
+    AF (Super SupStrong) Gen => "yngsts" ;
+    AF (Super SupWeak) Nom => "yngsta" ;
+    AF (Super SupWeak) Gen => "yngstas"
+    }
+  } ;
+
+
+oper jag_32 : ProPN = 
+ {s = table {
+    PNom => "jag" ;
+    PAcc => "mig" ;
+    PGen (ASg Utr) => "min" ;
+    PGen (ASg Neutr) => "mitt" ;
+    PGen APl => "mina"
+    } ;
+  h1 = Utr ;
+  h2 = Sg ;
+  h3 = P1
+  } ;
+
+oper du_33 : ProPN = 
+ {s = table {
+    PNom => "du" ;
+    PAcc => "dig" ;
+    PGen (ASg Utr) => "din" ;
+    PGen (ASg Neutr) => "ditt" ;
+    PGen APl => "dina"
+    } ;
+  h1 = Utr ;
+  h2 = Sg ;
+  h3 = P2
+  } ;
+
+oper han_34 : ProPN = 
+ {s = table {
+    PNom => "han" ;
+    PAcc => "honom" ;
+    PGen (ASg Utr) => "hans" ;
+    PGen (ASg Neutr) => "hans" ;
+    PGen APl => "hans"
+    } ;
+  h1 = Utr ;
+  h2 = Sg ;
+  h3 = P3
+  } ;
+
+oper hon_35 : ProPN = 
+ {s = table {
+    PNom => "hon" ;
+    PAcc => "henne" ;
+    PGen (ASg Utr) => "hennes" ;
+    PGen (ASg Neutr) => "hennes" ;
+    PGen APl => "hennes"
+    } ;
+  h1 = Utr ;
+  h2 = Sg ;
+  h3 = P3
+  } ;
+
+oper vi_36 : ProPN = 
+ {s = table {
+    PNom => "vi" ;
+    PAcc => "oss" ;
+    PGen (ASg Utr) => "vår" ;
+    PGen (ASg Neutr) => "vårt" ;
+    PGen APl => "våra"
+    } ;
+  h1 = Utr ;
+  h2 = Pl ;
+  h3 = P1
+  } ;
+
+oper ni_37 : ProPN = 
+ {s = table {
+    PNom => "ni" ;
+    PAcc => "er" ;
+    PGen (ASg Utr) => "er" ;
+    PGen (ASg Neutr) => "ert" ;
+    PGen APl => "era"
+    } ;
+  h1 = Utr ;
+  h2 = Pl ;
+  h3 = P2
+  } ;
+
+oper de_38 : ProPN = 
+ {s = table {
+    PNom => "de" ;
+    PAcc => "dem" ;
+    PGen (ASg Utr) => "deras" ;
+    PGen (ASg Neutr) => "deras" ;
+    PGen APl => "deras"
+    } ;
+  h1 = Utr ;
+  h2 = Pl ;
+  h3 = P3
+  } ;
+
+oper den_39 : ProPN = 
+ {s = table {
+    PNom => "den" ;
+    PAcc => "den" ;
+    PGen (ASg Utr) => "dess" ;
+    PGen (ASg Neutr) => "dess" ;
+    PGen APl => "dess"
+    } ;
+  h1 = Utr ;
+  h2 = Sg ;
+  h3 = P3
+  } ;
+
+oper det_40 : ProPN = 
+ {s = table {
+    PNom => "det" ;
+    PAcc => "det" ;
+    PGen (ASg Utr) => "dess" ;
+    PGen (ASg Neutr) => "dess" ;
+    PGen APl => "dess"
+    } ;
+  h1 = Neutr ;
+  h2 = Sg ;
+  h3 = P3
+  } ;
+
+oper man_1144 : Subst = 
+ {s = table {
+    SF Sg Indef Nom => "man" ;
+    SF Sg Indef Gen => "mans" ;
+    SF Sg Def Nom => "mannen" ;
+    SF Sg Def Gen => "mannens" ;
+    SF Pl Indef Nom => "män" ;
+    SF Pl Indef Gen => "mäns" ;
+    SF Pl Def Nom => "männen" ;
+    SF Pl Def Gen => "männens" 
+    } ;
+  h1 = Utr
+  } ;
+
+oper liten_1146 : Adj = 
+ {s = table {
+    AF (Posit (Strong (ASg Utr))) Nom => "liten" ;
+    AF (Posit (Strong (ASg Utr))) Gen => "litens" ;
+    AF (Posit (Strong (ASg Neutr))) Nom => "litet" ;
+    AF (Posit (Strong (ASg Neutr))) Gen => "litets" ;
+    AF (Posit (Strong APl)) Nom => "små" ;
+    AF (Posit (Strong APl)) Gen => "smås" ;
+    AF (Posit (Weak (AxSg NoMasc))) Nom => "lilla" ;
+    AF (Posit (Weak (AxSg NoMasc))) Gen => "lillas" ;
+    AF (Posit (Weak (AxSg Masc))) Nom => "lille" ;
+    AF (Posit (Weak (AxSg Masc))) Gen => "lilles" ;
+    AF (Posit (Weak AxPl)) Nom => "små" ;
+    AF (Posit (Weak AxPl)) Gen => "smås" ;
+    AF Compar Nom => "mindre" ;
+    AF Compar Gen => "mindres" ;
+    AF (Super SupStrong) Nom => "minst" ;
+    AF (Super SupStrong) Gen => "minsts" ;
+    AF (Super SupWeak) Nom => "minsta" ;
+    AF (Super SupWeak) Gen => "minstas"
+    }
+  } ;
+
+oper gå_1174 : Verbum = 
+ {s = table {
+    VF (Pres Ind Act) => "går" ;
+    VF (Pres Ind Pass) => "gås" ;
+    VF (Pres Cnj Act) => "gå" ;
+    VF (Pres Cnj Pass) => "gås" ;
+    VF (Pret Ind Act) => "gick" ;
+    VF (Pret Ind Pass) => "gicks" ;
+    VF (Pret Cnj Act) => "ginge" ;
+    VF (Pret Cnj Pass) => "ginges" ;
+    VF Imper => "gå" ;
+    VI (Inf Act) => "gå" ;
+    VI (Inf Pass) => "gås" ;
+    VI (Supin Act) => "gått" ;
+    VI (Supin Pass) => "gåtts" ;
+    VI (PtPres Nom) => "gående" ;
+    VI (PtPres Gen) => "gåendes" ;
+    VI (PtPret (Strong (ASg Utr)) Nom) => "gången" ;
+    VI (PtPret (Strong (ASg Utr)) Gen) => "gångens" ;
+    VI (PtPret (Strong (ASg Neutr)) Nom) => "gånget" ;
+    VI (PtPret (Strong (ASg Neutr)) Gen) => "gångets" ;
+    VI (PtPret (Strong APl) Nom) => "gångna" ;
+    VI (PtPret (Strong APl) Gen) => "gångnas" ;
+    VI (PtPret (Weak (AxSg NoMasc)) Nom) => "gångna" ;
+    VI (PtPret (Weak (AxSg NoMasc)) Gen) => "gångnas" ;
+    VI (PtPret (Weak (AxSg Masc)) Nom) => "gångne" ;
+    VI (PtPret (Weak (AxSg Masc)) Gen) => "gångnes" ;
+    VI (PtPret (Weak AxPl) Nom) => "gångna" ;
+    VI (PtPret (Weak AxPl) Gen) => "gångnas"
+    }
+  } ;
+}
diff --git a/grammars/resource/swedish/ResSwe.gf b/grammars/resource/swedish/ResSwe.gf
new file mode 100644
index 000000000..747929d59
--- /dev/null
+++ b/grammars/resource/swedish/ResSwe.gf
@@ -0,0 +1,196 @@
+--1 The Top-Level Swedish Resource Grammar
+--
+-- Aarne Ranta 2002 -- 2003
+--
+-- This is the Swedish concrete syntax of the multilingual resource
+-- grammar. Most of the work is done in the file $syntax.Swe.gf$.
+-- However, for the purpose of documentation, we make here explicit the
+-- linearization types of each category, so that their structures and
+-- dependencies can be seen.
+-- Another substantial part are the linearization rules of some
+-- structural words.
+--
+-- The users of the resource grammar should not look at this file for the
+-- linearization rules, which are in fact hidden in the document version.
+-- They should use $resource.Abs.gf$ to access the syntactic rules.
+-- This file can be consulted in those, hopefully rare, occasions in which
+-- one has to know how the syntactic categories are
+-- implemented. The parameter types are defined in $Types.gf$.
+
+concrete ResSwe of ResAbs = open Prelude, Syntax in {
+
+flags 
+  startcat=Phr ; 
+  parser=chart ;
+
+lincat 
+  CN     = {s : Number => SpeciesP => Case => Str ; g : Gender ; x : Sex ; 
+            p : IsComplexCN} ;
+  N      = CommNoun ;
+      -- = {s : Number => Species => Case => Str ; g : Gender ; x : Sex} ;
+  NP     = NounPhrase ;
+      -- = {s : NPForm => Str ; g : Gender ; n : Number} ;
+  PN     = {s : Case => Str ; g : Gender ; x : Sex} ;
+  Det    = {s : Gender => Sex => Str ; n : Number ; b : SpeciesP} ;
+  Fun    = CommNoun ** {s2 : Preposition} ;
+
+  Adj1   = Adjective ;
+      -- = {s : AdjFormPos => Case => Str} ; 
+  Adj2   = Adjective ** {s2 : Preposition} ;
+  AdjDeg = {s : AdjForm => Str} ;
+  AP     = Adjective ** {p : IsPostfixAdj} ;
+
+  V      = Verb ;
+      -- = {s : VForm => Str} ;
+  VP     = Verb ** {s2 : Str ; s3 : Gender => Number => Str} ;
+  TV     = Verb ** {s2 : Preposition} ;
+  VS     = Verb ;
+
+  AdV    = {s : Str ; isPost : Bool} ;
+
+  S      = Sentence ;
+      -- = {s : Order => Str} ;
+  Slash  = Sentence ** {s2 : Preposition} ;
+  RP     = {s : RelCase => GenNum => Str ; g : RelGender} ;
+  RC     = {s : GenNum => Str} ;
+  IP     = NounPhrase ;
+  Qu     = {s : QuestForm => Str} ;
+  Imp    = {s : Number => Str} ;
+
+  Phr    = {s : Str} ;
+
+  Conj   = {s : Str ; n : Number} ;
+  ConjD  = {s1 : Str ; s2 : Str ; n : Number} ;
+
+  ListS  = {s1,s2 : Order => Str} ; 
+  ListAP = {s1,s2 : AdjFormPos => Case => Str ; p : Bool} ;
+  ListNP = {s1,s2 : NPForm => Str ; g : Gender ; n : Number} ;
+
+--.
+
+lin 
+  UseN = noun2CommNounPhrase ;
+  ModAdj = modCommNounPhrase ;
+  ModGenOne = npGenDet singular ;
+  ModGenMany = npGenDet plural ;
+  UsePN = nameNounPhrase ;
+  UseFun = funAsCommNounPhrase ;
+  AppFun = appFunComm ;
+  AdjP1 = adj2adjPhrase ;
+  ComplAdj = complAdj ;
+  PositAdjP = positAdjPhrase ;
+  ComparAdjP = comparAdjPhrase ;
+  SuperlNP = superlNounPhrase ;
+
+  DetNP = detNounPhrase ;
+  IndefOneNP = indefNounPhrase singular ;
+  IndefManyNP = indefNounPhrase plural ;
+  DefOneNP = defNounPhrase singular ;
+  DefManyNP = defNounPhrase plural ;
+
+  PredVP = predVerbPhrase ;
+  PosV = predVerb True ;
+  NegV = predVerb False ;
+  PosA = predAdjective True ;
+  NegA = predAdjective False ;
+  PosCN = predCommNoun True ;
+  NegCN = predCommNoun False ;
+  PosTV = complTransVerb True ;
+  NegTV = complTransVerb False ;
+  PosNP = predNounPhrase True ;
+  NegNP = predNounPhrase False ;
+  PosVS = complSentVerb True ;
+  NegVS = complSentVerb False ;
+
+
+  AdvVP = adVerbPhrase ;
+  LocNP = locativeNounPhrase ;
+  AdvCN = advCommNounPhrase ;
+
+  PosSlashTV = slashTransVerb True ;
+  NegSlashTV = slashTransVerb False ;
+
+  IdRP = identRelPron ;
+  FunRP = funRelPron ;
+  RelVP = relVerbPhrase ;
+  RelSlash = relSlash ;
+  ModRC = modRelClause ;
+  RelSuch = relSuch ;
+
+  WhoOne = intPronWho singular ;
+  WhoMany = intPronWho plural ;
+  WhatOne = intPronWhat singular ;
+  WhatMany = intPronWhat plural ;
+  FunIP = funIntPron ;
+  NounIPOne = nounIntPron singular ;
+  NounIPMany = nounIntPron plural ;
+
+  QuestVP = questVerbPhrase ;
+  IntVP = intVerbPhrase ;
+  IntSlash = intSlash ;
+  QuestAdv = questAdverbial ;
+
+  ImperVP = imperVerbPhrase ;
+
+  IndicPhrase = indicUtt ;
+  QuestPhrase = interrogUtt ;
+  ImperOne = imperUtterance singular ;
+  ImperMany = imperUtterance plural ;
+
+lin
+  TwoS = twoSentence ;
+  ConsS = consSentence ;
+  ConjS = conjunctSentence ;
+  ConjDS = conjunctDistrSentence ;
+
+  TwoAP = twoAdjPhrase ;
+  ConsAP = consAdjPhrase ;
+  ConjAP = conjunctAdjPhrase ;
+  ConjDAP = conjunctDistrAdjPhrase ;
+
+  TwoNP = twoNounPhrase ;
+  ConsNP = consNounPhrase ;
+  ConjNP = conjunctNounPhrase ;
+  ConjDNP = conjunctDistrNounPhrase ;
+
+  SubjS = subjunctSentence ;
+  SubjImper = subjunctImperative ;
+  SubjQu = subjunctQuestion ;
+
+  PhrNP = useNounPhrase ;
+  PhrOneCN = useCommonNounPhrase singular ;
+  PhrManyCN = useCommonNounPhrase plural ;
+  PhrIP ip = ip ;
+  PhrIAdv ia = ia ;
+
+  INP    = pronNounPhrase jag_32 ;
+  ThouNP = pronNounPhrase du_33 ;
+  HeNP   = pronNounPhrase han_34 ;
+  SheNP  = pronNounPhrase hon_35 ;
+  WeNP   = pronNounPhrase vi_36 ;
+  YeNP   = pronNounPhrase ni_37 ;
+  TheyNP = pronNounPhrase de_38 ;
+
+  YouNP  = let {ni = pronNounPhrase ni_37 } in {s = ni.s ; g = ni.g ; n = Sg} ;
+
+  EveryDet = varjeDet ; 
+  AllDet   = allaDet ; 
+  WhichDet = vilkenDet ;
+  MostDet  = flestaDet ;
+
+  HowIAdv = ss "hur" ;
+  WhenIAdv = ss "när" ;
+  WhereIAdv = ss "var" ;
+  WhyIAdv = ss "varför" ;
+
+  AndConj  = ss "och" ** {n = Pl}  ;
+  OrConj   = ss "eller" ** {n = Sg} ;
+  BothAnd  = sd2 "både" "och" ** {n = Pl}  ;
+  EitherOr = sd2 "antingen" "eller" ** {n = Sg} ;
+  NeitherNor = sd2 "varken" "eller" ** {n = Sg} ;
+  IfSubj   = ss "om" ;
+  WhenSubj = ss "när" ;
+
+  PhrYes = ss ["Ja ."] ;
+  PhrNo = ss ["Nej ."] ;
+} ;
diff --git a/grammars/resource/swedish/Svenska.gf b/grammars/resource/swedish/Svenska.gf
new file mode 100644
index 000000000..b86c1bb1d
--- /dev/null
+++ b/grammars/resource/swedish/Svenska.gf
@@ -0,0 +1 @@
+resource Svenska = reuse ResSwe ;
diff --git a/grammars/resource/swedish/Syntax.gf b/grammars/resource/swedish/Syntax.gf
new file mode 100644
index 000000000..dab69b406
--- /dev/null
+++ b/grammars/resource/swedish/Syntax.gf
@@ -0,0 +1,1000 @@
+--1 A Small Swedish Resource Syntax
+--
+-- Aarne Ranta 2002
+--
+-- This resource grammar contains definitions needed to construct 
+-- indicative, interrogative, and imperative sentences in Swedish.
+--
+-- The following modules are presupposed:
+
+resource Syntax = Morpho ** open Prelude, (CO = Coordination) in {
+
+--2 Common Nouns
+--
+--3 Simple common nouns
+
+oper
+  CommNoun : Type = {s : Number => Species => Case => Str ; g : Gender ; x : Sex} ;
+
+-- When common nouns are extracted from lexicon, the composite noun form is ignored.
+-- But we have to indicate a sex.
+  extCommNoun : Sex -> Subst -> CommNoun = \x,sb ->
+    {s = \\n,b,c => sb.s ! SF n b c ; 
+     g = sb.h1 ; 
+     x = x} ;
+
+-- These constants are used for data abstraction over the parameter type $Num$.
+  singular = Sg ;
+  plural = Pl ;
+
+--3 Common noun phrases
+
+-- The need for this more complex type comes from the variation in the way in
+-- which a modifying adjective is inflected after different determiners:
+-- "(en) ful orm" / "(den) fula ormen" / "(min) fula orm".
+param
+  SpeciesP = IndefP | DefP Species ;  
+
+-- We also have to be able to decide if a $CommNounPhrase$ is complex
+-- (to form the definite form: "bilen" / "den stora bilen").
+
+oper
+  IsComplexCN : Type = Bool ;         
+
+-- Coercions between simple $Species$ and $SpeciesP$:
+  unSpeciesP : SpeciesP -> Species = \b -> 
+    case b of {IndefP => Indef ; DefP p => p} ;    -- bil/bil/bilen
+  unSpeciesAdjP : SpeciesP -> Species = \b -> 
+    case b of {IndefP => Indef ; DefP _ => Def} ;  -- gammal/gamla/gamla
+
+-- Here's the type itself.
+  CommNounPhrase : Type = 
+    {s : Number => SpeciesP => Case => Str ; 
+     g : Gender ; x : Sex ; p : IsComplexCN} ;
+
+-- To use a $CommNoun$ as $CommNounPhrase$.
+  noun2CommNounPhrase : CommNoun -> CommNounPhrase = \hus ->
+    {s = \\n,b,c => hus.s ! n ! unSpeciesP b ! c ; 
+     g = hus.g ; x = hus.x ; p = False} ;
+
+  n2n = noun2CommNounPhrase ;
+
+
+--2 Noun Phrases
+--
+-- The worst case for noun phrases is pronouns, which have inflection
+-- in (what is syntactically) their genitive. Most noun phrases can
+-- ignore this variation.
+
+oper
+  npCase : NPForm -> Case = \c -> case c of {PGen _ => Gen ; _ => Nom} ;
+  mkNPForm : Case -> NPForm = \c -> case c of {Gen => PGen APl ; _ => PNom} ;
+
+  NounPhrase : Type = {s : NPForm => Str ; g : Gender ; n : Number} ;
+
+-- Proper names are a simple kind of noun phrases. However, we want to
+-- anticipate the rule that proper names can be modified by 
+-- adjectives, even though noun phrases in general cannot - hence the sex.
+
+  ProperName : Type = {s : Case => Str ; g : Gender ; x : Sex} ;
+
+  mkProperName : Str -> Gender -> Sex -> ProperName = \john,g,x -> 
+    {s = table {Nom => john ; Gen => john + "s"} ; g = g ; x = x} ;
+   
+  nameNounPhrase : ProperName -> NounPhrase = 
+    \john -> {s = table {c => john.s ! npCase c} ; g = john.g ; n = Sg} ;
+
+  pronNounPhrase : ProPN -> NounPhrase = \jag -> 
+    {s = jag.s ; g = jag.h1 ; n = jag.h2} ;
+
+--2 Determiners
+--
+-- Determiners are inflected according to noun in gender and sex. 
+-- The number and species of the noun are determined by the determiner.
+
+  Determiner : Type = {s : Gender => Sex => Str ; n : Number ; b : SpeciesP} ;
+
+-- This is the rule for building noun phrases.
+
+  detNounPhrase : Determiner -> CommNounPhrase -> NounPhrase = \en, man -> 
+    {s = table {c => en.s ! man.g ! man.x ++ man.s ! en.n ! en.b ! npCase c} ;
+     g = man.g ; n = en.n} ;
+
+-- The following macros are sufficient to define most determiners.
+-- All $SpeciesP$ values come into question: 
+-- "en god vän" - "min gode vän" - "den gode vännen".
+
+  DetSg : Type = Gender => Sex => Str ;
+  DetPl : Type = Str ;
+
+  mkDeterminerSg :  DetSg -> SpeciesP -> Determiner = \en, b -> 
+    {s = en ; n = Sg ; b = b} ;
+
+  mkDeterminerPl :  DetPl -> SpeciesP -> Determiner = \alla, b -> 
+    {s = table {_ => table {_ => alla}} ; n = Pl ; b = b} ;
+
+  detSgInvar : Str -> DetSg = \varje -> table {_ => table {_ => varje}} ;
+
+-- A large class of determiners can be built from a gender-dependent table.
+
+  mkDeterminerSgGender : (Gender => Str) -> SpeciesP -> Determiner = \en -> 
+    mkDeterminerSg (table {g => table {_ => en ! g}}) ;
+
+-- Here are some examples. We are in fact doing some ad hoc morphology here, 
+-- instead of importing the lexicon.
+
+  varjeDet = mkDeterminerSg (detSgInvar "varje") IndefP ;
+  allaDet  = mkDeterminerPl "alla" IndefP ;
+  enDet    = mkDeterminerSgGender artIndef IndefP ;
+
+  flestaDet = mkDeterminerPl ["de flesta"] IndefP ;
+  vilkenDet = mkDeterminerSgGender 
+                (table {Utr => "vilken" ; Neutr => "vilket"}) IndefP ;
+  vilkaDet  = mkDeterminerPl "vilka" IndefP ;
+
+  vilkDet : Number -> Determiner = \n -> case n of {
+    Sg => vilkenDet ;
+    Pl => vilkaDet
+    } ;
+
+  någDet : Number -> Determiner = \n -> case n of {
+    Sg => mkDeterminerSgGender 
+                (table {Utr => "någon" ; Neutr => "något"}) IndefP ;
+    Pl =>  mkDeterminerPl "några" IndefP
+    } ;
+
+
+-- Genitives of noun phrases can be used like determiners, to build noun phrases.
+-- The number argument makes the difference between "min bil" - "mina bilar".
+
+  npGenDet : Number -> NounPhrase -> CommNounPhrase -> NounPhrase = 
+    \n,huset,vin -> {
+       s = \\c => case n of {
+             Sg => huset.s ! PGen (ASg vin.g) ++ 
+                   vin.s ! Sg ! DefP Indef ! npCase c ;
+             Pl => huset.s ! PGen APl ++ 
+                   vin.s ! Pl ! DefP Indef ! npCase c
+             } ;
+       g = vin.g ;
+       n = n  
+       } ;
+
+-- *Bare plural noun phrases* like "män", "goda vänner", are built without a 
+-- determiner word.
+
+  plurDet : CommNounPhrase -> NounPhrase = \cn -> 
+    {s = \\c => cn.s ! Pl ! IndefP ! npCase c ; 
+     g = cn.g ; 
+     n = Pl
+    } ;
+
+-- Definite phrases in Swedish are special, since determiner may be absent 
+-- depending on if the noun is complex: "bilen" - "den nya bilen".
+
+  denDet : CommNounPhrase -> NounPhrase = \cn -> 
+    detNounPhrase 
+      (mkDeterminerSgGender (table {g => artDef ! cn.p ! ASg g}) (DefP Def)) cn ;
+  deDet : CommNounPhrase -> NounPhrase = \cn -> 
+    detNounPhrase (mkDeterminerPl (artDef ! cn.p ! APl) (DefP Def)) cn ;
+
+-- It is useful to have macros for indefinite and definite, singular and plural
+-- noun-phrase-like syncategorematic expressions.
+
+  indefNounPhrase : Number -> CommNounPhrase -> NounPhrase = \n,hus -> case n of {
+    Sg => detNounPhrase enDet hus ;
+    Pl => plurDet hus
+    } ;
+
+  defNounPhrase : Number -> CommNounPhrase -> NounPhrase = \n,hus -> case n of {
+    Sg => denDet hus ;
+    Pl => deDet  hus
+    } ;
+
+  indefNoun : Number -> CommNounPhrase -> Str = \n,man -> case n of {
+    Sg => artIndef ! man.g ++ man.s ! Sg ! IndefP ! Nom ;
+    Pl => man.s ! Pl ! IndefP ! Nom
+    } ;
+
+--2 Adjectives
+--3 Simple adjectives
+--
+-- A special type of adjectives just having positive forms (for semantic reasons) 
+-- is useful, e.g. "finsk", "trekantig".
+ 
+  Adjective : Type = {s : AdjFormPos => Case => Str} ;
+
+  extAdjective : Adj -> Adjective = \adj ->
+    {s = table {f => table {c => adj.s ! AF (Posit f) c}}} ;
+
+-- Coercions between the compound gen-num type and gender and number:
+
+  gNum : Gender -> Number -> GenNum = \g,n -> 
+    case n of {Sg => ASg g ; Pl => APl} ;
+
+  genGN : GenNum -> Gender = \gn -> 
+    case gn of {ASg g => g ; _ => Utr} ;
+  numGN : GenNum -> Number = \gn -> 
+    case gn of {ASg _ => Sg ; APl => Pl} ;
+
+--3 Adjective phrases
+-- 
+-- An adjective phrase may contain a complement, e.g. "yngre än Rolf".
+-- Then it is used as postfix in modification, e.g. "en man yngre än Rolf".
+
+  IsPostfixAdj = Bool ;
+
+  AdjPhrase : Type = Adjective ** {p : IsPostfixAdj} ;
+
+-- Simple adjectives are not postfix:
+
+  adj2adjPhrase : Adjective -> AdjPhrase = \ny -> ny ** {p = False} ;
+
+--3 Comparison adjectives
+
+-- We take comparison adjectives directly from 
+-- the lexicon, which has full adjectives:
+
+  AdjDegr = Adj ; 
+
+-- Each of the comparison forms has a characteristic use:
+--
+-- Positive forms are used alone, as adjectival phrases ("ung").
+
+  positAdjPhrase : AdjDegr -> AdjPhrase = \ung ->
+    {s = table {a => \\c => ung.s ! AF (Posit a) c} ; 
+     p = False
+    } ;
+
+-- Comparative forms are used with an object of comparison, as
+-- adjectival phrases ("yngre än Rolf").
+
+  comparAdjPhrase : AdjDegr -> NounPhrase -> AdjPhrase = \yngre,rolf ->
+    {s = \\_, c => yngre.s ! AF Compar Nom ++ "än" ++ rolf.s ! mkNPForm c ;
+     p = True
+    } ;
+
+-- Superlative forms are used with a modified noun, picking out the
+-- maximal representative of a domain ("den yngste mannen").
+
+  superlNounPhrase : AdjDegr -> CommNounPhrase -> NounPhrase = \yngst,man ->
+    {s = \\c => let {gn = gNum man.g Sg} in 
+                artDef ! True ! gn ++ 
+                yngst.s ! AF (Super SupWeak) Nom ++
+                man.s ! Sg ! DefP Def ! npCase c ; 
+     g = man.g ; 
+     n = Sg
+    } ;
+
+-- Moreover, superlatives can be used alone as adjectival phrases
+-- ("yngst", "den yngste" - in free variation). 
+-- N.B. the former is only permitted in predicative position.
+
+  superlAdjPhrase : AdjDegr -> AdjPhrase = \ung ->
+    {s = \\a,c => variants {
+    ---       artDef ! True ! gn ++ yngst.s ! AF (Super SupWeak) c
+           ung.s ! AF (Super SupStrong) c 
+           } ; 
+     p = False
+    } ;
+
+--3 Two-place adjectives
+--
+-- A two-place adjective is an adjective with a preposition used before
+-- the complement. (Rem. $Preposition = Str$).
+
+  AdjCompl = Adjective ** {s2 : Preposition} ;
+
+  complAdj : AdjCompl -> NounPhrase -> AdjPhrase = \förtjust,dig ->
+    {s = \\a,c => förtjust.s ! a ! c ++ förtjust.s2 ++ dig.s ! PAcc ;
+     p = True
+    } ;
+
+
+--3 Modification of common nouns
+--
+-- The two main functions of adjective are in predication ("Johan är ung")
+-- and in modification ("en ung man"). Predication will be defined
+-- later, in the chapter on verbs.
+
+  modCommNounPhrase : AdjPhrase -> CommNounPhrase -> CommNounPhrase = \God,Nybil ->
+    {s = \\n, b, c =>
+           let {
+             god   = God.s ! mkAdjForm (unSpeciesAdjP b) n Nybil.g Nybil.x ! Nom ;
+             nybil = Nybil.s ! n ! b ! c
+             } in
+           preOrPost God.p nybil god ;
+     g = Nybil.g ; 
+     x = Nybil.x ; 
+     p = True} ;    
+
+-- A special case is modification of a noun that has not yet been modified.
+-- But it is simply a special case.
+
+  modCommNoun : Adjective -> CommNoun -> CommNounPhrase = \god,bil ->
+    modCommNounPhrase (adj2adjPhrase god) (n2n bil) ;
+
+-- We have used a straightforward 
+-- method building adjective forms from simple parameters.
+
+  mkAdjForm : Species -> Number -> Gender -> Sex -> AdjFormPos = \b,n,g,x -> 
+    case <b,n> of {
+      <Indef,Sg> => Strong (ASg g) ;
+      <Indef,Pl> => Strong APl ;
+      <Def,  Sg> => Weak (AxSg x) ; ---- add masc!
+      <Def,  Pl> => Weak AxPl
+      } ;
+
+
+--2 Function expressions
+
+-- A function expression is a common noun together with the
+-- preposition prefixed to its argument ("mor till x").
+-- The type is analogous to two-place adjectives and transitive verbs.
+
+  Function = CommNoun ** {s2 : Preposition} ;
+
+  mkFun : CommNoun -> Preposition -> Function = \f,p ->
+    f ** {s2 = p} ;
+
+-- The application of a function gives, in the first place, a common noun:
+-- "mor/mödrar till Johan". From this, other rules of the resource grammar 
+-- give noun phrases, such as "modern till Johan", "mödrarna till Johan",
+-- "mödrarna till Johan och Maria", and "modern till Johan och Maria" (the
+-- latter two corresponding to distributive and collective functions,
+-- respectively). Semantics will eventually tell when each
+-- of the readings is meaningful.
+
+  appFunComm : Function -> NounPhrase -> CommNounPhrase = \värde,x -> 
+    noun2CommNounPhrase
+      {s = \\n,b => table {
+              Gen => nonExist ;
+              _ => värde.s ! n ! b ! Nom ++ värde.s2 ++ x.s ! PAcc
+              } ;
+       g = värde.g ;
+       x = värde.x
+      } ;
+
+-- It is possible to use a function word as a common noun; the semantics is
+-- often existential or indexical.
+
+  funAsCommNounPhrase : Function -> CommNounPhrase = 
+    noun2CommNounPhrase ;
+
+-- The following is an aggregate corresponding to the original function application
+-- producing "Johans mor" and "modern till Johan". It does not appear in the
+-- resource grammar API any longer.
+
+  appFun : Bool -> Function -> NounPhrase -> NounPhrase = \coll,värde,x -> 
+    let {n = x.n ; nf = if_then_else Number coll Sg n} in 
+    variants {
+      defNounPhrase nf (appFunComm värde x) ;
+      npGenDet nf x (noun2CommNounPhrase värde)
+      } ;
+
+
+
+--2 Verbs
+
+-- Although the Swedish lexicon has full verb inflection, 
+-- we have limited this first version of the resource syntax to
+-- verbs in present tense. Their mode can be infinitive, imperative, and indicative.
+
+
+--3 Verb phrases
+--
+-- Verb phrases are discontinuous: the parts of a verb phrase are
+-- (s) an inflected verb, (s2) verb adverbials (such as negation), and
+-- (s3) complement. This discontinuity is needed in sentence formation
+-- to account for word order variations.
+
+  VerbPhrase : Type = Verb ** {s2 : Str ; s3 : Gender => Number => Str} ;
+
+-- A simple verb can be made into a verb phrase with an empty complement.
+-- There are two versions, depending on if we want to negate the verb.
+-- N.B. negation is *not* a function applicable to a verb phrase, since
+-- double negations with "inte" are not grammatical.
+
+  predVerb : Bool -> Verb -> VerbPhrase = \b,se -> 
+    se ** {
+     s2 = negation b ; 
+     s3 = \\_,_ => []
+     } ;
+
+  negation : Bool -> Str = \b -> if_then_else Str b [] "inte" ;
+
+-- Sometimes we want to extract the verb part of a verb phrase.
+
+  verbOfPhrase : VerbPhrase -> Verb = \v -> {s = v.s} ;
+
+-- Verb phrases can also be formed from adjectives ("är snäll"),
+-- common nouns ("är en man"), and noun phrases ("är den yngste mannen").
+-- The third rule is overgenerating: "är varje man" has to be ruled out
+-- on semantic grounds.
+
+  predAdjective : Bool -> Adjective -> VerbPhrase = \b,arg ->
+    verbVara ** {
+      s2 = negation b ; 
+      s3 = \\g,n => arg.s ! mkAdjForm Indef n g NoMasc ! Nom
+      } ;
+
+  predCommNoun : Bool -> CommNounPhrase -> VerbPhrase = \b,man ->
+    verbVara ** {
+      s2 = negation b ;
+      s3 = \\_,n => indefNoun n man
+     } ;
+
+  predNounPhrase : Bool -> NounPhrase -> VerbPhrase = \b,john ->
+    verbVara ** {
+      s2 = negation b ;
+      s3 = \\_,_ => john.s ! PNom
+    } ;
+
+--3 Transitive verbs
+--
+-- Transitive verbs are verbs with a preposition for the complement,
+-- in analogy with two-place adjectives and functions.
+-- One might prefer to use the term "2-place verb", since
+-- "transitive" traditionally means that the inherent preposition is empty.
+-- Such a verb is one with a *direct object*.
+
+  TransVerb : Type = Verb ** {s2 : Preposition} ; 
+
+  mkTransVerb : Verb -> Preposition -> TransVerb = \v,p -> 
+    v ** {s2 = p} ;
+
+  mkDirectVerb : Verb -> TransVerb = \v -> 
+    mkTransVerb v nullPrep ;
+
+  nullPrep : Preposition = [] ;
+
+  extTransVerb : Verbum -> Preposition -> TransVerb =
+    \v -> mkTransVerb (extVerb Act v) ;
+
+-- The rule for using transitive verbs is the complementization rule:
+
+  complTransVerb : Bool -> TransVerb -> NounPhrase -> VerbPhrase = \b,se,dig ->
+    {s = se.s ; s2 = negation b ; s3 = \\_,_ => se.s2 ++ dig.s ! PAcc} ;
+
+--2 Adverbials
+--
+-- Adverbials that modify verb phrases are either post- or pre-verbal.
+-- As a rule of thumb, simple adverbials ("bra","alltid") are pre-verbal,
+-- but this is not always the case ("här" is post-verbal).
+
+  Adverb : Type = SS ** {isPost : Bool} ;
+
+  advPre  : Str -> Adverb = \alltid -> ss alltid ** {isPost = False} ;
+  advPost : Str -> Adverb = \bra    -> ss bra    ** {isPost = True} ;
+
+  adVerbPhrase : VerbPhrase -> Adverb -> VerbPhrase = \spelar, bra ->
+    let {postp = bra.isPost} in
+    {
+  --- this unfortunately generates  VP#2 ::= VP#2
+     s  = spelar.s ; 
+     s2 = (if_then_else Str postp [] bra.s) ++ spelar.s2 ;
+     s3 = \\g,n => spelar.s3 ! g ! n ++ (if_then_else Str postp bra.s [])
+    } ;
+
+-- Adverbials are typically generated by prefixing prepositions.
+-- The rule for creating locative noun phrases by the preposition "i"
+-- is a little shaky: "i Sverige" but "på Island".
+
+  prepPhrase : Preposition -> NounPhrase -> Adverb = \i,huset ->
+    advPost (i ++ huset.s ! PAcc) ;
+
+  locativeNounPhrase : NounPhrase -> Adverb = 
+    prepPhrase "i" ;
+
+-- This is a source of the "mannen med teleskopen" ambiguity, and may produce
+-- strange things, like "bilar alltid" (while "bilar idag" is OK).
+-- Semantics will have to make finer distinctions among adverbials.
+
+  advCommNounPhrase : CommNounPhrase -> Adverb -> CommNounPhrase = \bil,idag ->
+    {s = \\n, b, c => bil.s ! n ! b ! c ++ idag.s ;
+     g = bil.g ; 
+     x = bil.x ; 
+     p = bil.p} ;    
+
+
+--2 Sentences
+--
+-- Sentences depend on a *word order parameter* selecting between main clause,
+-- inverted, and subordinate clause.
+
+param
+  Order = Main | Inv | Sub ;
+
+oper
+  Sentence : Type = SS1 Order ;
+
+-- This is the traditional $S -> NP VP$ rule. It takes care of both
+-- word order and agreement.
+
+  predVerbPhrase : NounPhrase -> VerbPhrase -> Sentence = 
+    \Jag, serdiginte -> 
+    let {
+      jag  = Jag.s ! PNom ; 
+      ser  = serdiginte.s ! Indicat ;
+      dig  = serdiginte.s3 ! Jag.g ! Jag.n ;
+      inte = serdiginte.s2
+    } in
+    {s = table {
+       Main => jag ++ ser ++ inte ++ dig ;  
+       Inv  => ser ++ jag ++ inte ++ dig ;
+       Sub  => jag ++ inte ++ ser ++ dig
+       }
+    } ;
+
+-- This is a macro for simultaneous predication and complementation.
+
+  predTransVerb : Bool -> NounPhrase -> TransVerb -> NounPhrase -> Sentence = 
+    \b,jag,ser,dig -> predVerbPhrase jag (complTransVerb b ser dig) ;
+
+--3 Sentence-complement verbs
+--
+-- Sentence-complement verbs take sentences as complements.
+
+  SentenceVerb : Type = Verb ;
+
+  complSentVerb : Bool -> SentenceVerb -> Sentence -> VerbPhrase = \b,se,duler ->
+    {s = se.s ; s2 = negation b ; s3 = \\_,_ => optStr "att" ++ duler.s ! Main} ;
+
+
+
+--2 Sentences missing noun phrases
+--
+-- This is one instance of Gazdar's *slash categories*, corresponding to his
+-- $S/NP$.
+-- We cannot have - nor would we want to have - a productive slash-category former.
+-- Perhaps a handful more will be needed.
+--
+-- Notice that the slash category has the same relation to sentences as
+-- transitive verbs have to verbs: it's like a *sentence taking a complement*.
+
+  SentenceSlashNounPhrase : Type = Sentence ** {s2 : Preposition} ;
+
+  slashTransVerb : Bool -> NounPhrase -> TransVerb -> SentenceSlashNounPhrase = 
+    \b, Jag, se -> 
+    let {
+      jag  = Jag.s ! PNom ; 
+      ser  = se.s ! Indicat ;
+      inte = negation b
+    } in
+    {s = table {
+       Main => jag ++ ser ++ inte ;  
+       Inv  => ser ++ jag ++ inte ;
+       Sub  => jag ++ inte ++ ser
+       } ;
+     s2 = se.s2
+    } ;
+
+
+--2 Relative pronouns and relative clauses
+--
+-- Relative pronouns can be nominative, accusative, or genitive, and
+-- they depend on gender and number just like adjectives.
+-- Moreover they may or may not carry their own genders: for instance,
+-- "som" just transmits the gender of a noun ("tal som är primt"), whereas
+-- "vars efterföljare" is $Utrum$ independently of the noun 
+-- ("tal vars efterföljare är prim"). 
+-- This variation is expressed by the $RelGender$ type.
+
+  RelPron : Type = {s : RelCase => GenNum => Str ; g : RelGender} ;
+
+param
+  RelGender = RNoGen | RG Gender ;
+
+-- The following functions are selectors for relative-specific parameters.
+ 
+oper
+  -- this will be needed in "tal som är jämnt" / "tal vars efterföljare är jämn"
+  mkGenderRel : RelGender -> Gender -> Gender = \rg,g -> case rg of {
+    RG gen => gen ;
+    _      => g
+    } ;
+
+  relCase : RelCase -> Case = \c -> case c of {
+    RGen => Gen ;
+    _    => Nom
+    } ; 
+
+-- The simplest relative pronoun has no gender of its own. As accusative variant,
+-- it has the omission of the pronoun ("mannen (som) jag ser").
+
+  identRelPron : RelPron = 
+    {s = table {
+      RNom  => \\_ => "som" ;
+      RAcc  => \\_ => variants {"som" ; []} ;
+      RGen  => \\_ => "vars" ;
+      RPrep => pronVilken
+      } ;
+     g = RNoGen
+    } ;
+
+-- Composite relative pronouns have the same variation as function
+-- applications ("efterföljaren till vilket" - "vars efterföljare").
+
+  funRelPron : Function -> RelPron -> RelPron = \värde,vilken -> 
+    {s = \\c,gn => 
+           variants {
+             vilken.s ! RGen ! gn ++ värde.s ! numGN gn ! Indef ! relCase c ; 
+             värde.s ! numGN gn ! Def ! Nom ++ värde.s2 ++ vilken.s ! RPrep ! gn
+             } ;
+     g = RG värde.g
+    } ;
+
+-- Relative clauses can be formed from both verb phrases ("som sover") and
+-- slash expressions ("som jag ser"). The latter has moreover the variation
+-- as for the place of the preposition ("som jag talar om" - "om vilken jag talar").
+
+  RelClause : Type = {s : GenNum => Str} ;
+
+  relVerbPhrase : RelPron -> VerbPhrase -> RelClause = \som,sover ->
+    {s = \\gn => 
+       som.s ! RNom ! gn ++ sover.s2 ++ sover.s ! Indicat ++ 
+       sover.s3 ! mkGenderRel som.g (genGN gn) ! numGN gn
+    } ;
+
+  relSlash : RelPron -> SentenceSlashNounPhrase -> RelClause = \som,jagTalar ->
+    {s = \\gn => 
+           let {jagtalar = jagTalar.s ! Sub ; om = jagTalar.s2} in
+           variants {
+             som.s ! RAcc ! gn ++ jagtalar ++ om ;
+             om ++ som.s ! RPrep ! gn ++ jagtalar
+             }
+    } ;
+
+-- A 'degenerate' relative clause is the one often used in mathematics, e.g.
+-- "tal x sådant att x är primt".
+
+  relSuch : Sentence -> RelClause = \A ->
+    {s = \\g => pronSådan ! g ++ "att" ++ A.s ! Sub} ;
+
+-- The main use of relative clauses is to modify common nouns.
+-- The result is a common noun, out of which noun phrases can be formed
+-- by determiners.
+
+  modRelClause : CommNounPhrase -> RelClause -> CommNounPhrase = \man,somsover ->
+    {s = \\n,b,c => man.s ! n ! b ! c ++ somsover.s ! gNum man.g n ;
+     g = man.g ;
+     x = man.x ;
+     p = False
+    } ;
+
+-- N.B. we do not get the determinative pronoun
+-- construction "den man som sover" in this way, but only "mannen som sover".
+-- Thus we need an extra rule:
+
+  detRelClause : Number -> CommNounPhrase -> RelClause -> NounPhrase = 
+    \n,man,somsover ->
+    {s = \\c => let {gn = gNum man.g n} in 
+                artDef ! True ! gn ++ 
+                man.s ! n ! DefP Indef ! npCase c ++ somsover.s ! gn ;
+     g = man.g ;
+     n = n
+    } ;
+
+
+--2 Interrogative pronouns
+--
+-- If relative pronouns are adjective-like, interrogative pronouns are
+-- noun-phrase-like. Actually we can use the very same type!
+
+  IntPron : Type = NounPhrase ; 
+
+-- In analogy with relative pronouns, we have a rule for applying a function
+-- to a relative pronoun to create a new one. We can reuse the rule applying
+-- functions to noun phrases!
+
+  funIntPron : Function -> IntPron -> IntPron = 
+    appFun False ; 
+
+-- There is a variety of simple interrogative pronouns:
+-- "vilken bil", "vem", "vad".
+
+  nounIntPron : Number -> CommNounPhrase -> IntPron = \n ->
+    detNounPhrase (vilkDet n) ;
+
+  intPronWho : Number -> IntPron = \num -> {
+    s = table {
+      PGen _ => "vems" ;
+      _      => "vem"
+      } ;
+    g = Utr ;
+    n = num
+  } ;
+
+  intPronWhat : Number -> IntPron = \num -> {
+    s = table {
+      PGen  _ => nonExist ; ---
+      _ => "vad"
+      } ;
+    n = num ;
+    g = Neutr
+  } ;
+
+--2 Utterances
+
+-- By utterances we mean whole phrases, such as 
+-- 'can be used as moves in a language game': indicatives, questions, imperative,
+-- and one-word utterances. The rules are far from complete.
+--
+-- N.B. we have not included rules for texts, which we find we cannot say much
+-- about on this level. In semantically rich GF grammars, texts, dialogues, etc, 
+-- will of course play an important role as categories not reducible to utterances.
+-- An example is proof texts, whose semantics show a dependence between premises
+-- and conclusions. Another example is intersentential anaphora.
+
+  Utterance = SS ;
+  
+  indicUtt : Sentence -> Utterance = \x -> postfixSS "." (defaultSentence x) ;
+  interrogUtt : Question -> Utterance = \x -> postfixSS "?" (defaultQuestion x) ;
+
+
+--2 Questions
+--
+-- Questions are either direct ("vem tog bollen") or indirect 
+-- ("vem som tog bollen").
+
+param 
+  QuestForm = DirQ | IndirQ ;
+
+oper
+  Question = SS1 QuestForm ;
+
+--3 Yes-no questions 
+--
+-- Yes-no questions are used both independently ("tog du bollen")
+-- and after interrogative adverbials ("varför tog du bollen").
+-- It is economical to handle with these two cases by the one
+-- rule, $questVerbPhrase'$. The only difference is if "om" appears
+-- in the indirect form.
+
+  questVerbPhrase : NounPhrase -> VerbPhrase -> Question = 
+    questVerbPhrase' False ;
+
+  questVerbPhrase' : Bool -> NounPhrase -> VerbPhrase -> Question = 
+    \adv,du,sover ->
+    let {dusover = (predVerbPhrase du sover).s} in
+    {s = table {
+      DirQ   => dusover ! Inv ;
+      IndirQ => (if_then_else Str adv [] "om") ++ dusover ! Sub
+      }
+    } ;
+
+--3 Wh-questions
+--
+-- Wh-questions are of two kinds: ones that are like $NP - VP$ sentences,
+-- others that are line $S/NP - NP$ sentences.
+
+  intVerbPhrase : IntPron -> VerbPhrase -> Question = \vem,sover ->
+    let {vemsom : NounPhrase = 
+           {s = \\c => vem.s ! c ++ "som" ; g = vem.g ; n = vem.n}
+        } in
+    {s = table {
+      DirQ   => (predVerbPhrase vem    sover).s ! Main ;
+      IndirQ => (predVerbPhrase vemsom sover).s ! Sub 
+      }
+    } ;
+
+  intSlash : IntPron -> SentenceSlashNounPhrase -> Question = \Vem, jagTalar ->
+    let {
+      vem = Vem.s ! PAcc ; 
+      jagtalar = jagTalar.s ! Sub ; 
+      talarjag = jagTalar.s ! Inv ; 
+      om = jagTalar.s2
+      } in
+    {s = table {
+      DirQ => variants {
+                vem ++ talarjag ++ om ;
+                om ++ vem ++ talarjag
+                } ;
+      IndirQ => variants {
+                vem ++ jagtalar ++ om ;
+                om ++ vem ++ jagtalar
+                }
+      } 
+    } ;
+
+--3 Interrogative adverbials
+--
+-- These adverbials will be defined in the lexicon: they include
+-- "när", "var", "hur", "varför", etc, which are all invariant one-word
+-- expressions. In addition, they can be formed by adding prepositions
+-- to interrogative pronouns, in the same way as adverbials are formed
+-- from noun phrases. N.B. we rely on record subtyping when ignoring the
+-- position component.
+
+  IntAdverb = SS ;
+
+  prepIntAdverb : Preposition -> IntPron -> IntAdverb =
+    prepPhrase ;
+
+-- A question adverbial can be applied to anything, and whether this makes
+-- sense is a semantic question.
+
+  questAdverbial : IntAdverb -> NounPhrase -> VerbPhrase -> Question = 
+    \hur, du, mår ->
+    {s = \\q => hur.s ++ (questVerbPhrase' True du mår).s ! q} ;
+
+
+--2 Imperatives
+--
+-- We only consider second-person imperatives.
+
+  Imperative = SS1 Number ;
+
+  imperVerbPhrase : VerbPhrase -> Imperative = \titta -> 
+    {s = \\n => titta.s ! Imperat ++ titta.s2 ++ titta.s3 ! Utr ! n} ;  
+
+  imperUtterance : Number -> Imperative -> Utterance = \n,I ->
+    ss (I.s ! n ++ "!") ;
+
+
+--2 Coordination
+--
+-- Coordination is to some extent orthogonal to the rest of syntax, and
+-- has been treated in a generic way in the module $CO$ in the file
+-- $coordination.gf$. The overall structure is independent of category,
+-- but there can be differences in parameter dependencies.
+--
+--3 Conjunctions
+--
+-- Coordinated phrases are built by using conjunctions, which are either
+-- simple ("och", "eller") or distributed ("både - och", "antingen - eller").
+--
+-- The conjunction has an inherent number, which is used when conjoining
+-- noun phrases: "John och Mary är rika" vs. "John eller Mary är rik"; in the
+-- case of "eller", the result is however plural if any of the disjuncts is.
+
+  Conjunction = CO.Conjunction ** {n : Number} ;
+  ConjunctionDistr = CO.ConjunctionDistr ** {n : Number} ;
+
+
+--3 Coordinating sentences
+--
+-- We need a category of lists of sentences. It is a discontinuous
+-- category, the parts corresponding to 'init' and 'last' segments
+-- (rather than 'head' and 'tail', because we have to keep track of the slot between
+-- the last two elements of the list). A list has at least two elements.
+
+  ListSentence : Type = {s1,s2 : Order => Str} ; 
+
+  twoSentence : (_,_ : Sentence) -> ListSentence = 
+    CO.twoTable Order ;
+
+  consSentence : ListSentence -> Sentence -> ListSentence = 
+    CO.consTable Order CO.comma ;
+
+-- To coordinate a list of sentences by a simple conjunction, we place
+-- it between the last two elements; commas are put in the other slots,
+-- e.g. "månen lyser, solen skiner och stjärnorna blinkar".
+
+  conjunctSentence : Conjunction -> ListSentence -> Sentence = 
+    CO.conjunctTable Order ;
+
+  conjunctOrd : Bool -> Conjunction -> CO.ListTable Order -> {s : Order => Str} = 
+    \b,or,xs ->
+    {s = \\p => xs.s1 ! p ++ or.s ++ xs.s2 ! p} ;
+
+
+-- To coordinate a list of sentences by a distributed conjunction, we place
+-- the first part (e.g. "antingen") in front of the first element, the second
+-- part ("eller") between the last two elements, and commas in the other slots.
+-- For sentences this is really not used.
+
+  conjunctDistrSentence : ConjunctionDistr -> ListSentence -> Sentence = 
+    CO.conjunctDistrTable Order ;
+
+--3 Coordinating adjective phrases
+--
+-- The structure is the same as for sentences. The result is a prefix adjective
+-- if and only if all elements are prefix.
+
+  ListAdjPhrase : Type = 
+    {s1,s2 : AdjFormPos => Case => Str ; p : Bool} ;
+
+  twoAdjPhrase : (_,_ : AdjPhrase) -> ListAdjPhrase = \x,y ->
+    CO.twoTable2 AdjFormPos Case x y ** {p = andB x.p y.p} ;
+  consAdjPhrase : ListAdjPhrase -> AdjPhrase -> ListAdjPhrase =  \xs,x ->
+    CO.consTable2 AdjFormPos Case CO.comma xs x ** {p = andB xs.p x.p} ;
+
+  conjunctAdjPhrase : Conjunction -> ListAdjPhrase -> AdjPhrase = \c,xs ->
+    CO.conjunctTable2 AdjFormPos Case c xs ** {p = xs.p} ;
+
+  conjunctDistrAdjPhrase : ConjunctionDistr -> ListAdjPhrase -> AdjPhrase = \c,xs ->
+    CO.conjunctDistrTable2 AdjFormPos Case c xs ** {p = xs.p} ;
+
+
+--3 Coordinating noun phrases
+--
+-- The structure is the same as for sentences. The result is either always plural
+-- or plural if any of the components is, depending on the conjunction.
+-- The gender is neuter if any of the components is.
+
+  ListNounPhrase : Type = {s1,s2 : NPForm => Str ; g : Gender ; n : Number} ;
+
+  twoNounPhrase : (_,_ : NounPhrase) -> ListNounPhrase = \x,y ->
+    CO.twoTable NPForm x y ** {n = conjNumber x.n y.n ; g = conjGender x.g y.g} ;
+
+  consNounPhrase : ListNounPhrase -> NounPhrase -> ListNounPhrase =  \xs,x ->
+    CO.consTable NPForm CO.comma xs x ** 
+       {n = conjNumber xs.n x.n ; g = conjGender xs.g x.g} ;
+
+  conjunctNounPhrase : Conjunction -> ListNounPhrase -> NounPhrase = \c,xs ->
+    CO.conjunctTable NPForm c xs ** {n = conjNumber c.n xs.n ; g = xs.g} ;
+
+  conjunctDistrNounPhrase : ConjunctionDistr -> ListNounPhrase -> NounPhrase = 
+    \c,xs ->
+    CO.conjunctDistrTable NPForm c xs ** {n = conjNumber c.n xs.n ; g = xs.g} ;
+
+-- We hve to define a calculus of numbers of genders. For numbers,
+-- it is like the conjunction with $Pl$ corresponding to $False$. For genders,
+-- $Neutr$ corresponds to $False$.
+
+  conjNumber : Number -> Number -> Number = \m,n -> case <m,n> of {
+    <Sg,Sg> => Sg ;
+    _ => Pl 
+    } ;
+
+  conjGender : Gender -> Gender -> Gender = \m,n -> case <m,n> of {
+    <Utr,Utr> => Utr ;
+    _ => Neutr 
+    } ;
+
+
+--2 Subjunction
+--
+-- Subjunctions ("om", "när", etc) 
+-- are a different way to combine sentences than conjunctions.
+-- The main clause can be a sentences, an imperatives, or a question,
+-- but the subjoined clause must be a sentence.
+--
+-- There are uniformly two variant word orders, e.g. "om du sover kommer björnen"
+-- and "björnen kommer om du sover".
+
+  Subjunction = SS ;
+
+  subjunctSentence : Subjunction -> Sentence -> Sentence -> Sentence = \if, A, B ->
+    let {As = A.s ! Sub} in 
+    {s = table {
+           Main => variants {if.s ++ As ++ "," ++ B.s ! Inv ; 
+                             B.s ! Main ++ "," ++ if.s ++ As} ;
+           o    => B.s ! o ++ "," ++ if.s ++ As
+           } 
+     } ;
+
+  subjunctImperative : Subjunction -> Sentence -> Imperative -> Imperative = 
+    \if, A, B -> 
+    {s = \\n => subjunctVariants if A (B.s ! n)} ;
+
+  subjunctQuestion : Subjunction -> Sentence -> Question -> Question = \if, A, B ->
+    {s = \\q => subjunctVariants if A (B.s ! q)} ;
+
+  subjunctVariants : Subjunction -> Sentence -> Str -> Str = \if,A,B ->
+    let {As = A.s ! Sub} in 
+    variants {if.s ++ As ++ "," ++ B ; B ++ "," ++ if.s ++ As} ;
+
+--2 One-word utterances
+-- 
+-- An utterance can consist of one phrase of almost any category, 
+-- the limiting case being one-word utterances. These
+-- utterances are often (but not always) in what can be called the
+-- default form of a category, e.g. the nominative.
+-- This list is far from exhaustive.
+
+  useNounPhrase : NounPhrase -> Utterance = \john ->
+    postfixSS "." (defaultNounPhrase john) ;
+  useCommonNounPhrase : Number -> CommNounPhrase -> Utterance = \n,car -> 
+    useNounPhrase (indefNounPhrase n car) ;
+
+-- Here are some default forms.
+
+  defaultNounPhrase : NounPhrase -> SS = \john -> 
+    ss (john.s ! PNom) ;
+
+  defaultQuestion : Question -> SS = \whoareyou ->
+    ss (whoareyou.s ! DirQ) ;
+
+  defaultSentence : Sentence -> Utterance = \x -> ss (x.s ! Main) ;
+} ;
diff --git a/grammars/resource/swedish/TestSwe.gf b/grammars/resource/swedish/TestSwe.gf
new file mode 100644
index 000000000..063119b56
--- /dev/null
+++ b/grammars/resource/swedish/TestSwe.gf
@@ -0,0 +1,35 @@
+concrete TestSwe of TestAbs = ResSwe ** open Syntax in {
+
+flags startcat=Phr ; lexer=text ; parser=chart ; unlexer=text ;
+
+-- a random sample from the lexicon
+
+lin
+  Big = stor_25 ;
+  Small = liten_1146 ;
+  Old = gammal_16 ;
+  Young = ung_29 ;
+  Man = extCommNoun Masc man_1144 ;
+  Woman = extCommNoun NoMasc (sApa "kvinn") ;
+  Car = extCommNoun NoMasc (sBil "bil") ;
+  House = extCommNoun NoMasc (sHus "hus") ;
+  Light = extCommNoun NoMasc (sHus "ljus") ;
+  Walk = extVerb Act gå_1174 ;
+  Run = extVerb Act (vFinna "spring" "sprang" "sprung") ;
+  Love = extTransVerb (vTala "älsk") [] ;
+  Send = extTransVerb (vTala "skick") [] ;
+  Wait = extTransVerb (vTala "vänt") "på" ;
+  Say = extVerb Act (vLeka "säg") ; --- works in present tense...
+  Prove = extVerb Act (vTala "bevis") ;
+  SwitchOn = extTransVerb (vVända "tän") [] ;
+  SwitchOff = extTransVerb (vLeka "släck") [] ;
+
+  Mother = mkFun (extCommNoun NoMasc mor_1) "till" ;
+  Uncle = mkFun (extCommNoun Masc farbror_8) "till" ;
+
+  Always = advPre "alltid" ;
+  Well = advPost "bra" ;
+
+  John = mkProperName "Johan" Utr Masc ;
+  Mary = mkProperName "Maria" Utr NoMasc ;
+} ;
diff --git a/grammars/resource/swedish/Types.gf b/grammars/resource/swedish/Types.gf
new file mode 100644
index 000000000..21ddfcfc7
--- /dev/null
+++ b/grammars/resource/swedish/Types.gf
@@ -0,0 +1,150 @@
+--1 Swedish Word Classes and Morphological Parameters
+--
+-- This is a resource module for Swedish morphology, defining the
+-- morphological parameters and word classes of Swedish. It is aimed
+-- to be complete w.r.t. the description of word forms.
+-- However, it does not include those parameters that are not needed for
+-- analysing individual words: such parameters are defined in syntax modules.
+--
+-- This GF grammar was obtained from the functional morphology file TypesSw.hs
+-- semi-automatically. The GF inflection engine obtained was obtained automatically.
+
+resource Types = open Prelude in {
+
+--
+
+--2 Enumerated parameter types 
+--
+-- These types are the ones found in school grammars.
+-- Their parameter values are atomic.
+
+param
+  Gender  = Utr | Neutr ;
+  Number  = Sg | Pl ;
+  Species = Indef | Def ;
+  Case    = Nom | Gen ;
+  Sex     = NoMasc | Masc ;
+  Mode    = Ind | Cnj ;
+  Voice   = Act | Pass ;
+  Degree  = Pos | Comp | Sup ;
+  Person  = P1 | P2 | P3 ;
+
+--2 Word classes and hierarchical parameter types
+--
+-- Real parameter types (i.e. ones on which words and phrases depend) 
+-- are mostly hierarchical. The alternative would be cross-products of
+-- simple parameters, but this would usually overgenerate.
+--
+
+--3 Substantives
+--
+-- Substantives (= common nouns) have a parameter of type SubstForm.
+
+param SubstForm = SF Number Species Case ;
+
+-- Substantives moreover have an inherent gender. 
+
+oper Subst : Type = {s : SubstForm => Str ; h1 : Gender} ;
+
+--3 Adjectives
+--
+-- Adjectives are a very complex class, and the full table has as many as
+-- 18 different forms. The major division is between the comparison degrees;
+-- the comparative has only the 2 case forms, whereas the positive has 12 forms.
+
+param
+  AdjForm = AF AdjFormGrad Case ;
+
+-- The positive strong forms depend on gender: "en stor bil" - "ett stort hus".
+-- But the weak forms depend on sex: "den stora bilen" - "den store mannen".
+-- The plural never makes a gender-sex distinction.
+
+  GenNum = ASg Gender | APl ;
+  SexNum = AxSg Sex | AxPl ;
+
+  AdjFormPos = Strong GenNum | Weak SexNum ;
+  AdjFormSup = SupStrong | SupWeak ;
+
+  AdjFormGrad =
+    Posit  AdjFormPos
+  | Compar  
+  | Super AdjFormSup ;
+
+oper 
+  Adj : Type = {s : AdjForm => Str} ;
+
+--3 Verbs
+--
+-- Verbs have 9 finite forms and as many as 18 infinite forms; the large number
+-- of the latter comes from adjectives. 
+
+oper Verbum : Type = {s : VerbForm => Str} ;
+
+param
+  VFin = 
+   Pres Mode Voice
+ | Pret Mode Voice
+ | Imper ;         --- no passive
+ 
+  VInf =
+   Inf Voice
+ | Supin Voice
+ | PtPres Case
+ | PtPret AdjFormPos Case ;
+
+  VerbForm = 
+   VF VFin
+ | VI VInf ;
+
+-- However, the syntax only needs a simplified verb category, with 
+-- present tense only. Such a verb can be extracted from the full verb,
+-- and a choice can be made between an active and a passive (deponent) verb.
+
+param
+  VForm = Infinit | Indicat | Imperat ;
+
+oper
+  Verb : Type = SS1 VForm ;
+
+  extVerb : Voice -> Verbum -> Verb = \v,verb -> {s = table { 
+    Infinit => verb.s ! VI (Inf v) ;
+    Indicat => verb.s ! VF (Pres Ind v) ;
+    Imperat => verb.s ! VF Imper  --- no passive in Verbum
+    }} ;
+
+--3 Other open classes
+--
+-- Proper names, adverbs (Adv having comparison forms and AdvIn not having them),
+-- and interjections are the remaining open classes.
+
+oper 
+  PNm    : Type = {s : Case => Str ; h1 : Gender} ;
+  Adv    : Type = {s : Degree => Str} ;
+  AdvInv : Type = {s : Str} ;
+  Interj : Type = {s : Str} ;
+  
+--3 Closed classes
+--
+-- The rest of the Swedish word classes are closed, i.e. not extensible by new
+-- lexical entries. Thus we don't have to know how to build them, but only
+-- how to use them, i.e. which parameters they have.
+--
+-- The most important distinction is between proper-name-like pronouns and
+-- adjective-like pronouns, which are inflected in completely different parameters.
+
+param 
+  NPForm      = PNom | PAcc | PGen GenNum ;
+  AdjPronForm = APron GenNum Case ;
+  AuxVerbForm = AuxInf | AuxPres | AuxPret | AuxSup ;
+
+oper 
+  ProPN    : Type = {s : NPForm => Str ; h1 : Gender ; h2 : Number ; h3 : Person} ;
+  ProAdj   : Type = {s : AdjPronForm => Str} ;
+  Prep     : Type = {s : Str} ;
+  Conjunct : Type = {s : Str} ;
+  Subjunct : Type = {s : Str} ;
+  Art      : Type = {s : GenNum => Str} ;
+  Part     : Type = {s : Str} ;
+  Infin    : Type = {s : Str} ;
+  VAux     : Type = {s : AuxVerbForm => Str} ;
+}
diff --git a/src/GF.hs b/src/GF.hs
new file mode 100644
index 000000000..a75f4ee0c
--- /dev/null
+++ b/src/GF.hs
@@ -0,0 +1,78 @@
+module Main where
+
+import Operations
+import UseIO
+import Option
+import IOGrammar
+import ShellState
+import Shell
+import SubShell
+import PShell
+import JGF
+import UTF8
+
+import Today (today)
+import Arch
+import System (getArgs)
+
+-- AR 19/4/2000 -- 11/11/2001
+
+main :: IO ()
+main = do
+  xs <- getArgs
+  let (os,fs) = getOptions "-" xs
+      java    = oElem forJava os
+  putStrLn $ if java then encodeUTF8 welcomeMsg else welcomeMsg
+  st <- case fs of 
+    f:_ -> useIOE emptyShellState (shellStateFromFiles os emptyShellState f)
+    _ -> return emptyShellState
+  if null fs then return () else putCPU 
+  if java then sessionLineJ st else do
+  gfInteract (initHState st) 
+  return ()
+
+gfInteract :: HState -> IO HState
+gfInteract st@(env,_) = do
+  -- putStrFlush "> " M.F 25/01-02 prompt moved to Arch.
+  (s,cs) <- getCommandLines
+  case ifImpure cs of
+
+    -- these are the three impure commands
+    Just (ICQuit,_) -> do
+      putStrLn "See you."
+      return st
+    Just (ICExecuteHistory file,_) -> do
+      ss  <- readFileIf file
+      let co = pCommandLines ss
+      st' <- execLinesH s co st      
+      gfInteract st'      
+    Just (ICEarlierCommand i,_) -> do
+      let line = earlierCommandH st i
+          co   = pCommandLine $ words line
+      st' <- execLinesH line [co] st       -- s would not work in execLinesH
+      gfInteract st'
+    Just (ICEditSession,os) -> 
+      editSession (addOptions os opts) env >> gfInteract st
+{- -----
+    Just (ICTranslateSession,os) -> 
+      translateSession (addOptions os opts) env >> gfInteract st
+-}
+    -- this is a normal command sequence
+    _ -> do
+      st' <- execLinesH s cs st
+      gfInteract st'
+   where
+     opts = globalOptions env
+
+welcomeMsg = 
+  "Welcome to " ++ authorMsg ++++ welcomeArch ++ "\n\nType 'h' for help."
+
+authorMsg = unlines [
+ "Grammatical Framework, Version 2.0-- (incomplete functionality)", 
+--- "Compiled March 26, 2003",
+ "Compiled " ++ today,
+ "Copyright (c) Markus Forsberg, Thomas Hallgren, Kristofer Johannisson,",
+ "Janna Khegai, Peter Ljunglöf, Petri Mäenpää, and Aarne Ranta", 
+ "1998-2003, under GNU General Public License (GPL)",
+ "Bug reports to aarne@cs.chalmers.se"
+ ]
diff --git a/src/GF/API.hs b/src/GF/API.hs
new file mode 100644
index 000000000..d2a60d24c
--- /dev/null
+++ b/src/GF/API.hs
@@ -0,0 +1,267 @@
+module API where
+
+import qualified AbsGF as GF
+import qualified AbsGFC as A
+import qualified Rename as R
+import GetTree
+import GFC
+import Values
+
+-----import GetGrammar
+-----import Compile
+import IOGrammar
+import Linear
+import Parsing
+import Morphology
+import PPrCF
+import CFIdent
+import PGrammar
+import Randomized (mkRandomTree)
+import Zipper
+
+import MMacros
+import TypeCheck
+import CMacros
+
+import Option
+import Custom
+import ShellState
+import Linear
+import GFC
+import qualified Grammar as G
+import PrGrammar
+import qualified Compute as Co
+import qualified Ident as I
+import qualified GrammarToCanon as GC
+import qualified CanonToGrammar as CG
+
+import Editing
+
+----import GrammarToXML 
+
+----import GrammarToMGrammar as M
+
+import Arch (myStdGen)
+
+import UTF8
+import Operations
+import UseIO
+
+import List (nub)
+import Monad (liftM)
+import System (system)
+
+-- Application Programmer's Interface to GF; also used by Shell. AR 10/11/2001
+
+type GFGrammar = StateGrammar
+type GFCat     = CFCat
+type Ident     = I.Ident
+
+-- these are enough for many simple applications
+
+{- -----
+file2grammar :: FilePath -> IO GFGrammar
+file2grammar = do
+  egr <- appIOE $ optFile2grammar (iOpts [beSilent])
+  err putStrLn return egr
+-}
+
+linearize :: GFGrammar -> Tree -> String
+linearize sgr = err id id . optLinearizeTree opts sgr where
+  opts = addOption firstLin $ stateOptions sgr
+
+linearizeToAll :: [GFGrammar] -> Tree -> [String]
+linearizeToAll grs t = [linearize gr t | gr <- grs]
+
+parse :: GFGrammar -> CFCat -> String -> [Tree]
+parse sgr cat = errVal [] . parseString noOptions sgr cat
+
+parseAny :: [GFGrammar] -> CFCat -> String -> [Tree]
+parseAny grs cat s = concat [parse gr cat s | gr <- grs]
+
+translate :: GFGrammar -> GFGrammar -> CFCat -> String -> [String]
+translate ig og cat = map (linearize og) . parse ig cat
+
+translateToAll :: GFGrammar -> [GFGrammar] -> CFCat -> String -> [String]
+translateToAll ig ogs cat = concat . map (linearizeToAll ogs) . parse ig cat
+
+translateFromAny :: [GFGrammar] -> GFGrammar -> CFCat -> String -> [String]
+translateFromAny igs og cat s = concat [translate ig og cat s | ig <- igs]
+
+translateBetweenAll :: [GFGrammar] -> CFCat -> String -> [String]
+translateBetweenAll grs cat = concat . map (linearizeToAll grs) . parseAny grs cat
+
+homonyms :: GFGrammar -> CFCat -> Tree -> [Tree]
+homonyms gr cat = nub . parse gr cat . linearize gr
+
+hasAmbiguousLin :: GFGrammar -> CFCat -> Tree -> Bool
+hasAmbiguousLin gr cat t = case (homonyms gr cat t) of
+  _:_:_ -> True
+  _ -> False
+
+{- ----
+-- returns printname if one exists; othewrise linearizes with metas
+printOrLin :: GFGrammar -> Fun -> String
+printOrLin gr = printOrLinearize (stateGrammarST gr)
+
+-- reads a syntax file and writes it in a format wanted
+transformGrammarFile :: Options -> FilePath -> IO String
+transformGrammarFile opts file = do
+  sy <- useIOE GF.emptySyntax $ getSyntax opts file
+  return $ optPrintSyntax opts sy
+-}
+
+-- then stg for customizable and internal use
+
+{- -----
+optFile2grammar :: Options -> FilePath -> IOE GFGrammar
+optFile2grammar os f = do
+  gr <- ioeErr $ compileModule os f
+  return $ grammar2stateGrammar gr
+
+optFile2grammarE :: Options -> FilePath -> IOE GFGrammar
+optFile2grammarE = optFile2grammar
+-}
+
+string2treeInState :: GFGrammar -> String -> State -> Err Tree
+string2treeInState gr s st = do
+  let metas = allMetas st
+  t <- pTerm s
+  annotate (grammar gr) $ qualifTerm (absId gr) $ refreshMetas metas t
+
+string2srcTerm :: G.SourceGrammar -> I.Ident -> String -> Err G.Term
+string2srcTerm gr m s = do
+  t <- pTerm s
+  R.renameSourceTerm gr m t
+
+randomTreesIO :: Options -> GFGrammar -> Int -> IO [Tree]
+randomTreesIO opts gr n = do
+  gen <- myStdGen mx
+  t   <- err (\s -> putStrLnFlush s >> return []) (return . singleton) $ 
+                                                       mkRandomTree gen mx g cat
+  ts  <- if n==1 then return [] else randomTreesIO opts gr (n-1)
+  return $ t ++ ts
+ where
+   cat = firstAbsCat opts gr
+   g   = grammar gr
+   mx  = optIntOrN opts flagDepth 41
+
+speechGenerate :: Options -> String -> IO ()
+speechGenerate opts str = do
+  let lan = maybe "" (" --language" +++) $ getOptVal opts speechLanguage
+  system ("echo" +++ "\"" ++ str ++ "\" | festival --tts" ++ lan)
+  return ()
+
+optLinearizeTreeVal :: Options -> GFGrammar -> Tree -> String
+optLinearizeTreeVal opts gr = err id id . optLinearizeTree opts gr
+
+optLinearizeTree :: Options -> GFGrammar -> Tree -> Err String
+optLinearizeTree opts gr t 
+  | oElem showRecord opts = liftM prt $ linearizeNoMark g c t
+  | otherwise             = return $ linTree2string g c t
+ where
+   g = grammar gr
+   c = cncId gr
+
+{- ----
+        untoksl . lin where
+  gr = concreteOf (stateGrammarST sgr)
+  lin -- options mutually exclusive, with priority: struct, rec, table, one
+   | oElem showStruct opts = markedLinString True gr . tree2loc
+   | oElem showRecord opts = err id prt                  . linTerm gr
+   | oElem tableLin opts   = err id (concatMap prLinTable)  . allLinsAsStrs gr
+   | oElem firstLin opts   = unlines . map sstr . take 1 . allLinStrings gr
+   | otherwise = unlines . map sstr . optIntOrAll opts flagNumber . allLinStrings gr
+  untoks = customOrDefault opts' useUntokenizer customUntokenizer sgr
+  opts' = addOptions opts $ stateOptions sgr
+  untoksl = unlines . map untoks . lines
+-}
+
+{-
+optLinearizeArgForm :: Options -> StateGrammar -> [Term] -> Term -> String
+optLinearizeArgForm opts sgr fs ts0 = untoksl $ lin ts where
+  gr = concreteOf (stateGrammarST sgr) 
+  ts = annotateTrm sgr ts0
+  ms = map (renameTrm (lookupConcrete gr)) fs
+  lin -- options mutually exclusive, with priority: struct, rec, table
+   | oElem tableLin opts = err id (concatMap prLinTable) . allLinsForForms gr ms
+   | otherwise = err id (unlines . map sstr . tkStrs . concat) . allLinsForForms gr ms
+  tkStrs = concat . map snd . concat . map snd
+  untoks = customOrDefault opts' useUntokenizer customUntokenizer sgr
+  opts' = addOptions opts $ stateOptions sgr
+  untoksl = unlines . map untoks . lines
+-}
+
+optParseArg :: Options -> GFGrammar -> String -> [Tree]
+optParseArg opts gr =  err (const []) id . optParseArgErr opts gr
+
+optParseArgErr :: Options -> GFGrammar -> String -> Err [Tree]
+optParseArgErr opts gr = liftM fst . optParseArgErrMsg opts gr
+
+optParseArgErrMsg :: Options -> GFGrammar -> String -> Err ([Tree],String)
+optParseArgErrMsg opts gr s = 
+  let cat = firstCatOpts opts gr
+  in parseStringMsg opts gr cat s
+
+-- analyses word by word
+morphoAnalyse :: Options -> GFGrammar -> String -> String
+morphoAnalyse opts gr 
+  | oElem beShort opts = morphoTextShort mo 
+  | otherwise = morphoText mo 
+ where
+  mo = morpho gr
+
+{-
+prExpXML :: StateGrammar -> Term -> [String]
+prExpXML gr = prElementX . term2elemx (stateAbstract gr) 
+
+prMultiGrammar :: Options -> ShellState -> String
+prMultiGrammar opts = M.showMGrammar (oElem optimizeCanon opts)
+-}
+-- access to customizable commands
+
+optPrintGrammar :: Options -> StateGrammar -> String
+optPrintGrammar opts = customOrDefault opts grammarPrinter customGrammarPrinter
+
+optPrintSyntax :: Options -> GF.Grammar -> String
+optPrintSyntax opts = customOrDefault opts grammarPrinter customSyntaxPrinter
+
+{- ----
+optPrintTree :: Options -> GFGrammar -> Tree -> String
+optPrintTree opts = customOrDefault opts grammarPrinter customTermPrinter
+
+-- look for string command (-filter=x)
+optStringCommand :: Options -> GFGrammar -> String -> String
+optStringCommand opts g = 
+  optIntOrAll opts flagLength .  
+  customOrDefault opts filterString customStringCommand g
+
+optTreeCommand :: Options -> GFGrammar -> Tree -> [Tree]
+optTreeCommand opts st = 
+  optIntOrAll opts flagNumber .  
+  customOrDefault opts termCommand customTermCommand st
+-}
+
+{-
+-- wraps term in a function and optionally computes the result
+
+wrapByFun :: Options -> StateGrammar -> Ident -> Term -> Term
+wrapByFun opts g f t = 
+  if oElem doCompute opts 
+  then err (const t) id $ computeAbsTerm (stateAbstract g) (appCons f [t])
+  else appCons f [t]
+
+optTransfer :: Options -> StateGrammar -> Term -> Term
+optTransfer opts g = case getOptVal opts transferFun of
+  Just f -> wrapByFun (addOption doCompute opts) g (string2id f)
+  _ -> id
+-}
+optTokenizer :: Options -> GFGrammar -> String -> String
+optTokenizer opts gr = show . customOrDefault opts useTokenizer customTokenizer gr
+
+-- performs UTF8 if the language name is not *U.gf ; should be by gr option ---
+optEncodeUTF8 :: Language -> GFGrammar -> String -> String
+optEncodeUTF8 lang gr = case reverse (prLanguage lang) of
+  'U':_ -> id
+  _ -> encodeUTF8
+
diff --git a/src/GF/API/IOGrammar.hs b/src/GF/API/IOGrammar.hs
new file mode 100644
index 000000000..a00ef18a6
--- /dev/null
+++ b/src/GF/API/IOGrammar.hs
@@ -0,0 +1,42 @@
+module IOGrammar where
+
+import Option
+import Abstract
+import qualified GFC
+import PGrammar
+import TypeCheck
+import Compile
+import ShellState
+
+import Operations
+import UseIO
+import Arch
+
+import Monad (liftM)
+
+-- for reading grammars and terms from strings and files
+
+--- a heuristic way of renaming constants is used
+string2absTerm :: String -> String -> Term 
+string2absTerm m = renameTermIn m . pTrm
+
+renameTermIn :: String -> Term -> Term
+renameTermIn m = refreshMetas [] . rename [] where
+  rename vs t = case t of
+    Abs x b -> Abs x (rename (x:vs) b)
+    Vr c    -> if elem c vs then t else Q (zIdent m) c
+    App f a -> App (rename vs f) (rename vs a)
+    _ -> t
+
+string2annotTree :: GFC.CanonGrammar -> Ident -> String -> Err Tree
+string2annotTree gr m = annotate gr . string2absTerm (prt m) ---- prt
+
+----string2paramList :: ConcreteST -> String -> [Term]
+---string2paramList st = map (renameTrm (lookupConcrete st) . patt2term) . pPattList
+
+shellStateFromFiles :: Options -> ShellState -> FilePath -> IOE ShellState
+shellStateFromFiles opts st file = do
+  let osb = addOptions (options [beVerbose, emitCode]) opts ---
+  grts <- compileModule osb st file
+  ioeErr $ updateShellState opts st grts
+  --- liftM (changeModTimes rts) $ grammar2shellState opts gr
diff --git a/src/GF/CF/CF.hs b/src/GF/CF/CF.hs
new file mode 100644
index 000000000..0cff68b97
--- /dev/null
+++ b/src/GF/CF/CF.hs
@@ -0,0 +1,180 @@
+module CF where
+
+import Operations
+import Str
+import AbsGFC
+import GFC
+import CFIdent
+import List (nub,nubBy)
+import Char (isUpper, isLower, toUpper, toLower)
+
+-- context-free grammars. AR 15/12/1999 -- 30/3/2000 -- 2/6/2001 -- 3/12/2001
+
+-- CF grammar data types
+
+-- abstract type CF. 
+-- Invariant: each category has all its rules grouped with it 
+--      also: the list is never empty (the category is just missing then)
+newtype CF  = CF ([(CFCat,[CFRule])], CFPredef) 
+type CFRule = (CFFun, (CFCat, [CFItem]))
+
+-- CFPredef is a hack for variable symbols and literals; normally = const []
+data CFItem = CFTerm RegExp | CFNonterm CFCat deriving (Eq, Ord,Show)
+
+newtype CFTree = CFTree (CFFun,(CFCat, [CFTree])) deriving (Eq, Show)
+
+type CFPredef  = CFTok -> [(CFCat, CFFun)] -- recognize literals, variables, etc
+
+-- Wadler style + return information
+type CFParser = [CFTok] -> ([(CFTree,[CFTok])],String)
+
+cfParseResults :: ([(CFTree,[CFTok])],String) -> [CFTree]
+cfParseResults rs = [b | (b,[]) <- fst rs]
+
+-- terminals are regular expressions on words; to be completed to full regexp
+data RegExp = 
+    RegAlts [CFWord]         -- list of alternative words
+  | RegSpec CFTok            -- special token
+  deriving (Eq, Ord, Show)
+
+type CFWord = String
+
+-- the above types should be kept abstract, and the following functions used
+
+-- to construct CF grammars
+
+emptyCF :: CF
+emptyCF = CF ([], emptyCFPredef)
+
+emptyCFPredef :: CFPredef
+emptyCFPredef = const []
+
+rules2CF :: [CFRule] -> CF
+rules2CF rs = CF (groupCFRules rs, emptyCFPredef)
+
+groupCFRules :: [CFRule] -> [(CFCat,[CFRule])]
+groupCFRules = foldr ins [] where
+  ins rule crs = case crs of
+    (c,r) : rs | compatCF c cat -> (c,rule:r) : rs
+    cr    : rs            -> cr         : ins rule rs
+    _                     -> [(cat,[rule])]
+   where
+     cat = valCatCF rule
+
+-- to construct rules
+
+-- make a rule from a single token without constituents
+atomCFRule :: CFCat -> CFFun -> CFTok -> CFRule
+atomCFRule c f s = (f, (c, [atomCFTerm s]))
+
+-- usual terminal
+atomCFTerm :: CFTok -> CFItem 
+atomCFTerm = CFTerm . atomRegExp
+
+atomRegExp :: CFTok -> RegExp
+atomRegExp t = case t of
+  TS s -> RegAlts [s] 
+  _    -> RegSpec t
+
+-- terminal consisting of alternatives
+altsCFTerm :: [String] -> CFItem 
+altsCFTerm = CFTerm . RegAlts
+
+
+-- to construct trees
+
+-- make a tree without constituents
+atomCFTree :: CFCat -> CFFun -> CFTree
+atomCFTree c f = buildCFTree c f []
+
+-- make a tree with constituents. 
+buildCFTree :: CFCat -> CFFun -> [CFTree] -> CFTree
+buildCFTree c f trees = CFTree (f,(c,trees))
+
+{- ----
+cfMeta0 :: CFTree
+cfMeta0 = atomCFTree uCFCat metaCFFun
+
+-- used in happy
+litCFTree :: String -> CFTree --- Maybe CFTree
+litCFTree s = maybe cfMeta0 id $ do
+  (c,f) <- getCFLiteral s
+  return $ buildCFTree c f []
+-}
+
+-- to decide whether a token matches a terminal item
+
+matchCFTerm :: CFItem -> CFTok -> Bool
+matchCFTerm (CFTerm t) s = satRegExp t s
+matchCFTerm _ _ = False
+
+satRegExp :: RegExp -> CFTok -> Bool
+satRegExp r t = case (r,t) of 
+  (RegAlts tt, TS s) -> elem s tt
+  (RegAlts tt, TC s) -> or [elem s' tt | s' <- caseUpperOrLower s]
+  (RegSpec x,  _)    -> t == x ---
+  _ -> False
+ where
+   caseUpperOrLower s = case s of
+     c:cs | isUpper c -> [s, toLower c : cs]
+     c:cs | isLower c -> [s, toUpper c : cs]
+     _ -> [s]
+
+-- to analyse a CF grammar
+
+catsOfCF :: CF -> [CFCat]
+catsOfCF (CF (rr,_)) = map fst rr 
+
+rulesOfCF :: CF -> [CFRule]
+rulesOfCF (CF (rr,_)) = concatMap snd rr
+
+ruleGroupsOfCF :: CF -> [(CFCat,[CFRule])]
+ruleGroupsOfCF (CF (rr,_)) = rr
+
+rulesForCFCat :: CF -> CFCat -> [CFRule]
+rulesForCFCat (CF (rr,_)) cat = maybe [] id $ lookup cat rr
+
+valCatCF :: CFRule -> CFCat
+valCatCF (_,(c,_)) = c
+
+valItemsCF :: CFRule -> [CFItem]
+valItemsCF (_,(_,i)) = i
+
+valFunCF :: CFRule -> CFFun
+valFunCF  (f,(_,_)) = f
+
+startCat :: CF -> CFCat
+startCat (CF (rr,_)) = fst (head rr) --- hardly useful
+
+predefOfCF :: CF -> CFPredef
+predefOfCF (CF (_,f)) = f
+
+appCFPredef :: CF -> CFTok -> [(CFCat, CFFun)]
+appCFPredef = ($) . predefOfCF
+
+valCFItem :: CFItem -> Either RegExp CFCat
+valCFItem (CFTerm r)     = Left r
+valCFItem (CFNonterm nt) = Right nt
+
+cfTokens :: CF -> [CFWord]
+cfTokens cf = nub $ concat $ [ wordsOfRegExp i | r <- rulesOfCF cf, 
+                                                 CFTerm i <- valItemsCF r]
+
+wordsOfRegExp :: RegExp -> [CFWord]
+wordsOfRegExp (RegAlts tt) = tt
+wordsOfRegExp _ = []
+
+forCFItem :: CFTok -> CFRule -> Bool
+forCFItem a (_,(_, CFTerm r : _)) = satRegExp r a
+forCFItem _ _ = False
+
+isCircularCF :: CFRule -> Bool
+isCircularCF (_,(c', CFNonterm c:[])) = compatCF c' c
+isCircularCF _ = False
+--- we should make a test of circular chains, too
+
+-- coercion to the older predef cf type
+
+predefRules :: CFPredef -> CFTok -> [CFRule]
+predefRules pre s = [atomCFRule c f s | (c,f) <- pre s]
+
diff --git a/src/GF/CF/CFIdent.hs b/src/GF/CF/CFIdent.hs
new file mode 100644
index 000000000..d9c451adb
--- /dev/null
+++ b/src/GF/CF/CFIdent.hs
@@ -0,0 +1,151 @@
+module CFIdent where
+
+import Operations
+import GFC
+import Ident
+import AbsGFC
+import PrGrammar
+import Str
+import Char (toLower, toUpper)
+
+-- symbols (categories, functions) for context-free grammars.
+
+-- these types should be abstract
+
+data CFTok = 
+   TS String     -- normal strings
+ | TC String     -- strings that are ambiguous between upper or lower case
+ | TL String     -- string literals
+ | TI Int        -- integer literals
+ | TV Ident      -- variables
+ | TM Int String -- metavariables; the integer identifies it
+  deriving (Eq, Ord, Show)
+
+newtype CFCat = CFCat (CIdent,Label) deriving (Eq, Ord, Show)
+
+tS, tC, tL, tI, tV, tM :: String -> CFTok
+tS  = TS
+tC  = TC
+tL  = TL
+tI  = TI . read 
+tV  = TV . identC
+tM  = TM 0
+
+tInt :: Int -> CFTok
+tInt = TI
+
+prCFTok :: CFTok -> String
+prCFTok t = case t of
+  TS s -> s
+  TC s -> s
+  TL s -> s
+  TI i -> show i
+  TV x -> prt x
+  TM i _ -> "?" ---
+
+-- to build trees: the Atom contains a GF function, Cn | Meta | Vr | Literal
+newtype CFFun = CFFun (Atom, Profile) deriving (Eq,Show)
+
+type Profile  = [([[Int]],[Int])]
+
+
+-- the following functions should be used instead of constructors
+
+-- to construct CF functions
+
+mkCFFun :: Atom -> CFFun
+mkCFFun t = CFFun (t,[])
+
+{- ----
+getCFLiteral :: String -> Maybe (CFCat, CFFun)
+getCFLiteral s = case lookupLiteral' s of
+  Ok (c, lit) -> Just (cat2CFCat c, mkCFFun lit)
+  _ -> Nothing
+-}
+
+varCFFun :: Ident -> CFFun
+varCFFun = mkCFFun . AV
+
+consCFFun :: CIdent -> CFFun
+consCFFun = mkCFFun . AC
+
+{- ----
+string2CFFun :: String -> CFFun 
+string2CFFun = consCFFun . Ident
+-}
+
+cfFun2String :: CFFun -> String
+cfFun2String (CFFun (f,_)) = prt f
+
+cfFun2Profile :: CFFun -> Profile
+cfFun2Profile (CFFun (_,p)) = p
+
+{- ----
+strPro2cfFun :: String -> Profile -> CFFun
+strPro2cfFun str p = (CFFun (AC (Ident str), p))
+-}
+
+metaCFFun :: CFFun
+metaCFFun = mkCFFun $ AM 0
+
+-- to construct CF categories
+
+-- belongs elsewhere
+mkCIdent :: String -> String -> CIdent
+mkCIdent m c = CIQ (identC m) (identC c)
+
+ident2CFCat :: CIdent -> Ident -> CFCat
+ident2CFCat mc d = CFCat (mc, L d)
+
+-- standard way of making cf cat: label s
+string2CFCat :: String -> String -> CFCat
+string2CFCat m c = ident2CFCat (mkCIdent m c) (identC "s")
+
+idents2CFCat :: Ident -> Ident -> CFCat
+idents2CFCat m c = ident2CFCat (CIQ m c) (identC "s")
+
+catVarCF :: CFCat
+catVarCF = ident2CFCat (mkCIdent "_" "#Var") (identC "_") ----
+
+{- ----
+uCFCat :: CFCat
+uCFCat = cat2CFCat uCat
+-}
+
+moduleOfCFCat :: CFCat -> Ident
+moduleOfCFCat (CFCat (CIQ m _, _)) = m
+
+-- the opposite direction
+cfCat2Cat :: CFCat -> CIdent   
+cfCat2Cat (CFCat (s,_)) = s
+
+
+-- to construct CF tokens
+
+string2CFTok :: String -> CFTok
+string2CFTok = tS
+
+str2cftoks :: Str -> [CFTok]
+str2cftoks = map tS . words . sstr
+
+-- decide if two token lists look the same (in parser postprocessing)
+
+compatToks :: [CFTok] -> [CFTok] -> Bool
+compatToks ts us = and [compatTok t u | (t,u) <- zip ts us]
+
+compatTok t u = any (`elem` (alts t)) (alts u) where
+  alts u = case u of
+    TC (c:s) -> [toLower c : s, toUpper c : s]
+    _ -> [prCFTok u]
+
+-- decide if two CFFuns have the same function head (profiles may differ)
+
+compatCFFun :: CFFun -> CFFun -> Bool
+compatCFFun (CFFun (f,_)) (CFFun (g,_)) = f == g
+
+-- decide whether two categories match
+-- the modifiers can be from different modules, but on the same extension
+-- path, so there is no clash, and they can be safely ignored ---
+compatCF :: CFCat -> CFCat -> Bool
+----compatCF = (==)
+compatCF (CFCat (CIQ _ c, l)) (CFCat (CIQ _ c', l')) = c==c' && l==l'
diff --git a/src/GF/CF/CanonToCF.hs b/src/GF/CF/CanonToCF.hs
new file mode 100644
index 000000000..6f7dc6d6b
--- /dev/null
+++ b/src/GF/CF/CanonToCF.hs
@@ -0,0 +1,157 @@
+module CanonToCF where
+
+import Operations
+import Option
+import Ident
+import AbsGFC
+import GFC
+import PrGrammar
+import CMacros
+import qualified Modules as M
+import CF
+import CFIdent
+import List (nub)
+import Monad
+
+-- AR 27/1/2000 -- 3/12/2001 -- 8/6/2003 
+
+-- The main function: for a given cnc module m, build the CF grammar with all the
+-- rules coming from modules that m extends. The categories are qualified by
+-- the abstract module name a that m is of.
+
+canon2cf :: Options -> CanonGrammar -> Ident -> Err CF
+canon2cf opts gr c = do
+  let ms = M.allExtends gr c
+  a <- M.abstractOfConcrete gr c
+  let cncs = [m | (n, M.ModMod m) <- M.modules gr, elem n ms]
+  let mms  = [(a, tree2list (M.jments m)) | m <- cncs]
+  rules0 <- liftM concat $ mapM (uncurry (cnc2cfCond opts)) mms
+  let rules = filter (not . isCircularCF) rules0 ---- temporarily here
+  let predef = const [] ---- mkCFPredef cfcats
+  return $ CF (groupCFRules rules, predef)
+
+cnc2cfCond :: Options -> Ident -> [(Ident,Info)] -> Err [CFRule]
+cnc2cfCond opts m gr = 
+  liftM concat $ 
+  mapM lin2cf [(m,fun,cat,args,lin) | (fun, CncFun cat args lin _) <- gr] 
+
+type IFun = Ident
+type ICat = CIdent
+
+-- all CF rules corresponding to a linearization rule
+lin2cf :: (Ident, IFun, ICat, [ArgVar], Term) -> Err [CFRule]
+lin2cf (m,fun,cat,args,lin) = errIn ("building CF rule for" +++ prt fun) $ do
+  rhss0  <- allLinValues lin                   -- :: [(Label, [([Patt],Term)])]
+  rhss1  <- mapM (mkCFItems m) (concat rhss0)  -- :: [(Label, [[PreCFItem]])]
+  mapM (mkCfRules m fun cat args) rhss1 >>= return . nub . concat
+
+-- making sequences of CF items from every branch in a linearization
+mkCFItems :: Ident -> (Label, [([Patt],Term)]) -> Err (Label, [[PreCFItem]])
+mkCFItems m (lab,pts) = do
+  itemss <- mapM (term2CFItems m) (map snd pts)
+  return (lab, concat itemss) ---- combinations? (test!)
+
+-- making CF rules from sequences of CF items
+mkCfRules :: Ident -> IFun -> ICat -> [ArgVar] -> (Label, [[PreCFItem]]) -> Err [CFRule]
+mkCfRules m fun cat args (lab, itss) = mapM mkOneRule itss
+ where
+  mkOneRule its = do
+    let nonterms = zip [0..] [(pos,d,v) | PNonterm _ pos d v <- its]
+        profile  = mkProfile nonterms
+	cfcat    = CFCat (redirectIdent m cat,lab)
+        cffun    = CFFun (AC (CIQ m fun), profile)
+        cfits    = map precf2cf its
+    return (cffun,(cfcat,cfits))
+  mkProfile nonterms = map mkOne args 
+    where
+      mkOne (A  c i) = mkOne (AB c 0 i)
+      mkOne (AB _ b i) = (map mkB [0..b-1], [k | (k,(j,_,True)) <- nonterms, j==i])
+        where
+          mkB j = [p | (p,(k, LV l,False)) <- nonterms, k == i, l == j]
+
+-- intermediate data structure of CFItems with information for profiles
+data PreCFItem = 
+    PTerm RegExp                       -- like ordinary Terminal 
+  | PNonterm CIdent Integer Label Bool -- cat, position, part/bind, whether arg
+   deriving Eq                    
+
+precf2cf :: PreCFItem -> CFItem
+precf2cf (PTerm r) = CFTerm r
+precf2cf (PNonterm cm _ (L c) True) = CFNonterm (ident2CFCat cm c)
+precf2cf (PNonterm _ _ _ False) = CFNonterm catVarCF
+
+
+-- the main job in translating linearization rules into sequences of cf items 
+term2CFItems :: Ident -> Term -> Err [[PreCFItem]]
+term2CFItems m t = errIn "forming cf items" $ case t of
+   S c _ -> t2c c
+
+   T _ cc -> do
+     its  <- mapM t2c [t | Cas _ t <- cc]
+     tryMkCFTerm (concat its)
+
+   C t1 t2 -> do
+     its1 <- t2c t1
+     its2 <- t2c t2
+     return [x ++ y | x <- its1, y <- its2]
+
+   FV ts -> do
+     its <- mapM t2c ts
+     tryMkCFTerm (concat its)
+
+   P arg s -> extrR arg s
+
+   K (KS s) -> return [[PTerm (RegAlts [s]) | not (null s)]]
+
+   E -> return [[]]
+
+   K (KP d vs) -> do
+     let its  =  [PTerm (RegAlts [s]) | s <- d]
+     let itss = [[PTerm (RegAlts [s]) | s <- t] | Var t _ <- vs]
+     tryMkCFTerm (its : itss)
+
+   _ -> prtBad "no cf for" t ----
+
+  where 
+
+    t2c = term2CFItems m
+
+    -- optimize the number of rules by a factorization
+    tryMkCFTerm :: [[PreCFItem]] -> Err [[PreCFItem]]  
+    tryMkCFTerm ii@(its:itss) | all (\x -> length x == length its) itss =
+      case mapM mkOne (counterparts ii) of
+        Ok tt -> return [tt]
+        _ -> return ii
+       where
+         mkOne cfits = case mapM mkOneTerm cfits of
+           Ok tt -> return $ PTerm (RegAlts (concat (nub tt)))
+           _ -> mkOneNonTerm cfits
+         mkOneTerm (PTerm (RegAlts t)) = return t
+         mkOneTerm _ = Bad ""
+         mkOneNonTerm (n@(PNonterm _ _ _ _) : cc) = 
+           if all (== n) cc 
+	      then return n
+	      else Bad ""
+         mkOneNonTerm _ = Bad ""
+         counterparts ll = [map (!! i) ll | i <- [0..length (head ll) - 1]]
+    tryMkCFTerm itss = return itss
+
+    extrR arg lab = case (arg,lab) of
+      (Arg (A cat pos), l@(L _))  -> return [[PNonterm (CIQ m cat) pos l True]]
+      (Arg (A cat pos), l@(LV _)) -> return [[PNonterm (CIQ m cat) pos l False]]
+      (Arg (AB cat pos b), l@(L _))  -> return [[PNonterm (CIQ m cat) pos l True]]
+      (Arg (AB cat pos b), l@(LV _)) -> return [[PNonterm (CIQ m cat) pos l False]]
+                                     ---- ??
+      _   -> prtBad "cannot extract record field from" arg
+
+{- Proof + 1 @ 4     catVarCF :: CFCat
+PNonterm CIdent Integer Label Bool -- cat, position, part/bind, whether arg
+
+
+mkCFPredef :: [CFCat] -> CFPredef
+mkCFPredef cats s = 
+  [(cat, metaCFFun)  | TM _ _ <- [s], cat <- cats] ++
+  [(cat, varCFFun x) | TV x   <- [s], cat <- cats] ++
+  [(cat, lit)        | TL t   <- [s], Just (cat,lit) <- [getCFLiteral t]] ++
+  [(cat, lit)        | TI i   <- [s], Just (cat,lit) <- [getCFLiteral (show i)]] ---
+-}
diff --git a/src/GF/CF/ChartParser.hs b/src/GF/CF/ChartParser.hs
new file mode 100644
index 000000000..09d538244
--- /dev/null
+++ b/src/GF/CF/ChartParser.hs
@@ -0,0 +1,166 @@
+
+module ChartParser (chartParser) where
+
+import Operations
+import CF
+import CFIdent
+import PPrCF (prCFItem)
+
+import OrdSet
+import OrdMap2
+
+import List (groupBy)
+
+type Token      = CFTok
+type Name       = CFFun
+type Category   = CFItem
+type Grammar    = ([Production], Terminal)
+type Production = (Name, Category, [Category])
+type Terminal   = Token -> [(Category, Maybe Name)]
+type GParser    = Grammar -> Category -> [Token] -> ([ParseTree],String)
+data ParseTree  = Node Name Category [ParseTree] | Leaf Token
+
+--------------------------------------------------
+-- converting between GF parsing and CFG parsing
+
+buildParser :: GParser -> CF -> CFCat -> CFParser
+buildParser gparser cf = parse
+  where 
+    parse = \start input -> 
+            let parse2 = parse' (CFNonterm start) input in 
+            ([(parse2tree t, []) | t <- fst parse2], snd parse2) 
+    parse' = gparser (cf2grammar cf)
+
+cf2grammar :: CF -> Grammar
+cf2grammar cf = (productions, terminal)
+  where 
+    productions  = [ (name, CFNonterm cat, rhs) | 
+		     (name, (cat, rhs)) <- cfRules ]
+    terminal tok = [ (CFNonterm cat, Just name) |
+		     (cat, name) <- cfPredef tok ] 
+		   ++
+		   [ (item, Nothing) |
+		     item <- elems rhsItems,
+		     matchCFTerm item tok ]
+    cfRules  = rulesOfCF cf
+    cfPredef = predefOfCF cf
+    rhsItems :: Set Category
+    rhsItems = union [ makeSet rhs | (_, (_, rhs)) <- cfRules ]
+
+parse2tree :: ParseTree -> CFTree
+parse2tree (Node name (CFNonterm cat) trees) = CFTree (name, (cat, trees')) 
+  where
+    trees' = [ parse2tree t | t@(Node _ _ _) <- trees ]   -- ignore leafs
+
+maybeNode :: Maybe Name -> Category -> Token -> ParseTree
+maybeNode (Just name) cat tok = Node name cat [Leaf tok]
+maybeNode Nothing     _   tok = Leaf tok
+
+
+--------------------------------------------------
+-- chart parsing (bottom up kilbury-like)
+
+type Chart   = [CState]
+type CState  = Set Edge 
+type Edge    = (Int, Category, [Category])
+type Passive = (Int, Int, Category)
+
+chartParser :: CF -> CFCat -> CFParser
+chartParser = buildParser chartParser0
+
+chartParser0 :: GParser
+chartParser0 (productions, terminal) = cparse
+  where
+    emptyCats :: Set Category
+    emptyCats = empties emptySet
+      where 
+        empties cats | cats==cats' = cats
+		     | otherwise   = empties cats'
+	  where cats' = makeSet [ cat | (_, cat, rhs) <- productions,
+				        all (`elemSet` cats) rhs ]
+
+    grammarMap :: Map Category [(Name, [Category])]
+    grammarMap = makeMapWith (++) 
+		 [ (cat, [(name,rhs)]) | (name, cat, rhs) <- productions ]
+
+    leftCornerMap :: Map Category (Set (Category,[Category]))
+    leftCornerMap = makeMapWith (<++>) [ (a, unitSet (b, bs)) | 
+					 (_, b, abs) <- productions, 
+					 (a : bs) <- removeNullable abs ]
+
+    removeNullable :: [Category] -> [[Category]]
+    removeNullable [] = []
+    removeNullable cats@(cat:cats')
+	| cat `elemSet` emptyCats = cats : removeNullable cats'
+	| otherwise               = [cats]
+
+    cparse :: Category -> [Token] -> ([ParseTree], String)
+    cparse start input = case lookup (0, length input, start) edgeTrees of
+			   Just trees -> (trees, "Chart:" ++++ prChart passiveEdges)
+			   Nothing    -> ([],    "Chart:" ++++ prChart passiveEdges)
+      where 
+        finalChart :: Chart
+        finalChart = map buildState initialChart
+
+        finalChartMap :: [Map Category (Set Edge)]
+	finalChartMap = map stateMap finalChart
+
+        stateMap :: CState -> Map Category (Set Edge)
+	stateMap state = makeMapWith (<++>) [ (a, unitSet (i,b,bs)) |
+					      (i, b, a:bs) <- elems state ]
+
+        initialChart :: Chart
+        initialChart = emptySet : map initialState (zip [0..] input)
+          where initialState (j, sym) = makeSet [ (j, cat, []) | 
+						  (cat, _) <- terminal sym ]
+
+        buildState :: CState -> CState
+	buildState = limit more
+	  where more (j, a, [])   = ordSet [ (j, b, bs) |
+				             (b, bs) <- elems (lookupWith emptySet leftCornerMap a) ]
+				    <++>
+				    lookupWith emptySet (finalChartMap !! j) a
+		more (j, b, a:bs) = ordSet [ (j, b, bs) |
+					     a `elemSet` emptyCats ]
+
+        passiveEdges :: [Passive]
+	passiveEdges = [ (i, j, cat) |
+			 (j, state) <- zip [0..] finalChart,
+			 (i, cat, []) <- elems state ]
+		       ++
+		       [ (i, i, cat) |
+			 i <- [0 .. length input],
+			 cat <- elems emptyCats ]
+
+        edgeTrees :: [ (Passive, [ParseTree]) ]
+	edgeTrees = [ (edge, treesFor edge) | edge <- passiveEdges ]
+
+        edgeTreesMap :: Map (Int, Category) [(Int, [ParseTree])]
+	edgeTreesMap = makeMapWith (++) [ ((i,c), [(j,trees)]) |
+					  ((i,j,c), trees) <- edgeTrees ]
+
+        treesFor :: Passive -> [ParseTree]
+	treesFor (i, j, cat) = [ Node name cat trees |
+				 (name, rhs) <- lookupWith [] grammarMap cat,
+				 trees <- children rhs i j ]
+			       ++
+			       [ maybeNode name cat tok |
+				 i == j-1,
+				 let tok = input !! i,
+				 Just name <- [lookup cat (terminal tok)] ]
+
+        children :: [Category] -> Int -> Int -> [[ParseTree]]
+	children []     i k = [ [] | i == k ]
+	children (c:cs) i k = [ tree : rest |
+				i <= k,
+				(j, trees) <- lookupWith [] edgeTreesMap (i,c),
+				rest <- children cs j k,
+				tree <- trees ]
+
+
+-- AR 10/12/2002
+
+prChart :: [Passive] -> String
+prChart = unlines . map (unwords . map prOne) . positions where
+  prOne (i,j,it) = show i ++ "-" ++ show j ++ "-" ++ prCFItem it
+  positions = groupBy (\ (i,_,_) (j,_,_) -> i == j) 
diff --git a/src/GF/CF/PPrCF.hs b/src/GF/CF/PPrCF.hs
new file mode 100644
index 000000000..ff4b64e66
--- /dev/null
+++ b/src/GF/CF/PPrCF.hs
@@ -0,0 +1,59 @@
+module PPrCF where
+
+import Operations
+import CF
+import CFIdent
+import AbsGFC
+import PrGrammar
+
+-- printing and parsing CF grammars, rules, and trees AR 26/1/2000 -- 9/6/2003
+---- use the Print class instead!
+
+prCF :: CF -> String
+prCF = unlines . (map prCFRule) . rulesOfCF -- hiding the literal recogn function
+
+prCFTree :: CFTree -> String
+prCFTree (CFTree (fun, (_,trees))) = prCFFun fun ++ prs trees where 
+ prs [] = ""
+ prs ts = " " ++ unwords (map ps ts)
+ ps t@(CFTree (_,(_,[]))) = prCFTree t
+ ps t = prParenth (prCFTree t)
+
+prCFRule :: CFRule -> String
+prCFRule (fun,(cat,its)) = 
+  prCFFun fun ++ "." +++ prCFCat cat +++ "::=" +++ 
+  unwords (map prCFItem its) +++ ";"
+
+prCFFun :: CFFun -> String
+prCFFun = prCFFun' True ---- False -- print profiles for debug
+
+prCFFun' :: Bool -> CFFun -> String
+prCFFun' profs (CFFun (t, p)) = prt t ++ pp p where
+    pp p = if (not profs || normal p) then "" else "_" ++ concat (map show p)
+    normal p = and [x==y && null b | ((b,x),y) <- zip p (map (:[]) [0..])]
+
+prCFCat :: CFCat -> String
+prCFCat (CFCat (c,l)) = prt c ++ "-" ++ prt l ----
+
+prCFItem (CFNonterm c) = prCFCat c
+prCFItem (CFTerm a) = prRegExp a
+
+prRegExp (RegAlts tt) = case tt of
+  [t] -> prQuotedString t
+  _ -> prParenth (prTList " | " (map prQuotedString tt))
+
+{- ----
+-- rules have an amazingly easy parser, if we use the format
+-- fun. C -> item1 item2 ... where unquoted items are treated as cats
+-- Actually would be nice to add profiles to this.
+
+getCFRule :: String -> Maybe CFRule
+getCFRule s = getcf (wrds s) where
+  getcf ww | length ww > 2 && ww !! 2 `elem` ["->", "::="] = 
+            Just (string2CFFun (init fun), (string2CFCat cat, map mkIt its)) where
+    fun : cat : _ : its = words s
+    mkIt ('"':w@(_:_)) = atomCFTerm (string2CFTok (init w))
+    mkIt w = CFNonterm (string2CFCat w)
+  getcf _ = Nothing
+  wrds = takeWhile (/= ";") . words -- to permit semicolon in the end
+-}
\ No newline at end of file
diff --git a/src/GF/CF/Profile.hs b/src/GF/CF/Profile.hs
new file mode 100644
index 000000000..6dbb5f85a
--- /dev/null
+++ b/src/GF/CF/Profile.hs
@@ -0,0 +1,95 @@
+module Profile (postParse) where
+
+import AbsGFC
+import GFC
+import qualified Ident as I
+import CMacros
+---import MMacros
+import CF
+import CFIdent
+import PPrCF     -- for error msg
+import PrGrammar
+
+import Operations
+
+import Monad
+import List (nub)
+
+
+-- restoring parse trees for discontinuous constituents, bindings, etc. AR 25/1/2001
+-- revised 8/4/2002 for the new profile structure
+
+postParse :: CFTree -> Err Exp
+postParse tree = do
+  iterm <- errIn "postprocessing initial parse tree" $ tree2term tree
+  return $ term2trm  iterm
+
+-- an intermediate data structure
+data ITerm = ITerm (Atom, BindVs) [ITerm] | IMeta   deriving (Eq,Show)
+type BindVs = [[I.Ident]]
+
+-- the job is done in two passes: 
+-- (1) tree2term: restore constituent order from Profile 
+-- (2) term2trm:  restore Bindings from Binds
+
+tree2term :: CFTree -> Err ITerm
+tree2term (CFTree (cff@(CFFun (fun,pro)), (_,trees))) = case fun of
+  AM _ -> return IMeta
+  _ -> do
+    args  <- mapM mkArg pro
+    binds <- mapM mkBinds pro
+    return $ ITerm (fun, binds) args
+ where
+   mkArg (_,arg) = case arg of
+     [x] -> do               -- one occurrence
+       trx <- trees !? x
+       tree2term trx
+     []  -> return IMeta     -- suppression
+     _   -> do               -- reduplication
+       trees' <- mapM (trees !?) arg
+       xs1    <- mapM tree2term trees' 
+       xs2    <- checkArity xs1
+       unif xs2
+
+   checkArity xs = if length (nub [length xx | ITerm _ xx <- xs']) > 1 
+                   then Bad "arity error" 
+                   else return xs'
+           where xs' = [t | t@(ITerm _ _) <- xs]
+   unif [] = return $ IMeta
+   unif xs@(ITerm fp@(f,_) xx : ts) = do
+     let hs = [h | ITerm (h,_) _ <- ts]
+     testErr (all (==f) hs)                 -- if fails, hs must be nonempty
+        ("unification expects" +++ prt f +++ "but found" +++ prt (head hs))
+     xx' <- mapM unifArg [0 .. length xx - 1]
+     return $ ITerm fp xx'
+    where
+      unifArg i = tryUnif [zz !! i | ITerm _ zz <- xs]
+   tryUnif xx = case [t | t@(ITerm _ _) <- xx] of
+     [] -> return IMeta
+     x:xs -> if all (==x) xs 
+             then return x 
+             else Bad "failed to unify"
+
+   mkBinds (xss,_) = mapM mkBind xss
+   mkBind xs = do
+     ts <- mapM (trees !?) xs
+     let vs = [x | CFTree (CFFun (AV x,_),(_,[])) <- ts]
+     testErr (length ts == length vs) "non-variable in bound position"
+     case vs of
+       [x]  -> return x
+       []   -> return $ I.identC "h_" ---- uBoundVar
+       y:ys -> do
+         testErr (all (==y) ys) ("fail to unify bindings of" +++ prt y)
+         return y
+
+term2trm :: ITerm -> Exp 
+term2trm IMeta = EAtom (AM 0) ---- mExp0
+term2trm (ITerm (fun, binds) terms) =
+  let bterms = zip binds terms
+  in mkAppAtom fun [mkAbsR xs (term2trm t) |  (xs,t) <- bterms]
+
+ --- these are deprecated
+ where
+   mkAbsR c e = foldr EAbs e c
+   mkAppAtom a = mkApp (EAtom a)
+   mkApp = foldl EApp
\ No newline at end of file
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
+    []                -> []
+
diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs
new file mode 100644
index 000000000..544214cb9
--- /dev/null
+++ b/src/GF/Compile/CheckGrammar.hs
@@ -0,0 +1,665 @@
+module CheckGrammar where
+
+import Grammar
+import Ident
+import Modules
+import Refresh ----
+
+import TypeCheck
+
+import PrGrammar
+import Lookup
+import LookAbs
+import Macros
+import ReservedWords ----
+import PatternMatch
+
+import Operations
+import CheckM
+
+import List
+import Monad
+
+-- AR 4/12/1999 -- 1/4/2000 -- 8/9/2001 -- 15/5/2002 -- 27/11/2002 -- 18/6/2003
+
+-- type checking also does the following modifications:
+-- * types of operations and local constants are inferred and put in place
+-- * both these types and linearization types are computed
+-- * tables are type-annotated
+
+showCheckModule :: [SourceModule] -> SourceModule -> Err ([SourceModule],String)
+showCheckModule mos m = do
+    (st,(_,msg)) <- checkStart $ checkModule mos m
+    return (st, unlines $ reverse msg)
+
+-- checking is performed in dependency order of modules
+
+checkModule :: [SourceModule] -> SourceModule -> Check [SourceModule]
+checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod of
+
+  ModMod mo@(Module mt fs me ops js) -> case mt of
+    MTAbstract -> do
+      js' <- mapMTree (checkAbsInfo gr name) js
+      return $ (name, ModMod (Module mt fs me ops js')) : ms
+
+    MTResource -> do
+      js' <- mapMTree (checkResInfo gr) js
+      return $ (name, ModMod (Module mt fs me ops js')) : ms
+
+    MTConcrete a -> do
+      ModMod abs <- checkErr $ lookupModule gr a
+      checkCompleteGrammar abs mo
+      js' <- mapMTree (checkCncInfo gr name (a,abs)) js
+      return $ (name, ModMod (Module mt fs me ops js')) : ms
+  _ -> return $ (name,mod) : ms
+ where
+   gr  = MGrammar $ (name,mod):ms
+
+checkAbsInfo :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info)
+checkAbsInfo st m (c,info) = do
+---- checkReservedId c
+ case info of
+   AbsCat (Yes cont) _ -> mkCheck "category" $ 
+     checkContext st cont ---- also cstrs
+   AbsFun (Yes typ) (Yes d) -> mkCheck "function" $ 
+     checkTyp st typ ----- ++ 
+     ----- checkEquation st (m,c) d  ---- also if there's no def!
+   _ -> return (c,info)
+ where
+   mkCheck cat ss = case ss of
+     [] -> return (c,info)
+     ["[]"] -> return (c,info) ----
+     _  -> checkErr $ prtBad (unlines ss ++++ "in" +++ cat) c
+
+checkCompleteGrammar :: SourceAbs -> SourceCnc -> Check ()
+checkCompleteGrammar abs cnc = mapM_ checkWarn $
+  checkComplete [f | (f, AbsFun (Yes _) _) <- abs'] cnc'
+   where
+     abs' = tree2list $ jments abs
+     cnc' = mapTree fst $ jments cnc
+     checkComplete sought given = foldr ckOne [] sought
+       where
+         ckOne f = if isInBinTree f given 
+                      then id
+                      else (("Warning: no linearization of" +++ prt f):)
+
+-- General Principle: only Yes-values are checked. 
+-- A May-value has always been checked in its origin module.
+
+checkResInfo :: SourceGrammar -> (Ident,Info) -> Check (Ident,Info)
+checkResInfo gr (c,info) = do
+  checkReservedId c
+  case info of
+
+    ResOper pty pde -> chIn "operation" $ do
+      (pty', pde') <- case (pty,pde) of
+         (Yes ty, Yes de) -> do
+           ty'     <- check ty typeType >>= comp . fst
+           (de',_) <- check de ty'
+           return (Yes ty', Yes de')
+         (Nope, Yes de) -> do
+           (de',ty') <- infer de
+           return (Yes ty', Yes de')
+         _ -> return (pty, pde) --- other cases are uninteresting
+      return (c, ResOper pty' pde')
+
+    ResParam (Yes pcs) -> chIn "parameter type" $ do
+      mapM_ ((mapM_ (checkIfParType gr . snd)) . snd) pcs
+      return (c,info)
+
+    _ ->  return (c,info)
+ where
+   infer = inferLType gr
+   check = checkLType gr
+   chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":")
+   comp = computeLType gr
+
+checkCncInfo :: SourceGrammar -> Ident -> (Ident,SourceAbs) -> 
+                (Ident,Info) -> Check (Ident,Info)
+checkCncInfo gr m (a,abs) (c,info) = do
+  checkReservedId c
+  case info of
+
+    CncFun _ (Yes trm) mpr -> chIn "linearization of" $ do
+      typ        <- checkErr $ lookupFunTypeSrc gr a c
+      cat0       <- checkErr $ valCat typ
+      (cont,val) <- linTypeOfType gr m typ         -- creates arg vars
+      (trm',_)   <- check trm (mkFunType (map snd cont) val)  -- erases arg vars
+      checkPrintname gr mpr
+      cat        <- return $ snd cat0
+      return (c, CncFun (Just (cat,(cont,val))) (Yes trm') mpr)
+                                                   -- cat for cf, typ for pe
+
+    CncCat (Yes typ) mdef mpr -> chIn "linearization type of" $ do
+      typ'  <- checkIfLinType gr typ
+      mdef' <- case mdef of
+        Yes def -> do
+          (def',_) <- checkLType gr def (mkFunType [typeStr] typ)
+          return $ Yes def'
+        _ -> return mdef
+      checkPrintname gr mpr
+      return (c,CncCat (Yes typ') mdef' mpr)
+
+    _ -> return (c,info)
+
+ where
+   env = gr
+   infer = inferLType gr
+   comp = computeLType gr 
+   check = checkLType gr
+   chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":")
+
+checkIfParType :: SourceGrammar -> Type -> Check ()
+checkIfParType st typ = checkCond ("Not parameter type" +++ prt typ) (isParType typ)
+  where
+   isParType ty = True ----
+{- case ty of
+     Cn typ -> case lookupConcrete st typ of
+       Ok (CncParType _ _ _) -> True
+       Ok (CncOper _ ty' _) -> isParType ty'
+       _ -> False
+     Q p t -> case lookupInPackage st (p,t) of
+       Ok (CncParType _ _ _) -> True
+       _ -> False
+     RecType r -> all (isParType . snd) r
+     _ -> False
+-}
+
+checkIfStrType :: SourceGrammar -> Type -> Check ()
+checkIfStrType st typ = case typ of
+  Table arg val -> do
+    checkIfParType st arg 
+    checkIfStrType st val
+  _ | typ == typeStr -> return ()
+  _ -> prtFail "not a string type" typ
+
+
+checkIfLinType :: SourceGrammar -> Type -> Check Type
+checkIfLinType st typ0 = do
+  typ <- computeLType st typ0
+  case typ of
+    RecType r -> do
+      let (lins,ihs) = partition (isLinLabel .fst) r
+      --- checkErr $ checkUnique $ map fst r
+      mapM_ checkInh ihs
+      mapM_ checkLin lins
+    _ -> prtFail "a linearization type must be a record type instead of" typ
+  return typ
+
+ where
+   checkInh (label,typ) = checkIfParType st typ
+   checkLin (label,typ) = checkIfStrType st typ
+
+
+computeLType :: SourceGrammar -> Type -> Check Type
+computeLType gr t = do
+  g0 <- checkGetContext
+  let g = [(x, Vr x) | (x,_) <- g0]
+  checkInContext g $ comp t
+ where
+  comp ty = case ty of
+
+    Q m ident -> do
+      ty' <- checkErr (lookupResDef gr m ident) 
+      if ty' == ty then return ty else comp ty' --- is this necessary to test?
+
+    Vr ident  -> checkLookup ident -- never needed to compute!
+
+    App f a -> do
+      f' <- comp f
+      a' <- comp a
+      case f' of
+        Abs x b -> checkInContext [(x,a')] $ comp b
+        _ -> return $ App f' a'
+
+    Prod x a b -> do
+      a' <- comp a
+      b' <- checkInContext [(x,Vr x)] $ comp b
+      return $ Prod x a' b'
+
+    Abs x b -> do
+      b' <- checkInContext [(x,Vr x)] $ comp b
+      return $ Abs x b'
+
+    ExtR r s -> do
+      r' <- comp r
+      s' <- comp s
+      case (r',s') of
+        (RecType rs, RecType ss) -> return $ RecType (rs ++ ss)
+        _ -> return $ ExtR r' s'
+
+    _ | isPredefConstant ty -> return ty
+
+    _ -> composOp comp ty
+
+checkPrintname :: SourceGrammar -> Perh Term -> Check ()
+checkPrintname st (Yes t) = checkLType st t typeStr >> return ()
+checkPrintname _ _ = return ()
+
+-- for grammars obtained otherwise than by parsing ---- update!!
+checkReservedId :: Ident -> Check ()
+checkReservedId x = let c = prt x in
+         if isResWord c 
+            then checkWarn ("Warning: reserved word used as identifier:" +++ c)
+            else return ()
+
+-- the underlying algorithms
+
+inferLType :: SourceGrammar -> Term -> Check (Term, Type)
+inferLType gr trm = case trm of
+
+   Q m ident -> checks [
+     termWith trm $ checkErr (lookupResType gr m ident)
+     ,
+     checkErr (lookupResDef gr m ident) >>= infer
+     ,
+     prtFail "cannot infer type of constant" trm
+     ]
+
+   QC m ident -> checks [
+     termWith trm $ checkErr (lookupResType gr m ident)
+     ,
+     checkErr (lookupResDef gr m ident) >>= infer
+     ,
+     prtFail "cannot infer type of canonical constant" trm
+     ]
+
+   Vr ident -> termWith trm $ checkLookup ident
+
+   App f a -> do
+     (f',fty) <- infer f
+     fty' <- comp fty
+     case fty' of
+       Prod z arg val -> do 
+         a' <- justCheck a arg
+         ty <- if isWildIdent z 
+                  then return val
+                  else substituteLType [(z,a')] val
+         return (App f' a',ty) 
+       _ -> prtFail ("function type expected for" +++ prt f +++ "instead of") fty
+
+   S f x -> do
+     (f', fty) <- infer f
+     case fty of
+       Table arg val -> do
+         x'<- justCheck x arg
+         return (S f' x', val)
+       _ -> prtFail "table lintype expected for the table in" trm
+
+   P t i -> do
+     (t',ty) <- infer t   --- ??
+     ty' <- comp ty
+     termWith (P t' i) $ checkErr $ case ty' of
+       RecType ts -> maybeErr ("unknown label" +++ show i +++ "in" +++ show ty') $ 
+                     lookup i ts
+       _ -> prtBad ("record type expected for" +++ prt t +++ "instead of") ty'
+
+   R r -> do
+     let (ls,fs) = unzip r
+     fsts <- mapM inferM fs
+     let ts = [ty | (Just ty,_) <- fsts]
+     checkCond ("cannot infer type of record"+++ prt trm) (length ts == length fsts)
+     return $ (R (zip ls fsts), RecType (zip ls ts))
+
+   T (TTyped arg) pts -> do
+     (_,val) <- checks $ map (inferCase (Just arg)) pts
+     check trm (Table arg val)
+   T (TComp arg) pts -> do
+     (_,val) <- checks $ map (inferCase (Just arg)) pts
+     check trm (Table arg val)
+   T ti pts -> do  -- tries to guess: good in oper type inference
+     let pts' = [pt | pt@(p,_) <- pts, isConstPatt p]
+     if null pts' 
+       then prtFail "cannot infer table type of" trm
+       else do 
+         (arg,val) <- checks $ map (inferCase Nothing) pts'
+         check trm (Table arg val)
+
+   K s  -> do
+     if elem ' ' s
+        then checkWarn ("Warning: space in token \"" ++ s ++ 
+                        "\". Lexical analysis may fail.")
+        else return ()
+     return (trm, typeTok)
+
+   EInt i -> return (trm, typeInt)
+
+   Empty -> return (trm, typeTok)
+
+   C s1 s2 -> 
+     check2 (flip justCheck typeStr) C s1 s2 typeStr
+
+   Glue s1 s2 -> 
+     check2 (flip justCheck typeStr) Glue s1 s2 typeStr ---- typeTok
+
+   Strs ts -> do
+     ts' <- mapM (\t -> justCheck t typeStr) ts 
+     return (Strs ts', typeStrs)
+
+   Alts (t,aa) -> do
+     t'  <- justCheck t typeStr
+     aa' <- flip mapM aa (\ (c,v) -> do
+        c' <- justCheck c typeStr 
+        v' <- justCheck v typeStrs
+        return (c',v'))
+     return (Alts (t',aa'), typeStr)
+
+   RecType r -> do
+     let (ls,ts) = unzip r
+     ts' <- mapM (flip justCheck typeType) ts 
+     return (RecType (zip ls ts'), typeType)
+
+   ExtR r s -> do
+     (r',rT) <- infer r 
+     rT'     <- comp rT
+     (s',sT) <- infer s
+     sT'     <- comp sT
+     let trm' = ExtR r' s'
+     case (rT', sT') of
+       (RecType rs, RecType ss) -> return (trm', RecType (rs ++ ss))
+       _ | rT' == typeType && sT' == typeType -> return (trm', typeType)
+       _ -> prtFail "records or record types expected in" trm
+
+   Sort _     -> 
+     termWith trm $ return typeType
+
+   Prod x a b -> do
+     a' <- justCheck a typeType
+     b' <- checkInContext [(x,a')] $ justCheck b typeType
+     return (Prod x a' b', typeType)
+
+   Table p t  -> do
+     p' <- justCheck p typeType --- check p partype! 
+     t' <- justCheck t typeType
+     return $ (Table p' t', typeType)
+
+   FV vs -> do
+     (ty,_) <- checks $ map infer vs
+---     checkIfComplexVariantType trm ty
+     check trm ty
+
+   _ -> prtFail "cannot infer lintype of" trm
+
+ where
+   env = gr
+   infer = inferLType env
+   comp = computeLType env 
+
+   check = checkLType env
+   
+   justCheck ty te = check ty te >>= return . fst
+
+   -- for record fields, which may be typed
+   inferM (mty, t) = do
+     (t', ty') <- case mty of
+       Just ty -> check ty t
+       _ -> infer t
+     return (Just ty',t')
+
+   inferCase mty (patt,term) = do
+     arg  <- maybe (inferPatt patt) return mty
+     cont <- pattContext env arg patt
+     i    <- checkUpdates cont
+     (_,val) <- infer term
+     checkResets i
+     return (arg,val)
+   isConstPatt p = case p of
+     PC _ ps -> True --- all isConstPatt ps
+     PP _ _ ps -> True --- all isConstPatt ps
+     PR ps -> all (isConstPatt . snd) ps
+     PT _ p -> isConstPatt p
+     _ -> False
+
+   inferPatt p = case p of
+     PP q c ps -> checkErr $ lookupResType gr q c >>= valTypeCnc
+     _ -> infer (patt2term p) >>= return . snd
+
+checkLType :: SourceGrammar -> Term -> Type -> Check (Term, Type)
+checkLType env trm typ0 = do
+
+  typ <- comp typ0
+
+  case trm of
+
+    Abs x c -> do
+      case typ of
+        Prod z a b -> do 
+          checkUpdate (x,a)
+          (c',b') <- if isWildIdent z
+                        then check c b
+                        else do
+                          b' <- checkIn "abs" $ substituteLType [(z,Vr x)] b
+                          check c b'
+          checkReset
+          return $ (Abs x c', Prod x a b')
+        _ -> prtFail "product expected instead of" typ
+
+    T _ [] ->
+      prtFail "found empty table in type" typ
+    T _ cs -> case typ of 
+      Table arg val -> do 
+        case allParamValues env arg of
+          Ok vs -> do
+            let ps0 = map fst cs
+            ps <- checkErr $ testOvershadow ps0 vs
+            if null ps 
+              then return () 
+              else checkWarn $ "Warning: patterns never reached:" +++ 
+                               concat (intersperse ", " (map prt ps))
+
+          _ -> return () -- happens with variable types
+        cs' <- mapM (checkCase arg val) cs
+        return (T (TTyped arg) cs', typ)
+      _ -> prtFail "table type expected for table instead of" typ
+
+    R r -> case typ of --- why needed? because inference may be too difficult
+       RecType rr -> do
+         let (ls,_) = unzip rr        -- labels of expected type
+         fsts <- mapM (checkM r) rr   -- check that they are found in the record
+         return $ (R fsts, typ)       -- normalize record
+
+       _ -> prtFail "record type expected in type checking instead of" typ
+
+    ExtR r s -> case typ of
+       _ | typ == typeType -> do
+         trm' <- comp trm
+         case trm' of
+           RecType _ -> termWith trm $ return typeType
+           _ -> prtFail "invalid record type extension" trm
+       RecType rr -> checks [
+         do (r',ty) <- infer r
+            case ty of
+              RecType rr1 -> do
+                s' <- justCheck s (minusRecType rr rr1)
+                return $ (ExtR r' s', typ) 
+              _ -> prtFail "record type expected in extension of" r
+         ,
+         do (s',ty) <- infer s
+            case ty of
+              RecType rr2 -> do 
+                r' <- justCheck r (minusRecType rr rr2)
+                return $ (ExtR r' s', typ) 
+              _ -> prtFail "record type expected in extension with" s
+         ]
+       _ -> prtFail "record extension not meaningful for" typ
+
+    FV vs -> do
+      ttys <- mapM (flip check typ) vs
+---      checkIfComplexVariantType trm typ
+      return (FV (map fst ttys), typ) --- typ' ?
+
+    S tab arg -> do
+      (tab',ty) <- infer tab
+      ty'       <- comp ty
+      case ty' of
+        Table p t -> do
+          (arg',val) <- check arg p
+          checkEq typ t trm
+          return (S tab' arg', t)
+        _ -> prtFail "table type expected for applied table instead of" ty'
+
+    Let (x,(mty,def)) body -> case mty of
+      Just ty -> do
+        (def',ty') <- check def ty
+        checkUpdate (x,ty')
+        body' <- justCheck body typ
+        checkReset
+        return (Let (x,(Just ty',def')) body', typ)
+      _ -> do
+        (def',ty) <- infer def  -- tries to infer type of local constant
+        check (Let (x,(Just ty,def')) body) typ
+
+    _ -> do
+      (trm',ty') <- infer trm
+      termWith trm' $ checkEq typ ty' trm'
+ where
+   cnc = env
+   infer = inferLType env
+   comp = computeLType env 
+
+   check = checkLType env
+   
+   justCheck ty te = check ty te >>= return . fst
+
+   checkEq = checkEqLType env
+
+   minusRecType rr rr1 = RecType [(l,v) | (l,v) <- rr, notElem l (map fst rr1)]
+
+   checkM rms (l,ty) = case lookup l rms of
+     Just (Just ty0,t) -> do
+       checkEq ty ty0 t
+       (t',ty') <- check t ty
+       return (l,(Just ty',t'))
+     Just (_,t) -> do
+       (t',ty') <- check t ty
+       return (l,(Just ty',t'))
+     _ -> prtFail "cannot find value for label" l
+
+   checkCase arg val (p,t) = do
+     cont <- pattContext env arg p
+     i    <- checkUpdates cont
+     t'   <- justCheck t val
+     checkResets i
+     return (p,t')
+
+pattContext :: LTEnv -> Type -> Patt -> Check Context
+pattContext env typ p = case p of
+  PV x -> return [(x,typ)]
+  PP q c ps -> do
+    t <- checkErr $ lookupResType cnc q c
+    (cont,v) <- checkErr $ typeFormCnc t
+    checkCond ("wrong number of arguments for constructor in" +++ prt p) 
+              (length cont == length ps)
+    checkEqLType env typ v (patt2term p)
+    mapM (uncurry (pattContext env)) (zip (map snd cont) ps) >>= return . concat
+  PR r -> do
+    typ' <- computeLType env typ
+    case typ' of
+      RecType t -> do
+        let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]]
+        mapM (uncurry (pattContext env)) pts >>= return . concat
+      _ -> prtFail "record type expected for pattern instead of" typ'
+  PT t p' -> do
+    checkEqLType env typ t (patt2term p')
+    pattContext env typ p'
+
+  _ -> return [] ----
+ where 
+   cnc = env
+
+-- auxiliaries
+
+type LTEnv = SourceGrammar
+
+termWith :: Term -> Check Type -> Check (Term, Type)
+termWith t ct = do
+  ty <- ct
+  return (t,ty)
+
+-- light-weight substitution for dep. types
+substituteLType :: Context -> Type -> Check Type
+substituteLType g t = case t of
+  Vr x -> return $ maybe t id $ lookup x g
+  _ -> composOp (substituteLType g) t
+
+-- compositional check/infer of binary operations
+check2 :: (Term -> Check Term) -> (Term -> Term -> Term) -> 
+          Term -> Term -> Type -> Check (Term,Type)
+check2 chk con a b t = do
+  a' <- chk a
+  b' <- chk b
+  return (con a' b', t)
+
+checkEqLType :: LTEnv -> Type -> Type -> Term -> Check Type
+checkEqLType env t u trm = do
+  t' <- comp t 
+  u' <- comp u
+  if alpha [] t' u' 
+     then return t'
+     else raise ("type of" +++ prt trm +++ 
+                ": expected" +++ prt t' ++ ", inferred" +++ prt u')
+ where
+   alpha g t u = case (t,u) of  --- quick hack version of TC.eqVal
+     (Prod x a b, Prod y c d) -> alpha g a c && alpha ((x,y):g) b d
+
+     ---- this should be made in Rename
+     (Q  m a, Q  n b) | a == b -> elem m (allExtends env n) 
+                               || elem n (allExtends env m)
+     (QC m a, QC n b) | a == b -> elem m (allExtends env n) 
+                               || elem n (allExtends env m)
+
+     (RecType rs, RecType ts) -> and [alpha g a b && l == k --- too strong req
+                                        | ((l,a),(k,b)) <- zip rs ts]
+                                  || -- if fails, try subtyping:
+                                 all (\ (l,a) -> 
+                                      any (\ (k,b) -> alpha g a b && l == k) ts) rs
+
+     (Table a b,  Table c d)  -> alpha g a c && alpha g b d
+     (Vr x,       Vr y)       -> x == y || elem (x,y) g || elem (y,x) g
+     _                        -> t == u 
+     --- the following should be one-way coercions only. AR 4/1/2001
+                                  || elem t sTypes && elem u sTypes
+                                  || (t == typeType && u == typePType) 
+                                  || (u == typeType && t == typePType) 
+
+   sTypes = [typeStr, typeTok, typeString]
+   comp = computeLType env
+
+-- linearization types and defaults
+
+linTypeOfType :: SourceGrammar -> Ident -> Type -> Check (Context,Type)
+linTypeOfType cnc m typ = do
+  (cont,cat) <- checkErr $ typeSkeleton typ
+  val  <- lookLin cat
+  args <- mapM mkLinArg (zip [0..] cont)
+  return (args, val)
+ where
+   mkLinArg (i,(n,mc@(m,cat))) = do
+     val  <- lookLin mc
+     let vars = mkRecType varLabel $ replicate n typeStr
+	 symb = argIdent n cat i
+     rec <- checkErr $ errIn ("extending" +++ prt vars +++ "with" +++ prt val) $
+            plusRecType vars val
+     return (symb,rec)
+   lookLin (_,c) = checks [ --- rather: update with defLinType ?
+      checkErr (lookupLincat cnc m c) >>= computeLType cnc
+     ,return defLinType
+     ]
+
+{-
+-- check if a type is complex in variants
+-- Not so useful as one might think, since variants of a complex type
+-- can be created indirectly: f (variants {True,False})
+
+checkIfComplexVariantType :: Term -> Type -> Check ()
+checkIfComplexVariantType e t = case t of
+  Prod _ _ _ -> cs
+  Table _ _  -> cs
+  RecType (_:_:_) -> cs
+  _ -> return ()
+ where
+   cs = case e of
+      FV (_:_) -> checkWarn $ "Warning:" +++ prt e +++ "has complex type" +++ prt t
+      _ -> return ()
+
+-}
diff --git a/src/GF/Compile/Compile.hs b/src/GF/Compile/Compile.hs
new file mode 100644
index 000000000..1e49946a6
--- /dev/null
+++ b/src/GF/Compile/Compile.hs
@@ -0,0 +1,207 @@
+module Compile where
+
+import Grammar
+import Ident
+import Option
+import PrGrammar
+import Update
+import Lookup
+import Modules
+import ModDeps
+import ReadFiles
+import ShellState
+import MkResource
+
+-- the main compiler passes
+import GetGrammar
+import Rename
+import Refresh
+import CheckGrammar
+import Optimize
+import GrammarToCanon
+import Share
+
+import qualified CanonToGrammar as CG
+
+import qualified GFC
+import qualified MkGFC
+import GetGFC
+
+import Operations
+import UseIO
+import Arch
+
+import Monad
+
+-- in batch mode: write code in a file
+
+batchCompile f = liftM fst $ compileModule defOpts emptyShellState f
+  where
+    defOpts = options [beVerbose, emitCode] 
+batchCompileOpt f = liftM fst $ compileModule defOpts emptyShellState f
+  where
+    defOpts = options [beVerbose, emitCode, optimizeCanon] 
+
+batchCompileOld f = compileOld defOpts f
+  where
+    defOpts = options [beVerbose, emitCode] 
+
+-- compile with one module as starting point
+
+compileModule :: Options -> ShellState -> FilePath -> 
+                 IOE (GFC.CanonGrammar, (SourceGrammar,[(FilePath,ModTime)]))
+compileModule opts st file = do
+  let ps   = pathListOpts opts
+  ioeIO $ print ps ----
+  let putp = putPointE opts
+  let rfs  = readFiles st
+  files <- getAllFiles ps rfs file
+  ioeIO $ print files ----
+  let names = map (fileBody . justFileName) files
+  ioeIO $ print names ----
+  let env0 = compileEnvShSt st names
+  (_,sgr,cgr) <- foldM (compileOne opts) env0 files
+  t <- ioeIO getNowTime
+  return $ (reverseModules cgr,       -- to preserve dependency order
+            (reverseModules sgr, --- keepResModules opts sgr, --- keep all so far
+             [(f,t) | f <- files]))   -- pass on the time of creation
+
+compileEnvShSt :: ShellState -> [ModName] -> CompileEnv
+compileEnvShSt st fs = (0,sgr,cgr) where
+  cgr = MGrammar [m | m@(i,_) <- modules (canModules st), notInc i]
+  sgr = MGrammar [m | m@(i,_) <- modules (srcModules st), notIns i]
+  notInc i = notElem (prt i) $ map fileBody fs
+  notIns i = notElem (prt i) $ map fileBody fs
+
+pathListOpts :: Options -> [InitPath]
+pathListOpts opts = maybe [""] pFilePaths $ getOptVal opts pathList
+
+reverseModules (MGrammar ms) = MGrammar $ reverse ms
+
+keepResModules :: Options -> SourceGrammar -> SourceGrammar
+keepResModules opts gr = 
+  if oElem retainOpers opts 
+    then MGrammar $ reverse [(i,mi) | (i,mi) <- modules gr, isResourceModule mi]
+    else emptyMGrammar
+
+
+-- the environment
+
+type CompileEnv = (Int,SourceGrammar, GFC.CanonGrammar)
+
+emptyCompileEnv :: CompileEnv
+emptyCompileEnv = (0,emptyMGrammar,emptyMGrammar)
+
+extendCompileEnvInt (_,MGrammar ss, MGrammar cs) (k,sm,cm) = 
+  return (k,MGrammar (sm:ss), MGrammar (cm:cs)) --- reverse later
+
+extendCompileEnv (k,s,c) (sm,cm) = extendCompileEnvInt (k,s,c) (k,sm,cm)
+
+compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
+compileOne opts env file = do
+
+  let putp = putPointE opts
+  let gf   = fileSuffix file
+  let path = justInitPath file
+  let name = fileBody file
+
+  case gf of
+    -- for canonical gf, just read the file and update environment
+    "gfc" -> do
+       cm <- putp ("+ reading" +++ file) $ getCanonModule file
+       sm <- ioeErr $ CG.canon2sourceModule cm
+       extendCompileEnv env (sm, cm)
+
+    -- for compiled resource, parse and organize, then update environment
+    "gfr" -> do
+       sm0  <- putp ("| parsing" +++ file) $ getSourceModule file
+       let mos = case env of (_,gr,_) -> modules gr
+       sm <- {- putp "creating indirections" $ -} ioeErr $ extendModule mos sm0
+       let gfc = gfcFile name 
+       cm <- putp ("+ reading" +++ gfc) $ getCanonModule gfc
+       extendCompileEnv env (sm,cm)
+
+    -- for gf source, do full compilation
+    _ -> do
+       sm0 <- putp ("- parsing" +++ file) $ getSourceModule file
+       (k',sm)  <- makeSourceModule opts env sm0
+       cm  <- putp "  generating code... " $ generateModuleCode opts path sm
+       extendCompileEnvInt env (k',sm,cm)
+
+-- dispatch reused resource at early stage
+
+makeSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule)
+makeSourceModule opts env@(k,gr,can) mo@(i,mi) = case mi of
+
+  ModMod m -> case mtype m of
+    MTReuse c -> do
+      sm <- ioeErr $ makeReuse gr i (extends m) c
+      let mo2 = (i, ModMod sm)
+          mos = modules gr
+      putp "  type checking reused" $ ioeErr $ showCheckModule mos mo2
+      return $ (k,mo2)
+    _ -> compileSourceModule opts env mo
+ where
+   putp = putPointE opts
+
+compileSourceModule :: Options -> CompileEnv -> SourceModule -> 
+                       IOE (Int,SourceModule)
+compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do
+
+  let putp = putPointE opts
+      mos  = modules gr
+
+  mo2:_ <- putp "  renaming " $ ioeErr $ renameModule mos mo
+
+  (mo3:_,warnings) <- putp "  type checking" $ ioeErr $ showCheckModule mos mo2
+  putStrE warnings
+
+  (k',mo3r:_) <- ioeErr $ refreshModule (k,mos) mo3
+
+  mo4:_ <- putp "  optimizing" $ ioeErr $ evalModule mos mo3r
+
+  return (k',mo4)
+
+generateModuleCode :: Options -> InitPath -> SourceModule -> IOE GFC.CanonModule
+generateModuleCode opts path minfo@(name,info) = do
+  let pname = prefixPathName path (prt name)
+  minfo0     <- ioeErr $ redModInfo minfo
+  minfo'     <- return $ if optim 
+                then shareModule fullOpt minfo0   -- parametrization and sharing
+                else shareModule basicOpt minfo0  -- sharing only
+
+  -- for resource, also emit gfr
+  case info of
+    ModMod m | mtype m == MTResource && emit && nomulti -> do
+      let (file,out) = (gfrFile pname, prGrammar (MGrammar [minfo]))
+      ioeIO $ writeFile file out >> putStr ("  wrote file" +++ file)
+    _ -> return ()
+  (file,out) <- do
+      code <- return $ MkGFC.prCanonModInfo minfo'
+      return (gfcFile pname, code)
+  if emit && nomulti 
+     then ioeIO $ writeFile file out >> putStr ("  wrote file" +++ file)
+     else return ()
+  return minfo'
+ where 
+   nomulti = not $ oElem makeMulti opts
+   emit  = oElem emitCode opts
+   optim = oElem optimizeCanon opts
+
+-- for old GF: sort into modules, write files, compile as usual
+
+compileOld :: Options -> FilePath -> IOE GFC.CanonGrammar
+compileOld opts file = do
+  let putp = putPointE opts
+  grammar1 <- putp ("- parsing old gf" +++ file) $ getOldGrammar file
+  files <- mapM writeNewGF $ modules grammar1
+  (_,_,grammar) <- foldM (compileOne opts) emptyCompileEnv files
+  return grammar
+
+writeNewGF :: SourceModule -> IOE FilePath
+writeNewGF m@(i,_) = do
+  let file = gfFile $ prt i
+  ioeIO $ writeFile file $ prGrammar (MGrammar [m])
+  ioeIO $ putStrLn $ "wrote file" +++ file
+  return file
+
diff --git a/src/GF/Compile/Extend.hs b/src/GF/Compile/Extend.hs
new file mode 100644
index 000000000..66a632445
--- /dev/null
+++ b/src/GF/Compile/Extend.hs
@@ -0,0 +1,77 @@
+module Extend where
+
+import Grammar
+import Ident
+import PrGrammar
+import Modules
+import Update
+import Macros
+import Operations
+
+import Monad
+
+-- AR 14/5/2003
+
+-- The top-level function $extendModInfo$
+-- extends a module symbol table by indirections to the module it extends
+
+extendModInfo :: Ident -> SourceModInfo -> SourceModInfo -> Err SourceModInfo
+extendModInfo name old new = case (old,new) of
+  (ModMod m0, ModMod (Module mt fs _ ops js)) -> do
+    testErr (mtype m0 == mt) ("illegal extension type at module" +++ show name)
+    js' <- extendMod name (jments m0) js
+    return $ ModMod (Module mt fs Nothing ops js)
+
+-- this is what happens when extending a module: new information is inserted,
+-- and the process is interrupted if unification fails
+
+extendMod :: Ident -> BinTree (Ident,Info) -> BinTree (Ident,Info) -> 
+             Err (BinTree (Ident,Info))
+extendMod name old new = 
+  foldM (tryInsert (extendAnyInfo name) (indirInfo name)) new $ tree2list old
+
+indirInfo :: Ident -> Info -> Info
+indirInfo n info = AnyInd b n' where 
+  (b,n') = case info of
+    ResValue _ -> (True,n)
+    ResParam _ -> (True,n)
+    AnyInd b k -> (b,k)
+    _ -> (False,n) ---- canonical in Abs
+
+{- ----
+case info of
+  AbsFun pty ptr -> AbsFun (perhIndir n pty) (perhIndir n ptr)
+  ---- find a suitable indirection for cat info!
+
+  ResOper pty ptr -> ResOper (perhIndir n pty) (perhIndir n ptr)
+  ResParam pp -> ResParam (perhIndir n pp) 
+  _ -> info
+
+  CncCat pty ptr ppr -> CncCat (perhIndir n pty) (perhIndir n ptr) (perhIndir n ppr)
+  CncFun m ptr   ppr -> CncFun m (perhIndir n ptr)                 (perhIndir n ppr)
+-}
+
+perhIndir :: Ident -> Perh a -> Perh a
+perhIndir n p = case p of
+  Yes _ -> May n
+  _ -> p
+
+extendAnyInfo :: Ident -> Info -> Info -> Err Info
+extendAnyInfo n i j = case (i,j) of
+  (AbsCat mc1 mf1, AbsCat mc2 mf2) -> 
+    liftM2 AbsCat (updatePerhaps n mc1 mc2) (updatePerhaps n mf1 mf2) --- add cstrs
+  (AbsFun mt1 md1, AbsFun mt2 md2) -> 
+    liftM2 AbsFun (updatePerhaps n mt1 mt2) (updatePerhaps n md1 md2) --- add defs
+
+  (ResParam mt1, ResParam mt2) -> liftM ResParam $ updatePerhaps n mt1 mt2
+  (ResValue mt1, ResValue mt2) -> liftM ResValue $ updatePerhaps n mt1 mt2
+  (ResOper mt1 m1, ResOper mt2 m2) -> 
+    liftM2 ResOper (updatePerhaps n mt1 mt2) (updatePerhaps n m1 m2)
+
+  (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> 
+    liftM3 CncCat (updatePerhaps n mc1 mc2) 
+                  (updatePerhaps n mf1 mf2) (updatePerhaps n mp1 mp2)
+  (CncFun m mt1 md1, CncFun _ mt2 md2) -> 
+    liftM2 (CncFun m) (updatePerhaps n mt1 mt2) (updatePerhaps n md1 md2)
+
+  _ -> Bad $ "cannot unify information for" +++ show n
diff --git a/src/GF/Compile/GetGrammar.hs b/src/GF/Compile/GetGrammar.hs
new file mode 100644
index 000000000..fb3fbf5ad
--- /dev/null
+++ b/src/GF/Compile/GetGrammar.hs
@@ -0,0 +1,71 @@
+module GetGrammar where
+
+import Operations
+import qualified ErrM as E ----
+
+import UseIO
+import Grammar
+import Modules
+import PrGrammar
+import qualified AbsGF as A
+import SourceToGrammar
+---- import Macros
+---- import Rename
+import Option
+--- import Custom
+import ParGF
+
+import ReadFiles ----
+
+import List (nub)
+import Monad (foldM)
+
+-- this module builds the internal GF grammar that is sent to the type checker
+
+getSourceModule :: FilePath -> IOE SourceModule
+getSourceModule file = do
+  string    <- readFileIOE file
+  let tokens = myLexer string
+  mo1  <- ioeErr $ err2err $ pModDef tokens
+  ioeErr $ transModDef mo1
+
+
+-- for old GF format with includes
+
+getOldGrammar :: FilePath -> IOE SourceGrammar
+getOldGrammar file = do
+  defs <- parseOldGrammarFiles file
+  let g = A.OldGr A.NoIncl defs
+  ioeErr $ transOldGrammar g file
+
+parseOldGrammarFiles :: FilePath -> IOE [A.TopDef]
+parseOldGrammarFiles file = do
+   putStrE $ "reading grammar of old format" +++ file
+   (_, g) <- getImports "" ([],[]) file
+   return g  -- now we can throw away includes
+  where 
+   getImports oldInitPath (oldImps, oldG) f = do
+     (path,s) <- readFileLibraryIOE oldInitPath f
+     if not (elem path oldImps) 
+       then do
+         (imps,g) <- parseOldGrammar path
+         foldM (getImports (initFilePath path)) (path : oldImps, g ++ oldG) imps
+       else 
+         return (oldImps, oldG)
+
+parseOldGrammar :: FilePath -> IOE ([FilePath],[A.TopDef])
+parseOldGrammar file = do
+  putStrE $ "reading old file" +++ file
+  s <- ioeIO $ readFileIf file
+  A.OldGr incl topdefs <- ioeErr $ err2err $ pOldGrammar $ myLexer $ fixNewlines s
+  includes <- ioeErr $ transInclude incl
+  return (includes, topdefs)
+
+----
+
+err2err :: E.Err a -> Err a
+err2err (E.Ok v) = Ok v
+err2err (E.Bad s) = Bad s
+
+ioeEErr = ioeErr . err2err
+
diff --git a/src/GF/Compile/GrammarToCanon.hs b/src/GF/Compile/GrammarToCanon.hs
new file mode 100644
index 000000000..d5977b510
--- /dev/null
+++ b/src/GF/Compile/GrammarToCanon.hs
@@ -0,0 +1,224 @@
+module GrammarToCanon where
+
+import Operations
+import Zipper
+import Option
+import Grammar
+import Ident
+import PrGrammar
+import Modules
+import Macros
+import qualified AbsGFC as G
+import qualified GFC as C
+import MkGFC
+---- import Alias
+import qualified PrintGFC as P
+
+import Monad
+
+-- compilation of optimized grammars to canonical GF. AR 5/10/2001 -- 12/5/2003
+
+-- This is the top-level function printing a gfc file
+
+showGFC :: SourceGrammar -> String
+showGFC = err id id . liftM (P.printTree . grammar2canon) . redGrammar
+
+-- any grammar, first trying without dependent types
+
+-- abstract syntax without dependent types
+
+redGrammar :: SourceGrammar -> Err C.CanonGrammar
+redGrammar (MGrammar gr) = liftM MGrammar $ mapM redModInfo gr
+
+redModInfo :: (Ident, SourceModInfo) -> Err (Ident, C.CanonModInfo)
+redModInfo (c,info) = do
+  c'    <- redIdent c
+  info' <- case info of
+    ModMod m -> do
+      (e,os) <- redExtOpen m
+      flags <- mapM redFlag $ flags m 
+      (a,mt) <- case mtype m of
+         MTConcrete a -> do
+           a' <- redIdent a
+           return (a', MTConcrete a') 
+         MTAbstract -> return (c',MTAbstract) --- c' not needed
+         MTResource -> return (c',MTResource) --- c' not needed
+      defss <- mapM (redInfo a) $ tree2list $ jments m
+      defs  <- return $ sorted2tree $ concat defss  -- sorted, but reduced
+      return $ ModMod $ Module mt flags e os defs
+  return (c',info')
+ where
+   redExtOpen m = do
+     e' <- case extends m of
+       Just e -> liftM Just $ redIdent e
+       _ -> return Nothing
+     os' <- mapM (\ (OQualif _ i) -> liftM OSimple (redIdent i)) $ opens m
+     return (e',os')
+
+redInfo :: Ident -> (Ident,Info) -> Err [(Ident,C.Info)]
+redInfo am (c,info) = errIn ("translating definition of" +++ prt c) $ do
+  c' <- redIdent c 
+  case info of
+    AbsCat (Yes cont) pfs -> do
+      returns c' $ C.AbsCat cont [] ---- constrs
+    AbsFun (Yes typ) pdf -> do
+      returns c' $ C.AbsFun typ (Eqs []) ---- df
+
+    ResParam (Yes ps) -> do
+      ps' <- mapM redParam ps
+      returns c' $ C.ResPar ps'
+
+    CncCat pty ptr ppr -> case (pty,ptr) of
+      (Yes ty, Yes (Abs _ t)) -> do
+        ty'  <- redCType ty
+        trm' <- redCTerm t
+        ppr' <- return $ G.FV []  ---- redCTerm 
+        return [(c', C.CncCat ty' trm' ppr')]
+      _ -> prtBad "cannot reduce rule for" c
+      
+    CncFun mt ptr ppr -> case (mt,ptr) of
+      (Just (cat,_), Yes trm) -> do
+        cat' <- redIdent cat
+        (xx,body,_) <- termForm trm
+        xx'   <- mapM redArgvar xx
+        body' <- errIn (prt body) $ redCTerm body ---- debug
+        ppr'  <- return $ G.FV []  ---- redCTerm 
+        return [(c',C.CncFun (G.CIQ am cat') xx' body' ppr')]
+      _ -> prtBad ("cannot reduce rule" +++ show info +++ "for") c ---- debug
+
+    AnyInd s b -> do
+      b' <- redIdent b
+      returns c' $ C.AnyInd s b'
+
+    _ -> return [] --- retain some operations
+ where
+   returns f i = return [(f,i)]
+
+redQIdent :: QIdent -> Err G.CIdent
+redQIdent (m,c) = return $ G.CIQ m c
+
+redIdent :: Ident -> Err Ident
+redIdent x 
+  | isWildIdent x = return $ identC "h_" --- needed in declarations
+  | otherwise = return $ identC $ prt x ---
+
+redFlag :: Option -> Err G.Flag
+redFlag (Opt (f,[x])) = return $ G.Flg (identC f) (identC x)
+redFlag o = Bad $ "cannot reduce option" +++ prOpt o
+
+redDecl :: Decl -> Err G.Decl
+redDecl (x,a) = liftM2 G.Decl (redIdent x) (redType a)
+
+redType :: Type -> Err G.Exp
+redType = redTerm
+
+redTerm :: Type -> Err G.Exp
+redTerm t = return $ rtExp t
+
+-- resource
+
+redParam :: Param -> Err G.ParDef
+redParam (c,cont) = do
+  c'    <- redIdent c
+  cont' <- mapM (redCType . snd) cont
+  return $ G.ParD c' cont'
+
+redArgvar :: Ident -> Err G.ArgVar
+redArgvar x = case x of
+  IA (x,i)     -> return $ G.A  (identC x) (toInteger i)
+  IAV (x,b,i) -> return $ G.AB (identC x) (toInteger b) (toInteger i)
+  _ -> Bad $ "cannot reduce" +++ show x +++ "as argument variable"
+
+redLindef :: Term -> Err G.Term
+redLindef t = case t of
+  Abs x b -> redCTerm b ---
+  _ -> redCTerm t
+
+redCType :: Type -> Err G.CType
+redCType t = case t of
+  RecType lbs -> do
+    let (ls,ts) = unzip lbs
+        ls' = map redLabel ls
+    ts' <- mapM redCType ts
+    return $ G.RecType $ map (uncurry G.Lbg) $ zip ls' ts'
+  Table p v  -> liftM2 G.Table (redCType p) (redCType v)
+  Q m c    -> liftM G.Cn $ redQIdent (m,c)
+  QC m c   -> liftM G.Cn $ redQIdent (m,c)
+  Sort "Str" -> return $ G.TStr
+  _ -> prtBad "cannot reduce to canonical the type" t
+
+redCTerm :: Term -> Err G.Term
+redCTerm t = case t of
+  Vr x -> liftM G.Arg $ redArgvar x
+  App _ _ -> do  -- only constructor applications can remain
+    (_,c,xx) <- termForm t
+    xx' <- mapM redCTerm xx
+    case c of
+      QC p c -> liftM2 G.Con (redQIdent (p,c)) (return xx')
+      _ -> prtBad "expected constructor head instead of" c
+  Q p c  -> liftM G.I (redQIdent (p,c))
+  QC p c -> liftM2 G.Con (redQIdent (p,c)) (return [])
+  R rs     -> do
+    let (ls,tts) = unzip rs
+        ls' = map redLabel ls
+    ts <- mapM (redCTerm . snd) tts
+    return $ G.R $ map (uncurry G.Ass) $ zip ls' ts
+  P tr l -> do
+    tr' <- redCTerm tr
+    return $ G.P tr' (redLabel l)
+  T i cs     -> do
+    ty  <- getTableType i
+    ty' <- redCType ty
+    let (ps,ts) = unzip cs
+    ps' <- mapM redPatt ps
+    ts' <- mapM redCTerm ts
+    return $ G.T ty' $ map (uncurry G.Cas) $ zip (map singleton ps') ts'
+  S u v -> liftM2 G.S (redCTerm u) (redCTerm v)
+  K s   -> return $ G.K (G.KS s)
+  C u v -> liftM2 G.C (redCTerm u) (redCTerm v)
+  FV ts -> liftM G.FV $ mapM redCTerm ts
+---  Ready ss -> return $ G.Ready [redStr ss] --- obsolete
+
+  Alts (d,vs) -> do ---
+    d'  <- redCTermTok d
+    vs' <- mapM redVariant vs
+    return $ G.K $ G.KP d' vs'
+
+  Empty -> return $ G.E
+
+---  Strs ss -> return $ G.Strs [s | K s <- ss] ---
+
+---- Glue obsolete in canon, should not occur here
+  Glue x y -> redCTerm (C x y)
+
+  _ -> Bad ("cannot reduce term" +++ prt t)
+
+redPatt :: Patt -> Err G.Patt
+redPatt p = case p of
+  PP m c ps -> liftM2 G.PC (redQIdent (m,c)) (mapM redPatt ps) 
+  PR rs -> do
+    let (ls,tts) = unzip rs
+        ls' = map redLabel ls
+    ts <- mapM redPatt tts
+    return $ G.PR $  map (uncurry G.PAss) $ zip ls' ts
+  PT _ q -> redPatt q
+  _ -> prtBad "cannot reduce pattern" p
+
+redLabel :: Label -> G.Label
+redLabel (LIdent s) = G.L $ identC s
+redLabel (LVar i)   = G.LV $ toInteger i
+
+redVariant :: (Term, Term) -> Err G.Variant
+redVariant (v,c) = do
+  v' <- redCTermTok v
+  c' <- redCTermTok c
+  return $ G.Var v' c'
+
+redCTermTok :: Term -> Err [String]
+redCTermTok t = case t of
+  K s   -> return [s]
+  Empty -> return []
+  C a b -> liftM2 (++) (redCTermTok a) (redCTermTok b)
+  Strs ss -> return [s | K s <- ss] ---
+  _ -> prtBad "cannot get strings from term" t
+
diff --git a/src/GF/Compile/MkResource.hs b/src/GF/Compile/MkResource.hs
new file mode 100644
index 000000000..8b3a01793
--- /dev/null
+++ b/src/GF/Compile/MkResource.hs
@@ -0,0 +1,75 @@
+module MkResource where
+
+import Grammar
+import Ident
+import Modules
+import Macros
+import PrGrammar
+
+import Operations
+
+import Monad
+
+-- extracting resource r from abstract + concrete syntax
+-- AR 21/8/2002 -- 22/6/2003 for GF with modules
+
+makeReuse :: SourceGrammar -> Ident -> Maybe Ident -> Ident -> Err SourceRes
+makeReuse gr r me c = do
+  mc <- lookupModule gr c
+
+  flags <- return [] --- no flags are passed: they would not make sense
+
+  (ops,jms) <- case mc of 
+    ModMod m -> case mtype m of
+      MTConcrete a -> do
+        ma <- lookupModule gr a
+        jmsA <- case ma of 
+           ModMod m' -> return $ jments m'
+           _ -> prtBad "expected abstract to be the type of" a
+        liftM ((,) (opens m)) $ mkResDefs r a me (extends m) jmsA (jments m)
+      _ -> prtBad "expected concrete to be the type of" c
+    _ -> prtBad "expected concrete to be the type of" c
+
+  return $ Module MTResource flags me ops jms
+
+mkResDefs :: Ident -> Ident -> Maybe Ident -> Maybe Ident -> 
+             BinTree (Ident,Info) -> BinTree (Ident,Info) -> 
+             Err (BinTree (Ident,Info))
+mkResDefs r a mext maext abs cnc = mapMTree mkOne abs where
+
+  mkOne (f,info) = case info of
+      AbsCat _ _ -> do
+        typ <- err (const (return defLinType)) return $ look f
+        return (f, ResOper (Yes typeType) (Yes typ))
+      AbsFun (Yes typ0) _ -> do
+        trm <- look f
+        typ <- redirTyp typ0 --- if isHardType typ0 then compute typ0 else ...
+        return (f, ResOper (Yes typ) (Yes trm))
+      AnyInd b _ -> case mext of
+        Just ext -> return (f,AnyInd b ext)
+        _ -> prtBad "no indirection possible in" r
+
+  look f = do
+     info <- lookupTree prt f cnc
+     case info of
+       CncCat (Yes ty) _ _ -> return ty
+       CncCat _ _ _        -> return defLinType
+       CncFun _ (Yes tr) _ -> return tr
+       _ -> prtBad "not enough information to reuse" f
+
+  -- type constant qualifications changed from abstract to resource
+  redirTyp ty = case ty of
+    Q n c | n == a -> return $ Q r c
+    Q n c | Just n == maext -> case mext of
+      Just ext -> return $ Q ext c
+      _ -> prtBad "no indirection of type possible in" r
+    _ -> composOp redirTyp ty
+
+{-
+-- for nicer printing of type signatures: preserves synonyms if not HO/dep type
+
+isHardType t = case t of
+  Prod x a b -> not (isWildIdent x) || isHardType a || isHardType b
+  App _ _    -> True
+  _          -> False  
+-}
diff --git a/src/GF/Compile/ModDeps.hs b/src/GF/Compile/ModDeps.hs
new file mode 100644
index 000000000..2aa042a95
--- /dev/null
+++ b/src/GF/Compile/ModDeps.hs
@@ -0,0 +1,88 @@
+module ModDeps where
+
+import Grammar
+import Ident
+import Option
+import PrGrammar
+import Update
+import Lookup
+import Modules
+
+import Operations
+
+import Monad
+
+-- AR 13/5/2003
+
+-- to check uniqueness of module names and import names, the
+-- appropriateness of import and extend types,
+-- to build a dependency graph of modules, and to sort them topologically
+
+mkSourceGrammar :: [(Ident,SourceModInfo)] -> Err SourceGrammar
+mkSourceGrammar ms = do
+  let ns = map fst ms
+  checkUniqueErr ns
+  mapM (checkUniqueImportNames ns . snd) ms
+  deps    <- moduleDeps ms
+  deplist <- either 
+               return 
+               (\ms -> Bad $ "circular modules" +++ unwords (map show ms)) $ 
+               topoTest deps
+  return $ MGrammar [(m, maybe undefined id $ lookup m ms)  | IdentM m _ <- deplist]
+
+checkUniqueErr ::  (Show i, Eq i) => [i] -> Err ()
+checkUniqueErr ms = do
+  let msg = checkUnique ms
+  if null msg then return () else Bad $ unlines msg
+
+-- check that import names don't clash with module names
+
+checkUniqueImportNames :: [Ident] -> SourceModInfo -> Err ()
+checkUniqueImportNames ns mo = case mo of
+  ModMod m -> test [n | OQualif n v <- opens m, n /= v]
+
+ where
+
+  test ms = testErr (all (`notElem` ns) ms)
+                    ("import names clashing with module names among" +++ 
+                       unwords (map prt ms))
+
+-- to decide what modules immediately depend on what, and check if the
+-- dependencies are appropriate
+
+type Dependencies = [(IdentM Ident,[IdentM Ident])]
+
+moduleDeps :: [(Ident,SourceModInfo)] -> Err Dependencies
+moduleDeps ms = mapM deps ms where
+  deps (c,mi) = errIn ("checking dependencies of module" +++ prt c) $ case mi of
+    ModMod m -> case mtype m of
+      MTConcrete a -> do
+        aty <- lookupModuleType gr a
+        testErr (aty == MTAbstract) "the for-module is not an abstract syntax" 
+        chDep (IdentM c (MTConcrete a)) 
+              (extends m) (MTConcrete a) (opens m) MTResource
+      t -> chDep (IdentM c t) (extends m) t (opens m) t
+
+  chDep it es ety os oty = do
+    ests <- case es of
+      Just e -> liftM singleton $ lookupModuleType gr e
+      _ -> return []
+    testErr (all (compatMType ety) ests) "inappropriate extension module type" 
+    osts <- mapM (lookupModuleType gr . openedModule) os
+    testErr (all (==oty) osts) "inappropriate open module type"
+    let ab = case it of
+               IdentM _ (MTConcrete a) -> [IdentM a MTAbstract]
+               _ -> [] ---- 
+    return (it, ab ++
+                [IdentM e ety | Just e <- [es]] ++ 
+                [IdentM (openedModule o) oty | o <- os])
+
+  -- check for superficial compatibility, not submodule relation etc
+  compatMType mt0 mt = case (mt0,mt) of
+    (MTConcrete _, MTConcrete _) -> True
+    (MTResourceImpl _, MTResourceImpl _) -> True
+    (MTReuse _, MTReuse _) -> True
+    ---- some more
+    _ -> mt0 == mt
+
+  gr = MGrammar ms --- hack
diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs
new file mode 100644
index 000000000..c901c3911
--- /dev/null
+++ b/src/GF/Compile/Optimize.hs
@@ -0,0 +1,171 @@
+module Optimize where
+
+import Grammar
+import Ident
+import Modules
+import PrGrammar
+import Macros
+import Lookup
+import Refresh
+import Compute
+import CheckGrammar
+import Update
+
+import Operations
+import CheckM
+
+import Monad
+import List
+
+-- partial evaluation of concrete syntax. AR 6/2001 -- 16/5/2003
+{-
+evalGrammar :: SourceGrammar -> Err SourceGrammar
+evalGrammar gr = do
+  gr2 <- refreshGrammar gr
+  mos <- foldM evalModule [] $ modules gr2
+  return $ MGrammar $ reverse mos 
+-}
+evalModule :: [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) -> 
+               Err [(Ident,SourceModInfo)]
+evalModule ms mo@(name,mod) = case mod of
+
+  ModMod (Module mt fs me ops js) -> case mt of
+    MTResource -> do
+      let deps = allOperDependencies name js
+      ids <- topoSortOpers deps
+      MGrammar (mod' : _) <- foldM evalOp gr ids
+      return $ mod' : ms
+    MTConcrete a -> do
+      js' <- mapMTree (evalCncInfo gr0 name a) js
+      return $ (name, ModMod (Module mt fs me ops js')) : ms
+
+    _ -> return $ (name,mod):ms
+ where
+   gr0 = MGrammar $ ms
+   gr  = MGrammar $ (name,mod) : ms
+
+   evalOp g@(MGrammar ((_, ModMod m) : _)) i = do
+     info  <- lookupTree prt i $ jments m
+     info' <- evalResInfo gr (i,info)
+     return $ updateRes g name i info'
+
+-- only operations need be compiled in a resource, and this is local to each
+-- definition since the module is traversed in topological order
+
+evalResInfo :: SourceGrammar -> (Ident,Info) -> Err Info
+evalResInfo gr (c,info) = case info of
+
+  ResOper pty pde -> eIn "operation" $ do
+    pde' <- case pde of
+       Yes de -> liftM yes $ comp de
+       _ -> return pde
+    return $ ResOper pty pde'
+
+  _ ->  return info
+ where
+   comp = computeConcrete gr
+   eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
+
+
+evalCncInfo :: 
+  SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err (Ident,Info)
+evalCncInfo gr cnc abs (c,info) = case info of
+
+  CncCat ptyp pde ppr -> do
+
+    pde' <- case (ptyp,pde) of
+      (Yes typ, Yes de) -> 
+        liftM yes $ pEval ([(strVar, typeStr)], typ) de
+      (Yes typ, Nope)   -> 
+        liftM yes $ mkLinDefault gr typ >>= pEval ([(strVar, typeStr)],typ)
+      (May b, Nope) ->
+        return $ May b
+      _ -> return pde   -- indirection
+
+    ppr' <- return ppr ----
+
+    return (c, CncCat ptyp pde' ppr')
+
+  CncFun (mt@(Just (_,ty))) pde ppr -> eIn ("linearization in type" +++  
+                                             show ty +++ "of") $ do
+    pde' <- case pde of
+      Yes de -> do
+        liftM yes $ pEval ty de
+      _ -> return pde
+    ppr' <- case ppr of
+      Yes pr -> liftM yes $ comp pr
+      _ -> return ppr  
+    return $ (c, CncFun mt pde' ppr') -- only cat in type actually needed
+
+  _ ->  return (c,info)
+ where
+   comp = computeConcrete gr
+   pEval = partEval gr
+   eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
+
+-- the main function for compiling linearizations
+
+partEval :: SourceGrammar -> (Context,Type) -> Term -> Err Term
+partEval gr (context, val) trm = do
+  let vars  = map fst context
+      args  = map Vr vars
+      subst = [(v, Vr v) | v <- vars]
+      trm1  = mkApp trm args
+  trm2 <- etaExpand val trm1 
+  trm3 <- comp subst trm2
+  return $ mkAbs vars trm3
+
+ where 
+
+   comp g t = {- refreshTerm t >>= -} computeTerm gr g t
+
+   etaExpand val t = recordExpand val t   --- >>= caseEx  -- done by comp
+
+-- here we must be careful not to reduce
+--   variants {{s = "Auto" ; g = N} ; {s = "Wagen" ; g = M}}
+--   {s  = variants {"Auto" ; "Wagen"} ; g  = variants {N ; M}} ;
+
+recordExpand :: Type -> Term -> Err Term
+recordExpand typ trm = case unComputed typ of
+  RecType tys -> case trm of
+    FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs]
+    _ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys]
+  _ -> return trm
+
+
+-- auxiliaries for compiling the resource
+
+allOperDependencies :: Ident -> BinTree (Ident,Info) -> [(Ident,[Ident])]
+allOperDependencies m b = 
+  [(f, nub (opty pty ++ opty pt)) | (f, ResOper pty pt) <- tree2list b]
+  where
+    opersIn t = case t of
+      Q n c | n == m -> [c]
+      _ -> collectOp opersIn t
+    opty (Yes ty) = opersIn ty
+    opty _ = []
+
+topoSortOpers :: [(Ident,[Ident])] -> Err [Ident]
+topoSortOpers st = do
+  let eops = topoTest st
+  either return (\ops -> Bad ("circular operations" +++ unwords (map prt (head ops)))) eops
+
+mkLinDefault :: SourceGrammar -> Type -> Err Term
+mkLinDefault gr typ = do
+  case unComputed typ of
+    RecType lts -> mapPairsM mkDefField lts >>= (return . Abs strVar . R . mkAssign)
+    _ -> prtBad "linearization type must be a record type, not" typ
+ where
+   mkDefField typ = case unComputed typ of
+     Table p t  -> do
+       t' <- mkDefField t
+       let T _ cs = mkWildCases t'
+       return $ T (TWild p) cs 
+     Sort "Str" -> return $ Vr strVar
+     QC q p     -> lookupFirstTag gr q p
+     RecType r  -> do
+       let (ls,ts) = unzip r
+       ts' <- mapM mkDefField ts
+       return $ R $ [assign l t | (l,t) <- zip ls ts']
+     _ -> prtBad "linearization type field cannot be" typ
+
diff --git a/src/GF/Compile/PGrammar.hs b/src/GF/Compile/PGrammar.hs
new file mode 100644
index 000000000..06d9fc72e
--- /dev/null
+++ b/src/GF/Compile/PGrammar.hs
@@ -0,0 +1,58 @@
+module PGrammar where
+
+---import LexGF
+import ParGF
+import SourceToGrammar
+import Grammar
+import Ident
+import qualified AbsGFC as A
+import qualified GFC as G
+import GetGrammar
+import Macros
+
+import Operations
+
+pTerm :: String -> Err Term
+pTerm s = do
+  e <- err2err $ pExp $ myLexer s
+  transExp e
+
+pTrm :: String -> Term
+pTrm = errVal (vr (zIdent "x")) . pTerm ---
+
+pTrms :: String -> [Term]
+pTrms = map pTrm . sep [] where
+  sep t cs = case cs of
+    ',' : cs2 -> reverse t : sep [] cs2
+    c   : cs2 -> sep (c:t) cs2
+    _         -> [reverse t]
+
+pTrm' :: String -> [Term]
+pTrm' = err (const []) singleton . pTerm
+
+pMeta :: String -> Integer
+pMeta _ = 0 ---
+
+pzIdent :: String -> Ident
+pzIdent = zIdent
+
+{-
+string2formsAndTerm :: String -> ([Term],Term)
+string2formsAndTerm s = case s of
+    '[':_:_ -> case span (/=']') s of  
+      (x,_:y) -> (pTrms (tail x), pTrm y)
+      _ -> ([],pTrm s)
+    _ -> ([], pTrm s)
+
+string2ident :: String -> Err Ident
+string2ident s = return $ case s of
+  c:'_':i -> identV (readIntArg i,[c]) ---
+  _ -> zIdent s
+
+-- reads the Haskell datatype
+readGrammar :: String -> Err GrammarST
+readGrammar s =  case [x | (x,t) <- reads s, ("","") <- lex t] of
+  [x] -> return x
+  []  -> Bad "no parse of Grammar"
+  _   -> Bad "ambiguous parse of Grammar"
+-}
diff --git a/src/GF/Compile/PrOld.hs b/src/GF/Compile/PrOld.hs
new file mode 100644
index 000000000..acce0ab67
--- /dev/null
+++ b/src/GF/Compile/PrOld.hs
@@ -0,0 +1,69 @@
+module PrOld where
+
+import PrGrammar
+import CanonToGrammar
+import qualified GFC
+import Grammar
+import Ident
+import Macros
+import Modules
+import qualified PrintGF as P
+import GrammarToSource
+
+import List
+import Operations
+import UseIO
+
+-- a hack to print gf2 into gf1 readable files
+-- Works only for canonical grammars, printed into GFC. Otherwise we would have
+-- problems with qualified names.
+--- printnames are not preserved, nor are lindefs
+
+printGrammarOld :: GFC.CanonGrammar -> String
+printGrammarOld gr = err id id $ do
+  as0 <- mapM canon2sourceModule [im | im@(_,ModMod m) <- modules gr, isModAbs m]
+  cs0 <- mapM canon2sourceModule 
+           [im | im@(_,ModMod m) <- modules gr, isModCnc m || isModRes m]
+  as1 <- return $ concatMap stripInfo $ concatMap (tree2list . js . snd) as0
+  cs1 <- return $ concatMap stripInfo $ concatMap (tree2list . js . snd) cs0
+  return $ unlines $ map prj $ srt as1 ++ srt cs1
+ where
+   js (ModMod m) = jments m
+   srt = sortBy (\ (i,_) (j,_) -> compare i j)
+   prj ii = P.printTree $ trAnyDef ii
+
+stripInfo :: (Ident,Info) -> [(Ident,Info)]
+stripInfo (c,i) = case i of
+  AbsCat   (Yes co) (Yes fs) -> rc $ AbsCat (Yes (stripContext co)) nope
+  AbsFun   (Yes ty) (Yes tr) -> rc $ AbsFun (Yes (stripTerm ty)) (Yes(stripTerm tr))
+  AbsFun   (Yes ty) _ -> rc $ AbsFun (Yes (stripTerm ty)) nope
+  ResParam (Yes ps)       -> rc $ ResParam (Yes [(c,stripContext co) | (c,co)<- ps])
+  CncCat   (Yes ty) _ _ -> rc $
+    CncCat (Yes (stripTerm ty)) nope nope
+  CncFun   _ (Yes tr) _ -> rc $ CncFun Nothing (Yes (stripTerm tr)) nope
+  _ -> []
+ where
+   rc j = [(c,j)]
+
+stripContext co = [(x, stripTerm t) | (x,t) <- co]
+
+stripTerm t = case t of
+  Q _ c -> Vr c
+  QC _ c -> Vr c
+  T ti cs -> T ti' [(stripPattern p, stripTerm c) | (p,c) <- cs] where
+               ti' = case ti of
+                  TTyped ty -> TTyped $ stripTerm ty
+                  TComp ty -> TComp $ stripTerm ty
+                  TWild ty -> TWild $ stripTerm ty
+                  _ -> ti
+  _ -> composSafeOp stripTerm t
+
+stripPattern p = case p of
+  PC c [] -> PV c
+  PP _ c [] -> PV c
+  PC c ps -> PC c (map stripPattern ps)
+  PP _ c ps -> PC c (map stripPattern ps)
+  PR lps -> PR [(l, stripPattern p) | (l,p) <- lps]
+  PT t p -> PT (stripTerm t) (stripPattern p)
+  _ -> p
+
diff --git a/src/GF/Compile/RemoveLiT.hs b/src/GF/Compile/RemoveLiT.hs
new file mode 100644
index 000000000..0e45be8c0
--- /dev/null
+++ b/src/GF/Compile/RemoveLiT.hs
@@ -0,0 +1,51 @@
+module RemoveLiT (removeLiT) where
+
+import Grammar
+import Ident
+import Modules
+import Macros
+import Lookup
+
+import Operations
+
+import Monad
+
+-- remove obsolete (Lin C) expressions before doing anything else. AR 21/6/2003
+
+-- What the program does is replace the occurrences of Lin C with the actual
+-- definition T given in lincat C = T ; with {s : Str} if no lincat is found.
+-- The procedule is uncertain, if T contains another Lin.
+
+removeLiT :: SourceGrammar -> Err SourceGrammar
+removeLiT gr = liftM MGrammar $ mapM (remlModule gr) (modules gr)
+
+remlModule :: SourceGrammar -> (Ident,SourceModInfo) -> Err (Ident,SourceModInfo)
+remlModule gr mi@(name,mod) = case mod of
+  ModMod (Module mt fs me ops js) -> do
+    js1 <- mapMTree (remlResInfo gr) js
+    let mod2 = ModMod $ Module mt fs me ops js1
+    return $ (name,mod2)
+  _ -> return mi
+
+remlResInfo :: SourceGrammar -> (Ident,Info) -> Err (Ident,Info)
+remlResInfo gr mi@(i,info) = case info of
+  ResOper pty ptr    -> liftM ((,) i) $ liftM2 ResOper (ren pty) (ren ptr)
+  CncCat pty ptr ppr -> liftM ((,) i) $ liftM3 CncCat (ren pty) (ren ptr) (ren ppr)
+  CncFun mt  ptr ppr -> liftM ((,) i) $ liftM2 (CncFun mt)      (ren ptr) (ren ppr)
+  _ -> return mi
+ where 
+   ren = remlPerh gr
+
+remlPerh gr pt = case pt of
+  Yes t -> liftM Yes $ remlTerm gr t
+  _ -> return pt
+
+remlTerm :: SourceGrammar -> Term -> Err Term
+remlTerm gr trm = case trm of
+  LiT c -> look c >>= remlTerm gr
+  _ -> composOp (remlTerm gr) trm
+ where
+   look c = err (const $ return defLinType) return $ lookupLincat gr m c
+   m = case [cnc | (cnc,ModMod m) <- modules gr, isModCnc m] of
+     cnc:_ -> cnc   -- actually there is always exactly one
+     _ -> zIdent "CNC" 
diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs
new file mode 100644
index 000000000..1e45b5fcc
--- /dev/null
+++ b/src/GF/Compile/Rename.hs
@@ -0,0 +1,263 @@
+module Rename where
+
+import Grammar
+import Modules
+import Ident
+import Macros
+import PrGrammar
+import Lookup
+import Extend
+import Operations
+
+import Monad
+
+-- AR 14/5/2003
+
+-- The top-level function $renameGrammar$ does several things:
+-- * extends each module symbol table by indirections to extended module
+-- * changes unqualified and as-qualified imports to absolutely qualified
+-- * goes through the definitions and resolves names
+-- Dependency analysis between modules has been performed before this pass.
+-- Hence we can proceed by $fold$ing 'from left to right'.
+
+renameGrammar :: SourceGrammar -> Err SourceGrammar
+renameGrammar g = liftM (MGrammar . reverse) $ foldM renameModule [] (modules g)
+
+-- this gives top-level access to renaming term input in the cc command
+renameSourceTerm :: SourceGrammar -> Ident -> Term -> Err Term
+renameSourceTerm g m t = do
+  mo     <- lookupErr m (modules g)
+  status <- buildStatus g m mo
+  renameTerm status [] t
+
+renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule]
+renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod of
+  ModMod (Module mt fs me ops js) -> do
+    (_,mod1@(ModMod m)) <- extendModule ms (name,mod)
+    let js1 = jments m
+    status <- buildStatus (MGrammar ms) name mod1
+    js2    <- mapMTree (renameInfo status) js1
+    let mod2 = ModMod $ Module mt fs me (map forceQualif ops) js2
+    return $ (name,mod2) : ms
+
+extendModule :: [SourceModule] -> SourceModule -> Err SourceModule
+extendModule ms (name,mod) = case mod of
+  ModMod (Module mt fs me ops js0) -> do
+    js  <- case mt of
+{- --- building the {s : Str} lincat
+      MTConcrete a -> do
+        ModMod ma <- lookupModule (MGrammar ms) a
+        let cats = [c | (c,AbsCat _ _) <- tree2list $ jments ma]
+            jscs = [(c,CncCat (yes defLinType) nope nope) | c <- cats]
+        return $ updatesTreeNondestr jscs js0
+-}
+      _ -> return js0
+    js1 <- case me of
+      Just n -> do
+        m0 <- case lookup n ms of
+          Just (ModMod m) -> do
+            testErr (sameMType (mtype m) mt) 
+                    ("illegal extension type to module" +++ prt name)
+            return m
+          _ -> Bad $ "cannot find extended module" +++ prt n
+        extendMod n (jments m0) js
+      _ -> return js
+    return $ (name,ModMod (Module mt fs Nothing ops js1))
+
+
+type Status = (StatusTree, [(OpenSpec Ident, StatusTree)])
+
+type StatusTree = BinTree (Ident,StatusInfo)
+
+type StatusInfo = Ident -> Term
+
+renameIdentTerm :: Status -> Term -> Err Term
+renameIdentTerm env@(act,imps) t = case t of
+  Vr c -> do
+    f <- lookupTreeMany prt opens c
+    return $ f c
+  Cn c -> do
+    f <- lookupTreeMany prt opens c
+    return $ f c
+  Q m' c -> do
+    m <- lookupErr m' qualifs
+    f <- lookupTree prt c m
+    return $ f c
+  QC m' c -> do
+    m <- lookupErr m' qualifs
+    f <- lookupTree prt c m
+    return $ f c
+  _ -> return t
+ where
+   opens   = act : [st  | (OSimple _,st) <- imps]
+   qualifs = [  (m, st) | (OQualif m _, st) <- imps]
+
+--- would it make sense to optimize this by inlining?
+renameIdentPatt :: Status -> Patt -> Err Patt
+renameIdentPatt env p = do
+  let t = patt2term p
+  t' <- renameIdentTerm env t
+  term2patt t'
+
+info2status :: Maybe Ident -> (Ident,Info) -> (Ident,StatusInfo)
+info2status mq (c,i) = (c, case i of
+  AbsFun _ (Yes (Con g)) | g == c -> maybe Con QC mq
+  ResValue _  -> maybe Con QC mq
+  ResParam _  -> maybe Con QC mq
+  AnyInd True m -> maybe Con (const (QC m)) mq
+  AnyInd False m -> maybe Cn (const (Q m)) mq
+  _           -> maybe Cn  Q mq
+  )
+
+tree2status :: OpenSpec Ident -> BinTree (Ident,Info) -> BinTree (Ident,StatusInfo)
+tree2status o = case o of
+  OSimple i   -> mapTree (info2status (Just i))
+  OQualif i j -> mapTree (info2status (Just j))
+
+buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Err Status
+buildStatus gr c mo = let mo' = self2status c mo in case mo of
+  ModMod m -> do
+    let ops  = opens m
+    mods <- mapM (lookupModule gr . openedModule) ops
+    let sts = map modInfo2status $ zip ops mods    
+    return $ if isModCnc m
+      then (NT, sts) -- the module itself does not define any names
+      else (mo',sts) -- so the empty ident is not needed
+
+modInfo2status :: (OpenSpec Ident,SourceModInfo) -> (OpenSpec Ident, StatusTree)
+modInfo2status (o,i) = (o,case i of
+  ModMod m -> tree2status o (jments m)
+  )
+
+self2status :: Ident -> SourceModInfo -> StatusTree
+self2status c i = case i of
+  ModMod m -> mapTree (info2status (Just c)) (jments m)   -- qualify internal
+---  ModMod m -> mapTree (resInfo2status Nothing) (jments m)
+-- change Lookup.qualifAnnot if you change this
+
+forceQualif o = case o of
+  OSimple i   -> OQualif i i
+  OQualif _ i -> OQualif i i
+  
+renameInfo :: Status -> (Ident,Info) -> Err (Ident,Info)
+renameInfo status (i,info) = errIn ("renaming definition of" +++ prt i) $ 
+                                liftM ((,) i) $ case info of
+  AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco)
+                                  (return pfs) ----
+  AbsFun pty ptr -> liftM2 AbsFun (ren pty) (ren ptr)
+
+  ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr)
+  ResParam pp -> liftM ResParam (renPerh (mapM (renameParam status)) pp)
+  ResValue t  -> liftM ResValue (ren t)
+  CncCat pty ptr ppr -> liftM3 CncCat (ren pty) (ren ptr) (ren ppr)
+  CncFun mt  ptr ppr -> liftM2 (CncFun mt)      (ren ptr) (ren ppr)
+  _ -> return info
+ where 
+   ren = renPerh rent
+   rent = renameTerm status []
+
+renPerh ren pt = case pt of
+  Yes t -> liftM Yes $ ren t
+  _ -> return pt
+
+renameTerm :: Status -> [Ident] -> Term -> Err Term
+renameTerm env vars = ren vars where
+  ren vs trm = case trm of
+    Abs x b    -> liftM  (Abs x) (ren (x:vs) b)
+    Prod x a b -> liftM2 (Prod x) (ren vs a) (ren (x:vs) b)
+    Vr x      
+      | elem x vs -> return trm
+      | otherwise -> renid trm
+    Cn _   -> renid trm
+    Con _  -> renid trm
+    Q _ _  -> renid trm
+    QC _ _ -> renid trm
+
+----    Eqs eqs -> Eqs (map (renameEquation consts vs) eqs)
+    T i cs -> do
+      i' <- case i of
+        TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source
+        _ -> return i
+      liftM (T i') $ mapM (renCase vs) cs  
+
+    Let (x,(m,a)) b -> do
+      m' <- case m of
+        Just ty -> liftM Just $ ren vs ty
+        _ -> return m
+      a' <- ren vs a
+      b' <- ren (x:vs) b
+      return $ Let (x,(m',a')) b'
+
+    P t@(Vr r) l                     -- for constant t we know it is projection
+      | elem r vs -> return trm                           -- var proj first
+      | otherwise -> case renid (Q r (label2ident l)) of  -- qualif   second
+          Ok t -> return t
+          _ -> liftM (flip P l) $ renid t                 -- const proj last
+
+    _ -> composOp (ren vs) trm
+
+  renid = renameIdentTerm env
+  renCase vs (p,t) = do
+    (p',vs') <- renpatt p
+    t' <- ren (vs' ++ vs) t
+    return (p',t')
+  renpatt = renamePattern env
+
+-- vars not needed in env, since patterns always overshadow old vars
+
+renamePattern :: Status -> Patt -> Err (Patt,[Ident])
+renamePattern env patt = case patt of
+
+  PC c ps -> do
+    c' <- renameIdentTerm env $ Cn c
+    psvss <- mapM renp ps
+    let (ps',vs) = unzip psvss
+    return $ case c' of
+      QC p d -> (PP p d ps', concat vs)
+      _ -> (PC c ps', concat vs)
+
+----  PP p c ps -> (PP p c ps',concat vs') where (ps',vs') = unzip $ map renp ps
+
+  PV x -> case renid patt of
+    Ok p -> return (p,[])
+    _    -> return (patt, [x])
+
+  PR r -> do
+    let (ls,ps) = unzip r
+    psvss <- mapM renp ps
+    let (ps',vs') = unzip psvss
+    return (PR (zip ls ps'), concat vs') 
+
+  _ -> return (patt,[])
+
+ where 
+   renp  = renamePattern env
+   renid = renameIdentPatt env
+
+renameParam :: Status -> (Ident, Context) -> Err (Ident, Context)
+renameParam env (c,co) = do
+  co' <- renameContext env co
+  return (c,co')
+
+renameContext :: Status -> Context -> Err Context
+renameContext b = renc [] where
+  renc vs cont = case cont of
+    (x,t) : xts 
+      | isWildIdent x -> do
+          t'   <- ren vs t
+          xts' <- renc vs xts
+          return $ (x,t') : xts'
+      | otherwise -> do
+          t'   <- ren vs t
+          let vs' = x:vs
+          xts' <- renc vs' xts
+          return $ (x,t') : xts'
+    _ -> return cont
+  ren = renameTerm b
+
+{-
+renameEquation :: Status -> [Ident] -> Equation -> Equation
+renameEquation b vs (ps,t) = (ps',renameTerm b (concat vs' ++ vs) t) where
+  (ps',vs') = unzip $ map (renamePattern b vs) ps
+-}
+
diff --git a/src/GF/Compile/ShellState.hs b/src/GF/Compile/ShellState.hs
new file mode 100644
index 000000000..f24c3b87c
--- /dev/null
+++ b/src/GF/Compile/ShellState.hs
@@ -0,0 +1,338 @@
+module ShellState where
+
+import Operations
+import GFC
+import AbsGFC
+---import CMacros
+import Look
+import qualified Modules as M
+import qualified Grammar as G
+import qualified PrGrammar as P
+import CF
+import CFIdent
+import CanonToCF
+import Morphology
+import Option
+import Ident
+import Arch (ModTime)
+
+-- AR 11/11/2001 -- 17/6/2003 (for modules) ---- unfinished
+
+-- multilingual state with grammars and options
+data ShellState = ShSt {
+  abstract   :: Maybe Ident ,        -- pointer to actual abstract; nothing in empty st
+  concrete   :: Maybe Ident ,        -- pointer to primary concrete
+  concretes  :: [(Ident,Ident)],     -- list of all concretes
+  canModules :: CanonGrammar ,       -- the place where abstracts and concretes reside
+  srcModules :: G.SourceGrammar ,    -- the place of saved resource modules
+  cfs        :: [(Ident,CF)] ,       -- context-free grammars
+  morphos    :: [(Ident,Morpho)],    -- morphologies
+  gloptions  :: Options,             -- global options
+  readFiles  :: [(FilePath,ModTime)],-- files read
+  absCats    :: [(G.Cat,(G.Context,  -- cats, their contexts, 
+                  [(G.Fun,G.Type)],          -- functions to them,
+                  [((G.Fun,Int),G.Type)]))], -- functions on them
+  statistics :: [Statistics]         -- statistics on grammars
+  }                             
+
+data Statistics = 
+    StDepTypes Bool        -- whether there are dependent types      
+  | StBoundVars [G.Cat]    -- which categories have bound variables
+  ---                      -- etc
+   deriving (Eq,Ord)
+
+emptyShellState = ShSt {
+  abstract   = Nothing,
+  concrete   = Nothing,
+  concretes  = [],
+  canModules = M.emptyMGrammar,
+  srcModules = M.emptyMGrammar,
+  cfs        = [],
+  morphos    = [],
+  gloptions  = noOptions,
+  readFiles  = [],
+  absCats    = [],
+  statistics = []
+  }
+
+type Language = Ident
+language = identC
+prLanguage = prIdent
+
+-- grammar for one language in a state, comprising its abs and cnc
+
+data StateGrammar = StGr {
+  absId   :: Ident,
+  cncId   :: Ident,
+  grammar :: CanonGrammar,
+  cf      :: CF,
+  morpho  :: Morpho
+  }
+
+emptyStateGrammar = StGr {
+  absId   = identC "#EMPTY", ---
+  cncId   = identC "#EMPTY", ---
+  grammar = M.emptyMGrammar,
+  cf      = emptyCF,
+  morpho  = emptyMorpho
+  }
+
+-- analysing shell grammar into parts
+stateGrammarST = grammar
+stateCF        = cf
+stateMorpho    = morpho
+stateOptions _ = noOptions ----
+
+cncModuleIdST = stateGrammarST
+
+-- form a shell state from a canonical grammar
+
+grammar2shellState :: Options -> (CanonGrammar, G.SourceGrammar) -> Err ShellState 
+grammar2shellState opts (gr,sgr) = updateShellState opts emptyShellState (gr,(sgr,[]))
+
+-- update a shell state from a canonical grammar
+
+updateShellState :: Options -> ShellState -> 
+                    (CanonGrammar,(G.SourceGrammar,[(FilePath,ModTime)])) -> 
+                    Err ShellState 
+updateShellState opts sh (gr,(sgr,rts)) = do 
+  let cgr = M.updateMGrammar (canModules sh) gr
+      a' = ifNull Nothing (return . last) $ allAbstracts cgr
+  abstr0 <- case abstract sh of
+    Just a -> do
+      --- test that abstract is compatible
+      return $ Just a
+    _ -> return a'
+  let concrs = maybe [] (allConcretes cgr) abstr0
+      concr0 = ifNull Nothing (return . last) concrs
+      notInrts f = notElem f $ map fst rts
+  cfs <- mapM (canon2cf opts cgr) concrs --- would not need to update all...
+
+  let funs = [] ---- funRulesOf cgr
+  let cats = [] ---- allCatsOf cgr
+  let csi  = [] ----
+{-
+             [(c,(co,
+                  [(fun,typ) | (fun,typ) <- funs, compatType tc typ], 
+                  funsOnTypeFs compatType funs tc))
+                                              | (c,co) <- cats, let tc = cat2type c]
+-}
+  let deps = True ---- not $ null $ allDepCats cgr
+  let binds = [] ---- allCatsWithBind cgr 
+
+  return $ ShSt {
+    abstract   = abstr0, 
+    concrete   = concr0, 
+    concretes  = zip concrs concrs,
+    canModules = cgr,
+    srcModules = M.updateMGrammar (srcModules sh) sgr,
+    cfs        = zip concrs cfs,
+    morphos    = zip concrs (repeat emptyMorpho),
+    gloptions  = opts,                            ---- -- global options
+    readFiles  = [ft | ft@(f,_) <- readFiles sh, notInrts f] ++ rts,
+    absCats    = csi,
+    statistics = [StDepTypes deps,StBoundVars binds]
+    }            
+
+prShellStateInfo :: ShellState -> String
+prShellStateInfo sh = unlines [
+  "main abstract :    " +++ maybe "(none)" P.prt (abstract sh),
+  "main concrete :    " +++ maybe "(none)" P.prt (concrete sh),
+  "all concretes :    " +++ unwords (map (P.prt . fst) (concretes sh)),
+  "canonical modules :" +++ unwords (map (P.prt .fst) (M.modules (canModules sh))),
+  "source modules :   " +++ unwords (map (P.prt .fst) (M.modules (srcModules sh))),
+  "global options :   " +++ prOpts (gloptions sh)
+  ]
+
+
+-- form just one state grammar, if unique, from a canonical grammar
+
+grammar2stateGrammar :: Options -> CanonGrammar -> Err StateGrammar 
+grammar2stateGrammar opts gr = do 
+  st    <- grammar2shellState opts (gr,M.emptyMGrammar)
+  concr <- maybeErr "no concrete syntax" $ concrete st 
+  return $ stateGrammarOfLang st concr
+
+-- all abstract modules
+allAbstracts :: CanonGrammar -> [Ident]
+allAbstracts gr = [i | (i,M.ModMod m) <- M.modules gr, M.mtype m == M.MTAbstract]
+
+-- the last abstract in dependency order
+greatestAbstract :: CanonGrammar -> Maybe Ident
+greatestAbstract gr = case allAbstracts gr of
+  [] -> Nothing
+  a -> return $ last a
+
+-- all concretes for a given abstract
+allConcretes :: CanonGrammar -> Ident -> [Ident]
+allConcretes gr a = [i | (i,M.ModMod m) <- M.modules gr, M.mtype m== M.MTConcrete a]
+
+stateGrammarOfLang :: ShellState -> Language -> StateGrammar
+stateGrammarOfLang st l = StGr {
+  absId   = maybe (identC "Abs") id (abstract st), ---
+  cncId   = l,
+  grammar = canModules st, ---- only those needed for l
+  cf      = maybe emptyCF id (lookup l (cfs st)),
+  morpho  = maybe emptyMorpho id (lookup l (morphos st))
+  }
+
+grammarOfLang st = stateGrammarST . stateGrammarOfLang st
+cfOfLang st      = stateCF        . stateGrammarOfLang st
+morphoOfLang st  = stateMorpho    . stateGrammarOfLang st
+optionsOfLang st = stateOptions   . stateGrammarOfLang st
+
+-- the last introduced grammar, stored in options, is the default for operations
+
+firstStateGrammar :: ShellState -> StateGrammar
+firstStateGrammar st = errVal emptyStateGrammar $ do
+  concr <- maybeErr "no concrete syntax" $ concrete st 
+  return $ stateGrammarOfLang st concr
+
+mkStateGrammar :: ShellState -> Language -> StateGrammar
+mkStateGrammar = stateGrammarOfLang
+
+-- analysing shell state into parts
+globalOptions = gloptions
+allLanguages  = map fst . concretes
+
+allStateGrammars = map snd . allStateGrammarsWithNames
+
+allStateGrammarsWithNames st = [(c, mkStateGrammar st c) | (c,_) <- concretes st]
+
+allGrammarFileNames st = [prLanguage c ++ ".gf" | (c,_) <- concretes st] ---
+
+{-
+allActiveStateGrammarsWithNames (ShSt (ma,gs,_)) = 
+  [(l, mkStateGrammar a c) | (l,((_,True),c)) <- gs, Just a <- [ma]]
+
+
+
+allActiveGrammars = map snd . allActiveStateGrammarsWithNames
+
+allGrammarSTs = map stateGrammarST . allStateGrammars
+allCFs        = map stateCF        . allStateGrammars
+
+firstGrammarST  = stateGrammarST . firstStateGrammar
+firstAbstractST = abstractOf . firstGrammarST
+firstConcreteST = concreteOf . firstGrammarST
+-}
+-- command-line option -language=foo overrides the actual grammar in state
+grammarOfOptState :: Options -> ShellState -> StateGrammar
+grammarOfOptState opts st = 
+  maybe (firstStateGrammar st) (stateGrammarOfLang st . language) $ 
+                                               getOptVal opts useLanguage
+
+-- command-line option -cat=foo overrides the possible start cat of a grammar
+firstCatOpts :: Options -> StateGrammar -> CFCat
+firstCatOpts opts sgr = 
+  maybe (stateFirstCat sgr) (string2CFCat (P.prt (absId sgr))) $ 
+    getOptVal opts firstCat
+
+-- a grammar can have start category as option startcat=foo ; default is S 
+stateFirstCat sgr =
+  maybe (string2CFCat a "S") (string2CFCat a) $ 
+  getOptVal (stateOptions sgr) gStartCat
+ where 
+   a = P.prt (absId sgr)
+
+-- the first cat for random generation
+firstAbsCat :: Options -> StateGrammar -> G.QIdent
+firstAbsCat opts sgr = 
+  maybe (absId sgr, identC "S") (\c -> (absId sgr, identC c)) $ ----
+    getOptVal opts firstCat
+
+{-
+-- command-line option -cat=foo overrides the possible start cat of a grammar
+stateTransferFun :: StateGrammar -> Maybe Fun
+stateTransferFun sgr = getOptVal (stateOptions sgr) transferFun >>= return . zIdent
+
+stateConcrete = concreteOf . stateGrammarST
+stateAbstract = abstractOf . stateGrammarST
+
+maybeStateAbstract (ShSt (ma,_,_)) = ma
+hasStateAbstract = maybe False (const True) . maybeStateAbstract
+abstractOfState = maybe emptyAbstractST id . maybeStateAbstract
+
+stateIsWord sg = isKnownWord (stateMorpho sg)
+
+
+-- getting info on a language
+existLang :: ShellState -> Language -> Bool
+existLang st lang = elem lang (allLanguages st)
+
+stateConcreteOfLang :: ShellState -> Language -> StateConcrete
+stateConcreteOfLang (ShSt (_,gs,_)) lang = 
+  maybe emptyStateConcrete snd $ lookup lang gs
+
+fileOfLang :: ShellState -> Language -> FilePath
+fileOfLang (ShSt (_,gs,_)) lang = 
+  maybe nonExistingLangFile (fst .fst) $ lookup lang gs
+
+nonExistingLangFile = "NON-EXISTING LANGUAGE" ---
+
+
+allLangOptions st lang = unionOptions (optionsOfLang st lang) (globalOptions st)
+
+-- construct state
+
+stateGrammar st cf mo opts = StGr ((st,cf,mo),opts)
+
+initShellState ab fs gs opts = 
+  ShSt (Just ab, [(getLangName f, ((f,True),g)) | (f,g) <- zip fs gs], opts)
+emptyInitShellState opts     = ShSt (Nothing, [], opts)
+
+-- the second-last part of a file name is the default language name
+getLangName :: String -> Language
+getLangName file = language (if notElem '.' file then file else langname) where
+ elif     = reverse file
+ xiferp   = tail (dropWhile (/='.') elif)
+ langname = reverse (takeWhile (flip notElem "./") xiferp)
+
+-- option -language=foo overrides the default language name
+getLangNameOpt :: Options -> String -> Language
+getLangNameOpt opts file = 
+  maybe (getLangName file) language $ getOptVal opts useLanguage
+-}
+-- modify state
+
+type ShellStateOper = ShellState -> ShellState
+
+reinitShellState :: ShellStateOper
+reinitShellState = const emptyShellState
+
+{-
+languageOn  = languageOnOff True
+languageOff = languageOnOff False
+
+languageOnOff :: Bool -> Language -> ShellStateOper
+languageOnOff b lang (ShSt (ab,gs,os)) = ShSt (ab, gs', os) where
+  gs' = [if lang==l then (l,((f,b),g)) else i | i@(l,((f,_),g)) <- gs]
+
+updateLanguage :: FilePath -> (Language, StateConcrete) -> ShellStateOper
+updateLanguage file (lang,gr) (ShSt (ab,gs,os)) = 
+  ShSt (ab, updateAssoc (lang,((file,True),gr)) gs, os') where
+    os' = changeOptVal os useLanguage (prLanguage lang) -- actualizes the new lang
+
+initWithAbstract :: AbstractST -> ShellStateOper
+initWithAbstract ab st@(ShSt (ma,cs,os)) = 
+  maybe (ShSt (Just ab,cs,os)) (const st) ma
+
+removeLanguage :: Language -> ShellStateOper
+removeLanguage lang (ShSt (ab,gs,os)) = ShSt (ab,removeAssoc lang gs, os)
+-}
+changeOptions :: (Options -> Options) -> ShellStateOper
+changeOptions f (ShSt a c cs can src cfs ms os ff ts ss) = 
+  ShSt a c cs can src cfs ms (f os) ff ts ss
+
+changeModTimes :: [(FilePath,ModTime)] -> ShellStateOper
+changeModTimes mfs (ShSt a c cs can src cfs ms os ff ts ss) = 
+  ShSt a c cs can src cfs ms os ff' ts ss
+ where
+   ff' = mfs ++ [mf | mf@(f,_) <- ff, notElem f (map fst mfs)]
+
+addGlobalOptions :: Options -> ShellStateOper
+addGlobalOptions = changeOptions . addOptions
+
+removeGlobalOptions :: Options -> ShellStateOper
+removeGlobalOptions = changeOptions . removeOptions
+
diff --git a/src/GF/Compile/Update.hs b/src/GF/Compile/Update.hs
new file mode 100644
index 000000000..9bc16f03a
--- /dev/null
+++ b/src/GF/Compile/Update.hs
@@ -0,0 +1,98 @@
+module Update where
+
+import Ident
+import Grammar
+import PrGrammar
+import Modules
+
+import Operations
+
+import List
+import Monad
+
+-- update a resource module by adding a new or changing an old definition
+
+updateRes :: SourceGrammar -> Ident -> Ident -> Info -> SourceGrammar
+updateRes gr@(MGrammar ms) m i info = MGrammar $ map upd ms where
+  upd (n,mod) 
+    | n /= m = (n,mod)
+    | n == m = case mod of
+       ModMod r -> (m,ModMod $ updateModule r i info)
+       _ -> (n,mod) --- no error msg
+
+-- combine a list of definitions into a balanced binary search tree
+
+buildAnyTree :: [(Ident,Info)] -> Err (BinTree (Ident, Info))
+buildAnyTree ias = do
+  ias' <- combineAnyInfos ias
+  return $ buildTree ias'
+
+
+-- unifying information for abstract, resource, and concrete
+
+combineAnyInfos :: [(Ident,Info)] -> Err [(Ident,Info)]
+combineAnyInfos = combineInfos unifyAnyInfo
+
+unifyAnyInfo :: Ident -> Info -> Info -> Err Info
+unifyAnyInfo c i j = errIn ("combining information for" +++ prt c) $ case (i,j) of
+  (AbsCat mc1 mf1, AbsCat mc2 mf2) -> 
+    liftM2 AbsCat (unifPerhaps mc1 mc2) (unifPerhaps mf1 mf2) ---- adding constrs
+  (AbsFun mt1 md1, AbsFun mt2 md2) -> 
+    liftM2 AbsFun (unifPerhaps mt1 mt2) (unifAbsDefs md1 md2) ---- adding defs
+
+  (ResParam mt1, ResParam mt2) -> liftM ResParam $ unifPerhaps mt1 mt2
+  (ResOper mt1 m1, ResOper mt2 m2) -> 
+    liftM2 ResOper (unifPerhaps mt1 mt2) (unifPerhaps m1 m2)
+
+  (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> 
+    liftM3 CncCat (unifPerhaps mc1 mc2) (unifPerhaps mf1 mf2) (unifPerhaps mp1 mp2)
+  (CncFun m mt1 md1, CncFun _ mt2 md2) -> 
+    liftM2 (CncFun m) (unifPerhaps mt1 mt2) (unifPerhaps md1 md2) ---- adding defs
+
+  _ -> Bad $ "cannot unify information for" +++ show i
+
+--- these auxiliaries should be somewhere else since they don't use the info types
+
+groupInfos :: Eq a => [(a,b)] -> [[(a,b)]]
+groupInfos = groupBy (\i j -> fst i == fst j)
+
+sortInfos :: Ord a => [(a,b)] -> [(a,b)]
+sortInfos = sortBy (\i j -> compare (fst i) (fst j))
+
+combineInfos :: Ord a => (a -> b -> b -> Err b) -> [(a,b)] -> Err [(a,b)]
+combineInfos f ris = do
+  let riss = groupInfos $ sortInfos ris
+  mapM (unifyInfos f) riss
+
+unifyInfos :: (a -> b -> b -> Err b) -> [(a,b)] -> Err (a,b)
+unifyInfos _ [] = Bad "empty info list"
+unifyInfos unif ris = do
+  let c = fst $ head ris
+  let infos = map snd ris
+  let ([i],is) = splitAt 1 infos 
+  info <- foldM (unif c) i is
+  return (c,info)
+
+tryInsert :: Ord a => (b -> b -> Err b) -> (b -> b) ->
+             BinTree (a,b) -> (a,b) -> Err (BinTree (a,b))
+tryInsert unif indir tree z@(x, info) = case tree of
+ NT -> return $ BT (x, indir info) NT NT
+ BT c@(a,info0) left right 
+   | x < a  -> do
+       left' <- tryInsert unif indir left z    
+       return $ BT c left' right 
+   | x > a  -> do
+       right' <- tryInsert unif indir right z    
+       return $ BT c left right' 
+   | x == a -> do
+       info' <- unif info info0
+       return $ BT (x,info') left right
+
+--- addToMaybeList m c = maybe (return c) (\old -> return (c ++ old)) m
+
+unifAbsDefs :: Perh Term -> Perh Term -> Err (Perh Term)
+unifAbsDefs p1 p2 = case (p1,p2) of
+  (Nope, _)  -> return p2
+  (_, Nope)  -> return p1
+  (Yes (Eqs bs), Yes (Eqs ds)) -> return $ yes $ Eqs $ bs ++ ds --- order!
+  _ -> Bad "update conflict"
diff --git a/src/GF/Data/ErrM.hs b/src/GF/Data/ErrM.hs
new file mode 100644
index 000000000..eb2078718
--- /dev/null
+++ b/src/GF/Data/ErrM.hs
@@ -0,0 +1,7 @@
+module ErrM (
+  module Operations
+) where
+
+import Operations
+
+-- hack for BNFC generated files. AR 21/9/2003
diff --git a/src/GF/Data/Operations.hs b/src/GF/Data/Operations.hs
new file mode 100644
index 000000000..7110a7ac0
--- /dev/null
+++ b/src/GF/Data/Operations.hs
@@ -0,0 +1,559 @@
+module Operations where
+
+import Char  (isSpace, toUpper, isSpace, isDigit)
+import List  (nub, sortBy, sort, deleteBy, nubBy)
+import Monad (liftM2)
+
+infixr 5 +++
+infixr 5 ++-
+infixr 5 ++++
+infixr 5 +++++
+infixl 9 !?
+
+-- some auxiliary GF operations. AR 19/6/1998 -- 6/2/2001
+-- Copyright (c) Aarne Ranta 1998-2000, under GNU General Public License (see GPL)
+
+ifNull :: b -> ([a] -> b) -> [a] -> b
+ifNull b f xs = if null xs then b else f xs
+  
+-- the Error monad
+
+data Err a = Ok a | Bad String   -- like Maybe type with error msgs
+  deriving (Read, Show, Eq)
+
+instance Monad Err where
+  return      = Ok
+  Ok a  >>= f = f a
+  Bad s >>= f = Bad s
+
+-- analogue of maybe
+err :: (String -> b) -> (a -> b) -> Err a -> b 
+err d f e = case e of
+  Ok a -> f a
+  Bad s -> d s
+
+-- add msg s to Maybe failures
+maybeErr :: String -> Maybe a -> Err a
+maybeErr s = maybe (Bad s) Ok
+
+testErr :: Bool -> String -> Err ()
+testErr cond msg = if cond then return () else Bad msg
+
+errVal :: a -> Err a -> a
+errVal a = err (const a) id
+
+errIn :: String -> Err a -> Err a
+errIn msg = err (\s -> Bad (s ++++ "OCCURRED IN" ++++ msg)) return
+
+-- used for extra error reports when developing GF
+derrIn :: String -> Err a -> Err a
+derrIn m = errIn m -- id
+
+performOps :: [a -> Err a] -> a -> Err a
+performOps ops a = case ops of
+  f:fs -> f a >>= performOps fs
+  [] -> return a
+
+repeatUntilErr :: (a -> Bool) -> (a -> Err a) -> a -> Err a
+repeatUntilErr cond f a = if cond a then return a else f a >>= repeatUntilErr cond f
+
+repeatUntil :: (a -> Bool) -> (a -> a) -> a -> a
+repeatUntil cond f a = if cond a then a else repeatUntil cond f (f a)
+
+okError :: Err a -> a
+okError = err (error "no result Ok") id
+
+isNotError :: Err a -> Bool
+isNotError = err (const False) (const True)
+
+showBad :: Show a => String -> a -> Err b
+showBad s a = Bad (s +++ show a)
+
+lookupErr :: (Eq a,Show a) => a -> [(a,b)] -> Err b
+lookupErr a abs = maybeErr ("Unknown" +++ show a) (lookup a abs)
+
+lookupErrMsg :: (Eq a,Show a) => String -> a -> [(a,b)] -> Err b
+lookupErrMsg m a abs = maybeErr (m +++ "gave unknown" +++ show a) (lookup a abs)
+
+lookupDefault :: Eq a => b -> a -> [(a,b)] -> b
+lookupDefault d x l = maybe d id $  lookup x l 
+
+updateLookupList ::  Eq a => (a,b) -> [(a,b)] -> [(a,b)]
+updateLookupList ab abs = insert ab [] abs where
+ insert c cc [] = cc ++ [c]
+ insert (a,b) cc ((a',b'):cc') = if   a == a' 
+                                 then cc ++ [(a,b)] ++ cc'
+                                 else insert (a,b) (cc ++ [(a',b')]) cc'
+
+mapPairListM :: Monad m => ((a,b) -> m c) -> [(a,b)] -> m [(a,c)]
+mapPairListM f xys =
+  do yy' <- mapM f xys
+     return (zip (map fst xys) yy')
+
+mapPairsM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)]
+mapPairsM f xys =
+  do let (xx,yy) = unzip xys
+     yy' <- mapM f yy
+     return (zip xx yy')
+
+pairM :: Monad a => (b -> a c) -> (b,b) -> a (c,c)
+pairM op (t1,t2) = liftM2 (,) (op t1) (op t2)
+
+-- like mapM, but continue instead of halting with Err
+mapErr :: (a -> Err b) -> [a] -> Err ([b], String) 
+mapErr f xs = Ok (ys, unlines ss) 
+  where
+    (ys,ss) = ([y | Ok y <- fxs], [s | Bad s <- fxs])
+    fxs = map f xs
+
+-- !! with the error monad
+(!?) :: [a] -> Int -> Err a
+xs !? i = foldr (const . return) (Bad "too few elements in list") $ drop i xs
+
+errList :: Err [a] -> [a]
+errList = errVal []
+
+singleton :: a -> [a]
+singleton = (:[])
+
+-- checking
+
+checkUnique :: (Show a, Eq a) => [a] -> [String]
+checkUnique ss = ["overloaded" +++ show s | s <- nub overloads] where
+  overloads = filter overloaded ss
+  overloaded s = length (filter (==s) ss) > 1
+
+titleIfNeeded :: a -> [a] -> [a]
+titleIfNeeded a [] = []
+titleIfNeeded a as = a:as
+
+errMsg :: Err a -> [String]
+errMsg (Bad m) = [m]
+errMsg _ = []
+
+errAndMsg :: Err a -> Err (a,[String])
+errAndMsg (Bad m) = Bad m
+errAndMsg (Ok a) = return (a,[])
+
+-- a three-valued maybe type to express indirections
+
+data Perhaps a b = Yes a | May b | Nope deriving (Show,Read,Eq,Ord)
+
+yes = Yes
+may = May
+nope = Nope
+
+mapP :: (a -> c) -> Perhaps a b -> Perhaps c b
+mapP f p = case p of
+  Yes a -> Yes (f a)
+  May b -> May b
+  Nope  -> Nope
+
+-- this is what happens when matching two values in the same module
+unifPerhaps :: Perhaps a b -> Perhaps a b -> Err (Perhaps a b)
+unifPerhaps p1 p2 = case (p1,p2) of
+  (Nope, _)  -> return p2
+  (_, Nope)  -> return p1
+  _ -> Bad "update conflict"
+
+-- this is what happens when updating a module extension
+updatePerhaps :: b -> Perhaps a b -> Perhaps a b -> Err (Perhaps a b)
+updatePerhaps old p1 p2 = case (p1,p2) of
+  (Yes a,    Nope)  -> return $ may old
+  (May older,Nope)  -> return $ may older
+  (_, May a)        -> Bad "strange indirection"
+  _ -> unifPerhaps p1 p2
+
+-- binary search trees
+
+data BinTree a = NT | BT a (BinTree a) (BinTree a) deriving (Show,Read)
+
+isInBinTree :: (Ord a) => a -> BinTree a -> Bool
+isInBinTree x tree = case tree of
+ NT -> False
+ BT a left right 
+   | x < a  -> isInBinTree x left
+   | x > a  -> isInBinTree x right
+   | x == a -> True
+
+-- quick method to see if two trees have common elements
+-- the complexity is O(log |old|, |new|) so the heuristic is that new is smaller
+
+commonsInTree :: (Ord a) => BinTree (a,b) -> BinTree (a,b) -> [(a,(b,b))]
+commonsInTree old new = foldr inOld [] new' where
+  new' = tree2list new
+  inOld (x,v) xs = case justLookupTree x old of
+    Ok v' -> (x,(v',v)) : xs
+    _ -> xs
+
+justLookupTree :: (Ord a) => a -> BinTree (a,b) -> Err b
+justLookupTree = lookupTree (const [])
+
+lookupTree :: (Ord a) => (a -> String) -> a -> BinTree (a,b) -> Err b
+lookupTree pr x tree = case tree of
+ NT -> Bad ("no occurrence of element" +++ pr x)
+ BT (a,b) left right 
+   | x < a  -> lookupTree pr x left
+   | x > a  -> lookupTree pr x right
+   | x == a -> return b
+
+lookupTreeEq :: (Ord a) => 
+     (a -> String) -> (a -> a -> Bool) -> a -> BinTree (a,b) -> Err b
+lookupTreeEq pr eq x tree = case tree of
+ NT -> Bad ("no occurrence of element equal to" +++ pr x)
+ BT (a,b) left right 
+   | eq x a -> return b     -- a weaker equality relation than ==
+   | x < a  -> lookupTreeEq pr eq x left
+   | x > a  -> lookupTreeEq pr eq x right
+
+lookupTreeMany :: Ord a => (a -> String) -> [BinTree (a,b)] -> a -> Err b
+lookupTreeMany pr (t:ts) x = case lookupTree pr x t of
+  Ok v -> return v
+  _ -> lookupTreeMany pr ts x
+lookupTreeMany pr [] x = Bad $ "failed to find" +++ pr x
+
+-- destructive update
+
+updateTree :: (Ord a) => (a,b) -> BinTree (a,b) -> BinTree (a,b)
+updateTree = updateTreeGen True
+
+-- destructive or not
+
+updateTreeGen :: (Ord a) => Bool -> (a,b) -> BinTree (a,b) -> BinTree (a,b)
+updateTreeGen destr z@(x,y) tree = case tree of
+ NT -> BT z NT NT
+ BT c@(a,b) left right 
+   | x < a  -> let left' = updateTree z left in   BT c left' right 
+   | x > a  -> let right' = updateTree z right in BT c left right' 
+   | otherwise -> if destr
+                    then BT z left right -- removing the old value of a
+                    else tree            -- retaining the old value if one exists
+
+updateTreeEq :: 
+  (Ord a) => (a -> a -> Bool) -> (a,b) -> BinTree (a,b) -> BinTree (a,b)
+updateTreeEq eq z@(x,y) tree = case tree of
+ NT -> BT z NT NT
+ BT c@(a,b) left right
+   | eq x a -> BT (a,y) left right -- removing the old value of a 
+   | x < a  -> let left' = updateTree z left in   BT c left' right 
+   | x > a  -> let right' = updateTree z right in BT c left right' 
+
+updatesTree :: (Ord a) => [(a,b)] -> BinTree (a,b) -> BinTree (a,b)
+updatesTree (z:zs) tr = updateTree z t where t = updatesTree zs tr
+updatesTree [] tr = tr
+
+updatesTreeNondestr :: (Ord a) => [(a,b)] -> BinTree (a,b) -> BinTree (a,b)
+updatesTreeNondestr xs tr = case xs of
+  (z:zs) -> updateTreeGen False z t where t = updatesTreeNondestr zs tr
+  _ -> tr
+
+buildTree :: (Ord a) => [(a,b)] -> BinTree (a,b)
+buildTree = sorted2tree . sortBy fs where
+  fs (x,_) (y,_) 
+    | x < y = LT
+    | x > y = GT
+    | True  = EQ 
+-- buildTree zz = updatesTree zz NT
+
+sorted2tree :: [(a,b)] -> BinTree (a,b)
+sorted2tree [] = NT
+sorted2tree xs = BT x (sorted2tree t1) (sorted2tree t2) where
+  (t1,(x:t2)) = splitAt (length xs `div` 2) xs
+
+mapTree :: (a -> b) -> BinTree a -> BinTree b
+mapTree f NT = NT
+mapTree f (BT a left right) = BT (f a) (mapTree f left) (mapTree f right)
+
+mapMTree :: Monad m => (a -> m b) -> BinTree a -> m (BinTree b)
+mapMTree f NT = return NT
+mapMTree f (BT a left right) = do
+ a'     <- f a
+ left'  <- mapMTree f left 
+ right' <- mapMTree f right
+ return $ BT a' left' right'
+
+tree2list :: BinTree a -> [a] -- inorder
+tree2list NT = []
+tree2list (BT z left right) = tree2list left ++ [z] ++ tree2list right
+
+depthTree :: BinTree a -> Int
+depthTree NT = 0
+depthTree (BT _ left right) = 1 + max (depthTree left) (depthTree right)
+
+mergeTrees :: Ord a => BinTree (a,b) -> BinTree (a,b) -> BinTree (a,[b])
+mergeTrees old new = foldr upd new' (tree2list old) where
+  upd xy@(x,y) tree = case tree of
+    NT -> BT (x,[y]) NT NT
+    BT (a,bs) left right 
+      | x < a  -> let left'  = upd xy left  in BT (a,bs) left' right 
+      | x > a  -> let right' = upd xy right in BT (a,bs) left  right' 
+      | otherwise -> BT (a, y:bs) left right -- adding the new value
+  new' = mapTree (\ (i,d) -> (i,[d])) new
+
+
+-- parsing
+
+type WParser a b = [a] -> [(b,[a])] -- old Wadler style parser
+
+wParseResults :: WParser a b -> [a] -> [b]
+wParseResults p aa = [b | (b,[]) <- p aa]
+
+-- printing
+
+indent :: Int -> String -> String
+indent i s = replicate i ' ' ++ s
+
+a +++ b   = a ++ " "    ++ b
+a ++- ""  = a 
+a ++- b   = a +++ b
+a ++++ b  = a ++ "\n"   ++ b
+a +++++ b = a ++ "\n\n" ++ b
+
+prUpper :: String -> String
+prUpper s = s1 ++ s2' where
+ (s1,s2) = span isSpace s
+ s2' = case s2 of
+   c:t -> toUpper c : t
+   _ -> s2
+
+prReplicate n s = concat (replicate n s)
+
+prTList t ss = case ss of
+  []   -> ""
+  [s]  -> s
+  s:ss -> s ++ t ++ prTList t ss
+
+prQuotedString x = "\"" ++ restoreEscapes x ++ "\""
+
+prParenth s = if s == "" then "" else "(" ++ s ++ ")"
+
+prCurly   s = "{" ++ s ++ "}"
+prBracket s = "[" ++ s ++ "]"
+
+prArgList xx = prParenth (prTList "," xx)
+
+prSemicList = prTList " ; "
+
+prCurlyList = prCurly . prSemicList
+
+restoreEscapes s = 
+  case s of 
+    []       -> []
+    '"' : t  -> '\\' : '"'  : restoreEscapes t
+    '\\': t  -> '\\' : '\\' : restoreEscapes t
+    c   : t  -> c : restoreEscapes t
+
+numberedParagraphs :: [[String]] -> [String]
+numberedParagraphs t = case t of 
+  []   -> []
+  p:[] -> p
+  _    -> concat [(show n ++ ".") : s | (n,s) <- zip [1..] t]
+
+prConjList :: String -> [String] -> String
+prConjList c []     = ""
+prConjList c [s]    = s
+prConjList c [s,t]  = s +++ c +++ t
+prConjList c (s:tt) = s ++ "," +++ prConjList c tt
+
+prIfEmpty :: String -> String -> String -> String -> String
+prIfEmpty em _    _    [] = em
+prIfEmpty em nem1 nem2 s  = nem1 ++ s ++ nem2
+
+-- Thomas Hallgren's wrap lines
+--- optWrapLines = if argFlag "wraplines" True then wrapLines 0 else id
+wrapLines n "" = ""
+wrapLines n s@(c:cs) =
+      if isSpace c
+      then c:wrapLines (n+1) cs
+      else case lex s of
+            [(w,rest)] -> if n'>=76
+                          then '\n':w++wrapLines l rest
+                          else w++wrapLines n' rest
+               where n' = n+l
+                     l = length w
+            _ -> s -- give up!!
+
+-- LaTeX code producing functions
+
+dollar s = '$' : s ++ "$"
+mbox s   = "\\mbox{" ++ s ++ "}"
+ital s   = "{\\em" +++ s ++ "}"
+boldf s  = "{\\bf" +++ s ++ "}"
+verbat s = "\\verbat!" ++ s ++ "!"
+
+mkLatexFile s = begindocument +++++ s +++++ enddocument
+
+begindocument =
+ "\\documentclass[a4paper,11pt]{article}" ++++ -- M.F. 25/01-02
+ "\\setlength{\\parskip}{2mm}" ++++
+ "\\setlength{\\parindent}{0mm}" ++++
+ "\\setlength{\\oddsidemargin}{0mm}" ++++
+ "\\setlength{\\evensidemargin}{-2mm}" ++++
+ "\\setlength{\\topmargin}{-8mm}" ++++
+ "\\setlength{\\textheight}{240mm}" ++++
+ "\\setlength{\\textwidth}{158mm}" ++++
+ "\\begin{document}\n"
+
+enddocument =
+ "\n\\end{document}\n"
+
+sortByLongest :: [[a]] -> [[a]]
+sortByLongest = sortBy longer where
+ longer x y 
+  | x' > y' = LT
+  | x' < y' = GT
+  | True    = EQ
+  where
+   x' = length x
+   y' = length y
+
+combinations :: [[a]] -> [[a]]
+combinations t = case t of 
+  []    -> [[]]
+  aa:uu -> [a:u | a <- aa, u <- combinations uu]
+
+mkTextFile :: String -> IO ()
+mkTextFile name = do
+  s <- readFile name
+  let s' = prelude name ++ "\n\n" ++ heading name  ++ "\n" ++ object s
+  writeFile (name ++ ".hs") s'
+ where
+   prelude name = "module " ++ name ++ " where" 
+   heading name = "txt" ++ name ++ " ="
+   object s = mk s ++ " \"\""
+   mk s = unlines ["  \"" ++ escs line ++ "\" ++ \"\\n\" ++" | line <- lines s]
+   escs s = case s of
+     c:cs | elem c "\"\\" -> '\\' : c : escs cs
+     c:cs -> c : escs cs
+     _ -> s
+
+initFilePath :: FilePath -> FilePath
+initFilePath f = reverse (dropWhile (/='/') (reverse f))
+
+-- topological sorting with test of cyclicity
+
+topoTest :: Eq a => [(a,[a])] -> Either [a] [[a]]
+topoTest g = if length g' == length g then Left g' else Right (cyclesIn g ++[[]]) 
+  where
+    g' = topoSort g
+  
+cyclesIn :: Eq a => [(a,[a])] -> [[a]]
+cyclesIn deps = nubb $ clean $ filt $ iterFix findDep immediate where
+  immediate = [[y,x] | (x,xs) <- deps, y <- xs] 
+  findDep chains = [y:x:chain | 
+                      x:chain <- chains, (x',xs) <- deps, x' == x, y <- xs, 
+                      notElem y (init chain)]
+
+  clean = map remdup
+  nubb = nubBy (\x y -> y == reverse x) 
+  filt = filter (\xs -> last xs == head xs)
+  remdup (x:xs) = x : remdup xs' where xs' = dropWhile (==x) xs
+  remdup [] = []
+
+
+
+topoSort :: Eq a => [(a,[a])] -> [a]
+topoSort g = reverse $ tsort 0 [ffs | ffs@(f,_) <- g, inDeg f == 0] [] where
+  tsort _ []     r = r
+  tsort k (ffs@(f,fs) : cs) r
+    | elem f r  = tsort k cs r
+    | k > lx    = r  
+    | otherwise = tsort (k+1) cs (f : tsort (k+1) (info fs) r)
+  info hs = [(f,fs) | (f,fs) <- g, elem f hs]
+  inDeg f = length [t | (h,hs) <- g, t <- hs, t == f]
+  lx = length g
+
+-- the generic fix point iterator
+
+iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a]
+iterFix more start = iter start start 
+  where
+    iter old new = if (null new')
+                      then old
+                      else iter (new' ++ old) new'
+      where
+        new' = filter (`notElem` old) (more new)
+
+-- association lists
+
+updateAssoc :: Eq a => (a,b) -> [(a,b)] -> [(a,b)]
+updateAssoc ab@(a,b) as = case as of
+  (x,y): xs | x == a -> (a,b):xs
+  xy   : xs          -> xy : updateAssoc ab xs
+  []                 -> [ab]
+
+removeAssoc :: Eq a => a -> [(a,b)] -> [(a,b)]
+removeAssoc a = filter ((/=a) . fst)
+
+-- chop into separator-separated parts
+
+chunks :: String -> [String] -> [[String]]
+chunks sep ws = case span (/= sep) ws of
+  (a,_:b) -> a : bs where bs = chunks sep b
+  (a, []) -> if null a then [] else [a]
+
+readIntArg :: String -> Int
+readIntArg n = if (not (null n) && all isDigit n) then read n else 0
+
+
+-- state monad with error; from Agda 6/11/2001
+
+newtype STM s a = STM (s -> Err (a,s)) 
+
+appSTM :: STM s a -> s -> Err (a,s)
+appSTM (STM f) s = f s
+
+stm :: (s -> Err (a,s)) -> STM s a
+stm = STM
+
+stmr :: (s -> (a,s)) -> STM s a
+stmr f = stm (\s -> return (f s))
+
+instance  Monad (STM s) where
+  return a    = STM (\s -> return (a,s))
+  STM c >>= f = STM (\s -> do 
+                        (x,s') <- c s
+                        let STM f' = f x
+                        f' s')
+
+readSTM :: STM s s
+readSTM = stmr (\s -> (s,s))
+
+updateSTM :: (s -> s) -> STM s () 
+updateSTM f = stmr (\s -> ((),f s))
+
+writeSTM :: s -> STM s ()
+writeSTM s = stmr (const ((),s))
+
+done :: Monad m => m ()
+done = return ()
+
+class Monad m => ErrorMonad m where
+  raise   :: String -> m a
+  handle  :: m a -> (String -> m a) -> m a
+  handle_ :: m a -> m a -> m a
+  handle_ a b =  a `handle` (\_ -> b)
+
+instance ErrorMonad Err where
+  raise  = Bad
+  handle a@(Ok _) _ = a
+  handle (Bad i) f  = f i
+
+instance ErrorMonad (STM s) where
+  raise msg = STM (\s -> raise msg)
+  handle (STM f) g = STM (\s -> (f s) 
+                                `handle` (\e -> let STM g' = (g e) in
+                                                    g' s))
+-- if the first check fails try another one
+checkAgain :: ErrorMonad m => m a -> m a -> m a
+checkAgain c1 c2 = handle_ c1 c2
+
+checks :: ErrorMonad m => [m a] -> m a
+checks [] = raise "no chance to pass"
+checks cs = foldr1 checkAgain cs
+
+allChecks :: ErrorMonad m => [m a] -> m [a]
+allChecks ms = case ms of
+  (m: ms) -> let rs = allChecks ms in handle_ (liftM2 (:) m rs) rs
+  _ -> return []
+
diff --git a/src/GF/Data/OrdMap2.hs b/src/GF/Data/OrdMap2.hs
new file mode 100644
index 000000000..f41d33139
--- /dev/null
+++ b/src/GF/Data/OrdMap2.hs
@@ -0,0 +1,118 @@
+
+
+--------------------------------------------------
+-- The class of ordered finite maps
+-- as described in section 2.2.2
+
+-- and an example implementation, 
+-- derived from the implementation in appendix A.2
+
+
+module OrdMap2 (OrdMap(..), Map) where
+
+import List (intersperse)
+
+
+--------------------------------------------------
+-- the class of ordered finite maps
+
+class OrdMap m where
+  emptyMap     :: Ord s => m s a
+  (|->)        :: Ord s => s -> a -> m s a
+  isEmptyMap   :: Ord s => m s a -> Bool
+  (?)          :: Ord s => m s a -> s -> Maybe a
+  lookupWith   :: Ord s => a -> m s a -> s -> a
+  mergeWith    :: Ord s => (a -> a -> a) -> m s a -> m s a -> m s a
+  unionMapWith :: Ord s => (a -> a -> a) -> [m s a] -> m s a
+  makeMapWith  :: Ord s => (a -> a -> a) -> [(s,a)] -> m s a
+  assocs       :: Ord s => m s a -> [(s,a)]
+  ordMap       :: Ord s => [(s,a)] -> m s a
+  mapMap       :: Ord s => (a -> b) -> m s a -> m s b
+
+  lookupWith z m s = case m ? s of
+		       Just a  -> a
+		       Nothing -> z
+
+  unionMapWith join = union
+    where union []   = emptyMap
+	  union [xs] = xs
+	  union xyss = mergeWith join (union xss) (union yss)
+	    where (xss, yss)       = split xyss
+		  split (x:y:xyss) = let (xs, ys) = split xyss in (x:xs, y:ys)
+		  split xs         = (xs, [])
+
+
+--------------------------------------------------
+-- finite maps as ordered associaiton lists, 
+-- paired with binary search trees
+
+data Map s a = Map [(s,a)] (TreeMap s a)
+
+instance (Eq s, Eq a) => Eq (Map s a) where
+  Map xs _ == Map ys _ = xs == ys
+
+instance (Show s, Show a) => Show (Map s a) where
+  show (Map ass _) = "{" ++ concat (intersperse "," (map show' ass)) ++ "}"
+    where show' (s,a) = show s ++ "|->" ++ show a
+
+instance OrdMap Map where
+  emptyMap = Map []      (makeTree [])
+  s |-> a  = Map [(s,a)] (makeTree [(s,a)])
+
+  isEmptyMap (Map ass _) = null ass
+  
+  Map _ tree ? s = lookupTree s tree
+
+  mergeWith join (Map xss _) (Map yss _) = Map xyss (makeTree xyss)
+    where xyss          = merge xss yss
+	  merge []  yss = yss
+	  merge xss []  = xss
+	  merge xss@(x@(s,x'):xss') yss@(y@(t,y'):yss')
+		= case compare s t of
+		    LT -> x : merge xss' yss
+		    GT -> y : merge xss  yss'
+		    EQ -> (s, join x' y') : merge xss' yss'
+
+  makeMapWith join []      = emptyMap
+  makeMapWith join [(s,a)] = s |-> a
+  makeMapWith join xyss    = mergeWith join (makeMapWith join xss) (makeMapWith join yss)
+    where (xss, yss)       = split xyss
+	  split (x:y:xys)  = let (xs, ys) = split xys in (x:xs, y:ys)
+	  split xs         = (xs, [])
+
+  assocs (Map xss _) = xss
+  ordMap xss         = Map xss (makeTree xss)
+
+  mapMap f (Map ass atree) = Map [ (s,f a) | (s,a) <- ass ] (mapTree f atree)
+
+
+--------------------------------------------------
+-- binary search trees
+-- for logarithmic lookup time
+
+data TreeMap s a = Nil | Node (TreeMap s a) s a (TreeMap s a)
+
+makeTree ass = tree
+  where
+    (tree,[])            = sl2bst (length ass) ass
+    sl2bst 0 ass         = (Nil, ass)
+    sl2bst 1 ((s,a):ass) = (Node Nil s a Nil, ass)
+    sl2bst n ass         = (Node ltree s a rtree, css)
+      where llen = (n-1) `div` 2
+            rlen = n - 1 - llen
+            (ltree, (s,a):bss) = sl2bst llen ass
+            (rtree, css)       = sl2bst rlen bss
+
+lookupTree s Nil = Nothing
+lookupTree s (Node left s' a right) 
+    = case compare s s' of
+        LT -> lookupTree s left 
+        GT -> lookupTree s right 
+        EQ -> Just a
+
+mapTree f Nil = Nil
+mapTree f (Node left s a right) = Node (mapTree f left) s (f a) (mapTree f right)
+
+
+
+
diff --git a/src/GF/Data/OrdSet.hs b/src/GF/Data/OrdSet.hs
new file mode 100644
index 000000000..84169a699
--- /dev/null
+++ b/src/GF/Data/OrdSet.hs
@@ -0,0 +1,111 @@
+
+
+--------------------------------------------------
+-- The class of ordered sets
+-- as described in section 2.2.1
+
+-- and an example implementation, 
+-- derived from the implementation in appendix A.1
+
+
+module OrdSet (OrdSet(..), Set) where
+
+import List (intersperse)
+
+
+--------------------------------------------------
+-- the class of ordered sets
+
+class OrdSet m where
+  emptySet  :: Ord a => m a
+  unitSet   :: Ord a => a -> m a
+  isEmpty   :: Ord a => m a -> Bool
+  elemSet   :: Ord a => a -> m a -> Bool
+  (<++>)    :: Ord a => m a -> m a -> m a
+  (<\\>)    :: Ord a => m a -> m a -> m a
+  plusMinus :: Ord a => m a -> m a -> (m a, m a)
+  union     :: Ord a => [m a] -> m a
+  makeSet   :: Ord a => [a] -> m a
+  elems     :: Ord a => m a -> [a]
+  ordSet    :: Ord a => [a] -> m a
+  limit     :: Ord a => (a -> m a) -> m a -> m a
+
+  xs <++> ys      = fst (plusMinus xs ys)
+  xs <\\> ys      = snd (plusMinus xs ys)
+  plusMinus xs ys = (xs <++> ys, xs <\\> ys)
+
+  union []   = emptySet
+  union [xs] = xs
+  union xyss = union xss <++> union yss
+    where (xss, yss)       = split xyss
+	  split (x:y:xyss) = let (xs, ys) = split xyss in (x:xs, y:ys)
+	  split xs         = (xs, [])
+
+  makeSet xs = union (map unitSet xs)
+
+  limit more start = limit' (start, start)
+    where limit' (old, new)
+	      | isEmpty new' = old
+	      | otherwise    = limit' (plusMinus new' old)
+	    where new'       = union (map more (elems new))
+
+
+--------------------------------------------------
+-- sets as ordered lists, 
+-- paired with a binary tree
+
+data Set a = Set [a] (TreeSet a)
+
+instance Eq a => Eq (Set a) where
+  Set xs _ == Set ys _ = xs == ys
+
+instance Ord a => Ord (Set a) where
+  compare (Set xs _) (Set ys _) = compare xs ys
+
+instance Show a => Show (Set a) where
+  show (Set xs _) = "{" ++ concat (intersperse "," (map show xs)) ++ "}"
+
+instance OrdSet Set where
+  emptySet  = Set []  (makeTree [])
+  unitSet a = Set [a] (makeTree [a])
+
+  isEmpty   (Set xs _) = null xs
+  elemSet a (Set _ xt) = elemTree a xt
+
+  plusMinus (Set xs _) (Set ys _) = (Set ps (makeTree ps), Set ms (makeTree ms))
+    where (ps, ms) = plm xs ys
+	  plm [] ys = (ys, [])
+	  plm xs [] = (xs, xs)
+	  plm xs@(x:xs') ys@(y:ys') = case compare x y of
+				        LT -> let (ps, ms) = plm xs' ys  in (x:ps, x:ms)
+					GT -> let (ps, ms) = plm xs  ys' in (y:ps,   ms)
+					EQ -> let (ps, ms) = plm xs' ys' in (x:ps,   ms)
+
+  elems (Set xs _) = xs
+  ordSet xs        = Set xs (makeTree xs)
+
+
+--------------------------------------------------
+-- binary search trees
+-- for logarithmic lookup time
+
+data TreeSet a = Nil | Node (TreeSet a) a (TreeSet a)
+
+makeTree xs = tree
+  where (tree,[])       = sl2bst (length xs) xs
+	sl2bst 0 xs     = (Nil, xs)
+	sl2bst 1 (a:xs) = (Node Nil a Nil, xs)
+	sl2bst n xs     = (Node ltree a rtree, zs)
+          where llen    = (n-1) `div` 2
+                rlen    = n - 1 - llen
+                (ltree, a:ys) = sl2bst llen xs
+                (rtree, zs)   = sl2bst rlen ys
+
+elemTree a Nil = False
+elemTree a (Node ltree x rtree) 
+    = case compare a x of
+        LT -> elemTree a ltree 
+        GT -> elemTree a rtree 
+        EQ -> True
+
+
diff --git a/src/GF/Data/Parsers.hs b/src/GF/Data/Parsers.hs
new file mode 100644
index 000000000..165d0f4e7
--- /dev/null
+++ b/src/GF/Data/Parsers.hs
@@ -0,0 +1,143 @@
+module Parsers where
+
+import Operations
+import Char
+
+
+infixr 2 |||, +||
+infixr 3 ***
+infixr 5 .>.
+infixr 5 ...
+infixr 5 ....
+infixr 5 +..
+infixr 5 ..+
+infixr 6 |>
+infixr 3 <<<
+
+-- some parser combinators a` la Wadler and Hutton
+-- no longer used in many places in GF
+
+type Parser a b = [a] -> [(b,[a])]
+
+parseResults :: Parser a b -> [a] -> [b]
+parseResults p s = [x | (x,r) <- p s, null r]
+
+parseResultErr :: Parser a b -> [a] -> Err b
+parseResultErr p s = case parseResults p s of
+  [x] -> return x
+  []  -> Bad "no parse"
+  _   -> Bad "ambiguous"
+
+(...) :: Parser a b -> Parser a c -> Parser a (b,c)
+(p ... q) s = [((x,y),r) | (x,t) <- p s, (y,r) <- q t]
+
+(.>.) :: Parser a b -> (b -> Parser a c) -> Parser a c
+(p .>. f) s = [(c,r) | (x,t) <- p s, (c,r) <- f x t]
+
+(|||) :: Parser a b -> Parser a b -> Parser a b
+(p ||| q) s = p s ++ q s
+
+(+||) :: Parser a b -> Parser a b -> Parser a b
+p1 +|| p2 = take 1 . (p1 ||| p2)
+
+literal :: (Eq a) => a -> Parser a a
+literal x (c:cs) = [(x,cs) | x == c]
+literal _ _ = []
+
+(***) :: Parser a b -> (b -> c) -> Parser a c
+(p *** f) s = [(f x,r) | (x,r) <- p s] 
+
+succeed :: b -> Parser a b
+succeed v s = [(v,s)]
+
+fails :: Parser a b
+fails s = []
+
+(+..) :: Parser a b -> Parser a c -> Parser a c
+p1 +.. p2 = p1 ... p2 *** snd
+
+(..+) :: Parser a b -> Parser a c -> Parser a b
+p1 ..+ p2 = p1 ... p2 *** fst
+
+(<<<) :: Parser a b -> c -> Parser a c  -- return
+p <<< v = p *** (\x -> v)
+
+(|>) :: Parser a b -> (b -> Bool) -> Parser a b
+p |> b = p .>. (\x -> if b x then succeed x else fails)
+
+many :: Parser a b -> Parser a [b]
+many p = (p ... many p *** uncurry (:)) +|| succeed []
+
+some :: Parser a b -> Parser a [b]
+some p = (p ... many p) *** uncurry (:)
+
+longestOfMany :: Parser a b -> Parser a [b]
+longestOfMany p = p .>. (\x -> longestOfMany p *** (x:)) +|| succeed []
+
+closure :: (b -> Parser a b) -> (b -> Parser a b)
+closure p v = p v .>. closure p ||| succeed v
+
+pJunk   :: Parser Char String
+pJunk = longestOfMany (satisfy (\x -> elem x "\n\t "))
+
+pJ :: Parser Char a -> Parser Char a
+pJ p = pJunk +.. p ..+ pJunk
+
+pTList  :: String -> Parser Char a -> Parser Char [a]
+pTList t p = p .... many (jL t +.. p) *** (\ (x,y) -> x:y) -- mod. AR 5/1/1999
+
+pTJList  :: String -> String -> Parser Char a -> Parser Char [a]
+pTJList t1 t2 p = p .... many (literals t1 +.. jL t2 +.. p) *** (uncurry (:))
+
+pElem   :: [String] -> Parser Char String
+pElem l = foldr (+||) fails (map literals l)
+
+(....) :: Parser Char b -> Parser Char c -> Parser Char (b,c)
+p1 .... p2 = p1 ... pJunk +.. p2
+
+item :: Parser a a
+item (c:cs) = [(c,cs)]
+item [] = []
+
+satisfy :: (a -> Bool) -> Parser a a
+satisfy b = item |> b
+
+literals :: (Eq a,Show a) => [a] -> Parser a [a]
+literals l = case l of 
+  []  -> succeed [] 
+  a:l -> literal a ... literals l *** (\ (x,y) -> x:y)
+
+lits :: (Eq a,Show a) => [a] -> Parser a [a]
+lits ts = literals ts
+
+jL :: String -> Parser Char String
+jL = pJ . lits
+
+pParenth p = literal '(' +.. pJunk +.. p ..+ pJunk ..+ literal ')'
+pCommaList p = pTList "," (pJ p)                      -- p,...,p
+pOptCommaList p = pCommaList p ||| succeed []            -- the same or nothing
+pArgList p = pParenth (pCommaList p) ||| succeed [] -- (p,...,p), poss. empty
+pArgList2 p = pParenth (p ... jL "," +.. pCommaList p) *** uncurry (:) -- min.2 args
+
+longestOfSome p = (p ... longestOfMany p) *** (\ (x,y) -> x:y)
+
+pIdent = pLetter ... longestOfMany pAlphaPlusChar *** uncurry (:)
+  where alphaPlusChar c = isAlphaNum c || c=='_' || c=='\''
+
+pLetter = satisfy (`elem` (['A'..'Z'] ++ ['a'..'z'] ++ 
+                           ['À' .. 'Û'] ++ ['à' .. 'û'])) -- no such in Char
+pDigit         = satisfy isDigit
+pLetters       = longestOfSome pLetter
+pAlphanum      = pDigit ||| pLetter
+pAlphaPlusChar = pAlphanum ||| satisfy (`elem` "_'")
+
+pQuotedString = literal '"' +.. pEndQuoted where
+ pEndQuoted =
+       literal '"' *** (const [])
+   +|| (literal '\\' +.. item .>. \ c -> pEndQuoted *** (c:))
+   +|| item .>. \ c -> pEndQuoted *** (c:)
+
+pIntc :: Parser Char Int
+pIntc = some (satisfy numb) *** read
+         where numb x = elem x ['0'..'9']
+
diff --git a/src/GF/Data/Str.hs b/src/GF/Data/Str.hs
new file mode 100644
index 000000000..743bd71b8
--- /dev/null
+++ b/src/GF/Data/Str.hs
@@ -0,0 +1,106 @@
+module Str (
+  Str (..), Tok (..),        --- constructors needed in PrGrammar 
+  str2strings, str2allStrings, str, sstr, sstrV, 
+  isZeroTok, prStr, plusStr, glueStr,
+  strTok, 
+  allItems
+) where
+
+import Operations
+import List (isPrefixOf, isSuffixOf, intersperse)
+
+-- abstract token list type. AR 2001, revised and simplified 20/4/2003
+
+newtype Str = Str [Tok]  deriving (Read, Show, Eq, Ord)
+
+data Tok = 
+   TK String
+ | TN Ss [(Ss, [String])] -- variants depending on next string 
+    deriving (Eq, Ord, Show, Read)
+
+-- notice that having both pre and post would leave to inconsistent situations:
+--   pre {"x" ; "y" / "a"} ++ post {"b" ; "a" / "x"}
+-- always violates a condition expressed by the one or the other
+
+-- a variant can itself be a token list, but for simplicity only a list of strings
+-- i.e. not itself containing variants
+
+type Ss = [String]
+
+-- matching functions in both ways
+
+matchPrefix :: Ss -> [(Ss,[String])] -> [String] -> Ss
+matchPrefix s vs t = 
+    head ([u | (u,as) <- vs, any (\c -> isPrefixOf c (concat t)) as] ++ [s])
+
+str2strings :: Str -> Ss
+str2strings (Str st) = alls st where 
+  alls st = case st of
+    TK s     : ts -> s                   : alls ts
+    TN ds vs : ts -> matchPrefix ds vs t ++ t where t = alls ts
+    []            -> []
+
+str2allStrings :: Str -> [Ss]
+str2allStrings (Str st) = alls st where 
+  alls st = case st of
+    TK s     : ts -> [s        : t | t <- alls ts]
+    TN ds vs : [] -> [ds      ++ v | v <- map fst vs]
+    TN ds vs : ts -> [matchPrefix ds vs t ++ t | t <- alls ts]
+    []            -> [[]]
+
+sstr :: Str -> String
+sstr = unwords . str2strings
+
+-- to handle a list of variants
+
+sstrV :: [Str] -> String
+sstrV ss = case ss of
+  []  -> "*"
+  _   -> unwords $ intersperse "/" $ map (unwords . str2strings) ss
+
+str :: String -> Str
+str s = if null s then Str [] else Str [itS s]
+
+itS :: String -> Tok
+itS s = TK s
+
+isZeroTok :: Str -> Bool
+isZeroTok t = case t of
+  Str [] -> True
+  Str [TK []] -> True
+  _ -> False
+
+strTok :: Ss -> [(Ss,[String])] -> Str
+strTok ds vs = Str [TN ds vs]
+
+prStr = prQuotedString . sstr
+
+plusStr :: Str -> Str -> Str
+plusStr (Str ss) (Str tt) = Str (ss ++ tt)
+
+glueStr :: Str -> Str -> Str
+glueStr (Str ss) (Str tt) = Str $ case (ss,tt) of
+  ([],_) -> tt
+  (_,[]) -> ss
+  _ -> init ss ++ glueIt (last ss) (head tt) ++ tail tt
+ where
+   glueIt t u = case (t,u) of
+     (TK s, TK s') -> return $ TK $ s ++ s'
+     (TN ds vs, TN es ws) -> return $ TN (glues (matchPrefix ds vs es) es) 
+                               [(glues (matchPrefix ds vs w) w,cs) | (w,cs) <- ws]
+     (TN ds vs, TK s) -> map TK $ glues (matchPrefix ds vs [s]) [s]
+     (TK s, TN es ws) -> return $ TN (glues [s] es) [(glues [s] w, c) | (w,c) <- ws]
+
+glues :: [[a]] -> [[a]] -> [[a]]
+glues ss tt = case (ss,tt) of
+  ([],_) -> tt
+  (_,[]) -> ss
+  _ -> init ss ++ [last ss ++ head tt] ++ tail tt
+
+-- to create the list of all lexical items
+
+allItems :: Str -> [String]
+allItems (Str s) = concatMap allOne s where
+  allOne t = case t of
+    TK s -> [s]
+    TN ds vs -> ds ++ concatMap fst vs
diff --git a/src/GF/Data/Zipper.hs b/src/GF/Data/Zipper.hs
new file mode 100644
index 000000000..d498c5a56
--- /dev/null
+++ b/src/GF/Data/Zipper.hs
@@ -0,0 +1,172 @@
+module Zipper where
+
+import Operations
+
+-- Gérard Huet's zipper (JFP 7 (1997)). AR 10/8/2001
+
+newtype Tr a = Tr (a,[Tr a]) deriving (Show,Eq)
+    
+data Path a = 
+    Top 
+  | Node ([Tr a], (Path a, a), [Tr a]) 
+   deriving Show
+
+leaf a = Tr (a,[])
+
+newtype Loc a = Loc (Tr a, Path a)     deriving Show
+
+goLeft, goRight, goUp, goDown :: Loc a -> Err (Loc a)
+goLeft (Loc (t,p)) = case p of
+  Top -> Bad "left of top"
+  Node (l:left, upv, right) -> return $ Loc (l, Node (left,upv,t:right))
+  Node _ -> Bad "left of first"
+goRight (Loc (t,p)) = case p of
+  Top -> Bad "right of top"
+  Node (left, upv, r:right) -> return $ Loc (r, Node (t:left,upv,right))
+  Node _ -> Bad "right of first"
+goUp (Loc (t,p)) = case p of
+  Top -> Bad "up of top"
+  Node (left, (up,v), right) -> 
+    return $ Loc (Tr (v, reverse left ++ (t:right)), up)
+goDown (Loc (t,p)) = case t of
+  Tr (v,(t1:trees)) -> return $ Loc (t1,Node ([],(p,v),trees))
+  _ -> Bad "down of empty"
+
+changeLoc :: Loc a -> Tr a -> Err (Loc a)
+changeLoc (Loc (_,p)) t = return $ Loc (t,p)
+
+changeNode :: (a -> a) -> Loc a -> Loc a
+changeNode f (Loc (Tr (n,ts),p)) = Loc (Tr (f n, ts),p)
+
+forgetNode :: Loc a -> Err (Loc a)
+forgetNode (Loc (Tr (n,[t]),p)) = return $ Loc (t,p)
+forgetNode _ = Bad $ "not a one-branch tree"
+
+-- added sequential representation
+
+-- a successor function
+goAhead :: Loc a -> Err (Loc a) 
+goAhead s@(Loc (t,p)) = case (t,p) of
+  (Tr (_,_:_),Node (_,_,_:_)) -> goDown s
+  (Tr (_,[]), _)              -> upsRight s
+  (_,         _)              -> goDown s
+ where
+   upsRight t = case goRight t of
+     Ok t' -> return t'
+     Bad _ -> goUp t >>= upsRight
+
+-- a predecessor function
+goBack :: Loc a -> Err (Loc a) 
+goBack s@(Loc (t,p)) = case goLeft s of
+  Ok s' -> downRight s'
+  _     -> goUp s
+ where
+   downRight s = case goDown s of
+     Ok s' -> case goRight s' of
+       Ok s'' -> downRight s''
+       _ -> downRight s'       
+     _     -> return s
+
+-- n-ary versions
+
+goAheadN :: Int ->  Loc a -> Err (Loc a)
+goAheadN i st
+  | i < 1     = return st
+  | otherwise = goAhead st >>= goAheadN (i-1)
+
+goBackN :: Int ->  Loc a -> Err (Loc a)
+goBackN i st
+  | i < 1     = return st
+  | otherwise = goBack st >>= goBackN (i-1)
+
+-- added mappings between locations and trees
+
+loc2tree (Loc (t,p)) = case p of
+  Top -> t
+  Node (left,(p',v),right) -> 
+    loc2tree (Loc (Tr (v, reverse left ++ (t : right)),p'))
+
+loc2treeMarked :: Loc a -> Tr (a, Bool)
+loc2treeMarked (Loc (Tr (a,ts),p)) = 
+  loc2tree (Loc (Tr (mark a, map (mapTr nomark) ts), mapPath nomark p)) 
+ where 
+   (mark, nomark) = (\a -> (a,True), \a -> (a, False))
+
+tree2loc t = Loc (t,Top)
+
+goRoot = tree2loc . loc2tree
+
+goLast :: Loc a -> Err (Loc a)
+goLast = rep goAhead where
+  rep f s = err (const (return s)) (rep f) (f s)
+
+-- added some utilities
+
+traverseCollect :: Path a -> [a]
+traverseCollect p = reverse $ case p of
+  Top -> []
+  Node (_, (p',v), _) -> v : traverseCollect p'
+
+scanTree :: Tr a -> [a]
+scanTree (Tr (a,ts)) = a : concatMap scanTree ts
+
+mapTr :: (a -> b) -> Tr a -> Tr b
+mapTr f (Tr (x,ts)) = Tr (f x, map (mapTr f) ts)
+
+mapTrM :: Monad m => (a -> m b) -> Tr a -> m (Tr b)
+mapTrM f (Tr (x,ts)) = do
+  fx  <- f x
+  fts <- mapM (mapTrM f) ts
+  return $ Tr (fx,fts)
+
+mapPath :: (a -> b) -> Path a -> Path b
+mapPath f p = case p of
+  Node (ts1, (p,v), ts2) -> 
+    Node (map (mapTr f) ts1, (mapPath f p, f v), map (mapTr f) ts2)
+  Top -> Top
+
+mapPathM :: Monad m => (a -> m b) -> Path a -> m (Path b)
+mapPathM f p = case p of
+  Node (ts1, (p,v), ts2) -> do
+    ts1' <- mapM (mapTrM f) ts1
+    p'   <- mapPathM f p
+    v'   <- f v 
+    ts2' <- mapM (mapTrM f) ts2
+    return $ Node (ts1', (p',v'), ts2')
+  Top -> return Top
+
+mapLoc :: (a -> b) -> Loc a -> Loc b
+mapLoc f (Loc (t,p)) = Loc (mapTr f t, mapPath f p)
+
+mapLocM :: Monad m => (a -> m b) -> Loc a -> m (Loc b)
+mapLocM f (Loc (t,p)) = do
+  t' <- mapTrM f t
+  p' <- mapPathM f p
+  return $ (Loc (t',p'))
+
+foldTr :: (a -> [b] -> b) -> Tr a -> b
+foldTr f (Tr (x,ts)) = f x (map (foldTr f) ts)
+
+foldTrM :: Monad m => (a -> [b] -> m b) -> Tr a -> m b
+foldTrM f (Tr (x,ts)) = do
+  fts <- mapM (foldTrM f) ts
+  f x fts
+
+mapSubtrees :: (Tr a -> Tr a) -> Tr a -> Tr a
+mapSubtrees f t = let Tr (x,ts) = f t in Tr (x, map (mapSubtrees f) ts)
+
+mapSubtreesM :: Monad m => (Tr a -> m (Tr a)) -> Tr a -> m (Tr a)
+mapSubtreesM f t = do
+  Tr (x,ts) <- f t
+  ts' <- mapM (mapSubtreesM f) ts
+  return $ Tr (x, ts')
+
+-- change the root without moving the pointer
+changeRoot :: (a -> a) -> Loc a -> Loc a
+changeRoot f loc = case loc of
+  Loc (Tr (a,ts),Top) -> Loc (Tr (f a,ts),Top)
+  Loc (t, Node (left,pv,right)) -> Loc (t, Node (left,chPath pv,right))
+ where
+   chPath pv = case pv of 
+     (Top,a) -> (Top, f a)
+     (Node (left,pv,right),v) -> (Node (left, chPath pv,right),v)
diff --git a/src/GF/Fudgets/ArchEdit.hs b/src/GF/Fudgets/ArchEdit.hs
new file mode 100644
index 000000000..82653595d
--- /dev/null
+++ b/src/GF/Fudgets/ArchEdit.hs
@@ -0,0 +1,16 @@
+module ArchEdit (
+  fudlogueEdit, fudlogueWrite, fudlogueWriteUni
+ ) where
+
+import CommandF
+import UnicodeF
+
+-- architecture/compiler dependent definitions for unix/ghc, if Fudgets works.
+-- If not, use the modules in for-ghci
+
+fudlogueEdit font = fudlogueEditF ----
+fudlogueWrite = fudlogueWriteU
+fudlogueWriteUni _ _ = do
+  putStrLn "sorry no unicode available in ghc"
+
+
diff --git a/src/GF/Fudgets/CommandF.hs b/src/GF/Fudgets/CommandF.hs
new file mode 100644
index 000000000..8bf791a61
--- /dev/null
+++ b/src/GF/Fudgets/CommandF.hs
@@ -0,0 +1,120 @@
+module CommandF where
+
+import Operations
+
+import Session
+import Commands
+
+import Fudgets
+import FudgetOps
+
+import EventF
+
+-- a graphical shell for any kind of GF with Zipper editing. AR 20/8/2001
+
+fudlogueEditF :: CEnv -> IO ()
+fudlogueEditF env = 
+  fudlogue $ gfSizeP $ shellF ("GF 1.1 Fudget Editor") (gfF env)
+
+gfF env = nameLayoutF gfLayout $ (gfOutputF env >==< gfCommandF env) >+< quitButF
+
+( quitN : menusN : newN : transformN : filterN : displayN :
+  navigateN : viewN : outputN : saveN : _) = map show [1..]
+
+gfLayout = placeNL verticalP [generics,output,navigate,menus,transform]
+  where
+    generics  = placeNL horizontalP (map leafNL 
+                           [newN,saveN,viewN,displayN,filterN,quitN])
+    output    = leafNL outputN
+    navigate  = leafNL navigateN
+    menus     = leafNL menusN
+    transform = leafNL transformN
+ 
+gfSizeP = spacerF (sizeS (Point 720 640))
+
+gfOutputF env = 
+  ((nameF outputN $ (writeFileF >+< textWindowF)) 
+     >==< 
+   (absF (saveSP "EMPTY") 
+                        >==< 
+    (nameF saveN (popupStringInputF "Save" "foo.tmp" "Save to file:")
+         >+<  
+      mapF (displayJustStateIn env))))
+   >==< 
+  mapF Right 
+
+gfCommandF :: CEnv -> F () SState
+gfCommandF env = loopCommandsF env >==< getCommandsF env >==< mapF (\_ -> Click)
+
+loopCommandsF :: CEnv -> F Command SState
+loopCommandsF env = loopThroughRightF (mapGfStateF env) (mkMenusF env)
+
+mapGfStateF :: CEnv -> F (Either Command Command) (Either SState SState)
+mapGfStateF env = mapstateF execFC (initSState) where
+  execFC e0 (Left  c) = (e,[Right e,Left e]) where e = execECommand env c e0
+  execFC e0 (Right c) = (e,[Left e,Right e]) where e = execECommand env c e0
+
+mkMenusF :: CEnv -> F SState Command
+mkMenusF env = 
+  nameF menusN $
+  labAboveF "Select Action on Subterm" 
+            (mapF fst >==< smallPickListF snd >==< mapF (mkRefineMenu env))
+
+getCommandsF env = 
+    newF env     >*<
+    viewF        >*<
+    menuDisplayF env >*<
+    filterF      >*<
+    navigateF    >*<
+    transformF
+
+key2command ((key,_),_) = case key of
+     "Up"    -> CBack 1
+     "Down"  -> CAhead 1
+     "Left"  -> CPrevMeta
+     "Right" -> CNextMeta
+     "space" -> CTop
+
+     "d"     -> CDelete
+     "u"     -> CUndo
+     "v"     -> CView
+
+     _ -> CVoid
+
+transformF =
+  nameF transformN $
+  mapF (either key2command id) >==< (keyboardF $
+  placerF horizontalP $
+  cPopupStringInputF CRefineParse    "Parse" "" "Parse in concrete syntax" >*< 
+  --- to enable Unicode: ("Refine by parsing" `labLeftOfF` writeInputF)
+  cPopupStringInputF CRefineWithTree "Term" "" "Parse term"                >*<
+  cMenuF "Modify" termCommandMenu                                 	   >*<
+  cPopupStringInputF CAlphaConvert "Alpha" "x_0 x" "Alpha convert"         >*<  
+  cButtonF CRefineRandom "Random"                                          >*<
+  cButtonF CUndo "Undo"
+  )
+
+quitButF = nameF quitN $ quitF >==< buttonF "Quit"
+
+newF env = nameF newN     $ cMenuF "New"    (newCatMenu env)
+menuDisplayF env = nameF displayN $ cMenuF "Menus" $ displayCommandMenu env
+filterF  = nameF filterN  $ cMenuF "Filter" stringCommandMenu
+
+viewF = nameF viewN $ cButtonF CView "View"
+
+navigateF =
+  nameF navigateN $
+  placerF horizontalP $
+  cButtonF CPrevMeta  "?<"    >*<
+  cButtonF (CBack 1)  "<"     >*<
+  cButtonF CTop       "Top"   >*<
+  cButtonF CLast      "Last"  >*<
+  cButtonF (CAhead 1) ">"     >*<
+  cButtonF CNextMeta  ">?"
+
+cButtonF c s = mapF (const c) >==< buttonF s
+cMenuF s css = menuF s css >==< mapF (\_ -> CVoid)
+
+cPopupStringInputF comm lab def msg = 
+  mapF comm >==< popupStringInputF lab def msg >==< mapF (const [])
+
diff --git a/src/GF/Fudgets/EventF.hs b/src/GF/Fudgets/EventF.hs
new file mode 100644
index 000000000..cfcf3e401
--- /dev/null
+++ b/src/GF/Fudgets/EventF.hs
@@ -0,0 +1,36 @@
+module EventF where
+import AllFudgets
+
+-- The first string is the name of the key (e.g., "Down" for the down arrow key)
+-- The modifiers list shift, control and alt keys that were active while the
+-- key was pressed.
+-- The last string is the text produced by the key (for keys that produce
+-- printable characters, empty for control keys).
+
+type KeyPress = ((String,[Modifiers]),String)
+
+keyboardF :: F i o -> F i (Either KeyPress o)
+keyboardF fud = idRightSP (concatMapSP post) >^^=< oeventF mask fud
+  where
+    post (KeyEvent {type'=Pressed,keySym=sym,state=mods,keyLookup=s}) =
+       [((sym,mods),s)]
+    post _ = []
+
+    mask = [KeyPressMask,
+            EnterWindowMask, LeaveWindowMask -- because of CTT implementation
+	   ]
+
+-- Output events:
+oeventF em fud =  eventF em (idLeftF fud)
+
+-- Feed events to argument fudget:
+eventF eventmask = serCompLeftToRightF . groupF startcmds eventK
+  where
+    startcmds = [XCmd $ ChangeWindowAttributes [CWEventMask eventmask],
+	         XCmd $ ConfigureWindow [CWBorderWidth 0]]
+    eventK = K $ mapFilterSP route
+      where route = message low high
+            low (XEvt event) = Just (High (Left event))
+	    low _ = Nothing
+	    high h = Just (High (Right h))
+
diff --git a/src/GF/Fudgets/FudgetOps.hs b/src/GF/Fudgets/FudgetOps.hs
new file mode 100644
index 000000000..6c4e1a8b2
--- /dev/null
+++ b/src/GF/Fudgets/FudgetOps.hs
@@ -0,0 +1,47 @@
+module FudgetOps where
+
+import Fudgets
+
+-- auxiliary Fudgets for GF syntax editor
+
+-- save and display
+
+showAndSaveF fud = (writeFileF >+< textWindowF) >==< saveF fud
+
+saveF :: F a String -> F (Either String a) (Either (String,String) String)
+saveF fud = 
+  absF (saveSP "EMPTY") 
+    >==< 
+  (popupStringInputF "Save" "foo.tmp" "Save to file:" >+< fud)
+
+saveSP :: String -> SP (Either String String) (Either (String,String) String)
+saveSP contents = getSP $ \msg -> case msg of
+  Left  file   -> putSP (Left (file,contents)) (saveSP contents)
+  Right string -> putSP (Right string)         (saveSP string)
+
+textWindowF = writeOutputF
+
+-- to replace stringInputF by a pop-up slot behind a button
+popupStringInputF :: String -> String -> String -> F String String
+popupStringInputF label deflt msg =
+  mapF snd 
+      >==<
+  (popupSizeP $ stringPopupF deflt)
+      >==<
+  mapF (\_ -> (Just msg,Nothing)) 
+      >==<
+  decentButtonF label
+      >==<
+  mapF (\_ -> Click)
+
+decentButtonF = spacerF (sizeS (Point 80 20)) . buttonF
+
+popupSizeP = spacerF (sizeS (Point 240 100))
+
+--- the Unicode stuff should be inserted here
+
+writeOutputF = moreF >==< mapF lines
+
+writeInputF = stringInputF
+
+
diff --git a/src/GF/Fudgets/UnicodeF.hs b/src/GF/Fudgets/UnicodeF.hs
new file mode 100644
index 000000000..22a250658
--- /dev/null
+++ b/src/GF/Fudgets/UnicodeF.hs
@@ -0,0 +1,23 @@
+module UnicodeF where
+import Fudgets
+
+import Operations
+import Unicode
+
+-- AR 12/4/2000, 18/9/2001 (added font parameter)
+
+fudlogueWriteU :: String -> (String -> String) -> IO ()
+fudlogueWriteU fn trans = 
+  fudlogue $
+  shellF "GF Unicode Output" (writeF fn trans >+< quitButtonF)
+
+writeF fn trans = writeOutputF fn >==< mapF trans >==< writeInputF fn
+
+displaySizeP = placerF (spacerP (sizeS (Point 440 500)) verticalP)
+
+writeOutputF fn = moreF' (setFont fn) >==< justWriteOutputF
+
+justWriteOutputF = mapF (map (wrapLines 0) . filter (/=[]) . map mkUnicode . lines)
+
+writeInputF fn = stringInputF' (setShowString mkUnicode . setFont fn)
+
diff --git a/src/GF/Grammar/AbsCompute.hs b/src/GF/Grammar/AbsCompute.hs
new file mode 100644
index 000000000..52a2ca678
--- /dev/null
+++ b/src/GF/Grammar/AbsCompute.hs
@@ -0,0 +1,64 @@
+module AbsCompute where
+
+import Operations
+
+import Abstract
+import PrGrammar
+import LookAbs
+import PatternMatch
+import Compute
+
+import Monad (liftM, liftM2)
+
+-- computation in abstract syntax w.r.t. explicit definitions.
+--- old GF computation; to be updated
+
+compute :: GFCGrammar -> Exp -> Err Exp
+compute = computeAbsTerm
+
+computeAbsTerm :: GFCGrammar -> Exp -> Err Exp
+computeAbsTerm gr = computeAbsTermIn gr []
+
+computeAbsTermIn :: GFCGrammar -> [Ident] -> Exp -> Err Exp
+computeAbsTermIn gr = compt where
+  compt vv t = case t of
+    Prod x a b  -> liftM2 (Prod x) (compt vv a) (compt (x:vv) b)
+    Abs x b     -> liftM  (Abs  x)              (compt (x:vv) b)
+    _ -> do
+      let t' = beta vv t
+      (yy,f,aa) <- termForm t'
+      let vv' = yy ++ vv
+      aa'    <- mapM (compt vv') aa
+      case look f of
+        Just (Eqs eqs) -> case findMatch eqs aa' of
+          Ok (d,g) -> do
+            let (xs,ts) = unzip g
+            ts' <- alphaFreshAll vv' ts ---
+            let g' = zip xs ts'
+            d' <- compt vv' $ substTerm vv' g' d
+            return $ mkAbs yy $ d'
+          _ -> do
+            return $ mkAbs yy $ mkApp f aa'
+        Just d -> do
+          d' <- compt vv' d
+          da <- ifNull (return d') (compt vv' . mkApp d') aa' 
+          return $ mkAbs yy $ da
+        _ -> do
+          return $ mkAbs yy $ mkApp f aa'
+
+  look (Q m f) = case lookupAbsDef gr m f of
+    Ok (Just (Eqs [])) -> Nothing  -- canonical
+    Ok md -> md
+    _ -> Nothing
+  look _ = Nothing
+
+beta :: [Ident] -> Exp -> Exp
+beta vv c = case c of
+  App (Abs x b) a -> beta vv $ substTerm vv [xvv] (beta (x:vv) b) 
+                                                    where xvv = (x,beta vv a) 
+  App f         a -> let (a',f') = (beta vv a, beta vv f) in 
+                     (if a'==a && f'==f then id else beta vv) $ App f' a'
+  Prod x a b      -> Prod x (beta vv a) (beta (x:vv) b)
+  Abs x b         -> Abs x (beta (x:vv) b)
+  _               -> c
+
diff --git a/src/GF/Grammar/Abstract.hs b/src/GF/Grammar/Abstract.hs
new file mode 100644
index 000000000..538fff90b
--- /dev/null
+++ b/src/GF/Grammar/Abstract.hs
@@ -0,0 +1,24 @@
+module Abstract (
+
+module Grammar,
+module Values,
+module Macros,
+module Ident,
+module MMacros,
+module PrGrammar,
+
+Grammar
+
+ ) where
+
+import Grammar
+import Values
+import Macros
+import Ident
+import MMacros
+import PrGrammar
+
+type Grammar = SourceGrammar ---
+
+
+
diff --git a/src/GF/Grammar/AppPredefined.hs b/src/GF/Grammar/AppPredefined.hs
new file mode 100644
index 000000000..f59c910b0
--- /dev/null
+++ b/src/GF/Grammar/AppPredefined.hs
@@ -0,0 +1,51 @@
+module AppPredefined where
+
+import Operations
+import Grammar
+import Ident
+import PrGrammar (prt)
+---- import PGrammar (pTrm)
+
+-- predefined function definitions. AR 12/3/2003.
+-- Type checker looks at signatures in predefined.gf
+
+appPredefined :: Term -> Term
+appPredefined t = case t of
+
+  App f x -> case f of
+
+    -- one-place functions
+    Q (IC "Predef") (IC f) -> case (f, appPredefined x) of
+      ("length", K s) -> EInt $ length s
+      _ -> t
+
+    -- two-place functions
+    App (Q (IC "Predef") (IC f)) z -> case (f, appPredefined z, appPredefined x) of
+      ("drop", EInt i, K s) -> K (drop i s)
+      ("take", EInt i, K s) -> K (take i s)
+      ("tk",   EInt i, K s) -> K (take (max 0 (length s - i)) s)
+      ("dp",   EInt i, K s) -> K (drop (max 0 (length s - i)) s)
+      ("eqStr",K s,    K t) -> if s == t then predefTrue else predefFalse
+      ("eqInt",EInt i, EInt j) -> if i==j then predefTrue else predefFalse
+      ("plus", EInt i, EInt j) -> EInt $ i+j
+      ("show", _, t) -> K $ prt t
+      ("read", _, K s) -> str2tag s --- because of K, only works for atomic tags
+      _ -> t
+    _ -> t
+  _ -> t
+
+-- read makes variables into constants
+
+str2tag :: String -> Term
+str2tag s = case s of
+----  '\'' : cs -> mkCn $ pTrm $ init cs
+  _ -> Cn $ IC s ---
+ where
+   mkCn t = case t of
+     Vr i -> Cn i
+     App c a -> App (mkCn c) (mkCn a)
+     _ -> t
+
+
+predefTrue = Q (IC "Predef") (IC "PTrue")
+predefFalse = Q (IC "Predef") (IC "PFalse")
diff --git a/src/GF/Grammar/Compute.hs b/src/GF/Grammar/Compute.hs
new file mode 100644
index 000000000..1f1eba28c
--- /dev/null
+++ b/src/GF/Grammar/Compute.hs
@@ -0,0 +1,238 @@
+module Compute where
+
+import Operations
+import Grammar
+import Ident
+import Str
+import PrGrammar
+import Modules
+import Macros
+import Lookup
+import Refresh
+import PatternMatch
+
+import AppPredefined
+
+import List (nub,intersperse)
+import Monad (liftM2, liftM)
+
+-- computation of concrete syntax terms into normal form
+-- used mainly for partial evaluation
+
+computeConcrete :: SourceGrammar -> Term -> Err Term
+computeConcrete g t = {- refreshTerm t >>= -} computeTerm g [] t
+
+computeTerm :: SourceGrammar -> Substitution -> Term -> Err Term
+computeTerm 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 given to variable") x) return $ lookup x g
+       case t' of 
+         _ | t == t' -> return t
+         _ -> comp g t'
+
+     Abs x b -> do 
+       b' <- comp (ext x (Vr x) g) b
+       return $ Abs x b'
+
+     Let (x,(_,a)) b -> do
+       a' <- comp g a
+       comp (ext x a' g) b
+
+     Prod x a b -> do
+       a' <- comp g a
+       b' <- comp (ext x (Vr x) g) b
+       return $ Prod x a' b'
+
+     -- beta-convert
+     App f a -> do
+       f' <- comp g f
+       a' <- comp g a
+       case (f',a') of
+         (Abs x b,_) -> comp (ext x a' g) b
+         (FV fs, _)  -> mapM (\c -> comp g (App c a')) fs >>= return . FV
+         (_, FV as)  -> mapM (\c -> comp g (App f' c)) as >>= return . FV
+
+         (Alias _ _ d, _) -> comp g (App d a')
+
+         (S (T i cs) e,_) -> prawitz g i (flip App a') cs e
+
+	 _ -> returnC $ appPredefined $ App f' a'
+     P t l  -> do
+       t' <- comp g t
+       case t' of
+         FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . FV
+         R r   -> maybe (prtBad "no value for label" l) (comp g . snd) $ lookup l r 
+
+         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)
+         ExtR a (R b) ->                 
+           case comp g (P (R b) l) of
+             Ok v -> return v
+             _ -> comp g (P a l)
+
+         Alias _ _ r -> comp g (P r l)
+
+         S (T i cs) e -> prawitz g i (flip P l) cs e
+
+         _   -> returnC $ P t' l
+
+     S t v -> do
+       t'     <- comp g t
+       v'     <- comp g v
+       case t' of
+         T _ [(PV IW,c)] -> comp g c           --- an optimization
+         T _ [(PT _ (PV IW),c)] -> comp g c
+
+         T _ [(PV z,c)] -> comp (ext z v' g) c --- another optimization
+         T _ [(PT _ (PV z),c)] -> comp (ext z v' g) c
+
+         FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . FV
+
+         T _ cc -> case v' of
+	   FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . FV
+           _ -> 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
+
+         Alias _ _ d -> comp g (S d v')
+
+         S (T i cs) e -> prawitz g i (flip S v') cs e
+
+	 _    -> returnC $ S t' v'
+
+     -- glue if you can
+     Glue x0 y0 -> do
+       x <- comp g x0
+       y <- comp g y0
+       case (x,y) of
+         (Alias _ _ d, y)  -> comp g $ Glue d y
+         (x, Alias _ _ d)  -> comp g $ Glue x d
+
+         (S (T i cs) e, s) -> prawitz g i (flip Glue s) cs e
+         (s, S (T i cs) e) -> prawitz g i (Glue s) cs e
+         (_,K "")          -> return x
+         (K "",_)          -> return y
+         (K a, K b)        -> return $ K (a ++ b)
+         (K a, Alts (d,vs)) -> do
+            let glx = Glue x
+            comp g $ Alts (glx d, [(glx v,c) | (v,c) <- vs])
+         (Alts _, K a) -> do
+            x' <- strsFromTerm x
+            return $ variants [
+              foldr1 C (map K (str2strings (glueStr v (str a)))) | v <- x']
+         _ -> 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
+       returnC $ case (a',b') of
+         (Empty,_) -> b'
+         (_,Empty) -> a'
+         _     -> C a' b'
+
+     -- reduce free variation as much as you can
+     FV [t] -> comp g t
+
+     -- merge record extensions if you can
+     ExtR r s -> do
+       r' <- comp g r
+       s' <- comp g s
+       case (r',s') of
+         (Alias _ _ d, _)  -> comp g $ ExtR d s'
+         (_, Alias _ _ d)  -> comp g $ Glue r' d
+
+         (R rs, R ss) -> return $ R (rs ++ ss)
+         (RecType rs, RecType ss) -> return $ RecType (rs ++ ss)
+         _ -> return $ ExtR r' s'
+
+     -- case-expand tables
+     T i cs -> do
+       pty0 <- getTableType i
+       ptyp <- comp g pty0
+       case allParamValues gr ptyp of
+         Ok vs -> do
+
+           cs'  <- mapM (compBranchOpt g) cs
+           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 $ T (TComp ptyp) (zip ps' ts)
+         _ -> do
+           cs' <- mapM (compBranch g) cs
+           return $ T i cs'  -- happens with variable types
+
+     Alias c a d -> do
+       d' <- comp g d
+       return $ Alias c a d'  -- alias only disappears in certain redexes
+
+     -- otherwise go ahead
+     _ -> composOp (comp g) t >>= returnC
+
+    where
+
+     look = lookupResDef gr
+
+     ext x a g = (x,a):g
+
+     returnC = return --- . computed
+
+     variants [t] = t
+     variants 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
+       _ -> []
+
+     prawitz g i f cs e = do
+       cs' <- mapM (compBranch g) [(p, f v) | (p,v) <- cs]
+       return $ S (T i cs') e
+
+-- argument variables cannot be glued
+
+checkNoArgVars :: Term -> Err Term
+checkNoArgVars t = case t of
+  Vr (IA _)  -> prtBad "cannot glue (+) term with run-time variable" t
+  Vr (IAV _) -> prtBad "cannot glue (+) term with run-time variable" t
+  _ -> composOp checkNoArgVars t
diff --git a/src/GF/Grammar/Grammar.hs b/src/GF/Grammar/Grammar.hs
new file mode 100644
index 000000000..1ee5425c4
--- /dev/null
+++ b/src/GF/Grammar/Grammar.hs
@@ -0,0 +1,154 @@
+module Grammar where
+
+import Str
+import Ident
+import Option ---
+import Modules
+
+import Operations
+
+-- AR 23/1/2000 -- 30/5/2001 -- 4/5/2003
+
+-- grammar as presented to the compiler
+
+type SourceGrammar = MGrammar Ident Option Info
+
+type SourceModInfo = ModInfo Ident Option Info
+
+type SourceModule = (Ident, SourceModInfo)
+
+type SourceAbs = Module Ident Option Info
+type SourceRes = Module Ident Option Info
+type SourceCnc = Module Ident Option Info
+
+-- judgements in abstract syntax
+
+data Info =                  
+   AbsCat   (Perh Context) (Perh [Fun])    -- constructors
+ | AbsFun   (Perh Type) (Perh Term)        -- Yes f = canonical
+ | AbsTrans Ident
+
+-- judgements in resource
+ | ResParam (Perh [Param])
+ | ResValue (Perh Type) -- to mark parameter constructors for lookup
+ | ResOper  (Perh Type) (Perh Term)
+
+-- judgements in concrete syntax
+ | CncCat  (Perh Type) (Perh Term) MPr -- lindef ini'zed, 
+ | CncFun  (Maybe (Ident,(Context,Type))) (Perh Term) MPr  -- type info added at TC
+
+-- indirection to module Ident; the Bool says if canonical
+ | AnyInd Bool Ident 
+  deriving (Read, Show)
+
+type Perh a = Perhaps a Ident -- to express indirection to other module
+
+type MPr = Perhaps Term Ident -- printname
+
+type Type = Term
+type Cat  = QIdent
+type Fun  = QIdent
+
+type QIdent = (Ident,Ident)
+
+data Term =
+   Vr Ident             -- variable
+ | Cn Ident             -- constant
+ | Con Ident            -- constructor
+ | Sort String          -- basic type
+ | EInt Int             -- integer 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
+
+ | ECase Term [Branch]  -- case expression in abstract syntax à la Alfa
+
+-- below this only for concrete syntax
+ | RecType [Labelling]  -- record type: { p : A ; ...}
+ | R [Assign]           -- record:      { p = a ; ...}
+ | P Term Label         -- projection:  r.p
+ | 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 ; ...}
+ | S Term Term          -- selection:   t ! p
+
+ | Let LocalDef Term    -- local definition: let {t : T = a} in b
+
+ | Alias Ident Type Term  -- constant and its definition, used in inlining
+
+ | Q  Ident Ident        -- qualified constant from a package
+ | QC Ident Ident        -- qualified constructor from a package
+
+ | C Term Term    -- concatenation: s ++ t
+ | Glue Term Term -- agglutination: s + t
+
+ | FV [Term]      -- alternatives in free variation: variants { s ; ... }
+
+ | Alts (Term, [(Term, Term)]) -- alternatives by prefix: pre {t ; s/c ; ...}
+ | Strs [Term]                 -- conditioning prefix strings: strs {s ; ...} 
+
+ --- these three are obsolete
+ | LiT Ident      -- linearization type
+ | Ready Str      -- result of compiling; not to be parsed ...
+ | Computed Term  -- result of computing: not to be reopened nor parsed
+
+  deriving (Read, Show, Eq, Ord)
+
+data Patt =
+   PC Ident [Patt]        -- constructor pattern: C p1 ... pn    C 
+ | PP Ident Ident [Patt]  -- package constructor pattern: P.C p1 ... pn    P.C 
+ | PV Ident               -- variable pattern: x
+ | PW                     -- wild card pattern: _
+ | PR [(Label,Patt)]      -- record pattern: {r = p ; ...}  -- only concrete
+ | PString String         -- string literal pattern: "foo"  -- only abstract
+ | PInt    Int            -- integer literal pattern: 12    -- only abstract
+ | PT Type Patt           -- type-annotated pattern
+  deriving (Read, Show, Eq, Ord)
+
+-- to guide computation and type checking of tables
+data TInfo = 
+   TRaw         -- received from parser; can be anything
+ | TTyped Type  -- type annontated, but can be anything
+ | TComp Type   -- expanded
+ | TWild Type   -- just one wild card pattern, no need to expand 
+  deriving (Read, Show, Eq, Ord)
+
+data Label = 
+    LIdent String
+  | LVar Int
+   deriving (Read, Show, Eq, Ord) -- record label
+
+newtype MetaSymb = MetaSymb Int    deriving (Read, Show, Eq, Ord)
+
+type Decl     = (Ident,Term)  -- (x:A)  (_:A)  A
+type Context  = [Decl]        -- (x:A)(y:B)   (x,y:A)   (_,_:A)
+type Equation = ([Patt],Term) 
+
+type Labelling = (Label, Term) 
+type Assign = (Label, (Maybe Type, Term)) 
+type Case = (Patt, Term) 
+type LocalDef = (Ident, (Maybe Type, Term))
+
+type Param = (Ident, Context) 
+type Altern = (Term, [(Term, Term)])
+
+type Substitution =  [(Ident, Term)]
+
+-- branches à la Alfa
+newtype Branch = Branch (Con,([Ident],Term)) deriving (Eq, Ord,Show,Read)
+type Con = Ident ---
+
+varLabel = LVar
+
+wildPatt :: Patt
+wildPatt = PV wildIdent
+
+type Trm = Term
diff --git a/src/GF/Grammar/LookAbs.hs b/src/GF/Grammar/LookAbs.hs
new file mode 100644
index 000000000..5e0994d46
--- /dev/null
+++ b/src/GF/Grammar/LookAbs.hs
@@ -0,0 +1,125 @@
+module LookAbs where
+
+import Operations
+import qualified GFC as C
+import Abstract
+import Ident
+
+import Modules
+
+import List (nub)
+import Monad
+
+type GFCGrammar = C.CanonGrammar
+
+lookupAbsDef :: GFCGrammar -> Ident -> Ident -> Err (Maybe Term)
+lookupAbsDef gr m c = do
+  mi   <- lookupModule gr m
+  case mi of
+    ModMod mo -> do
+      info <- lookupInfo mo c
+      case info of
+        C.AbsFun _ t  -> return $ return t
+        C.AnyInd _ n  -> lookupAbsDef gr n c
+        _ -> return Nothing
+    _ -> Bad $ prt m +++ "is not an abstract module"
+
+lookupFunType :: GFCGrammar -> Ident -> Ident -> Err Type
+lookupFunType gr m c = do
+  mi   <- lookupModule gr m
+  case mi of
+    ModMod mo -> do
+      info <- lookupInfo mo c
+      case info of
+        C.AbsFun t _  -> return t
+        C.AnyInd _ n  -> lookupFunType gr n c
+        _ -> prtBad "cannot find type of" c
+    _ -> Bad $ prt m +++ "is not an abstract module"
+
+lookupCatContext :: GFCGrammar -> Ident -> Ident -> Err Context
+lookupCatContext gr m c = do
+  mi   <- lookupModule gr m
+  case mi of
+    ModMod mo -> do
+      info <- lookupInfo mo c
+      case info of
+        C.AbsCat co _ -> return co
+        C.AnyInd _ n  -> lookupCatContext gr n c
+        _ -> prtBad "unknown category" c
+    _ -> Bad $ prt m +++ "is not an abstract module"
+
+---- should be revised (20/9/2003)
+isPrimitiveFun :: GFCGrammar -> Fun -> Bool
+isPrimitiveFun gr (m,c) = case lookupAbsDef gr m c of
+  Ok (Just (Eqs [])) -> True  -- is canonical
+  Ok (Just _)        -> False -- has defining clauses
+  _                  -> True  -- has no definition
+
+
+-- looking up refinement terms
+
+lookupRef :: GFCGrammar -> Binds -> Term -> Err Val
+lookupRef gr binds at = case at of
+  Q m f -> lookupFunType gr m f >>= return . vClos
+  Vr i  -> maybeErr ("unknown variable" +++ prt at) $ lookup i binds
+  _     -> prtBad "cannot refine with complex term" at ---
+
+refsForType :: (Val -> Type -> Bool) -> GFCGrammar -> Binds -> Val -> [(Term,Val)]
+refsForType compat gr binds val = 
+  [(vr i, t) | (i,t) <- binds, Ok ty <- [val2exp t], compat val ty] ++
+  [(qq f, vClos t) | (f,t) <- funsForType compat gr val]
+
+
+funRulesOf :: GFCGrammar -> [(Fun,Type)]
+funRulesOf gr = 
+----  funRulesForLiterals ++
+  [((i,f),typ) | (i, ModMod m)   <- modules gr,
+                   mtype m == MTAbstract,
+                   (f, C.AbsFun typ _) <- tree2list (jments m)]
+
+allCatsOf :: GFCGrammar -> [(Cat,Context)]
+allCatsOf gr = 
+  [((i,c),cont) | (i, ModMod m) <- modules gr,
+                    isModAbs m,
+                    (c, C.AbsCat cont _) <- tree2list (jments m)]
+
+funsForType :: (Val -> Type -> Bool) -> GFCGrammar -> Val -> [(Fun,Type)]
+funsForType compat gr val = [(fun,typ) | (fun,typ) <- funRulesOf gr, 
+                                         compat val typ]
+
+funsOnType :: (Val -> Type -> Bool) -> GFCGrammar -> Val -> [((Fun,Int),Type)]
+funsOnType compat gr = funsOnTypeFs compat (funRulesOf gr)
+
+funsOnTypeFs :: (Val -> Type -> Bool) -> [(Fun,Type)] -> Val -> [((Fun,Int),Type)]
+funsOnTypeFs compat fs val = [((fun,i),typ) | 
+                                       (fun,typ) <- fs,
+                                        Ok (args,_,_) <- [typeForm typ],
+                                        (i,arg) <- zip [0..] (map snd args),
+                                        compat val arg]
+
+
+-- this is needed at compile time
+
+lookupFunTypeSrc :: Grammar -> Ident -> Ident -> Err Type
+lookupFunTypeSrc gr m c = do
+  mi   <- lookupModule gr m
+  case mi of
+    ModMod mo -> do
+      info <- lookupInfo mo c
+      case info of
+        AbsFun (Yes t) _  -> return t
+        AnyInd _ n  -> lookupFunTypeSrc gr n c
+        _ -> prtBad "cannot find type of" c
+    _ -> Bad $ prt m +++ "is not an abstract module"
+
+lookupCatContextSrc :: Grammar -> Ident -> Ident -> Err Context
+lookupCatContextSrc gr m c = do
+  mi   <- lookupModule gr m
+  case mi of
+    ModMod mo -> do
+      info <- lookupInfo mo c
+      case info of
+        AbsCat (Yes co) _ -> return co
+        AnyInd _ n  -> lookupCatContextSrc gr n c
+        _ -> prtBad "unknown category" c
+    _ -> Bad $ prt m +++ "is not an abstract module"
diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs
new file mode 100644
index 000000000..b8afbc21e
--- /dev/null
+++ b/src/GF/Grammar/Lookup.hs
@@ -0,0 +1,393 @@
+module Lookup where
+
+import Operations
+import Abstract
+import Modules
+
+import List (nub)
+import Monad
+
+-- lookup in resource and concrete in compiling; for abstract, use Look
+
+lookupResDef :: SourceGrammar -> Ident -> Ident -> Err Term
+lookupResDef gr m c = do
+  mi   <- lookupModule gr m
+  case mi of
+    ModMod mo -> do
+      info <- lookupInfo mo c
+      case info of
+        ResOper _ (Yes t) -> return $ qualifAnnot m t 
+        AnyInd _ n        -> lookupResDef gr n c
+        ResParam _        -> return $ QC m c
+        ResValue _        -> return $ QC m c
+        _   -> Bad $ prt c +++ "is not defined in resource" +++ prt m
+    _ -> Bad $ prt m +++ "is not a resource"
+
+lookupResType :: SourceGrammar -> Ident -> Ident -> Err Type
+lookupResType gr m c = do
+  mi   <- lookupModule gr m
+  case mi of
+    ModMod mo -> do
+      info <- lookupInfo mo c
+      case info of
+        ResOper (Yes t) _ -> return $ qualifAnnot m t
+        AnyInd _ n        -> lookupResType gr n c
+        ResParam _        -> return $ typePType
+        ResValue (Yes t)  -> return $ qualifAnnotPar m t
+        _   -> Bad $ prt c +++ "has no type defined in resource" +++ prt m
+    _ -> Bad $ prt m +++ "is not a resource"
+
+lookupParams :: SourceGrammar -> Ident -> Ident -> Err [Param]
+lookupParams gr m c = do
+  mi   <- lookupModule gr m
+  case mi of
+    ModMod mo -> do
+      info <- lookupInfo mo c
+      case info of
+        ResParam (Yes ps) -> return ps
+        AnyInd _ n        -> lookupParams gr n c
+        _   -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m
+    _ -> Bad $ prt m +++ "is not a resource"
+
+lookupParamValues :: SourceGrammar -> Ident -> Ident -> Err [Term]
+lookupParamValues gr m c = do
+  ps <- lookupParams gr m c
+  liftM concat $ mapM mkPar ps
+ where
+   mkPar (f,co) = do
+     vs <- liftM combinations $ mapM (\ (_,ty) -> allParamValues gr ty) co
+     return $ map (mkApp (QC m f)) vs
+
+lookupFirstTag :: SourceGrammar -> Ident -> Ident -> Err Term
+lookupFirstTag gr m c = do
+  vs <- lookupParamValues gr m c
+  case vs of
+    v:_ -> return v
+    _ -> prtBad "no parameter values given to type" c
+
+allParamValues :: SourceGrammar -> Type -> Err [Term]
+allParamValues cnc ptyp = case ptyp of
+     QC p c -> lookupParamValues cnc p c
+     RecType r -> do
+       let (ls,tys) = unzip r
+       tss <- mapM allPV tys
+       return [R (zipAssign ls ts) | ts <- combinations tss]
+     _ -> prtBad "cannot find parameter values for" ptyp
+  where
+    allPV = allParamValues cnc
+
+qualifAnnot :: Ident -> Term -> Term
+qualifAnnot _ = id
+-- Using this we wouldn't have to annotate constants defined in a module itself.
+-- But things are simpler if we do (cf. Zinc).
+-- Change Rename.self2status to change this behaviour.
+
+-- we need this for lookup in ResVal
+qualifAnnotPar m t = case t of
+  Cn c  -> Q m c
+  Con c -> QC m c
+  _ -> composSafeOp (qualifAnnotPar m) t
+
+
+lookupLincat :: SourceGrammar -> Ident -> Ident -> Err Type
+lookupLincat gr m c = do
+  mi <- lookupModule gr m
+  case mi of
+    ModMod mo -> do
+      info <- lookupInfo mo c
+      case info of
+        CncCat (Yes t) _ _ -> return t
+        AnyInd _ n         -> lookupLincat gr n c
+        _   -> Bad $ prt c +++ "has no linearization type in" +++ prt m
+    _ -> Bad $ prt m +++ "is not concrete"
+
+
+
+{-
+-- the type of oper may have to be inferred at TC, so it may be junk before it
+
+lookupResIdent :: Ident -> [(Ident, SourceRes)] -> Err (Term,Type)
+lookupResIdent c ms = case lookupWhich ms c of
+  Ok (i,info)  -> case info of
+    ResOper (Yes t) _ -> return (Q i c, t)
+    ResOper _ _       -> return (Q i c, undefined) ----
+    ResParam _        -> return (Q i c, typePType)
+    ResValue (Yes t)  -> return (QC i c, t)
+  _   -> Bad $ "not found in resource" +++ prt c
+
+-- NB we only have to look up cnc in canonical!
+
+-- you may want to strip the qualification if the module is the current one
+
+stripMod :: Ident -> Term -> Term
+stripMod m t = case t of
+  Q  n c | n==m -> Cn c
+  QC n c | n==m -> Con c
+  _ -> t
+
+-- what you want may be a pattern and not a term. Then use Macros.term2patt
+
+
+
+
+-- an auxiliary for making ordered search through a list of modules
+
+lookups :: Ord i => (i -> m -> Err (Perhaps a m)) -> i -> [m] -> Err (Perhaps a m)
+lookups look c [] = Bad "not found in any module"
+lookups look c (m:ms) = case look c m of
+  Ok (Yes v)  -> return $ Yes v
+  Ok (May m') -> look c m'
+  _   -> lookups look c ms
+
+
+lookupAbstract :: AbstractST -> Ident -> Err AbsInfo
+lookupAbstract g i = errIn ("not found in abstract" +++ prt i) $ lookupTree prt i g
+
+lookupFunsToCat :: AbstractST -> Ident -> Err [Fun]
+lookupFunsToCat g c = errIn ("looking up functions to category" +++ prt c) $ do
+  info <- lookupAbstract g c
+  case info of
+    AbsCat _ _ fs _ -> return fs
+    _ -> prtBad "not category" c
+
+allFunsWithValCat ab = [(f,c) | (c, AbsCat _ _ fs _) <- abstr2list ab, f <- fs]
+
+allDefs ab = [(f,d) | (f,AbsFun _ (Just d)) <- abstr2list ab]
+
+lookupCatContext :: AbstractST -> Ident -> Err Context
+lookupCatContext g c = errIn "context of category" $ do
+  info <- lookupAbstract g c
+  case info of
+    AbsCat c _ _ _ -> return c
+    _ -> prtBad "not category" c
+
+lookupFunType :: AbstractST -> Ident -> Err Term
+lookupFunType g c = errIn "looking up type of function" $ case c of
+  IL s -> lookupLiteral s >>= return . fst
+  _ -> do
+    info <- lookupAbstract g c
+    case info of
+      AbsFun t _ -> return t
+      AbsType t  -> return typeType
+      _ -> prtBad "not function" c
+
+lookupFunArity :: AbstractST -> Ident -> Err Int
+lookupFunArity g c = do
+  typ <- lookupFunType g c
+  ctx <- contextOfType typ
+  return $ length ctx
+
+lookupAbsDef :: AbstractST -> Ident -> Err (Maybe Term)
+lookupAbsDef g c = errIn "looking up definition in abstract syntax" $ do
+  info <- lookupAbstract g c
+  case info of
+    AbsFun _ t -> return t
+    AbsType t  -> return $ Just t
+    _ -> return $ Nothing  -- constant found and accepted as primitive
+
+
+allCats :: AbstractST -> [Ident]
+allCats abstr = [c | (c, AbsCat _ _ _ _) <- abstr2list abstr]
+
+allIndepCats :: AbstractST -> [Ident]
+allIndepCats abstr = [c | (c, AbsCat [] _ _ _) <- abstr2list abstr]
+
+lookupConcrete :: ConcreteST -> Ident -> Err CncInfo
+lookupConcrete g i = errIn ("not found in concrete" +++ prt i) $ lookupTree prt i g
+
+lookupPackage :: ConcreteST -> Ident -> Err ([Ident], ConcreteST)
+lookupPackage g p = do
+  info <- lookupConcrete g p
+  case info of
+    CncPackage ps ins -> return (ps,ins)
+    _ -> prtBad "not package" p
+
+lookupInPackage :: ConcreteST -> (Ident,Ident) -> Err CncInfo
+lookupInPackage = lookupLift (flip (lookupTree prt))
+
+lookupInAll :: [BinTree (Ident,b)] -> Ident -> Err b
+lookupInAll = lookInAll (flip (lookupTree prt)) 
+
+lookInAll :: (BinTree (Ident,c)  -> Ident -> Err b) -> 
+              [BinTree (Ident,c)] -> Ident -> Err b
+lookInAll look ts c = case ts of
+  t : ts' -> err (const $ lookInAll look ts' c) return $ look t c
+  [] -> prtBad "not found in any package" c
+
+lookupLift :: (ConcreteST -> Ident -> Err b) -> 
+              ConcreteST  -> (Ident,Ident) -> Err b
+lookupLift look g (p,f) = do
+  (ps,ins) <- lookupPackage g p
+  ps' <- mapM (lookupPackage g) ps
+  lookInAll look (ins : reverse (map snd ps')) f
+
+termFromPackage :: ConcreteST -> Ident -> Term -> Err Term
+termFromPackage g p = termFP where
+  termFP t = case t of
+    Cn c -> return $ if isInPack c
+               then Q p c
+               else Cn c 
+    T (TTyped t) cs -> do
+      t' <- termFP t
+      liftM (T (TTyped t')) $ mapM branchInPack cs
+    T i cs -> liftM (T i) $ mapM branchInPack cs
+    _ -> composOp termFP t
+  isInPack c = case lookupInPackage g (p,c) of
+    Ok _ -> True
+    _    -> False
+  branchInPack (q,t) = do
+    p' <- pattInPack q
+    t' <- termFP t
+    return (p',t')
+  pattInPack q = case q of
+    PC c ps -> do
+      let pc = if isInPack c
+                  then PP p c
+                  else PC c
+      ps' <- mapM pattInPack ps 
+      return $ pc ps'
+    _ -> return q
+
+lookupCncDef :: ConcreteST -> Ident -> Err Term
+lookupCncDef g t@(IL _) = return $ cn t
+lookupCncDef g c = errIn "looking up defining term" $ do
+  info <- lookupConcrete g c
+  case info of
+    CncOper _ t _  -> return t  -- the definition
+    CncCat t _ _ _ -> return t  -- the linearization type
+    _ -> return $ Cn c -- constant found and accepted
+
+lookupOperDef :: ConcreteST -> Ident -> Err Term
+lookupOperDef g c = errIn "looking up defining term of oper" $ do
+  info <- lookupConcrete g c
+  case info of
+    CncOper _ t _ -> return t
+    _ -> prtBad "not oper" c
+
+lookupLincat :: ConcreteST -> Ident -> Err Term
+lookupLincat g c = return $ errVal defaultLinType $ do
+  info <- lookupConcrete g c
+  case info of
+    CncCat t _ _ _ -> return t
+    _ -> prtBad "not category" c
+
+lookupLindef :: ConcreteST -> Ident -> Err Term
+lookupLindef g c = return $ errVal linDefStr $ do
+  info <- lookupConcrete g c
+  case info of
+    CncCat _ (Just t) _ _ -> return t
+    CncCat _ _ _ _        -> return $ linDefStr --- wrong: this is only sof {s:Str}
+    _ -> prtBad "not category" c
+
+lookupLinType :: ConcreteST -> Ident -> Err Type
+lookupLinType g c = errIn "looking up type in concrete syntax" $ do
+  info <- lookupConcrete g c
+  case info of
+    CncParType _ _ _ -> return typeType
+    CncParam ty _ -> return ty
+    CncOper (Just ty) _ _ -> return ty
+    _ -> prtBad "no type found for" c
+
+lookupLin :: ConcreteST -> Ident -> Err Term
+lookupLin g c = errIn "looking up linearization rule" $ do
+  info <- lookupConcrete g c
+  case info of
+    CncFun t _ -> return t
+    _ -> prtBad "not category" c
+
+lookupFirstTag :: ConcreteST -> Ident -> Err Term
+lookupFirstTag g c = do
+  vs <- lookupParamValues g c
+  case vs of
+    v:_ -> return v
+    _ -> prtBad "empty parameter type" c
+
+lookupPrintname :: ConcreteST -> Ident -> Err String
+lookupPrintname g c = case lookupConcrete g c of
+  Ok info -> case info of
+    CncCat _ _ _ m   -> mpr m
+    CncFun _ m       -> mpr m
+    CncParType _ _ m -> mpr m
+    CncOper _ _ m    -> mpr m
+    _ -> Bad "no possible printname"
+  Bad s -> Bad s
+ where
+     mpr = maybe (Bad "no printname") (return . stringFromTerm)
+
+-- this variant succeeds even if there's only abstr syntax
+lookupPrintname' g c = case lookupConcrete g c of
+  Bad _   -> return $ prt c 
+  Ok info -> case info of
+    CncCat _ _ _ m   -> mpr m
+    CncFun _ m       -> mpr m
+    CncParType _ _ m -> mpr m
+    CncOper _ _ m    -> mpr m
+    _ -> return $ prt c
+   where
+     mpr = return . maybe (prt c) stringFromTerm
+
+allOperDefs :: ConcreteST -> [(Ident,CncInfo)]
+allOperDefs cnc = [d | d@(_, CncOper _ _ _) <- concr2list cnc]
+
+allPackageDefs :: ConcreteST -> [(Ident,CncInfo)]
+allPackageDefs cnc = [d | d@(_, CncPackage _ _) <- concr2list cnc]
+
+allOperDependencies :: ConcreteST -> [(Ident,[Ident])]
+allOperDependencies cnc = 
+  [(f, filter (/= f) $ -- package name may occur in the package itself
+       nub (concatMap (opersInCncInfo cnc f . snd) (tree2list ds))) | 
+                             (f, CncPackage _ ds) <- allPackageDefs cnc] ++
+  [(f, nub (opersInTerm cnc t)) | 
+                             (f, CncOper _ t _) <- allOperDefs cnc]
+
+opersInTerm :: ConcreteST -> Term -> [Ident]
+opersInTerm cnc t = case t of
+     Cn c -> [c | isOper c]
+     Q p c -> [p]
+     _ -> collectOp ops t
+  where
+   isOper (IL _) = False 
+   isOper c = errVal False $ lookupOperDef cnc c >>= return . const True
+   ops = opersInTerm cnc
+
+-- this is used inside packages, to find references to outside the package
+opersInCncInfo :: ConcreteST -> Ident -> CncInfo -> [Ident]
+opersInCncInfo cnc p i = case i of
+   CncOper _ t _-> filter (not . internal) $ opersInTerm cnc t
+   _ -> []
+  where
+    internal c = case lookupInPackage cnc (p,c) of
+      Ok _ -> True
+      _ -> False
+   
+opersUsedInLins ::  ConcreteST -> [(Ident,[Ident])] -> [Ident]
+opersUsedInLins cnc deps = do
+  let ops0 = concat [opersInTerm cnc t | (_, CncFun t _) <- concr2list cnc]
+  nub $ closure ops0
+ where
+   closure ops = case [g | (f,fs) <- deps, elem f ops, g <- fs, notElem g ops] of
+     [] -> ops
+     ops' -> ops ++ closure ops'
+   -- presupposes deps are not circular: check this first!
+
+
+
+
+-- create refinement and wrapping lists
+
+
+varOrConst :: AbstractST -> Ident -> Err Term
+varOrConst abstr c = case lookupFunType abstr c of
+  Ok _ -> return $ Cn c   --- bindings cannot overshadow constants
+  _ -> case c of
+    IL _ -> return $ Cn c
+    _ -> return $ Vr c
+
+-- a rename operation for parsing term input; for abstract syntax and parameters
+renameTrm :: (Ident -> Err a) -> Term -> Term
+renameTrm look = ren [] where
+  ren vars t = case t of
+    Vr x | notElem x vars && isNotError (look x) -> Cn x
+    Abs x b -> Abs x $ ren (x:vars) b
+    _ -> composSafeOp (ren vars) t
+-}
diff --git a/src/GF/Grammar/MMacros.hs b/src/GF/Grammar/MMacros.hs
new file mode 100644
index 000000000..4078221dc
--- /dev/null
+++ b/src/GF/Grammar/MMacros.hs
@@ -0,0 +1,261 @@
+module MMacros where
+
+import Operations
+import Zipper
+
+import Grammar
+import PrGrammar
+import Ident
+import Refresh
+import Values
+----import GrammarST
+import Macros
+
+import Monad
+
+-- some more abstractions on grammars, esp. for Edit
+
+nodeTree (Tr (n,_)) = n
+argsTree (Tr (_,ts)) = ts
+
+isFocusNode (N (_,_,_,_,b)) = b
+bindsNode   (N (b,_,_,_,_)) = b
+atomNode    (N (_,a,_,_,_)) = a
+valNode     (N (_,_,v,_,_)) = v
+constrsNode (N (_,_,_,(c,_),_)) = c
+metaSubstsNode (N (_,_,_,(_,m),_)) = m
+
+atomTree = atomNode . nodeTree 
+valTree  = valNode  . nodeTree
+
+mkNode binds atom vtyp cs = N (binds,atom,vtyp,cs,False)
+
+type Var = Ident
+type Meta = MetaSymb
+
+metasTree :: Tree ->  [Meta]
+metasTree = concatMap metasNode . scanTree where
+  metasNode n = [m | AtM m <- [atomNode n]] ++ map fst (metaSubstsNode n)
+
+varsTree :: Tree ->  [(Var,Val)]
+varsTree t = [(x,v) | N (_,AtV x,v,_,_) <- scanTree t]
+
+constrsTree :: Tree -> Constraints
+constrsTree = constrsNode . nodeTree
+
+allConstrsTree :: Tree -> Constraints
+allConstrsTree = concatMap constrsNode . scanTree
+
+changeConstrs :: (Constraints -> Constraints) -> TrNode -> TrNode
+changeConstrs f (N (b,a,v,(c,m),x)) = N (b,a,v,(f c, m),x)
+
+changeMetaSubst :: (MetaSubst -> MetaSubst) -> TrNode -> TrNode
+changeMetaSubst f (N (b,a,v,(c,m),x)) = N (b,a,v,(c, f m),x)
+
+changeAtom :: (Atom -> Atom) -> TrNode -> TrNode
+changeAtom f (N (b,a,v,(c,m),x)) = N (b,f a,v,(c, m),x)
+
+------ on the way to Edit
+
+uTree :: Tree
+uTree = Tr (uNode, []) -- unknown tree
+
+uNode :: TrNode
+uNode = mkNode [] uAtom uVal ([],[])
+
+
+uAtom :: Atom
+uAtom = AtM meta0
+
+mAtom :: Atom
+mAtom = AtM meta0
+
+uVal :: Val
+uVal = vClos uExp
+
+vClos :: Exp -> Val
+vClos = VClos []
+
+uExp :: Exp
+uExp = Meta meta0
+
+mExp :: Exp
+mExp = Meta meta0
+
+mExp0 = mExp
+
+meta2exp :: MetaSymb -> Exp
+meta2exp = Meta
+
+atomC = AtC
+
+funAtom :: Atom -> Err Fun
+funAtom a = case a of
+  AtC f -> return f
+  _ -> prtBad "not function head" a
+
+uBoundVar :: Ident
+uBoundVar = zIdent "#h" -- used for suppressed bindings
+
+atomIsMeta :: Atom -> Bool
+atomIsMeta atom = case atom of
+  AtM _ -> True
+  _   -> False
+
+getMetaAtom a = case a of
+  AtM m -> return m
+  _ -> Bad "the active node is not meta"
+
+cat2val :: Context -> Cat -> Val
+cat2val cont cat = vClos $ mkApp (qq cat) [mkMeta i | i <- [1..length cont]]
+
+val2cat :: Val -> Err Cat
+val2cat v = val2exp v >>= valCat
+
+substTerm  :: [Ident] -> Substitution -> Term -> Term
+substTerm ss g c = case c of
+  Vr x        -> maybe c id $ lookup x g
+  App f a     -> App (substTerm ss g f) (substTerm ss g a)
+  Abs x b     -> let y = mkFreshVarX ss x in 
+                   Abs y (substTerm (y:ss) ((x, Vr y):g) b)
+  Prod x a b  -> let y = mkFreshVarX ss x in 
+                   Prod y (substTerm ss g a) (substTerm (y:ss) ((x,Vr y):g) b)
+  _           -> c
+
+metaSubstExp :: MetaSubst -> [(Meta,Exp)]
+metaSubstExp msubst = [(m, errVal (meta2exp m) (val2expSafe v)) | (m,v) <- msubst]
+
+-- belong here rather than to computation
+
+substitute :: [Var] -> Substitution -> Exp -> Err Exp
+substitute v s = return . substTerm v s
+
+alphaConv :: [Var] -> (Var,Var) -> Exp -> Err Exp ---
+alphaConv oldvars (x,x') = substitute (x:x':oldvars) [(x,Vr x')]
+
+alphaFresh :: [Var] -> Exp -> Err Exp
+alphaFresh vs = refreshTermN $ maxVarIndex vs
+
+alphaFreshAll :: [Var] -> [Exp] -> Err [Exp]
+alphaFreshAll vs = mapM $ alphaFresh vs -- done in a state monad
+
+
+val2exp = val2expP False     -- for display
+val2expSafe = val2expP True  -- for type checking
+
+val2expP :: Bool -> Val -> Err Exp
+val2expP safe v = case v of
+
+  VClos g@(_:_) e@(Meta _) -> if safe 
+                              then prtBad "unsafe value substitution" v
+                              else substVal g e
+  VClos g e -> substVal g e
+  VApp f c  -> liftM2 App (val2expP safe f) (val2expP safe c)
+  VCn c     -> return $ qq c
+  VGen i x  -> if safe 
+               then prtBad "unsafe val2exp" v
+               else return $ vr $ x  --- in editing, no alpha conversions presentv
+ where 
+   substVal g e = mapPairsM (val2expP safe) g >>= return . (\s -> substTerm [] s e)
+
+isConstVal :: Val -> Bool
+isConstVal v = case v of
+  VApp f c   -> isConstVal f && isConstVal c
+  VCn _      -> True
+  VClos [] e -> null $ freeVarsExp e  
+  _          -> False --- could be more liberal
+
+mkProdVal :: Binds -> Val -> Err Val ---
+mkProdVal bs v = do 
+  bs' <- mapPairsM val2exp bs
+  v'  <- val2exp v
+  return $ vClos $ foldr (uncurry Prod) v' bs'
+
+freeVarsExp :: Exp -> [Ident]
+freeVarsExp e = case e of
+  Vr x -> [x]
+  App f c -> freeVarsExp f ++ freeVarsExp c
+  Abs x b -> filter (/=x) (freeVarsExp b)
+  Prod x a b -> freeVarsExp a ++ filter (/=x) (freeVarsExp b)
+  _ -> [] --- thus applies to abstract syntax only
+
+ident2string = prIdent
+
+tree :: (TrNode,[Tree]) -> Tree
+tree = Tr
+
+eqCat :: Cat -> Cat -> Bool
+eqCat = (==)
+
+addBinds :: Binds -> Tree -> Tree
+addBinds b (Tr (N (b0,at,t,c,x),ts)) = Tr (N (b ++ b0,at,t,c,x),ts)
+
+bodyTree :: Tree -> Tree
+bodyTree (Tr (N (_,a,t,c,x),ts)) = Tr (N ([],a,t,c,x),ts)
+
+refreshMetas :: [Meta] -> Exp -> Exp
+refreshMetas metas = fst . rms minMeta where
+  rms meta trm = case trm of
+    Meta m  -> (Meta meta, nextMeta meta)
+    App f a -> let (f',msf) = rms meta f 
+                   (a',msa) = rms msf a
+               in (App f' a', msa)
+    Prod x a b -> 
+               let (a',msa) = rms meta a 
+                   (b',msb) = rms msa b
+               in (Prod x a' b', msb)
+    Abs x b -> let (b',msb) = rms meta b in (Abs x b', msb)
+    _       -> (trm,meta)
+  minMeta = int2meta $ 
+              if null metas then 0 else (maximum (map metaSymbInt metas) + 1)
+
+ref2exp :: [Var] -> Type -> Ref -> Err Exp
+ref2exp bounds typ ref = do
+  cont <- contextOfType typ
+  xx0  <- mapM (typeSkeleton . snd) cont
+  let (xxs,cs) = unzip [(length hs, c) | (hs,c) <- xx0]
+      args     = [mkAbs xs mExp | i <- xxs, let xs = mkFreshVars i bounds]
+  return $ mkApp ref args
+  -- no refreshment of metas
+  
+type Ref = Exp -- invariant: only Con or Var
+
+fun2wrap :: [Var] -> ((Fun,Int),Type) -> Exp -> Err Exp
+fun2wrap oldvars ((fun,i),typ) exp = do
+  cont <- contextOfType typ
+  args <- mapM mkArg (zip [0..] (map snd cont))
+  return $ mkApp (qq fun) args
+ where
+  mkArg (n,c) = do
+    cont <- contextOfType c
+    let vars = mkFreshVars (length cont) oldvars
+    return $ mkAbs vars $ if n==i then exp else mExp
+
+---
+
+mkJustProd cont typ = mkProd (cont,typ,[])
+
+int2var :: Int -> Ident
+int2var = zIdent . ('$':) . show
+
+meta0 :: Meta
+meta0 = int2meta 0
+
+termMeta0 :: Term
+termMeta0 = Meta meta0
+
+identVar (Vr x) = return x
+identVar _ = Bad "not a variable"
+
+
+-- light-weight rename for user interaction
+
+qualifTerm :: Ident -> Term -> Term
+qualifTerm m  = qualif [] where
+  qualif xs t = case t of
+    Abs x b -> Abs x $ qualif (x:xs) b
+    Prod x a b -> Prod x (qualif xs a) $ qualif (x:xs) b
+    Vr x | notElem x xs -> Q m x 
+    Cn c  -> Q m c
+    Con c -> QC m c
+    _ -> composSafeOp (qualif xs) t
diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs
new file mode 100644
index 000000000..e6906f985
--- /dev/null
+++ b/src/GF/Grammar/Macros.hs
@@ -0,0 +1,634 @@
+module Macros where
+
+import Operations
+import Str
+import Grammar
+import Ident
+import PrGrammar
+
+import Monad (liftM)
+import Char (isDigit)
+
+-- AR 7/12/1999 - 9/5/2000 -- 4/6/2001
+
+-- operations on terms and types not involving lookup in or reference to grammars
+
+firstTypeForm :: Type -> Err (Context, Type)
+firstTypeForm t = case t of
+  Prod x a b  -> do
+    (x', val) <- firstTypeForm b 
+    return ((x,a):x',val)
+  _ -> return ([],t)
+
+qTypeForm :: Type -> Err (Context, Cat, [Term])
+qTypeForm t = case t of
+  Prod x a b  -> do
+    (x', cat, args) <- qTypeForm b 
+    return ((x,a):x', cat, args)
+  App c a -> do
+    (_,cat, args) <- qTypeForm c
+    return ([],cat,args ++ [a])
+  Q m c ->
+    return ([],(m,c),[]) 
+  QC m c ->
+    return ([],(m,c),[]) 
+  _       -> 
+    prtBad "no normal form of type" t
+
+qq :: QIdent -> Term
+qq (m,c) = Q m c
+
+typeForm = qTypeForm ---- no need to dist any more
+
+typeFormCnc :: Type -> Err (Context, Type)
+typeFormCnc t = case t of
+  Prod x a b  -> do
+    (x', v) <- typeFormCnc b 
+    return ((x,a):x',v)
+  _ -> return ([],t)
+
+valCat :: Type -> Err Cat
+valCat typ = 
+  do (_,cat,_) <- typeForm typ
+     return cat
+
+valType :: Type -> Err Type
+valType typ = 
+  do (_,cat,xx) <- typeForm typ --- not optimal to do in this way
+     return $ mkApp (qq cat) xx
+
+valTypeCnc :: Type -> Err Type
+valTypeCnc typ = 
+  do (_,ty) <- typeFormCnc typ
+     return ty
+
+typeRawSkeleton :: Type -> Err ([(Int,Type)],Type)
+typeRawSkeleton typ =
+  do (cont,typ) <- typeFormCnc typ
+     args <- mapM (typeRawSkeleton . snd) cont
+     return ([(length c, v) | (c,v) <- args], typ)
+
+type MCat = (Ident,Ident)
+
+sortMCat :: String -> MCat
+sortMCat s = (zIdent "_", zIdent s)
+
+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
+  _ -> prtBad "no qualified constant" t
+
+typeSkeleton :: Type -> Err ([(Int,MCat)],MCat)
+typeSkeleton typ = do
+  (cont,val) <- typeRawSkeleton typ
+  cont' <- mapPairsM getMCat cont
+  val'  <- getMCat val
+  return (cont',val')
+
+catSkeleton :: Type -> Err ([MCat],MCat)
+catSkeleton typ =
+  do (args,val) <- typeSkeleton typ
+     return (map snd args, val)
+
+funsToAndFrom :: Type -> (MCat, [(MCat,[Int])])
+funsToAndFrom t = errVal undefined $ do ---
+  (cs,v) <- catSkeleton t
+  let cis = zip cs [0..]
+  return $ (v, [(c,[i | (c',i) <- cis, c' == c]) | c <- cs])
+
+typeFormConcrete :: Type -> Err (Context, Type)
+typeFormConcrete t = case t of
+  Prod x a b  -> do 
+    (x', typ) <- typeFormConcrete b 
+    return ((x,a):x', typ)
+  _       -> return ([],t)
+
+isRecursiveType :: Type -> Bool
+isRecursiveType t = errVal False $ do
+  (cc,c) <- catSkeleton t -- thus recursivity on Cat level
+  return $ any (== c) cc
+
+
+contextOfType :: Type -> Err Context
+contextOfType typ = case typ of
+  Prod x a b -> liftM ((x,a):) $ contextOfType b
+  _ -> return [] 
+
+unComputed :: Term -> Term
+unComputed t = case t of
+  Computed v -> unComputed v
+  _ -> t --- composSafeOp unComputed t
+
+computed = Computed
+
+termForm :: Term -> Err ([(Ident)], Term, [Term])
+termForm t = case t of
+   Abs x b  ->
+     do (x', fun, args) <- termForm b 
+        return (x:x', fun, args)
+   App c a ->
+     do (_,fun, args) <- termForm c
+        return ([],fun,args ++ [a]) 
+   _       -> 
+     return ([],t,[])
+
+appForm :: Term -> (Term, [Term])
+appForm t = case t of
+  App c a -> (fun, args ++ [a]) where (fun, args) = appForm c
+  _       -> (t,[])
+
+varsOfType :: Type -> [Ident]
+varsOfType t = case t of
+  Prod x _ b -> x : varsOfType b
+  _ -> []
+
+mkProdSimple :: Context -> Term -> Term
+mkProdSimple c t = mkProd (c,t,[])
+
+mkProd :: (Context, Term, [Term]) -> Term
+mkProd ([],typ,args) = mkApp typ args
+mkProd ((x,a):dd, typ, args) = Prod x a (mkProd (dd, typ, args))
+
+mkTerm :: ([(Ident)], Term, [Term]) -> Term
+mkTerm (xx,t,aa) = mkAbs xx (mkApp t aa)
+
+mkApp :: Term -> [Term] -> Term
+mkApp = foldl App
+
+mkAbs :: [Ident] -> Term -> Term
+mkAbs xx t = foldr Abs t xx
+
+appCons :: Ident -> [Term] -> Term
+appCons = mkApp . Cn
+
+appc :: String -> [Term] -> Term
+appc = appCons . zIdent
+
+mkLet :: [LocalDef] -> Term -> Term
+mkLet defs t = foldr Let t defs
+
+isVariable (Vr _ ) = True
+isVariable _ = False
+
+eqIdent :: Ident -> Ident -> Bool
+eqIdent = (==)
+
+zIdent :: String -> Ident
+zIdent s = identC s
+
+uType :: Type
+uType = Cn (zIdent "UndefinedType")
+
+assign :: Label -> Term -> Assign
+assign l t = (l,(Nothing,t))
+
+assignT :: Label -> Type -> Term -> Assign
+assignT l a t = (l,(Just a,t))
+
+unzipR :: [Assign] -> ([Label],[Term])
+unzipR r = (ls, map snd ts) where (ls,ts) = unzip r
+
+mkAssign :: [(Label,Term)] -> [Assign]
+mkAssign lts = [assign l t | (l,t) <- lts]
+
+zipAssign :: [Label] -> [Term] -> [Assign]
+zipAssign ls ts = [assign l t | (l,t) <- zip ls ts]
+
+ident2label :: Ident -> Label
+ident2label c = LIdent (prIdent c)
+
+label2ident :: Label -> Ident
+label2ident = identC . prLabel
+
+prLabel :: Label -> String
+prLabel = prt
+
+mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))]
+mapAssignM f ltvs = do
+  let (ls,tvs) = unzip ltvs
+      (ts, vs) = unzip  tvs  
+  ts' <- mapM (\t -> case t of
+            Nothing -> return Nothing
+            Just y  -> f y >>= return . Just) ts
+  vs' <- mapM f vs
+  return (zip ls (zip ts' vs'))
+
+mkRecordN :: Int -> (Int -> Label) -> [Term] -> Term
+mkRecordN int lab typs = R [ assign (lab i) t | (i,t) <- zip [int..] typs]
+
+mkRecord :: (Int -> Label) -> [Term] -> Term
+mkRecord = mkRecordN 0
+
+mkRecTypeN :: Int -> (Int -> Label) -> [Type] -> Type
+mkRecTypeN int lab typs = RecType [ (lab i, t) | (i,t) <- zip [int..] typs]
+
+mkRecType :: (Int -> Label) -> [Type] -> Type
+mkRecType = mkRecTypeN 0
+
+typeType  = srt "Type"
+typePType = srt "PType"
+typeStr   = srt "Str"
+typeTok   = srt "Tok"
+typeStrs  = srt "Strs"
+
+typeString = constPredefRes "String"
+typeInt = constPredefRes "Int"
+
+constPredefRes s = Q (IC "Predef") (zIdent s)
+
+isPredefConstant t = case t of
+  Q (IC "Predef") _ -> True
+  _ -> False
+
+mkSelects :: Term -> [Term] -> Term
+mkSelects t tt = foldl S t tt
+
+mkTable :: [Term] -> Term -> Term
+mkTable tt t = foldr Table t tt
+
+mkCTable :: [Ident] -> Term -> Term
+mkCTable ids v = foldr ccase v ids where 
+  ccase x t = T TRaw [(PV x,t)]
+
+mkDecl :: Term -> Decl
+mkDecl typ = (wildIdent, typ)
+
+eqStrIdent :: Ident -> Ident -> Bool
+eqStrIdent = (==)
+
+tupleLabel i = LIdent $ "p" ++ show i
+linLabel i = LIdent $ "s" ++ show i
+
+tuple2record :: [Term] -> [Assign]
+tuple2record ts = [assign (tupleLabel i) t | (i,t) <- zip [1..] ts]
+
+tuple2recordType :: [Term] -> [Labelling]
+tuple2recordType ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts]
+
+tuple2recordPatt :: [Patt] -> [(Label,Patt)]
+tuple2recordPatt ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts]
+
+mkCases :: Ident -> Term -> Term
+mkCases x t = T TRaw [(PV x, t)]
+
+mkWildCases :: Term -> Term
+mkWildCases = mkCases wildIdent
+
+mkFunType :: [Type] -> Type -> Type
+mkFunType tt t = mkProd ([(wildIdent, ty) | ty <- tt], t, []) -- nondep prod
+
+plusRecType :: Type -> Type -> Err Type
+plusRecType t1 t2 = case (unComputed t1, unComputed t2) of
+  (RecType r1, RecType r2) -> return (RecType (r1 ++ r2))
+  _ -> Bad ("cannot add record types" +++ prt t1 +++ "and" +++ prt t2) 
+
+plusRecord :: Term -> Term -> Err Term
+plusRecord t1 t2 =
+ case (t1,t2) of
+   (R r1, R r2 ) -> return (R (r1 ++ r2))
+   (_,    FV rs) -> mapM (plusRecord t1) rs >>= return . FV
+   (FV rs,_    ) -> mapM (`plusRecord` t2) rs >>= return . FV
+   _ -> Bad ("cannot add records" +++ prt t1 +++ "and" +++ prt t2)
+
+-- default linearization type
+
+defLinType = RecType [(LIdent "s",  typeStr)]
+
+-- refreshing variables
+
+varX :: Int -> Ident
+varX i = identV (i,"x")
+
+mkFreshVar :: [Ident] -> Ident
+mkFreshVar olds = varX (maxVarIndex olds + 1) 
+
+-- trying to preserve a given symbol
+mkFreshVarX :: [Ident] -> Ident -> Ident
+mkFreshVarX olds x = if (elem x olds) then (varX (maxVarIndex olds + 1)) else x
+
+maxVarIndex :: [Ident] -> Int
+maxVarIndex = maximum . ((-1):) . map varIndex
+
+mkFreshVars :: Int -> [Ident] -> [Ident] 
+mkFreshVars n olds = [varX (maxVarIndex olds + i) | i <- [1..n]]
+
+--- quick hack for refining with var in editor
+freshAsTerm :: String -> Term
+freshAsTerm s = Vr (varX (readIntArg s))
+
+-- create a terminal for concrete syntax
+string2term :: String -> Term
+string2term = ccK
+
+ccK = K
+ccC = C
+
+-- create a terminal from identifier
+ident2terminal :: Ident -> Term
+ident2terminal = ccK . prIdent
+
+-- create a constant
+string2CnTrm :: String -> Term
+string2CnTrm = Cn . zIdent
+
+symbolOfIdent :: Ident -> String
+symbolOfIdent = prIdent
+
+symid = symbolOfIdent
+
+vr = Vr
+cn = Cn
+srt = Sort
+meta = Meta
+cnIC = cn . IC
+
+justIdentOf (Vr x) = Just x
+justIdentOf (Cn x) = Just x
+justIdentOf _ = Nothing
+
+isMeta (Meta _) = True
+isMeta _ = False
+mkMeta = Meta . MetaSymb
+
+nextMeta :: MetaSymb -> MetaSymb
+nextMeta = int2meta . succ . metaSymbInt
+
+int2meta = MetaSymb
+
+metaSymbInt :: MetaSymb -> Int
+metaSymbInt (MetaSymb k) = k
+
+freshMeta :: [MetaSymb] -> MetaSymb
+freshMeta ms = MetaSymb (minimum [n | n <- [0..length ms], 
+                                      notElem n (map metaSymbInt ms)])
+
+mkFreshMetasInTrm :: [MetaSymb] -> Trm -> Trm
+mkFreshMetasInTrm metas = fst . rms minMeta where
+  rms meta trm = case trm of
+    Meta m  -> (Meta (MetaSymb meta), meta + 1)
+    App f a -> let (f',msf) = rms meta f 
+                   (a',msa) = rms msf a
+               in (App f' a', msa)
+    Prod x a b -> 
+               let (a',msa) = rms meta a 
+                   (b',msb) = rms msa b
+               in (Prod x a' b', msb)
+    Abs x b -> let (b',msb) = rms meta b in (Abs x b', msb)
+    _       -> (trm,meta)
+  minMeta = if null metas then 0 else (maximum (map metaSymbInt metas) + 1)
+
+-- decides that a term has no metavariables
+isCompleteTerm :: Term -> Bool
+isCompleteTerm t = case t of
+  Meta _  -> False
+  Abs _ b -> isCompleteTerm b
+  App f a -> isCompleteTerm f && isCompleteTerm a
+  _       -> True 
+
+linTypeStr :: Type
+linTypeStr = mkRecType linLabel [typeStr] -- default lintype {s :: Str}
+
+linAsStr :: String -> Term
+linAsStr s = mkRecord linLabel [K s] -- default linearization {s = s}
+
+linDefStr :: Term
+linDefStr = Abs s (R [assign (linLabel 0) (Vr s)]) where s = zIdent "s"
+
+term2patt :: Term -> Err Patt
+term2patt trm = case termForm trm of
+  Ok ([], Vr x, []) -> return (PV x)
+  Ok ([], Con c, aa) -> do
+    aa' <- mapM term2patt aa
+    return (PC c aa')
+  Ok ([], QC p c, aa) -> do
+    aa' <- mapM term2patt aa
+    return (PP p c aa')
+  Ok ([], R r, []) -> do
+    let (ll,aa) = unzipR r
+    aa' <- mapM term2patt aa
+    return (PR (zip ll aa'))
+  Ok ([],EInt i,[]) -> return $ PInt i
+  Ok ([],K s,   []) -> return $ PString s
+  _ -> prtBad "no pattern corresponds to term" trm
+
+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
+  PString s -> K s 
+
+-- to gather s-fields; assumes term in normal form, preserves label
+allLinFields :: Term -> Err [[(Label,Term)]]
+allLinFields trm = case unComputed trm of
+----  R rs  -> return [[(l,t) | (l,(Just ty,t)) <- rs, isStrType ty]] -- good
+  R rs  -> return [[(l,t) | (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
+     LIdent ('s':cs) | all isDigit cs -> True
+     _ -> False
+
+-- to gather ultimate cases in a table; preserves pattern list
+allCaseValues :: Term -> [([Patt],Term)]
+allCaseValues trm = case unComputed trm of
+  T _ cs -> [(p:ps, t) | (p,t0) <- cs, (ps,t) <- allCaseValues t0]
+  _      -> [([],trm)]
+
+-- to 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
+
+-- to mark str parts of fields in a record f by a function f
+markLinFields :: (Term -> Term) -> Term -> Term
+markLinFields f t = case t of
+    R r -> R $ map mkField r
+    _ -> t
+ where
+  mkField (l,(_,t)) = if (isLinLabel l) then (assign l (mkTbl t)) else (assign l t)
+  mkTbl t = case t of
+    T i cs -> T i [(p, mkTbl v) | (p,v) <- cs]
+    _ -> f t
+
+-- to get a string from a term that represents a sequence of terminals
+strsFromTerm :: Term -> Err [Str]
+strsFromTerm t = case unComputed t of
+  K s   -> return [str s]
+  C s t -> do
+    s' <- strsFromTerm s
+    t' <- strsFromTerm t
+    return [plusStr x y | x <- s', y <- t']
+  Glue s t -> do
+    s' <- strsFromTerm s
+    t' <- strsFromTerm t
+    return [glueStr x y | x <- s', y <- t']
+  Alts (d,vs) -> do
+    d0 <- strsFromTerm d
+    v0 <- mapM (strsFromTerm . fst) vs
+    c0 <- mapM (strsFromTerm . snd) vs
+    let vs' = zip v0 c0
+    return [strTok (str2strings def) vars | 
+              def  <- d0,
+              vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] | 
+                                                          vv <- combinations v0]
+           ]
+  FV ts -> mapM strsFromTerm ts >>= return . concat
+  Strs ts -> mapM strsFromTerm ts >>= return . concat  
+  Ready ss -> return [ss]
+  Alias _ _ d -> strsFromTerm d --- should not be needed...
+  _ -> prtBad "cannot get Str from term" t
+
+-- to print an Str-denoting term as a string; if the term is of wrong type, the error msg
+stringFromTerm :: Term -> String
+stringFromTerm = err id (ifNull "" (sstr . head)) . strsFromTerm
+
+
+-- to define compositional term functions
+
+composSafeOp :: (Term -> Term) -> Term -> Term
+composSafeOp op trm = case composOp (mkMonadic op) trm of
+  Ok t -> t
+  _ -> error "the operation is safe isn't it ?"
+ where
+ mkMonadic f = return . f
+
+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)
+   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')
+   Let (x,(mt,a)) b -> 
+     do a'  <- co a
+        mt' <- case mt of
+                 Just t -> co t >>= (return . Just) 
+                 _ -> return mt
+        b'  <- co b
+        return (Let (x,(mt',a')) b')
+   Alias c ty d -> 
+     do v <- co d
+        ty' <- co ty
+        return $ Alias c ty' v
+   C s1 s2 -> 
+     do v1 <- co s1 
+        v2 <- co s2
+        return (C v1 v2)
+   Glue s1 s2 -> 
+     do v1 <- co s1
+        v2 <- co s2
+        return (Glue v1 v2)
+   Alts (t,aa) ->
+     do t' <- co t
+        aa' <- mapM (pairM co) aa
+        return (Alts (t',aa'))
+   FV ts -> mapM co ts >>= return . FV
+   Strs tt -> mapM co tt >>= return . Strs
+   _ -> return trm -- covers K, Vr, Cn, Sort
+
+getTableType :: TInfo -> Err Type
+getTableType i = case i of
+  TTyped ty -> return ty
+  TComp ty  -> return ty
+  TWild ty  -> return ty
+  _ -> Bad "the table is untyped"
+
+changeTableType :: Monad m => (Type -> m Type) -> TInfo -> m TInfo
+changeTableType co i = case i of
+    TTyped ty -> co ty >>= return . TTyped
+    TComp ty  -> co ty >>= return . TComp
+    TWild ty  -> co ty >>= return . TWild
+    _ -> return i
+
+collectOp :: (Term -> [a]) -> Term -> [a]
+collectOp co trm = case trm of
+  App c a    -> co c ++ co a 
+  Abs _ b    -> co b
+  Prod _ a b -> co a ++ co b 
+  S c a      -> co c ++ co a
+  Table a c  -> co a ++ co c
+  ExtR a c   -> co a ++ co c
+  R r        -> concatMap (\ (_,(mt,a)) -> maybe [] co mt ++ co a) r 
+  RecType r  -> concatMap (co . snd) r 
+  P t i      -> co t
+  T _ cc     -> concatMap (co . snd) cc -- not from patterns --- nor from type annot
+  Let (x,(mt,a)) b -> maybe [] co mt ++ co a ++ co b
+  C s1 s2    -> co s1 ++ co s2 
+  Glue s1 s2 -> co s1 ++ co s2 
+  Alts (t,aa) -> let (x,y) = unzip aa in co t ++ concatMap co (x ++ y)
+  FV ts      -> concatMap co ts
+  Strs tt    -> concatMap co tt
+  _ -> [] -- covers K, Vr, Cn, Sort, Ready
+
+-- to find the word items in a term
+
+wordsInTerm :: Term -> [String]
+wordsInTerm trm = filter (not . null) $ case trm of
+   K s     -> [s]
+   S c _   -> wo c
+   Alts (t,aa) -> wo t ++ concatMap (wo . fst) aa
+   Ready s -> allItems s
+   _       -> collectOp wo trm
+ where wo = wordsInTerm
+
+noExist = FV []
+
+defaultLinType :: Type
+defaultLinType = mkRecType linLabel [typeStr]
+
+metaTerms :: [Term]
+metaTerms = map (Meta . MetaSymb) [0..]
+
+-- from GF1, 20/9/2003
+
+isInOneType :: Type -> Bool
+isInOneType t = case t of
+  Prod _ a b -> a == b
+  _ -> False
+
diff --git a/src/GF/Grammar/PatternMatch.hs b/src/GF/Grammar/PatternMatch.hs
new file mode 100644
index 000000000..2ca8b21de
--- /dev/null
+++ b/src/GF/Grammar/PatternMatch.hs
@@ -0,0 +1,98 @@
+module PatternMatch where
+
+import Operations
+import Grammar
+import Ident
+import Macros
+import PrGrammar
+
+import List
+import Monad
+
+-- pattern matching for both concrete and abstract syntax. AR -- 16/6/2003
+
+
+matchPattern :: [(Patt,Term)] -> Term -> Err (Term, Substitution)
+matchPattern pts term = 
+  errIn ("trying patterns" +++ unwords (intersperse "," (map (prt . fst) pts))) $
+  findMatch [([p],t) | (p,t) <- pts] [term]
+
+testOvershadow :: [Patt] -> [Term] -> Err [Patt]
+testOvershadow pts vs = do
+  let numpts = zip pts [0..]
+  let cases  = [(p,EInt i) | (p,i) <- numpts]
+  ts <- mapM (liftM fst . matchPattern cases) vs
+  return $ [p | (p,i) <- numpts, notElem i [i | EInt i <- ts] ]
+
+findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution)
+findMatch cases terms = case cases of
+   [] -> Bad $"no applicable case for" +++ unwords (intersperse "," (map prt terms))
+   (patts,_):_ | length patts /= length terms -> 
+       Bad ("wrong number of args for patterns :" +++ 
+            unwords (map prt patts) +++ "cannot take" +++ unwords (map prt terms))
+   (patts,val):cc -> case mapM tryMatch (zip patts terms) of
+       Ok substs -> return (val, concat substs)
+       _         -> findMatch cc terms
+
+tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
+tryMatch (p,t) = do 
+  t' <- termForm t
+  trym p t'
+ where
+  trym p t' =
+    case (p,t') of
+      (PV IW, _) | isInConstantForm t -> return [] -- optimization with wildcard
+      (PV x,  _) | isInConstantForm t -> return [(x,t)]
+      (PString s, ([],K i,[])) | s==i -> return []
+      (PInt s, ([],EInt i,[])) | s==i -> return []
+      (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 && p `eqStrIdent` f && length pp == length tt ->
+         do matches <- mapM tryMatch (zip pp tt)
+            return (concat matches)
+      ---- hack for AppPredef bug
+      (PP q p pp, ([], Q r f, tt)) | 
+            q `eqStrIdent` r && p `eqStrIdent` f && length pp == length tt ->
+         do matches <- mapM tryMatch (zip pp tt)
+            return (concat matches)
+
+      (PR r, ([],R r',[])) |
+            all (`elem` map fst r') (map fst r) ->
+         do matches <- mapM tryMatch 
+                            [(p,snd a) | (l,p) <- r, let Just a = lookup l r']
+            return (concat matches)
+      (PT _ p',_) -> trym p' t'
+      (_, ([],Alias _ _ d,[])) -> tryMatch (p,d)
+      _ -> prtBad "no match in case expr for" t
+  
+isInConstantForm :: Term -> Bool
+isInConstantForm trm = case trm of
+    Cn _     -> True
+    Con _    -> True
+    Q _ _    -> True
+    QC _ _   -> True
+    Abs _ _  -> True
+    App c a  -> isInConstantForm c && isInConstantForm a
+    R r      -> all (isInConstantForm . snd . snd) r
+    Alias _ _ t -> isInConstantForm t
+    _       -> False ---- isInArgVarForm trm
+
+varsOfPatt :: Patt -> [Ident]
+varsOfPatt p = case p of
+  PV x -> [x | not (isWildIdent x)]
+  PC _ ps -> concat $ map varsOfPatt ps
+  PP _ _ ps -> concat $ map varsOfPatt ps
+  PR r    -> concat $ map (varsOfPatt . snd) r
+  PT _ q -> varsOfPatt q
+  _ -> []
+
+-- to search matching parameter combinations in tables
+isMatchingForms :: [Patt] -> [Term] -> Bool
+isMatchingForms ps ts = all match (zip ps ts') where
+  match (PC c cs, (Cn d, ds)) = c == d && isMatchingForms cs ds
+  match _ = True
+  ts' = map appForm ts
+
diff --git a/src/GF/Grammar/PrGrammar.hs b/src/GF/Grammar/PrGrammar.hs
new file mode 100644
index 000000000..03197ea02
--- /dev/null
+++ b/src/GF/Grammar/PrGrammar.hs
@@ -0,0 +1,189 @@
+module PrGrammar where
+
+import Operations
+import Zipper
+import Grammar
+import Modules
+import qualified PrintGF as P
+import qualified PrintGFC as C
+import qualified AbsGFC as A
+import Values
+import GrammarToSource
+import Ident
+import Str
+
+import List (intersperse)
+
+-- AR 7/12/1999 - 1/4/2000 - 10/5/2003
+
+-- printing and prettyprinting class
+
+class Print a where
+  prt  :: a -> String
+  prt2 :: a -> String   -- printing with parentheses, if needed
+  prpr :: a -> [String] -- pretty printing
+  prt_ :: a -> String   -- printing without ident qualifications
+  prt2 = prt
+  prt_ = prt
+  prpr = return . prt
+
+-- to show terms etc in error messages
+prtBad :: Print a => String -> a -> Err b
+prtBad s a = Bad (s +++ prt a)
+
+prGrammar = P.printTree . trGrammar
+prModule  = P.printTree . trModule
+
+instance Print Term where
+  prt = P.printTree . trt
+  prt_ = prExp
+
+instance Print Ident where
+  prt = P.printTree . tri
+
+instance Print Patt where
+  prt = P.printTree . trp
+
+instance Print Label where
+  prt = P.printTree . trLabel
+
+instance Print MetaSymb where
+  prt (MetaSymb i) = "?" ++ show i
+
+prParam :: Param -> String
+prParam (c,co) = prt c +++ prContext co
+
+prContext :: Context -> String
+prContext co = unwords $ map prParenth [prt x +++ ":" +++ prt t | (x,t) <- co]
+
+-- some GFC notions
+
+instance Print A.Exp where prt = C.printTree
+instance Print A.Term where prt = C.printTree
+instance Print A.Patt where prt = C.printTree
+instance Print A.Case where prt = C.printTree
+instance Print A.Atom where prt = C.printTree
+instance Print A.CIdent where prt = C.printTree
+instance Print A.CType where prt = C.printTree
+instance Print A.Label where prt = C.printTree
+instance Print A.Module where prt = C.printTree
+instance Print A.Sort where prt = C.printTree
+
+
+-- 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
+
+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))
+
+--- to get rig of brackets
+prRefinement :: Term -> String
+prRefinement t = case t of
+  Q m c  -> prQIdent (m,c)
+  QC m c -> prQIdent (m,c)
+  _ -> prt t
+
+-- a pretty-printer for parsable output
+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
+ 
+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) = s
+  prt (AtI i) = show i
+
+prQIdent :: QIdent -> String
+prQIdent (m,f) = prt m ++ "." ++ 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
diff --git a/src/GF/Grammar/Refresh.hs b/src/GF/Grammar/Refresh.hs
new file mode 100644
index 000000000..8b33444d0
--- /dev/null
+++ b/src/GF/Grammar/Refresh.hs
@@ -0,0 +1,105 @@
+module Refresh where
+
+import Operations
+import Grammar
+import Ident
+import Modules
+import Macros
+import Monad
+
+refreshTerm :: Term -> Err Term
+refreshTerm = refreshTermN 0
+
+refreshTermN :: Int -> Term -> Err Term
+refreshTermN i e = liftM snd $ refreshTermKN i e
+
+refreshTermKN :: Int -> Term -> Err (Int,Term)
+refreshTermKN i e = liftM (\ (t,(_,i)) -> (i,t)) $ 
+                    appSTM (refresh e) (initIdStateN i)
+
+refresh :: Term -> STM IdState Term
+refresh e = case e of
+
+  Vr x    -> liftM  Vr  (lookVar x)
+  Abs x b -> liftM2 Abs (refVarPlus x)  (refresh b)
+
+  Prod x a b -> do
+    a'  <- refresh a
+    x'  <- refVar  x
+    b'  <- refresh b
+    return $ Prod x' a' b'
+
+  Let (x,(mt,a)) b -> do
+    a'  <- refresh a
+    mt' <- case mt of
+             Just t -> refresh t >>= (return . Just) 
+             _ -> return mt
+    x'  <- refVar x
+    b'  <- refresh b
+    return (Let (x',(mt',a')) b')
+
+  R r  -> liftM R $ refreshRecord r
+
+  ExtR r s -> liftM2 ExtR (refresh r)  (refresh s)
+  
+  T i cc -> liftM2 T (refreshTInfo i) (mapM refreshCase cc)
+
+  _ -> composOp refresh e
+
+refreshCase :: (Patt,Term) -> STM IdState (Patt,Term)
+refreshCase (p,t) = liftM2 (,) (refreshPatt p) (refresh t)
+
+refreshPatt p = case p of
+  PV x    -> liftM PV     (refVar x)
+  PC c ps -> liftM (PC c) (mapM refreshPatt ps)
+  PP q c ps -> liftM (PP q c) (mapM refreshPatt ps)
+  PR r    -> liftM PR     (mapPairsM refreshPatt r)
+  PT t p' -> liftM2 PT    (refresh t) (refreshPatt p')
+  _ -> return p
+
+refreshRecord r = case r of
+  [] -> return r
+  (x,(mt,a)):b -> do
+    a'  <- refresh a
+    mt' <- case mt of
+             Just t -> refresh t >>= (return . Just) 
+             _ -> return mt
+    b'  <- refreshRecord b
+    return $ (x,(mt',a')) : b'
+
+refreshTInfo i = case i of
+  TTyped t -> liftM TTyped $ refresh t
+  TComp t -> liftM TComp $ refresh t
+  TWild t -> liftM TWild $ refresh t
+  _ -> return i
+
+-- for abstract syntax
+
+refreshEquation :: Equation -> Err ([Patt],Term)
+refreshEquation pst = err Bad (return . fst) (appSTM (refr pst) initIdState) where
+  refr (ps,t) = liftM2 (,) (mapM refreshPatt ps) (refresh t)
+
+-- for concrete and resource in grammar, before optimizing
+
+refreshGrammar :: SourceGrammar -> Err SourceGrammar
+refreshGrammar = liftM (MGrammar . snd) . foldM refreshModule (0,[]) . modules
+
+refreshModule :: (Int,[SourceModule]) -> SourceModule -> Err (Int,[SourceModule])
+refreshModule (k,ms) mi@(i,m) = case m of
+    ModMod mo@(Module mt fs me ops js) | (isModCnc mo || mt == MTResource) -> do
+      (k',js') <- foldM refreshRes (k,[]) $ tree2list js
+      return (k', (i, ModMod(Module mt fs me ops (buildTree js'))) : ms)
+    _ -> return (k, mi:ms)
+ where
+  refreshRes (k,cs) ci@(c,info) = case info of
+    ResOper ptyp (Yes trm) -> do   ---- refresh ptyp
+      (k',trm') <- refreshTermKN k trm
+      return $ (k', (c, ResOper ptyp (Yes trm')):cs)
+    CncCat mt (Yes trm) pn -> do   ---- refresh mt, pn
+      (k',trm') <- refreshTermKN k trm
+      return $ (k', (c, CncCat mt (Yes trm') pn):cs)
+    CncFun mt (Yes trm) pn -> do   ---- refresh pn
+      (k',trm') <- refreshTermKN k trm
+      return $ (k', (c, CncFun mt (Yes trm') pn):cs)
+    _ -> return (k, ci:cs)
+
diff --git a/src/GF/Grammar/ReservedWords.hs b/src/GF/Grammar/ReservedWords.hs
new file mode 100644
index 000000000..43738989f
--- /dev/null
+++ b/src/GF/Grammar/ReservedWords.hs
@@ -0,0 +1,32 @@
+module ReservedWords (isResWord, isResWordGFC) where
+
+import List
+
+-- reserved words of GF. (c) Aarne Ranta 19/3/2002 under Gnu GPL
+-- modified by Markus Forsberg 9/4. 
+-- modified by AR 12/6/2003 for GF2 and GFC
+
+
+isResWord :: String -> Bool
+isResWord s = isInTree s resWordTree
+
+resWordTree :: BTree
+resWordTree = 
+--  mapTree fst $ sorted2tree $ flip zip (repeat ()) $ sort allReservedWords
+    B "let" (B "concrete" (B "Tok" (B "Str" (B "PType" (B "Lin" N N) N) (B "Strs" N N)) (B "case" (B "abstract" (B "Type" N N) N) (B "cat" N N))) (B "fun" (B "flags" (B "def" (B "data" N N) N) (B "fn" N N)) (B "in" (B "grammar" N N) (B "include" N N)))) (B "pattern" (B "of" (B "lindef" (B "lincat" (B "lin" N N) N) (B "lintype" N N)) (B "out" (B "oper" (B "open" N N) N) (B "param" N N))) (B "strs" (B "resource" (B "printname" (B "pre" N N) N) (B "reuse" N N)) (B "transfer" (B "table" N N) (B "variants" N N))))
+
+
+isResWordGFC :: String -> Bool
+isResWordGFC s = isInTree s $
+  B "of" (B "fun" (B "concrete" (B "cat" (B "abstract" N N) N) (B "flags" N N)) (B "lin" (B "in" N N) (B "lincat" N N))) (B "resource" (B "param" (B "oper" (B "open" N N) N) (B "pre" N N)) (B "table" (B "strs" N N) (B "variants" N N)))
+
+data BTree = N | B String BTree BTree deriving (Show)
+
+isInTree :: String -> BTree -> Bool
+isInTree x tree = case tree of
+ N -> False
+ B a left right 
+   | x < a  -> isInTree x left
+   | x > a  -> isInTree x right
+   | x == a -> True
+
diff --git a/src/GF/Grammar/TC.hs b/src/GF/Grammar/TC.hs
new file mode 100644
index 000000000..ce9da979d
--- /dev/null
+++ b/src/GF/Grammar/TC.hs
@@ -0,0 +1,210 @@
+module TC where
+
+import Operations
+import Abstract
+import AbsCompute
+
+import Monad
+
+-- Thierry Coquand's type checking algorithm that creates a trace
+
+data AExp =
+     AVr   Ident Val 
+   | ACn   QIdent Val
+   | AType 
+   | AInt  Int 
+   | AStr  String
+   | AMeta MetaSymb Val
+   | AApp  AExp AExp Val 
+   | AAbs  Ident Val AExp 
+   | AProd Ident AExp AExp 
+   | AEqs  [([Exp],AExp)] ---
+  deriving (Eq,Show)
+
+type Theory = QIdent -> Err Val
+
+lookupConst :: Theory -> QIdent -> Err Val
+lookupConst th f = th f
+
+lookupVar :: Env -> Ident -> Err Val
+lookupVar g x = maybe (prtBad "unknown variable" x) return $ lookup x ((IW,uVal):g)
+-- wild card IW: no error produced, ?0 instead.
+
+type TCEnv = (Int,Env,Env)
+
+emptyTCEnv :: TCEnv
+emptyTCEnv = (0,[],[])
+
+whnf :: Val -> Err Val
+whnf v = ---- errIn ("whnf" +++ prt v) $ ---- debug
+         case v of
+  VApp u w -> do
+    u' <- whnf u 
+    w' <- whnf w
+    app u' w'
+  VClos env e -> eval env e
+  _ -> return v
+
+app :: Val -> Val -> Err Val
+app u v = case u of
+  VClos env (Abs x e) -> eval ((x,v):env) e
+  _ -> return $ VApp u v
+  
+eval :: Env -> Exp -> Err Val
+eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $ 
+             case e of
+  Vr x    -> lookupVar env x
+  Q m c   -> return $ VCn (m,c)
+  Sort c  -> return $ VType --- the only sort is Type
+  App f a -> join $ liftM2 app (eval env f) (eval env a)
+  _ -> return $ VClos env e
+
+eqVal :: Int -> Val -> Val -> Err [(Val,Val)]
+eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $ 
+                do
+  w1 <- whnf u1
+  w2 <- whnf u2 
+  let v = VGen k
+  case (w1,w2) of
+    (VApp f1 a1, VApp f2 a2) -> liftM2 (++) (eqVal k f1 f2) (eqVal k a1 a2)
+    (VClos env1 (Abs x1 e1), VClos env2 (Abs x2 e2)) ->
+      eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2)
+    (VClos env1 (Prod x1 a1 e1), VClos env2 (Prod x2 a2 e2)) ->
+      liftM2 (++) 
+        (eqVal k     (VClos env1          a1) (VClos env2          a2))
+        (eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2))
+    (VGen i _, VGen j _) -> return [(w1,w2) | i /= j]
+    _ -> return [(w1,w2) | w1 /= w2]
+-- invariant: constraints are in whnf
+
+checkType :: Theory -> TCEnv -> Exp -> Err (AExp,[(Val,Val)])
+checkType th tenv e = checkExp th tenv e vType
+
+checkExp :: Theory -> TCEnv -> Exp -> Val -> Err (AExp, [(Val,Val)])
+checkExp th tenv@(k,rho,gamma) e ty = do
+  typ <- whnf ty
+  let v = VGen k
+  case e of
+    Meta m -> return $ (AMeta m typ,[])
+
+    Abs x t -> case typ of
+      VClos env (Prod y a b) -> do
+	a' <- whnf $ VClos env a ---
+	(t',cs) <- checkExp th 
+                           (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
+	return (AAbs x a' t', cs)
+      _ -> prtBad ("function type expected for" +++ prt e +++ "instead of") typ
+
+    Eqs es -> do
+      bcs <- mapM (\b -> checkBranch th tenv b typ) es
+      let (bs,css) = unzip bcs
+      return (AEqs bs, concat css) 
+
+    Prod x a b -> do
+      testErr (typ == vType) "expected Type"
+      (a',csa) <- checkType th tenv a
+      (b',csb) <- checkType th (k+1, (x,v x):rho, (x,VClos rho a):gamma) b
+      return (AProd x a' b', csa ++ csb)
+
+    _ -> checkInferExp th tenv e typ
+
+checkInferExp :: Theory -> TCEnv -> Exp -> Val -> Err (AExp, [(Val,Val)])
+checkInferExp th tenv@(k,_,_) e typ = do
+  (e',w,cs1) <- inferExp th tenv e
+  cs2 <- eqVal k w typ
+  return (e',cs1 ++ cs2)
+      
+inferExp :: Theory -> TCEnv -> Exp -> Err (AExp, Val, [(Val,Val)])
+inferExp th tenv@(k,rho,gamma) e = case e of
+  Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x
+  Q m c -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c)
+  Sort _ -> return (AType, vType, [])
+  App f t -> do
+    (f',w,csf) <- inferExp th tenv f 
+    typ <- whnf w
+    case typ of
+      VClos env (Prod x a b) -> do
+        (a',csa) <- checkExp th tenv t (VClos env a)
+	b' <- whnf $ VClos ((x,VClos rho t):env) b
+	return $ (AApp f' a' b', b', csf ++ csa)
+      _ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ
+  _ -> prtBad "cannot infer type of expression" e
+
+checkBranch :: Theory -> TCEnv -> Equation -> Val -> Err (([Exp],AExp),[(Val,Val)])
+checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $ 
+                                  chB tenv' ps' ty 
+ where 
+
+  (ps',_,rho2,_) = ps2ts k ps
+  tenv' = (k,rho2++rho, gamma)
+  (k,rho,gamma) = tenv
+
+  chB tenv@(k,rho,gamma) ps ty = case ps of
+    p:ps2 -> do
+      typ <- whnf ty
+      case typ of
+        VClos env (Prod y a b) -> do
+	  a' <- whnf $ VClos env a
+          (p', sigma, binds, cs1) <- checkP tenv p y a'
+          let tenv' = (length binds, sigma ++ rho, binds ++ gamma)
+          ((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b)
+	  return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt
+        _ -> prtBad ("Product expected for definiens" +++prt t +++ "instead of") typ
+    [] -> do
+      (e,cs) <- checkExp th tenv t ty
+      return (([],e),cs)
+  checkP env@(k,rho,gamma) t x a = do
+     (delta,cs) <- checkPatt th env t a
+     let sigma = [(x, VGen i x) | ((x,_),i) <- zip delta [k..]]
+     return (VClos sigma t, sigma, delta, cs)
+
+  ps2ts k = foldr p2t ([],0,[],k) 
+  p2t p (ps,i,g,k) = case p of
+     PV IW   -> (meta (MetaSymb i) : ps, i+1,g,k) 
+     PV x    -> (vr x   : ps, i, upd x k g,k+1)
+----     PL s    -> (cn s : ps, i, g, k)
+     PP m c xs -> (mkApp (qq (m,c)) xss : ps, j, g',k') 
+                    where (xss,j,g',k') = foldr p2t ([],i,g,k) xs
+     _ -> error $ "undefined p2t case" +++ prt p +++ "in checkBranch"
+
+  upd x k g = (x, VGen k x) : g --- hack to recognize pattern variables
+
+checkPatt :: Theory -> TCEnv -> Exp -> Val -> Err (Binds,[(Val,Val)])
+checkPatt th tenv exp val = do
+  (aexp,_,cs) <- checkExpP tenv exp val
+  let binds = extrBinds aexp
+  return (binds,cs)
+ where
+   extrBinds aexp = case aexp of
+     AVr i v    -> [(i,v)]
+     AApp f a _ -> extrBinds f ++ extrBinds a
+     _ -> [] -- no other cases are possible
+
+--- ad hoc, to find types of variables
+   checkExpP tenv@(k,rho,gamma) exp val = case exp of
+     Meta m -> return $ (AMeta m val, val, [])
+     Vr x   -> return $ (AVr   x val, val, [])
+     Q m c  -> do
+       typ <- lookupConst th (m,c)
+       return $ (ACn (m,c) typ, typ, [])
+     App f t -> do
+       (f',w,csf) <- checkExpP tenv f val
+       typ <- whnf w
+       case typ of
+         VClos env (Prod x a b) -> do
+           (a',_,csa) <- checkExpP tenv t (VClos env a)
+	   b' <- whnf $ VClos ((x,VClos rho t):env) b
+	   return $ (AApp f' a' b', b', csf ++ csa)
+         _ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ
+     _ -> prtBad "cannot typecheck pattern" exp
+
+-- auxiliaries
+
+noConstr :: Err Val -> Err (Val,[(Val,Val)])
+noConstr er = er >>= (\v -> return (v,[]))
+
+mkAnnot :: (Val -> AExp) -> Err (Val,[(Val,Val)]) -> Err (AExp,Val,[(Val,Val)])
+mkAnnot a ti = do
+  (v,cs) <- ti
+  return (a v, v, cs)
+
diff --git a/src/GF/Grammar/TypeCheck.hs b/src/GF/Grammar/TypeCheck.hs
new file mode 100644
index 000000000..c97bdd362
--- /dev/null
+++ b/src/GF/Grammar/TypeCheck.hs
@@ -0,0 +1,231 @@
+module TypeCheck where
+
+import Operations
+import Zipper
+
+import Abstract
+import AbsCompute
+import Refresh
+import LookAbs
+
+import TC
+
+import Unify ---
+
+import Monad (foldM, liftM, liftM2)
+
+-- top-level type checking functions; TC should not be called directly.
+
+annotate :: GFCGrammar -> Exp -> Err Tree
+annotate gr exp = annotateIn gr [] exp Nothing 
+
+-- type check in empty context, return a list of constraints
+justTypeCheck :: GFCGrammar -> Exp -> Val -> Err Constraints
+justTypeCheck gr e v = do
+  (_,constrs0) <- checkExp (grammar2theory gr) (initTCEnv []) e v
+  constrs1     <- reduceConstraints gr 0 constrs0
+  return $ fst $ splitConstraints constrs1
+
+-- type check in empty context, return the expression itself if valid
+checkIfValidExp :: GFCGrammar -> Exp -> Err Exp
+checkIfValidExp gr e = do
+  (_,_,constrs0) <- inferExp (grammar2theory gr) (initTCEnv []) e
+  constrs1       <- reduceConstraints gr 0 constrs0
+  ifNull (return e) (Bad  . unwords . prConstrs) constrs1
+
+annotateIn :: GFCGrammar -> Binds -> Exp -> Maybe Val -> Err Tree
+annotateIn gr gamma exp = maybe (infer exp) (check exp) where
+  infer e = do 
+    (a,_,cs) <- inferExp theory env e
+    aexp2treeC (a,cs)
+  check e v = do
+    (a,cs) <- checkExp theory env e v
+    aexp2treeC (a,cs)
+  env = initTCEnv gamma
+  theory = grammar2theory gr 
+  aexp2treeC (a,c) = do
+    c' <- reduceConstraints gr (length gamma) c
+    aexp2tree (a,c')
+
+-- invariant way of creating TCEnv from context
+initTCEnv gamma = 
+  (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma) 
+
+-- process constraints after eqVal by computing by defs
+reduceConstraints :: GFCGrammar -> Int -> Constraints -> Err Constraints
+reduceConstraints gr i = liftM concat . mapM redOne where
+  redOne (u,v) = do
+    u' <- computeVal gr u
+    v' <- computeVal gr v
+    eqVal i u' v' 
+
+computeVal :: GFCGrammar -> Val -> Err Val
+computeVal gr v = case v of
+  VClos g@(_:_) e -> do
+    e' <- compt (map fst g) e          --- bindings of g in e?
+    whnf $ VClos g e'
+  VApp f c -> liftM2 VApp (compv f) (compv c) >>= whnf
+  _ -> whnf v
+ where
+   compt = computeAbsTermIn gr
+   compv = computeVal gr
+
+-- take apart constraints that have the form (? <> t), usable as solutions
+splitConstraints :: Constraints -> (Constraints,MetaSubst)
+splitConstraints cs = csmsu where
+
+  csmsu     = unif (csf,msf)  -- alternative: filter first
+  (csf,msf) = foldr mkOne ([],[]) cs
+
+  csmsf     = foldr mkOne ([],msu) csu
+  (csu,msu) = unif (cs,[])    -- alternative: unify first
+
+  mkOne (u,v) = case (u,v) of
+    (VClos g (Meta m), v) | null g -> sub m v
+    (v, VClos g (Meta m)) | null g -> sub m v
+    -- do nothing if meta has nonempty closure; null g || isConstVal v WAS WRONG
+    c -> con c
+  con c (cs,ms) = (c:cs,ms)
+  sub m v (cs,ms) = (cs,(m,v):ms)
+
+  unifo = id -- alternative: don't use unification
+
+  unif cm@(cs,ms) = errVal cm $ do --- alternative: use unification  
+    (cs',ms') <- unifyVal cs
+    return (cs', ms' ++ ms)
+
+performMetaSubstNode :: MetaSubst -> TrNode -> TrNode
+performMetaSubstNode subst n@(N (b,a,v,(c,m),s)) = let
+  v' = metaSubstVal v
+  b' = [(x,metaSubstVal v) | (x,v) <- b]
+  c' = [(u',v') | (u,v) <- c, 
+                  let (u',v') = (metaSubstVal u, metaSubstVal v), u' /= v']
+  in N (b',a,v',(c',m),s)
+ where
+   metaSubstVal u = errVal u $ whnf $ case u of
+     VApp  f a -> VApp  (metaSubstVal f) (metaSubstVal a)
+     VClos g e -> VClos [(x,metaSubstVal v) | (x,v) <- g] (metaSubstExp e)
+     _ -> u
+   metaSubstExp e = case e of
+     Meta m -> errVal e $ maybe (return e) val2expSafe $ lookup m subst
+     _ -> composSafeOp metaSubstExp e
+
+-- weak heuristic to narrow down menus; not used for TC. 15/11/2001
+-- the age-old method from GF 0.9
+possibleConstraints :: GFCGrammar -> Constraints -> Bool
+possibleConstraints gr = and . map (possibleConstraint gr)
+
+possibleConstraint :: GFCGrammar -> (Val,Val) -> Bool
+possibleConstraint gr (u,v) = errVal True $ do
+    u' <- val2exp u >>= compute gr
+    v' <- val2exp v >>= compute gr
+    return $ cts u' v'
+ where
+  cts t u = case (t,u) of
+    (Q m c,      Q n d)      -> c == d || notCan (m,c) || notCan (n,d)
+    (App f a,    App g b)    -> cts f g && cts a b
+    (Abs x b,    Abs y c)    -> cts b c
+    (Prod x a f, Prod y b g) -> cts a b && cts f g
+    (_         , _)          -> isUnknown t || isUnknown u
+
+  isUnknown t = case t of
+    Vr _ -> True
+    Meta _ -> True
+    _ -> False
+
+  notCan = not . isPrimitiveFun gr
+
+-- interface to TC type checker
+
+type2val :: Type -> Val
+type2val = VClos []
+
+aexp2tree :: (AExp,[(Val,Val)]) -> Err Tree
+aexp2tree (aexp,cs) = do
+  (bi,at,vt,ts) <- treeForm aexp
+  ts' <- mapM aexp2tree [(t,[]) | t <- ts]
+  return $ Tr (N (bi,at,vt,(cs,[]),False),ts')
+ where
+  treeForm a = case a of
+     AAbs x v b  -> do
+       (bi, at, vt, args) <- treeForm b
+       v' <- whnf v ---- should not be needed...
+       return ((x,v') : bi, at, vt, args)
+     AApp c a v -> do
+       (_,at,_,args) <- treeForm c
+       v' <- whnf v ---- 
+       return ([],at,v',args ++ [a]) 
+     AVr x v -> do
+       v' <- whnf v ---- 
+       return ([],AtV x,v',[])
+     ACn c v -> do
+       v' <- whnf v ---- 
+       return ([],AtC c,v',[])
+     AMeta m v -> do
+       v' <- whnf v ---- 
+       return ([],AtM m,v',[])
+     _ -> Bad "illegal tree" -- AProd
+
+grammar2theory :: GFCGrammar -> Theory
+grammar2theory gr (m,f) = case lookupFunType gr m f of
+  Ok t -> return $ type2val t
+  Bad s -> case lookupCatContext gr m f of
+    Ok cont -> return $ cont2val cont
+    _ -> Bad s
+
+cont2exp :: Context -> Exp
+cont2exp c = mkProd (c, eType, []) -- to check a context
+
+cont2val :: Context -> Val
+cont2val = type2val . cont2exp
+
+-- some top-level batch-mode checkers for the compiler
+
+justTypeCheckSrc :: Grammar -> Exp -> Val -> Err Constraints
+justTypeCheckSrc gr e v = do
+  (_,constrs0) <- checkExp (grammar2theorySrc gr) (initTCEnv []) e v
+-----  constrs1     <- reduceConstraints gr 0 constrs0
+  return $ fst $ splitConstraints constrs0
+
+grammar2theorySrc :: Grammar -> Theory
+grammar2theorySrc gr (m,f) = case lookupFunTypeSrc gr m f of
+  Ok t -> return $ type2val t
+  Bad s -> case lookupCatContextSrc gr m f of
+    Ok cont -> return $ cont2val cont
+    _ -> Bad s
+
+checkContext :: Grammar -> Context -> [String]
+checkContext st = checkTyp st . cont2exp
+
+checkTyp :: Grammar -> Type -> [String]
+checkTyp gr typ = err singleton prConstrs $ justTypeCheckSrc gr typ vType
+
+checkEquation :: Grammar -> Fun -> Trm -> [String]
+checkEquation gr (m,fun) def = err singleton id $ do
+  typ  <- lookupFunTypeSrc gr m fun
+  cs   <- justTypeCheckSrc gr def (vClos typ)
+  let cs1 = cs ----- filter (not . possibleConstraint gr) cs ----
+  return $ ifNull [] (singleton . prConstraints) cs1
+
+checkConstrs :: Grammar -> Cat -> [Ident] -> [String]
+checkConstrs gr cat _ = [] ---- check constructors!
+
+
+
+
+
+ 
+{- ----
+err singleton concat . mapM checkOne where
+  checkOne con = do
+    typ   <- lookupFunType gr con
+    typ'  <- computeAbsTerm gr typ
+    vcat  <- valCat typ'
+    return $ if (cat == vcat) then [] else ["wrong type in constructor" +++ prt con]
+-}
+
+editAsTermCommand :: GFCGrammar -> (Loc TrNode -> Err (Loc TrNode)) -> Exp -> [Exp]
+editAsTermCommand gr c e = err (const []) singleton $ do
+  t  <- annotate gr $ refreshMetas [] e
+  t' <- c $ tree2loc t
+  return $ tree2exp $ loc2tree t'
diff --git a/src/GF/Grammar/Unify.hs b/src/GF/Grammar/Unify.hs
new file mode 100644
index 000000000..a39087c62
--- /dev/null
+++ b/src/GF/Grammar/Unify.hs
@@ -0,0 +1,84 @@
+module Unify where
+
+import Abstract
+
+import Operations
+
+import List (partition)
+
+-- (c) Petri Mäenpää & Aarne Ranta, 1998--2001
+
+-- brute-force adaptation of the old-GF program AR 21/12/2001 ---
+-- the only use is in TypeCheck.splitConstraints
+
+unifyVal :: Constraints -> Err (Constraints,MetaSubst)
+unifyVal cs0 = do
+  let (cs1,cs2) = partition notSolvable cs0 
+  let (us,vs) = unzip cs1
+  us' <- mapM val2exp us
+  vs' <- mapM val2exp vs
+  let (ms,cs) = unifyAll (zip us' vs') []
+  return (cs1 ++ [(VClos [] t, VClos [] u) | (t,u) <- cs], 
+          [(m,          VClos [] t) | (m,t) <- ms])
+ where
+   notSolvable (v,w) = case (v,w) of -- don't consider nonempty closures
+     (VClos (_:_) _,_) -> True
+     (_,VClos (_:_) _) -> True
+     _ -> False
+
+type Unifier = [(MetaSymb, Trm)]
+type Constrs = [(Trm, Trm)]
+
+unifyAll :: Constrs -> Unifier -> (Unifier,Constrs)
+unifyAll [] g = (g, [])
+unifyAll ((a@(s, t)) : l) g =
+  let (g1, c) = unifyAll l g
+  in case unify s t g1 of
+       Ok g2  -> (g2, c)
+       _      -> (g1, a : c)
+
+unify :: Trm -> Trm -> Unifier -> Err Unifier
+unify e1 e2 g = 
+ case (e1, e2) of 
+  (Meta s, t) -> do
+     tg <- subst_all g t
+     let sg = maybe e1 id (lookup s g)
+     if (sg == Meta s) then extend g s tg else unify sg tg g 
+  (t, Meta s) -> unify e2 e1 g
+  (Q _ a, Q _ b) | (a == b)      -> return g ---- qualif?
+  (QC _ a, QC _ b) | (a == b)    -> return g ----
+  (Vr x, Vr y) | (x == y)        -> return g 
+  (Abs x b, Abs y c)               -> do let c' = substTerm [x] [(y,Vr x)] c 
+                                         unify b c' g
+  (App c a, App d b)            -> case unify c d g of 
+                                     Ok g1 -> unify a b g1 
+                                     _       -> prtBad "fail unify" e1
+  _                             -> prtBad "fail unify" e1
+
+extend :: Unifier -> MetaSymb -> Trm -> Err Unifier
+extend g s t | (t == Meta s) = return g  
+             | occCheck s t  = prtBad "occurs check" t
+             | True          = return ((s, t) : g) 
+
+subst_all :: Unifier -> Trm -> Err Trm
+subst_all s u =
+ case (s,u) of
+  ([], t)  -> return t
+  (a : l, t) -> do
+     t' <- (subst_all l t) --- successive substs - why ?
+     return $ substMetas [a] t'
+
+substMetas :: [(MetaSymb,Trm)] -> Trm -> Trm
+substMetas subst trm = case trm of
+   Meta x -> case lookup x subst of
+     Just t -> t
+     _ -> trm
+   _ -> composSafeOp (substMetas subst) trm
+
+occCheck :: MetaSymb -> Trm -> Bool
+occCheck s u = case u of
+    Meta v  -> s == v
+    App c a -> occCheck s c || occCheck s a
+    Abs x b -> occCheck s b
+    _       -> False
+
diff --git a/src/GF/Grammar/Values.hs b/src/GF/Grammar/Values.hs
new file mode 100644
index 000000000..7b02d187a
--- /dev/null
+++ b/src/GF/Grammar/Values.hs
@@ -0,0 +1,52 @@
+module Values where
+
+import Operations
+import Zipper
+
+import Grammar
+import Ident
+
+-- values used in TC type checking
+
+type Exp = Term
+
+data Val = VGen Int Ident | VApp Val Val | VCn QIdent | VType | VClos Env Exp 
+  deriving (Eq,Show)
+
+type Env = [(Ident,Val)]
+
+-- annotated tree used in editing
+
+type Tree = Tr TrNode
+
+newtype TrNode = N (Binds,Atom,Val,(Constraints,MetaSubst),Bool) 
+  deriving (Eq,Show)
+
+data Atom = AtC Fun | AtM MetaSymb | AtV Ident | AtL String | AtI Int
+  deriving (Eq,Show)
+
+type Binds = [(Ident,Val)]
+type Constraints = [(Val,Val)]
+type MetaSubst = [(MetaSymb,Val)]
+
+-- for TC
+
+vType :: Val
+vType = VType
+
+cType :: Ident
+cType = identC "Type" --- #0
+
+eType :: Exp
+eType = Sort "Type"
+
+tree2exp :: Tree -> Exp
+tree2exp (Tr (N (bi,at,_,_,_),ts)) = foldr Abs (foldl App at' ts') bi' where
+  at' = case at of
+    AtC (m,c) -> Q m c
+    AtV i -> Vr i
+    AtM m -> Meta m
+    AtL s -> K s
+    AtI s -> EInt s
+  bi' = map fst bi
+  ts' = map tree2exp ts
diff --git a/src/GF/Infra/CheckM.hs b/src/GF/Infra/CheckM.hs
new file mode 100644
index 000000000..2ce1a4e95
--- /dev/null
+++ b/src/GF/Infra/CheckM.hs
@@ -0,0 +1,70 @@
+module CheckM where
+
+import Operations
+import Grammar
+import Ident
+import PrGrammar
+
+-- the strings are non-fatal warnings
+type Check a = STM (Context,[String]) a
+
+checkError :: String -> Check a
+checkError = raise
+
+checkCond :: String -> Bool -> Check ()
+checkCond s b = if b then return () else checkError s
+
+-- warnings should be reversed in the end
+checkWarn :: String -> Check ()
+checkWarn s = updateSTM (\ (cont,msg) -> (cont, s:msg))
+
+checkUpdate :: Decl -> Check ()
+checkUpdate d = updateSTM (\ (cont,msg) -> (d:cont, msg))
+
+checkInContext :: [Decl] -> Check r -> Check r
+checkInContext g ch = do
+  i <- checkUpdates g
+  r <- ch
+  checkResets i
+  return r
+
+checkUpdates :: [Decl] -> Check Int
+checkUpdates ds = mapM checkUpdate ds >> return (length ds)
+
+checkReset :: Check ()
+checkReset = checkResets 1
+
+checkResets :: Int -> Check ()
+checkResets i = updateSTM (\ (cont,msg) -> (drop i cont, msg))
+
+checkGetContext :: Check Context
+checkGetContext = do
+  (co,_) <- readSTM
+  return co
+
+checkLookup :: Ident -> Check Type
+checkLookup x = do
+  co <- checkGetContext
+  checkErr $ maybe (prtBad "unknown variable" x) return $ lookup x co
+
+checkStart :: Check a -> Err (a,(Context,[String]))
+checkStart c = appSTM c ([],[])
+
+checkErr :: Err a -> Check a
+checkErr e = stm (\s -> do
+  v <- e
+  return (v,s)
+  )
+
+checkVal :: a -> Check a
+checkVal v = return v
+
+prtFail :: Print a => String -> a -> Check b
+prtFail s t = checkErr $ prtBad s t
+
+checkIn :: String -> Check a -> Check a
+checkIn msg c = stm $ \s@(g,ws) -> case appSTM c s of
+  Bad e -> Bad $ msg ++++ e
+  Ok (v,(g',ws')) -> Ok (v,(g',ws2)) where
+    new = take (length ws' - length ws) ws'
+    ws2 = [msg ++++ w | w <- new] ++ ws
diff --git a/src/GF/Infra/Ident.hs b/src/GF/Infra/Ident.hs
new file mode 100644
index 000000000..3e564460c
--- /dev/null
+++ b/src/GF/Infra/Ident.hs
@@ -0,0 +1,117 @@
+module Ident where
+
+import Operations
+-- import Monad
+
+data Ident = 
+   IC String            -- raw identifier after parsing, resolved in Rename
+ | IW                   -- wildcard
+
+-- below this line: internal representation never returned by the parser
+ | IV (Int,String)      -- variable
+ | IA (String,Int)      -- argument of cat at position
+ | IAV (String,Int,Int) -- argument of cat with bindings at position
+
+  deriving (Eq, Ord, Show, Read)
+
+prIdent :: Ident -> String
+prIdent i = case i of
+  IC s -> s
+  IV (n,s) -> s ++ "_" ++ show n
+  IA (s,j) -> s ++ "_" ++ show j
+  IAV (s,b,j) -> s ++ "_" ++ show b ++ "_" ++ show j
+  IW -> "_"
+
+(identC, identV, identA, identAV, identW) = 
+    (IC,     IV,     IA,     IAV,     IW)
+
+-- normal identifier
+-- ident s = IC s
+
+-- to mark argument variables
+argIdent 0 (IC c) i = identA  (c,i)
+argIdent b (IC c) i = identAV (c,b,i)
+
+-- used in lin defaults
+strVar = identA ("str",0)
+
+-- wild card
+wildIdent = identW
+
+isWildIdent :: Ident -> Bool
+isWildIdent = (== wildIdent)
+
+newIdent = identC "#h"
+
+mkIdent :: String -> Int -> Ident
+mkIdent s i = identV (i,s)
+
+varIndex :: Ident -> Int
+varIndex (IV (n,_)) = n
+varIndex _ = -1 --- other than IV should not count
+
+-- refreshing identifiers
+
+type IdState = ([(Ident,Ident)],Int) 
+
+initIdStateN :: Int -> IdState
+initIdStateN i = ([],i)
+
+initIdState :: IdState
+initIdState = initIdStateN 0
+
+lookVar :: Ident -> STM IdState Ident
+lookVar a@(IA _) = return a
+lookVar x = do
+  (sys,_) <- readSTM
+  stm (\s -> maybe (Bad ("cannot find" +++ show x +++ prParenth (show sys))) 
+                   return $ 
+             lookup x sys >>= (\y -> return (y,s)))
+
+refVar :: Ident -> STM IdState Ident
+----refVar IW = return IW --- no update of wildcard
+refVar x = do
+  (_,m) <- readSTM
+  let x' = IV (m, prIdent x)
+  updateSTM (\ (sys,mx) -> ((x, x'):sys, mx + 1))
+  return x'
+
+refVarPlus :: Ident -> STM IdState Ident
+----refVarPlus IW = refVar (identC "h")
+refVarPlus x = refVar x
+
+
+{-
+------------------------------
+-- to test
+
+refreshExp :: Exp -> Err Exp
+refreshExp e = err Bad (return . fst) (appSTM (refresh e) initState)
+
+refresh :: Exp -> STM State Exp
+refresh e = case e of
+  Atom x  -> lookVar x >>= return . Atom
+  App f a -> liftM2 App (refresh f) (refresh a)
+  Abs x b -> liftM2 Abs (refVar x)  (refresh b)
+  Fun xs a b -> do
+    a'  <- refresh a
+    xs' <- mapM refVar xs
+    b'  <- refresh b
+    return $ Fun xs' a' b'
+
+data Exp =
+   Atom Ident
+ | App Exp Exp
+ | Abs Ident Exp
+ | Fun [Ident] Exp Exp
+  deriving Show
+
+exp1 = Abs (IC "y") (Atom (IC "y"))
+exp2 = Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "y")))
+exp3 = Abs (IC "y") (Abs (IC "z") (App (Atom (IC "y")) (Atom (IC "z"))))
+exp4 = Abs (IC "y") (Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "z"))))
+exp5 = Abs (IC "y") (Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "y"))))
+exp6 = Abs (IC "y") (Fun [IC "x", IC "y"] (Atom (IC "y")) (Atom (IC "y")))
+exp7 = Abs (IL "8") (Atom (IC "y"))
+
+-}
diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs
new file mode 100644
index 000000000..01b789f8f
--- /dev/null
+++ b/src/GF/Infra/Modules.hs
@@ -0,0 +1,181 @@
+module Modules where
+
+import Ident
+import Option
+import Operations
+
+import List
+
+
+-- AR 29/4/2003
+
+-- The same structure will be used in both source code and canonical.
+-- The parameters tell what kind of data is involved.
+-- Invariant: modules are stored in dependency order
+
+data MGrammar i f a = MGrammar {modules :: [(i,ModInfo i f a)]}
+  deriving Show
+
+data ModInfo i f a =
+    ModMainGrammar (MainGrammar i)
+  | ModMod (Module i f a)
+  deriving Show
+
+data Module i f a = Module {
+    mtype   :: ModuleType i ,
+    flags   :: [f] ,
+    extends :: Maybe i ,
+    opens   :: [OpenSpec i] ,
+    jments  :: BinTree (i,a)
+  }
+  deriving Show
+
+-- destructive update
+
+--- dep order preserved since old cannot depend on new
+updateMGrammar :: Ord i => MGrammar i f a -> MGrammar i f a -> MGrammar i f a
+updateMGrammar old new = MGrammar $ 
+  [(i,m) | (i,m) <- os, notElem i (map fst ns)] ++ ns
+ where
+   os = modules old
+   ns = modules new
+
+updateModule :: Ord i => Module i f t -> i -> t -> Module i f t
+updateModule (Module  mt fs me ops js) i t = 
+  Module mt fs me ops (updateTree (i,t) js)
+
+data MainGrammar i = MainGrammar {
+    mainAbstract  :: i ,
+    mainConcretes :: [MainConcreteSpec i]
+  }
+  deriving Show
+
+data MainConcreteSpec i = MainConcreteSpec {
+    concretePrintname :: i ,
+    concreteName :: i ,
+    transferIn   :: Maybe (OpenSpec i) ,  -- if there is an in-transfer
+    transferOut  :: Maybe (OpenSpec i)    -- if there is an out-transfer
+  }
+  deriving Show
+
+data OpenSpec i = OSimple i | OQualif i i
+  deriving (Eq,Show)
+
+openedModule :: OpenSpec i -> i
+openedModule o = case o of
+  OSimple m -> m
+  OQualif _ m -> m
+
+-- initial dependency list
+depPathModule :: Ord i => Module i f a -> [OpenSpec i]
+depPathModule m = fors m ++ exts m ++ opens m where
+  fors m = case mtype m of
+    MTTransfer i j -> [i,j]
+    MTConcrete i   -> [OSimple i]
+    _              -> []
+  exts m = map OSimple $ maybe [] return $ extends m
+
+-- all modules that a module extends, directly or indirectly
+allExtends :: (Show i,Ord i) => MGrammar i f a -> i -> [i]
+allExtends gr i = case lookupModule gr i of
+  Ok (ModMod m) -> case extends m of 
+    Just i1 -> i : allExtends gr i1
+    _ -> [i]
+  _ -> []
+
+-- initial search path: the nonqualified dependencies
+searchPathModule :: Ord i => Module i f a -> [i]
+searchPathModule m = [i | OSimple i <- depPathModule m]
+
+-- a new module can safely be added to the end, since nothing old can depend on it
+addModule :: Ord i => 
+             MGrammar i f a -> i -> ModInfo i f a -> MGrammar i f a
+addModule gr name mi = MGrammar $ (modules gr ++ [(name,mi)])
+
+emptyMGrammar :: MGrammar i f a
+emptyMGrammar = MGrammar []
+
+
+-- we store the module type with the identifier
+
+data IdentM i = IdentM {
+  identM :: i ,
+  typeM  :: ModuleType i
+  }
+  deriving (Eq,Show)
+
+-- encoding the type of the module
+data ModuleType i = 
+    MTAbstract 
+  | MTTransfer (OpenSpec i) (OpenSpec i) 
+  | MTResource
+  | MTResourceInt
+  | MTResourceImpl i 
+  | MTConcrete i
+  | MTConcreteInt i i 
+  | MTConcreteImpl i i i
+  | MTReuse i
+  deriving (Eq,Show)
+
+typeOfModule mi = case mi of
+  ModMod m -> mtype m
+
+isResourceModule mi = case typeOfModule mi of
+  MTResource -> True
+  MTReuse _ -> True
+  MTResourceInt -> True
+  MTResourceImpl _ -> True
+  _ -> False
+
+abstractOfConcrete :: (Show i, Eq i) => MGrammar i f a -> i -> Err i
+abstractOfConcrete gr c = do
+  m <- lookupModule gr c
+  case m of
+    ModMod n -> case mtype n of
+      MTConcrete a -> return a
+      _ -> Bad $ "expected concrete" +++ show c
+    _ -> Bad $ "expected concrete" +++ show c
+
+abstractModOfConcrete :: (Show i, Eq i) => 
+                         MGrammar i f a -> i -> Err (Module i f a)
+abstractModOfConcrete gr c = do
+  a <- abstractOfConcrete gr c
+  m <- lookupModule gr a
+  case m of
+    ModMod n -> return n
+    _ -> Bad $ "expected abstract" +++ show c
+
+
+-- the canonical file name
+
+--- canonFileName s = prt s ++ ".gfc"
+
+lookupModule :: (Show i,Eq i) => MGrammar i f a -> i -> Err (ModInfo i f a)
+lookupModule gr m = case lookup m (modules gr) of
+  Just i -> return i
+  _ -> Bad $ "unknown module" +++ show m 
+             +++ "among" +++ unwords (map (show . fst) (modules gr)) ---- debug
+
+lookupModuleType :: (Show i,Eq i) => MGrammar i f a -> i -> Err (ModuleType i)
+lookupModuleType gr m = do
+  mi <- lookupModule gr m
+  return $ typeOfModule mi
+
+lookupInfo :: (Show i, Ord i) => Module i f a -> i -> Err a
+lookupInfo mo i = lookupTree show i (jments mo)
+
+isModAbs m = case mtype m of
+  MTAbstract -> True
+  _ -> False
+
+isModRes m = case mtype m of
+  MTResource -> True
+  _ -> False
+
+isModCnc m = case mtype m of
+  MTConcrete _ -> True
+  _ -> False
+
+sameMType m n = case (m,n) of
+  (MTConcrete _, MTConcrete _) -> True
+  _ -> m == n
diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs
new file mode 100644
index 000000000..e81c9cd82
--- /dev/null
+++ b/src/GF/Infra/Option.hs
@@ -0,0 +1,204 @@
+module Option where
+
+import List (partition)
+import Char (isDigit)
+
+-- all kinds of options, to be kept abstract
+
+newtype Option = Opt (String,[String]) deriving (Eq,Show,Read)
+newtype Options = Opts [Option] deriving (Eq,Show,Read)
+
+noOptions :: Options
+noOptions = Opts []
+
+iOpt o   = Opt (o,[])   -- simple option -o
+aOpt o a = Opt (o,[a])  -- option with argument -o=a
+iOpts = Opts
+
+oArg s = s -- value of option argument
+
+oElem :: Option -> Options -> Bool
+oElem o (Opts os) = elem o os
+
+type OptFun = String -> Option
+
+getOptVal :: Options -> OptFun -> Maybe String
+getOptVal (Opts os) fopt = 
+  case [a | opt@(Opt (o,[a])) <- os, opt == fopt a] of
+    a:_ -> Just a
+    _ -> Nothing
+
+getOptInt :: Options -> OptFun -> Maybe Int
+getOptInt opts f = do
+  s <- getOptVal opts f
+  if (not (null s) && all isDigit s) then return (read s) else Nothing 
+
+optIntOrAll :: Options -> OptFun -> [a] -> [a]
+optIntOrAll opts f = case getOptInt opts f of
+  Just i -> take i
+  _ -> id
+
+optIntOrN :: Options -> OptFun -> Int -> Int
+optIntOrN opts f n = case getOptInt opts f of
+  Just i -> i
+  _ -> n
+
+optIntOrOne :: Options -> OptFun -> Int
+optIntOrOne opts f = optIntOrN opts f 1
+
+changeOptVal :: Options -> OptFun -> String -> Options
+changeOptVal os f x = 
+  addOption (f x) $ maybe os (\y -> removeOption (f y) os) $ getOptVal os f
+
+addOption :: Option -> Options -> Options
+addOption o (Opts os) = iOpts (o:os)
+
+addOptions (Opts os) os0 = foldr addOption os0 os
+
+removeOption :: Option -> Options -> Options
+removeOption o (Opts os) = iOpts (filter (/=o) os)
+
+removeOptions (Opts os) os0 = foldr removeOption os0 os
+
+options = foldr addOption noOptions
+
+unionOptions :: Options -> Options -> Options
+unionOptions (Opts os) (Opts os') = Opts (os ++ os')
+
+-- parsing options, with prefix pre (e.g. "-")
+
+getOptions :: String -> [String] -> (Options, [String])
+getOptions pre inp = let
+  (os,rest) = span (isOption pre) inp -- options before args
+  in
+  (Opts (map (pOption pre) os), rest)
+
+pOption :: String -> String -> Option
+pOption pre s = case span (/= '=') (drop (length pre) s) of
+  (f,_:a) -> aOpt f a
+  (o,[])  -> iOpt o
+
+isOption :: String -> String -> Bool
+isOption pre = (==pre) . take (length pre)
+
+-- printing options, without prefix
+
+prOpt (Opt (s,[])) = s
+prOpt (Opt (s,xs)) = s ++ "=" ++ concat xs
+prOpts (Opts os) = unwords $ map prOpt os
+
+-- a suggestion for option names
+
+-- parsing
+strictParse  = iOpt "strict"
+forgiveParse = iOpt "n"
+ignoreParse  = iOpt "ign"
+literalParse = iOpt "lit"
+rawParse     = iOpt "raw"
+firstParse   = iOpt "1"
+dontParse    = iOpt "read" -- parse as term instead of string
+
+-- grammar formats
+showAbstr   = iOpt "abs"
+showXML     = iOpt "xml"
+showOld     = iOpt "old"
+showLatex   = iOpt "latex"
+showFullForm = iOpt "fullform" 
+showEBNF    = iOpt "ebnf"
+showCF      = iOpt "cf"
+showWords   = iOpt "ws"
+showOpts    = iOpt "opts"
+-- showOptim   = iOpt "opt"
+isCompiled  = iOpt "gfc"
+isHaskell   = iOpt "gfhs"
+noCompOpers = iOpt "nocomp"
+retainOpers = iOpt "retain"
+defaultGrOpts = []
+newParser   = iOpt "new"
+noCF        = iOpt "nocf"
+checkCirc   = iOpt "nocirc"
+noCheckCirc = iOpt "nocheckcirc"
+
+-- linearization
+allLin      = iOpt "all"
+firstLin    = iOpt "one"
+distinctLin = iOpt "nub"
+dontLin     = iOpt "show"
+showRecord  = iOpt "record"
+showStruct  = iOpt "structured"
+xmlLin      = showXML
+latexLin    = showLatex
+tableLin    = iOpt "table"
+defaultLinOpts = [firstLin]
+useUTF8     = iOpt "utf8"
+
+-- other
+beVerbose    = iOpt "v"
+showInfo     = iOpt "i"
+beSilent     = iOpt "s"
+emitCode     = iOpt "o"
+makeMulti    = iOpt "multi"
+beShort      = iOpt "short"
+wholeGrammar = iOpt "w"
+makeFudget   = iOpt "f"
+byLines      = iOpt "lines"
+byWords      = iOpt "words"
+analMorpho   = iOpt "morpho"
+doTrace      = iOpt "tr"
+noCPU        = iOpt "nocpu"
+doCompute    = iOpt "c"
+optimizeCanon = iOpt "opt"
+
+-- mainly for stand-alone
+useUnicode    = iOpt "unicode"
+optCompute    = iOpt "compute"
+optCheck      = iOpt "typecheck"
+optParaphrase = iOpt "paraphrase"
+forJava       = iOpt "java"
+
+-- for edit session
+allLangs  = iOpt "All"
+absView   = iOpt "Abs"
+
+-- options that take arguments
+useTokenizer   = aOpt "lexer"
+useUntokenizer = aOpt "unlexer"
+useParser      = aOpt "parser"
+firstCat       = aOpt "cat"      -- used on command line
+gStartCat      = aOpt "startcat" -- used in grammar, to avoid clash w res word
+useLanguage    = aOpt "lang"
+speechLanguage = aOpt "language"
+useFont        = aOpt "font"
+grammarFormat  = aOpt "format"
+grammarPrinter = aOpt "printer"
+filterString   = aOpt "filter"
+termCommand    = aOpt "transform"
+transferFun    = aOpt "transfer"
+forForms       = aOpt "forms"
+menuDisplay    = aOpt "menu"
+sizeDisplay    = aOpt "size"
+typeDisplay    = aOpt "types"
+noDepTypes     = aOpt "nodeptypes"
+extractGr      = aOpt "extract"
+pathList       = aOpt "path"
+
+-- refinement order
+nextRefine  = aOpt "nextrefine"
+firstRefine = oArg "first"
+lastRefine  = oArg "last"
+
+-- Boolean flags
+flagYes = oArg "yes"
+flagNo  = oArg "no"
+
+-- integer flags
+flagDepth = aOpt "depth"
+flagLength = aOpt "length"
+flagNumber = aOpt "number"
+
+caseYesNo :: Options -> OptFun -> Maybe Bool
+caseYesNo opts f = do
+  v <- getOptVal opts f
+  if v == flagYes   then return True
+     else if v == flagNo then return False
+     else Nothing
diff --git a/src/GF/Infra/ReadFiles.hs b/src/GF/Infra/ReadFiles.hs
new file mode 100644
index 000000000..f755397f2
--- /dev/null
+++ b/src/GF/Infra/ReadFiles.hs
@@ -0,0 +1,135 @@
+module ReadFiles where
+
+import Arch (selectLater, modifiedFiles, ModTime)
+
+import Operations
+import UseIO
+import System
+import Char
+import Monad
+
+-- make analysis for GF grammar modules. AR 11/6/2003
+
+-- to find all files that have to be read, put them in dependency order, and
+-- decide which files need recompilation. Name file.gf is returned for them,
+-- and file.gfc or file.gfr otherwise.
+
+type ModName = String
+type FileName = String
+type InitPath = String
+type FullPath = String
+
+getAllFiles :: [InitPath] -> [(FullPath,ModTime)] -> FileName -> 
+               IOE [FullPath]
+getAllFiles ps env file = do
+  ds  <- getImports ps file
+  -- print ds  ---- debug
+  ds1 <- ioeErr $ either 
+           return 
+           (\ms -> Bad $ "circular modules" +++ unwords (map show (head ms))) $ 
+              topoTest $ map fst ds
+  let paths = [(f,p) | ((f,_),p) <- ds]
+  let pds1 = [(p,f) | f <- ds1, Just p <- [lookup f paths]]
+  ds2 <- ioeIO $ mapM selectFormat pds1
+  -- print ds2 ---- debug
+  let ds3 = needCompile ds ds2
+  ds4 <- ioeIO $ modifiedFiles env ds3
+  return ds4
+
+getImports :: [InitPath] -> FileName -> IOE [((ModName,[ModName]),InitPath)]
+getImports ps = get [] where
+  get ds file = do
+    let name = fileBody file
+    (p,s) <- readFileIfPath ps $ file
+    let imps  = importsOfFile s
+    case imps of
+      _ | elem name (map (fst . fst) ds) -> return ds  --- file already read
+      [] -> return $ ((name,[]),p):ds
+      _  -> do
+        let files = map gfFile imps
+        foldM get (((name,imps),p):ds) files
+
+-- to decide whether to read gf or gfc; returns full file path
+
+selectFormat :: (InitPath,ModName) -> IO (ModName,(FullPath,Bool))
+selectFormat (p,f) = do
+  let pf = prefixPathName p f
+  f0 <- selectLater (gfFile pf) (gfcFile pf)
+  f1 <- selectLater (gfrFile pf) f0
+  return $ (f, (f1, f1 == gfFile pf)) -- True if needs compile
+
+needCompile :: [((ModName,[ModName]),InitPath)] -> [(ModName,(FullPath,Bool))] ->
+               [FullPath]
+needCompile deps sfiles = filt $ mark $ iter changed where
+
+  -- start with the changed files themselves; returns [ModName]
+  changed = [f | (f,(_,True)) <- sfiles] 
+
+  -- add other files that depend on some changed file; returns [ModName]
+  iter np = let new = [f | ((f,fs),_) <- deps, 
+                           not (elem f np), any (flip elem np) fs]
+            in  if null new then np else (iter (new ++ np))
+
+  -- for each module in the full list, choose source file if change is needed
+  -- returns [FullPath]
+  mark cs = [f' | (f,(file,_)) <- sfiles, 
+                  let f' = if (elem f cs) then gfFile (fileBody file) else file]
+
+  -- if the top file is gfc, only gfc files need be read (could be even better)---
+  filt ds = if isGFC (last ds) 
+    then [gfcFile name | f <- ds, 
+               let (name,suff) = nameAndSuffix f, elem suff ["gfc","gfr"]] 
+    else ds
+
+isGFC = (== "gfc") . fileSuffix
+
+gfcFile = suffixFile "gfc"
+gfrFile = suffixFile "gfr"
+gfFile  = suffixFile "gf"
+
+-- to get imports without parsing the file
+
+importsOfFile :: String -> [FilePath]
+importsOfFile = 
+  filter (not . spec) .      -- ignore keywords and special symbols
+  unqual .                   -- take away qualifiers
+  takeWhile (not . term) .   -- read until curly or semic
+  drop 2 .                   -- ignore keyword and module name
+  lexs .                     -- analyse into lexical tokens
+  unComm                     -- ignore comments before the headed line
+ where
+    term = flip elem ["{",";"]
+    spec = flip elem ["of", "open","in", "reuse", "=", "(", ")",",","**"]
+    unqual ws = case ws of
+      "(":q:ws' -> unqual ws'
+      w:ws' -> w:unqual ws'
+      _ -> ws
+
+unComm s = case s of
+      '-':'-':cs -> unComm $ dropWhile (/='\n') cs
+      '{':'-':cs -> dpComm cs
+      c:cs -> c : unComm cs
+      _ -> s
+    
+dpComm s = case s of
+      '-':'}':cs -> unComm cs
+      c:cs -> dpComm cs
+      _ -> s
+    
+lexs s = x:xs where 
+      (x,y) = head $ lex s
+      xs = if null y then [] else lexs y
+
+-- old GF tolerated newlines in quotes. No more supported!
+fixNewlines s = case s of
+     '"':cs -> '"':mk cs
+     c  :cs -> c:fixNewlines cs
+     _ -> s
+ where
+   mk s = case s of
+     '\\':'"':cs -> '\\':'"': mk cs
+     '"'     :cs -> '"' :fixNewlines cs
+     '\n'    :cs -> '\\':'n': mk cs
+     c       :cs -> c : mk cs
+     _ -> s 
+
diff --git a/src/GF/Infra/UseIO.hs b/src/GF/Infra/UseIO.hs
new file mode 100644
index 000000000..bd9d9e22a
--- /dev/null
+++ b/src/GF/Infra/UseIO.hs
@@ -0,0 +1,245 @@
+module UseIO where
+
+import Operations
+import Arch (prCPU)
+import Option
+
+import IO
+import System
+import Monad
+
+putShow' :: Show a => (c -> a) -> c -> IO ()
+putShow' f = putStrLn . show . length . show . f
+
+putIfVerb opts msg =
+      if oElem beVerbose opts
+         then putStrLn msg
+         else return ()
+
+putIfVerbW opts msg =
+      if oElem beVerbose opts
+         then putStr (' ' : msg)
+         else return ()
+
+-- obsolete with IOE monad
+errIO :: a -> Err a -> IO a
+errIO = errOptIO noOptions
+
+errOptIO :: Options -> a -> Err a -> IO a
+errOptIO os e m = case m of
+  Ok x  -> return x
+  Bad k -> do  
+    putIfVerb os k
+    return e
+
+prOptCPU opts = if (oElem noCPU opts) then (const (return 0)) else prCPU
+
+putCPU = do 
+  prCPU 0 
+  return ()
+
+putPoint :: Show a => Options -> String -> IO a -> IO a
+putPoint = putPoint' id
+
+putPoint' :: Show a => (c -> a) -> Options -> String -> IO c -> IO c
+putPoint' f opts msg act = do
+  let sil x = if oElem beSilent opts then return () else x
+      ve  x = if oElem beVerbose opts then x else return ()
+  ve $ putStrLn msg
+  a <- act
+  ve $ putShow' f a
+  ve $ putCPU
+  return a
+
+readFileIf :: String -> IO String
+readFileIf f = catch (readFile f) (\_ -> reportOn f) where
+ reportOn f = do
+   putStrLnFlush ("File " ++ f ++ " does not exist. Returned empty string")
+   return ""
+
+getFilePath :: [FilePath] -> String -> IO (Maybe FilePath)
+getFilePath paths file = get paths where
+  get []     = putStrLnFlush ("file" +++ file +++ "not found") >> return Nothing
+  get (p:ps) = let pfile = prefixPathName p file in
+               catch (readFile pfile >> return (Just pfile)) (\_ -> get ps)
+
+readFileIfPath :: [FilePath] -> String -> IOE (FilePath,String)
+readFileIfPath paths file = do
+  mpfile <- ioeIO $ getFilePath paths file
+  case mpfile of
+    Just pfile -> do
+      s <- ioeIO $ readFile pfile
+      return (justInitPath pfile,s)
+    _ -> ioeErr $ Bad ("File " ++ file ++ " does not exist.")
+
+pFilePaths :: String -> [FilePath]
+pFilePaths s = case span (/=':') s of
+  (f,_:cs) -> f : pFilePaths cs
+  (f,_)    -> [f]
+
+prefixPathName :: String -> FilePath -> FilePath
+prefixPathName "" f = f
+prefixPathName p f = p ++ "/" ++ f
+
+justInitPath :: FilePath -> FilePath
+justInitPath = reverse . drop 1 . dropWhile (/='/') . reverse
+
+nameAndSuffix :: FilePath -> (String,String)
+nameAndSuffix file = case span (/='.') (reverse file) of
+  (_,[])      -> (file,[])
+  (xet,deman) -> if elem '/' xet 
+                   then (file,[])
+                   else (reverse $ drop 1 deman,reverse xet)
+
+unsuffixFile, fileBody :: FilePath -> String
+unsuffixFile = fst . nameAndSuffix
+fileBody = unsuffixFile
+
+fileSuffix :: FilePath -> String
+fileSuffix = snd . nameAndSuffix
+
+justFileName :: FilePath -> String
+justFileName = reverse . takeWhile (/='/') . reverse
+
+suffixFile :: String -> FilePath -> FilePath
+suffixFile suff file = file ++ "." ++ suff
+
+--
+
+getLineWell :: IO String -> IO String
+getLineWell ios = 
+  catch getLine (\e -> if (isEOFError e) then ios else ioError e)
+
+putStrFlush :: String -> IO ()
+putStrFlush s = putStr s >> hFlush stdout
+
+putStrLnFlush :: String -> IO ()
+putStrLnFlush s = putStrLn s >> hFlush stdout
+
+-- a generic quiz session
+
+type QuestionsAndAnswers = [(String, String -> (Integer,String))]
+
+teachDialogue :: QuestionsAndAnswers -> String -> IO ()
+teachDialogue qas welc = do
+  putStrLn $ welc ++++ genericTeachWelcome
+  teach (0,0) qas
+ where 
+    teach _ [] = do putStrLn "Sorry, ran out of problems"
+    teach (score,total) ((question,grade):quas) = do
+      putStr ("\n" ++ question ++ "\n> ") 
+      answer <- getLine
+      if (answer == ".") then return () else do
+        let (result, feedback) = grade answer
+            score' = score + result 
+            total' = total + 1
+        putStr (feedback ++++ "Score" +++ show score' ++ "/" ++ show total')
+        if (total' > 9 && fromInteger score' / fromInteger total' >= 0.75)
+           then do putStrLn "\nCongratulations - you passed!"
+           else teach (score',total') quas
+
+    genericTeachWelcome = 
+      "The quiz is over when you have done at least 10 examples" ++++
+      "with at least 75 % success." +++++
+      "You can interrupt the quiz by entering a line consisting of a dot ('.').\n"
+
+
+-- IO monad with error; adapted from state monad
+
+newtype IOE a = IOE (IO (Err a))
+
+appIOE :: IOE a -> IO (Err a)
+appIOE (IOE iea) = iea
+
+ioe :: IO (Err a) -> IOE a
+ioe = IOE
+
+ioeIO :: IO a -> IOE a
+ioeIO io = ioe (io >>= return . return)
+
+ioeErr :: Err a -> IOE a
+ioeErr = ioe . return 
+
+instance  Monad IOE where
+  return a    = ioe (return (return a))
+  IOE c >>= f = IOE $ do 
+                  x <- c          -- Err a
+                  appIOE $ err ioeBad f x         -- f :: a -> IOE a
+
+ioeBad :: String -> IOE a
+ioeBad = ioe . return . Bad
+
+useIOE :: a -> IOE a -> IO a
+useIOE a ioe = appIOE ioe >>= err (\s -> putStrLn s >> return a) return 
+
+putStrLnE :: String -> IOE ()
+putStrLnE = ioeIO . putStrLnFlush 
+
+putStrE :: String -> IOE ()
+putStrE = ioeIO . putStrFlush 
+
+putPointE :: Options -> String -> IOE a -> IOE a
+putPointE opts msg act = do
+  let ve x = if oElem beVerbose opts then x else return ()
+  ve $ ioeIO $ putStrFlush msg
+  a <- act
+---  ve $ ioeIO $ putShow' id a --- replace by a statistics command
+  ve $ ioeIO $ putStrFlush " "
+  ve $ ioeIO $ putCPU
+  return a
+{-
+putPointE :: Options -> String -> IOE a -> IOE a
+putPointE opts msg act = do
+  let ve x = if oElem beVerbose opts then x else return ()
+  ve $ putStrE msg
+  a <- act
+---  ve $ ioeIO $ putShow' id a --- replace by a statistics command
+  ve $ ioeIO $ putCPU
+  return a
+-}
+
+-- forces verbosity
+putPointEVerb :: Options -> String -> IOE a -> IOE a
+putPointEVerb opts = putPointE (addOption beVerbose opts)
+
+-- ((do {s <- readFile f; return (return s)}) ) 
+readFileIOE :: FilePath -> IOE (String)
+readFileIOE f = ioe $ catch (readFile f >>= return . return)
+                      (\_ -> return (Bad (reportOn f))) where
+  reportOn f = "File " ++ f ++ " not found."
+  
+-- like readFileIOE but look also in the GF library if file not found
+-- intended semantics: if file is not found, try $GF_LIB_PATH/file
+-- (even if file is an absolute path, but this should always fail)
+-- it returns not only contents of the file, but also the path used
+readFileLibraryIOE :: String -> FilePath -> IOE (FilePath, String)
+readFileLibraryIOE ini f = 
+	ioe $ catch ((do {s <- readFile initPath; return (return (initPath,s))}))
+	 (\_ -> tryLibrary ini f) where
+		tryLibrary :: String -> FilePath -> IO (Err (FilePath, String))
+		tryLibrary ini f = 
+			catch (do {
+				lp <- getLibPath; 
+				s <- readFile (lp ++ f);
+				return (return (lp ++ f, s))
+			}) (\_ -> return (Bad (reportOn f)))
+		initPath = addInitFilePath ini f
+		getLibPath :: IO String
+		getLibPath = do {
+			lp <- getEnv "GF_LIB_PATH";
+			return (if last lp == '/' then lp else lp ++ ['/']);
+		} 
+		reportOn f = "File " ++ f ++ " not found."
+		libPath ini f = f
+		addInitFilePath ini file = case file of
+			'/':_ -> file        -- absolute path name
+			_     -> ini ++ file -- relative path name
+
+
+-- example
+koeIOE :: IO ()
+koeIOE = useIOE () $ do
+  s  <- ioeIO  $ getLine
+  s2 <- ioeErr $ mapM (!? 2) $ words s
+  ioeIO $ putStrLn s2
+
diff --git a/src/GF/Shell.hs b/src/GF/Shell.hs
new file mode 100644
index 000000000..6e4afe88f
--- /dev/null
+++ b/src/GF/Shell.hs
@@ -0,0 +1,292 @@
+module Shell where
+
+--- abstract away from these?
+import Str
+import qualified Grammar as G
+import qualified Ident as I
+import qualified Compute as Co
+import qualified GFC
+import Values
+import GetTree
+
+import API
+import IOGrammar
+import Compile
+---- import GFTex
+-----import TeachYourself -- also a subshell
+
+import ShellState
+import Option
+import Information
+import HelpFile
+import PrOld
+import PrGrammar
+
+import Monad (foldM)
+import System (system)
+
+import Operations
+import UseIO
+import UTF8 (encodeUTF8)
+
+
+---- import qualified GrammarToGramlet as Gr
+---- import qualified GrammarToCanonXML2 as Canon
+
+-- AR 18/4/2000 - 7/11/2001
+
+type SrcTerm = G.Term -- term as returned by the command parser
+
+data Command =
+   CImport FilePath
+ | CRemoveLanguage Language
+ | CEmptyState
+ | CTransformGrammar FilePath
+ | CConvertLatex FilePath
+
+ | CLinearize [()] ---- parameters
+ | CParse
+ | CTranslate Language Language
+ | CGenerateRandom Int
+ | CPutTerm
+ | CWrapTerm Ident
+ | CMorphoAnalyse
+ | CTestTokenizer
+ | CComputeConcrete I.Ident String
+
+ | CTranslationQuiz Language Language
+ | CTranslationList Language Language Int
+ | CMorphoQuiz
+ | CMorphoList Int
+
+ | CReadFile   FilePath
+ | CWriteFile  FilePath
+ | CAppendFile FilePath
+ | CSpeakAloud
+ | CPutString
+ | CShowTerm
+ | CSystemCommand String
+
+ | CSetFlag
+ | CSetLocalFlag Language
+
+ | CPrintGrammar
+ | CPrintGlobalOptions
+ | CPrintLanguages
+ | CPrintInformation I.Ident
+ | CPrintMultiGrammar
+ | CPrintGramlet 
+ | CPrintCanonXML
+ | CPrintCanonXMLStruct 
+ | CPrintHistory
+ | CHelp
+
+ | CImpure ImpureCommand
+
+ | CVoid
+
+-- to isolate the commands that are executed on top level
+data ImpureCommand = 
+    ICQuit | ICExecuteHistory FilePath | ICEarlierCommand Int
+  | ICEditSession | ICTranslateSession
+
+type CommandLine = (CommandOpt, CommandArg,  [CommandOpt])
+
+type CommandOpt = (Command, Options)
+
+type HState  = (ShellState,([String],Integer)) -- history & CPU
+
+type ShellIO = (HState, CommandArg) -> IO (HState, CommandArg)
+
+initHState :: ShellState -> HState
+initHState st = (st,([],0))
+
+cpuHState (_,(_,i)) = i
+optsHState (st,_) = globalOptions st
+putHStateCPU cpu (st,(h,_)) = (st,(h,cpu))
+updateHistory s (st,(h,cpu)) = (st,(s:h,cpu))
+earlierCommandH (_,(h,_)) = ((h ++ repeat "") !!) -- empty command if index over
+
+execLinesH :: String -> [CommandLine] -> HState -> IO HState
+execLinesH s cs hst@(st, (h, _)) = do
+  (_,st') <- execLines True cs hst
+  cpu     <- prOptCPU (optsHState st') (cpuHState hst)
+  return $ putHStateCPU cpu $ updateHistory s st'
+
+ifImpure :: [CommandLine] -> Maybe (ImpureCommand,Options)
+ifImpure cls = foldr (const . Just) Nothing [(c,os) | ((CImpure c,os),_,_) <- cls]
+
+-- the main function: execution of commands. put :: Bool forces immediate output
+
+-- command line with consecutive (;) commands: no value transmitted
+execLines :: Bool -> [CommandLine] -> HState -> IO ([String],HState)
+execLines put cs st = foldM (flip (execLine put)) ([],st) cs
+
+-- command line with piped (|) commands: no value returned
+execLine :: Bool -> CommandLine -> ([String],HState) -> IO ([String],HState)
+execLine put (c@(co, os), arg, cs) (outps,st) = do
+  (st',val) <- execC c (st, arg)
+  let tr = oElem doTrace os || null cs    -- option -tr leaves trace in pipe
+      utf = if (oElem useUTF8 os) then encodeUTF8 else id 
+      outp = if tr then [utf (prCommandArg val)] else []
+  if put then mapM_ putStrLnFlush outp else return ()
+  execs cs val (if put then [] else outps ++ outp, st')
+ where
+    execs []     arg st = return st
+    execs (c:cs) arg st = execLine put (c, arg, cs) st
+
+-- individual commands possibly piped: value returned; this is not a state monad
+execC :: CommandOpt -> ShellIO
+execC co@(comm, opts0) sa@((st,(h,_)),a) = case comm of
+
+  --- read old GF and write into files; no update of st yet
+  CImport file | oElem showOld opts -> useIOE sa $ batchCompileOld file >> return sa
+
+  CImport file -> useIOE sa $ do
+    st <- shellStateFromFiles opts st file
+    ioeIO $ changeState (const st) sa --- \ ((_,h),a) -> ((st,h), a))
+  CEmptyState         -> changeState reinitShellState sa
+
+{-
+  CRemoveLanguage lan -> changeState (removeLanguage lan) sa
+  CTransformGrammar file -> do
+    s <- transformGrammarFile opts file
+    returnArg (AString s) sa
+  CConvertLatex file -> do
+    s <- readFileIf file
+    returnArg (AString (convertGFTex s)) sa 
+-}
+  CPrintHistory -> (returnArg $ AString $ unlines $ reverse h) sa
+  -- good to have here for piping; eh and ec must be done on outer level
+
+  CLinearize [] -> changeArg (opTS2CommandArg (optLinearizeTreeVal opts gro) . s2t) sa
+----  CLinearize m -> changeArg (opTS2CommandArg (optLinearizeArgForm opts gro m)) sa
+
+  CParse     -> case optParseArgErrMsg opts gro (prCommandArg a) of
+    Ok (ts,msg) -> putStrLnFlush msg >> changeArg (const $ ATrms ts) sa
+    Bad msg -> changeArg (const $ AError msg) sa
+
+  CTranslate il ol -> do
+    let a' = opST2CommandArg (optParseArgErr opts (sgr il)) a
+    returnArg (opTS2CommandArg (optLinearizeTreeVal opts (sgr ol)) a') sa
+  CGenerateRandom n -> do
+    ts <- randomTreesIO opts gro (optIntOrN opts flagNumber n)
+    returnArg (ATrms ts) sa
+-----  CPutTerm -> changeArg (opTT2CommandArg (optTermCommand opts gro) . s2t) sa
+-----  CWrapTerm f -> changeArg (opTT2CommandArg (return . wrapByFun opts gro f)) sa
+  CMorphoAnalyse -> changeArg (AString . morphoAnalyse opts gro . prCommandArg) sa
+  CTestTokenizer -> changeArg (AString . optTokenizer opts gro . prCommandArg) sa
+
+  CComputeConcrete m t -> 
+    justOutput (putStrLn (err id prt (
+                string2srcTerm src m t >>= Co.computeConcrete src))) sa
+
+{- ----
+  CTranslationQuiz il ol -> justOutput (teachTranslation opts (sgr il) (sgr ol)) sa
+  CTranslationList il ol n -> do 
+    qs <- transTrainList opts (sgr il) (sgr ol) (toInteger n)
+    returnArg (AString $ foldr (+++++) [] [unlines (s:ss) | (s,ss) <- qs]) sa
+
+  CMorphoQuiz -> justOutput (teachMorpho opts gro) sa
+  CMorphoList n -> do 
+    qs <- useIOE [] $ morphoTrainList opts gro (toInteger n)
+    returnArg (AString $ foldr (+++++) [] [unlines (s:ss) | (s,ss) <- qs]) sa
+-}
+  CReadFile file   -> returnArgIO   (readFileIf file >>= return . AString) sa
+  CWriteFile file  -> justOutputArg (writeFile file) sa
+  CAppendFile file -> justOutputArg (appendFile file) sa
+  CSpeakAloud      -> justOutputArg (speechGenerate opts) sa
+  CSystemCommand s -> justOutput    (system s >> return ()) sa
+-----  CPutString       -> changeArg     (opSS2CommandArg (optStringCommand opts gro)) sa
+-----  CShowTerm        -> changeArg     (opTS2CommandArg (optPrintTerm opts gro) . s2t) sa
+
+  CSetFlag           -> changeState (addGlobalOptions opts0) sa
+---- deprec!  CSetLocalFlag lang -> changeState (addLocalOptions lang opts0) sa
+
+  CHelp              -> returnArg   (AString txtHelpFile) sa
+
+  CPrintGrammar
+    | oElem showOld opts -> returnArg (AString $ printGrammarOld (canModules st)) sa
+    | otherwise -> returnArg (AString (optPrintGrammar opts gro)) sa
+  CPrintGlobalOptions -> justOutput (putStrLn $ prShellStateInfo st) sa
+  CPrintInformation c -> justOutput (useIOE () $ showInformation opts st c) sa
+  CPrintLanguages     -> justOutput 
+                         (putStrLn $ unwords $ map prLanguage $ allLanguages st) sa
+----  CPrintMultiGrammar  -> returnArg (AString (prMultiGrammar opts st)) sa
+----  CPrintGramlet       -> returnArg (AString (Gr.prGramlet st)) sa
+----  CPrintCanonXML      -> returnArg (AString (Canon.prCanonXML st False)) sa
+----  CPrintCanonXMLStruct -> returnArg (AString (Canon.prCanonXML st True)) sa
+  _ -> justOutput (putStrLn "command not understood") sa
+
+ where
+   sgr = stateGrammarOfLang st
+   gro = grammarOfOptState opts st
+   opts = addOptions opts0 (globalOptions st)
+   src = srcModules st
+
+   s2t a = case a of
+     ASTrm s  -> err AError (ATrms . return) $ string2treeErr gro s
+     _ -> a
+
+
+-- commands either change the state or process the argument, but not both
+-- some commands just do output
+
+changeState :: ShellStateOper -> ShellIO
+changeState f ((st,h),a) = return ((f st,h), a)
+
+changeArg :: (CommandArg -> CommandArg) -> ShellIO
+changeArg f (st,a) = return (st, f a)
+
+changeArgMsg :: (CommandArg -> (CommandArg,String)) -> ShellIO
+changeArgMsg f (st,a) = do
+  let (b,msg) = f a
+  putStrLnFlush msg
+  return (st, b)
+
+returnArg :: CommandArg -> ShellIO
+returnArg = changeArg . const
+
+returnArgIO :: IO CommandArg -> ShellIO
+returnArgIO io (st,_) = io >>= (\a -> return (st,a))
+
+justOutputArg :: (String -> IO ()) -> ShellIO
+justOutputArg f sa@(st,a) = f (prCommandArg a) >> return (st, AUnit)
+
+justOutput :: IO () -> ShellIO
+justOutput = justOutputArg . const
+
+-- type system for command arguments; instead of plain strings...
+
+data CommandArg = 
+   AError  String 
+ | ATrms   [Tree] 
+ | ASTrm   String   -- to receive from parser 
+ | AStrs   [Str] 
+ | AString String 
+ | AUnit 
+  deriving (Eq, Show)
+
+prCommandArg :: CommandArg -> String
+prCommandArg arg = case arg of
+  AError s   -> s
+  AStrs ss   -> sstrV ss
+  AString s  -> s
+  ATrms []   -> "no tree found"
+  ATrms tt   -> unlines $ map prt_Tree tt
+  ASTrm s    -> s
+  AUnit      -> ""
+
+opSS2CommandArg :: (String -> String) -> CommandArg -> CommandArg
+opSS2CommandArg f = AString . f . prCommandArg
+
+opST2CommandArg :: (String -> Err [Tree]) -> CommandArg -> CommandArg
+opST2CommandArg f = err AError ATrms . f . prCommandArg
+
+opTS2CommandArg :: (Tree -> String) -> CommandArg -> CommandArg
+opTS2CommandArg f (ATrms ts) = AString $ unlines $ map f ts
+opTS2CommandArg _ _ = AError ("expected term")
+
+opTT2CommandArg :: (Tree -> [Tree]) -> CommandArg -> CommandArg
+opTT2CommandArg f (ATrms ts) = ATrms $ concat $ map f ts
+opTT2CommandArg _ _ = AError ("expected term")
diff --git a/src/GF/Shell/CommandL.hs b/src/GF/Shell/CommandL.hs
new file mode 100644
index 000000000..463b3d4e4
--- /dev/null
+++ b/src/GF/Shell/CommandL.hs
@@ -0,0 +1,135 @@
+module CommandL where
+
+import Operations
+import UseIO
+
+import CMacros
+
+import GetTree
+import ShellState
+import Option
+import Session
+import Commands
+
+import Char
+import List (intersperse)
+
+import UTF8
+
+-- a line-based shell
+
+initEditLoop :: CEnv -> IO () -> IO ()
+initEditLoop env resume = do
+  let env' = addGlobalOptions (options [sizeDisplay "short"]) env
+  putStrLnFlush $ initEditMsg env'
+  let state = initSStateEnv env'
+  putStrLnFlush $ showCurrentState env' state
+  editLoop env' state resume
+
+editLoop :: CEnv -> SState -> IO () -> IO ()
+editLoop env state resume = do
+  putStrFlush "edit> "
+  c <- getCommand
+  if (isQuit c) then resume else do
+    (env',state') <- execCommand env c state
+    let package = case c of
+          CCEnvEmptyAndImport _ -> initEditMsgEmpty env'
+          _ -> showCurrentState env' state'
+    putStrLnFlush package
+
+    editLoop env' state' resume
+
+getCommand :: IO Command
+getCommand = do
+  s <- getLine
+  return $ pCommand s
+
+getCommandUTF :: IO Command
+getCommandUTF = do
+  s <- getLine
+  return $ pCommand s  -- the GUI is doing this: $ decodeUTF8 s 
+
+pCommand = pCommandWords . words where 
+  pCommandWords s = case s of
+    "n" : cat : _ -> CNewCat (strings2Cat cat)
+    "t" : ws      -> CNewTree $ unwords ws
+    "g" : ws      -> CRefineWithTree $ unwords ws  -- *g*ive
+    "p" : ws      -> CRefineParse $ unwords ws
+    ">" : i : _   -> CAhead $ readIntArg i
+    ">" : []      -> CAhead 1
+    "<" : i : _   -> CBack $ readIntArg i
+    "<" : []      -> CBack 1
+    ">>" : _      -> CNextMeta
+    "<<" : _      -> CPrevMeta
+    "'" : _       -> CTop
+    "+" : _       -> CLast
+    "r" : f : _   -> CRefineWithAtom f
+    "w" : f:i : _ -> CWrapWithFun (strings2Fun f, readIntArg i)
+    "ch": f : _   -> CChangeHead (strings2Fun f)
+    "ph": _       -> CPeelHead
+    "x" : ws      -> CAlphaConvert $ unwords ws
+    "s" : i : _   -> CSelectCand (readIntArg i)
+    "f" : "unstructured" : _ -> CRemoveOption showStruct --- hmmm
+    "f" : "structured" : _ -> CAddOption showStruct --- hmmm
+    "f" : s : _   -> CAddOption (filterString s)
+    "u" : _       -> CUndo
+    "d" : _       -> CDelete
+    "c" : s : _   -> CTermCommand s
+    "a" : _       -> CRefineRandom --- *a*leatoire
+    "m" :  _      -> CMenu
+----    "ml" : s : _  -> changeMenuLanguage s
+----    "ms" : s : _  -> changeMenuSize s
+----    "mt" : s : _  -> changeMenuTyped s
+    "v" : _       -> CView
+    "q" : _       -> CQuit
+    "h" : _       -> CHelp initEditMsg
+
+    "i" : file: _ -> CCEnvImport file
+    "e" : []      -> CCEnvEmpty
+    "e" : file: _ -> CCEnvEmptyAndImport file
+
+    "open" : f: _ -> CCEnvOpenTerm f
+    "openstring": f: _ -> CCEnvOpenString f
+
+    "on" :lang: _ -> CCEnvOn  lang 
+    "off":lang: _ -> CCEnvOff lang 
+    "pfile" :f:_  -> CCEnvRefineParse f
+    "tfile" :f:_  -> CCEnvRefineWithTree f
+
+-- openstring file
+-- pfile file
+-- tfile file
+-- on lang
+-- off lang
+
+    "gf": comm    -> CCEnvGFShell (unwords comm)
+
+    []            -> CVoid
+    _             -> CError
+
+-- well, this lists the commands of the line-based editor
+initEditMsg env = unlines $
+  "State-dependent editing commands are given in the menu:" :
+  "  n = new, r = refine, w = wrap, d = delete, s = select." :
+  "Commands changing the environment:" :
+  "  i [file] = import, e = empty." :
+  "Other commands:" : 
+  "  a = random, v = change view, u = undo, h = help, q = quit," :
+  "  ml [Lang] = change menu language," :
+  "  ms (short | long) = change menu command size," :
+  "  mt (typed | untyped) = change menu item typing," :
+  "  p [string] = refine by parsing, g [term] = refine by term," :             
+  "  > = down, < = up, ' = top, >> = next meta, << = previous meta." :
+---- ("  c [" ++ unwords (intersperse "|" allTermCommands) ++ "] = modify term") : 
+---- ("  f [" ++ unwords (intersperse "|" allStringCommands) ++ "] = modify output") : 
+  []
+
+initEditMsgEmpty env = initEditMsg env +++++ unlines (
+  "Start editing by n Cat selecting category\n\n" :
+  "-------------\n" :
+  ["n" +++ cat | (_,cat) <- newCatMenu env]
+  )
+
+showCurrentState env' state' =
+  unlines (tr ++ ["",""] ++ msg ++ ["",""] ++ map fst menu) 
+                 where (tr,msg,menu) = displaySStateIn env' state'
diff --git a/src/GF/Shell/Commands.hs b/src/GF/Shell/Commands.hs
new file mode 100644
index 000000000..5c92c7bd6
--- /dev/null
+++ b/src/GF/Shell/Commands.hs
@@ -0,0 +1,443 @@
+module Commands where
+
+import Operations
+import Zipper
+
+----import AccessGrammar (Term (Vr)) ----
+import qualified Grammar as G ---- Cat
+import GFC
+import qualified AbsGFC ---- Atom
+import CMacros
+import LookAbs
+
+import GetTree
+import API
+import ShellState
+
+import qualified Shell
+import qualified Ident as I
+import qualified PShell
+import qualified Macros as M
+import PrGrammar
+import TypeCheck ---- tree2exp
+import PGrammar
+import IOGrammar
+import UseIO
+import Unicode
+
+import Option
+import CF
+----- import CFIdent (cat2CFCat, cfCat2Cat)
+import Linear
+import Randomized
+import Editing
+import Session
+import Custom
+
+import Random (mkStdGen)
+import Monad (liftM2)
+import List (intersperse)
+import Random (newStdGen)
+
+--- temporary hacks for GF 2.0
+
+-- abstract command language for syntax editing. AR 22/8/2001
+
+data Command =
+   CNewCat G.Cat
+ | CNewTree String
+ | CAhead Int
+ | CBack Int
+ | CNextMeta
+ | CPrevMeta
+ | CTop
+ | CLast
+ | CRefineWithTree String
+ | CRefineWithAtom String
+ | CRefineParse String
+ | CWrapWithFun (G.Fun,Int)
+ | CChangeHead G.Fun
+ | CPeelHead
+ | CAlphaConvert String
+ | CRefineRandom
+ | CSelectCand Int
+ | CTermCommand  String
+ | CAddOption Option
+ | CRemoveOption Option
+ | CDelete
+ | CUndo
+ | CView
+ | CMenu
+ | CQuit
+ | CHelp  (CEnv -> String) -- help message depends on grammar and interface
+ | CError -- syntax error in command
+ | CVoid  -- empty command, e.g. just <enter>
+
+-- commands affecting CEnv
+ | CCEnvImport String
+ | CCEnvEmptyAndImport String
+ | CCEnvOpenTerm String
+ | CCEnvOpenString String
+ | CCEnvEmpty
+
+ | CCEnvOn  String
+ | CCEnvOff String
+
+ | CCEnvGFShell String
+
+-- other commands using IO
+ | CCEnvRefineWithTree String
+ | CCEnvRefineParse String
+
+isQuit CQuit = True
+isQuit _ = False
+
+-- an abstract environment type
+
+type CEnv    = ShellState
+
+grammarCEnv  = firstStateGrammar
+canCEnv  = canModules
+concreteCEnv = cncId
+abstractCEnv = absId
+
+stdGenCEnv env s = mkStdGen (length (displayJustStateIn env s) * 31 +11) ---
+
+initSStateEnv env = case getOptVal (stateOptions sgr) gStartCat of
+----  Just cat -> action2commandNext (newCat gr (identC cat)) initSState
+  _ -> initSState
+ where 
+   sgr = firstStateGrammar env
+   gr  = stateGrammarST sgr
+
+-- the main function
+
+execCommand :: CEnv -> Command -> SState -> IO (CEnv,SState)
+execCommand env c s = case c of
+{- ----
+-- these commands do need IO
+  CCEnvImport file -> do
+
+    gr <- optFile2grammar noOptions (maybeStateAbstract env) file
+    let lan = getLangNameOpt noOptions file
+    return (updateLanguage file (lan, getStateConcrete gr) 
+                           (initWithAbstract (stateAbstract gr) env), s)
+
+  CCEnvEmptyAndImport file -> do
+    gr <- optFile2grammar noOptions Nothing file
+    let lan = getLangNameOpt noOptions file
+    return (updateLanguage file (lan, getStateConcrete gr) 
+                 (initWithAbstract (stateAbstract gr) emptyShellState), initSState)
+
+  CCEnvEmpty -> do
+    return (emptyShellState, initSState)
+
+  CCEnvGFShell command -> do
+    let cs = PShell.pCommandLines command
+    (msg,(env',_)) <- Shell.execLines False cs (Shell.initHState env)
+    return (env', changeMsg msg s) ----
+
+  CCEnvOpenTerm file -> do
+    c <- readFileIf file
+    let (fs,t) = envAndTerm file c
+
+    env' <- shellStateFromFiles noOptions fs
+    return (env', (action2commandNext $ \x -> 
+                      (string2treeErr (grammarCEnv env') t x >>= 
+                                                      \t -> newTree t x)) s)
+
+  CCEnvOpenString file -> do
+    c <- readFileIf file
+    let (fs,t) = envAndTerm file c
+    env' <- shellStateFromFiles noOptions fs
+    let gr   = grammarCEnv env'
+        sgr  = firstStateGrammar env'
+        agrs = allActiveGrammars env'
+        cat  = firstCatOpts (stateOptions sgr) sgr
+    state0 <- err (const $ return (stateSState s)) return $
+                   newCat gr (cfCat2Cat cat) $ stateSState s
+    state1 <- return $ 
+                   refineByExps True gr (parseAny agrs cat t) $ changeState state0 s
+    return (env', state1)
+
+  CCEnvOn  name -> return (languageOn  (language name) env,s)
+  CCEnvOff name -> return (languageOff (language name) env,s)
+-}
+-- this command is improved by the use of IO
+  CRefineRandom -> do
+    g <- newStdGen
+    return (env, action2commandNext (refineRandom g 41 cgr) s)
+
+-- these commands use IO
+  CCEnvRefineWithTree file -> do
+    str <- readFileIf file 
+    execCommand env (CRefineWithTree str) s 
+  CCEnvRefineParse file -> do
+    str <- readFileIf file 
+    execCommand env (CRefineParse str) s 
+
+-- other commands don't need IO; they are available in the fudget
+  c -> return (env, execECommand env c s)
+
+ where
+   gr = grammarCEnv env
+   cgr = canCEnv env
+   opts = globalOptions env
+
+   -- format for documents: import lines of form "-- file", then term 
+   envAndTerm f s = 
+     (map ((initFilePath f ++) . filter (/=' ') . drop 2) fs, unlines ss) where
+       (fs,ss) = span isImport (lines s)
+       isImport l = take 2 l == "--"
+
+
+execECommand :: CEnv -> Command -> ECommand
+execECommand env c = case c of
+  CNewCat cat        -> action2commandNext $ \x -> do
+                          s' <- newCat cgr cat x
+                          uniqueRefinements cgr s'
+{- ----
+  CNewTree s         -> action2commandNext $ \x -> do 
+                          t  <- string2treeErr gr s 
+                          s' <- newTree t x
+                          uniqueRefinements cgr s'
+-}
+  CAhead n           -> action2command (goAheadN n)
+  CBack n            -> action2command (goBackN n)
+  CTop               -> action2command $ return . goRoot
+  CLast              -> action2command $ goLast
+  CNextMeta          -> action2command goNextNewMeta
+  CPrevMeta          -> action2command goPrevNewMeta
+  CRefineWithAtom s  -> action2commandNext $ \x -> do 
+                          t  <- string2ref gr s
+                          s' <- refineWithAtom der cgr t x
+                          uniqueRefinements cgr s'
+  CWrapWithFun fi    -> action2commandNext $ wrapWithFun cgr fi
+  CChangeHead f      -> action2commandNext $ changeFunHead cgr f
+  CPeelHead          -> action2commandNext $ peelFunHead cgr
+{- ----
+  CAlphaConvert s    -> action2commandNext $ \x ->
+                          string2varPair s >>= \xy -> alphaConvert gr xy x
+
+  CRefineWithTree s  -> action2commandNext $ \x -> 
+                          (string2treeErr gr s x >>= \t -> refineWithTree der gr t x)
+
+  CRefineParse str   -> \s -> refineByExps der gr 
+                          (parseAny agrs (cat2CFCat (actCat (stateSState s))) str) s
+-}
+  
+  CRefineRandom -> \s -> action2commandNext
+                              (refineRandom (stdGenCEnv env s) 41 cgr) s 
+
+  CSelectCand i      -> selectCand cgr i
+{- ----
+  CTermCommand c     -> case c of
+                          "paraphrase" -> \s ->
+                             replaceByTermCommand gr c (actExp (stateSState s)) s
+                          "transfer" -> action2commandNext $
+                                        transferSubTree (stateTransferFun sgr) gr
+                          _ -> replaceByEditCommand gr c
+-}
+----  CAddOption o       -> changeStOptions (addOption o)
+----  CRemoveOption o    -> changeStOptions (removeOption o)
+  CDelete            -> action2commandNext $ deleteSubTree cgr
+  CUndo              -> undoCommand
+----  CMenu              -> \s -> changeMsg (menuState env s) s
+  CView              -> changeView
+  CHelp h            -> changeMsg [h env]
+  CVoid              -> id
+  _                  -> changeMsg ["command not yet implemented"]
+ where
+   sgr  = firstStateGrammar env 
+   agrs = [sgr] ---- allActiveGrammars env
+   cgr  = canCEnv env
+   gr   = grammarCEnv env
+   der  = maybe True not $ caseYesNo (globalOptions env) noDepTypes
+          -- if there are dep types, then derived refs;  deptypes is the default
+
+--
+
+
+{- ----
+string2varPair :: String -> Err (I.Ident,I.Ident)
+string2varPair s = case words s of
+  x : y : [] -> liftM2 (,) (string2ident x) (string2ident y)
+  _          -> Bad "expected format 'x y'"
+
+
+-- seen on display
+
+cMenuDisplay :: String -> Command
+cMenuDisplay s = CAddOption (menuDisplay s)
+-}
+newCatMenu env = [(CNewCat c, prQIdent c) | ---- printname env initSState c) | 
+                         (c,[]) <- allCatsOf (canCEnv env)]
+
+mkRefineMenu :: CEnv -> SState -> [(Command,String)]
+mkRefineMenu env sstate = [(c,s) | (c,(s,_)) <- mkRefineMenuAll env sstate]
+
+mkRefineMenuAll :: CEnv -> SState -> [(Command,(String,String))]
+mkRefineMenuAll env sstate = 
+  case (refinementsState cgr state, candsSState sstate, wrappingsState cgr state) of
+    ([],[],wraps) -> 
+       [(CWrapWithFun fi, prWrap fit)     | fit@(fi,_) <- wraps] ++
+       [(CChangeHead f,   prChangeHead f) | f <- headChangesState cgr state] ++
+       [(CPeelHead,     (ifShort "ph" "PeelHead", "ph")) | canPeelState cgr state] ++
+       [(CDelete,       (ifShort "d"  "Delete",   "d"))]
+    (refs,[],_)   -> [(CRefineWithAtom (prRefinement f), prRef t) | t@(f,_) <- refs]
+    (_,cands,_)   -> [(CSelectCand i,   prCand (t,i))    | (t,i) <- zip cands [0..]]
+
+ where
+  prRef  (f,t) = 
+    (ifShort "r" "Refine" +++ prOrLinExp f +++ ifTyped (":" +++ prt t),
+     "r" +++ prRefinement f)
+  prChangeHead f = 
+    (ifShort "ch" "ChangeHead" +++ prOrLinFun f,
+     "ch" +++ prQIdent f)
+  prWrap ((f,i),t) = 
+    (ifShort "w" "Wrap"   +++ prOrLinFun f +++ ifTyped (":" +++ prt t) +++
+     ifShort (show i) (prBracket (show i)),
+     "w" +++ prQIdent f +++ show i)
+  prCand (t,i) = 
+    (ifShort ("s" +++ prOrLinExp t) ("Select" +++ prOrLinExp t),"s" +++ show i)
+
+  gr = grammarCEnv env
+  cgr = canCEnv env
+  state = stateSState sstate
+  opts = addOptions (optsSState sstate) (globalOptions env)
+  ifOpt f v a b = case getOptVal opts f of 
+    Just s | s == v -> a 
+    _ -> b
+  ifShort = ifOpt sizeDisplay "short"
+  ifTyped t = ifOpt typeDisplay "typed" t ""
+  prOrLinExp t = prRefinement t --- maybe (prt t) prOrLinFun $ M.justIdentOf t
+  prOrLinTree t = case getOptVal opts menuDisplay of
+    Just "Abs" -> prt t
+    Just lang -> optLinearizeTreeVal (addOption firstLin opts) 
+                          (stateGrammarOfLang env (language lang)) t
+    _ -> prt t
+  prOrLinFun = printname env sstate
+
+-- there are three orthogonal parameters: Abs/[conc], short/long, typed/untyped
+-- the default is Abs, long, untyped; the Menus menu changes the parameter
+
+emptyMenuItem = (CVoid,("",""))
+
+
+
+---- allStringCommands = snd $ customInfo customStringCommand
+termCommandMenu, stringCommandMenu :: [(Command,String)]
+termCommandMenu = []
+stringCommandMenu = []
+
+displayCommandMenu :: CEnv -> [(Command,String)]
+displayCommandMenu env = []
+{- ----
+---- allTermCommands = snd $ customInfo customEditCommand
+termCommandMenu = [(CTermCommand s, s) | s <- allTermCommands]
+
+stringCommandMenu = 
+   (CAddOption showStruct,      "structured") :
+   (CRemoveOption showStruct,   "unstructured") :
+  [(CAddOption (filterString s), s) | s <- allStringCommands]
+
+displayCommandMenu env = 
+  [(CAddOption (menuDisplay s), s) | s <- "Abs" : langs] ++
+  [(CAddOption (sizeDisplay s), s) | s <- ["short", "long"]] ++
+  [(CAddOption (typeDisplay s), s) | s <- ["typed", "untyped"]]
+ where
+   langs = map prLanguage $ allLanguages env
+
+changeMenuLanguage, changeMenuSize, changeMenuTyped :: String -> Command
+changeMenuLanguage s = CAddOption (menuDisplay s)
+changeMenuSize s     = CAddOption (sizeDisplay s)
+changeMenuTyped s    = CAddOption (typeDisplay s)
+-}
+
+menuState env = map snd . mkRefineMenu env
+
+prState :: State -> [String]
+prState s = prMarkedTree (loc2treeMarked s)
+
+displayJustStateIn env state = case displaySStateIn env state of 
+   (t,msg,_) -> unlines (t ++ ["",""] ++ msg) --- ad hoc for CommandF
+
+displaySStateIn env state = (tree',msg,menu) where
+  (tree,msg,menu) = displaySState env state
+  grs    = allStateGrammars env
+  lang   = (viewSState state) `mod` (length grs + 3)
+  tree'  = (tree : exp : linAll ++ separ (linAll ++ [tree])) !! lang
+  opts   = addOptions (optsSState state) (globalOptions env)  -- state opts override
+  lin g  = linearizeState fudWrap opts g zipper
+  exp    = return $ tree2string $ loc2tree zipper
+  zipper = stateSState state
+  linAll = map lin grs
+  separ  = singleton . map unlines . intersperse [replicate 72 '*']
+
+displaySStateJavaX env state = unlines $ tagXML "gfedit" $ concat [
+  tagXML "linearizations" (concat 
+    [tagAttrXML "lin" ("lang", prLanguage lang) ss | (lang,ss) <- lins]),
+  tagXML "tree"           tree,
+  tagXML "message"        msg,
+  tagXML "menu"           (tagsXML "item" menu')
+  ]
+ where
+  (tree,msg,menu) = displaySState env state
+  menu'  = [tagXML "show" [s] ++ tagXML "send" [c] | (s,c) <- menu] 
+  (ls,grs) = unzip $ lgrs
+  lgrs   = allStateGrammarsWithNames env --- allActiveStateGrammarsWithNames env
+  lins   = (langAbstract, exp) : linAll
+  opts   = addOptions (optsSState state) (globalOptions env)  -- state opts override
+  lin (n,gr) = (n, map uni $ linearizeState noWrap opts gr zipper) where
+                  uni = optEncodeUTF8 n gr . mkUnicode
+  exp    = prprTree $ loc2tree zipper
+---  xml    = prExpXML gr $ tree2exp $ loc2tree zipper --- better: dir. from zipper
+  zipper = stateSState state
+  linAll = map lin lgrs
+  gr     = firstStateGrammar env
+
+langAbstract = language "Abstract"
+langXML      = language "XML"
+
+
+linearizeState :: (String -> [String]) -> Options -> GFGrammar -> State -> [String]
+linearizeState wrap opts gr = 
+ wrap . strop . unt . optLinearizeTreeVal opts gr . loc2tree
+                  --- markedLinString br g
+  where
+   unt   = id ---- customOrDefault (stateOptions g) useUntokenizer customUntokenizer g
+   strop = id ---- maybe id ($ g) $ customAsOptVal opts filterString customStringCommand
+   br    = oElem showStruct opts
+
+noWrap, fudWrap :: String -> [String]
+noWrap = lines
+fudWrap = lines . wrapLines 0 ---
+
+displaySState :: CEnv -> SState -> ([String],[String],[(String,String)])
+displaySState env state = 
+  (prState (stateSState state), msgSState state, menuSState env state)
+
+menuSState :: CEnv -> SState -> [(String,String)]
+menuSState env state = [(s,c) | (_,(s,c)) <- mkRefineMenuAll env state]
+
+printname :: CEnv -> SState -> G.Fun -> String
+printname env state f = case getOptVal opts menuDisplay of
+  Just "Abs" -> prQIdent f
+----  Just lang  -> printn lang f
+  _ -> prQIdent f
+ where
+  opts = addOptions (optsSState state) (globalOptions env)
+  printn lang = linearize gr ---- printOrLinearize (grammarOfLang env (language lang))
+  gr = grammarCEnv env
+
+
+--- XML printing; does not belong here!
+
+tagsXML t = concatMap (tagXML t)
+tagAttrXML t av ss = mkTagAttrXML t av : map (indent 2) ss ++ [mkEndTagXML t]
+tagXML t ss = mkTagXML t : map (indent 2) ss ++ [mkEndTagXML t]
+mkTagXML t = '<':t ++ ">"
+mkEndTagXML t = mkTagXML ('/':t)
+mkTagAttrsXML t avs = '<':t +++ unwords [a++"="++v | (a,v) <- avs] ++">"
+mkTagAttrXML  t av  = mkTagAttrsXML t [av]
+
diff --git a/src/GF/Shell/JGF.hs b/src/GF/Shell/JGF.hs
new file mode 100644
index 000000000..215ad3e3e
--- /dev/null
+++ b/src/GF/Shell/JGF.hs
@@ -0,0 +1,59 @@
+module JGF where
+
+import Operations
+import UseIO
+
+import IOGrammar
+import Option
+import ShellState
+import Session
+import Commands
+import CommandL
+
+import System
+import UTF8
+
+
+-- GF editing session controlled by e.g. a Java program. AR 16/11/2001
+
+sessionLineJ :: ShellState -> IO ()
+sessionLineJ env = do
+  putStrLnFlush $ initEditMsgJavaX env
+  let env' = addGlobalOptions (options [sizeDisplay "short"]) env
+  editLoopJ env' (initSState)
+
+editLoopJ :: CEnv -> SState -> IO ()
+editLoopJ = editLoopJnewX
+
+-- this is the real version, with XML
+
+editLoopJnewX :: CEnv -> SState -> IO ()
+editLoopJnewX env state = do
+  c <- getCommandUTF
+  case c of
+    CQuit -> return ()
+
+    c -> do
+      (env',state') <- execCommand env c state
+      let package = case c of
+            CCEnvImport _         -> initAndEditMsgJavaX env' state'
+            CCEnvEmptyAndImport _ -> initAndEditMsgJavaX env' state'
+            CCEnvOpenTerm _       -> initAndEditMsgJavaX env' state'
+            CCEnvOpenString _     -> initAndEditMsgJavaX env' state'
+            CCEnvEmpty            -> initEditMsgJavaX env'
+            _ -> displaySStateJavaX env' state'
+      putStrLnFlush package
+      editLoopJnewX env' state'
+
+welcome = 
+  "An experimental GF Editor for Java." ++ 
+  "(c) Kristofer Johannisson, Janna Khegai, and Aarne Ranta 2002 under CNU GPL."
+
+initEditMsgJavaX env = encodeUTF8 $ unlines $ tagXML "gfinit" $ 
+  tagsXML "newcat"   [["n" +++ cat]     | (_,cat) <- newCatMenu env] ++
+  tagXML  "language" [prLanguage langAbstract] ++
+  concat [tagAttrXML "language" ("file",file) [prLanguage lang] |
+           (file,lang) <- zip (allGrammarFileNames env) (allLanguages env)]
+
+initAndEditMsgJavaX env state = 
+  initEditMsgJavaX env ++++ displaySStateJavaX env state
diff --git a/src/GF/Shell/PShell.hs b/src/GF/Shell/PShell.hs
new file mode 100644
index 000000000..f28218f27
--- /dev/null
+++ b/src/GF/Shell/PShell.hs
@@ -0,0 +1,115 @@
+module PShell where
+
+import Operations
+import UseIO
+import ShellState
+import Shell
+import Option
+import PGrammar (pzIdent, pTrm) --- (string2formsAndTerm)
+import API
+import Arch(fetchCommand)
+import Char (isDigit)
+
+-- parsing GF shell commands. AR 11/11/2001
+
+-- getting a sequence of command lines as input
+
+getCommandLines :: IO (String,[CommandLine])
+getCommandLines = do
+  s <- fetchCommand "> "
+  return (s,pCommandLines s)
+
+pCommandLines :: String -> [CommandLine]
+pCommandLines = map pCommandLine . concatMap (chunks ";;" . words) . lines
+
+pCommandLine :: [String] -> CommandLine
+pCommandLine s = pFirst (chks s) where
+  pFirst cos = case cos of
+    (c,os,[a]) : cs -> ((c,os), a, pCont cs)
+    _               -> ((CVoid,noOptions), AError "no parse", [])
+  pCont cos = case cos of
+    (c,os,_)   : cs -> (c,os) : pCont cs
+    _               -> []
+  chks = map pCommandOpt . chunks "|"
+
+pCommandOpt :: [String] -> (Command, Options, [CommandArg])
+pCommandOpt (w:ws) = let 
+  (os, co)     = getOptions "-" ws
+  (comm, args) = pCommand (w:co)
+  in
+  (comm, os, args)
+pCommandOpt s = (CVoid, noOptions, [AError "no parse"])
+
+pInputString :: String -> [CommandArg]
+pInputString s = case s of
+  ('"':_:_) -> [AString (init (tail s))]
+  _         -> [AError "illegal string"]
+
+pCommand :: [String] -> (Command, [CommandArg])
+pCommand ws = case ws of
+
+  "i"  : f : [] -> aUnit   (CImport f)
+  "rl" : l : [] -> aUnit   (CRemoveLanguage (language l))
+  "e"  : []     -> aUnit   CEmptyState
+  "tg" : f : [] -> aUnit   (CTransformGrammar f)
+  "cl" : f : [] -> aUnit   (CConvertLatex f)
+
+  "ph" : []     -> aUnit   CPrintHistory
+
+  "l"  : s      -> aTermLi CLinearize s
+
+  "p"  : s      -> aString CParse s
+  "t"  : i:o: s -> aString (CTranslate (language i) (language o)) s
+  "gr" : []     -> aUnit   (CGenerateRandom 1)
+  "gr" : n : [] -> aUnit   (CGenerateRandom (readIntArg n)) -- deprecated 12/5/2001
+  "pt" : s      -> aTerm   CPutTerm s
+-----  "wt" : f : s  -> aTerm   (CWrapTerm (string2id f)) s
+  "ma" : s      -> aString CMorphoAnalyse s
+  "tt" : s      -> aString CTestTokenizer s
+  "cc" : m : s  -> aUnit   $ CComputeConcrete (pzIdent m) $ unwords s
+
+  "tq" : i:o:[] -> aUnit   (CTranslationQuiz (language i) (language o))
+  "tl":i:o:n:[] -> aUnit   (CTranslationList (language i) (language o) (readIntArg n))
+  "mq" : []     -> aUnit   CMorphoQuiz
+  "ml" : n : [] -> aUnit   (CMorphoList (readIntArg n))
+
+  "wf" : f : s  -> aString (CWriteFile f) s
+  "af" : f : s  -> aString (CAppendFile f) s
+  "rf" : f : [] -> aUnit   (CReadFile f)
+  "sa" : s      -> aString CSpeakAloud s
+  "ps" : s      -> aString CPutString s
+  "st" : s      -> aTerm   CShowTerm s
+  "!"  : s      -> aUnit   (CSystemCommand (unwords s))
+  
+  "sf" : l : [] -> aUnit (CSetLocalFlag (language l))
+  "sf" : []     -> aUnit CSetFlag
+
+  "pg" : []     -> aUnit CPrintGrammar
+  "pi" : c : [] -> aUnit $ CPrintInformation (pzIdent c)
+
+  "pj"  : []     -> aUnit CPrintGramlet
+  "pxs" : []     -> aUnit CPrintCanonXMLStruct
+  "px"  : []     -> aUnit CPrintCanonXML
+  "pm"  : []     -> aUnit CPrintMultiGrammar
+  "po"  : []     -> aUnit CPrintGlobalOptions
+  "pl"  : []     -> aUnit CPrintLanguages
+  "h"   : []     -> aUnit CHelp
+
+  "q"  : []     -> aImpure ICQuit
+  "eh" : f : [] -> aImpure (ICExecuteHistory f)
+  n    : [] | all isDigit n -> aImpure (ICEarlierCommand (readIntArg n))
+
+  "es" : []     -> aImpure ICEditSession
+  "ts" : []     -> aImpure ICTranslateSession
+
+  _             -> (CVoid, [])
+
+ where
+   aString c ss = (c, pInputString (unwords ss))
+   aTerm c ss   = (c, [ASTrm $ unwords ss]) ---- [ASTrms [s2t (unwords ss)]])
+   aUnit c      = (c, [AUnit])
+   aImpure      = aUnit . CImpure
+
+   aTermLi c ss = (c [], [ASTrm $ unwords ss])
+   ---- (c forms, [ASTrms [term]]) where
+   ----  (forms,term) = ([], s2t (unwords ss)) ---- string2formsAndTerm (unwords ss)
diff --git a/src/GF/Shell/SubShell.hs b/src/GF/Shell/SubShell.hs
new file mode 100644
index 000000000..c910d3dd0
--- /dev/null
+++ b/src/GF/Shell/SubShell.hs
@@ -0,0 +1,43 @@
+module SubShell where
+
+import Operations
+import UseIO
+import ShellState
+import Option
+import API
+
+import CommandL
+import ArchEdit
+
+-- AR 20/4/2000 -- 12/11/2001
+
+editSession :: Options -> ShellState -> IO ()
+editSession opts st
+  | oElem makeFudget opts = fudlogueEdit font st'
+  | otherwise             = initEditLoop st' (return ())
+ where
+   st'   = addGlobalOptions opts st
+   font  = maybe myUniFont mkOptFont $ getOptVal opts useFont
+
+myUniFont = "-mutt-clearlyu-medium-r-normal--0-0-100-100-p-0-iso10646-1"
+mkOptFont = id
+{- ----
+translateSession :: Options -> ShellState -> IO ()
+translateSession opts st = do
+  let grs   = allStateGrammars st
+      cat   = firstCatOpts opts (firstStateGrammar st)
+      trans = unlines . translateBetweenAll grs cat
+  translateLoop opts trans
+
+translateLoop opts trans = do
+  let fud  = oElem makeFudget opts
+      font = maybe myUniFont mkOptFont $ getOptVal opts useFont
+  if fud then fudlogueWrite font trans else loopLine
+ where
+   loopLine = do
+     putStrFlush "trans> "
+     s <- getLine
+     if s == "." then return () else do
+       putStrLnFlush $ trans s
+       loopLine
+-}
diff --git a/src/GF/Source/AbsGF.hs b/src/GF/Source/AbsGF.hs
new file mode 100644
index 000000000..16d342dd8
--- /dev/null
+++ b/src/GF/Source/AbsGF.hs
@@ -0,0 +1,242 @@
+module AbsGF where
+
+import Ident --H
+
+-- Haskell module generated by the BNF converter, except for --H
+
+-- newtype Ident = Ident String deriving (Eq,Ord,Show) --H
+
+newtype LString = LString String deriving (Eq,Ord,Show)
+
+data Grammar =
+   Gr [ModDef]
+  deriving (Eq,Ord,Show)
+
+data ModDef =
+   MMain Ident Ident [ConcSpec]
+ | MAbstract Ident Extend Opens [TopDef]
+ | MResource Ident Extend Opens [TopDef]
+ | MResourceInt Ident Extend Opens [TopDef]
+ | MResourceImp Ident Ident Opens [TopDef]
+ | MConcrete Ident Ident Extend Opens [TopDef]
+ | MConcreteInt Ident Ident Extend Opens [TopDef]
+ | MConcreteImp Open Ident Ident
+ | MTransfer Ident Open Open Extend Opens [TopDef]
+ | MReuseAbs Ident Ident
+ | MReuseCnc Ident Ident
+ | MReuseAll Ident Extend Ident
+  deriving (Eq,Ord,Show)
+
+data ConcSpec =
+   ConcSpec Ident ConcExp
+  deriving (Eq,Ord,Show)
+
+data ConcExp =
+   ConcExp Ident [Transfer]
+  deriving (Eq,Ord,Show)
+
+data Transfer =
+   TransferIn Open
+ | TransferOut Open
+  deriving (Eq,Ord,Show)
+
+data Extend =
+   Ext Ident
+ | NoExt
+  deriving (Eq,Ord,Show)
+
+data Opens =
+   NoOpens
+ | Opens [Open]
+  deriving (Eq,Ord,Show)
+
+data Open =
+   OName Ident
+ | OQual Ident Ident
+  deriving (Eq,Ord,Show)
+
+data Def =
+   DDecl [Ident] Exp
+ | DDef [Ident] Exp
+ | DPatt Ident [Patt] Exp
+ | DFull [Ident] Exp Exp
+  deriving (Eq,Ord,Show)
+
+data TopDef =
+   DefCat [CatDef]
+ | DefFun [FunDef]
+ | DefDef [Def]
+ | DefData [ParDef]
+ | DefTrans [FlagDef]
+ | DefPar [ParDef]
+ | DefOper [Def]
+ | DefLincat [PrintDef]
+ | DefLindef [Def]
+ | DefLin [Def]
+ | DefPrintCat [PrintDef]
+ | DefPrintFun [PrintDef]
+ | DefFlag [FlagDef]
+ | DefPrintOld [PrintDef]
+ | DefLintype [Def]
+ | DefPattern [Def]
+  deriving (Eq,Ord,Show)
+
+data CatDef =
+   CatDef Ident [DDecl]
+  deriving (Eq,Ord,Show)
+
+data FunDef =
+   FunDef [Ident] Exp
+  deriving (Eq,Ord,Show)
+
+data ParDef =
+   ParDef Ident [ParConstr]
+ | ParDefIndir Ident Ident
+ | ParDefAbs Ident
+  deriving (Eq,Ord,Show)
+
+data ParConstr =
+   ParConstr Ident [DDecl]
+  deriving (Eq,Ord,Show)
+
+data PrintDef =
+   PrintDef [Ident] Exp
+  deriving (Eq,Ord,Show)
+
+data FlagDef =
+   FlagDef Ident Ident
+  deriving (Eq,Ord,Show)
+
+data LocDef =
+   LDDecl [Ident] Exp
+ | LDDef [Ident] Exp
+ | LDFull [Ident] Exp Exp
+  deriving (Eq,Ord,Show)
+
+data Exp =
+   EIdent Ident
+ | EConstr Ident
+ | ECons Ident
+ | ESort Sort
+ | EString String
+ | EInt Integer
+ | EMeta
+ | EEmpty
+ | EStrings String
+ | ERecord [LocDef]
+ | ETuple [TupleComp]
+ | EIndir Ident
+ | ETyped Exp Exp
+ | EProj Exp Label
+ | EQConstr Ident Ident
+ | EQCons Ident Ident
+ | EApp Exp Exp
+ | ETable [Case]
+ | ETTable Exp [Case]
+ | ECase Exp [Case]
+ | EVariants [Exp]
+ | EPre Exp [Altern]
+ | EStrs [Exp]
+ | EConAt Ident Exp
+ | ESelect Exp Exp
+ | ETupTyp Exp Exp
+ | EExtend Exp Exp
+ | EAbstr [Bind] Exp
+ | ECTable [Bind] Exp
+ | EProd Decl Exp
+ | ETType Exp Exp
+ | EConcat Exp Exp
+ | EGlue Exp Exp
+ | ELet [LocDef] Exp
+ | EEqs [Equation]
+ | ELString LString
+ | ELin Ident
+  deriving (Eq,Ord,Show)
+
+data Patt =
+   PW
+ | PV Ident
+ | PCon Ident
+ | PQ Ident Ident
+ | PInt Integer
+ | PStr String
+ | PR [PattAss]
+ | PTup [PattTupleComp]
+ | PC Ident [Patt]
+ | PQC Ident Ident [Patt]
+  deriving (Eq,Ord,Show)
+
+data PattAss =
+   PA [Ident] Patt
+  deriving (Eq,Ord,Show)
+
+data Label =
+   LIdent Ident
+ | LVar Integer
+  deriving (Eq,Ord,Show)
+
+data Sort =
+   Sort_Type
+ | Sort_PType
+ | Sort_Tok
+ | Sort_Str
+ | Sort_Strs
+  deriving (Eq,Ord,Show)
+
+data PattAlt =
+   AltP Patt
+  deriving (Eq,Ord,Show)
+
+data Bind =
+   BIdent Ident
+ | BWild
+  deriving (Eq,Ord,Show)
+
+data Decl =
+   DDec [Bind] Exp
+ | DExp Exp
+  deriving (Eq,Ord,Show)
+
+data TupleComp =
+   TComp Exp
+  deriving (Eq,Ord,Show)
+
+data PattTupleComp =
+   PTComp Patt
+  deriving (Eq,Ord,Show)
+
+data Case =
+   Case [PattAlt] Exp
+  deriving (Eq,Ord,Show)
+
+data Equation =
+   Equ [Patt] Exp
+  deriving (Eq,Ord,Show)
+
+data Altern =
+   Alt Exp Exp
+  deriving (Eq,Ord,Show)
+
+data DDecl =
+   DDDec [Bind] Exp
+ | DDExp Exp
+  deriving (Eq,Ord,Show)
+
+data OldGrammar =
+   OldGr Include [TopDef]
+  deriving (Eq,Ord,Show)
+
+data Include =
+   NoIncl
+ | Incl [FileName]
+  deriving (Eq,Ord,Show)
+
+data FileName =
+   FString String
+ | FIdent Ident
+ | FSlash FileName
+ | FDot FileName
+ | FMinus FileName
+ | FAddId Ident FileName
+  deriving (Eq,Ord,Show)
+
diff --git a/src/GF/Source/CompileM.hs b/src/GF/Source/CompileM.hs
new file mode 100644
index 000000000..3d97a029e
--- /dev/null
+++ b/src/GF/Source/CompileM.hs
@@ -0,0 +1,141 @@
+module CompileM where
+
+import Grammar
+import Ident
+import Option
+import PrGrammar
+import Update
+import Lookup
+import Modules
+---import Rename
+
+import Operations
+import UseIO
+
+import Monad
+
+compileMGrammar :: Options -> SourceGrammar -> IOE SourceGrammar
+compileMGrammar opts sgr = do
+
+  ioeErr $ checkUniqueModuleNames sgr
+
+  deps <- ioeErr $ moduleDeps sgr
+
+  deplist <- either return 
+                 (\ms -> ioeBad $ "circular modules" +++ unwords (map show ms)) $ 
+                 topoTest deps
+
+  let deps' = closureDeps deps
+
+  foldM (compileModule opts deps' sgr) emptyMGrammar deplist
+
+checkUniqueModuleNames :: MGrammar i f a r c -> Err ()
+checkUniqueModuleNames gr = do
+  let ms = map fst $ tree2list $ modules gr
+      msg = checkUnique ms
+  if null msg then return () else Bad $ unlines msg
+
+-- to decide what modules immediately depend on what, and check if the
+-- dependencies are appropriate
+
+moduleDeps :: MGrammar i f a c r -> Err Dependencies
+moduleDeps gr = mapM deps $ tree2list $ modules gr where
+  deps (c,mi) = errIn ("checking dependencies of module" +++ prt c) $ case mi of
+    ModAbs m -> chDep (IdentM c MTAbstract) 
+                      (extends m) MTAbstract (opens m) MTAbstract
+    ModRes m -> chDep (IdentM c MTResource) 
+                      (extends m) MTResource (opens m) MTResource
+    ModCnc m -> do
+      a:ops <- case opens m of
+        os@(_:_) -> return os
+        _ -> Bad "no abstract indicated for concrete module"
+      aty <- lookupModuleType gr a
+      testErr (aty == MTAbstract) "the for-module is not an abstract syntax" 
+      chDep (IdentM c (MTConcrete a)) (extends m) MTResource ops MTResource
+
+  chDep it es ety os oty = do
+    ests <- mapM (lookupModuleType gr) es
+    testErr (all (==ety) ests) "inappropriate extension module type" 
+    osts <- mapM (lookupModuleType gr) os
+    testErr (all (==oty) osts) "inappropriate open module type" 
+    return (it, [IdentM e ety | e <- es] ++ [IdentM o oty | o <- os])
+
+type Dependencies = [(IdentM Ident,[IdentM Ident])]
+
+---compileModule :: Options -> Dependencies -> SourceGrammar -> 
+---                 CanonGrammar -> IdentM -> IOE CanonGrammar
+compileModule opts deps sgr cgr i = do
+  
+   let name = identM i 
+
+   testIfCompiled deps name
+
+   mi <- ioeErr $ lookupModule sgr name
+
+   mi' <- case typeM i of
+     -- previously compiled cgr used as symbol table
+     MTAbstract   -> compileAbstract cgr mi
+     MTResource   -> compileResource cgr mi
+     MTConcrete a -> compileConcrete a cgr mi 
+
+   ifIsOpt doOutput $ writeCanonFile name mi'
+
+   return $ addModule cgr name mi'
+
+ where
+
+   ifIsOpt o f = if (oElem o opts) then f else return ()
+   doOutput    = iOpt "o"
+
+
+testIfCompiled :: Dependencies -> Ident -> IOE Bool
+testIfCompiled _ _ = return False ----
+
+---writeCanonFile :: Ident -> CanonModInfo -> IOE ()
+writeCanonFile name mi' = ioeIO $ writeFile (canonFileName name) [] ----
+
+canonFileName n = n ++ ".gfc" ---- elsewhere!
+
+---compileAbstract :: CanonGrammar -> SourceModInfo -> IOE CanonModInfo
+compileAbstract can (ModAbs m0) = do
+  let m1 = renameMAbstract m0
+{-
+  checkUnique
+  typeCheck
+  generateCode
+  addToCanon
+-}
+  ioeBad "compile abs not yet"
+
+---compileResource :: CanonGrammar -> SourceModInfo -> IOE CanonModInfo
+compileResource can md = do
+{-
+  checkUnique
+  typeCheck
+  topoSort
+  compileOpers -- conservative, since more powerful than lin
+  generateCode
+  addToCanon
+-}
+  ioeBad "compile res not yet"
+
+---compileConcrete :: Ident -> CanonGrammar -> SourceModInfo -> IOE CanonModInfo
+compileConcrete ab can md = do
+{-
+  checkUnique
+  checkComplete ab
+  typeCheck
+  topoSort
+  compileOpers
+  optimize
+  createPreservedOpers
+  generateCode
+  addToCanon
+-}
+  ioeBad "compile cnc not yet"
+
+
+-- to be imported
+
+closureDeps :: [(a,[a])] -> [(a,[a])]
+closureDeps ds = ds ---- fix-point iteration
diff --git a/src/GF/Source/GrammarToSource.hs b/src/GF/Source/GrammarToSource.hs
new file mode 100644
index 000000000..6303bcd99
--- /dev/null
+++ b/src/GF/Source/GrammarToSource.hs
@@ -0,0 +1,181 @@
+module GrammarToSource where
+
+import Operations
+import Grammar
+import Modules
+import Option
+import qualified AbsGF as P
+import Ident
+
+-- AR 13/5/2003
+-- translate internal to parsable and printable source
+
+trGrammar :: SourceGrammar -> P.Grammar
+trGrammar (MGrammar ms) = P.Gr (map trModule ms) -- no includes
+
+trModule :: (Ident,SourceModInfo) -> P.ModDef
+trModule (i,mo) = case mo of
+  ModMod m -> mkModule i' (trExtend (extends m)) (mkOpens (map trOpen (opens m)))
+                 (mkTopDefs (concatMap trAnyDef (tree2list (jments m)) ++ 
+                            (map trFlag (flags m))))
+ where
+   i' = tri i
+   mkModule = case typeOfModule mo of
+     MTResource -> P.MResource
+     MTAbstract -> P.MAbstract
+     MTConcrete a -> P.MConcrete (tri a)
+
+trExtend :: Maybe Ident -> P.Extend
+trExtend i = maybe P.NoExt (P.Ext . tri) i
+
+---- this has to be completed with other mtys
+forName (MTConcrete a) = tri a
+
+trOpen :: OpenSpec Ident -> P.Open
+trOpen o = case o of
+  OSimple i   -> P.OName (tri i)
+  OQualif i j -> P.OQual (tri i) (tri j)
+
+mkOpens ds = if null ds then P.NoOpens else P.Opens ds
+mkTopDefs ds = ds
+
+trAnyDef :: (Ident,Info) -> [P.TopDef]
+trAnyDef (i,info) = let i' = tri i in case info of
+  AbsCat (Yes co) _ -> [P.DefCat [P.CatDef i' (map trDecl co)]]
+  AbsFun (Yes ty) _ -> [P.DefFun [P.FunDef [i'] (trt ty)]]
+  AbsFun (May b)  _ -> [P.DefFun [P.FunDef [i'] (P.EIndir (tri b))]]
+  ---- don't destroy definitions!
+
+  ResOper pty ptr -> [P.DefOper [trDef i' pty ptr]]
+  ResParam pp -> [P.DefPar [case pp of
+    Yes ps -> P.ParDef i' [P.ParConstr (tri c) (map trDecl co) | (c,co) <- ps]
+    May b  -> P.ParDefIndir i' $ tri b
+    _      -> P.ParDefAbs i']]
+
+  CncCat (Yes ty) Nope _ -> 
+    [P.DefLincat [P.PrintDef [i'] (trt ty)]] 
+  CncCat pty ptr ppr -> 
+    [P.DefLindef [trDef i' pty ptr]] 
+    ---- P.DefPrintCat [P.PrintDef i' (trt pr)]]
+  CncFun _ ptr ppr -> 
+    [P.DefLin [trDef i' nope ptr]] 
+    ---- P.DefPrintFun [P.PrintDef i' (trt pr)]]
+  _ -> [] 
+
+trDef :: Ident -> Perh Type -> Perh Term -> P.Def
+trDef i pty ptr = case (pty,ptr) of
+  (Nope,     Nope) -> P.DDef  [i] (P.EMeta) ---
+  (_,        Nope) -> P.DDecl [i] (trPerh pty)
+  (Nope,     _   ) -> P.DDef  [i] (trPerh ptr)
+  (_,        _   ) -> P.DFull [i] (trPerh pty) (trPerh ptr)
+
+trPerh p = case p of
+  Yes t -> trt t
+  May b -> P.EIndir $ tri b
+  _ -> P.EMeta ---
+
+
+trFlag :: Option -> P.TopDef
+trFlag o = case o of
+  Opt (f,[x]) -> P.DefFlag [P.FlagDef (identC f) (identC x)]
+  _ -> P.DefFlag [] --- warning?
+
+trt :: Term -> P.Exp 
+trt trm = case trm of
+    Vr s -> P.EIdent $ tri s
+    Cn s -> P.ECons $ tri s
+    Con s -> P.EConstr $ tri s
+----    ConAt id typ -> P.EConAt (tri id) (trt typ)
+
+    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 -> "fn" +++ prCurlyList [prtBranchOld pst | pst <- pts] ---
+----    ECase e bs -> "case" +++ prt e +++ "of" +++ prCurlyList (map prtBranch bs) 
+
+    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)
+
+    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)
+    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)
+
+    Table x v -> P.ETType (trt x) (trt v)
+    S f x -> P.ESelect  (trt f) (trt x)
+----    Alias c a t -> "{-" +++ prt c +++ "=" +++ "-}" +++ prt t
+--    Alias c a t -> prt (Let (c,(Just a,t)) (Vr c))  -- thus Alias is only internal
+
+    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 $ toInteger i
+
+    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
+    Strs tt -> P.EStrs $ map trt tt
+    _ -> error $ "not yet" +++ show trm ----
+
+trp :: Patt -> P.Patt
+trp p = case p of
+    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]
+----    PT t p -> prt p ---- prParenth (prt p +++ ":" +++ prt t)
+
+
+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 [P.AltP (trp patt)] (trt trm)
+
+trDecl (x,ty) = P.DDDec [trb x] (trt ty)
+
+tri :: Ident -> Ident
+tri i = case prIdent i of
+  s@('_':_:_) -> identC $ 'h':s ---- unsafe; needed since _3 etc are generated 
+  s -> identC $ s
+  
+trb i = if isWildIdent i then P.BWild else P.BIdent (tri i)
+
+trLabel i = case i of
+  LIdent s -> P.LIdent $ identC s
+  LVar i -> P.LVar $ toInteger i
+
+trLabelIdent i = identC $ case i of
+  LIdent s -> s
+  LVar i -> "v" ++ show i --- should not happen
+
diff --git a/src/GF/Source/LexGF.hs b/src/GF/Source/LexGF.hs
new file mode 100644
index 000000000..e9406dd78
--- /dev/null
+++ b/src/GF/Source/LexGF.hs
@@ -0,0 +1,127 @@
+module LexGF where
+
+import Alex
+import ErrM
+
+pTSpec p = PT p . TS    
+
+mk_LString p = PT p . eitherResIdent T_LString 
+
+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
+ | T_LString String
+
+ 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 "let" (B "concrete" (B "Tok" (B "Str" (B "PType" (B "Lin" N N) N) (B "Strs" N N)) (B "case" (B "abstract" (B "Type" N N) N) (B "cat" N N))) (B "fun" (B "flags" (B "def" (B "data" N N) N) (B "fn" N N)) (B "in" (B "grammar" N N) (B "include" N N)))) (B "pattern" (B "of" (B "lindef" (B "lincat" (B "lin" N N) N) (B "lintype" N N)) (B "out" (B "oper" (B "open" N N) N) (B "param" N N))) (B "strs" (B "resource" (B "printname" (B "pre" N N) N) (B "reuse" N N)) (B "transfer" (B "table" 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),("mk_LString",mk_LString),("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__12_0,lx__13_0,lx__14_0,lx__15_0,lx__16_0,lx__17_0,lx__18_0,lx__19_0,lx__20_0,lx__21_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',10),('\n',10),('\v',10),('\f',10),('\r',10),(' ',10),('!',14),('"',18),('$',14),('\'',15),('(',14),(')',14),('*',11),('+',13),(',',14),('-',1),('.',14),('/',14),('0',21),('1',21),('2',21),('3',21),('4',21),('5',21),('6',21),('7',21),('8',21),('9',21),(':',14),(';',14),('<',14),('=',12),('>',14),('?',14),('@',14),('A',17),('B',17),('C',17),('D',17),('E',17),('F',17),('G',17),('H',17),('I',17),('J',17),('K',17),('L',17),('M',17),('N',17),('O',17),('P',17),('Q',17),('R',17),('S',17),('T',17),('U',17),('V',17),('W',17),('X',17),('Y',17),('Z',17),('[',14),('\\',14),(']',14),('_',14),('a',17),('b',17),('c',17),('d',17),('e',17),('f',17),('g',17),('h',17),('i',17),('j',17),('k',17),('l',17),('m',17),('n',17),('o',17),('p',17),('q',17),('r',17),('s',17),('t',17),('u',17),('v',17),('w',17),('x',17),('y',17),('z',17),('{',4),('|',14),('}',14),('\192',17),('\193',17),('\194',17),('\195',17),('\196',17),('\197',17),('\198',17),('\199',17),('\200',17),('\201',17),('\202',17),('\203',17),('\204',17),('\205',17),('\206',17),('\207',17),('\208',17),('\209',17),('\210',17),('\211',17),('\212',17),('\213',17),('\214',17),('\216',17),('\217',17),('\218',17),('\219',17),('\220',17),('\221',17),('\222',17),('\223',17),('\224',17),('\225',17),('\226',17),('\227',17),('\228',17),('\229',17),('\230',17),('\231',17),('\232',17),('\233',17),('\234',17),('\235',17),('\236',17),('\237',17),('\238',17),('\239',17),('\240',17),('\241',17),('\242',17),('\243',17),('\244',17),('\245',17),('\246',17),('\248',17),('\249',17),('\250',17),('\251',17),('\252',17),('\253',17),('\254',17),('\255',17)]))
+lx__1_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__1_0 = (True,[(3,"pTSpec",[],Nothing,Nothing)],-1,(('-','>'),[('-',2),('>',14)]))
+lx__2_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__2_0 = (False,[],2,(('\n','\n'),[('\n',3)]))
+lx__3_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__3_0 = (True,[(0,"",[],Nothing,Nothing)],-1,(('0','0'),[]))
+lx__4_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__4_0 = (True,[(3,"pTSpec",[],Nothing,Nothing)],-1,(('-','-'),[('-',5)]))
+lx__5_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__5_0 = (False,[],5,(('-','-'),[('-',8)]))
+lx__6_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__6_0 = (False,[],5,(('-','}'),[('-',8),('}',7)]))
+lx__7_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__7_0 = (True,[(1,"",[],Nothing,Nothing)],5,(('-','-'),[('-',8)]))
+lx__8_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__8_0 = (False,[],5,(('-','}'),[('-',6),('}',9)]))
+lx__9_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__9_0 = (True,[(1,"",[],Nothing,Nothing)],-1,(('0','0'),[]))
+lx__10_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__10_0 = (True,[(2,"",[],Nothing,Nothing)],-1,(('\t',' '),[('\t',10),('\n',10),('\v',10),('\f',10),('\r',10),(' ',10)]))
+lx__11_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__11_0 = (True,[(3,"pTSpec",[],Nothing,Nothing)],-1,(('*','*'),[('*',14)]))
+lx__12_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__12_0 = (True,[(3,"pTSpec",[],Nothing,Nothing)],-1,(('>','>'),[('>',14)]))
+lx__13_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__13_0 = (True,[(3,"pTSpec",[],Nothing,Nothing)],-1,(('+','+'),[('+',14)]))
+lx__14_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__14_0 = (True,[(3,"pTSpec",[],Nothing,Nothing)],-1,(('0','0'),[]))
+lx__15_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__15_0 = (False,[],15,(('\'','\''),[('\'',16)]))
+lx__16_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__16_0 = (True,[(4,"mk_LString",[],Nothing,Nothing)],15,(('\'','\''),[('\'',16)]))
+lx__17_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__17_0 = (True,[(5,"ident",[],Nothing,Nothing)],-1,(('\'','\255'),[('\'',17),('0',17),('1',17),('2',17),('3',17),('4',17),('5',17),('6',17),('7',17),('8',17),('9',17),('A',17),('B',17),('C',17),('D',17),('E',17),('F',17),('G',17),('H',17),('I',17),('J',17),('K',17),('L',17),('M',17),('N',17),('O',17),('P',17),('Q',17),('R',17),('S',17),('T',17),('U',17),('V',17),('W',17),('X',17),('Y',17),('Z',17),('_',17),('a',17),('b',17),('c',17),('d',17),('e',17),('f',17),('g',17),('h',17),('i',17),('j',17),('k',17),('l',17),('m',17),('n',17),('o',17),('p',17),('q',17),('r',17),('s',17),('t',17),('u',17),('v',17),('w',17),('x',17),('y',17),('z',17),('\192',17),('\193',17),('\194',17),('\195',17),('\196',17),('\197',17),('\198',17),('\199',17),('\200',17),('\201',17),('\202',17),('\203',17),('\204',17),('\205',17),('\206',17),('\207',17),('\208',17),('\209',17),('\210',17),('\211',17),('\212',17),('\213',17),('\214',17),('\216',17),('\217',17),('\218',17),('\219',17),('\220',17),('\221',17),('\222',17),('\223',17),('\224',17),('\225',17),('\226',17),('\227',17),('\228',17),('\229',17),('\230',17),('\231',17),('\232',17),('\233',17),('\234',17),('\235',17),('\236',17),('\237',17),('\238',17),('\239',17),('\240',17),('\241',17),('\242',17),('\243',17),('\244',17),('\245',17),('\246',17),('\248',17),('\249',17),('\250',17),('\251',17),('\252',17),('\253',17),('\254',17),('\255',17)]))
+lx__18_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__18_0 = (False,[],18,(('\n','\\'),[('\n',-1),('"',20),('\\',19)]))
+lx__19_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__19_0 = (False,[],-1,(('"','t'),[('"',18),('\'',18),('\\',18),('n',18),('t',18)]))
+lx__20_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__20_0 = (True,[(6,"string",[],Nothing,Nothing)],-1,(('0','0'),[]))
+lx__21_0 :: (Bool, [(Int,String,[Int],Maybe((Char,Char),[(Char,Bool)]),Maybe Int)], Int, ((Char,Char),[(Char,Int)]))
+lx__21_0 = (True,[(7,"int",[],Nothing,Nothing)],-1,(('0','9'),[('0',21),('1',21),('2',21),('3',21),('4',21),('5',21),('6',21),('7',21),('8',21),('9',21)]))
+
diff --git a/src/GF/Source/PrintGF.hs b/src/GF/Source/PrintGF.hs
new file mode 100644
index 000000000..9d71dfe6e
--- /dev/null
+++ b/src/GF/Source/PrintGF.hs
@@ -0,0 +1,435 @@
+module PrintGF where
+
+-- pretty-printer generated by the BNF converter, except --H
+
+import AbsGF
+import Ident --H
+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
+
+    --H these three are hand-written
+    "{0"     :ts -> cons "{"  $ rend (i+1) ts
+    t :"}0"  :ts -> cons t    $ space "}"  $ rend (i-1) ts
+    t : "."  :ts -> cons t    $ cons "."  $ rend i ts
+
+    "["      :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 -> space t   $ rend i ts
+    _            -> ""
+  cons s t  = s ++ t
+  new i s   = '\n' : replicate (2*i) ' ' ++ dropWhile isSpace s
+  space t s = if null s then t else t ++ " " ++ s
+
+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] --H
+  prtList es = case es of
+   [x] -> (concat [prt 0 x])
+   x:xs -> (concat [prt 0 x , [","] , prt 0 xs])
+
+
+instance Print LString where
+  prt _ (LString i) = [i]
+
+
+
+instance Print Grammar where
+  prt i e = case e of
+   Gr moddefs -> prPrec i 0 (concat [prt 0 moddefs])
+
+
+instance Print ModDef where
+  prt i e = case e of
+   MMain id0 id concspecs -> prPrec i 0 (concat [["grammar"] , prt 0 id0 , ["="] , ["{"] , ["abstract"] , ["="] , prt 0 id , [";"] , prt 0 concspecs , ["}"]])
+   MAbstract id extend opens topdefs -> prPrec i 0 (concat [["abstract"] , prt 0 id , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]])
+   MResource id extend opens topdefs -> prPrec i 0 (concat [["resource"] , prt 0 id , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]])
+   MResourceInt id extend opens topdefs -> prPrec i 0 (concat [["resource"] , ["abstract"] , prt 0 id , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]])
+   MResourceImp id0 id opens topdefs -> prPrec i 0 (concat [["resource"] , prt 0 id0 , ["of"] , prt 0 id , ["="] , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]])
+   MConcrete id0 id extend opens topdefs -> prPrec i 0 (concat [["concrete"] , prt 0 id0 , ["of"] , prt 0 id , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]])
+   MConcreteInt id0 id extend opens topdefs -> prPrec i 0 (concat [["concrete"] , ["abstract"] , ["of"] , prt 0 id0 , ["in"] , prt 0 id , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]])
+   MConcreteImp open id0 id -> prPrec i 0 (concat [["concrete"] , ["of"] , prt 0 open , ["="] , prt 0 id0 , ["**"] , prt 0 id])
+   MTransfer id open0 open extend opens topdefs -> prPrec i 0 (concat [["transfer"] , prt 0 id , [":"] , prt 0 open0 , ["->"] , prt 0 open , ["="] , prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]])
+   MReuseAbs id0 id -> prPrec i 0 (concat [["resource"] , ["abstract"] , prt 0 id0 , ["="] , ["reuse"] , prt 0 id])
+   MReuseCnc id0 id -> prPrec i 0 (concat [["resource"] , ["concrete"] , prt 0 id0 , ["="] , ["reuse"] , prt 0 id])
+   MReuseAll id0 extend id -> prPrec i 0 (concat [["resource"] , prt 0 id0 , ["="] , prt 0 extend , ["reuse"] , prt 0 id])
+
+  prtList es = case es of
+   [] -> (concat [])
+   x:xs -> (concat [prt 0 x , prt 0 xs])
+
+instance Print ConcSpec where
+  prt i e = case e of
+   ConcSpec id concexp -> prPrec i 0 (concat [prt 0 id , ["="] , prt 0 concexp])
+
+  prtList es = case es of
+   [] -> (concat [])
+   [x] -> (concat [prt 0 x])
+   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
+
+instance Print ConcExp where
+  prt i e = case e of
+   ConcExp id transfers -> prPrec i 0 (concat [prt 0 id , prt 0 transfers])
+
+
+instance Print Transfer where
+  prt i e = case e of
+   TransferIn open -> prPrec i 0 (concat [["("] , ["transfer"] , ["in"] , prt 0 open , [")"]])
+   TransferOut open -> prPrec i 0 (concat [["("] , ["transfer"] , ["out"] , prt 0 open , [")"]])
+
+  prtList es = case es of
+   [] -> (concat [])
+   x:xs -> (concat [prt 0 x , prt 0 xs])
+
+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 Opens where
+  prt i e = case e of
+   NoOpens  -> prPrec i 0 (concat [])
+   Opens opens -> prPrec i 0 (concat [["open"] , prt 0 opens , ["in"]])
+
+
+instance Print Open where
+  prt i e = case e of
+   OName id -> prPrec i 0 (concat [prt 0 id])
+   OQual id0 id -> prPrec i 0 (concat [["("] , prt 0 id0 , ["="] , prt 0 id , [")"]])
+
+  prtList es = case es of
+   [] -> (concat [])
+   [x] -> (concat [prt 0 x])
+   x:xs -> (concat [prt 0 x , [","] , prt 0 xs])
+
+instance Print Def where
+  prt i e = case e of
+   DDecl ids exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp])
+   DDef ids exp -> prPrec i 0 (concat [prt 0 ids , ["="] , prt 0 exp])
+   DPatt id patts exp -> prPrec i 0 (concat [prt 0 id , prt 0 patts , ["="] , prt 0 exp])
+   DFull ids exp0 exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp0 , ["="] , prt 0 exp])
+
+  prtList es = case es of
+   [x] -> (concat [prt 0 x , [";"]])
+   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
+
+instance Print TopDef where
+  prt i e = case e of
+   DefCat catdefs -> prPrec i 0 (concat [["cat"] , prt 0 catdefs])
+   DefFun fundefs -> prPrec i 0 (concat [["fun"] , prt 0 fundefs])
+   DefDef defs -> prPrec i 0 (concat [["def"] , prt 0 defs])
+   DefData pardefs -> prPrec i 0 (concat [["data"] , prt 0 pardefs])
+   DefTrans flagdefs -> prPrec i 0 (concat [["transfer"] , prt 0 flagdefs])
+   DefPar pardefs -> prPrec i 0 (concat [["param"] , prt 0 pardefs])
+   DefOper defs -> prPrec i 0 (concat [["oper"] , prt 0 defs])
+   DefLincat printdefs -> prPrec i 0 (concat [["lincat"] , prt 0 printdefs])
+   DefLindef defs -> prPrec i 0 (concat [["lindef"] , prt 0 defs])
+   DefLin defs -> prPrec i 0 (concat [["lin"] , prt 0 defs])
+   DefPrintCat printdefs -> prPrec i 0 (concat [["printname"] , ["cat"] , prt 0 printdefs])
+   DefPrintFun printdefs -> prPrec i 0 (concat [["printname"] , ["fun"] , prt 0 printdefs])
+   DefFlag flagdefs -> prPrec i 0 (concat [["flags"] , prt 0 flagdefs])
+   DefPrintOld printdefs -> prPrec i 0 (concat [["printname"] , prt 0 printdefs])
+   DefLintype defs -> prPrec i 0 (concat [["lintype"] , prt 0 defs])
+   DefPattern defs -> prPrec i 0 (concat [["pattern"] , prt 0 defs])
+
+  prtList es = case es of
+   [] -> (concat [])
+   x:xs -> (concat [prt 0 x , prt 0 xs])
+
+instance Print CatDef where
+  prt i e = case e of
+   CatDef id ddecls -> prPrec i 0 (concat [prt 0 id , prt 0 ddecls])
+
+  prtList es = case es of
+   [x] -> (concat [prt 0 x , [";"]])
+   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
+
+instance Print FunDef where
+  prt i e = case e of
+   FunDef ids exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp])
+
+  prtList es = case es of
+   [x] -> (concat [prt 0 x , [";"]])
+   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
+
+instance Print ParDef where
+  prt i e = case e of
+   ParDef id parconstrs -> prPrec i 0 (concat [prt 0 id , ["="] , prt 0 parconstrs])
+   ParDefIndir id0 id -> prPrec i 0 (concat [prt 0 id0 , ["="] , ["("] , ["in"] , prt 0 id , [")"]])
+   ParDefAbs id -> prPrec i 0 (concat [prt 0 id])
+
+  prtList es = case es of
+   [x] -> (concat [prt 0 x , [";"]])
+   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
+
+instance Print ParConstr where
+  prt i e = case e of
+   ParConstr id ddecls -> prPrec i 0 (concat [prt 0 id , prt 0 ddecls])
+
+  prtList es = case es of
+   [] -> (concat [])
+   [x] -> (concat [prt 0 x])
+   x:xs -> (concat [prt 0 x , ["|"] , prt 0 xs])
+
+instance Print PrintDef where
+  prt i e = case e of
+   PrintDef ids exp -> prPrec i 0 (concat [prt 0 ids , ["="] , prt 0 exp])
+
+  prtList es = case es of
+   [x] -> (concat [prt 0 x , [";"]])
+   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
+
+instance Print FlagDef where
+  prt i e = case e of
+   FlagDef id0 id -> prPrec i 0 (concat [prt 0 id0 , ["="] , prt 0 id])
+
+  prtList es = case es of
+   [x] -> (concat [prt 0 x , [";"]])
+   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
+
+instance Print LocDef where
+  prt i e = case e of
+   LDDecl ids exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp])
+   LDDef ids exp -> prPrec i 0 (concat [prt 0 ids , ["="] , prt 0 exp])
+   LDFull ids exp0 exp -> prPrec i 0 (concat [prt 0 ids , [":"] , prt 0 exp0 , ["="] , 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 Exp where
+  prt i e = case e of
+   EIdent id -> prPrec i 4 (concat [prt 0 id])
+   EConstr id -> prPrec i 4 (concat [["{0"] , prt 0 id , ["}0"]]) --H
+   ECons id -> prPrec i 4 (concat [["["] , prt 0 id , ["]"]])
+   ESort sort -> prPrec i 4 (concat [prt 0 sort])
+   EString str -> prPrec i 4 (concat [prt 0 str])
+   EInt n -> prPrec i 4 (concat [prt 0 n])
+   EMeta  -> prPrec i 4 (concat [["?"]])
+   EEmpty  -> prPrec i 4 (concat [["["] , ["]"]])
+   EStrings str -> prPrec i 4 (concat [["["] , prt 0 str , ["]"]])
+   ERecord locdefs -> prPrec i 4 (concat [["{"] , prt 0 locdefs , ["}"]])
+   ETuple tuplecomps -> prPrec i 4 (concat [["<"] , prt 0 tuplecomps , [">"]])
+   EIndir id -> prPrec i 4 (concat [["("] , ["in"] , prt 0 id , [")"]])
+   ETyped exp0 exp -> prPrec i 4 (concat [["<"] , prt 0 exp0 , [":"] , prt 0 exp , [">"]])
+   EProj exp label -> prPrec i 3 (concat [prt 3 exp , ["."] , prt 0 label])
+   EQConstr id0 id -> prPrec i 3 (concat [["{0"] , prt 0 id0 , ["."] , prt 0 id , ["}0"]]) --H
+   EQCons id0 id -> prPrec i 3 (concat [["["] , prt 0 id0 , ["."] , prt 0 id , ["]"]])
+   EApp exp0 exp -> prPrec i 2 (concat [prt 2 exp0 , prt 3 exp])
+   ETable cases -> prPrec i 2 (concat [["table"] , ["{"] , prt 0 cases , ["}"]])
+   ETTable exp cases -> prPrec i 2 (concat [["table"] , prt 4 exp , ["{"] , prt 0 cases , ["}"]])
+   ECase exp cases -> prPrec i 2 (concat [["case"] , prt 0 exp , ["of"] , ["{"] , prt 0 cases , ["}"]])
+   EVariants exps -> prPrec i 2 (concat [["variants"] , ["{"] , prt 0 exps , ["}"]])
+   EPre exp alterns -> prPrec i 2 (concat [["pre"] , ["{"] , prt 0 exp , [";"] , prt 0 alterns , ["}"]])
+   EStrs exps -> prPrec i 2 (concat [["strs"] , ["{"] , prt 0 exps , ["}"]])
+   EConAt id exp -> prPrec i 2 (concat [prt 0 id , ["@"] , prt 4 exp])
+   ESelect exp0 exp -> prPrec i 1 (concat [prt 1 exp0 , ["!"] , prt 2 exp])
+   ETupTyp exp0 exp -> prPrec i 1 (concat [prt 1 exp0 , ["*"] , prt 2 exp])
+   EExtend exp0 exp -> prPrec i 1 (concat [prt 1 exp0 , ["**"] , prt 2 exp])
+   EAbstr binds exp -> prPrec i 0 (concat [["\\"] , prt 0 binds , ["->"] , prt 0 exp])
+   ECTable binds exp -> prPrec i 0 (concat [["\\"] , ["\\"] , prt 0 binds , ["=>"] , prt 0 exp])
+   EProd decl exp -> prPrec i 0 (concat [prt 0 decl , ["->"] , prt 0 exp])
+   ETType exp0 exp -> prPrec i 0 (concat [prt 1 exp0 , ["=>"] , prt 0 exp])
+   EConcat exp0 exp -> prPrec i 0 (concat [prt 1 exp0 , ["++"] , prt 0 exp])
+   EGlue exp0 exp -> prPrec i 0 (concat [prt 1 exp0 , ["+"] , prt 0 exp])
+   ELet locdefs exp -> prPrec i 0 (concat [["let"] , ["{"] , prt 0 locdefs , ["}"] , ["in"] , prt 0 exp])
+   EEqs equations -> prPrec i 0 (concat [["fn"] , ["{"] , prt 0 equations , ["}"]])
+   ELString lstring -> prPrec i 4 (concat [prt 0 lstring])
+   ELin id -> prPrec i 2 (concat [["Lin"] , prt 0 id])
+
+  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
+   PW  -> prPrec i 1 (concat [["_"]])
+   PV id -> prPrec i 1 (concat [prt 0 id])
+   PCon id -> prPrec i 1 (concat [["{0"] , prt 0 id , ["}0"]]) --H
+   PQ id0 id -> prPrec i 1 (concat [prt 0 id0 , ["."] , prt 0 id])
+   PInt n -> prPrec i 1 (concat [prt 0 n])
+   PStr str -> prPrec i 1 (concat [prt 0 str])
+   PR pattasss -> prPrec i 1 (concat [["{"] , prt 0 pattasss , ["}"]])
+   PTup patttuplecomps -> prPrec i 1 (concat [["<"] , prt 0 patttuplecomps , [">"]])
+   PC id patts -> prPrec i 0 (concat [prt 0 id , prt 0 patts])
+   PQC id0 id patts -> prPrec i 0 (concat [prt 0 id0 , ["."] , prt 0 id , prt 0 patts])
+
+  prtList es = case es of
+   [x] -> (concat [prt 1 x])
+   x:xs -> (concat [prt 1 x , prt 0 xs])
+
+instance Print PattAss where
+  prt i e = case e of
+   PA ids patt -> prPrec i 0 (concat [prt 0 ids , ["="] , prt 0 patt])
+
+  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
+   LIdent id -> prPrec i 0 (concat [prt 0 id])
+   LVar n -> prPrec i 0 (concat [["$"] , prt 0 n])
+
+
+instance Print Sort where
+  prt i e = case e of
+   Sort_Type  -> prPrec i 0 (concat [["Type"]])
+   Sort_PType  -> prPrec i 0 (concat [["PType"]])
+   Sort_Tok  -> prPrec i 0 (concat [["Tok"]])
+   Sort_Str  -> prPrec i 0 (concat [["Str"]])
+   Sort_Strs  -> prPrec i 0 (concat [["Strs"]])
+
+
+instance Print PattAlt where
+  prt i e = case e of
+   AltP patt -> prPrec i 0 (concat [prt 0 patt])
+
+  prtList es = case es of
+   [x] -> (concat [prt 0 x])
+   x:xs -> (concat [prt 0 x , ["|"] , prt 0 xs])
+
+instance Print Bind where
+  prt i e = case e of
+   BIdent id -> prPrec i 0 (concat [prt 0 id])
+   BWild  -> prPrec i 0 (concat [["_"]])
+
+  prtList es = case es of
+   [] -> (concat [])
+   [x] -> (concat [prt 0 x])
+   x:xs -> (concat [prt 0 x , [","] , prt 0 xs])
+
+instance Print Decl where
+  prt i e = case e of
+   DDec binds exp -> prPrec i 0 (concat [["("] , prt 0 binds , [":"] , prt 0 exp , [")"]])
+   DExp exp -> prPrec i 0 (concat [prt 2 exp])
+
+
+instance Print TupleComp where
+  prt i e = case e of
+   TComp exp -> prPrec i 0 (concat [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 PattTupleComp where
+  prt i e = case e of
+   PTComp patt -> prPrec i 0 (concat [prt 0 patt])
+
+  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
+   Case pattalts exp -> prPrec i 0 (concat [prt 0 pattalts , ["=>"] , prt 0 exp])
+
+  prtList es = case es of
+   [x] -> (concat [prt 0 x])
+   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
+
+instance Print Equation where
+  prt i e = case e of
+   Equ patts exp -> prPrec i 0 (concat [prt 0 patts , ["->"] , 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 Altern where
+  prt i e = case e of
+   Alt exp0 exp -> prPrec i 0 (concat [prt 0 exp0 , ["/"] , 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 DDecl where
+  prt i e = case e of
+   DDDec binds exp -> prPrec i 0 (concat [["("] , prt 0 binds , [":"] , prt 0 exp , [")"]])
+   DDExp exp -> prPrec i 0 (concat [prt 4 exp])
+
+  prtList es = case es of
+   [] -> (concat [])
+   x:xs -> (concat [prt 0 x , prt 0 xs])
+
+instance Print OldGrammar where
+  prt i e = case e of
+   OldGr include topdefs -> prPrec i 0 (concat [prt 0 include , prt 0 topdefs])
+
+
+instance Print Include where
+  prt i e = case e of
+   NoIncl  -> prPrec i 0 (concat [])
+   Incl filenames -> prPrec i 0 (concat [["include"] , prt 0 filenames])
+
+
+instance Print FileName where
+  prt i e = case e of
+   FString str -> prPrec i 0 (concat [prt 0 str])
+   FIdent id -> prPrec i 0 (concat [prt 0 id])
+   FSlash filename -> prPrec i 0 (concat [["/"] , prt 0 filename])
+   FDot filename -> prPrec i 0 (concat [["."] , prt 0 filename])
+   FMinus filename -> prPrec i 0 (concat [["-"] , prt 0 filename])
+   FAddId id filename -> prPrec i 0 (concat [prt 0 id , prt 0 filename])
+
+  prtList es = case es of
+   [x] -> (concat [prt 0 x , [";"]])
+   x:xs -> (concat [prt 0 x , [";"] , prt 0 xs])
+
+
diff --git a/src/GF/Source/SkelGF.hs b/src/GF/Source/SkelGF.hs
new file mode 100644
index 000000000..cf0932a87
--- /dev/null
+++ b/src/GF/Source/SkelGF.hs
@@ -0,0 +1,289 @@
+module SkelGF where
+
+-- Haskell module generated by the BNF converter
+
+import AbsGF
+import Ident
+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
+
+
+transLString :: LString -> Result
+transLString x = case x of
+  LString str  -> failure x
+
+
+transGrammar :: Grammar -> Result
+transGrammar x = case x of
+  Gr moddefs  -> failure x
+
+
+transModDef :: ModDef -> Result
+transModDef x = case x of
+  MMain id0 id concspecs  -> failure x
+  MAbstract id extend opens topdefs  -> failure x
+  MResource id extend opens topdefs  -> failure x
+  MResourceInt id extend opens topdefs  -> failure x
+  MResourceImp id0 id opens topdefs  -> failure x
+  MConcrete id0 id extend opens topdefs  -> failure x
+  MConcreteInt id0 id extend opens topdefs  -> failure x
+  MConcreteImp open id0 id  -> failure x
+  MTransfer id open0 open extend opens topdefs  -> failure x
+  MReuseAbs id0 id  -> failure x
+  MReuseCnc id0 id  -> failure x
+  MReuseAll id0 extend id  -> failure x
+
+
+transConcSpec :: ConcSpec -> Result
+transConcSpec x = case x of
+  ConcSpec id concexp  -> failure x
+
+
+transConcExp :: ConcExp -> Result
+transConcExp x = case x of
+  ConcExp id transfers  -> failure x
+
+
+transTransfer :: Transfer -> Result
+transTransfer x = case x of
+  TransferIn open  -> failure x
+  TransferOut open  -> failure x
+
+
+transExtend :: Extend -> Result
+transExtend x = case x of
+  Ext id  -> failure x
+  NoExt  -> failure x
+
+
+transOpens :: Opens -> Result
+transOpens x = case x of
+  NoOpens  -> failure x
+  Opens opens  -> failure x
+
+
+transOpen :: Open -> Result
+transOpen x = case x of
+  OName id  -> failure x
+  OQual id0 id  -> failure x
+
+
+transDef :: Def -> Result
+transDef x = case x of
+  DDecl ids exp  -> failure x
+  DDef ids exp  -> failure x
+  DPatt id patts exp  -> failure x
+  DFull ids exp0 exp  -> failure x
+
+
+transTopDef :: TopDef -> Result
+transTopDef x = case x of
+  DefCat catdefs  -> failure x
+  DefFun fundefs  -> failure x
+  DefDef defs  -> failure x
+  DefData pardefs  -> failure x
+  DefTrans flagdefs  -> failure x
+  DefPar pardefs  -> failure x
+  DefOper defs  -> failure x
+  DefLincat printdefs  -> failure x
+  DefLindef defs  -> failure x
+  DefLin defs  -> failure x
+  DefPrintCat printdefs  -> failure x
+  DefPrintFun printdefs  -> failure x
+  DefFlag flagdefs  -> failure x
+  DefPrintOld printdefs  -> failure x
+  DefLintype defs  -> failure x
+  DefPattern defs  -> failure x
+
+
+transCatDef :: CatDef -> Result
+transCatDef x = case x of
+  CatDef id ddecls  -> failure x
+
+
+transFunDef :: FunDef -> Result
+transFunDef x = case x of
+  FunDef ids exp  -> failure x
+
+
+transParDef :: ParDef -> Result
+transParDef x = case x of
+  ParDef id parconstrs  -> failure x
+  ParDefIndir id0 id  -> failure x
+  ParDefAbs id  -> failure x
+
+
+transParConstr :: ParConstr -> Result
+transParConstr x = case x of
+  ParConstr id ddecls  -> failure x
+
+
+transPrintDef :: PrintDef -> Result
+transPrintDef x = case x of
+  PrintDef ids exp  -> failure x
+
+
+transFlagDef :: FlagDef -> Result
+transFlagDef x = case x of
+  FlagDef id0 id  -> failure x
+
+
+transLocDef :: LocDef -> Result
+transLocDef x = case x of
+  LDDecl ids exp  -> failure x
+  LDDef ids exp  -> failure x
+  LDFull ids exp0 exp  -> failure x
+
+
+transExp :: Exp -> Result
+transExp x = case x of
+  EIdent id  -> failure x
+  EConstr id  -> failure x
+  ECons id  -> failure x
+  ESort sort  -> failure x
+  EString str  -> failure x
+  EInt n  -> failure x
+  EMeta  -> failure x
+  EEmpty  -> failure x
+  EStrings str  -> failure x
+  ERecord locdefs  -> failure x
+  ETuple tuplecomps  -> failure x
+  EIndir id  -> failure x
+  ETyped exp0 exp  -> failure x
+  EProj exp label  -> failure x
+  EQConstr id0 id  -> failure x
+  EQCons id0 id  -> failure x
+  EApp exp0 exp  -> failure x
+  ETable cases  -> failure x
+  ETTable exp cases  -> failure x
+  ECase exp cases  -> failure x
+  EVariants exps  -> failure x
+  EPre exp alterns  -> failure x
+  EStrs exps  -> failure x
+  EConAt id exp  -> failure x
+  ESelect exp0 exp  -> failure x
+  ETupTyp exp0 exp  -> failure x
+  EExtend exp0 exp  -> failure x
+  EAbstr binds exp  -> failure x
+  ECTable binds exp  -> failure x
+  EProd decl exp  -> failure x
+  ETType exp0 exp  -> failure x
+  EConcat exp0 exp  -> failure x
+  EGlue exp0 exp  -> failure x
+  ELet locdefs exp  -> failure x
+  EEqs equations  -> failure x
+  ELString lstring  -> failure x
+  ELin id  -> failure x
+
+
+transPatt :: Patt -> Result
+transPatt x = case x of
+  PW  -> failure x
+  PV id  -> failure x
+  PCon id  -> failure x
+  PQ id0 id  -> failure x
+  PInt n  -> failure x
+  PStr str  -> failure x
+  PR pattasss  -> failure x
+  PTup patttuplecomps  -> failure x
+  PC id patts  -> failure x
+  PQC id0 id patts  -> failure x
+
+
+transPattAss :: PattAss -> Result
+transPattAss x = case x of
+  PA ids patt  -> failure x
+
+
+transLabel :: Label -> Result
+transLabel x = case x of
+  LIdent id  -> failure x
+  LVar n  -> failure x
+
+
+transSort :: Sort -> Result
+transSort x = case x of
+  Sort_Type  -> failure x
+  Sort_PType  -> failure x
+  Sort_Tok  -> failure x
+  Sort_Str  -> failure x
+  Sort_Strs  -> failure x
+
+
+transPattAlt :: PattAlt -> Result
+transPattAlt x = case x of
+  AltP patt  -> failure x
+
+
+transBind :: Bind -> Result
+transBind x = case x of
+  BIdent id  -> failure x
+  BWild  -> failure x
+
+
+transDecl :: Decl -> Result
+transDecl x = case x of
+  DDec binds exp  -> failure x
+  DExp exp  -> failure x
+
+
+transTupleComp :: TupleComp -> Result
+transTupleComp x = case x of
+  TComp exp  -> failure x
+
+
+transPattTupleComp :: PattTupleComp -> Result
+transPattTupleComp x = case x of
+  PTComp patt  -> failure x
+
+
+transCase :: Case -> Result
+transCase x = case x of
+  Case pattalts exp  -> failure x
+
+
+transEquation :: Equation -> Result
+transEquation x = case x of
+  Equ patts exp  -> failure x
+
+
+transAltern :: Altern -> Result
+transAltern x = case x of
+  Alt exp0 exp  -> failure x
+
+
+transDDecl :: DDecl -> Result
+transDDecl x = case x of
+  DDDec binds exp  -> failure x
+  DDExp exp  -> failure x
+
+
+transOldGrammar :: OldGrammar -> Result
+transOldGrammar x = case x of
+  OldGr include topdefs  -> failure x
+
+
+transInclude :: Include -> Result
+transInclude x = case x of
+  NoIncl  -> failure x
+  Incl filenames  -> failure x
+
+
+transFileName :: FileName -> Result
+transFileName x = case x of
+  FString str  -> failure x
+  FIdent id  -> failure x
+  FSlash filename  -> failure x
+  FDot filename  -> failure x
+  FMinus filename  -> failure x
+  FAddId id filename  -> failure x
+
+
+
diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs
new file mode 100644
index 000000000..f9e098e08
--- /dev/null
+++ b/src/GF/Source/SourceToGrammar.hs
@@ -0,0 +1,505 @@
+module SourceToGrammar where
+
+import qualified Grammar as G
+import qualified PrGrammar as GP
+import qualified Modules as GM
+import qualified Macros as M
+import qualified Update as U
+import qualified Option as GO
+import qualified ModDeps as GD
+import Ident
+import AbsGF
+import PrintGF
+import RemoveLiT --- for bw compat
+import Operations
+
+import Monad
+import Char
+
+-- based on the skeleton Haskell module generated by the BNF converter
+
+type Result = Err String
+
+failure :: Show a => a -> Err b
+failure x = Bad $ "Undefined case: " ++ show x
+
+transIdent :: Ident -> Err Ident
+transIdent x = case x of
+  x  -> return x
+
+transGrammar :: Grammar -> Err G.SourceGrammar
+transGrammar x = case x of
+  Gr moddefs  -> do
+    moddefs' <- mapM transModDef moddefs
+    GD.mkSourceGrammar moddefs'
+
+transModDef :: ModDef -> Err (Ident, G.SourceModInfo)
+transModDef x = case x of
+  MMain id0 id concspecs  -> do
+    id0' <- transIdent id0
+    id'  <- transIdent id
+    concspecs' <- mapM transConcSpec concspecs
+    return $ (id0', GM.ModMainGrammar (GM.MainGrammar id' concspecs'))
+  MAbstract id extends opens defs  -> do
+    id'      <- transIdent id
+    extends' <- transExtend extends
+    opens'   <- transOpens opens
+    defs0    <- mapM transAbsDef $ getTopDefs defs
+    defs'    <- U.buildAnyTree [d | Left  ds <- defs0, d <- ds]
+    flags    <- return       [f | Right fs <- defs0, f <- fs]
+    return $ (id', GM.ModMod (GM.Module GM.MTAbstract flags extends' opens' defs')) 
+  MResource id extends opens defs  -> do
+    id'      <- transIdent id
+    extends' <- transExtend extends
+    opens'   <- transOpens opens
+    defs0    <- mapM transResDef $ getTopDefs defs
+    defs'    <- U.buildAnyTree [d | Left  ds <- defs0, d <- ds]
+    flags    <- return       [f | Right fs <- defs0, f <- fs]
+    return $ (id', GM.ModMod (GM.Module GM.MTResource flags extends' opens' defs')) 
+  MConcrete id open extends opens defs -> do
+    id'      <- transIdent id
+    open'    <- transIdent open
+    extends' <- transExtend extends
+    opens'   <- transOpens opens
+    defs0    <- mapM transCncDef $ getTopDefs defs
+    defs'    <- U.buildAnyTree [d | Left  ds <- defs0, d <- ds]
+    flags    <- return       [f | Right fs <- defs0, f <- fs]
+    return $ (id', 
+      GM.ModMod (GM.Module (GM.MTConcrete open') flags extends' opens' defs'))
+  MTransfer id open0 open extends opens defs -> do
+    id'      <- transIdent id
+    open0'   <- transOpen open0
+    open'    <- transOpen open
+    extends' <- transExtend extends
+    opens'   <- transOpens opens
+    defs0    <- mapM transAbsDef $ getTopDefs defs
+    defs'    <- U.buildAnyTree [d | Left  ds <- defs0, d <- ds]
+    flags    <- return       [f | Right fs <- defs0, f <- fs]
+    return $ (id', 
+     GM.ModMod (GM.Module (GM.MTTransfer open0' open') flags extends' opens' defs'))
+
+  MReuseAbs id0 id  -> failure x
+  MReuseCnc id0 id  -> failure x
+  MReuseAll r e c  -> do
+    r' <- transIdent r
+    e' <- transExtend e
+    c' <- transIdent c
+    return $ (r', GM.ModMod (GM.Module (GM.MTReuse c') [] e' [] NT)) 
+
+getTopDefs :: [TopDef] -> [TopDef]
+getTopDefs x = x
+
+transConcSpec :: ConcSpec -> Err (GM.MainConcreteSpec Ident)
+transConcSpec x = case x of
+  ConcSpec id concexp  -> do
+    id' <- transIdent id
+    (m,mi,mo) <- transConcExp concexp
+    return $ GM.MainConcreteSpec id' m mi mo
+
+transConcExp :: ConcExp -> 
+       Err (Ident, Maybe (GM.OpenSpec Ident),Maybe (GM.OpenSpec Ident))
+transConcExp x = case x of
+  ConcExp id transfers  -> do
+    id' <- transIdent id
+    trs <- mapM transTransfer transfers
+    tin <- case [o | Left o <- trs] of
+      [o] -> return $ Just o
+      []  -> return $ Nothing
+      _   -> Bad "ambiguous transfer in"
+    tout <- case [o | Right o <- trs] of
+      [o] -> return $ Just o
+      []  -> return $ Nothing
+      _   -> Bad "ambiguous transfer out"
+    return (id',tin,tout)
+
+transTransfer :: Transfer -> 
+                 Err (Either (GM.OpenSpec Ident)(GM.OpenSpec Ident))
+transTransfer x = case x of
+  TransferIn open  -> liftM Left  $ transOpen open
+  TransferOut open -> liftM Right $ transOpen open
+
+transExtend :: Extend -> Err (Maybe Ident)
+transExtend x = case x of
+  Ext id  -> transIdent id >>= return . Just
+  NoExt -> return Nothing
+
+transOpens :: Opens -> Err [GM.OpenSpec Ident]
+transOpens x = case x of
+  NoOpens  -> return []
+  Opens opens  -> mapM transOpen opens
+
+transOpen :: Open -> Err (GM.OpenSpec Ident)
+transOpen x = case x of
+  OName id   -> liftM  GM.OSimple $ transIdent id
+  OQual id m -> liftM2 GM.OQualif (transIdent id) (transIdent m)
+
+transAbsDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option])
+transAbsDef x = case x of
+  DefCat catdefs -> do
+    catdefs' <- mapM transCatDef catdefs
+    returnl [(cat, G.AbsCat (yes cont) nope) | (cat,cont) <- catdefs']
+  DefFun fundefs -> do
+    fundefs' <- mapM transFunDef fundefs
+    returnl [(fun, G.AbsFun (yes typ) nope) | (funs,typ) <- fundefs', fun <- funs]
+  DefDef defs  -> do
+    defs' <- liftM concat $ mapM getDefsGen defs
+    returnl [(c, G.AbsFun nope pe) | (c,(_,pe)) <- defs']
+  DefData _ -> returnl [] ----
+  DefTrans defs  -> do
+    let (ids,vals) = unzip [(i,v) | FlagDef i v <- defs]
+    defs' <- liftM2 zip (mapM transIdent ids) (mapM transIdent vals)
+    returnl [(c, G.AbsTrans f) | (c,f) <- defs']
+  DefFlag defs -> liftM Right $ mapM transFlagDef defs
+  _ -> Bad $ "illegal definition in abstract module:" ++++ printTree x
+
+returnl :: a -> Err (Either a b)
+returnl = return . Left
+
+transFlagDef :: FlagDef -> Err GO.Option
+transFlagDef x = case x of
+  FlagDef f x  -> return $ GO.Opt (prIdent f,[prIdent x])
+
+transCatDef :: CatDef -> Err (Ident, G.Context)
+transCatDef x = case x of
+  CatDef id ddecls  -> liftM2 (,) (transIdent id) 
+                                  (mapM transDDecl ddecls >>= return . concat)
+
+transFunDef :: FunDef -> Err ([Ident], G.Type)
+transFunDef x = case x of
+  FunDef ids typ  -> liftM2 (,) (mapM transIdent ids) (transExp typ)
+
+transResDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option])
+transResDef x = case x of
+  DefPar pardefs -> do
+    pardefs' <- mapM transParDef pardefs
+    returnl $ [(p, G.ResParam (if null pars 
+                                  then nope -- abstract param type 
+                                  else (yes pars))) | (p,pars) <- pardefs']
+           ++ [(f, G.ResValue (yes (M.mkProdSimple co (G.Cn p)))) |
+                     (p,pars) <- pardefs', (f,co) <- pars]
+  DefOper defs -> do
+    defs' <- liftM concat $ mapM getDefs defs
+    returnl [(f, G.ResOper pt pe) | (f,(pt,pe)) <- defs']
+
+  DefLintype defs -> do
+    defs' <- liftM concat $ mapM getDefs defs
+    returnl [(f, G.ResOper pt pe) | (f,(pt,pe)) <- defs']
+
+  DefFlag defs -> liftM Right $ mapM transFlagDef defs
+  _ -> Bad $ "illegal definition form in resource" +++ printTree x
+
+transParDef :: ParDef -> Err (Ident, [G.Param])
+transParDef x = case x of
+  ParDef id params  -> liftM2 (,) (transIdent id) (mapM transParConstr params)
+  ParDefAbs id -> liftM2 (,) (transIdent id) (return [])
+  _ -> Bad $ "illegal definition in resource:" ++++ printTree x
+
+transCncDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option])
+transCncDef x = case x of
+  DefLincat defs  -> do
+    defs' <- liftM concat $ mapM transPrintDef defs
+    returnl [(f, G.CncCat (yes t) nope nope) | (f,t) <- defs']
+  DefLindef defs  -> do
+    defs' <- liftM concat $ mapM getDefs defs
+    returnl [(f, G.CncCat pt pe nope) | (f,(pt,pe)) <- defs']
+  DefLin defs  -> do
+    defs' <- liftM concat $ mapM getDefs defs
+    returnl [(f, G.CncFun Nothing pe nope) | (f,(_,pe)) <- defs']
+  DefPrintCat defs -> do
+    defs' <- liftM concat $ mapM transPrintDef defs
+    returnl [(f, G.CncCat nope nope (yes e)) | (f,e) <- defs']    
+  DefPrintFun defs -> do
+    defs' <- liftM concat $ mapM transPrintDef defs
+    returnl [(f, G.CncFun Nothing nope (yes e)) | (f,e) <- defs']
+  DefPrintOld defs -> do  -- a guess, for backward compatibility
+    defs' <- liftM concat $ mapM transPrintDef defs
+    returnl [(f, G.CncFun Nothing nope (yes e)) | (f,e) <- defs']    
+  DefFlag defs -> liftM Right $ mapM transFlagDef defs
+  DefPattern defs  -> do
+    defs' <- liftM concat $ mapM getDefs defs
+    let defs2 = [(f, termInPattern t) | (f,(_,Yes t)) <- defs']
+    returnl [(f, G.CncFun Nothing (yes t) nope) | (f,t) <- defs2]
+
+  _ -> Bad $ "illegal definition in concrete syntax:" ++++ printTree x
+
+transPrintDef :: PrintDef -> Err [(Ident,G.Term)]
+transPrintDef x = case x of
+  PrintDef id exp  -> do
+    (ids,e) <- liftM2 (,) (mapM transIdent id) (transExp exp)
+    return $ [(i,e) | i <- ids]
+
+getDefsGen :: Def -> Err [(Ident, (G.Perh G.Type, G.Perh G.Term))]
+getDefsGen d = case d of
+  DDecl ids t -> do
+    ids' <- mapM transIdent ids
+    t'   <- transExp t
+    return [(i,(yes t', nope)) | i <- ids']
+  DDef ids e -> do
+    ids' <- mapM transIdent ids
+    e'   <- transExp e
+    return [(i,(nope, yes e')) | i <- ids']
+  DFull ids t e -> do
+    ids' <- mapM transIdent ids
+    t'   <- transExp t
+    e'   <- transExp e
+    return [(i,(yes t', yes e')) | i <- ids']
+  DPatt id patts e  -> do
+    id' <- transIdent id
+    ps' <- mapM transPatt patts
+    e'  <- transExp e
+    return [(id',(nope, yes (G.Eqs [(ps',e')])))]
+
+-- sometimes you need this special case, e.g. in linearization rules
+getDefs :: Def -> Err [(Ident, (G.Perh G.Type, G.Perh G.Term))]
+getDefs d = case d of
+  DPatt id patts e  -> do
+    id' <- transIdent id
+    xs  <- mapM tryMakeVar patts
+    e'  <- transExp e
+    return [(id',(nope, yes (M.mkAbs xs e')))]
+  _ -> getDefsGen d
+
+-- accepts a pattern that is either a variable or a wild card
+tryMakeVar :: Patt -> Err Ident
+tryMakeVar p = do
+  p' <- transPatt p
+  case p' of
+    G.PV i -> return i
+    G.PW   -> return identW
+    _ -> Bad $ "not a legal pattern in lambda binding" +++ GP.prt p'
+
+transExp :: Exp -> Err G.Term
+transExp x = case x of
+  EIdent id     -> liftM G.Vr $ transIdent id
+  EConstr id    -> liftM G.Con $ transIdent id
+  ECons id      -> liftM G.Cn $ transIdent id
+  EQConstr m c  -> liftM2 G.QC (transIdent m) (transIdent c)
+  EQCons m c    -> liftM2 G.Q  (transIdent m) (transIdent c)
+  EString str   -> return $ G.K str 
+  ESort sort    -> liftM G.Sort $ transSort sort
+  EInt n        -> return $ G.EInt $ fromInteger n
+  EMeta         -> return $ M.meta $ M.int2meta 0
+  EEmpty        -> return G.Empty
+  EStrings []   -> return G.Empty
+  EStrings str  -> return $ foldr1 G.C $ map G.K $ words str
+  ERecord defs  -> erecord2term defs
+  ETupTyp _ _   -> do
+    let tups t = case t of
+          ETupTyp x y -> tups x ++ [y] -- right-associative parsing
+          _ -> [t]
+    es <- mapM transExp $ tups x
+    return $ G.RecType $ M.tuple2recordType es
+  ETuple tuplecomps  -> do
+    es <- mapM transExp [e | TComp e <- tuplecomps]
+    return $ G.R $ M.tuple2record es
+  EProj exp id  -> liftM2 G.P (transExp exp) (trLabel id)
+  EApp exp0 exp  -> liftM2 G.App (transExp exp0) (transExp exp)
+  ETable cases  -> liftM (G.T G.TRaw) (transCases cases)
+  ETTable exp cases -> 
+    liftM2 (\t c -> G.T (G.TTyped t) c) (transExp exp) (transCases cases)
+  ECase exp cases  -> do
+    exp' <- transExp exp
+    cases' <- transCases cases
+    return $ G.S (G.T G.TRaw cases') exp'
+  ECTable binds exp  -> liftM2 M.mkCTable (mapM transBind binds) (transExp exp)
+
+  EVariants exps    -> liftM G.FV $ mapM transExp exps
+  EPre exp alts     -> liftM2 (curry G.Alts) (transExp exp) (mapM transAltern alts)
+  EStrs exps        -> liftM G.Strs $ mapM transExp exps
+  ESelect exp0 exp  -> liftM2 G.S (transExp exp0) (transExp exp)
+  EExtend exp0 exp  -> liftM2 G.ExtR (transExp exp0) (transExp exp)
+  EAbstr binds exp  -> liftM2 M.mkAbs (mapM transBind binds) (transExp exp)
+  ETyped exp0 exp   -> liftM2 G.Typed (transExp exp0) (transExp exp)
+
+  EProd decl exp    -> liftM2 M.mkProdSimple (transDecl decl) (transExp exp)
+  ETType exp0 exp   -> liftM2 G.Table (transExp exp0) (transExp exp)
+  EConcat exp0 exp  -> liftM2 G.C (transExp exp0) (transExp exp)
+  EGlue exp0 exp    -> liftM2 G.Glue (transExp exp0) (transExp exp)
+  ELet defs exp  -> do
+    exp'  <- transExp exp
+    defs0 <- mapM locdef2fields defs
+    defs' <- mapM tryLoc $ concat defs0
+    return $ M.mkLet defs' exp'
+   where
+     tryLoc (c,(mty,Just e)) = return (c,(mty,e))
+     tryLoc (c,_) = Bad $ "local definition of" +++ GP.prt c +++ "without value"
+
+  ELString (LString str) -> return $ G.K str 
+  ELin id -> liftM G.LiT $ transIdent id
+
+  _ -> Bad $ "translation not yet defined for" +++ printTree x ----
+
+--- this is complicated: should we change Exp or G.Term ?
+ 
+erecord2term :: [LocDef] -> Err G.Term
+erecord2term ds = do
+  ds' <- mapM locdef2fields ds 
+  mkR $ concat ds'
+ where
+  mkR fs = do 
+    fs' <- transF fs
+    return $ case fs' of
+      Left ts  -> G.RecType ts
+      Right ds -> G.R ds
+  transF [] = return $ Left [] --- empty record always interpreted as record type
+  transF fs@(f:_) = case f of
+    (lab,(Just ty,Nothing)) -> mapM tryRT fs >>= return . Left
+    _ -> mapM tryR fs >>= return . Right
+  tryRT f = case f of
+    (lab,(Just ty,Nothing)) -> return (M.ident2label lab,ty)
+    _ -> Bad $ "illegal record type field" +++ GP.prt (fst f) --- manifest fields ?!
+  tryR f = case f of
+    (lab,(mty, Just t)) -> return (M.ident2label lab,(mty,t))
+    _ -> Bad $ "illegal record field" +++ GP.prt (fst f)
+
+  
+locdef2fields d = case d of
+    LDDecl ids t -> do
+      labs <- mapM transIdent ids
+      t'   <- transExp t
+      return [(lab,(Just t',Nothing)) | lab <- labs]
+    LDDef ids e -> do
+      labs <- mapM transIdent ids
+      e'   <- transExp e
+      return [(lab,(Nothing, Just e')) | lab <- labs]
+    LDFull ids t e -> do
+      labs <- mapM transIdent ids
+      t'   <- transExp t
+      e'   <- transExp e
+      return [(lab,(Just t', Just e')) | lab <- labs]
+
+trLabel :: Label -> Err G.Label
+trLabel x = case x of
+
+  -- this case is for bward compatibiity and should be removed
+  LIdent (IC ('v':ds)) | all isDigit ds -> return $ G.LVar $ readIntArg ds 
+  
+  LIdent (IC s) -> return $ G.LIdent s
+  LVar x   -> return $ G.LVar $ fromInteger x
+
+transSort :: Sort -> Err String
+transSort x = case x of
+  _ -> return $ printTree x
+
+transPatt :: Patt -> Err G.Patt
+transPatt x = case x of
+  PW  -> return G.wildPatt
+  PV id  -> liftM G.PV $ transIdent id
+  PC id patts  -> liftM2 G.PC (transIdent id) (mapM transPatt patts)
+  PCon id  -> liftM2 G.PC (transIdent id) (return [])
+  PInt n  -> return $ G.PInt (fromInteger n)
+  PStr str  -> return $ G.PString str
+  PR pattasss -> do
+    let (lss,ps) = unzip [(ls,p) | PA ls p <- pattasss]
+        ls = map LIdent $ concat lss
+    liftM G.PR $ liftM2 zip (mapM trLabel ls) (mapM transPatt ps)
+  PTup pcs -> 
+    liftM (G.PR . M.tuple2recordPatt) (mapM transPatt [e | PTComp e <- pcs])
+  PQ id0 id  -> liftM3 G.PP (transIdent id0) (transIdent id) (return [])
+  PQC id0 id patts  -> 
+    liftM3 G.PP (transIdent id0) (transIdent id) (mapM transPatt patts)
+
+transBind :: Bind -> Err Ident
+transBind x = case x of
+  BIdent id  -> transIdent id
+  BWild  -> return identW
+
+transDecl :: Decl -> Err [G.Decl]
+transDecl x = case x of
+  DDec binds exp  -> do
+    xs   <- mapM transBind binds
+    exp' <- transExp exp
+    return [(x,exp') | x <- xs]
+  DExp exp  -> liftM (return . M.mkDecl) $ transExp exp
+
+transCases :: [Case] -> Err [G.Case]
+transCases = liftM concat . mapM transCase
+
+transCase :: Case -> Err [G.Case]
+transCase (Case pattalts exp) = do
+  patts <- mapM transPatt [p | AltP p <- pattalts]
+  exp'  <- transExp exp  
+  return [(p,exp') | p <- patts]
+
+transAltern :: Altern -> Err (G.Term, G.Term)
+transAltern x = case x of
+  Alt exp0 exp  -> liftM2 (,) (transExp exp0) (transExp exp)
+
+transParConstr :: ParConstr -> Err G.Param
+transParConstr x = case x of
+  ParConstr id ddecls  -> do
+    id' <- transIdent id
+    ddecls' <- mapM transDDecl ddecls
+    return (id',concat ddecls')
+
+transDDecl :: DDecl -> Err [G.Decl]
+transDDecl x = case x of
+  DDDec binds exp  -> transDecl $ DDec binds exp
+  DDExp exp  ->  transDecl $ DExp exp
+
+-- to deal with the old format, sort judgements in three modules, forming
+-- their names from a given string, e.g. file name or overriding user-given string
+
+transOldGrammar :: OldGrammar -> String -> Err G.SourceGrammar
+transOldGrammar x name = case x of
+  OldGr includes topdefs  -> do --- includes must be collected separately
+    let moddefs = sortTopDefs topdefs
+    g1 <- transGrammar $ Gr moddefs
+    removeLiT g1 --- needed for bw compatibility with an obsolete feature
+ where
+   sortTopDefs ds = [mkAbs a,mkRes r,mkCnc c] 
+     where (a,r,c) = foldr srt ([],[],[]) ds
+   srt d (a,r,c) = case d of
+     DefCat catdefs  -> (d:a,r,c)
+     DefFun fundefs  -> (d:a,r,c)
+     DefDef defs     -> (d:a,r,c)
+     DefData pardefs -> (d:a,r,c)
+     DefPar pardefs  -> (a,d:r,c)
+     DefOper defs    -> (a,d:r,c)
+     DefLintype defs -> (a,d:r,c)
+     DefLincat defs  -> (a,r,d:c)
+     DefLindef defs  -> (a,r,d:c)
+     DefLin defs     -> (a,r,d:c)
+     DefPattern defs -> (a,r,d:c)
+     DefFlag defs    -> (a,r,d:c) --- a guess
+     DefPrintCat printdefs  -> (a,r,d:c)
+     DefPrintFun printdefs  -> (a,r,d:c)
+     DefPrintOld printdefs  -> (a,r,d:c)
+   mkAbs a = MAbstract absName NoExt (Opens []) $ topDefs a
+   mkRes r = MResource resName NoExt (Opens []) $ topDefs r
+   mkCnc r = MConcrete cncName absName NoExt (Opens [OName resName]) $ topDefs r
+   topDefs t = t
+
+   absName = identC topic
+   resName = identC ("Res" ++ lang)
+   cncName = identC lang
+
+   (beg,rest) = span (/='.') name
+   (topic,lang) = case rest of -- to avoid overwriting old files
+     ".gf" -> ("Abs" ++ beg,"Cnc" ++ beg)
+     []    -> ("Abs" ++ beg,"Cnc" ++ beg)
+     _:s   -> (beg, takeWhile (/='.') s)
+
+transInclude :: Include -> Err [FilePath]
+transInclude x = case x of
+  NoIncl -> return []
+  Incl filenames  -> return $ map trans filenames
+ where
+   trans f = case f of
+     FString s  -> s
+     FIdent (IC s) -> s
+     FSlash filename  -> '/' : trans filename
+     FDot filename  -> '.' : trans filename
+     FMinus filename  -> '-' : trans filename
+     FAddId (IC s) filename  -> s ++ trans filename
+
+termInPattern :: G.Term -> G.Term
+termInPattern t = M.mkAbs xx $ G.R [(s, (Nothing, toP body))] where
+  toP t = case t of
+    G.Vr x -> G.P t s
+    _ -> M.composSafeOp toP t
+  s = G.LIdent "s"
+  (xx,body) = abss [] t
+  abss xs t = case t of
+    G.Abs x b -> abss (x:xs) b
+    _ -> (reverse xs,t)
diff --git a/src/GF/Source/TestGF.hs b/src/GF/Source/TestGF.hs
new file mode 100644
index 000000000..f1c8e49a1
--- /dev/null
+++ b/src/GF/Source/TestGF.hs
@@ -0,0 +1,22 @@
+-- automatically generated by BNF Converter
+module TestGF where 
+
+import LexGF
+import ParGF
+import SkelGF
+import PrintGF
+import AbsGF
+import ErrM
+
+type ParseFun a = [Token] -> Err a
+
+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 (myLexer 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/System/Arch.hs b/src/GF/System/Arch.hs
new file mode 100644
index 000000000..5fb963fec
--- /dev/null
+++ b/src/GF/System/Arch.hs
@@ -0,0 +1,71 @@
+module Arch (
+ myStdGen, prCPU, selectLater, modifiedFiles, ModTime, getModTime,getNowTime,
+ welcomeArch, fetchCommand) where
+
+import Time
+import Random
+import CPUTime
+import Monad (filterM)
+import Directory
+import Readline
+
+---- import qualified UnicodeF as U --(fudlogueWrite)
+
+-- architecture/compiler dependent definitions for unix/hbc
+
+myStdGen :: Int -> IO StdGen ---
+--- myStdGen _ = newStdGen --- gives always the same result
+myStdGen int0 = do
+  t0  <- getClockTime 
+  cal <- toCalendarTime t0 
+  let int = int0 + ctSec cal + fromInteger (div (ctPicosec cal) 10000000)
+  return $ mkStdGen int
+
+prCPU cpu = do 
+  cpu' <- getCPUTime
+  putStrLn (show ((cpu' - cpu) `div` 1000000000) ++ " msec")
+  return cpu'
+
+welcomeArch = "This is the system compiled with ghc."
+
+fetchCommand :: String -> IO (String)
+fetchCommand s = do
+  res <- readline s
+  case res of
+   Nothing -> return "q"
+   Just s -> do addHistory s
+                return s
+
+-- selects the one with the later modification time of two
+
+selectLater :: FilePath -> FilePath -> IO FilePath
+selectLater x y = do
+  ex <- doesFileExist x
+  if not ex 
+    then return y --- which may not exist
+    else do
+      ey <- doesFileExist y
+      if not ey 
+        then return x
+        else do 
+          tx <- getModificationTime x
+          ty <- getModificationTime y
+          return $ if tx < ty then y else x
+
+-- a file is considered as modified also if it has not been read yet
+
+modifiedFiles :: [(FilePath,ModTime)] -> [FilePath] -> IO [FilePath]
+modifiedFiles ofs fs = print (map fst ofs) >> filterM isModified fs where
+  isModified file = case lookup file ofs of
+    Just to -> do
+      t <- getModTime file
+      return $ to < t
+    _ -> return True
+
+type ModTime = ClockTime
+
+getModTime :: FilePath -> IO ModTime
+getModTime = getModificationTime
+
+getNowTime :: IO ModTime
+getNowTime = getClockTime
diff --git a/src/GF/Text/Arabic.hs b/src/GF/Text/Arabic.hs
new file mode 100644
index 000000000..6df79c4a9
--- /dev/null
+++ b/src/GF/Text/Arabic.hs
@@ -0,0 +1,48 @@
+module Arabic where
+
+mkArabic :: String -> String
+mkArabic = reverse . unwords . (map mkArabicWord) . words
+--- reverse : assumes everything's on same line
+
+type ArabicChar = Char
+
+mkArabicWord :: String -> [ArabicChar]
+mkArabicWord = map mkArabicChar . getLetterPos
+
+getLetterPos :: String -> [(Char,Int)]
+getLetterPos []     = []
+getLetterPos ('I':cs)  = ('*',7) : getLetterPos cs           -- 0xfe80
+getLetterPos ('O':cs)  = ('*',8) : getIn cs                  -- 0xfe8b
+getLetterPos ('l':'a':cs) = ('*',5) : getLetterPos cs        -- 0xfefb
+getLetterPos [c]    = [(c,1)]                                -- 1=isolated
+getLetterPos (c:cs) | isReduced c = (c,1) : getLetterPos cs
+getLetterPos (c:cs) = (c,3) : getIn cs                       -- 3=initial
+
+  
+getIn []     = []
+getIn ('I':cs)  = ('*',7) : getLetterPos cs                -- 0xfe80
+getIn ('O':cs)  = ('*',9) : getIn cs                       -- 0xfe8c
+getIn ('l':'a':cs) = ('*',6) : getLetterPos cs             -- 0xfefc
+getIn [c]    = [(c,2)]                                     -- 2=final
+getIn (c:cs) | isReduced c = (c,2) : getLetterPos cs
+getIn (c:cs) = (c,4) : getIn cs                            -- 4=medial
+
+isReduced :: Char -> Bool
+isReduced c = c `elem` "UuWiYOaAdVrzwj"
+
+mkArabicChar ('*',p) | p > 4 && p < 10 = 
+  (map toEnum [0xfefb,0xfefc,0xfe80,0xfe8b,0xfe8c]) !! (p-5)  
+mkArabicChar cp@(c,p) = case lookup c cc of Just c' -> (c' !! (p-1)) ; _ -> c 
+ where 
+   cc = mkArabicTab allArabicCodes allArabic
+
+mkArabicTab (c:cs) as = (c,as1) : mkArabicTab cs as2 where
+  (as1,as2) = if isReduced c then splitAt 2 as else splitAt 4 as
+mkArabicTab [] _ = []
+
+allArabicCodes = "UuWiYOabAtvgHCdVrzscSDTZoxfqklmnhwjy" 
+
+allArabic :: String
+allArabic = (map toEnum [0xfe81 .. 0xfef4]) -- I=0xfe80
+
+
diff --git a/src/GF/Text/Greek.hs b/src/GF/Text/Greek.hs
new file mode 100644
index 000000000..8cbba8c54
--- /dev/null
+++ b/src/GF/Text/Greek.hs
@@ -0,0 +1,158 @@
+module Greek where
+
+mkGreek :: String -> String
+mkGreek = unwords . (map mkGreekWord) . mkGravis . words
+
+--- TODO : optimize character formation by factorizing the case expressions
+
+type GreekChar = Char
+
+mkGreekWord :: String -> [GreekChar]
+mkGreekWord = map (toEnum . mkGreekChar) . mkGreekSpec
+
+mkGravis :: [String] -> [String]
+mkGravis [] = []
+mkGravis [w] = [w]
+mkGravis (w1:w2:ws)
+ | stressed w2 = mkG w1 : mkGravis (w2:ws)
+ | otherwise = w1 : w2 : mkGravis ws
+  where
+    stressed w = any (`elem`  "'~`") w
+    mkG :: String -> String
+    mkG w = let (w1,w2) = span (/='\'') w in
+               case w2 of
+                 '\'':v:cs | not (any isVowel cs) -> w1 ++ "`" ++ [v] ++ cs
+                 '\'':'!':v:cs | not (any isVowel cs) -> w1 ++ "`!" ++ [v] ++ cs
+                 _ -> w
+    isVowel c = elem c "aehiouw"
+
+mkGreekSpec :: String -> [(Char,Int)]
+mkGreekSpec str = case str of
+  [] -> []
+  '(' :'\'': '!' : c : cs -> (c,25)  : mkGreekSpec cs
+  '(' :'~' : '!' : c : cs -> (c,27)  : mkGreekSpec cs
+  '(' :'`' : '!' : c : cs -> (c,23)  : mkGreekSpec cs
+  '(' :      '!' : c : cs -> (c,21)  : mkGreekSpec cs
+  ')' :'\'': '!' : c : cs -> (c,24)  : mkGreekSpec cs
+  ')' :'~' : '!' : c : cs -> (c,26)  : mkGreekSpec cs
+  ')' :'`' : '!' : c : cs -> (c,22)  : mkGreekSpec cs
+  ')' :      '!' : c : cs -> (c,20)  : mkGreekSpec cs
+  '\'':      '!' : c : cs -> (c,30)  : mkGreekSpec cs
+  '~' :      '!' : c : cs -> (c,31)  : mkGreekSpec cs
+  '`' :      '!' : c : cs -> (c,32)  : mkGreekSpec cs
+  '!' :            c : cs -> (c,33)  : mkGreekSpec cs
+  '(' :'\'': c : cs -> (c,5)  : mkGreekSpec cs
+  '(' :'~' : c : cs -> (c,7)  : mkGreekSpec cs
+  '(' :'`' : c : cs -> (c,3)  : mkGreekSpec cs
+  '(' :      c : cs -> (c,1)  : mkGreekSpec cs
+  ')' :'\'': c : cs -> (c,4)  : mkGreekSpec cs
+  ')' :'~' : c : cs -> (c,6)  : mkGreekSpec cs
+  ')' :'`' : c : cs -> (c,2)  : mkGreekSpec cs
+  ')' :      c : cs -> (c,0)  : mkGreekSpec cs
+  '\'':      c : cs -> (c,10) : mkGreekSpec cs
+  '~' :      c : cs -> (c,11) : mkGreekSpec cs
+  '`' :      c : cs -> (c,12) : mkGreekSpec cs
+  c   :          cs -> (c,-1) : mkGreekSpec cs
+
+mkGreekChar (c,-1) = case lookup c cc of Just c' -> c' ; _ -> fromEnum c 
+ where 
+   cc = zip "abgdezhqiklmnxoprjstyfcuw" allGreekMin
+mkGreekChar (c,n) = case (c,n) of
+  ('a',10)        -> 0x03ac 
+  ('a',11)        -> 0x1fb6
+  ('a',12)        -> 0x1f70
+  ('a',30)        -> 0x1fb4
+  ('a',31)        -> 0x1fb7
+  ('a',32)        -> 0x1fb2
+  ('a',33)        -> 0x1fb3
+  ('a',n) | n >19 -> 0x1f80 + n - 20
+  ('a',n)         -> 0x1f00 + n
+  ('e',10)        -> 0x03ad    -- ' 
+--  ('e',11)        -> 0x1fb6    -- ~ can't happen
+  ('e',12)        -> 0x1f72    -- `
+  ('e',n)         -> 0x1f10 + n
+  ('h',10)        -> 0x03ae    -- ' 
+  ('h',11)        -> 0x1fc6    -- ~
+  ('h',12)        -> 0x1f74    -- `
+
+  ('h',30)        -> 0x1fc4
+  ('h',31)        -> 0x1fc7
+  ('h',32)        -> 0x1fc2
+  ('h',33)        -> 0x1fc3
+  ('h',n) | n >19 -> 0x1f90 + n - 20
+
+  ('h',n)         -> 0x1f20 + n
+  ('i',10)        -> 0x03af    -- ' 
+  ('i',11)        -> 0x1fd6    -- ~
+  ('i',12)        -> 0x1f76    -- `
+  ('i',n)         -> 0x1f30 + n
+  ('o',10)        -> 0x03cc    -- ' 
+--  ('o',11)        -> 0x1fb6    -- ~ can't happen
+  ('o',12)        -> 0x1f78    -- `
+  ('o',n)         -> 0x1f40 + n
+  ('y',10)        -> 0x03cd    -- ' 
+  ('y',11)        -> 0x1fe6    -- ~
+  ('y',12)        -> 0x1f7a    -- `
+  ('y',n)         -> 0x1f50 + n
+  ('w',10)        -> 0x03ce    -- ' 
+  ('w',11)        -> 0x1ff6    -- ~
+  ('w',12)        -> 0x1f7c    -- `
+
+  ('w',30)        -> 0x1ff4
+  ('w',31)        -> 0x1ff7
+  ('w',32)        -> 0x1ff2
+  ('w',33)        -> 0x1ff3
+  ('w',n) | n >19 -> 0x1fa0 + n - 20
+
+  ('w',n)         -> 0x1f60 + n
+  ('r',1)         -> 0x1fe5
+  _               -> mkGreekChar (c,-1) --- should not happen
+
+allGreekMin :: [Int]
+allGreekMin = [0x03b1 .. 0x03c9]
+
+
+{-
+encoding of Greek writing. Those hard to guess are marked with ---
+
+               maj   min
+A a Alpha     0391  03b1  
+B b Beta      0392  03b2
+G g Gamma     0393  03b3
+D d Delta     0394  03b4
+E e Epsilon   0395  03b5
+Z z Zeta      0396  03b6
+H h Eta ---   0397  03b7
+Q q Theta --- 0398  03b8
+I i Iota      0399  03b9
+K k Kappa     039a  03ba
+L l Lambda    039b  03bb
+M m My        039c  03bc
+N n Ny        039d  03bd
+X x Xi        039e  03be
+O o Omikron   039f  03bf
+P p Pi        03a0  03c0
+R r Rho       03a1  03c1
+  j Sigma ---       03c2
+S s Sigma     03a3  03c3
+T t Tau       03a4  03c4
+Y y Ypsilon   03a5  03c5
+F f Phi       03a6  03c6
+C c Khi ---   03a7  03c7
+U u Psi       03a8  03c8
+W w Omega --- 03a9  03c9
+
+( spiritus asper
+) spiritus lenis
+! iota subscriptum
+
+' acutus
+~ circumflexus
+` gravis
+
+-}
+
+
+
+
+
diff --git a/src/GF/Text/Hebrew.hs b/src/GF/Text/Hebrew.hs
new file mode 100644
index 000000000..ebcc078e3
--- /dev/null
+++ b/src/GF/Text/Hebrew.hs
@@ -0,0 +1,21 @@
+module Hebrew where
+
+mkHebrew :: String -> String
+mkHebrew = reverse . unwords . (map mkHebrewWord) . words
+--- reverse : assumes everything's on same line
+
+type HebrewChar = Char
+
+mkHebrewWord :: String -> [HebrewChar]
+mkHebrewWord = map mkHebrewChar
+
+mkHebrewChar c = case lookup c cc of Just c' -> c' ; _ -> c 
+ where 
+   cc = zip allHebrewCodes allHebrew
+
+allHebrewCodes = "-abgdhwzHTyKklMmNnSoPpCcqrst"
+
+allHebrew :: String
+allHebrew = (map toEnum (0x05be : [0x05d0 .. 0x05ea]))
+
+
diff --git a/src/GF/Text/Russian.hs b/src/GF/Text/Russian.hs
new file mode 100644
index 000000000..07605a83a
--- /dev/null
+++ b/src/GF/Text/Russian.hs
@@ -0,0 +1,31 @@
+module Russian where
+
+-- an ad hoc ASCII encoding. Delimiters: /_ _/
+mkRussian :: String -> String
+mkRussian = unwords . (map mkRussianWord) . words
+
+-- the KOI8 encoding, incomplete. Delimiters: /* */
+mkRusKOI8 :: String -> String
+mkRusKOI8 = unwords . (map mkRussianKOI8) . words
+
+type RussianChar = Char
+
+mkRussianWord :: String -> [RussianChar]
+mkRussianWord = map (mkRussianChar allRussianCodes)
+
+mkRussianKOI8 :: String -> [RussianChar]
+mkRussianKOI8 = map (mkRussianChar allRussianKOI8)
+
+mkRussianChar chars c = case lookup c cc of Just c' -> c' ; _ -> c 
+ where 
+   cc = zip chars allRussian
+
+allRussianCodes = 
+ "ÅåABVGDEXZIJKLMNOPRSTUFHCQW£}!*ÖYÄabvgdexzijklmnoprstufhcqw#01'öyä"
+allRussianKOI8 =
+ "^@áâ÷çäåöúéêëìíîïðòóôõæèãþûýøùÿüàñÁÂ×ÇÄÅÖÚÉÊËÌÍÎÏÐÒÓÔÕÆÈÃÞÛÝØÙßÜÀÑ"
+
+allRussian :: String
+allRussian = (map toEnum (0x0401:0x0451:[0x0410 .. 0x044f])) -- Ëë in odd places
+
+
diff --git a/src/GF/Text/Text.hs b/src/GF/Text/Text.hs
new file mode 100644
index 000000000..08e897a9b
--- /dev/null
+++ b/src/GF/Text/Text.hs
@@ -0,0 +1,56 @@
+module Text where
+
+import Operations
+import Char
+
+-- elementary text postprocessing. AR 21/11/2001
+-- This is very primitive indeed. The functions should work on
+-- token lists and not on strings. AR 5/12/2002
+
+
+formatAsTextLit :: String -> String
+formatAsTextLit = formatAsText . unwords . map unStringLit . words 
+--- hope that there will be deforestation...
+
+formatAsCodeLit :: String -> String
+formatAsCodeLit = formatAsCode . unwords . map unStringLit . words 
+
+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 singleton ".!?") 
+  minor = flip elem (map singleton ",:;")
+  para  = (=="<p>") 
+
+formatAsCode :: String -> String
+formatAsCode = unwords . format . words where
+  format ws = case ws of
+    p : w : ww | parB p -> format ((p ++ w') : ww') where (w':ww') = format (w:ww)
+    w : p : ww | par  p -> format ((w ++ p') : ww') where (p':ww') = format (p:ww)
+    w     : ww           -> w        : format ww
+    [] -> []
+  parB = flip elem (map singleton "([{")
+  parE = flip elem (map singleton "}])")
+  par t = parB t || parE t
+
+performBinds :: String -> String
+performBinds = unwords . format . words where
+  format ws = case ws of
+    w : "&+" : u : ws -> format ((w ++ u) : ws)
+    w : ws            -> w : format ws
+    []                -> []
+
+unStringLit :: String -> String
+unStringLit s = case s of
+  c : cs | strlim c && strlim (last cs) -> init cs
+  _ -> s
+ where
+   strlim = (=='\'')
diff --git a/src/GF/Text/UTF8.hs b/src/GF/Text/UTF8.hs
new file mode 100644
index 000000000..57b711b4b
--- /dev/null
+++ b/src/GF/Text/UTF8.hs
@@ -0,0 +1,35 @@
+module UTF8 where
+
+-- From the Char module supplied with HBC.
+-- code by Thomas Hallgren (Jul 10 1999)
+
+-- Take a Unicode string and encode it as a string
+-- with the UTF8 method.
+decodeUTF8 :: String -> String
+decodeUTF8 "" = ""
+decodeUTF8 (c:cs) | c < '\x80' = c : decodeUTF8 cs
+decodeUTF8 (c:c':cs) | '\xc0' <= c  && c  <= '\xdf' && 
+		      '\x80' <= c' && c' <= '\xbf' =
+	toEnum ((fromEnum c `mod` 0x20) * 0x40 + fromEnum c' `mod` 0x40) : decodeUTF8 cs
+decodeUTF8 (c:c':c'':cs) | '\xe0' <= c   && c   <= '\xef' && 
+		          '\x80' <= c'  && c'  <= '\xbf' &&
+		          '\x80' <= c'' && c'' <= '\xbf' =
+	toEnum ((fromEnum c `mod` 0x10 * 0x1000) + (fromEnum c' `mod` 0x40) * 0x40 + fromEnum c'' `mod` 0x40) : decodeUTF8 cs
+decodeUTF8 _ = error "UniChar.decodeUTF8: bad data"
+
+encodeUTF8 :: String -> String
+encodeUTF8 "" = ""
+encodeUTF8 (c:cs) =
+	if c > '\x0000' && c < '\x0080' then
+	    c : encodeUTF8 cs
+	else if c < toEnum 0x0800 then
+	    let i = fromEnum c
+	    in  toEnum (0xc0 + i `div` 0x40) : 
+	        toEnum (0x80 + i `mod` 0x40) : 
+		encodeUTF8 cs
+	else
+	    let i = fromEnum c
+	    in  toEnum (0xe0 + i `div` 0x1000) : 
+	        toEnum (0x80 + (i `mod` 0x1000) `div` 0x40) : 
+		toEnum (0x80 + i `mod` 0x40) : 
+		encodeUTF8 cs
diff --git a/src/GF/Text/Unicode.hs b/src/GF/Text/Unicode.hs
new file mode 100644
index 000000000..78aba0461
--- /dev/null
+++ b/src/GF/Text/Unicode.hs
@@ -0,0 +1,24 @@
+module Unicode where
+
+import Greek (mkGreek)
+import Arabic (mkArabic)
+import Hebrew (mkHebrew)
+import Russian (mkRussian, mkRusKOI8)
+
+-- ad hoc Unicode conversions from different alphabets
+
+-- AR 12/4/2000, 18/9/2001, 30/5/2002
+
+mkUnicode s = case s of
+ '/':'/':cs -> mkGreek   (remClosing cs)
+ '/':'+':cs -> mkHebrew  (remClosing cs)
+ '/':'-':cs -> mkArabic  (remClosing cs)
+ '/':'_':cs -> mkRussian (remClosing cs)
+ '/':'*':cs -> mkRusKOI8 (remClosing cs)
+ _      -> s
+
+remClosing cs 
+ | lcs > 1 && last cs == '/' = take (lcs-2) cs
+ | otherwise = cs
+    where lcs = length cs
+
diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs
new file mode 100644
index 000000000..bf84d776b
--- /dev/null
+++ b/src/GF/UseGrammar/Custom.hs
@@ -0,0 +1,256 @@
+module Custom where
+
+import Operations
+import Text
+import Tokenize
+import qualified Grammar as G
+import qualified AbsGFC as A
+import qualified GFC as C
+import qualified AbsGF as GF
+import qualified MMacros as MM
+import AbsCompute
+import TypeCheck
+------import Compile
+import ShellState
+import Editing
+import Paraphrases
+import Option
+import CF
+import CFIdent
+
+---- import CFtoGrammar
+import PPrCF
+import PrGrammar
+
+----import Morphology
+-----import GrammarToHaskell
+-----import GrammarToCanon (showCanon, showCanonOpt)
+-----import qualified GrammarToGFC as GFC
+
+-- the cf parsing algorithms
+import ChartParser -- or some other CF Parser
+
+import MoreCustom -- either small/ or big/. The one in Small is empty.
+
+import UseIO
+
+-- minimal version also used in Hugs. AR 2/12/2002. 
+
+-- databases for customizable commands. AR 21/11/2001
+-- for:  grammar parsers, grammar printers, term commands, string commands
+-- idea: items added here are usable throughout GF; nothing else need be edited
+-- they are often usable through the API: hence API cannot be imported here!
+
+-- Major redesign 3/4/2002: the first entry in each database is DEFAULT.
+-- If no other value is given, the default is selected.
+-- Because of this, two invariants have to be preserved:
+-- ** no databases may be empty
+-- ** additions are made to the end of the database
+
+-- these are the databases; the comment gives the name of the flag
+
+-- grammarFormat, "-format=x" or file suffix
+customGrammarParser :: CustomData (FilePath -> IOE C.CanonGrammar) 
+
+-- grammarPrinter, "-printer=x"
+customGrammarPrinter :: CustomData (StateGrammar -> String)             
+
+-- syntaxPrinter, "-printer=x"
+customSyntaxPrinter  :: CustomData (GF.Grammar -> String)        
+
+-- termPrinter, "-printer=x"
+customTermPrinter  :: CustomData (StateGrammar -> A.Exp -> String)
+
+-- termCommand, "-transform=x"
+customTermCommand    :: CustomData (StateGrammar -> A.Exp -> [A.Exp])
+
+-- editCommand, "-edit=x"
+customEditCommand    :: CustomData (StateGrammar -> Action)
+
+-- filterString, "-filter=x"
+customStringCommand  :: CustomData (StateGrammar -> String -> String)
+
+-- useParser, "-parser=x"
+customParser         :: CustomData (StateGrammar -> CFCat -> CFParser)
+
+-- useTokenizer, "-lexer=x"
+customTokenizer      :: CustomData (StateGrammar -> String -> [CFTok])  
+
+-- useUntokenizer, "-unlexer=x" --- should be from token list to string
+customUntokenizer    :: CustomData (StateGrammar -> String -> String)  
+
+
+-- this is the way of selecting an item
+customOrDefault :: Options -> OptFun -> CustomData a -> a
+customOrDefault opts optfun db = maybe (defaultCustomVal db) id $ 
+                                   customAsOptVal opts optfun db
+
+-- to produce menus of custom operations
+customInfo :: CustomData a -> (String, [String])
+customInfo c = (titleCustomData c, map (ciStr . fst) (dbCustomData c))
+
+-------------------------------
+
+type CommandId = String
+
+strCI :: String -> CommandId
+strCI = id
+
+ciStr :: CommandId -> String
+ciStr = id
+
+ciOpt :: CommandId -> Option
+ciOpt = iOpt
+
+newtype CustomData a = CustomData (String, [(CommandId,a)])
+customData title db = CustomData (title,db)
+dbCustomData (CustomData (_,db)) = db
+titleCustomData (CustomData (t,_)) = t
+
+lookupCustom :: CustomData a -> CommandId -> Maybe a
+lookupCustom = flip lookup . dbCustomData
+
+customAsOptVal :: Options -> OptFun -> CustomData a -> Maybe a
+customAsOptVal opts optfun db = do
+  arg <- getOptVal opts optfun
+  lookupCustom db (strCI arg)
+
+-- take the first entry from the database
+defaultCustomVal :: CustomData a -> a
+defaultCustomVal (CustomData (s,db)) = 
+  ifNull (error ("empty database:" +++ s)) (snd . head) db
+
+-------------------------------------------------------------------------
+-- and here's the customizable part:
+
+-- grammar parsers: the ID is also used as file name suffix
+customGrammarParser = 
+  customData "Grammar parsers, selected by file name suffix" $
+  [
+------   (strCI "gf",  compileModule noOptions) -- DEFAULT
+-- add your own grammar parsers here
+  ] 
+  ++ moreCustomGrammarParser
+
+
+customGrammarPrinter = 
+  customData "Grammar printers, selected by option -printer=x" $
+  [
+----   (strCI "gf",      prt)  -- DEFAULT
+  (strCI "cf",      prCF . stateCF)
+
+{- ----
+   (strCI "gf",      prt  . st2grammar . stateGrammarST)  -- DEFAULT
+  ,(strCI "canon",   showCanon "Lang" . stateGrammarST)
+  ,(strCI "gfc",     GFC.showGFC . stateGrammarST)
+  ,(strCI "canonOpt",showCanonOpt "Lang" . stateGrammarST)
+  ,(strCI "morpho",  prMorpho . stateMorpho)
+  ,(strCI "opts",    prOpts . stateOptions)
+-}
+-- add your own grammar printers here
+--- also include printing via grammar2syntax!
+  ] 
+  ++ moreCustomGrammarPrinter
+
+customSyntaxPrinter = 
+  customData "Syntax printers, selected by option -printer=x" $
+  [ 
+-- add your own grammar printers here
+  ] 
+  ++ moreCustomSyntaxPrinter
+
+
+customTermPrinter = 
+  customData "Term printers, selected by option -printer=x" $
+  [ 
+    (strCI "gf",     const prt) -- DEFAULT
+-- add your own term printers here
+  ]
+  ++ moreCustomTermPrinter
+
+customTermCommand = 
+  customData "Term transformers, selected by option -transform=x" $
+  [
+   (strCI "identity",   \_ t -> [t]) -- DEFAULT
+{- ----
+  ,(strCI "compute",    \g t -> err (const [t]) return (computeAbsTerm g t))
+  ,(strCI "paraphrase", \g t -> mkParaphrases g t)
+  ,(strCI "typecheck",  \g t -> err (const []) return (checkIfValidExp g t))
+  ,(strCI "solve",      \g t -> editAsTermCommand g 
+                                            (uniqueRefinements g) t)
+  ,(strCI "context",    \g t -> editAsTermCommand g  
+                                            (contextRefinements g) t)
+-}
+---  ,(strCI "delete",     \g t -> [MM.mExp0])
+-- add your own term commands here
+  ]
+  ++ moreCustomTermCommand
+
+customEditCommand = 
+  customData "Editor state transformers, selected by option -edit=x" $
+  [
+   (strCI "identity",   const return) -- DEFAULT
+  ,(strCI "transfer",   const return) --- done ad hoc on top level
+{- ----
+  ,(strCI "typecheck",  reCheckState)
+  ,(strCI "solve",      solveAll)
+  ,(strCI "context",    contextRefinements)
+  ,(strCI "compute",    computeSubTree)
+-}
+  ,(strCI "paraphrase", const return) --- done ad hoc on top level
+-- add your own edit commands here
+  ]
+  ++ moreCustomEditCommand
+
+customStringCommand = 
+  customData "String filters, selected by option -filter=x" $
+  [
+   (strCI "identity",  const $ id)   -- DEFAULT
+  ,(strCI "erase",     const $ const "")
+  ,(strCI "take100",   const $ take 100)
+  ,(strCI "text",      const $ formatAsText)
+  ,(strCI "code",      const $ formatAsCode)
+----  ,(strCI "latexfile", const $ mkLatexFile)
+  ,(strCI "length",    const $ show . length)
+-- add your own string commands here
+  ]
+  ++ moreCustomStringCommand
+
+customParser = 
+  customData "Parsers, selected by option -parser=x" $
+  [
+   (strCI "chart",    chartParser . stateCF)
+-- add your own parsers here
+  ]
+  ++ moreCustomParser
+
+customTokenizer = 
+  customData "Tokenizers, selected by option -lexer=x" $
+  [
+   (strCI "words",     const $ tokWords)
+  ,(strCI "literals",  const $ tokLits)
+  ,(strCI "vars",      const $ tokVars)
+  ,(strCI "chars",     const $ map (tS . singleton))
+  ,(strCI "code",      const $ lexHaskell)
+  ,(strCI "text",      const $ lexText)
+----  ,(strCI "codelit",   lexHaskellLiteral . stateIsWord)
+----  ,(strCI "textlit",   lexTextLiteral . stateIsWord)
+  ,(strCI "codeC",     const $ lexC2M)
+  ,(strCI "codeCHigh", const $ lexC2M' True)
+-- add your own tokenizers here
+  ]
+  ++ moreCustomTokenizer
+
+customUntokenizer = 
+  customData "Untokenizers, selected by option -unlexer=x" $
+  [
+   (strCI "unwords",   const $ id)   -- DEFAULT
+  ,(strCI "text",      const $ formatAsText)
+  ,(strCI "code",      const $ formatAsCode)
+  ,(strCI "textlit",   const $ formatAsTextLit)
+  ,(strCI "codelit",   const $ formatAsCodeLit)
+  ,(strCI "concat",    const $ concat . words)
+  ,(strCI "bind",      const $ performBinds)
+-- add your own untokenizers here
+  ]
+  ++ moreCustomUntokenizer
diff --git a/src/GF/UseGrammar/Editing.hs b/src/GF/UseGrammar/Editing.hs
new file mode 100644
index 000000000..616ddc7cc
--- /dev/null
+++ b/src/GF/UseGrammar/Editing.hs
@@ -0,0 +1,358 @@
+module Editing where
+
+import Abstract
+import qualified GFC
+import TypeCheck
+import LookAbs
+import AbsCompute
+
+import Operations
+import Zipper
+
+-- generic tree editing, with some grammar notions assumed. AR 18/8/2001 
+-- 19/6/2003 for GFC
+
+type CGrammar = GFC.CanonGrammar
+
+type State = Loc TrNode
+
+-- the "empty" state
+initState :: State
+initState = tree2loc uTree 
+
+isRootState :: State -> Bool
+isRootState s = case actPath s of
+  Top -> True
+  _ -> False
+
+actTree :: State -> Tree
+actTree (Loc (t,_)) = t
+
+actPath :: State -> Path TrNode
+actPath (Loc (_,p)) = p
+
+actVal :: State -> Val
+actVal = valNode . nodeTree . actTree
+
+actCat :: State -> Cat
+actCat = errVal undefined . val2cat . actVal ---- undef
+
+actAtom :: State -> Atom
+actAtom = atomTree . actTree
+
+actExp = tree2exp . actTree
+
+-- current local bindings
+actBinds :: State -> Binds
+actBinds = bindsNode . nodeTree . actTree
+
+-- constraints in current subtree
+actConstrs :: State -> Constraints
+actConstrs = allConstrsTree . actTree   
+
+-- constraints in the whole tree
+allConstrs :: State -> Constraints
+allConstrs = allConstrsTree . loc2tree   
+
+-- metas in current subtree
+actMetas :: State -> [Meta]
+actMetas = metasTree . actTree   
+
+-- metas in the whole tree
+allMetas :: State -> [Meta]
+allMetas = metasTree . loc2tree
+
+actTreeBody :: State -> Tree
+actTreeBody = bodyTree . actTree
+
+allPrevBinds :: State -> Binds
+allPrevBinds = concatMap bindsNode . traverseCollect . actPath
+
+allBinds :: State -> Binds
+allBinds s = actBinds s ++ allPrevBinds s
+
+actGen :: State -> Int
+actGen = length . allBinds -- symbol generator for VGen
+
+allPrevVars :: State -> [Var]
+allPrevVars = map fst . allPrevBinds
+
+allVars :: State -> [Var]
+allVars = map fst . allBinds
+
+vGenIndex = length . allBinds
+
+actIsMeta = atomIsMeta . actAtom
+
+actMeta :: State -> Err Meta
+actMeta = getMetaAtom . actAtom
+
+-- meta substs are not only on the actual path...
+entireMetaSubst :: State -> MetaSubst
+entireMetaSubst = concatMap metaSubstsNode . scanTree . loc2tree
+
+isCompleteTree = null . filter atomIsMeta . map atomNode . scanTree 
+isCompleteState = isCompleteTree . loc2tree
+
+initStateCat :: Context -> Cat -> Err State
+initStateCat cont cat = do
+  return $ tree2loc (Tr (mkNode [] mAtom (cat2val cont cat) ([],[]), []))
+
+-- this function only concerns the body of an expression...
+annotateInState :: CGrammar -> Exp -> State -> Err Tree
+annotateInState gr exp state = do
+  let binds = allBinds state
+      val   = actVal state
+  annotateIn gr binds exp (Just val)
+
+-- ...whereas this one works with lambda abstractions
+annotateExpInState :: CGrammar -> Exp -> State -> Err Tree
+annotateExpInState gr exp state = do
+  let cont  = allPrevBinds state
+      binds = actBinds state
+      val   = actVal state
+  typ <- mkProdVal binds val
+  annotateIn gr binds exp (Just typ)
+  
+treeByExp :: (Exp -> Err Exp) -> CGrammar -> Exp -> State -> Err Tree
+treeByExp trans gr exp0 state = do
+  exp <- trans exp0
+  annotateExpInState gr exp state
+
+-- actions
+
+type Action = State -> Err State
+
+newCat :: CGrammar -> Cat -> Action
+newCat gr cat@(m,c) _ = do
+  cont <- lookupCatContext gr m c
+  testErr (null cont) "start cat must have null context" -- for easier meta refresh
+  initStateCat cont cat
+
+newTree :: Tree -> Action
+newTree t _ = return $ tree2loc t
+
+newExpTC :: CGrammar -> Exp -> Action
+newExpTC gr t s = annotate gr (refreshMetas [] t) >>= flip newTree s
+
+goNextMeta, goPrevMeta, goNextNewMeta, goPrevNewMeta, goNextMetaIfCan :: Action
+
+goNextMeta = repeatUntilErr actIsMeta goAhead -- can be the location itself
+goPrevMeta = repeatUntilErr actIsMeta goBack
+
+goNextNewMeta s = goAhead s >>= goNextMeta    -- always goes away from location
+goPrevNewMeta s = goBack  s >>= goPrevMeta
+
+goNextMetaIfCan = actionIfPossible goNextMeta
+
+actionIfPossible a s = return $ errVal s (a s)
+
+goFirstMeta, goLastMeta :: Action
+goFirstMeta s = goNextMeta $ goRoot s
+goLastMeta  s = goLast s >>= goPrevMeta
+
+noMoreMetas :: State -> Bool
+noMoreMetas = err (const True) (const False) . goNextMeta 
+
+replaceSubTree :: Tree -> Action
+replaceSubTree tree state = changeLoc state tree
+
+refineWithTree :: Bool -> CGrammar -> Tree -> Action
+refineWithTree der gr tree state = do
+  m      <- errIn "move pointer to meta" $ actMeta state
+  state' <- replaceSubTree tree state
+  let cs0     = allConstrs state'
+      (cs,ms) = splitConstraints cs0
+      v       = vClos $ tree2exp (bodyTree tree)
+      msubst  = (m,v) : ms
+  metaSubstRefinements gr msubst $ mapLoc (performMetaSubstNode msubst) state'
+
+  -- without dep. types, no constraints, no grammar needed - simply: do
+  --   testErr (actIsMeta state) "move pointer to meta"
+  --   replaceSubTree tree state
+
+refineAllNodes :: Action -> Action
+refineAllNodes act state = do  
+  let estate0 = goFirstMeta state
+  case estate0 of
+    Bad _ -> return state
+    Ok state0 -> do 
+      (state',n) <- tryRefine 0 state0
+      if n==0 
+        then return state
+        else actionIfPossible goFirstMeta state'
+ where
+   tryRefine n state = err (const $ return (state,n)) return $ do 
+     state' <- goNextMeta state
+     meta   <- actMeta state'
+     case act state' of
+       Ok state2 -> tryRefine (n+1) state2
+       _ -> err (const $ return (state',n)) return $ do
+         state2 <- goNextNewMeta state' 
+         tryRefine n state2
+
+uniqueRefinements :: CGrammar -> Action
+uniqueRefinements = refineAllNodes . uniqueRefine
+
+metaSubstRefinements :: CGrammar -> MetaSubst -> Action
+metaSubstRefinements gr = refineAllNodes . metaSubstRefine gr
+
+contextRefinements :: CGrammar -> Action
+contextRefinements gr = refineAllNodes contextRefine where
+  contextRefine state = case varRefinementsState state of
+    [(e,_)] -> refineWithAtom False gr e state
+    _ -> Bad "no unique refinement in context"
+  varRefinementsState state = 
+    [r | r@(e,_) <- refinementsState gr state, isVariable e]
+
+uniqueRefine :: CGrammar -> Action
+uniqueRefine gr state = case refinementsState gr state of
+  [(e,_)] -> refineWithAtom False gr e state
+  _ -> Bad "no unique refinement"
+
+metaSubstRefine :: CGrammar -> MetaSubst -> Action
+metaSubstRefine gr msubst state = do
+  m <- errIn "move pointer to meta" $ actMeta state
+  case lookup m msubst of
+    Just v -> do
+       e <- val2expSafe v
+       refineWithExpTC False gr e state
+    _ -> Bad "no metavariable substitution available"
+
+refineWithExpTC :: Bool -> CGrammar -> Exp -> Action
+refineWithExpTC der gr exp0 state = do
+  let oldmetas = allMetas state
+      exp = refreshMetas oldmetas exp0
+  tree0 <- annotateInState gr exp state
+  let tree = addBinds (actBinds state) $ tree0
+  refineWithTree der gr tree state
+
+refineWithAtom :: Bool -> CGrammar -> Ref -> Action -- function or variable
+refineWithAtom der gr at state = do
+  val <- lookupRef gr (allBinds state) at
+  typ <- val2exp val
+  let oldvars  = allVars state
+  exp <- ref2exp oldvars typ at
+  refineWithExpTC der gr exp state
+
+-- in this command, we know that the result is well-typed, since computation
+-- rules have been type checked and the result is equal
+
+computeSubTree :: CGrammar -> Action
+computeSubTree gr state = do
+  let exp = tree2exp (actTree state)
+  tree <- treeByExp (compute gr) gr exp state
+  replaceSubTree tree state
+
+-- but here we don't, since the transfer flag isn't type checked,
+-- and computing the transfer function is not checked to preserve equality
+
+transferSubTree :: Maybe Fun -> CGrammar -> Action
+transferSubTree Nothing _ s = return s
+transferSubTree (Just fun) gr state = do
+  let exp = mkApp (qq fun) [tree2exp $ actTree state]
+  tree <- treeByExp (compute gr) gr exp state
+  state' <- replaceSubTree tree state
+  reCheckState gr state'
+
+deleteSubTree :: CGrammar -> Action
+deleteSubTree gr state = 
+  if isRootState state
+     then do
+       let cat = actCat state
+       newCat gr cat state
+     else do
+       let metas = allMetas state
+           binds = actBinds state
+           exp = refreshMetas metas mExp0
+       tree <- annotateInState gr exp state
+       state' <- replaceSubTree (addBinds binds tree) state
+       reCheckState gr state' --- must be unfortunately done. 20/11/2001
+
+wrapWithFun :: CGrammar -> (Fun,Int) -> Action
+wrapWithFun gr (f@(m,c),i) state = do
+  typ <- lookupFunType gr m c
+  let olds = allPrevVars state
+      oldmetas = allMetas state
+  exp0  <- fun2wrap olds ((f,i),typ) (tree2exp (actTreeBody state))
+  let exp = refreshMetas oldmetas exp0
+  tree0 <- annotateInState gr exp state  
+  let tree = addBinds (actBinds state) $ tree0
+  state' <- replaceSubTree tree state
+  reCheckState gr state' --- must be unfortunately done. 20/11/2001
+
+alphaConvert :: CGrammar -> (Var,Var) -> Action
+alphaConvert gr (x,x') state = do
+  let oldvars = allPrevVars state
+  testErr (notElem x' oldvars) ("clash with previous bindings" +++ show x')
+  let binds0  = actBinds state
+      vars0   = map fst binds0
+  testErr (notElem x' vars0) ("clash with other bindings" +++ show x')
+  let binds   = [(if z==x then x' else z, t) | (z,t) <- binds0]
+      vars    = map fst binds
+  exp' <- alphaConv (vars ++ oldvars) (x,x') (tree2exp (actTreeBody state))
+  let exp = mkAbs vars exp'
+  tree <- annotateExpInState gr exp state
+  replaceSubTree tree state
+
+changeFunHead :: CGrammar -> Fun -> Action
+changeFunHead gr f state = do
+  let state' = changeNode (changeAtom (const (atomC f))) state
+  reCheckState gr state' --- must be done because of constraints elsewhere
+
+peelFunHead :: CGrammar -> Action
+peelFunHead gr state = do
+  state' <- forgetNode state
+  reCheckState gr state' --- must be done because of constraints elsewhere
+
+-- an expensive operation
+reCheckState :: CGrammar -> State -> Err State
+reCheckState gr st = annotate gr (tree2exp (loc2tree st)) >>= return . tree2loc
+
+-- extract metasubstitutions from constraints and solve them
+solveAll :: CGrammar -> State -> Err State
+solveAll gr st0 = do
+  st <- reCheckState gr st0
+  let cs0     = allConstrs st
+      (cs,ms) = splitConstraints cs0
+  metaSubstRefinements gr ms $ mapLoc (performMetaSubstNode ms) st
+
+
+-- active refinements
+
+refinementsState :: CGrammar -> State -> [(Term,Val)]
+refinementsState gr state = 
+  let filt = possibleRefVal gr state in 
+  if actIsMeta state 
+     then refsForType filt gr (allBinds state) (actVal state)
+     else []
+
+wrappingsState :: CGrammar -> State -> [((Fun,Int),Type)]
+wrappingsState gr state
+  | actIsMeta state = []
+  | isRootState state = funs 
+  | otherwise = [rule | rule@(_,typ) <- funs, possibleRefVal gr state aval typ]
+ where 
+   funs = funsOnType (possibleRefVal gr state) gr aval
+   aval = actVal state
+
+headChangesState :: CGrammar -> State -> [Fun]
+headChangesState gr state = errVal [] $ do 
+  f@(m,c) <-  funAtom (actAtom state)
+  typ0 <- lookupFunType gr m c
+  return [fun | (fun,typ) <- funRulesOf gr, fun /= f, typ == typ0] 
+                                                          --- alpha-conv !
+
+canPeelState :: CGrammar -> State -> Bool
+canPeelState gr state = errVal False $ do
+  f@(m,c) <-  funAtom (actAtom state)
+  typ <- lookupFunType gr m c
+  return $ isInOneType typ
+
+possibleRefVal :: CGrammar -> State -> Val -> Type -> Bool
+possibleRefVal gr state val typ = errVal True $ do --- was False
+  vtyp <- valType typ
+  let gen = actGen state
+  cs   <- return [(val, vClos vtyp)] --- eqVal gen val (vClos vtyp) --- only poss cs
+  return $ possibleConstraints gr cs --- a simple heuristic
+
diff --git a/src/GF/UseGrammar/GetTree.hs b/src/GF/UseGrammar/GetTree.hs
new file mode 100644
index 000000000..9b545c7dd
--- /dev/null
+++ b/src/GF/UseGrammar/GetTree.hs
@@ -0,0 +1,46 @@
+module GetTree where
+
+import GFC
+import Values
+import qualified Grammar as G
+import Ident
+import MMacros
+import Macros
+import Rename
+import TypeCheck
+import PGrammar
+import ShellState
+
+import Operations
+
+-- how to form linearizable trees from strings and from terms of different levels
+--
+-- String --> raw Term --> annot, qualif Term --> Tree
+
+string2tree :: StateGrammar -> String -> Tree
+string2tree gr = errVal uTree . string2treeErr gr
+
+string2treeErr :: StateGrammar -> String -> Err Tree
+string2treeErr gr s = do
+  t <- pTerm s
+  let t1 = refreshMetas [] t
+  let t2 = qualifTerm abstr t1
+  annotate grc t2
+ where
+   abstr = absId gr
+   grc = grammar gr
+
+string2Cat, string2Fun :: StateGrammar -> String -> (Ident,Ident)
+string2Cat gr c = (absId gr,identC c)
+string2Fun = string2Cat
+
+strings2Cat, strings2Fun :: String -> (Ident,Ident)
+strings2Cat s = (identC m, identC (drop 1 c)) where (m,c) = span (/= '.') s
+strings2Fun = strings2Cat
+
+string2ref :: StateGrammar -> String -> Err G.Term
+string2ref _ ('x':'_':ds) = return $ freshAsTerm ds --- hack for generated vars
+string2ref gr s = 
+  if elem '.' s 
+    then return $ uncurry G.Q $ strings2Fun s
+    else return $ G.Vr $ identC s
diff --git a/src/GF/UseGrammar/Information.hs b/src/GF/UseGrammar/Information.hs
new file mode 100644
index 000000000..569d8ace6
--- /dev/null
+++ b/src/GF/UseGrammar/Information.hs
@@ -0,0 +1,130 @@
+module Information where
+
+import Grammar
+import Ident
+import Modules
+import Option
+import CF
+import PPrCF
+import ShellState
+import PrGrammar
+import Lookup
+import qualified GFC
+import qualified AbsGFC
+
+import Operations
+import UseIO
+
+-- information on module, category, function, operation, parameter,... AR 16/9/2003
+-- uses source grammar
+
+-- the top level function
+
+showInformation :: Options -> ShellState -> Ident -> IOE ()
+showInformation opts st c = do
+  is <- ioeErr $ getInformation opts st c
+  mapM_ (putStrLnE . prInformation opts c) is
+
+-- the data type of different kinds of information
+
+data Information = 
+   IModAbs  SourceAbs
+ | IModRes  SourceRes
+ | IModCnc  SourceCnc
+ | IModule  SourceAbs ---- to be deprecated
+ | ICatAbs  Ident Context [Ident]
+ | ICatCnc  Ident Type    [CFRule] Term
+ | IFunAbs  Ident Type    (Maybe Term)
+ | IFunCnc  Ident Type    [CFRule] Term
+ | IOper    Ident Type    Term
+ | IParam   Ident         [Param] [Term]
+ | IValue   Ident Type
+
+type CatId = AbsGFC.CIdent
+type FunId = AbsGFC.CIdent
+
+prInformation :: Options -> Ident -> Information -> String
+prInformation opts c i = unlines $ prt c : case i of
+  IModule m -> [
+    "module of type" +++ show (mtype m),
+    "extends" +++ show (extends m),
+    "opens" +++ show (opens m),
+    "defines" +++ unwords (map prt (ownConstants (jments m)))
+    ]
+  ICatAbs m co _ -> [
+    "category in abstract module" +++ prt m,
+    "context" +++ prContext co
+    ]
+  ICatCnc m ty cfs tr -> [
+    "category in concrete module" +++ prt m,
+    "linearization type" +++ prt ty
+    ]
+  IFunAbs m ty _ -> [
+    "function in abstract module" +++ prt m,
+    "type" +++ prt ty
+    ]
+  IFunCnc m ty cfs tr -> [
+    "function in concrete module" +++ prt m,
+    "linearization" +++ prt tr
+   ---    "linearization type" +++ prt ty
+    ]
+  IOper m ty tr -> [
+    "operation in resource module" +++ prt m,
+    "type" +++ prt ty,
+    "definition" +++ prt tr 
+    ]
+  IParam m ty ts -> [
+    "parameter type in resource module" +++ prt m,
+    "constructors" +++ unwords (map prParam ty),
+    "values" +++ unwords (map prt ts)
+    ]
+  IValue m ty -> [
+    "parameter constructor in resource module" +++ prt m,
+    "type" +++ show ty
+    ]
+
+-- also finds out if an identifier is defined in many places
+
+getInformation :: Options -> ShellState -> Ident -> Err [Information]
+getInformation opts st c = allChecks $ [
+  do
+    m <- lookupModule src c 
+    case m of
+      ModMod mo -> return $ IModule mo
+      _ -> prtBad "not a source module" c
+  ] ++ map lookInSrc ss ++ map lookInCan cs
+ where
+   lookInSrc (i,m) = do
+     j <- lookupInfo m c 
+     case j of
+       AbsCat (Yes co) _ -> return $ ICatAbs i co [] ---
+       AbsFun (Yes ty) _ -> return $ IFunAbs i ty Nothing ---
+       CncCat (Yes ty) _ _ -> do
+         ---- let cat = ident2CFCat i c
+         ---- rs <- concat [rs | (c,rs) <- cf, ]
+         return $ ICatCnc i ty [] ty ---       
+       CncFun _ (Yes tr) _ -> do
+         rs <- return []
+         return $ IFunCnc i tr rs tr ---       
+       ResOper (Yes ty) (Yes tr) -> return $ IOper i ty tr
+       ResParam (Yes ps) -> do
+         ts <- allParamValues src (QC i c)
+         return $ IParam i ps ts
+       ResValue (Yes ty) -> return $ IValue i ty ---
+       
+       _ -> prtBad "nothing available for" i
+   lookInCan (i,m) = do
+     Bad "nothing available yet in canonical"
+
+   src = srcModules st
+   can = canModules st
+   ss  = [(i,m) | (i,ModMod m) <- modules src]
+   cs  = [(i,m) | (i,ModMod m) <- modules can]
+   cf  = concatMap ruleGroupsOfCF $ map snd $ cfs st
+
+ownConstants :: BinTree (Ident, Info) -> [Ident]
+ownConstants = map fst . filter isOwn . tree2list where
+  isOwn (c,i) = case i of
+    AnyInd _ _ -> False
+    _ -> True
+
diff --git a/src/GF/UseGrammar/Linear.hs b/src/GF/UseGrammar/Linear.hs
new file mode 100644
index 000000000..da1bfce52
--- /dev/null
+++ b/src/GF/UseGrammar/Linear.hs
@@ -0,0 +1,195 @@
+module Linear where
+
+import GFC
+import AbsGFC
+import qualified Abstract as A
+import MkGFC (rtQIdent) ----
+import Ident
+import PrGrammar
+import CMacros
+import Look
+import Str
+import Unlex
+----import TypeCheck -- to annotate
+
+import Operations
+import Zipper
+
+import Monad
+
+-- Linearization for canonical GF. AR 7/6/2003
+
+-- The worker function: linearize a Tree, return
+-- a record. Possibly mark subtrees.
+
+-- NB. Constants in trees are annotated by the name of the abstract module.
+-- A concrete module name must be given to find (and choose) linearization rules.
+
+linearizeToRecord :: CanonGrammar -> Marker -> Ident -> A.Tree -> Err Term
+linearizeToRecord gr mk m = lin [] where
+
+  lin ts t = errIn ("lint" +++ prt t) $ ---- 
+    if A.isFocusNode (A.nodeTree t) 
+      then liftM markFocus $ lint ts t
+      else lint ts t
+
+  lint ts t@(Tr (n,xs)) = do
+
+    let binds = A.bindsNode n
+        at    = A.atomNode n
+    c   <- A.val2cat $ A.valNode n
+    xs' <- mapM (\ (i,x) -> lin (i:ts) x) $ zip [0..] xs
+
+    r <- case at of
+      A.AtC f -> look f >>= comp xs'
+      A.AtL s -> return $ recS $ tK $ prt at
+      A.AtI i -> return $ recS $ tK $ prt at
+      A.AtV x -> lookCat c >>= comp [tK (prt at)]
+      A.AtM m -> lookCat c >>= comp [tK (prt at)] 
+
+    return $ mk ts $ mkBinds binds r
+
+  look = lookupLin gr . redirectIdent m . rtQIdent
+  comp = ccompute gr
+  mkBinds bs bdy = case bdy of
+    R fs -> R $ [Ass (LV i) (tK (prt t)) | (i,(t,_)) <- zip [0..] bs] ++ fs
+
+  recS t = R [Ass (L (identC "s")) t] ----
+
+  lookCat = return . errVal defLindef . look 
+         ---- should always be given in the module
+
+type Marker = [Int] -> Term -> Term
+
+-- if no marking is wanted, use the following
+
+noMark :: [Int] -> Term -> Term
+noMark = const id
+
+-- thus the special case:
+
+linearizeNoMark :: CanonGrammar -> Ident -> A.Tree -> Err Term
+linearizeNoMark gr = linearizeToRecord gr noMark
+
+-- expand tables in linearized term to full, normal-order tables
+-- NB expand from inside-out so that values are not looked up in copies of branches
+
+expandLinTables :: CanonGrammar -> Term -> Err Term
+expandLinTables gr t = case t of
+  R rs -> liftM (R . map (uncurry Ass)) $ mapPairsM exp [(l,r) | Ass l r <- rs]
+  T ty rs -> do
+    rs' <- mapPairsM exp [(l,r) | Cas l r <- rs] -- expand from inside-out
+    let t' = T ty $ map (uncurry Cas) rs'
+    vs  <- alls ty
+    ps  <- mapM term2patt vs
+    ts' <- mapM (comp . S t') $ vs
+    return $ T ty [Cas [p] t | (p,t) <- zip ps ts']
+  FV ts -> liftM FV $ mapM exp ts
+  _ -> return t
+ where
+   alls = allParamValues gr
+   exp  = expandLinTables gr
+   comp = ccompute gr []
+
+-- from records, one can get to records of tables of strings
+
+rec2strTables :: Term -> Err [[(Label,[([Patt],[Str])])]]
+rec2strTables r = do
+  vs <- allLinValues r
+  mapM (mapPairsM (mapPairsM strsFromTerm)) vs
+
+-- from these tables, one may want to extract the ones for the "s" label
+
+strTables2sTables :: [[(Label,[([Patt],[Str])])]] -> [[([Patt],[Str])]]
+strTables2sTables ts = [t | r <- ts, (l,t) <- r, l == linLab0]
+
+linLab0 :: Label
+linLab0 = L (identC "s")
+
+-- to get lists of token lists is easy
+sTables2strs :: [[([Patt],[Str])]] -> [[Str]]
+sTables2strs = map snd . concat
+
+-- from this, to get a list of strings --- customize unlexer
+strs2strings :: [[Str]] -> [String]
+strs2strings = map unlex
+
+-- finally, a top-level function to get a string from an expression
+linTree2string :: CanonGrammar -> Ident -> A.Tree -> String
+linTree2string gr m e = err id id $ do
+  t  <- linearizeNoMark gr m e
+  r  <- expandLinTables gr t
+  ts <- rec2strTables r
+  let ss = strs2strings $ sTables2strs $ strTables2sTables ts
+  ifNull (prtBad "empty linearization of" e) (return . head) ss
+
+
+-- argument is a Tree, value is a list of strs; needed in Parsing
+
+allLinsOfTree :: CanonGrammar -> Ident -> A.Tree -> [Str]
+allLinsOfTree gr a e = err (singleton . str) id $ do
+  e' <- return e ---- annotateExp gr e
+  r  <- linearizeNoMark gr a e'
+  r' <- expandLinTables gr r
+  ts <- rec2strTables r'
+  return $ concat $ sTables2strs $ strTables2sTables ts
+
+{-
+-- the value is a list of strs
+allLinStrings :: CanonGrammar -> Tree -> [Str]
+allLinStrings gr ft = case allLinsAsStrs gr ft of
+  Ok ts -> map snd $ concat $ map snd $ concat ts
+  Bad s -> [str s]
+
+-- the value is a list of strs, not forgetting their arguments
+allLinsAsStrs :: CanonGrammar -> Tree -> Err [[(Label,[([Patt],Str)])]]
+allLinsAsStrs gr ft = do
+  lpts <- allLinearizations gr ft
+  return $ concat $ mapM (mapPairsM (mapPairsM strsFromTerm)) lpts
+
+-- the value is a list of terms of type Str, not forgetting their arguments
+allLinearizations :: CanonGrammar -> Tree -> Err [[(Label,[([Patt],Term)])]]
+allLinearizations gr ft = linearizeTree gr ft >>= allLinValues
+
+-- to a list of strings
+linearizeToStrings :: CanonGrammar -> ([Int] ->Term -> Term) -> Tree -> Err [String]
+linearizeToStrings gr mk = liftM (map unlex) . linearizeToStrss gr mk
+
+-- to a list of token lists
+linearizeToStrss :: CanonGrammar -> ([Int] -> Term -> Term) -> Tree -> Err [[Str]]
+linearizeToStrss gr mk e = do
+  R rs <- linearizeToRecord gr mk e ----
+  t <- lookupErr linLab0 [(r,s) | Ass r s <- rs]
+  return $ map strsFromTerm $ allInTable t 
+  
+
+-- the value is a list of strings, not forgetting their arguments
+allLinsOfFun :: CanonGrammar -> CIdent -> Err [[(Label,[([Patt],Term)])]]
+allLinsOfFun gr f = do
+  t <- lookupLin gr f 
+  allLinValues t
+
+
+
+-}
+
+
+
+
+{- ----
+-- returns printname if one exists; otherwise linearizes with metas
+printOrLinearize :: CanonGrammar -> Fun -> String
+printOrLinearize gr f = 
+{- ----
+ errVal (prtt f) $ case lookupPrintname cnc f of
+  Ok s -> return s
+  _ -> -} 
+ 
+          unlines $ take 1 $ err singleton id $ 
+       do
+    t  <- lookupFunType gr f
+    f' <- ref2exp [] t (AC f) --- []
+    lin f'
+ where 
+   lin = linearizeToStrings gr (const id) ----
+-}
diff --git a/src/GF/UseGrammar/MoreCustom.hs b/src/GF/UseGrammar/MoreCustom.hs
new file mode 100644
index 000000000..0ebbb25fb
--- /dev/null
+++ b/src/GF/UseGrammar/MoreCustom.hs
@@ -0,0 +1,15 @@
+module MoreCustom where
+
+-- All these lists are supposed to be empty!
+-- Items should be added to ../Custom.hs instead.
+
+moreCustomGrammarParser = []
+moreCustomGrammarPrinter = []
+moreCustomSyntaxPrinter = []
+moreCustomTermPrinter = []
+moreCustomTermCommand = []
+moreCustomEditCommand = []
+moreCustomStringCommand = []
+moreCustomParser = []
+moreCustomTokenizer = []
+moreCustomUntokenizer = []
diff --git a/src/GF/UseGrammar/Morphology.hs b/src/GF/UseGrammar/Morphology.hs
new file mode 100644
index 000000000..102e41340
--- /dev/null
+++ b/src/GF/UseGrammar/Morphology.hs
@@ -0,0 +1,116 @@
+module Morphology where
+
+import AbsGFC
+import GFC
+import PrGrammar
+
+import Operations
+
+import Char
+import List (sortBy, intersperse)
+import Monad (liftM)
+
+-- construct a morphological analyser from a GF grammar. AR 11/4/2001
+
+-- we have found the binary search tree sorted by word forms more efficient
+-- than a trie, at least for grammars with 7000 word forms
+
+type Morpho = BinTree (String,[String])
+
+emptyMorpho = NT
+
+-- with literals
+appMorpho :: Morpho -> String -> (String,[String])
+appMorpho m s = (s, ps ++ ms) where
+  ms = case lookupTree id s m of
+    Ok vs -> vs
+    _ -> []
+  ps = [] ---- case lookupLiteral s of
+    ---- Ok (t,_) -> [tagPrt t]
+    ---- _ -> []
+
+-- without literals
+appMorphoOnly :: Morpho -> String -> (String,[String])
+appMorphoOnly m s = (s, ms) where
+  ms = case lookupTree id s m of
+    Ok vs -> vs
+    _ -> []
+
+-- recognize word, exluding literals
+isKnownWord :: Morpho -> String -> Bool
+isKnownWord mo = not . null . snd . appMorphoOnly mo
+
+mkMorpho :: CanonGrammar -> Morpho 
+mkMorpho gr = emptyMorpho ----
+{- ----
+mkMorpho gr = mkMorphoTree $ concat $ map mkOne $ allItems where
+  mkOne (Left (fun,c))  = map (prOne fun c) $ allLins fun
+  mkOne (Right (fun,_)) = map (prSyn fun) $ allSyns fun
+  
+  -- gather forms of lexical items
+  allLins fun = errVal [] $ do
+    ts <- allLinsOfFun gr fun 
+    ss <- mapM (mapPairsM (mapPairsM (return . wordsInTerm))) ts
+    return [(p,s) | (p,fs) <- concat $ map snd $ concat ss, s <- fs]
+  prOne f c (ps,s) = (s, prt f +++ tagPrt c ++ concat (map tagPrt ps))
+
+  -- gather syncategorematic words
+  allSyns fun = errVal [] $ do
+    tss <- allLinsOfFun gr fun 
+    let ss = [s | ts <- tss, (_,fs) <- ts, (_,s) <- fs]
+    return $ concat $ map wordsInTerm ss
+  prSyn f s = (s, "+<syncategorematic>" ++ tagPrt f)
+
+  -- all words, Left from lexical rules and Right syncategorematic
+  allItems = [lexRole t (f,c) | (f,c) <- allFuns, t <- lookType f] where
+    allFuns = allFunsWithValCat ab
+    lookType = errVal [] . liftM (:[]) . lookupFunType ab
+    lexRole t = case typeForm t of
+      Ok ([],_,_) -> Left
+      _ -> Right
+-}
+
+-- printing full-form lexicon and results
+
+prMorpho :: Morpho -> String
+prMorpho = unlines . map prMorphoAnalysis . tree2list
+
+prMorphoAnalysis :: (String,[String]) -> String
+prMorphoAnalysis (w,fs) = unlines (w:fs)
+
+prMorphoAnalysisShort :: (String,[String]) -> String
+prMorphoAnalysisShort (w,fs) = prBracket (w' ++ prTList "/" fs) where
+  w' = if null fs then w +++ "*" else ""
+
+tagPrt :: Print a => a -> String
+tagPrt = ("+" ++) . prt --- could look up print name in grammar
+
+-- print all words recognized
+
+allMorphoWords :: Morpho -> [String]
+allMorphoWords = map fst . tree2list
+
+-- analyse running text and show results either in short form or on separate lines
+morphoTextShort mo = unwords . map (prMorphoAnalysisShort . appMorpho mo) . words
+morphoText mo = unlines . map (('\n':) . prMorphoAnalysis . appMorpho mo) . words
+
+-- format used in the Italian Verb Engine
+prFullForm :: Morpho -> String
+prFullForm = unlines . map prOne . tree2list where
+  prOne (s,ps) = s ++ " : " ++ unwords (intersperse "/" ps)
+
+-- auxiliaries
+
+mkMorphoTree :: (Ord a, Eq b) => [(a,b)] -> BinTree (a,[b])
+mkMorphoTree = sorted2tree . sortAssocs
+
+sortAssocs :: (Ord a, Eq b) => [(a,b)] -> [(a,[b])]
+sortAssocs = arrange . sortBy (\ (x,_) (y,_) -> compare x y) where
+  arrange ((x,v):xvs) = arr x [v] xvs
+  arrange [] = []
+  arr y vs xs = case xs of
+    (x,v):xvs -> if x==y then arr y vvs xvs else (y,vs) : arr x [v] xvs
+                    where vvs = if elem v vs then vs else (v:vs)
+    _ -> [(y,vs)]
+    
+
diff --git a/src/GF/UseGrammar/Paraphrases.hs b/src/GF/UseGrammar/Paraphrases.hs
new file mode 100644
index 000000000..f5dc710f9
--- /dev/null
+++ b/src/GF/UseGrammar/Paraphrases.hs
@@ -0,0 +1,53 @@
+module Paraphrases (mkParaphrases) where
+
+import Operations
+import AbsGFC
+import GFC
+import Look
+import CMacros ---- (mkApp, eqStrIdent)
+import AbsCompute
+import List (nub)
+
+-- paraphrases of GF terms. AR 6/10/1998 -- 24/9/1999 -- 5/7/2000 -- 5/6/2002
+-- Copyright (c) Aarne Ranta 1998--99, under GNU General Public License (see GPL)
+-- thus inherited from the old GF. Incomplete and inefficient...
+
+mkParaphrases :: CanonGrammar -> Exp -> [Exp]
+mkParaphrases st t = [t]
+---- mkParaphrases st = nub . map (beta []) . paraphrases (allDefs st)
+
+{- ----
+type Definition = (Fun,Trm)
+
+paraphrases :: [Definition] -> Trm -> [Trm]
+paraphrases th t =
+  t :
+  paraImmed th t ++
+---  paraMatch th t ++
+  case t of
+    App c a -> [App d b | d <- paraphrases th c, b <- paraphrases th a]
+    Abs x b -> [Abs x d | d <- paraphrases th b]
+    c       -> []
+
+paraImmed :: [Definition] -> Trm -> [Trm]
+paraImmed defs t = 
+  [Cn f | (f, u) <- defs, t == u] ++ --- eqTerm
+  case t of
+    Cn c -> [u | (f, u) <- defs, eqStrIdent f c]
+    _    -> []
+-}
+{- ---
+paraMatch :: [Definition] -> Trm -> [Trm]
+paraMatch th@defs t = 
+ [mkApp (Cn f) xx | (PC f zz, u) <- defs, 
+                    let (fs,sn) = fullApp u, fs == h, length sn == length zz] ++
+ case findAMatch defs t of
+   Ok (g,b) -> [substTerm [] g b]
+   _        -> []
+  where 
+    (h,xx)    = fullApp t
+    fullApp c = case c of 
+                  App f a -> (f', a' ++ [a]) where (f',a') = fullApp f
+                  c       -> (c,[])
+
+-}
diff --git a/src/GF/UseGrammar/Parsing.hs b/src/GF/UseGrammar/Parsing.hs
new file mode 100644
index 000000000..4cd4f4bc8
--- /dev/null
+++ b/src/GF/UseGrammar/Parsing.hs
@@ -0,0 +1,98 @@
+module Parsing where
+
+import CheckM
+import qualified AbsGFC as C
+import GFC
+import MkGFC (trExp) ----
+import CMacros
+import Linear
+import Str
+import CF
+import CFIdent
+import Ident
+import TypeCheck
+import Values
+--import CFMethod
+import Tokenize
+import Profile
+import Option
+import Custom
+import ShellState
+
+import Operations
+
+import List (nub)
+import Monad (liftM)
+
+-- AR 26/1/2000 -- 8/4 -- 28/1/2001 -- 9/12/2002
+
+parseString :: Options -> StateGrammar -> CFCat -> String -> Err [Tree]
+parseString os sg cat = liftM fst . parseStringMsg os sg cat
+
+parseStringMsg :: Options -> StateGrammar -> CFCat -> String -> Err ([Tree],String)
+parseStringMsg os sg cat s = do
+  (ts,(_,ss)) <- checkStart $ parseStringC os sg cat s
+  return (ts,unlines ss)
+
+parseStringC :: Options -> StateGrammar -> CFCat -> String -> Check [Tree]
+parseStringC opts0 sg cat s = do
+  let opts = unionOptions opts0 $ stateOptions sg
+      cf  = stateCF sg
+      gr  = stateGrammarST sg
+      cn  = cncId sg
+      tok = customOrDefault opts useTokenizer customTokenizer sg
+      parser = customOrDefault opts useParser customParser sg cat
+  tokens2trms opts sg cn parser (tok s)
+
+tokens2trms :: Options ->StateGrammar ->Ident -> CFParser -> [CFTok] -> Check [Tree]
+tokens2trms opts sg cn parser as = do
+  let res@(trees,info) = parser as
+  ts0 <- return $ nub (cfParseResults res)
+  ts  <- case () of
+    _ | null ts0 -> checkWarn "No success in cf parsing" >> return []
+    _ | raw      -> do
+      ts1 <- return (map cf2trm0 ts0) ----- should not need annot
+      mapM (checkErr . (annotate gr) . trExp) ts1 ---- complicated
+    _ -> do
+      (ts1,_) <- checkErr $ mapErr postParse ts0
+      ts2 <- mapM (checkErr . (annotate gr) . trExp) ts1 ---- 
+      if forgive then return ts2 else do
+        let tsss = [(t, allLinsOfTree gr cn t) | t <- ts2]
+            ps = [t | (t,ss) <- tsss, 
+                      any (compatToks as) (map str2cftoks ss)]
+        if null ps 
+           then raise $ "Failure in morphology." ++
+                  if verb 
+                     then "\nPossible corrections: " +++++ 
+                          unlines (nub (map sstr (concatMap snd tsss)))
+                     else ""
+           else return ps
+
+  if verb 
+     then checkWarn $ " the token list" +++ show as ++++ unknown as +++++ info
+     else return ()
+
+  return $ optIntOrAll opts flagNumber $ nub ts
+ where
+   gr  = stateGrammarST sg
+
+   raw     = oElem rawParse opts
+   verb    = oElem beVerbose opts
+   forgive = oElem forgiveParse opts
+
+   unknown ts = case filter noMatch ts of
+     [] -> "where all words are known"
+     us -> "with the unknown tokens" +++ show us --- needs to be fixed for literals
+   terminals = map TS $ cfTokens $ stateCF sg
+   noMatch t = all (not . compatTok t) terminals 
+     
+
+--- too much type checking in building term info? return FullTerm to save work?
+
+-- raw parsing: so simple it is for a context-free CF grammar
+cf2trm0 :: CFTree -> C.Exp
+cf2trm0 (CFTree (fun, (_, trees))) = mkAppAtom (cffun2trm fun) (map cf2trm0 trees)
+ where
+   cffun2trm (CFFun (fun,_)) = fun
+   mkApp = foldl C.EApp
+   mkAppAtom a = mkApp (C.EAtom a)
diff --git a/src/GF/UseGrammar/Randomized.hs b/src/GF/UseGrammar/Randomized.hs
new file mode 100644
index 000000000..dceb6acc6
--- /dev/null
+++ b/src/GF/UseGrammar/Randomized.hs
@@ -0,0 +1,47 @@
+module Randomized where
+
+import Abstract
+import Editing
+
+import Operations
+import Zipper
+
+--- import Arch (myStdGen) --- circular for hbc
+import Random --- (mkStdGen, StdGen, randoms) --- bad import for hbc
+
+-- random generation and refinement. AR 22/8/2001
+-- implemented as sequence of refinement menu selecsions, encoded as integers
+
+myStdGen = mkStdGen ---
+
+-- build one random tree; use mx to prevent infinite search
+mkRandomTree :: StdGen -> Int -> CGrammar -> QIdent -> Err Tree
+mkRandomTree gen mx gr cat = mkTreeFromInts (take mx (randoms gen)) gr cat
+
+refineRandom :: StdGen -> Int -> CGrammar -> Action
+refineRandom gen mx = mkStateFromInts $ take mx $ map abs (randoms gen)
+
+-- build a tree from a list of integers
+mkTreeFromInts :: [Int] -> CGrammar -> QIdent -> Err Tree
+mkTreeFromInts ints gr cat = do
+  st0   <- newCat gr cat initState
+  state <- mkStateFromInts ints gr st0
+  return $ loc2tree state
+
+mkStateFromInts :: [Int] -> CGrammar -> Action
+mkStateFromInts ints gr = mkRandomState ints where
+  mkRandomState [] state = do
+    testErr (isCompleteState state) "not completed"
+    return state
+  mkRandomState (n:ns) state = do 
+    let refs = refinementsState gr state
+    testErr (not (null refs)) $ "no refinements available for" +++ 
+                                              prt (actVal state)
+    (ref,_) <- (refs !? (n `mod` (length refs)))
+    state1  <- refineWithAtom False gr ref state
+    if isCompleteState state1 
+       then return state1
+       else do 
+         state2  <- goNextMeta state1
+	 mkRandomState ns state2
+
diff --git a/src/GF/UseGrammar/RealMoreCustom.hs b/src/GF/UseGrammar/RealMoreCustom.hs
new file mode 100644
index 000000000..b9f461a1f
--- /dev/null
+++ b/src/GF/UseGrammar/RealMoreCustom.hs
@@ -0,0 +1,122 @@
+module MoreCustom where
+
+import Operations
+import Text
+import Tokenize
+import UseGrammar
+import qualified UseSyntax as S
+import ShellState
+import Editing
+import Paraphrases
+import Option
+import CF
+import CFIdent --- (CFTok, tS)
+
+import EBNF
+import CFtoGrammar
+import PPrCF
+
+import CFtoHappy
+import Morphology
+import GrammarToHaskell
+import GrammarToCanon (showCanon)
+import GrammarToXML
+import qualified SyntaxToLatex as L
+import GFTex
+import MkResource
+import SeparateOper
+
+-- the cf parsing algorithms
+import ChartParser -- or some other CF Parser
+import Earley -- such as this one
+---- import HappyParser -- or this...
+
+import qualified PPrSRG as SRG
+import PPrGSL
+
+import qualified TransPredCalc as PC
+
+-- databases for customizable commands. AR 21/11/2001
+-- Extends ../Custom.
+
+moreCustomGrammarParser = 
+  [
+   (strCIm "gfl",  S.parseGrammar . extractGFLatex)   
+  ,(strCIm "tex",  S.parseGrammar . extractGFLatex)
+  ,(strCIm "ebnf", pAsGrammar pEBNFasGrammar)
+  ,(strCIm "cf",   pAsGrammar pCFAsGrammar)
+-- add your own grammar parsers here
+  ]
+ where
+  -- use a parser with no imports or flags
+  pAsGrammar p = err Bad (\g -> return (([],noOptions),g)) . p
+
+
+moreCustomGrammarPrinter = 
+  [
+   (strCIm "happy",   cf2HappyS . stateCF)
+  ,(strCIm "srg",     SRG.prSRG . stateCF)
+  ,(strCIm "gsl",     prGSL . stateCF)
+  ,(strCIm "gfhs",    show . stateGrammarST)
+  ,(strCIm "haskell", grammar2haskell . st2grammar . stateGrammarST)
+  ,(strCIm "xml",     unlines . prDTD . grammar2dtd . stateAbstract)
+  ,(strCIm "fullform",prFullForm . stateMorpho)
+  ,(strCIm "resource",prt . st2grammar . mkResourceGrammar . stateGrammarST)
+  ,(strCIm "resourcetypes", 
+      prt . operTypeGrammar . st2grammar . mkResourceGrammar . stateGrammarST)
+  ,(strCIm "resourcedefs", 
+      prt . operDefGrammar . st2grammar . mkResourceGrammar . stateGrammarST)
+-- add your own grammar printers here
+--- also include printing via grammar2syntax!
+  ]
+
+moreCustomSyntaxPrinter = 
+  [ 
+    (strCIm "gf",    S.prSyntax) -- DEFAULT
+   ,(strCIm "latex", L.syntax2latexfile)
+-- add your own grammar printers here
+  ]
+
+moreCustomTermPrinter = 
+  [ 
+    (strCIm "xml",    \g t -> unlines $ prElementX $ term2elemx (stateAbstract g) t)
+-- add your own term printers here
+  ]
+
+moreCustomTermCommand = 
+  [
+   (strCIm "predcalc",   \_ t -> PC.transfer t)
+-- add your own term commands here
+  ]
+
+moreCustomEditCommand = 
+  [
+-- add your own edit commands here
+  ]
+
+moreCustomStringCommand = 
+  [
+-- add your own string commands here
+  ]
+
+moreCustomParser = 
+  [
+   (strCIm "chart",    chartParser . stateCF)
+  ,(strCIm "earley",   earleyParser . stateCF)
+--  ,(strCIm "happy",     const $ lexHaskell)
+--  ,(strCIm "td",        const $ lexText)
+-- add your own parsers here
+  ]
+
+moreCustomTokenizer = 
+  [
+-- add your own tokenizers here
+  ]
+
+moreCustomUntokenizer = 
+  [
+-- add your own untokenizers here
+  ]
+
+
+strCIm = id
diff --git a/src/GF/UseGrammar/Session.hs b/src/GF/UseGrammar/Session.hs
new file mode 100644
index 000000000..bf2dd30ab
--- /dev/null
+++ b/src/GF/UseGrammar/Session.hs
@@ -0,0 +1,110 @@
+module Session where
+
+import Abstract
+import Option
+---- import Custom
+import Editing
+
+import Operations
+
+-- First version 8/2001. Adapted to GFC with modules 19/6/2003.
+-- Nothing had to be changed, which is a sign of good modularity.
+
+-- keep these abstract
+
+type SState = [(State,[Exp],SInfo)]       -- exps are candidate refinements
+type SInfo  = ([String],(Int,Options))    -- string is message, int is the view
+
+initSState :: SState
+initSState = [(initState, [], (["Select category to start"],(0,noOptions)))] 
+             -- instead of empty
+
+okInfo n = ([],(n,True))
+
+stateSState ((s,_,_):_)     = s
+candsSState ((_,ts,_):_)    = ts
+infoSState  ((_,_,i):_)     = i
+msgSState   ((_,_,(m,_)):_) = m
+viewSState  ((_,_,(_,(v,_))):_) = v
+optsSState  ((_,_,(_,(_,o))):_) = o
+
+treeSState = actTree . stateSState
+
+
+-- from state to state
+
+type ECommand = SState -> SState
+
+-- elementary commands
+
+-- change state, drop cands, drop message, preserve options
+changeState :: State -> ECommand
+changeState s ss = changeMsg [] $ (s,[],infoSState ss) : ss 
+
+changeCands :: [Exp] -> ECommand
+changeCands ts ss@((s,_,(_,b)):_) = (s,ts,(candInfo ts,b)) : ss   -- add new state
+
+changeMsg :: [String] -> ECommand
+changeMsg m ((s,ts,(_,b)):ss) = (s,ts,(m,b)) : ss   -- just change message
+
+changeView :: ECommand
+changeView ((s,ts,(m,(v,b))):ss) = (s,ts,(m,(v+1,b))) : ss    -- toggle view
+
+changeStOptions :: (Options -> Options) -> ECommand
+changeStOptions f ((s,ts,(m,(v,o))):ss) = (s,ts,(m,(v, f o))) : ss
+
+noNeedForMsg = changeMsg [] -- everything's all right: no message
+
+candInfo ts = case length ts of
+  0 -> ["no acceptable alternative"]
+  1 -> ["just one acceptable alternative"]
+  n -> [show n +++ "alternatives to select"]
+
+-- keep SState abstract from this on
+
+-- editing commands
+
+action2command :: Action -> ECommand
+action2command act state = case act (stateSState state) of 
+  Ok  s -> changeState s state 
+  Bad m -> changeMsg [m] state
+  
+action2commandNext :: Action -> ECommand -- move to next meta after execution
+action2commandNext act = action2command (\s -> act s >>= goNextMetaIfCan)
+
+undoCommand :: ECommand
+undoCommand ss@[_] = changeMsg ["cannot go back"] ss
+undoCommand (_:ss) = changeMsg ["successful undo"] ss
+
+selectCand :: CGrammar -> Int -> ECommand
+selectCand gr i state = err (\m -> changeMsg [m] state) id $ do
+  exp <- candsSState state !? i
+  let s = stateSState state
+  tree <- annotateInState gr exp s
+  return $ case replaceSubTree tree s of
+      Ok st' -> changeState st' state
+      Bad s  -> changeMsg [s] state
+
+refineByExps :: Bool -> CGrammar -> [Exp] -> ECommand
+refineByExps der gr trees = case trees of
+  [t] -> action2commandNext (refineWithExpTC der gr t)
+  _  -> changeCands trees
+
+replaceByTrees :: CGrammar -> [Exp] -> ECommand
+replaceByTrees gr trees = case trees of
+  [t] -> action2commandNext (\s -> 
+            annotateExpInState gr t s >>= flip replaceSubTree s)
+  _  -> changeCands trees
+
+{- ----
+replaceByEditCommand :: CGrammar -> String -> ECommand
+replaceByEditCommand gr co = 
+  action2command $
+  maybe return ($ gr) $
+  lookupCustom customEditCommand (strCI co) 
+
+replaceByTermCommand :: CGrammar -> String -> Exp -> ECommand
+replaceByTermCommand gr co exp = 
+  replaceByTrees gr $ maybe [exp] (\f -> f (abstractOf gr) exp) $ 
+    lookupCustom customTermCommand (strCI co) 
+-}
diff --git a/src/GF/UseGrammar/TeachYourself.hs b/src/GF/UseGrammar/TeachYourself.hs
new file mode 100644
index 000000000..9037b9198
--- /dev/null
+++ b/src/GF/UseGrammar/TeachYourself.hs
@@ -0,0 +1,69 @@
+module TeachYourself where
+
+import Operations
+import UseIO
+
+import UseGrammar
+import Linear (allLinsIfContinuous)
+import ShellState
+import API
+import Option
+
+import Random --- (randoms)  --- bad import for hbc
+import Arch (myStdGen)
+import System
+
+-- translation and morphology quiz. AR 10/5/2000 -- 12/4/2002
+
+teachTranslation :: Options -> GFGrammar -> GFGrammar -> IO ()
+teachTranslation opts ig og = do
+  tts <- transTrainList opts ig og infinity
+  let qas = [ (q, mkAnswer as) | (q,as) <- tts]
+  teachDialogue qas "Welcome to GF Translation Quiz."
+
+transTrainList :: 
+  Options -> GFGrammar -> GFGrammar -> Integer -> IO [(String,[String])]
+transTrainList opts ig og number = do
+  ts <- randomTermsIO opts ig (fromInteger number)
+  return $ map mkOne $ ts
+ where
+   cat = firstCatOpts opts ig
+   mkOne t = (norml (linearize ig t),map (norml . linearize og) (homonyms ig cat t))
+
+teachMorpho :: Options -> GFGrammar -> IO ()
+teachMorpho opts ig = useIOE () $ do
+  tts <- morphoTrainList opts ig infinity
+  let qas = [ (q, mkAnswer as) | (q,as) <- tts]
+  ioeIO $ teachDialogue qas "Welcome to GF Morphology Quiz."
+
+morphoTrainList :: Options -> GFGrammar -> Integer -> IOE [(String,[String])]
+morphoTrainList opts ig number = do
+  ts   <- ioeIO $ randomTreesIO opts ig (fromInteger number)
+  gen  <- ioeIO $ myStdGen (fromInteger number)
+  mkOnes gen ts
+ where
+   mkOnes gen (t:ts) = do
+     psss    <- ioeErr $ allLinsIfContinuous gr t
+     let pss = concat psss
+     let (i,gen') = randomR (0, length pss - 1) gen
+     (ps,ss) <- ioeErr $ pss !? i
+     (_,ss0) <- ioeErr $ pss !? 0
+     let bas = sstrV $ take 1 ss0
+     more <- mkOnes gen' ts
+     return $ (bas +++ ":" +++ unwords (map prt ps), return (sstrV ss)) : more
+   mkOnes gen [] = return []
+
+   gr = stateConcrete ig
+
+-- compare answer to the list of possible answers, increase score and give feedback 
+mkAnswer :: [String] -> String -> (Integer, String) 
+mkAnswer as s = if (elem (norml s) as) 
+                   then (1,"Yes.") 
+                   else (0,"No, not" +++ s ++ ", but" ++++ unlines as)
+
+norml = unwords . words
+
+--- the maximal number of precompiled quiz problems
+infinity :: Integer
+infinity = 123 
+
diff --git a/src/GF/UseGrammar/Tokenize.hs b/src/GF/UseGrammar/Tokenize.hs
new file mode 100644
index 000000000..dd0879931
--- /dev/null
+++ b/src/GF/UseGrammar/Tokenize.hs
@@ -0,0 +1,130 @@
+module Tokenize where
+
+import Operations
+---- import UseGrammar (isLiteral,identC)
+import CFIdent
+
+import Char
+
+-- lexers = tokenizers, to prepare input for GF grammars. AR 4/1/2002
+-- an entry for each is included in Custom.customTokenizer
+
+-- just words
+
+tokWords :: String -> [CFTok]
+tokWords = map tS . words
+
+tokLits :: String -> [CFTok]
+tokLits = map mkCFTok . words
+
+tokVars :: String -> [CFTok]
+tokVars = map mkCFTokVar . words
+
+mkCFTok :: String -> CFTok
+mkCFTok s = tS s ---- if (isLiteral s) then (mkLit s) else (tS s)
+
+mkCFTokVar :: String -> CFTok
+mkCFTokVar s = case s of
+  '?':_:_      -> tM s
+  'x':'_':_    -> tV s
+  'x':[]       -> tV s
+  '$':xs@(_:_) -> if last s == '$' then tV (init xs) else tS s
+  _            -> tS s
+
+mkLit :: String -> CFTok
+mkLit s = if (all isDigit s) then (tI s) else (tL s)
+
+mkTL :: String -> CFTok
+mkTL s = if (all isDigit s) then (tI s) else (tL ("'" ++ s ++ "'"))
+
+
+-- Haskell lexer, usable for much code
+
+lexHaskell :: String -> [CFTok]
+lexHaskell ss = case lex ss of
+  [(w@(_:_),ws)] -> tS w : lexHaskell ws
+  _ -> []
+
+-- somewhat shaky text lexer
+
+lexText :: String -> [CFTok]
+lexText = uncap . lx where
+
+  lx s = case s of
+    p : cs | isMPunct p -> tS [p] : uncap (lx cs)
+    p : cs | isPunct p  -> tS [p] : lx cs
+    s : cs | isSpace s  -> lx cs
+    _ : _  -> getWord s
+    _ -> []
+
+  getWord s  = tS w : lx ws where (w,ws) = span isNotSpec s
+  isMPunct c = elem c ".!?"
+  isPunct c  = elem c ",:;()\""
+  isNotSpec c = not (isMPunct c || isPunct c || isSpace c)
+  uncap (TS (c:cs) : ws) = tC (c:cs) : ws
+  uncap s = s
+
+-- lexer for C--, a mini variant of C
+
+lexC2M :: String -> [CFTok]
+lexC2M = lexC2M' False
+
+lexC2M' :: Bool -> String -> [CFTok]
+lexC2M' isHigherOrder s = case s of
+  '#':cs                 -> lexC $ dropWhile (/='\n') cs
+  '/':'*':cs             -> lexC $ dropComment cs
+  c:cs   | isSpace c     -> lexC cs
+  c:cs   | isAlpha c     -> getId s
+  c:cs   | isDigit c     -> getLit s
+  c:d:cs | isSymb [c,d]  -> tS [c,d] : lexC cs
+  c:cs   | isSymb [c]    -> tS [c]   : lexC cs
+  _                      -> [] --- covers end of file and unknown characters
+ where
+  lexC = lexC2M' isHigherOrder
+  getId s  = mkT i : lexC cs where (i,cs) = span isIdChar s
+  getLit s = tI i  : lexC cs where (i,cs) = span isDigit s
+  isIdChar c = isAlpha c || isDigit c || elem c "'_"
+  isSymb = reservedAnsiCSymbol 
+  dropComment s = case s of
+    '*':'/':cs -> cs
+    _:cs -> dropComment cs
+    _ -> []
+  mkT i = if (isRes i) then (tS i) else 
+            if isHigherOrder then (tV i) else (tL ("'" ++ i ++ "'"))
+  isRes = reservedAnsiC
+
+
+reservedAnsiCSymbol s = case lookupTree show s ansiCtree of
+  Ok True -> True 
+  _ -> False
+
+reservedAnsiC s = case lookupTree show s ansiCtree of
+  Ok False -> True 
+  _ -> False
+
+-- for an efficient lexer: precompile this!
+ansiCtree = buildTree $ [(s,True)  | s <- reservedAnsiCSymbols] ++
+                        [(s,False) | s <- reservedAnsiCWords]
+
+reservedAnsiCSymbols = words $
+    "<<= >>= << >> ++ -- == <= >= *= += -= %= /= &= ^= |= " ++ 
+    "^ { } = , ; + * - ( ) < > & % ! ~"
+
+reservedAnsiCWords = words $ 
+    "auto break case char const continue default " ++ 
+    "do double else enum extern float for goto if int " ++
+    "long register return short signed sizeof static struct switch typedef " ++
+    "union unsigned void volatile while " ++
+    "main printin putchar"  --- these are not ansi-C
+
+-- turn unknown tokens into string literals; not recursively for literals 123, 'foo'
+
+unknown2string :: (String -> Bool) -> [CFTok] -> [CFTok]
+unknown2string isKnown = map mkOne where
+  mkOne t@(TS s) = if isKnown s then t else mkTL s
+  mkOne t@(TC s) = if isKnown s then t else mkTL s
+  mkOne t        = t
+
+lexTextLiteral    isKnown = unknown2string isKnown . lexText
+lexHaskellLiteral isKnown = unknown2string isKnown . lexHaskell
+
diff --git a/src/HelpFile.hs b/src/HelpFile.hs
new file mode 100644
index 000000000..224535134
--- /dev/null
+++ b/src/HelpFile.hs
@@ -0,0 +1,376 @@
+module HelpFile where
+
+txtHelpFile =
+  "\n-- commands that change the state" ++
+  "\n" ++
+  "\ni, import: i File" ++
+  "\n      Reads a grammar from File and compiles it into a GF runtime grammar." ++
+  "\n      Files \"include\"d in File are read recursively, nubbing repetitions." ++
+  "\n      If a grammar with the same language name is already in the state," ++
+  "\n      it is overwritten - but only if compilation succeeds. " ++
+  "\n      The grammar parser depends on the file name suffix:" ++
+  "\n        .gf    normal GF source " ++
+  "\n        .gfl   LaTeX file with grammar in \\begGF..\\end{verbatim} environments" ++
+  "\n        .tex   LaTeX file with grammar in \\begGF..\\end{verbatim} environments" ++
+  "\n        .gfc   already optimized - skip compilation and type checking" ++
+  "\n        .gfhc  already compiled (a Haskell data object)" ++
+  "\n        .ebnf  EBNF format" ++
+  "\n        .cf    Context-free format" ++
+  "\n  options:" ++
+  "\n      -v            verbose: give lots of messages " ++
+  "\n      -s            silent: don't give error messages" ++
+  "\n      -opt          perform branch-sharing optimization" ++
+  "\n      -retain       retain oper and lintype definitions" ++
+  "\n      -nocf         don't build context-free grammar (thus no parser)" ++
+  "\n      -nocheckcirc  don't eliminate circular rules from CF " ++
+  "\n      -nocirc       do eliminate circ rules (default; currently just explicit ones)" ++
+  "\n  flags:" ++
+  "\n      -lang    set the name used for the grammar in the session" ++
+  "\n" ++
+  "\nrl, remove language: rl Language" ++
+  "\n      Takes away the language from the state." ++
+  "\n" ++
+  "\ne,  empty state: e" ++
+  "\n      Takes away all languages and resets all global flags." ++
+  "\n" ++
+  "\nsf, set flags: sf Language? Flag*" ++
+  "\n      The values of the Flags are set for Language. If no language" ++
+  "\n      is specified, the flags are set globally." ++
+  "\n" ++
+  "\n-- commands that give information about the state" ++
+  "\n" ++
+  "\npg, print grammar: pg" ++
+  "\n      Prints the actual grammar (overridden by the -lang=X flag)." ++
+  "\n      The -printer=X flag sets the format in which the grammar is" ++
+  "\n      written." ++
+  "\n      N.B. since grammars are compiled when imported, this command" ++
+  "\n      generally does not show the grammar in the same format as the" ++
+  "\n      source. In particular, the -printer=latex is not supported. " ++
+  "\n      Use the command tg -printer=latex File to print the source " ++
+  "\n      grammar in LaTeX." ++
+  "\n  options:" ++
+  "\n      -utf8  apply UTF8-encoding to the grammar" ++
+  "\n" ++
+  "\n  flags: " ++
+  "\n      -printer" ++
+  "\n      -lang" ++
+  "\n      " ++
+  "\n" ++
+  "\npm, print multigrammar: pm" ++
+  "\n      Prints the current multilingual grammar into a Haskell file" ++
+  "\n      in a canonical format (usable by the canonical GF editor)." ++
+  "\n  options" ++
+  "\n      -opt perform branch-sharing optimization (should not have been done at import)" ++
+  "\n" ++
+  "\npo, print options: po" ++
+  "\n      Prints those flag values in the current state that differ from defaults." ++
+  "\n" ++
+  "\npl, print languages: pl" ++
+  "\n      Prints the names of currently available languages." ++
+  "\n" ++
+  "\n" ++
+  "\n-- commands that execute and show the session history" ++
+  "\n" ++
+  "\neh, execute history: eh File" ++
+  "\n      Executes commands in the file." ++
+  "\n" ++
+  "\nph, print history; ph" ++
+  "\n      Prints the commands issued during the GF session." ++
+  "\n      The result is readable by the eh command." ++
+  "\n      HINT: write \"ph | wf foo.hist\" to save the history." ++
+  "\n" ++
+  "\n" ++
+  "\n-- linearization, parsing, translation, and computation" ++
+  "\n" ++
+  "\nl,  linearize: l PattList? Tree" ++
+  "\n      Shows all linearization forms of Tree by the actual grammar" ++
+  "\n      (which is overridden by the -lang flag). " ++
+  "\n      The pattern list has the form [P, ... ,Q] where P,...,Q follow GF " ++
+  "\n      syntax for patterns. All those forms are generated that match with the" ++
+  "\n      pattern list. Too short lists are filled with variables in the end." ++
+  "\n      Only the -table flag is available if a pattern list is specified." ++
+  "\n      HINT: see GF language specification for the syntax of Pattern and Term." ++
+  "\n      You can also copy and past parsing results." ++
+  "\n  options:  " ++
+  "\n      -table   show parameters" ++
+  "\n      -struct  bracketed form" ++
+  "\n      -record  record, i.e. explicit GF concrete syntax term" ++
+  "\n  flags:" ++
+  "\n      -lang    linearize in this grammar" ++
+  "\n      -number  give this number of forms at most" ++
+  "\n      -unlexer filter output through unlexer" ++
+  "\n" ++
+  "\np,  parse: p String" ++
+  "\n      Shows all Trees returned for String by the actual" ++
+  "\n      grammar (overridden by the -lang flag), in the category S (overridden" ++
+  "\n      by the -cat flag)." ++
+  "\n  options:" ++
+  "\n      -n       non-strict: tolerates morphological errors" ++
+  "\n      -ign     ignore unknown words when parsing" ++
+  "\n      -raw     return context-free terms in raw form" ++
+  "\n      -v       verbose: give more information if parsing fails" ++
+  "\n  flags:" ++
+  "\n      -cat     parse in this category" ++
+  "\n      -lang    parse in this grammar" ++
+  "\n      -lexer   filter input through this lexer" ++
+  "\n      -parser  use this context-free parsing method" ++
+  "\n      -number  return this many results at most" ++
+  "\n" ++
+  "\ntt, test tokenizer: tt String" ++
+  "\n      Show the token list sent to the parser when String is parsed." ++
+  "\n      HINT: can be useful when debugging the parser." ++
+  "\n  flags: " ++
+  "\n     -lexer    use this lexer" ++
+  "\n" ++
+  "\ncc, compute concrete: cc Term" ++
+  "\n      Compute a term by concrete syntax definitions. " ++
+  "\n      N.B. You need the flag -retain when importing the grammar, if you want " ++
+  "\n      the oper definitions to be retained after compilation; otherwise this" ++
+  "\n      command does not expand oper constants." ++
+  "\n      N.B.' The resulting Term is not a term in the sense of abstract syntax," ++
+  "\n      and hence not a valid input to a Tree-demanding command." ++
+  "\n  flags:" ++
+  "\n     -lang" ++
+  "\n" ++
+  "\nt, translate: t Lang Lang String" ++
+  "\n      Parses String in Lang1 and linearizes the resulting Trees in Lang2." ++
+  "\n  flags:" ++
+  "\n      -cat" ++
+  "\n      -lexer" ++
+  "\n      -parser" ++
+  "\n" ++
+  "\ngr, generate random: gr" ++
+  "\n      Generates a random Tree." ++
+  "\n  flags:" ++
+  "\n      -cat     generate in this category" ++
+  "\n      -lang    use the abstract syntax of this grammar" ++
+  "\n      -number  generate this number of trees" ++
+  "\n      -depth   use this number of search steps at most" ++
+  "\n" ++
+  "\nma, morphologically analyse: ma String" ++
+  "\n      Runs morphological analysis on each word in String and displays" ++
+  "\n      the results line by line." ++
+  "\n  options:" ++
+  "\n      -short   show analyses in bracketed words, instead of separate lines" ++
+  "\n  flags:" ++
+  "\n      -lang" ++
+  "\n" ++
+  "\n" ++
+  "\n-- elementary generation of Strings and Trees" ++
+  "\n" ++
+  "\nps, put string: ps String" ++
+  "\n      Returns its argument String, like Unix echo." ++
+  "\n      HINT. The strength of ps comes from the possibility to receive the argument" ++
+  "\n      from a pipeline, and altering it by the -filter flag." ++
+  "\n  flags:" ++
+  "\n      -filter  filter the result through this string processor " ++
+  "\n      -length  cut the string after this number of characters" ++
+  "\n" ++
+  "\npt, put tree: pt Tree" ++
+  "\n      Returns its argument Tree, like a specialized Unix echo." ++
+  "\n      HINT. The strength of pt comes from the possibility to receive the argument" ++
+  "\n      from a pipeline, and altering it by the -transform flag." ++
+  "\n  flags:" ++
+  "\n      -transform   transform the result by this term processor" ++
+  "\n      -number      generate this number of terms at most" ++
+  "\n" ++
+  "\nst, show tree: st Tree" ++
+  "\n      Prints the tree as a string. Unlike pt, this command cannot be" ++
+  "\n      used in a pipe to produce a tree, since its output is a string." ++
+  "\n  flags:" ++
+  "\n      -printer     show the tree in a special format (-printer=xml supported)" ++
+  "\n" ++
+  "\nwt, wrap tree: wt Fun Tree" ++
+  "\n      Returns its argument Tree wrapped in the function Fun." ++
+  "\n  flags:" ++
+  "\n      -c           compute the resulting tree" ++
+  "\n" ++
+  "\n" ++
+  "\n-- subshells" ++
+  "\n" ++
+  "\nes, editing session: es" ++
+  "\n      Opens an interactive editing session." ++
+  "\n      N.B. Exit from a Fudget session is to the Unix shell, not to GF. " ++
+  "\n  options:" ++
+  "\n      -f Fudget GUI (necessary for Unicode; only available in X Window System)" ++
+  "\n" ++
+  "\nts, translation session: ts" ++
+  "\n      Translates input lines from any of the actual languages to any other one." ++
+  "\n      To exit, type a full stop (.) alone on a line." ++
+  "\n      N.B. Exit from a Fudget session is to the Unix shell, not to GF. " ++
+  "\n      HINT: Set -parser and -lexer locally in each grammar." ++
+  "\n  options:" ++
+  "\n      -f Fudget GUI (necessary for Unicode; only available in X Window System)" ++
+  "\n  flags:" ++
+  "\n      -cat" ++
+  "\n" ++
+  "\ntq, translation quiz: tq Lang Lang" ++
+  "\n      Random-generates translation exercises from Lang1 to Lang2," ++
+  "\n      keeping score of success." ++
+  "\n      To interrupt, type a full stop (.) alone on a line." ++
+  "\n      HINT: Set -parser and -lexer locally in each grammar." ++
+  "\n  flags:" ++
+  "\n      -cat" ++
+  "\n" ++
+  "\ntl, translation list: tl Lang Lang Int" ++
+  "\n      Random-generates a list of Int translation exercises from Lang1 to Lang2." ++
+  "\n      HINT: use wf to save the exercises in a file." ++
+  "\n  flags:" ++
+  "\n      -cat" ++
+  "\n" ++
+  "\nmq, morphology quiz: mq" ++
+  "\n      Random-generates morphological exercises," ++
+  "\n      keeping score of success." ++
+  "\n      To interrupt, type a full stop (.) alone on a line." ++
+  "\n      HINT: use printname judgements in your grammar to" ++
+  "\n      produce nice expressions for desired forms." ++
+  "\n  flags:" ++
+  "\n      -cat" ++
+  "\n      -lang" ++
+  "\n" ++
+  "\nml, morphology list: tl Int" ++
+  "\n      Random-generates a list of Int morphological exercises," ++
+  "\n      keeping score of success." ++
+  "\n      HINT: use wf to save the exercises in a file." ++
+  "\n  flags:" ++
+  "\n      -cat" ++
+  "\n      -lang" ++
+  "\n" ++
+  "\n" ++
+  "\n-- IO related commands" ++
+  "\n" ++
+  "\nrf, read file: rf File" ++
+  "\n      Returns the contents of File as a String; error is File does not exist." ++
+  "\n" ++
+  "\nwf, write file: wf File String" ++
+  "\n      Writes String into File; File is created if it does not exist." ++
+  "\n      N.B. the command overwrites File without a warning." ++
+  "\n" ++
+  "\naf, append file: af File" ++
+  "\n      Writes String into the end of File; File is created if it does not exist." ++
+  "\n" ++
+  "\ntg, transform grammar: tg File" ++
+  "\n      Reads File, parses as a grammar, but instead of compiling further, prints it. " ++
+  "\n      The environment is not changed. When parsing the grammar, the same file" ++
+  "\n      name suffixes are supported as in the i command." ++
+  "\n      HINT: use this command to print the grammar in another format (the -printer" ++
+  "\n      flag); pipe it to wf to save this format." ++
+  "\n  flags:" ++
+  "\n      -printer  (only -printer=latex supported currently)" ++
+  "\n" ++
+  "\ncl, convert latex: cl File" ++
+  "\n      Reads File, which is expected to be in LaTeX form." ++
+  "\n      Two environments are treated in special ways:" ++
+  "\n      \\begGF    - \\end{verbatim}, which contains GF judgements," ++
+  "\n      \\begTGF   - \\end{verbatim}, which contains a GF expression (displayed), and" ++
+  "\n      \\begInTGF - \\end{verbatim}, which contains a GF expressions (inlined)." ++
+  "\n      Moreover, certain macros should be included in the file; you can" ++
+  "\n      get those macros by applying 'tg -printer=latex foo.gf' to any grammar" ++
+  "\n      foo.gf. Notice that the same File can be imported as a GF grammar," ++
+  "\n      consisting of all the judgements in \\begGF environments." ++
+  "\n      HINT: pipe with 'wf Foo.tex' to generate a new Latex file." ++
+  "\n" ++
+  "\nsa, speak aloud: sa String" ++
+  "\n      Uses the Festival speech generator to produce speech for String." ++
+  "\n      The command cupports Festival's language flag, which is sent verbatim" ++
+  "\n      to Festival, e.g. -language=spanish. Omitting this flag gives the " ++
+  "\n      system-dependent default voice (often British English)." ++
+  "\n     flags:" ++
+  "\n       -language" ++
+  "\n" ++
+  "\nh, help: h" ++
+  "\n      Displays this help message." ++
+  "\n" ++
+  "\nq, quit: q" ++
+  "\n      Exits GF." ++
+  "\n      HINT: you can use 'ph | wf history' to save your session." ++
+  "\n" ++
+  "\n!, system command: ! String" ++
+  "\n      Issues a system command. No value is returned to GF." ++
+  "\n" ++
+  "\n" ++
+  "\n" ++
+  "\n-- Flags. The availability of flags is defined separately for each command." ++
+  "\n" ++
+  "\n-cat: category in which parsing is performed." ++
+  "\n      The default is S." ++
+  "\n" ++
+  "\n-depth: the search depth in e.g. random generation." ++
+  "\n      The default depends on application." ++
+  "\n" ++
+  "\n-filter: operation performed on a string. The default is identity." ++
+  "\n    -filter=identity     no change" ++
+  "\n    -filter=erase        erase the text" ++
+  "\n    -filter=take100      show the first 100 characters" ++
+  "\n    -filter=length       show the length of the string" ++
+  "\n    -filter=text         format as text (punctuation, capitalization)" ++
+  "\n    -filter=code         format as code (spacing, indentation)" ++
+  "\n    -filter=latexfile    embed in a LaTeX file " ++
+  "\n" ++
+  "\n-lang: grammar used when executing a grammar-dependent command." ++
+  "\n       The default is the last-imported grammar." ++
+  "\n" ++
+  "\n-language: voice used by Festival as its --language flag in the sa command. " ++
+  "\n       The default is system-dependent. " ++
+  "\n" ++
+  "\n-length: the maximum number of characters shown of a string. " ++
+  "\n       The default is unlimited." ++
+  "\n" ++
+  "\n-lexer: tokenization transforming a string into lexical units for a parser." ++
+  "\n       The default is words." ++
+  "\n    -lexer=words         tokens are separated by spaces or newlines" ++
+  "\n    -lexer=literals      like words, but GF integer and string literals recognized" ++
+  "\n    -lexer=vars          like words, but \"x\",\"x_...\",\"$...$\" as vars, \"?...\" as meta" ++
+  "\n    -lexer=chars         each character is a token" ++
+  "\n    -lexer=code          use Haskell's lex" ++
+  "\n    -lexer=text          with conventions on punctuation and capital letters" ++
+  "\n    -lexer=codelit       like code, but treat unknown words as string literals" ++
+  "\n    -lexer=textlit       like text, but treat unknown words as string literals" ++
+  "\n    -lexer=codeC         use a C-like lexer" ++
+  "\n" ++
+  "\n-number: the maximum number of generated items in a list. " ++
+  "\n       The default is unlimited." ++
+  "\n" ++
+  "\n-parser: Context-free    parsing algorithm. The default is chart." ++
+  "\n    -parser=earley       Earley algorithm" ++
+  "\n    -parser=chart        bottom-up chart parser" ++
+  "\n" ++
+  "\n-printer: format in which the grammar is printed. The default is gf." ++
+  "\n    -printer=gf             GF grammar" ++
+  "\n    -printer=cf             context-free grammar" ++
+  "\n    -printer=resource       resource grammar (cat+lincat, fun+lin --> oper)" ++
+  "\n    -printer=resourcetypes  resource grammar type signatures" ++
+  "\n    -printer=resourcedefs   resource grammar operation definitions" ++
+  "\n    -printer=happy          source file for Happy parser generator" ++
+  "\n    -printer=srg            speech recognition grammar" ++
+  "\n    -printer=canon          grammar compiled into a canonical form, Haskell module" ++
+  "\n    -printer=canonOpt       canonical form, with branch-sharing optimization" ++
+  "\n    -printer=gfhs           compiled grammar as Haskell data object" ++
+  "\n    -printer=haskell        abstract syntax in Haskell, with translations to/from GF" ++
+  "\n    -printer=morpho         full-form lexicon, long format" ++
+  "\n    -printer=latex          LaTeX file (for the tg command)" ++
+  "\n    -printer=fullform       full-form lexicon, short format" ++
+  "\n    -printer=xml            XML: DTD for the pg command, object for st" ++
+  "\n" ++
+  "\n-startcat: like -cat, but used in grammars (to avoid clash with the keyword cat)" ++
+  "\n" ++
+  "\n-transform: transformation performed on a syntax tree. The default is identity." ++
+  "\n    -transform=identity  no change" ++
+  "\n    -transform=compute   compute by using definitions in the grammar" ++
+  "\n    -transform=typecheck return the term only if it is type-correct" ++
+  "\n    -transform=solve     solve metavariables as derived refinements" ++
+  "\n    -transform=context   solve metavariables by unique refinements as variables" ++
+  "\n    -transform=delete    replace the term by metavariable" ++
+  "\n    -transform=predcalc  generating sentences from predicate calculus formulas" ++
+  "\n" ++
+  "\n-unlexer: untokenization transforming linearization output into a string." ++
+  "\n       The default is unwords." ++
+  "\n    -unlexer=unwords     space-separated token list (like unwords)" ++
+  "\n    -unlexer=text        format as text: punctuation, capitalization, paragraph <p>" ++
+  "\n    -unlexer=code        format as code (spacing, indentation)" ++
+  "\n    -unlexer=textlit     like text, but remove string literal quotes" ++
+  "\n    -unlexer=codelit     like code, but remove string literal quotes" ++
+  "\n    -unlexer=concat      remove all spaces" ++
+  "\n    -unlexer=bind        like identity, but bind at \"&+\"" ++
+  "\n" ++
+  []
\ No newline at end of file
diff --git a/src/JavaGUI/DynamicTree.java b/src/JavaGUI/DynamicTree.java
new file mode 100644
index 000000000..6acc6ff64
--- /dev/null
+++ b/src/JavaGUI/DynamicTree.java
@@ -0,0 +1,272 @@
+

+/*

+ * This code is based on an example provided by Richard Stanford, 

+ * a tutorial reader.

+ */

+

+import java.awt.*;

+import javax.swing.*;

+import javax.swing.tree.*;

+import javax.swing.event.*;

+import java.util.Vector;

+import java.awt.event.*;

+

+public class DynamicTree extends JPanel implements KeyListener,

+                                           ActionListener{

+    public static DefaultMutableTreeNode rootNode;

+    protected DefaultTreeModel treeModel;

+    public JTree tree;

+    public int oldSelection = 0;

+    private Toolkit toolkit = Toolkit.getDefaultToolkit();

+    JPopupMenu popup = new JPopupMenu();

+    JMenuItem menuItem;

+    Timer timer = new Timer(500, this);

+    MouseEvent m;

+    

+    public DynamicTree() {

+        timer.setRepeats(false);

+        rootNode = new DefaultMutableTreeNode("Root Node");

+        treeModel = new DefaultTreeModel(rootNode);

+        treeModel.addTreeModelListener(new MyTreeModelListener());

+

+        tree = new JTree(treeModel);

+        tree.setRootVisible(false);

+        tree.setEditable(false);

+        tree.getSelectionModel().setSelectionMode

+                (TreeSelectionModel.SINGLE_TREE_SELECTION);

+        tree.addKeyListener(this);

+        menuItem = new JMenuItem("Paste");

+        menuItem.addActionListener(this);

+        popup.add(menuItem);                         

+            

+        //Add listener to components that can bring up popup menus.

+        MouseListener popupListener = new PopupListener();

+        tree.addMouseListener(popupListener);

+              

+        tree.addTreeSelectionListener(new TreeSelectionListener() {

+           public void valueChanged(TreeSelectionEvent e) {

+             if  (tree.getSelectionRows()!=null) {

+               if (GFEditor.nodeTable == null)

+                  {if (GFEditor.debug) System.out.println("null node table");}

+               else

+                 {if (GFEditor.debug) System.out.println("node table: "+

+                   GFEditor.nodeTable.contains(new Integer(0)) +" "+ 

+                   GFEditor.nodeTable.keys().nextElement()); }

+               if (tree.getSelectionPath() == null)

+                 {if (GFEditor.debug) System.out.println("null root path"); }

+               else

+                 {if (GFEditor.debug) System.out.println("selected path"+

+                        tree.getSelectionPath());} 

+               int i = ((Integer)GFEditor.nodeTable.get(

+                       tree.getSelectionPath())).intValue();

+               int j = oldSelection;    

+               GFEditor.treeChanged = true; 

+               if (i>j) GFEditor.send("> "+String.valueOf(i-j)); 

+               else GFEditor.send("< "+String.valueOf(j-i));               

+            }          

+          }

+        });

+

+        tree.setCellRenderer(new MyRenderer());

+        tree.setShowsRootHandles(true);

+        setPreferredSize(new Dimension(200, 100));

+        JScrollPane scrollPane = new JScrollPane(tree);

+        setLayout(new GridLayout(1,0));

+        add(scrollPane);

+    }

+

+    /** Remove all nodes except the root node. */

+    public void clear() {

+        rootNode.removeAllChildren();

+        treeModel.reload();

+    }

+

+    /** Remove the currently selected node. */

+    public void removeCurrentNode() {

+        TreePath currentSelection = tree.getSelectionPath();

+        if (currentSelection != null) {

+            DefaultMutableTreeNode currentNode = (DefaultMutableTreeNode)

+                         (currentSelection.getLastPathComponent());

+            MutableTreeNode parent = (MutableTreeNode)(currentNode.getParent());

+            if (parent != null) {

+                treeModel.removeNodeFromParent(currentNode);

+                return;

+            }

+        } 

+

+        // Either there was no selection, or the root was selected.

+        toolkit.beep();

+    }

+

+    /** Add child to the currently selected node. */

+    public DefaultMutableTreeNode addObject(Object child) {

+        DefaultMutableTreeNode parentNode = null;

+        TreePath parentPath = tree.getSelectionPath();

+

+        if (parentPath == null) {

+            parentNode = rootNode;

+        } else {

+            parentNode = (DefaultMutableTreeNode)

+                         (parentPath.getLastPathComponent());

+        }

+

+        return addObject(parentNode, child, true);

+    }

+

+    public DefaultMutableTreeNode addObject(DefaultMutableTreeNode parent,

+                                            Object child) {

+        return addObject(parent, child, false);

+    }

+

+    public DefaultMutableTreeNode addObject(DefaultMutableTreeNode parent,

+                                            Object child, 

+                                            boolean shouldBeVisible) {

+        DefaultMutableTreeNode childNode = 

+                new DefaultMutableTreeNode(child);

+

+        if (parent == null) {

+            parent = rootNode;

+        }

+

+        treeModel.insertNodeInto(childNode, parent, 

+                                 parent.getChildCount());

+

+        // Make sure the user can see the lovely new node.

+        if (shouldBeVisible) {

+            tree.scrollPathToVisible(new TreePath(childNode.getPath()));

+        }

+        return childNode;

+    }

+

+    class MyTreeModelListener implements TreeModelListener {

+        public void treeNodesChanged(TreeModelEvent e) {

+            DefaultMutableTreeNode node;

+            node = (DefaultMutableTreeNode)

+                     (e.getTreePath().getLastPathComponent());

+

+            /*

+             * If the event lists children, then the changed

+             * node is the child of the node we've already

+             * gotten.  Otherwise, the changed node and the

+             * specified node are the same.

+             */

+            try {

+                int index = e.getChildIndices()[0];

+                node = (DefaultMutableTreeNode)

+                       (node.getChildAt(index));

+            } catch (NullPointerException exc) {}

+

+            if (GFEditor.debug) System.out.println

+                            ("The user has finished editing the node.");

+            if (GFEditor.debug) System.out.println(

+                            "New value: " + node.getUserObject());

+        }

+        public void treeNodesInserted(TreeModelEvent e) {

+        }

+        public void treeNodesRemoved(TreeModelEvent e) {

+        }

+        public void treeStructureChanged(TreeModelEvent e) {

+        }

+    }

+

+    private class MyRenderer extends DefaultTreeCellRenderer {

+        ImageIcon tutorialIcon;

+

+        public MyRenderer() {

+            tutorialIcon = new ImageIcon("images/middle.gif");

+        }

+

+        public Component getTreeCellRendererComponent(

+                            JTree tree,

+                            Object value,

+                            boolean sel,

+                            boolean expanded,

+                            boolean leaf,

+                            int row,

+                            boolean hasFocus) {

+

+            super.getTreeCellRendererComponent(

+                            tree, value, sel,

+                            expanded, leaf, row,

+                            hasFocus);

+            if (leaf && isTutorialBook(value)) 

+                setIcon(tutorialIcon);

+                

+           return this;

+        }

+        protected boolean isTutorialBook(Object value) {

+            DefaultMutableTreeNode node =

+                    (DefaultMutableTreeNode)value;

+            String nodeInfo = 

+                    (String)(node.getUserObject());

+           

+            if (nodeInfo.indexOf("?") >= 0) {

+                return true;

+            } 

+

+            return false;

+        }

+

+    }//class

+

+    class PopupListener extends MouseAdapter {

+        public void mousePressed(MouseEvent e) {

+            int selRow = tree.getRowForLocation(e.getX(), e.getY());

+            tree.setSelectionRow(selRow);

+            if (GFEditor.debug) System.out.println("selection changed!");

+            maybeShowPopup(e);

+        }

+

+        public void mouseReleased(MouseEvent e) {

+            if (GFEditor.debug) System.out.println("mouse released!");

+            maybeShowPopup(e);

+        }

+    }

+    void maybeShowPopup(MouseEvent e) {

+         if (GFEditor.debug) System.out.println("may be!");        

+         if (e.isPopupTrigger()) {

+            m=e;

+            timer.start();

+         } 

+    }

+    void addMenuItem(String name){

+                menuItem = new JMenuItem(name);

+                menuItem.addActionListener(this);

+                popup.add(menuItem);

+

+    }

+

+    public void actionPerformed(ActionEvent ae)

+    { 

+      if (ae.getSource()==timer){

+            if (GFEditor.debug) System.out.println("changing menu!");

+            popup.removeAll();

+            for (int i = 0; i<GFEditor.listModel.size() ; i++) 

+                addMenuItem(GFEditor.listModel.elementAt(i).toString());

+            popup.show(m.getComponent(), m.getX(), m.getY());

+       }

+       else{

+         GFEditor.treeChanged = true; 

+         GFEditor.send((String)GFEditor.commands.elementAt

+               (popup.getComponentIndex((JMenuItem)(ae.getSource()))));

+       }                   

+    }

+

+    /** Handle the key pressed event. */

+    public void keyPressed(KeyEvent e) {

+        int keyCode = e.getKeyCode();   

+        switch (keyCode){ 

+        case 32:  GFEditor.send("'"); break;

+        case 127: GFEditor.send("d"); break;

+        }

+    }

+    /** Handle the key typed event. */

+    public void keyTyped(KeyEvent e) {

+    }

+    /** Handle the key released event. */

+    public void keyReleased(KeyEvent e) {

+    }

+

+}

+

+

diff --git a/src/JavaGUI/GFEditor.java b/src/JavaGUI/GFEditor.java
new file mode 100644
index 000000000..2625f2e3a
--- /dev/null
+++ b/src/JavaGUI/GFEditor.java
@@ -0,0 +1,1420 @@
+//package javaGUI;                                 

+

+import java.awt.*;

+import java.awt.event.*;

+import javax.swing.*;

+import javax.swing.text.*;

+import javax.swing.event.*;

+import javax.swing.tree.*;

+import java.io.*;

+import java.util.*;

+//import gfWindow.GrammarFilter;

+

+public class GFEditor extends JFrame implements ActionListener, KeyListener {

+

+    public static boolean debug = false;

+    public static boolean newObject = false;

+    public static boolean finished = false;

+    private String parseInput = "";

+    private String alphaInput = "";

+    private static String status = "status";

+    private static String selectedMenuLanguage = "Abstract";

+    private static String linearization = "";

+    private String termInput = "";    

+    private static String outputString = "";

+    private static String treeString = "";

+    private static String fileString = "";

+    public static Vector commands = new Vector();

+    public static Hashtable nodeTable = new Hashtable();

+    JFileChooser fc1 = new  JFileChooser("./");

+    JFileChooser fc = new  JFileChooser("./");

+    private String [] filterMenu = {"Filter", "identity", 

+         "erase", "take100", "text", "code", "latexfile", 

+                        "structured", "unstructured" };

+    private String [] modifyMenu = {"Modify", "identity","transfer", 

+         "compute", "paraphrase", "typecheck", "solve", "context" };

+//    private String [] modeMenu = {"Menus", "printname", 

+//         "plain", "short", "long", "typed", "untyped" };

+    private static String [] newMenu = {"New"};

+

+    private static boolean firstLin = true;

+    private static boolean waiting = false;

+    public static boolean treeChanged = true;

+    private static String result;

+    private static int selectionStart;

+    private static int selectionEnd;

+    private static BufferedReader fromProc;   

+    private static BufferedWriter toProc;

+    private static String commandPath = new String("GF");

+    private static JTextArea output = new JTextArea();

+    public static DefaultListModel listModel= new DefaultListModel();

+    private JList list = new JList(listModel);

+    private static DynamicTree tree = new DynamicTree();

+ 

+    private JLabel grammar = new JLabel("No topic          ");   

+    private JButton save = new JButton("Save");   

+    private JButton open = new JButton("Open");   

+    private JButton newTopic = new JButton("New Topic");   

+    private JButton gfCommand = new JButton("GF command");   

+    

+    private JButton leftMeta = new JButton("?<");   

+    private JButton left = new JButton("<");   

+    private JButton top = new JButton("Top");   

+    private JButton right = new JButton(">");

+    private JButton rightMeta = new JButton(">?");

+    private JButton read = new JButton("Read");   

+  //  private JButton parse = new JButton("Parse");   

+  //  private JButton term = new JButton("Term");   

+    private JButton alpha = new JButton("Alpha");   

+    private JButton random = new JButton("Random");   

+    private JButton undo = new JButton("Undo");   

+

+    private JPanel inputPanel = new JPanel();   

+    private JPanel inputPanel2 = new JPanel();   

+    private JPanel inputPanel3 = new JPanel();   

+    private JButton ok = new JButton("OK");   

+    private JButton cancel = new JButton("Cancel");   

+    private JTextField inputField = new JTextField();   

+    private JLabel inputLabel = new JLabel("Read: ");   

+    private JButton browse = new JButton("Browse...");

+    private ButtonGroup readGroup = new ButtonGroup();

+    private JRadioButton termReadButton = new JRadioButton("Term");

+    private JRadioButton stringReadButton = new JRadioButton("String");

+

+    private JDialog dialog;

+   

+    private static JComboBox menu = new JComboBox(newMenu);      

+    private JComboBox filter = new JComboBox(filterMenu);   

+    private JComboBox modify = new JComboBox(modifyMenu);   

+  //  private JComboBox mode = new JComboBox(modeMenu);   

+

+    private JPanel downPanel = new JPanel();

+    private JSplitPane treePanel; 

+    private JPanel upPanel = new JPanel();

+    private JPanel middlePanel = new JPanel();

+    private JPanel middlePanelUp = new JPanel();

+    private JPanel middlePanelDown = new JPanel();

+    private JSplitPane centerPanel;

+    private static JFrame gui2 = new JFrame();

+    private JPanel centerPanel2= new JPanel();

+    private JPanel centerPanelDown = new JPanel();

+    private JScrollPane outputPanelDown = new JScrollPane(list); 

+    private JScrollPane outputPanelCenter = new JScrollPane(output);

+    private JPanel outputPanelUp = new JPanel();

+    private JPanel statusPanel = new JPanel();

+    private static JLabel statusLabel = new JLabel(status);

+    private    Container cp;

+

+    private   static  JMenuBar menuBar= new JMenuBar();;

+    private   static  ButtonGroup menuGroup = new ButtonGroup();

+    private   JMenu viewMenu= new JMenu("View");

+    private   JMenu submenu= new JMenu("language");

+    private   JMenu modeMenu= new JMenu("Menus");

+    private   static JMenu langMenu= new JMenu("Languages");

+    private   static JMenu fileMenu= new JMenu("File");

+    private JRadioButtonMenuItem rbMenuItem;

+    private JRadioButtonMenuItem rbMenuItemLong;

+   // private JRadioButtonMenuItem rbMenuItemAbs;

+    private JRadioButtonMenuItem rbMenuItemUnTyped;

+    private static JMenuItem fileMenuItem;

+    private static JCheckBoxMenuItem cbMenuItem;

+    private static RadioListener myListener ;     

+    private static ButtonGroup group = new ButtonGroup();

+    private static ButtonGroup languageGroup = new ButtonGroup();

+

+    public GFEditor()

+    {

+        this.addWindowListener(new WindowAdapter() {

+            public void windowClosing(WindowEvent e) {

+              endProgram();

+            }

+        });

+        setJMenuBar(menuBar);

+        setTitle("GF Syntax Editor");

+        viewMenu.setToolTipText("View settings");        

+        fileMenu.setToolTipText("Main operations");

+        langMenu.setToolTipText("Language settings");

+        menuBar.add(fileMenu);

+        menuBar.add(langMenu);                        

+        menuBar.add(viewMenu);

+        menuBar.add(modeMenu);

+

+        cbMenuItem = new JCheckBoxMenuItem("Tree");

+        cbMenuItem.setActionCommand("showTree");

+        myListener = new RadioListener();     

+        cbMenuItem.addActionListener(myListener);

+        cbMenuItem.setSelected(true);

+        viewMenu.add(cbMenuItem);

+        viewMenu.addSeparator();              

+

+        fileMenuItem = new JMenuItem("Open...");

+        fileMenuItem.setActionCommand("open");

+        fileMenuItem.addActionListener(this);     

+        fileMenu.add(fileMenuItem);

+        fileMenuItem = new JMenuItem("New Topic...");

+        fileMenuItem.setActionCommand("newTopic");

+        fileMenuItem.addActionListener(this);     

+        fileMenu.add(fileMenuItem);

+        fileMenuItem = new JMenuItem("Reset");

+        fileMenuItem.setActionCommand("reset");

+        fileMenuItem.addActionListener(this);     

+        fileMenu.add(fileMenuItem);

+        fileMenuItem = new JMenuItem("Save As...");

+        fileMenuItem.setActionCommand("save");

+        fileMenuItem.addActionListener(this);     

+        fileMenu.add(fileMenuItem);

+        fileMenu.addSeparator();

+        fileMenuItem = new JMenuItem("Exit");

+        fileMenuItem.setActionCommand("quit");

+        fileMenuItem.addActionListener(this);     

+        fileMenu.add(fileMenuItem);

+

+        rbMenuItem = new JRadioButtonMenuItem("One window");

+        rbMenuItem.setActionCommand("combine");

+        rbMenuItem.addActionListener(myListener);

+        rbMenuItem.setSelected(true);

+/*        rbMenuItem.setMnemonic(KeyEvent.VK_R);

+        rbMenuItem.setAccelerator(KeyStroke.getKeyStroke(

+                KeyEvent.VK_1, ActionEvent.ALT_MASK));

+        rbMenuItem.getAccessibleContext().setAccessibleDescription(

+                "This doesn't really do anything");

+*/     

+        menuGroup.add(rbMenuItem);

+        viewMenu.add(rbMenuItem);

+

+        rbMenuItem = new JRadioButtonMenuItem("Split windows");

+        rbMenuItem.setMnemonic(KeyEvent.VK_O);

+        rbMenuItem.setActionCommand("split");

+        rbMenuItem.addActionListener(myListener);

+        menuGroup.add(rbMenuItem);

+        viewMenu.add(rbMenuItem);

+

+        modeMenu.add(submenu);

+        

+       /* rbMenuItemAbs = new JRadioButtonMenuItem("Abstract");

+        rbMenuItemAbs.setActionCommand("Abstract");

+        rbMenuItemAbs.addActionListener(myListener);

+        languageGroup.add(rbMenuItemAbs); 

+       */

+

+        modeMenu.addSeparator();              

+        menuGroup = new ButtonGroup();

+        rbMenuItemLong = new JRadioButtonMenuItem("long");

+        rbMenuItemLong.setActionCommand("long");

+        rbMenuItemLong.setSelected(true);

+        rbMenuItemLong.addActionListener(myListener);

+        menuGroup.add(rbMenuItemLong);

+        modeMenu.add(rbMenuItemLong);

+        rbMenuItem = new JRadioButtonMenuItem("short");

+        rbMenuItem.setActionCommand("short");

+        rbMenuItem.addActionListener(myListener);

+        menuGroup.add(rbMenuItem);

+        modeMenu.add(rbMenuItem);

+        modeMenu.addSeparator();              

+ 

+        menuGroup = new ButtonGroup();

+        rbMenuItem = new JRadioButtonMenuItem("typed");

+        rbMenuItem.setActionCommand("typed");

+        rbMenuItem.addActionListener(myListener);

+        rbMenuItem.setSelected(false);

+        menuGroup.add(rbMenuItem);

+        modeMenu.add(rbMenuItem);

+        rbMenuItemUnTyped = new JRadioButtonMenuItem("untyped");

+        rbMenuItemUnTyped.setSelected(true);

+        rbMenuItemUnTyped.setActionCommand("untyped");

+        rbMenuItemUnTyped.addActionListener(myListener);

+        menuGroup.add(rbMenuItemUnTyped);

+        modeMenu.add(rbMenuItemUnTyped);

+

+        cp = getContentPane();

+        cp.setLayout(new BorderLayout());

+        output.setToolTipText("Linearizations' display area");   

+        output.setEditable(false);

+        output.setLineWrap(true);

+        output.setWrapStyleWord(true);

+//        output.setSelectionColor(Color.green);

+        output.setSelectionColor(Color.white);

+//        output.setFont(new Font("Arial Unicode MS", Font.PLAIN, 17));

+        output.setFont(new Font(null, Font.PLAIN, 17));

+//        System.out.println(output.getFont().getFontName());

+        gfCommand.setToolTipText("Sending a command to GF");

+        read.setToolTipText("Refining with term or linearization from typed string or file");

+        modify.setToolTipText("Choosing a linearization method");

+        alpha.setToolTipText("Performing alpha-conversion");

+        random.setToolTipText("Generating random refinement");

+        undo.setToolTipText("Going back to the previous state");

+        downPanel.add(gfCommand);

+        //downPanel.add(parse);

+        //downPanel.add(term);  

+        downPanel.add(read);  

+        downPanel.add(modify);   

+        downPanel.add(alpha);     

+        downPanel.add(random);

+        downPanel.add(undo);

+

+        leftMeta.setToolTipText("Moving the focus to the previous metavariable");

+        rightMeta.setToolTipText("Moving the focus to the next metavariable");

+        left.setToolTipText("Moving the focus to the previous term");

+        right.setToolTipText("Moving the focus to the next term");

+        top.setToolTipText("Moving the focus to the top term");       

+        middlePanelUp.add(leftMeta);

+        middlePanelUp.add(left);

+        middlePanelUp.add(top);

+        middlePanelUp.add(right);

+        middlePanelUp.add(rightMeta);

+        middlePanelDown.add(new JLabel("Select Action on Subterm"));

+        middlePanel.setLayout(new BorderLayout());

+        middlePanel.add(middlePanelUp, BorderLayout.NORTH);

+        middlePanel.add(middlePanelDown, BorderLayout.CENTER);

+

+        menu.setToolTipText("The list of available categories to start editing");

+        open.setToolTipText("Reading both a new environment and an editing object from file. Current editing will be discarded");

+        save.setToolTipText("Writing the current editing object to file in the term or text format");

+        grammar.setToolTipText("Current Topic");

+        newTopic.setToolTipText("Reading a new environment from file. Current editing will be discarded.");

+        upPanel.add(grammar);

+        upPanel.add(menu);

+        upPanel.add(open);

+        upPanel.add(save);

+        upPanel.add(newTopic);

+        

+        filter.setToolTipText("Choosing the linearization representation format");

+        modeMenu.setToolTipText("Choosing the refinement options' representation");   

+        statusLabel.setToolTipText("The current focus type");

+        list.setToolTipText("The list of current refinment options");

+        tree.setToolTipText("The abstract syntax tree representation of the current editing object");

+        upPanel.add(filter);

+        //upPanel.add(mode);

+        populateTree(tree); 

+        outputPanelUp.setLayout(new BorderLayout());

+        outputPanelUp.add(outputPanelCenter, BorderLayout.CENTER);

+        outputPanelUp.add(statusPanel, BorderLayout.SOUTH);

+        statusPanel.setLayout(new GridLayout(1,1));

+        statusPanel.add(statusLabel);

+        treePanel = new JSplitPane(JSplitPane.HORIZONTAL_SPLIT,

+                                   tree, outputPanelUp);

+        treePanel.setDividerSize(5);

+        treePanel.setDividerLocation(100);

+        centerPanel2.setLayout(new BorderLayout());

+        gui2.setSize(350,150);

+        gui2.setTitle("Select Action on Subterm");

+        gui2.setLocationRelativeTo(treePanel);

+        centerPanelDown.setLayout(new BorderLayout());

+        centerPanel = new JSplitPane(JSplitPane.VERTICAL_SPLIT,

+                                   treePanel, centerPanelDown);

+        centerPanel.addKeyListener(tree);      

+        centerPanel.setOneTouchExpandable(true);

+        centerPanelDown.add(middlePanel, BorderLayout.NORTH);

+        centerPanelDown.add(outputPanelDown, BorderLayout.CENTER);

+        cp.add(centerPanel, BorderLayout.CENTER);

+        cp.add(upPanel, BorderLayout.NORTH);

+        cp.add(downPanel, BorderLayout.SOUTH);

+

+        list.setSelectionMode(ListSelectionModel.SINGLE_SELECTION);

+

+        MouseListener mouseListener = new MouseAdapter() {

+           public void mouseClicked(MouseEvent e) {

+             if (e.getClickCount() == 2) {

+               listAction(list.locationToIndex(e.getPoint()));

+             }

+           }

+        };

+        list.addMouseListener(mouseListener);

+        list.addKeyListener(this);

+        menu.addActionListener(this);

+        save.addActionListener(this);     

+        open.addActionListener(this);     

+        newTopic.addActionListener(this);

+        gfCommand.addActionListener(this);     

+        

+        filter.addActionListener(this);   

+        filter.setMaximumRowCount(9);  

+        leftMeta.addActionListener(this);     

+        left.addActionListener(this);

+     

+        menu.setFocusable(false);

+        save.setFocusable(false); 

+        save.setActionCommand("save");

+        open.setFocusable(false); 

+        open.setActionCommand("open");

+        newTopic.setFocusable(false);

+        newTopic.setActionCommand("newTopic");

+        gfCommand.setFocusable(false);

+        

+        filter.setFocusable(false);

+        leftMeta.setFocusable(false);

+        left.setFocusable(false);  

+               

+        top.addActionListener(this);     

+        right.addActionListener(this);     

+        rightMeta.addActionListener(this);     

+        //parse.addActionListener(this);     

+        //term.addActionListener(this);     

+        read.addActionListener(this);     

+        modify.addActionListener(this);     

+        //mode.addActionListener(this);     

+        alpha.addActionListener(this);     

+        random.addActionListener(this);     

+        undo.addActionListener(this);

+

+        top.setFocusable(false);  

+        right.setFocusable(false);  

+        rightMeta.setFocusable(false);  

+        //parse.setFocusable(false);  

+        //term.setFocusable(false);  

+        read.setFocusable(false);  

+        modify.setFocusable(false);  

+        //mode.setFocusable(false);  

+        alpha.setFocusable(false);  

+        random.setFocusable(false);  

+        undo.setFocusable(false);  

+

+        output.addKeyListener(tree);            

+	setSize(800,730);

+	outputPanelUp.setPreferredSize(new Dimension(500,300));

+        treePanel.setDividerLocation(0.3);

+        nodeTable.put(new TreePath(DynamicTree.rootNode.getPath()), new Integer(0));

+        setVisible(true);

+

+        JRadioButton termButton = new JRadioButton("Term");

+        termButton.setActionCommand("term");

+        termButton.setSelected(true);  

+        JRadioButton linButton = new JRadioButton("Text");

+        linButton.setActionCommand("lin");

+        // Group the radio buttons.

+        group.add(linButton);

+        group.add(termButton);

+        JPanel buttonPanel = new JPanel();

+        buttonPanel.setPreferredSize(new Dimension(70, 70));

+        buttonPanel.add(new JLabel("Format:"));

+        buttonPanel.add(linButton);

+        buttonPanel.add(termButton);

+        fc1.setAccessory(buttonPanel);

+

+        termReadButton.setActionCommand("term");

+        stringReadButton.setSelected(true);  

+        stringReadButton.setActionCommand("lin");

+        // Group the radio buttons.

+        readGroup.add(stringReadButton);

+        readGroup.add(termReadButton);

+        JPanel readButtonPanel = new JPanel();

+        readButtonPanel.setLayout(new GridLayout(3,1));

+        readButtonPanel.setPreferredSize(new Dimension(70, 70));

+        readButtonPanel.add(new JLabel("Format:"));

+        readButtonPanel.add(stringReadButton);

+        readButtonPanel.add(termReadButton);

+        dialog= new JDialog(this, "Input");

+        dialog.setLocationRelativeTo(this);

+        dialog.getContentPane().add(inputPanel);

+        inputPanel.setLayout(new BorderLayout(10,10));

+        inputPanel3.setLayout(new GridLayout(2,1,5,5));

+        inputPanel3.add(inputLabel);

+        inputPanel3.add(inputField);

+        ok.addActionListener(this);

+        browse.addActionListener(this);

+        cancel.addActionListener(this);

+        inputField.setPreferredSize(new Dimension(300,23));

+        inputPanel.add(inputPanel3, BorderLayout.CENTER);

+        inputPanel.add(new JLabel(" "), BorderLayout.WEST);

+        inputPanel.add(readButtonPanel, BorderLayout.EAST);

+        inputPanel.add(inputPanel2, BorderLayout.SOUTH);

+        inputPanel2.add(ok);

+        inputPanel2.add(cancel);

+        inputPanel2.add(browse);

+        dialog.setSize(350,135);                                          

+

+          try {

+            result = fromProc.readLine();

+            while(result != null)  {                  

+              finished = false;

+              if (debug) System.out.println("1 "+result);

+              while (result.indexOf("gf")==-1){                          

+                outputString +=result+"\n";

+                result = fromProc.readLine();

+                if (debug) System.out.println("1 "+result);

+              }

+              output.append(outputString);

+              while ((result.indexOf("newcat")==-1)&&(result.indexOf("<lin ")==-1)){

+                result = fromProc.readLine();

+                if (debug) System.out.println("1 "+result);

+              }

+              if (result.indexOf("<lin ")==-1)

+                formNewMenu();                   

+

+              if (!finished) { 

+

+                while ((result.length()==0)||(result.indexOf("<lin ")==-1)) {

+                  result = fromProc.readLine();

+                  if (result!=null){

+                    if (debug) System.out.println("10 "+result);                    

+                  }

+                  else System.exit(0);

+                }

+                readLin();

+                readTree();

+                readMessage();

+                if (newObject)

+                  formSelectMenu();                 

+                else {

+                  while(result.indexOf("</menu")==-1) {

+                    result = fromProc.readLine();

+                     if (debug) System.out.println("12 "+result);                    

+                  }

+                }

+                for (int i=0; i<3; i++){ 

+                  result = fromProc.readLine();

+                  if (debug) System.out.println("11 "+result);                    

+                }                                   

+              }

+            }           

+            output.append("*** NOTHING MORE TO READ FROM " + commandPath + "\n");

+          } catch (IOException e) {

+          System.out.println("Could not read from external process");

+        }

+   }

+

+    public static void send(String text){

+       try {

+             output.setText("");

+             outputString = ""; 

+             if (debug) System.out.println("output cleared");     

+             toProc.write(text, 0, text.length());

+             toProc.newLine();

+             toProc.flush();

+       } catch (IOException e) {

+          System.out.println("Could not write to external process");

+       }  

+    }            

+

+    public void endProgram(){

+          send("q");     

+          System.exit(0);

+    }

+                        

+    public static void main(String args[])

+    { 

+        Locale.setDefault(Locale.US);

+        try {

+            Process extProc = Runtime.getRuntime().exec(args[0]); 

+            fromProc = new BufferedReader (new InputStreamReader(

+                           extProc.getInputStream(),"UTF8"));

+            toProc = new BufferedWriter(new OutputStreamWriter(extProc.getOutputStream()));

+            /*  try {

+                  UIManager.setLookAndFeel(

+                  //UIManager.getSystemLookAndFeelClassName() );         

+                  "com.sun.java.swing.plaf.windows.WindowsLookAndFeel");

+                } catch (Exception e) { }

+            */

+            GFEditor gui = new GFEditor();

+            

+        } catch (IOException e) {

+            System.out.println("Could not start " + commandPath);

+        }

+    }

+

+    public static void formSelectMenu (){

+      if (debug) System.out.println("list model changing! ");      

+      String s ="";

+      try {

+        //read item

+        result = fromProc.readLine();

+        if (debug) System.out.println("8 "+result);

+        listModel.clear();

+        commands.clear();

+        while (result.indexOf("/menu")==-1){

+          //read show

+          result = fromProc.readLine();

+          if (debug) System.out.println("8 "+result);

+          while (result.indexOf("/show")==-1){          

+            result = fromProc.readLine();

+            if (debug) System.out.println("9 "+result);

+            if (result.indexOf("/show")==-1) 

+            {

+              if (result.length()>8)

+                  s+=result.trim();

+              else

+                s+=result;    

+            }

+          }            

+//          if (s.charAt(0)!='d')

+//            listModel.addElement("Refine " + s);

+//          else 

+          listModel.addElement(s);

+          s="";

+          //read /show

+          //read send

+          result = fromProc.readLine();

+          if (debug) System.out.println("8 "+result);

+          result = fromProc.readLine();

+          if (debug) System.out.println("8 "+result);

+          saveCommand();

+          // read /item

+          result = fromProc.readLine();

+          if (debug) System.out.println("8 "+result);

+          result = fromProc.readLine();

+          if (debug) System.out.println("8 "+result);

+        }

+     } catch(IOException e){ }

+   }

+

+   public static void saveCommand(){

+     if (newObject) commands.add(result);

+     try {            

+        result = fromProc.readLine();             

+        if (debug) System.out.println("9 "+result);          

+     } catch(IOException e){ }

+   }

+

+   public void readLin(){

+      try {

+        linearization="";  

+        linearization += result+"\n";           

+        result = fromProc.readLine();

+        if (debug) System.out.println("6 "+result);

+        while (result.indexOf("/linearization")==-1){       

+          linearization += result+"\n";           

+          result = fromProc.readLine();

+          if (debug) System.out.println("6 "+result);                     

+        }

+        if (newObject) formLin();               

+        result = fromProc.readLine();             

+        if (debug) System.out.println("6 "+result);          

+     } catch(IOException e){ }

+   }

+

+   public static void readTree(){

+      try {

+        result = fromProc.readLine();

+        if (debug) System.out.println("6 "+result);

+        while (result.indexOf("/tree")==-1){       

+          treeString += result+"\n";           

+          result = fromProc.readLine();

+          if (debug) System.out.println("6 "+result);                     

+        }

+        if (treeChanged && (newObject)) {

+          formTree(tree); 

+          treeChanged = false;  

+        } 

+        treeString="";                     

+        result = fromProc.readLine();             

+        if (debug) System.out.println("6 "+result);          

+     } catch(IOException e){ }

+   }

+

+   public static void readMessage(){

+      String s ="";

+      try {

+        result = fromProc.readLine();

+        if (debug) System.out.println("7 "+result);

+        while (result.indexOf("/message")==-1){       

+          s += result+"\n";           

+          result = fromProc.readLine();

+          if (debug) System.out.println("7 "+result);                     

+        }

+        if (s.length()>1)

+          output.append("-------------"+'\n'+s);  

+        result = fromProc.readLine();             

+        if (debug) System.out.println("7 "+result);          

+     } catch(IOException e){ }

+   }

+                       

+  public void formNewMenu () {

+    boolean more = true;

+    try {

+      result = fromProc.readLine();

+      if (debug) System.out.println("2 "+result);

+

+      while (more){

+        if (result.indexOf("language")==-1) {

+          menu.addItem(result.substring(6));                       

+        } 

+        else 

+          more = false;

+        result = fromProc.readLine();

+        if (debug) System.out.println("2 "+result); 

+        result = fromProc.readLine();

+        if (debug) System.out.println("3 "+result); 

+        if (result.indexOf("language")!=-1) 

+          more = false; 

+        result = fromProc.readLine();             

+        if (debug) System.out.println("4 "+result);       

+      }

+

+      more = true;

+      while (more){

+        if ((result.indexOf("/gf")==-1)&&(result.indexOf("lin")==-1)) {         

+          //form lang and Menu menu: 

+          cbMenuItem = new JCheckBoxMenuItem(result.substring(4));

+          if (debug) System.out.println ("menu item: "+result.substring(4));   

+          cbMenuItem.setSelected(true);

+          cbMenuItem.setActionCommand("lang");

+          cbMenuItem.addActionListener(myListener);

+          langMenu.add(cbMenuItem);

+/*          if ((result.substring(4)).equals("Abstract"))

+          {

+             submenu.add(rbMenuItemAbs);

+             if (selectedMenuLanguage.equals("Abstract"))

+               rbMenuItemAbs.setSelected(true);

+               languageGroup.add(rbMenuItemAbs); 

+          }

+          else

+          {

+*/

+             rbMenuItem = new JRadioButtonMenuItem(result.substring(4));

+             rbMenuItem.setActionCommand(result.substring(4));

+             rbMenuItem.addActionListener(myListener);

+             languageGroup.add(rbMenuItem);

+             if ((result.substring(4)).equals(selectedMenuLanguage))

+             {

+                System.out.println("Selecting "+selectedMenuLanguage);

+                rbMenuItem.setSelected(true);

+             }

+

+             submenu.add(rbMenuItem);

+// }

+        } 

+        else 

+          more = false;

+        // read </language>

+        result = fromProc.readLine();

+        if (debug) System.out.println("2 "+result); 

+        // read <language> or </gf...>

+        result = fromProc.readLine();

+        if (debug) System.out.println("3 "+result); 

+        if ((result.indexOf("/gf")!=-1)||(result.indexOf("lin")!=-1)) 

+          more = false; 

+        if (result.indexOf("/gf")!=-1)

+          finished = true;

+        // registering the file name:

+        if (result.indexOf("language")!=-1) {

+          String path = result.substring(result.indexOf('=')+1,

+                                         result.indexOf('>')); 

+          path =path.substring(path.lastIndexOf('/')+1);

+          if (debug) System.out.println("name: "+path);

+          fileString +="--" + path +"\n";

+          if (path.lastIndexOf('.')!=path.indexOf('.'))

+            grammar.setText(path.substring(0,

+                 path.indexOf('.')).toUpperCase()+"          ");

+        }

+        result = fromProc.readLine();             

+        if (debug) System.out.println("4 "+result);               

+      }

+      System.out.println("languageGroupElement formed"+ 

+                            languageGroup.getButtonCount());                   

+      langMenu.addSeparator();

+      fileMenuItem = new JMenuItem("Add...");

+      fileMenuItem.setActionCommand("import");

+      fileMenuItem.addActionListener(this);     

+      langMenu.add(fileMenuItem);

+      // in order to get back in main in the beggining of while:

+      result = fromProc.readLine();

+    } catch(IOException e){ }

+  }

+

+  public void outputAppend(){

+    int i, j, k, l, l2, m;

+    i=result.indexOf("type=");

+    j=result.indexOf('>',i);

+    l = result.indexOf("<focus");

+    l2 = result.indexOf("focus");    

+    if (l2!=-1){

+

+      // in case focus tag is cut into two lines:

+      if (l==-1) l=l2-7;         

+

+      if (debug) System.out.println("form Lin1: "+result);

+      statusLabel.setText(" "+result.substring(i+5,j));

+      //cutting <focus>

+      result= result.substring(0,l)+result.substring(j+1);

+      i=result.indexOf("/f",l);

+System.out.println("/ is at the position"+i);

+      j=result.indexOf('>',i);

+      k=result.length()-j;

+      if (debug) System.out.println("form Lin2: "+result);

+      m = output.getText().length();

+      

+      //cutting </focus>    

+      // in case focus tag is cut into two lines:

+      if (debug)

+        System.out.println("char at the previous position"+result.charAt(i-1));

+      if (result.charAt(i-1)!='<') 

+        result= result.substring(0,i-8)+result.substring(j+1);

+      else

+        result= result.substring(0,i-1)+result.substring(j+1);

+      j= result.indexOf("<focus");

+      l2 = result.indexOf("focus");    

+      // in case focus tag is cut into to lines:

+      if ((l2!=-1)&&(j==-1)) j=l2-7;

+      // only one focus 

+      if (j==-1){

+        output.append(result+'\n'); 

+        selectionStart=m+l;

+        selectionEnd=output.getText().length()-k; 

+        try {  

+          output.getHighlighter().addHighlight(selectionStart, selectionEnd, new DefaultHighlighter.DefaultHighlightPainter(Color.green) );

+//          output.getHighlighter().addHighlight(selectionStart, selectionEnd, new DefaultHighlighter.DefaultHighlightPainter(Color.white) );

+        } catch (Exception e) {}

+      } 

+      //several focuses

+      else {

+        output.append(result.substring(0,j));           

+        result = result.substring(j); 

+        selectionStart=m+l;

+        selectionEnd=m+i-1; 

+        try {  

+//          output.getHighlighter().addHighlight(selectionStart, selectionEnd, new DefaultHighlighter.DefaultHighlightPainter(Color.green) );

+          output.getHighlighter().addHighlight(selectionStart, selectionEnd, new DefaultHighlighter.DefaultHighlightPainter(Color.white) );

+        } catch (Exception e) {}

+        outputAppend();

+      }

+      if (debug) System.out.println("form Lin3: "+result);

+    }   

+    else 

+      output.append(result+'\n');          

+    firstLin=false;

+  }

+

+  public void formLin(){

+    boolean visible=true; 

+    firstLin=true; 

+    result = linearization.substring(0,linearization.indexOf('\n'));

+    String lin = linearization.substring(linearization.indexOf('\n')+1);

+    //extract the language from result

+    int ind = result.indexOf('=');

+    int ind2 = result.indexOf('>');

+    String s = result.substring(ind+1,ind2);

+    result = lin.substring(0,lin.indexOf("</lin>"));

+    lin = lin.substring(lin.indexOf("</lin>"));

+    while (lin.length()>1) {

+      //check if the language is on     

+      if (!visible) visible = true;       

+      // in the list?

+      for (int i=0; i<langMenu.getItemCount()-2;i++)        

+        if (langMenu.getItem(i).getText().equals(s))

+        {

+          visible = false;

+          break; 

+        }

+      if (!visible) visible = true;       

+      else {

+        //add item to the language list:

+        cbMenuItem = new JCheckBoxMenuItem(s);

+        if (debug) System.out.println ("menu item: "+s);   

+        cbMenuItem.setSelected(true);

+        cbMenuItem.setActionCommand("lang");

+        cbMenuItem.addActionListener(myListener);

+        if (langMenu.getItemCount()<2)

+          langMenu.add(cbMenuItem, langMenu.getItemCount());  

+        else

+          langMenu.add(cbMenuItem, langMenu.getItemCount()-2);  

+

+        rbMenuItem = new JRadioButtonMenuItem(s);

+        rbMenuItem.setActionCommand(s);

+        rbMenuItem.addActionListener(myListener);

+        languageGroup.add(rbMenuItem);

+        submenu.add(rbMenuItem);

+

+      }

+      // selected?

+      for (int i=0; i<langMenu.getItemCount()-2;i++)

+        if ((langMenu.getItem(i).getText().equals(s))&&

+                    !(langMenu.getItem(i).isSelected()) ) {

+          visible = false;

+          break; 

+        }

+      if (visible) {   

+        if (!firstLin)

+          output.append("************"+'\n');  

+        if (debug) System.out.println("linearization for the language: "+result);

+        outputAppend();

+      }

+      // read </lin>

+      lin = lin.substring(lin.indexOf('\n')+1);

+      // read lin or 'end'

+      if (lin.length()<1) break;

+       

+      result = lin.substring(0,lin.indexOf('\n'));

+      lin = lin.substring(lin.indexOf('\n')+1);

+      if (result.indexOf("<lin ")!=-1){

+        //extract the language from result

+        ind = result.indexOf('=');

+        ind2 = result.indexOf('>');

+        s = result.substring(ind+1,ind2);

+        result = lin.substring(0,lin.indexOf("</lin>"));

+        lin = lin.substring(lin.indexOf("</lin>"));

+      }  

+    }

+  }

+

+  public void actionPerformed(ActionEvent ae)

+  {  

+    boolean abs = true;

+    Object obj = ae.getSource();

+    if ( obj == menu ) {

+      if (!menu.getSelectedItem().equals("New"))           

+      { 

+        treeChanged = true; 

+        send("n " + menu.getSelectedItem());

+        newObject = true;

+        menu.setSelectedIndex(0);

+      }

+    }

+    if ( obj == filter ) {

+      if (!filter.getSelectedItem().equals("Filter"))           

+      { 

+        send("f " + filter.getSelectedItem());

+        filter.setSelectedIndex(0);

+      }

+    }

+    if ( obj == modify ) {

+      if (!modify.getSelectedItem().equals("Modify"))           

+      { 

+        treeChanged = true; 

+        send("c " + modify.getSelectedItem());

+        modify.setSelectedIndex(0);

+      }

+    }

+/*    if ( obj == mode ) {

+      if (!mode.getSelectedItem().equals("Menus"))           

+      {  

+        send("o " + mode.getSelectedItem());

+        mode.setSelectedIndex(0);              

+      }               

+    }

+*/

+    // buttons and menu items: 

+    try {

+      if (Class.forName("javax.swing.AbstractButton").isInstance(obj)) {

+        String name =((AbstractButton)obj).getActionCommand();

+

+        if ( name.equals("quit")) {

+          endProgram();

+        }

+              

+        if ( name.equals("save") ) {

+ 

+          if (fc1.getChoosableFileFilters().length<2)

+            fc1.addChoosableFileFilter(new GrammarFilter()); 

+          int returnVal = fc1.showSaveDialog(GFEditor.this);

+          if (returnVal == JFileChooser.APPROVE_OPTION) {

+            File file = fc1.getSelectedFile();

+            if (debug) System.out.println("saving ... ");

+

+            // checking if the abstract syntax is on:

+            for (int i=0; i<langMenu.getItemCount()-2;i++)

+              if ((langMenu.getItem(i).getText().equals("Abstract"))&&

+                 !(langMenu.getItem(i).isSelected()) ) {

+                if (debug) System.out.println("No Abstract syntax !!!!");

+                  abs = false;

+                  break; 

+                }

+

+            String text = output.getText();

+            int end = text.indexOf("******");

+

+            // saving as a term:

+            if (group.getSelection().getActionCommand().equals("term")) {

+              if (end !=-1)

+                if (abs) {

+                  writeOutput(fileString+text.substring(0, end), file.getPath());

+                  abs=true;

+                }

+                else {

+                  int i = linearization.indexOf('\n');

+                  int j = linearization.indexOf("/lin");

+                  writeOutput(fileString+linearization.substring(i+1, j-1), file.getPath());

+                } 

+              else

+                JOptionPane.showMessageDialog(this, "No term to save");   

+            }  

+            // saving as a linearization:

+            else  

+                // abstract syntax is shown:

+                if (abs){

+                  end =  text.indexOf('\n', end);

+                  writeOutput(fileString+text.substring(end), file.getPath());

+                  abs = true;

+                }

+                else

+                  writeOutput(fileString+text, file.getPath());

+           }           

+         }

+

+         if ( name.equals("open") ) {

+           if (fc1.getChoosableFileFilters().length<2)

+             fc1.addChoosableFileFilter(new GrammarFilter()); 

+           int returnVal = fc1.showOpenDialog(GFEditor.this);

+           if (returnVal == JFileChooser.APPROVE_OPTION) {

+

+           /* "sending" should be fixed on the GF side:

+             rbMenuItemLong.setSelected(true);

+             send("ms long");

+             rbMenuItemUnTyped.setSelected(true);

+             send("mt untyped");

+             selectedMenuLanguage = "Abstract";

+             rbMenuItemAbs.setSelected(true);

+             send("ml Abs");

+           */

+

+             treeChanged = true; 

+             newObject = true;

+             menu.removeAllItems();

+             menu.addItem("New");

+             langMenu.removeAll();

+

+             AbstractButton ab = null;

+

+           while (languageGroup.getButtonCount()>0)

+           {

+             for (Enumeration e = languageGroup.getElements(); 

+                                      e.hasMoreElements() ;) 

+             {

+               ab = (AbstractButton)e.nextElement();

+               System.out.println("more to remove ! "+ab.getText()); 

+               languageGroup.remove(ab);

+             }

+             System.out.println("languageGroupElement after import removal "+ 

+                            languageGroup.getButtonCount());                   

+           }

+             submenu.removeAll();

+

+             File file = fc1.getSelectedFile();

+	     // opening the file for editing :

+             if (debug) System.out.println("opening: "+ file.getPath().replace('\\','/'));

+             if (group.getSelection().getActionCommand().equals("term")) {

+               if (debug) System.out.println(" opening as a term ");

+               send("open "+ file.getPath().replace('\\','/'));         

+             }

+             else {

+               if (debug) System.out.println(" opening as a linearization ");

+               send("openstring "+ file.getPath().replace('\\','/'));

+             }

+

+             fileString ="";

+             grammar.setText("No Topic          ");

+           }           

+         }

+

+         if ( name.equals("import") ) {

+           if (fc.getChoosableFileFilters().length<2)

+             fc.addChoosableFileFilter(new GrammarFilter()); 

+           int returnVal = fc.showOpenDialog(GFEditor.this);

+           if (returnVal == JFileChooser.APPROVE_OPTION) {

+             File file = fc.getSelectedFile();

+	     // importing a new language :

+             if (debug) System.out.println("importing: "+ file.getPath());

+

+             langMenu.removeAll();

+

+             AbstractButton ab = null;

+

+           while (languageGroup.getButtonCount()>0)

+           {

+             for (Enumeration e = languageGroup.getElements(); 

+                                      e.hasMoreElements() ;) 

+             {

+               ab = (AbstractButton)e.nextElement();

+               System.out.println("more to remove ! "+ab.getText()); 

+               languageGroup.remove(ab);

+             }

+             System.out.println("languageGroupElement after import removal "+ 

+                            languageGroup.getButtonCount());                   

+           }

+

+             submenu.removeAll();

+

+             menu.removeAllItems();

+             menu.addItem("New");

+             fileString ="";

+             send("i "+ file.getPath().replace('\\','/'));

+

+           }           

+         }

+         if ( name.equals("newTopic") ) {

+           if (fc.getChoosableFileFilters().length<2)

+             fc.addChoosableFileFilter(new GrammarFilter()); 

+           int returnVal = fc.showOpenDialog(GFEditor.this);

+           if (returnVal == JFileChooser.APPROVE_OPTION) {

+             int n = JOptionPane.showConfirmDialog(this,

+               "This will dismiss the previous editing. Would you like to continue?",

+                     "Starting a new topic", JOptionPane.YES_NO_OPTION);

+             if (n == JOptionPane.YES_OPTION){

+               File file = fc.getSelectedFile();

+               // importing a new grammar :                

+               newObject = false; 

+               statusLabel.setText(status); 

+               listModel.clear();

+               tree.clear();

+               populateTree(tree);

+               menu.removeAllItems();

+               menu.addItem("New");

+               langMenu.removeAll();

+

+             AbstractButton ab = null;

+

+           while (languageGroup.getButtonCount()>0)

+           {

+             for (Enumeration e = languageGroup.getElements(); 

+                                      e.hasMoreElements() ;) 

+             {

+               ab = (AbstractButton)e.nextElement();

+               System.out.println("more to remove ! "+ab.getText()); 

+               languageGroup.remove(ab);

+             }

+             System.out.println("languageGroupElement after import removal "+ 

+                            languageGroup.getButtonCount());                   

+           }

+

+               selectedMenuLanguage = "Abstract";

+               rbMenuItemLong.setSelected(true);

+               rbMenuItemUnTyped.setSelected(true);

+               submenu.removeAll();

+ 

+               fileString="";

+               grammar.setText("No Topic          ");

+               send("e "+ file.getPath().replace('\\','/'));

+             }

+           }           

+         }

+

+         if ( obj == gfCommand ){

+           String s = JOptionPane.showInputDialog("Command:", parseInput);

+           if (s!=null) {

+              parseInput = s;

+              s = "gf "+s;

+              //treeChanged = true; 

+              send(s);

+           }

+        }

+

+        if ( name.equals("reset") ) {

+              newObject = false; 

+              statusLabel.setText(status); 

+              listModel.clear();

+              tree.clear();

+              populateTree(tree);

+              menu.removeAllItems();

+              menu.addItem("New");

+              langMenu.removeAll();

+

+             AbstractButton ab = null;

+

+           while (languageGroup.getButtonCount()>0)

+           {

+             for (Enumeration e = languageGroup.getElements(); 

+                                      e.hasMoreElements() ;) 

+             {

+               ab = (AbstractButton)e.nextElement();

+               System.out.println("more to remove ! "+ab.getText()); 

+               languageGroup.remove(ab);

+             }

+             System.out.println("languageGroupElement after import removal "+ 

+                            languageGroup.getButtonCount());                   

+           }

+

+               selectedMenuLanguage = "Abstract";

+

+               submenu.removeAll();

+               rbMenuItemLong.setSelected(true);

+               rbMenuItemUnTyped.setSelected(true);

+

+              fileString="";

+              grammar.setText("No Topic          ");

+              send("e");

+        }

+

+        if ( obj == leftMeta ) {

+           treeChanged = true; 

+           send("<<");

+        }

+        if ( obj == left ) {

+           treeChanged = true; 

+           send("<");

+        }

+        if ( obj == top ) {

+           treeChanged = true; 

+           send("'");

+        }

+        if ( obj == right ) {

+           treeChanged = true; 

+           send(">");

+        }

+        if ( obj == rightMeta ) {

+           treeChanged = true; 

+           send(">>");

+        }

+

+        if ( obj == cancel ) {

+          dialog.hide();

+        }

+

+        if ( obj == browse ) {

+           if (fc.getChoosableFileFilters().length<2)

+             fc.addChoosableFileFilter(new GrammarFilter()); 

+           int returnVal = fc.showOpenDialog(GFEditor.this);

+           if (returnVal == JFileChooser.APPROVE_OPTION) {

+               File file = fc.getSelectedFile();

+               inputField.setText(file.getPath().replace('\\','/'));

+           }

+        }

+     

+        if ( obj == ok ) {

+           treeChanged = true; 

+           if (termReadButton.isSelected()) { 

+             termInput = inputField.getText();

+             if (termInput.indexOf('/')==-1){

+               send("g "+termInput); 

+               System.out.println("sending term  string");

+             }

+             else {

+               send("tfile "+termInput);                           

+               System.out.println("sending file term: "+termInput);          

+             }

+           }   

+           else {

+             parseInput = inputField.getText();

+             if (parseInput.indexOf('/')==-1){

+               send("p "+parseInput);        

+               System.out.println("sending parse string"+parseInput);

+             }   

+             else {

+               send("pfile "+parseInput);           

+               System.out.println("sending file parse string: "+parseInput);          

+             }

+           }

+           dialog.hide();

+        }

+

+        if ( obj == read ) {

+          if (stringReadButton.isSelected())

+            inputField.setText(parseInput);

+          else

+            inputField.setText(termInput);

+          dialog.show();

+        }   

+

+/*        if ( obj == term ) {

+          inputLabel.setText("Term:");

+          inputField.setText(termInput);

+          dialog.show();

+        }

+        if ( obj == parse ) {

+          inputLabel.setText("Parse:");

+          inputField.setText(parseInput);

+          dialog.show();

+        }

+*/

+        if ( obj == alpha){

+           String s = JOptionPane.showInputDialog("Type string:", alphaInput);

+           if (s!=null) {

+               alphaInput = s;

+               treeChanged = true; 

+               send("x "+s);

+           }      

+        }

+        if ( obj == random){

+           treeChanged = true; 

+           send("a");

+        }

+        if ( obj == undo){

+           treeChanged = true; 

+           send("u");

+        }

+      }

+    } catch (Exception e){}

+  }

+  static void writeOutput(String str, String fileName) {

+

+       try {

+           FileOutputStream fos = new FileOutputStream(fileName);

+           Writer out = new OutputStreamWriter(fos, "UTF8");

+           out.write(str);

+           out.close();

+       } catch (IOException e) {

+              JOptionPane.showMessageDialog(null, 

+             "Document is empty!","Error", JOptionPane.ERROR_MESSAGE);

+       }

+   }

+    public static void populateTree(DynamicTree treePanel) {

+        String p1Name = new String("Root");

+        DefaultMutableTreeNode p1;

+        p1 = treePanel.addObject(null, p1Name);

+    }

+

+    public static void formTree(DynamicTree treePanel) {

+        Hashtable table = new Hashtable();

+        TreePath path=null;

+        boolean treeStarted = false, selected = false;  

+        String s = treeString;

+        String name ="";

+        treePanel.clear();

+        int j, shift=0, star=0, index = 0;

+        DefaultMutableTreeNode p2=null, p1=null;

+        if (debug) System.out.print("treeString: "+ s);

+        if (s.indexOf('*')!=-1) star = 1; 

+        while (s.length()>0) {

+            while ((s.length()>0) && ((s.charAt(0)=='*')||(s.charAt(0)==' '))){      

+               if (s.charAt(0) == '*') selected = true;

+               s = s.substring(1);     

+               shift++;  

+            }             

+            if (s.length()>0) {

+               j = s.indexOf("\n");      

+               name = s.substring(0, j);     

+               index++;

+               s = s.substring(j+1);    

+               shift = (shift - star)/2;

+

+               p1 = (DefaultMutableTreeNode)table.get(new Integer(shift));

+               p2 = treePanel.addObject(p1, name);  

+               table.put(new Integer(shift+1), p2);

+               path = new TreePath(p2.getPath());

+               nodeTable.put(path, new Integer(index));

+               if (selected) {                        

+                       treePanel.tree.setSelectionPath(path);              

+                       treePanel.oldSelection = index;

+                       if (debug) System.out.println("new selected index "+ index);

+                       selected = false;

+               }

+               treeStarted=true;               

+            }

+            shift = 0;

+        }

+        if ((p2!=null)) {

+           treePanel.tree.makeVisible(path); 

+           gui2.toFront();

+           index = 0;

+        }

+    }

+

+    /** Listens to the radio buttons. */

+    class RadioListener implements ActionListener { 

+      public void actionPerformed(ActionEvent e) {

+        String action = e.getActionCommand();

+        if (action.equals("split") ) {

+          cp.remove(centerPanel);

+          centerPanel2.add(middlePanelUp, BorderLayout.SOUTH);

+          if (((JCheckBoxMenuItem)viewMenu.getItem(0)).isSelected()) {             

+            centerPanel2.add(treePanel, BorderLayout.CENTER);

+          }

+          else {

+            centerPanel2.add(outputPanelUp, BorderLayout.CENTER);

+          } 

+          cp.add(centerPanel2, BorderLayout.CENTER);                 

+          gui2.getContentPane().add(outputPanelDown);

+          gui2.setVisible(true);

+          pack();

+          repaint();                                       

+        }

+        if (action.equals("combine") ) {

+          cp.remove(centerPanel2);  

+          middlePanel.add(middlePanelUp, BorderLayout.NORTH);

+          if (((JCheckBoxMenuItem)viewMenu.getItem(0)).isSelected()) {                         gui2.setVisible(false);

+            centerPanel.setLeftComponent(treePanel);

+          }

+          else {

+            centerPanel.setLeftComponent(outputPanelUp);

+            gui2.setVisible(false);

+          } 

+          cp.add(centerPanel, BorderLayout.CENTER);

+          centerPanelDown.add(outputPanelDown, BorderLayout.CENTER);

+          pack();

+          repaint();               

+        }

+        if (action.equals("showTree") ) {

+          if (!((JCheckBoxMenuItem)e.getSource()).isSelected()){

+            if (debug) System.out.println("was selected");

+            cbMenuItem.setSelected(false);

+            if (((JRadioButtonMenuItem)viewMenu.getItem(2)).isSelected()) {      

+              centerPanel.remove(treePanel);

+              centerPanel.setLeftComponent(outputPanelUp); 

+            }

+            else {

+              centerPanel2.remove(treePanel);

+              centerPanel2.add(outputPanelUp, BorderLayout.CENTER); 

+            }

+          }

+          else { 

+            if (debug) System.out.println("was not selected");

+            cbMenuItem.setSelected(true);

+            if (((JRadioButtonMenuItem)viewMenu.getItem(2)).isSelected()) {      

+              centerPanel.remove(outputPanelUp);

+              treePanel.setRightComponent(outputPanelUp);

+              centerPanel.setLeftComponent(treePanel);

+            }

+            else {

+              centerPanel2.remove(outputPanelUp);

+              treePanel.setRightComponent(outputPanelUp);

+              centerPanel2.add(treePanel, BorderLayout.CENTER);

+            }                    

+          }

+          pack();

+          repaint();                               

+        }

+        if (action.equals("lang")) {

+          if (newObject) {

+            output.setText("");

+            formLin();

+          }

+          if (debug) 

+            System.out.println("language option has changed "+((JCheckBoxMenuItem)e.getSource()).getText());

+          if (((JCheckBoxMenuItem)e.getSource()).isSelected()){

+            System.out.println("turning on");

+            send("on "+((JCheckBoxMenuItem)e.getSource()).getText());

+          }

+          else{

+            System.out.println("turning off");

+            send("off "+((JCheckBoxMenuItem)e.getSource()).getText());

+          }

+        }

+        //modeMenus actions:

+        else {

+          if ((action.equals("long")) || (action.equals("short")))  

+            {

+                send("ms " + action);

+            }

+          else 

+            if ((action.equals("typed")) || (action.equals("untyped")))  

+              {

+                send("mt " + action);

+              }

+            else 

+              {

+                selectedMenuLanguage = action;

+                if (action.equals("Abstract"))

+                {

+                   send("ml Abs");

+                }

+                else 

+                {

+                  System.out.println("sending "+action);

+                  send("ml " + action);

+                }

+              }

+        }

+      }

+    }

+

+    /** Handle the key pressed event. */

+    public void keyPressed(KeyEvent e) {

+        int keyCode = e.getKeyCode();   

+        if  (keyCode == 10) { 

+            listAction(list.getSelectedIndex());

+        }

+    }

+    /** Handle the key typed event. */

+    public void keyTyped(KeyEvent e) {

+    }

+    /** Handle the key released event. */

+    public void keyReleased(KeyEvent e) {

+    }

+

+    public void listAction(int index) {

+      if (index == -1) 

+        {if (debug) System.out.println("no selection");}

+      else {

+        treeChanged = true; 

+        send((String)commands.elementAt(list.getSelectedIndex()));

+      }

+    }

+}

diff --git a/src/JavaGUI/GrammarFilter.java b/src/JavaGUI/GrammarFilter.java
new file mode 100644
index 000000000..514da3fa8
--- /dev/null
+++ b/src/JavaGUI/GrammarFilter.java
@@ -0,0 +1,30 @@
+import java.io.File;
+import javax.swing.*;
+import javax.swing.filechooser.*;
+
+public class GrammarFilter extends FileFilter {
+    
+    // Accept all directories and all gf, gfm files.
+    public boolean accept(File f) {
+        if (f.isDirectory()) {
+            return true;
+        }
+
+        String extension = Utils.getExtension(f);
+	if (extension != null) {
+            if (extension.equals(Utils.gf) ||
+                extension.equals(Utils.gfm)) {
+                    return true;
+            } else {
+                return false;
+            }
+    	}
+
+        return false;
+    }
+    
+    // The description of this filter
+    public String getDescription() {
+        return "Just Grammars";
+    }
+}
diff --git a/src/JavaGUI/Utils.java b/src/JavaGUI/Utils.java
new file mode 100644
index 000000000..f7c6f5b93
--- /dev/null
+++ b/src/JavaGUI/Utils.java
@@ -0,0 +1,22 @@
+
+import java.io.File;
+
+public class Utils {
+
+    public final static String gf = "gf";
+    public final static String gfm = "gfm";
+
+    /*
+     * Get the extension of a file.
+     */
+    public static String getExtension(File f) {
+        String ext = null;
+        String s = f.getName();
+        int i = s.lastIndexOf('.');
+
+        if (i > 0 &&  i < s.length() - 1) {
+            ext = s.substring(i+1).toLowerCase();
+        }
+        return ext;
+    }
+}
diff --git a/src/Makefile b/src/Makefile
new file mode 100644
index 000000000..2a9019c03
--- /dev/null
+++ b/src/Makefile
@@ -0,0 +1,23 @@
+GHMAKE=ghc 
+GHCFLAGS=-package lang -package util
+GHCFUDFLAG=-package Fudgets
+GHCINCLUDE=-iapi -icompile -igrammar -iinfra -ishell -isource -icanonical -iuseGrammar -icf -ifor-ghc
+
+all:
+	make today ; make ghc
+ghc: 
+	$(GHMAKE) $(GHCFLAGS) $(GHCINCLUDE) $(GHCFUDFLAG) --make GF.hs -o gf2+ ; strip gf2+ ; mv gf2+ ../bin/
+batch: 
+	$(GHMAKE) $(GHCFLAGS) $(GHCINCLUDE) --make GF2.hs -o gf2 ; strip gf2
+api: 
+	$(GHMAKE) $(GHCFLAGS) $(GHCINCLUDE) --make API.hs
+shell: 
+	$(GHMAKE) $(GHCFLAGS) $(GHCINCLUDE) --make Shell.hs
+clean: 
+	rm -rf */*.o */*.hi *.o *.hi */*.ghi *.ghi *~ */*~
+hugs:
+	hugs -P.:for-hugs:api:source:canonical:cf:grammar:infra:shell:useGrammar:compile: GF
+today:
+	runhugs util/MkToday
+javac:
+	cd java ; javac GFEditor.java ; cd ..
diff --git a/src/Today.hs b/src/Today.hs
new file mode 100644
index 000000000..9bb6712ee
--- /dev/null
+++ b/src/Today.hs
@@ -0,0 +1 @@
+module Today where today = "Mon Sep 22 15:54:44 CEST 2003"
diff --git a/src/tools/GFDoc.hs b/src/tools/GFDoc.hs
new file mode 100644
index 000000000..0c5f943d9
--- /dev/null
+++ b/src/tools/GFDoc.hs
@@ -0,0 +1,255 @@
+module Main where
+
+import List
+import System
+import Char
+
+-- produce a HTML document from a list of GF grammar files. AR 6/10/2002
+
+-- to read files and write a file
+
+main :: IO ()
+main = do
+  xx <- getArgs
+  let 
+   (typ,format,name) = case xx of
+    "+latex" : x: [] -> (True,doc2latex,x)
+    x:[]             -> (False,doc2html,x)
+    _ -> (True,doc2html, "unknown.txt") ---
+  if null xx
+     then do
+       putStrLn welcome
+       putStrLn help
+     else do  
+       ss <- readFile name
+       let outfile = fileFormat typ name
+       writeFile outfile $ format $ pDoc $ ss
+
+welcome = unlines [
+  "",
+  "gfdoc - a rudimentary GF document generator.",
+  "(c) Aarne Ranta (aarne@cs.chalmers.se) 2002 under GNU GPL."
+  ]
+
+help = unlines $ [
+  "",
+  "Usage: gfdoc (+latex) file",
+  "",
+  "The program operates with lines in GF code, treating them into LaTeX",
+  "(flag +latex) or to HTML (by default). The output is written in a file",
+  "whose name is formed from the input file name by replacing its suffix",
+  "with html or tex.",
+  "",
+  "The translation is line by line",
+  "depending as follows on how the line begins",
+  "",
+  " --[Int]    heading of level Int",  
+  " --         new paragraph",
+  " --.        end of document",
+---  " ---        ignore this comment line in document",
+---  " {---}      ignore this code line in document",
+  " --[Text]   Text belongs to text paragraph",
+  " [Text]     Text belongs to code paragraph",
+  "",
+  "Within a text paragraph, text enclosed between certain characters",
+  "is treated specially:",
+  "",
+  " *[Text]*   emphasized (boldface)",
+  " \"[Text]\"   example string (italics)",
+  " $[Text]$   example code (courier)"
+  ]
+
+fileFormat isLatex x = body ++ if isLatex then "tex" else "html" where
+  body = reverse $ dropWhile (/='.') $ reverse x
+
+-- the document datatype
+
+data Doc = Doc Title [Paragraph]
+
+type Title = [TextItem]
+
+data Paragraph = 
+   Text [TextItem]         -- text line starting with --
+ | List [[TextItem]]       -- 
+ | Code String             -- other text line
+ | New                     -- new paragraph: line consisting of --
+ | Heading Int [TextItem]  -- text line starting with --n where n = 1,2,3,4
+
+data TextItem =
+   Str String
+ | Emp String  -- emphasized,     *...*
+ | Lit String  -- string literal, "..."
+ | Inl String  -- inlined code,   '...'
+
+
+-- parse document
+
+pDoc :: String -> Doc
+pDoc s = case lines s of
+  ('-':'-':'1':title) : paras -> Doc (pItems title) (map pPara (grp paras))
+  paras -> Doc [] (map pPara (grp paras))
+ where
+   grp ss = case ss of
+     s : rest --- | ignore s      -> grp rest
+              | isEnd s       -> []
+              | begComment s  -> let (s1,s2) = getComment (drop 2 s : rest) 
+                                 in map ("-- " ++) s1 ++ grp s2 
+              | isComment s   -> s : grp rest
+              | all isSpace s -> grp rest
+     [] -> []
+     _ -> unlines code : grp rest where (code,rest) = span (not . isComment) ss 
+   pPara s = case s of
+     '-':'-':d:text | isDigit d -> Heading (read [d]) (pItems text)
+     '-':'-':[]                 -> New
+     '-':'-':text               -> Text (pItems (dropWhile isSpace text))
+     _                          -> Code s
+   pItems s = case s of
+     '*'  : cs -> get 1 Emp (=='*')  cs
+     '"'  : cs -> get 1 Lit (=='"')  cs
+     '$'  : cs -> get 1 Inl (=='$') cs
+     []        -> []
+     _         -> get 0 Str (flip elem "*\"$") s
+
+   get _ _   _     [] = []
+   get k con isEnd cs = con beg : pItems (drop k rest) 
+                    where (beg,rest) =  span (not . isEnd) cs
+ 
+   ignore s = case s of
+     '-':'-':'-':_ -> True
+     '{':'-':'-':'-':'}':_ -> True
+     _ -> False
+
+   isEnd s = case s of
+     '-':'-':'.':_ -> True
+     _ -> False
+
+
+-- render in html
+
+doc2html :: Doc -> String
+doc2html (Doc title paras) = unlines $
+  tagXML "html" $
+    tagXML "body" $
+      unwords (tagXML "i" ["Produced by " ++ welcome]) :
+      mkTagXML "p" :
+      concat (tagXML "h1" [concat (map item2html title)]) :
+      empty :
+      map para2html paras
+
+para2html :: Paragraph -> String
+para2html p = case p of
+  Text its      -> concat (map item2html its)
+  Code s        -> unlines $ tagXML "pre" $ map (indent 2) $ 
+                                              remEmptyLines $ lines $ spec s
+  New           -> mkTagXML "p"
+  Heading i its -> concat $ tagXML ('h':show i) [concat (map item2html its)]
+
+item2html :: TextItem -> String
+item2html i = case i of
+  Str s -> spec s
+  Emp s -> concat $ tagXML "b" [spec s]
+  Lit s -> concat $ tagXML "i" [spec s]
+  Inl s -> concat $ tagXML "tt" [spec s]
+
+mkTagXML t = '<':t ++ ">"
+mkEndTagXML t = mkTagXML ('/':t)
+tagXML t ss = mkTagXML t : ss ++ [mkEndTagXML t]
+
+spec = elimLt
+
+elimLt s = case s of
+  '<':cs -> "&lt;" ++ elimLt cs
+  c  :cs -> c : elimLt cs
+  _      -> s
+
+
+-- render in latex
+
+doc2latex :: Doc -> String
+doc2latex (Doc title paras) = unlines $
+  preludeLatex :
+  funLatex "title"  [concat (map item2latex title)] :
+  funLatex "author" [fontLatex "footnotesize" (welcome)] :
+  envLatex "document" (
+    funLatex "maketitle" [] :
+    map para2latex paras)   
+
+para2latex :: Paragraph -> String
+para2latex p = case p of
+  Text its      -> concat (map item2latex its)
+  Code s        -> unlines $ envLatex "verbatim" $ map (indent 2) $ 
+                                                   remEmptyLines $ lines $ s
+  New           -> "\n"
+  Heading i its -> headingLatex i (concat (map item2latex its))
+
+item2latex :: TextItem -> String
+item2latex i = case i of
+  Str s -> specl s
+  Emp s -> fontLatex "bf" (specl s)
+  Lit s -> fontLatex "it" (specl s)
+  Inl s -> fontLatex "tt" (specl s)
+
+funLatex :: String -> [String] -> String
+funLatex f xs = "\\" ++ f ++ concat ["{" ++ x ++ "}" | x <- xs]
+
+envLatex :: String -> [String] -> [String]
+envLatex e ss = 
+  funLatex "begin" [e] :
+  ss ++
+  [funLatex "end" [e]]
+
+headingLatex :: Int -> String -> String
+-- for slides
+-- headingLatex _ s = funLatex "newone" [] ++ "\n" ++ funLatex "heading" [s] 
+headingLatex i s = funLatex t [s] where 
+  t = case i of
+    2 -> "section"
+    3 -> "subsection"
+    _ -> "subsubsection"
+
+fontLatex :: String -> String -> String
+fontLatex f s = "{\\" ++ f ++ " " ++ s ++ "}"
+
+specl = eliml
+
+eliml s = case s of
+  '|':cs -> mmath "mid" ++ elimLt cs
+  '{':cs -> mmath "\\{" ++ elimLt cs
+  '}':cs -> mmath "\\}" ++ elimLt cs
+  _      -> s
+
+mmath s = funLatex "mbox" ["$" ++ s ++ "$"]
+
+preludeLatex = unlines $ [
+  "\\documentclass[12pt]{article}",
+  "\\usepackage{isolatin1}",
+  "\\setlength{\\oddsidemargin}{0mm}",
+  "\\setlength{\\evensidemargin}{-2mm}",
+  "\\setlength{\\topmargin}{-16mm}",
+  "\\setlength{\\textheight}{240mm}",
+  "\\setlength{\\textwidth}{158mm}",
+  "\\setlength{\\parskip}{2mm}",
+  "\\setlength{\\parindent}{0mm}"
+ ]
+
+-- auxiliaries
+
+empty = ""
+
+isComment = (== "--") . take 2
+
+begComment =  (== "{-") . take 2
+
+getComment ss = case ss of
+  "-}":ls -> ([],ls)
+  l:ls -> (l : s1, s2) where (s1,s2) = getComment ls
+  _    -> ([],[])
+
+indent n = (replicate n ' ' ++)
+
+remEmptyLines = rem False where
+  rem prevGood ls = case span empty ls of
+    (_ :_, ss@(_ : _)) -> (if prevGood then ("":) else id) $ rem False ss
+    (_,    [])         -> []
+    (_,    s:ss)       -> s : rem True ss 
+  empty = all isSpace
diff --git a/src/tools/MkHelpFile.hs b/src/tools/MkHelpFile.hs
new file mode 100644
index 000000000..9355a688e
--- /dev/null
+++ b/src/tools/MkHelpFile.hs
@@ -0,0 +1,20 @@
+module Main where
+
+main = do
+  s <- readFile "HelpFile"
+  let s' = mkHsFile (lines s)
+  writeFile "HelpFile.hs" s'
+
+mkHsFile ss =
+  "module HelpFile where\n\n" ++
+  "txtHelpFile =\n" ++
+  unlines (map mkOne ss) ++
+  "  []"
+
+mkOne s = "  \"" ++ pref s ++ (escs s) ++ "\" ++"
+ where 
+   pref (' ':_) = "\\n"
+   pref _ = "\\n" ---
+   escs [] = []
+   escs (c:cs) | elem c "\"\\" = '\\':c:escs cs
+   escs (c:cs) = c:escs cs
diff --git a/src/tools/MkToday.hs b/src/tools/MkToday.hs
new file mode 100644
index 000000000..1a15de2b5
--- /dev/null
+++ b/src/tools/MkToday.hs
@@ -0,0 +1,15 @@
+module Main where
+
+import System
+
+main :: IO ()
+main = do
+  system "date >foo.tmp"
+  d0 <- readFile "foo.tmp"
+  let d = head $ lines d0
+  writeFile "Today.hs" $ mkToday d
+  system "rm foo.tmp"
+  return ()
+
+mkToday d = "module Today where today = \"" ++ d ++ "\"\n"
+
diff --git a/src/tools/WriteF.hs b/src/tools/WriteF.hs
new file mode 100644
index 000000000..fd491b4e5
--- /dev/null
+++ b/src/tools/WriteF.hs
@@ -0,0 +1,57 @@
+module Main where
+import Fudgets
+import System
+
+import Operations
+
+import Greek (mkGreek)
+import Arabic (mkArabic)
+import Hebrew (mkHebrew)
+import Russian (mkRussian)
+
+-- AR 12/4/2000
+
+main = do
+  xx <- getArgs
+  (case xx of
+     "HELP" : _ -> putStrLn usageWriteF
+     "FILE" : file : _ -> do
+            str <- readFileIf file
+            fudlogueWrite (Just str)
+     w:_ -> fudlogueWrite (Just (unwords xx)) 
+     _   -> fudlogueWrite Nothing)
+
+usageWriteF =
+  "Usage: WriteF [-H20Mg -A5M] [FILE <filename> | <inputstring> | HELP]" ++++
+  "Without arguments, an interactive display is opened." ++++
+  "Prefix your string with / for Greek, - for Arabic, + for Hebrew, _ for Russian."
+
+fudlogueWrite mbstr = 
+  fudlogue $
+  shellF "Unicode Output" (writeF mbstr >+< quitButtonF)
+
+writeF Nothing = writeOutputF >==< writeInputF
+writeF (Just str) = startupF [str] writeOutputF 
+
+displaySizeP = placerF (spacerP (sizeS (Point 440 500)) verticalP)
+
+writeOutputF = 
+  displaySizeP (moreF' (setFont myFont))
+---  displaySizeP (scrollF (displayF' (setFont myFont)))
+---    >=^<
+---  vboxD' 0 . map g 
+    >==< 
+  mapF (map mkUnicode . lines)
+
+writeInputF = stringInputF' (setShowString mkUnicode . setFont myFont)
+
+mkUnicode s = case s of
+ '/':cs -> mkGreek cs
+ '+':cs -> mkHebrew cs
+ '-':cs -> mkArabic cs
+ '_':cs -> mkRussian cs
+ _      -> s
+
+myFont = "-mutt-clearlyu-medium-r-normal--17-120-100-100-p-101-iso10646-1"
+--- myFont = "-arabic-newspaper-medium-r-normal--32-246-100-100-p-137-iso10646-1"
+--- myFont = "-misc-fixed-medium-r-semicondensed--13-120-75-75-c-60-iso10646-1"