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

src-3.0/GF/Source/AbsGF.hs

@@ -0,0 +1,306 @@
+module GF.Source.AbsGF where
+
+-- Haskell module generated by the BNF converter
+
+newtype LString = LString String deriving (Eq,Ord,Show)
+newtype PIdent = PIdent ((Int,Int),String) deriving (Eq,Ord,Show)
+data Grammar =
+   Gr [ModDef]
+  deriving (Eq,Ord,Show)
+
+data ModDef =
+   MMain PIdent PIdent [ConcSpec]
+ | MModule ComplMod ModType ModBody
+  deriving (Eq,Ord,Show)
+
+data ConcSpec =
+   ConcSpec PIdent ConcExp
+  deriving (Eq,Ord,Show)
+
+data ConcExp =
+   ConcExp PIdent [Transfer]
+  deriving (Eq,Ord,Show)
+
+data Transfer =
+   TransferIn Open
+ | TransferOut Open
+  deriving (Eq,Ord,Show)
+
+data ModType =
+   MTAbstract PIdent
+ | MTResource PIdent
+ | MTInterface PIdent
+ | MTConcrete PIdent PIdent
+ | MTInstance PIdent PIdent
+ | MTTransfer PIdent Open Open
+  deriving (Eq,Ord,Show)
+
+data ModBody =
+   MBody Extend Opens [TopDef]
+ | MNoBody [Included]
+ | MWith Included [Open]
+ | MWithBody Included [Open] Opens [TopDef]
+ | MWithE [Included] Included [Open]
+ | MWithEBody [Included] Included [Open] Opens [TopDef]
+ | MReuse PIdent
+ | MUnion [Included]
+  deriving (Eq,Ord,Show)
+
+data Extend =
+   Ext [Included]
+ | NoExt
+  deriving (Eq,Ord,Show)
+
+data Opens =
+   NoOpens
+ | OpenIn [Open]
+  deriving (Eq,Ord,Show)
+
+data Open =
+   OName PIdent
+ | OQualQO QualOpen PIdent
+ | OQual QualOpen PIdent PIdent
+  deriving (Eq,Ord,Show)
+
+data ComplMod =
+   CMCompl
+ | CMIncompl
+  deriving (Eq,Ord,Show)
+
+data QualOpen =
+   QOCompl
+ | QOIncompl
+ | QOInterface
+  deriving (Eq,Ord,Show)
+
+data Included =
+   IAll PIdent
+ | ISome PIdent [PIdent]
+ | IMinus PIdent [PIdent]
+  deriving (Eq,Ord,Show)
+
+data Def =
+   DDecl [Name] Exp
+ | DDef [Name] Exp
+ | DPatt Name [Patt] Exp
+ | DFull [Name] Exp Exp
+  deriving (Eq,Ord,Show)
+
+data TopDef =
+   DefCat [CatDef]
+ | DefFun [FunDef]
+ | DefFunData [FunDef]
+ | DefDef [Def]
+ | DefData [DataDef]
+ | DefTrans [Def]
+ | DefPar [ParDef]
+ | DefOper [Def]
+ | DefLincat [PrintDef]
+ | DefLindef [Def]
+ | DefLin [Def]
+ | DefPrintCat [PrintDef]
+ | DefPrintFun [PrintDef]
+ | DefFlag [FlagDef]
+ | DefPrintOld [PrintDef]
+ | DefLintype [Def]
+ | DefPattern [Def]
+ | DefPackage PIdent [TopDef]
+ | DefVars [Def]
+ | DefTokenizer PIdent
+  deriving (Eq,Ord,Show)
+
+data CatDef =
+   SimpleCatDef PIdent [DDecl]
+ | ListCatDef PIdent [DDecl]
+ | ListSizeCatDef PIdent [DDecl] Integer
+  deriving (Eq,Ord,Show)
+
+data FunDef =
+   FunDef [PIdent] Exp
+  deriving (Eq,Ord,Show)
+
+data DataDef =
+   DataDef PIdent [DataConstr]
+  deriving (Eq,Ord,Show)
+
+data DataConstr =
+   DataId PIdent
+ | DataQId PIdent PIdent
+  deriving (Eq,Ord,Show)
+
+data ParDef =
+   ParDefDir PIdent [ParConstr]
+ | ParDefIndir PIdent PIdent
+ | ParDefAbs PIdent
+  deriving (Eq,Ord,Show)
+
+data ParConstr =
+   ParConstr PIdent [DDecl]
+  deriving (Eq,Ord,Show)
+
+data PrintDef =
+   PrintDef [Name] Exp
+  deriving (Eq,Ord,Show)
+
+data FlagDef =
+   FlagDef PIdent PIdent
+  deriving (Eq,Ord,Show)
+
+data Name =
+   IdentName PIdent
+ | ListName PIdent
+  deriving (Eq,Ord,Show)
+
+data LocDef =
+   LDDecl [PIdent] Exp
+ | LDDef [PIdent] Exp
+ | LDFull [PIdent] Exp Exp
+  deriving (Eq,Ord,Show)
+
+data Exp =
+   EIdent PIdent
+ | EConstr PIdent
+ | ECons PIdent
+ | ESort Sort
+ | EString String
+ | EInt Integer
+ | EFloat Double
+ | EMeta
+ | EEmpty
+ | EData
+ | EList PIdent Exps
+ | EStrings String
+ | ERecord [LocDef]
+ | ETuple [TupleComp]
+ | EIndir PIdent
+ | ETyped Exp Exp
+ | EProj Exp Label
+ | EQConstr PIdent PIdent
+ | EQCons PIdent PIdent
+ | EApp Exp Exp
+ | ETable [Case]
+ | ETTable Exp [Case]
+ | EVTable Exp [Exp]
+ | ECase Exp [Case]
+ | EVariants [Exp]
+ | EPre Exp [Altern]
+ | EStrs [Exp]
+ | EConAt PIdent Exp
+ | EPatt Patt
+ | EPattType Exp
+ | ESelect Exp Exp
+ | ETupTyp Exp Exp
+ | EExtend Exp Exp
+ | EGlue Exp Exp
+ | EConcat Exp Exp
+ | EAbstr [Bind] Exp
+ | ECTable [Bind] Exp
+ | EProd Decl Exp
+ | ETType Exp Exp
+ | ELet [LocDef] Exp
+ | ELetb [LocDef] Exp
+ | EWhere Exp [LocDef]
+ | EEqs [Equation]
+ | EExample Exp String
+ | ELString LString
+ | ELin PIdent
+  deriving (Eq,Ord,Show)
+
+data Exps =
+   NilExp
+ | ConsExp Exp Exps
+  deriving (Eq,Ord,Show)
+
+data Patt =
+   PChar
+ | PChars String
+ | PMacro PIdent
+ | PM PIdent PIdent
+ | PW
+ | PV PIdent
+ | PCon PIdent
+ | PQ PIdent PIdent
+ | PInt Integer
+ | PFloat Double
+ | PStr String
+ | PR [PattAss]
+ | PTup [PattTupleComp]
+ | PC PIdent [Patt]
+ | PQC PIdent PIdent [Patt]
+ | PDisj Patt Patt
+ | PSeq Patt Patt
+ | PRep Patt
+ | PAs PIdent Patt
+ | PNeg Patt
+  deriving (Eq,Ord,Show)
+
+data PattAss =
+   PA [PIdent] Patt
+  deriving (Eq,Ord,Show)
+
+data Label =
+   LIdent PIdent
+ | LVar Integer
+  deriving (Eq,Ord,Show)
+
+data Sort =
+   Sort_Type
+ | Sort_PType
+ | Sort_Tok
+ | Sort_Str
+ | Sort_Strs
+  deriving (Eq,Ord,Show)
+
+data Bind =
+   BIdent PIdent
+ | 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 Patt 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 PIdent
+ | FSlash FileName
+ | FDot FileName
+ | FMinus FileName
+ | FAddId PIdent FileName
+  deriving (Eq,Ord,Show)
+

src-3.0/GF/Source/ErrM.hs

@@ -0,0 +1,26 @@
+-- BNF Converter: Error Monad
+-- Copyright (C) 2004  Author:  Aarne Ranta
+
+-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE.
+module GF.Source.ErrM where
+
+-- the Error monad: like Maybe type with error msgs
+
+import Control.Monad (MonadPlus(..), liftM)
+
+data Err a = Ok a | Bad String
+  deriving (Read, Show, Eq, Ord)
+
+instance Monad Err where
+  return      = Ok
+  fail        = Bad
+  Ok a  >>= f = f a
+  Bad s >>= f = Bad s
+
+instance Functor Err where
+  fmap = liftM
+
+instance MonadPlus Err where
+  mzero = Bad "Err.mzero"
+  mplus (Bad _) y = y
+  mplus x       _ = x

src-3.0/GF/Source/GF.cf

@@ -0,0 +1,370 @@
+-- AR 2/5/2003, 14-16 o'clock, Torino
+
+-- 17/6/2007: marked with suffix --% those lines that are obsolete and
+-- should not be included in documentation
+
+entrypoints Grammar, ModDef, 
+  OldGrammar, --%
+  Exp ; -- let's see if more are needed
+
+comment "--" ;
+comment "{-" "-}" ;
+
+-- the top-level grammar
+
+Gr. Grammar ::= [ModDef] ;
+
+-- semicolon after module is permitted but not obligatory
+
+terminator ModDef "" ;
+_. ModDef ::= ModDef ";" ;
+
+-- The $main$ multilingual grammar structure --%
+
+MMain. ModDef ::= "grammar" PIdent "=" "{" "abstract" "=" PIdent ";" [ConcSpec] "}" ;--%
+
+ConcSpec. ConcSpec ::= PIdent "=" ConcExp ;--%
+separator ConcSpec ";" ;--%
+
+ConcExp. ConcExp ::= PIdent [Transfer] ;--%
+
+separator Transfer "" ;--%
+TransferIn.  Transfer ::= "(" "transfer" "in" Open ")" ;  --%
+TransferOut. Transfer ::= "(" "transfer" "out" Open ")" ;  --%
+
+-- the module header
+
+MModule2. ModHeader ::= ComplMod ModType "=" ModHeaderBody ;
+
+MBody2.      ModHeaderBody ::= Extend Opens ;
+MNoBody2.    ModHeaderBody ::= [Included] ;
+MWith2.      ModHeaderBody ::=                 Included "with" [Open] ;
+MWithBody2.  ModHeaderBody ::=                 Included "with" [Open] "**" Opens ; 
+MWithE2.     ModHeaderBody ::= [Included] "**" Included "with" [Open] ;
+MWithEBody2. ModHeaderBody ::= [Included] "**" Included "with" [Open] "**" Opens ; 
+
+MReuse2. ModHeaderBody ::= "reuse" PIdent ; --%
+MUnion2. ModHeaderBody ::= "union" [Included] ;--%
+
+-- the individual modules
+
+MModule. ModDef ::= ComplMod ModType "=" ModBody ;
+
+MTAbstract.  ModType ::= "abstract" PIdent ;
+MTResource.  ModType ::= "resource" PIdent ;
+MTInterface. ModType ::= "interface" PIdent ;
+MTConcrete.  ModType ::= "concrete" PIdent "of" PIdent ;
+MTInstance.  ModType ::= "instance" PIdent "of" PIdent ;
+MTTransfer.  ModType ::= "transfer" PIdent ":" Open "->" Open ;
+
+
+MBody.      ModBody ::= Extend Opens "{" [TopDef] "}" ;
+MNoBody.    ModBody ::= [Included] ;
+MWith.      ModBody ::=                 Included "with" [Open] ;
+MWithBody.  ModBody ::=                 Included "with" [Open] "**" Opens "{" [TopDef] "}" ; 
+MWithE.     ModBody ::= [Included] "**" Included "with" [Open] ;
+MWithEBody. ModBody ::= [Included] "**" Included "with" [Open] "**" Opens "{" [TopDef] "}" ; 
+
+MReuse. ModBody ::= "reuse" PIdent ; --%
+MUnion. ModBody ::= "union" [Included] ;--%
+
+separator TopDef "" ;
+
+Ext.   Extend ::= [Included] "**" ;
+NoExt. Extend ::= ;
+
+separator Open "," ;
+NoOpens. Opens ::= ;
+OpenIn.  Opens ::= "open" [Open] "in" ;
+
+OName.   Open ::= PIdent ;
+OQualQO. Open ::= "(" QualOpen PIdent ")" ;
+OQual.   Open ::= "(" QualOpen PIdent "=" PIdent ")" ;
+
+CMCompl.   ComplMod ::= ;
+CMIncompl. ComplMod ::= "incomplete" ;
+
+QOCompl.     QualOpen ::= ;
+QOIncompl.   QualOpen ::= "incomplete" ;--%
+QOInterface. QualOpen ::= "interface" ;--%
+
+separator Included "," ;
+
+IAll.   Included ::= PIdent ;
+ISome.  Included ::= PIdent "[" [PIdent] "]" ;
+IMinus. Included ::= PIdent "-" "[" [PIdent] "]" ;
+
+-- definitions after the $oper$ keywords
+
+DDecl.  Def ::= [Name] ":" Exp ;
+DDef.   Def ::= [Name] "=" Exp ;
+DPatt.  Def ::= Name [Patt] "=" Exp ;  -- non-empty pattern list
+DFull.  Def ::= [Name] ":" Exp "=" Exp ;
+
+-- top-level definitions
+
+DefCat.    TopDef ::= "cat" [CatDef] ;
+DefFun.    TopDef ::= "fun" [FunDef] ;
+DefFunData.TopDef ::= "data" [FunDef] ;
+DefDef.    TopDef ::= "def" [Def] ;
+DefData.   TopDef ::= "data" [DataDef] ;
+
+DefTrans.  TopDef ::= "transfer" [Def] ;--%
+
+DefPar.    TopDef ::= "param" [ParDef] ;
+DefOper.   TopDef ::= "oper"  [Def] ;
+
+DefLincat. TopDef ::= "lincat" [PrintDef] ;
+DefLindef. TopDef ::= "lindef" [Def] ;
+DefLin.    TopDef ::= "lin"    [Def] ;
+
+DefPrintCat. TopDef ::= "printname" "cat" [PrintDef] ;
+DefPrintFun. TopDef ::= "printname" "fun" [PrintDef] ;
+DefFlag.     TopDef ::= "flags" [FlagDef] ;
+
+SimpleCatDef.   CatDef ::= PIdent [DDecl] ;
+ListCatDef.     CatDef ::= "[" PIdent [DDecl] "]" ;
+ListSizeCatDef. CatDef ::= "[" PIdent [DDecl] "]" "{" Integer "}" ;
+
+FunDef.    FunDef ::= [PIdent] ":" Exp ;
+
+DataDef.   DataDef    ::= PIdent "=" [DataConstr] ;
+DataId.    DataConstr ::= PIdent ;
+DataQId.   DataConstr ::= PIdent "." PIdent ;
+separator DataConstr "|" ;
+
+
+ParDefDir.   ParDef ::= PIdent "=" [ParConstr] ;
+ParDefIndir. ParDef ::= PIdent "=" "(" "in" PIdent ")" ;
+ParDefAbs.   ParDef ::= PIdent ;
+
+ParConstr. ParConstr ::= PIdent [DDecl] ;
+
+PrintDef. PrintDef ::= [Name] "=" Exp ;
+
+FlagDef. FlagDef ::= PIdent "=" PIdent ;
+
+terminator nonempty Def ";" ;
+terminator nonempty CatDef ";" ;
+terminator nonempty FunDef ";" ;
+terminator nonempty DataDef ";" ;
+terminator nonempty ParDef ";" ;
+
+terminator nonempty PrintDef ";" ;
+terminator nonempty FlagDef ";" ;
+
+separator ParConstr "|" ;
+
+separator nonempty PIdent "," ;
+
+-- names of categories and functions in definition LHS
+
+IdentName. Name ::= PIdent ;
+ListName.  Name ::= "[" PIdent "]" ;
+
+separator nonempty Name "," ;
+
+-- definitions in records and $let$ expressions
+
+LDDecl.  LocDef ::= [PIdent] ":" Exp ;
+LDDef.   LocDef ::= [PIdent] "=" Exp ;
+LDFull.  LocDef ::= [PIdent] ":" Exp "=" Exp ;
+
+separator LocDef ";" ;
+
+-- terms and types
+
+EIdent.    Exp6 ::= PIdent ;
+EConstr.   Exp6 ::= "{" PIdent "}" ;--%
+ECons.     Exp6 ::= "%" PIdent "%" ;--%
+ESort.     Exp6 ::= Sort ;
+EString.   Exp6 ::= String ;
+EInt.      Exp6 ::= Integer ;
+EFloat.    Exp6 ::= Double ;
+EMeta.     Exp6 ::= "?" ;
+EEmpty.    Exp6 ::= "[" "]" ;
+EData.     Exp6 ::= "data" ;
+EList.     Exp6 ::= "[" PIdent Exps "]" ;
+EStrings.  Exp6 ::= "[" String "]" ;
+ERecord.   Exp6 ::= "{" [LocDef] "}" ; -- !
+ETuple.    Exp6 ::= "<" [TupleComp] ">" ;  --- needed for separator ","
+EIndir.    Exp6 ::= "(" "in" PIdent ")" ;   -- indirection, used in judgements --%
+ETyped.    Exp6 ::= "<" Exp ":" Exp ">" ;  -- typing, used for annotations
+
+EProj.     Exp5 ::= Exp5 "." Label ;
+EQConstr.  Exp5 ::= "{" PIdent "." PIdent "}" ;  -- qualified constructor --%
+EQCons.    Exp5 ::= "%" PIdent "." PIdent  ;     -- qualified constant --%
+
+EApp.      Exp4 ::= Exp4 Exp5 ;
+ETable.    Exp4 ::= "table" "{" [Case] "}" ;
+ETTable.   Exp4 ::= "table" Exp6 "{" [Case] "}" ;
+EVTable.   Exp4 ::= "table" Exp6 "[" [Exp] "]" ;
+ECase.     Exp4 ::= "case" Exp "of" "{" [Case] "}" ;
+EVariants. Exp4 ::= "variants" "{" [Exp] "}" ;
+--- EPreCase.  Exp4 ::= "pre" "{" [Case] "}" ;
+EPre.      Exp4 ::= "pre" "{" Exp ";" [Altern] "}" ;
+EStrs.     Exp4 ::= "strs" "{" [Exp] "}" ;
+EConAt.    Exp4 ::= PIdent "@" Exp6 ; --%
+
+EPatt.     Exp4 ::= "#" Patt2 ;
+EPattType. Exp4 ::= "pattern" Exp5 ;
+
+ESelect.   Exp3 ::= Exp3 "!" Exp4 ;
+ETupTyp.   Exp3 ::= Exp3 "*" Exp4 ;
+EExtend.   Exp3 ::= Exp3 "**" Exp4 ;
+
+EGlue.     Exp1 ::= Exp2 "+"  Exp1 ;
+
+EConcat.   Exp  ::= Exp1 "++" Exp ;
+
+EAbstr.    Exp  ::= "\\" [Bind] "->" Exp ;
+ECTable.   Exp  ::= "\\""\\" [Bind] "=>" Exp ;
+EProd.     Exp  ::= Decl "->" Exp ;
+ETType.    Exp  ::= Exp3 "=>" Exp ; -- these are thus right associative
+ELet.      Exp  ::= "let" "{" [LocDef] "}" "in" Exp ;
+ELetb.     Exp  ::= "let" [LocDef] "in" Exp ;
+EWhere.    Exp  ::= Exp3 "where" "{" [LocDef] "}" ;
+EEqs.      Exp  ::= "fn" "{" [Equation] "}" ; --%
+
+EExample.  Exp  ::= "in" Exp5 String ;
+
+coercions Exp 6 ;
+
+separator Exp ";" ; -- in variants
+
+-- list of arguments to category
+NilExp. Exps ::= ;
+ConsExp. Exps ::= Exp6 Exps ; -- Exp6 to force parantheses
+
+-- patterns
+
+PChar.  Patt2  ::= "?" ;
+PChars. Patt2  ::= "[" String "]" ;
+PMacro. Patt2  ::= "#" PIdent ;
+PM.     Patt2  ::= "#" PIdent "." PIdent ;
+PW.     Patt2  ::= "_" ;
+PV.     Patt2  ::= PIdent ;
+PCon.   Patt2  ::= "{" PIdent "}" ; --%
+PQ.     Patt2  ::= PIdent "." PIdent ;
+PInt.   Patt2  ::= Integer ;
+PFloat. Patt2  ::= Double ;
+PStr.   Patt2  ::= String ;
+PR.     Patt2  ::= "{" [PattAss] "}" ;
+PTup.   Patt2  ::= "<" [PattTupleComp] ">" ;
+PC.     Patt1  ::= PIdent [Patt] ;
+PQC.    Patt1  ::= PIdent "." PIdent [Patt] ;
+PDisj.  Patt   ::= Patt "|" Patt1 ;
+PSeq.   Patt   ::= Patt "+" Patt1 ;
+PRep.   Patt1  ::= Patt2 "*" ;
+PAs.    Patt1  ::= PIdent "@" Patt2 ;
+PNeg.   Patt1  ::= "-" Patt2 ;
+
+coercions Patt 2 ;
+
+PA.  PattAss ::= [PIdent] "=" Patt ;
+
+-- labels
+
+LIdent. Label ::= PIdent ;
+LVar.   Label ::= "$" Integer ;
+
+-- basic types
+
+rules Sort ::= 
+    "Type" 
+  | "PType" 
+  | "Tok"  --%
+  | "Str" 
+  | "Strs" ;
+
+separator PattAss ";" ;
+
+-- this is explicit to force higher precedence level on rhs
+(:[]). [Patt] ::= Patt2 ;
+(:).   [Patt] ::= Patt2 [Patt] ;
+
+
+-- binds in lambdas and lin rules
+
+BIdent. Bind ::= PIdent ;
+BWild.  Bind ::= "_" ;
+
+separator Bind "," ;
+
+
+-- declarations in function types
+
+DDec.  Decl ::= "(" [Bind] ":" Exp ")" ;
+DExp.  Decl ::= Exp4 ; -- can thus be an application
+
+-- tuple component (term or pattern)
+
+TComp. TupleComp ::= Exp ;
+PTComp. PattTupleComp ::= Patt ;
+
+separator TupleComp "," ;
+separator PattTupleComp "," ;
+
+-- case branches
+
+Case. Case ::= Patt "=>" Exp ;
+
+separator nonempty Case ";" ;
+
+-- cases in abstract syntax --%
+
+Equ. Equation ::= [Patt] "->" Exp ; --%
+
+separator Equation ";" ; --%
+
+-- prefix alternatives
+
+Alt. Altern ::= Exp "/" Exp ;
+
+separator Altern ";" ;
+
+-- in a context, higher precedence is required than in function types
+
+DDDec.  DDecl ::= "(" [Bind] ":" Exp ")" ;
+DDExp.  DDecl ::= Exp6 ;  -- can thus *not* be an application
+
+separator DDecl "" ;
+
+
+-------------------------------------- --%
+
+-- for backward compatibility --%
+
+OldGr.  OldGrammar ::= Include [TopDef] ; --%
+
+NoIncl. Include ::= ; --%
+Incl.   Include ::= "include" [FileName] ; --%
+
+FString. FileName ::= String ; --%
+
+terminator nonempty FileName ";" ; --%
+
+FIdent.  FileName ::= PIdent ; --%
+FSlash.  FileName ::= "/" FileName ; --%
+FDot.    FileName ::= "." FileName ; --%
+FMinus.  FileName ::= "-" FileName ; --%
+FAddId.  FileName ::= PIdent FileName ; --%
+
+token LString '\'' (char - '\'')* '\'' ; --%
+ELString.  Exp6 ::= LString ; --%
+ELin.      Exp4 ::= "Lin" PIdent ; --%
+
+DefPrintOld.  TopDef ::= "printname" [PrintDef] ; --%
+DefLintype.   TopDef ::= "lintype"   [Def] ; --%
+DefPattern.   TopDef ::= "pattern"   [Def] ; --%
+
+-- deprecated packages are attempted to be interpreted --%
+DefPackage.   TopDef ::= "package" PIdent "=" "{" [TopDef] "}" ";" ; --%
+
+-- these two are just ignored after parsing --%
+DefVars.      TopDef ::= "var" [Def] ; --%
+DefTokenizer. TopDef ::= "tokenizer" PIdent ";" ; --%
+
+-- identifiers
+
+position token PIdent ('_' | letter) (letter | digit | '_' | '\'')* ;

src-3.0/GF/Source/GrammarToSource.hs

@@ -0,0 +1,259 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GrammarToSource
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/10/04 11:05:07 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.23 $
+--
+-- From internal source syntax to BNFC-generated (used for printing).
+-----------------------------------------------------------------------------
+
+module GF.Source.GrammarToSource ( trGrammar,
+			 trModule,
+			 trAnyDef,
+			 trLabel,
+			 trt, tri, trp
+		       ) where
+
+import GF.Data.Operations
+import GF.Grammar.Grammar
+import GF.Infra.Modules
+import GF.Infra.Option
+import qualified GF.Source.AbsGF as P
+import GF.Infra.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 -> P.MModule compl typ body where
+    compl = case mstatus m of
+      MSIncomplete -> P.CMIncompl
+      _ -> P.CMCompl
+    i' = tri i
+    typ = case typeOfModule mo of
+      MTResource -> P.MTResource i'
+      MTAbstract -> P.MTAbstract i'
+      MTConcrete a -> P.MTConcrete i' (tri a)
+      MTTransfer a b -> P.MTTransfer i' (trOpen a) (trOpen b)
+      MTInstance a -> P.MTInstance i' (tri a)
+      MTInterface -> P.MTInterface i'
+    body = P.MBody 
+             (trExtends (extend m)) 
+             (mkOpens (map trOpen (opens m)))
+             (mkTopDefs (concatMap trAnyDef (tree2list (jments m)) ++ map trFlag (flags m)))
+
+trExtends :: [(Ident,MInclude Ident)] -> P.Extend
+trExtends [] = P.NoExt 
+trExtends es = (P.Ext $ map tre es) where
+  tre (i,c) = case c of 
+    MIAll       -> P.IAll   (tri i)
+    MIOnly is   -> P.ISome  (tri i) (map tri is)
+    MIExcept is -> P.IMinus (tri i) (map tri is)
+
+---- this has to be completed with other mtys
+forName (MTConcrete a) = tri a
+
+trOpen :: OpenSpec Ident -> P.Open
+trOpen o = case o of
+  OSimple OQNormal i -> P.OName (tri i)
+  OSimple q i -> P.OQualQO (trQualOpen q) (tri i)
+  OQualif q i j -> P.OQual (trQualOpen q) (tri i) (tri j)
+
+trQualOpen q = case q of
+  OQNormal -> P.QOCompl
+  OQIncomplete -> P.QOIncompl
+  OQInterface -> P.QOInterface
+
+
+mkOpens ds = if null ds then P.NoOpens else P.OpenIn ds
+mkTopDefs ds = ds
+
+trAnyDef :: (Ident,Info) -> [P.TopDef]
+trAnyDef (i,info) = let i' = tri i in case info of
+  AbsCat (Yes co) pd -> [P.DefCat [P.SimpleCatDef i' (map trDecl co)]]
+  AbsFun (Yes ty) (Yes EData) -> [P.DefFunData [P.FunDef [i'] (trt ty)]]
+  AbsFun (Yes ty) pt -> [P.DefFun [P.FunDef [i'] (trt ty)]] ++ case pt of
+    Yes t -> [P.DefDef [P.DDef [mkName i'] (trt t)]]
+    _ -> []
+  AbsFun (May b)  _ -> [P.DefFun [P.FunDef [i'] (P.EIndir (tri b))]]
+  ---- don't destroy definitions!
+  AbsTrans f -> [P.DefTrans [P.DDef [mkName i'] (trt f)]]
+
+  ResOper pty ptr -> [P.DefOper [trDef i' pty ptr]]
+  ResParam pp -> [P.DefPar [case pp of
+    Yes (ps,_) -> P.ParDefDir i' [P.ParConstr (tri c) (map trDecl co) | (c,co) <- ps]
+    May b  -> P.ParDefIndir i' $ tri b
+    _      -> P.ParDefAbs i']]
+
+  ResOverload tysts -> 
+    [P.DefOper [P.DDef [mkName i'] (
+      P.EApp (P.EIdent $ tri $ identC "overload") 
+        (P.ERecord [P.LDFull [i'] (trt ty) (trt fu) | (ty,fu) <- tysts]))]]
+
+  CncCat (Yes ty) Nope _ -> 
+    [P.DefLincat [P.PrintDef [mkName i'] (trt ty)]] 
+  CncCat pty ptr ppr -> 
+    [P.DefLindef [trDef i' pty ptr]] ++
+    [P.DefPrintCat [P.PrintDef [mkName i'] (trt pr)] | Yes pr <- [ppr]]
+  CncFun _ ptr ppr -> 
+    [P.DefLin [trDef i' nope ptr]] ++ 
+    [P.DefPrintFun [P.PrintDef [mkName i'] (trt pr)] | Yes pr <- [ppr]]
+{-
+  ---- encoding of AnyInd without changing syntax. AR 20/9/2007
+  AnyInd s b -> 
+    [P.DefOper [P.DDef [mkName i] 
+      (P.EApp (P.EInt (if s then 1 else 0)) (P.EIdent (tri b)))]]
+-}
+  _ -> [] 
+
+
+trDef :: P.PIdent -> Perh Type -> Perh Term -> P.Def
+trDef i pty ptr = case (pty,ptr) of
+  (Nope,     Nope) -> P.DDef  [mkName i] (P.EMeta) ---
+  (_,        Nope) -> P.DDecl [mkName i] (trPerh pty)
+  (Nope,     _   ) -> P.DDef  [mkName i] (trPerh ptr)
+  (_,        _   ) -> P.DFull [mkName 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 (tri $ identC f) (tri $ 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
+    Sort s -> P.ESort $ case s of
+      "Type" -> P.Sort_Type
+      "PType" -> P.Sort_PType
+      "Tok" -> P.Sort_Tok
+      "Str" -> P.Sort_Str
+      "Strs" -> P.Sort_Strs
+      _ -> error $ "not yet sort " +++ show trm ----
+
+    App c a -> P.EApp (trt c) (trt a)
+    Abs x b -> P.EAbstr [trb x] (trt b)
+    Eqs pts -> P.EEqs [P.Equ (map trp ps) (trt t) | (ps,t) <- pts]
+    Meta m  -> P.EMeta
+    Prod x a b | isWildIdent x -> P.EProd (P.DExp (trt a)) (trt b)
+    Prod x a b -> P.EProd (P.DDec [trb x] (trt a)) (trt b)
+
+    Example t s -> P.EExample (trt t) s
+    R [] -> P.ETuple [] --- to get correct parsing when read back
+    R r -> P.ERecord $ map trAssign r
+    RecType r -> P.ERecord $ map trLabelling r
+    ExtR x y -> P.EExtend (trt x) (trt y)
+    P t l -> P.EProj (trt t) (trLabel l)
+    PI t l _ -> P.EProj (trt t) (trLabel l)
+    Q t l -> P.EQCons (tri t) (tri l)
+    QC t l -> P.EQConstr (tri t) (tri l)
+    TSh (TComp ty) cc -> P.ETTable (trt ty) (map trCases cc)
+    TSh (TTyped ty) cc -> P.ETTable (trt ty) (map trCases cc)
+    TSh (TWild ty) cc -> P.ETTable (trt ty) (map trCases cc)
+    T (TTyped ty) cc -> P.ETTable (trt ty) (map trCase cc)
+    T (TComp ty) cc -> P.ETTable (trt ty) (map trCase cc)
+    T (TWild ty) cc -> P.ETTable (trt ty) (map trCase cc)
+    T _ cc -> P.ETable (map trCase cc)
+    V ty cc -> P.EVTable (trt ty) (map trt cc)
+
+    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 i
+    EFloat i -> P.EFloat i
+
+    EPatt p -> P.EPatt (trp p)
+    EPattType t -> P.EPattType (trt t)
+
+    Glue a b -> P.EGlue (trt a) (trt b)
+    Alts (t, tt) -> P.EPre (trt t) [P.Alt (trt v) (trt c) | (v,c) <- tt]
+    FV ts -> P.EVariants $ map trt ts
+    Strs tt -> P.EStrs $ map trt tt
+    EData -> P.EData
+    _ -> error $ "not yet" +++ show trm ----
+
+trp :: Patt -> P.Patt
+trp p = case p of
+    PW -> P.PW
+    PV s | isWildIdent s -> P.PW
+    PV s -> P.PV $ tri s
+    PC c [] -> P.PCon $ tri c
+    PC c a -> P.PC (tri c) (map trp a)
+    PP p c [] -> P.PQ (tri p) (tri c)
+    PP p c a -> P.PQC (tri p) (tri c) (map trp a)
+    PR r -> P.PR [P.PA [tri $ trLabelIdent l] (trp p) | (l,p) <- r]
+    PString s -> P.PStr s
+    PInt i -> P.PInt i
+    PFloat i -> P.PFloat i
+    PT t p -> trp p ---- prParenth (prt p +++ ":" +++ prt t)
+
+    PAs  x p -> P.PAs (tri x) (trp p)
+
+    PAlt p q -> P.PDisj (trp p) (trp q)
+    PSeq p q -> P.PSeq (trp p) (trp q)
+    PRep p   -> P.PRep (trp p)
+    PNeg p   -> P.PNeg (trp p)
+    PChar    -> P.PChar
+    PChars s -> P.PChars s
+    PM m c   -> P.PM (tri m) (tri c)
+
+
+trAssign (lab, (mty, t)) = maybe (P.LDDef x t') (\ty -> P.LDFull x (trt ty) t') mty
+  where 
+    t' = trt t
+    x  = [tri $ trLabelIdent lab]
+
+trLabelling (lab,ty) = P.LDDecl [tri $ trLabelIdent lab] (trt ty)
+
+trCase  (patt, trm) = P.Case (trp patt) (trt trm)
+trCases (patts,trm) = P.Case (foldl1 P.PDisj (map trp patts)) (trt trm)
+
+trDecl (x,ty) = P.DDDec [trb x] (trt ty)
+
+tri :: Ident -> P.PIdent
+tri = ppIdent . prIdent 
+
+ppIdent i = P.PIdent ((0,0),i)
+
+trb i = if isWildIdent i then P.BWild else P.BIdent (tri i)
+
+trLabel :: Label -> P.Label
+trLabel i = case i of
+  LIdent s -> P.LIdent $ ppIdent s
+  LVar i -> P.LVar $ toInteger i
+
+trLabelIdent i = identC $ case i of
+  LIdent s -> s
+  LVar i -> "v" ++ show i --- should not happen
+
+mkName :: P.PIdent -> P.Name
+mkName = P.IdentName

src-3.0/GF/Source/LexGF.x

@@ -0,0 +1,137 @@
+-- -*- haskell -*-
+-- This Alex file was machine-generated by the BNF converter
+{
+module LexGF where
+
+import ErrM
+import SharedString
+}
+
+
+$l = [a-zA-Z\192 - \255] # [\215 \247]    -- isolatin1 letter FIXME
+$c = [A-Z\192-\221] # [\215]    -- capital isolatin1 letter FIXME
+$s = [a-z\222-\255] # [\247]    -- small isolatin1 letter FIXME
+$d = [0-9]                -- digit
+$i = [$l $d _ ']          -- identifier character
+$u = [\0-\255]          -- universal: any character
+
+@rsyms =    -- reserved words consisting of special symbols
+   \; | \= | \{ | \} | \( | \) | \: | \- \> | \* \* | \, | \[ | \] | \- | \. | \| | \% | \? | \< | \> | \@ | \! | \* | \+ | \+ \+ | \\ | \= \> | \_ | \$ | \/
+
+:-
+"--" [.]* ; -- Toss single line comments
+"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ; 
+
+$white+ ;
+@rsyms { tok (\p s -> PT p (TS $ share s)) }
+\' ($u # \')* \' { tok (\p s -> PT p (eitherResIdent (T_LString . share) s)) }
+
+$l $i*   { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
+\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \"{ tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) }
+
+$d+      { tok (\p s -> PT p (TI $ share s))    }
+$d+ \. $d+ (e (\-)? $d+)? { tok (\p s -> PT p (TD $ share s)) }
+
+{
+
+tok f p s = f p s
+
+share :: String -> String
+share = shareString
+
+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,Ord)
+
+data Token = 
+   PT  Posn Tok
+ | Err Posn
+  deriving (Eq,Show,Ord)
+
+tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
+tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
+tokenPos _ = "end of file"
+
+posLineCol (Pn _ l c) = (l,c)
+mkPosToken t@(PT p _) = (posLineCol p, prToken t)
+
+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
+  PT _ (T_LString s) -> s
+
+  _ -> show t
+
+data BTree = N | B String Tok BTree BTree deriving (Show)
+
+eitherResIdent :: (String -> Tok) -> String -> Tok
+eitherResIdent tv s = treeFind resWords
+  where
+  treeFind N = tv s
+  treeFind (B a t left right) | s < a  = treeFind left
+                              | s > a  = treeFind right
+                              | s == a = t
+
+resWords = b "lincat" (b "def" (b "Type" (b "Str" (b "PType" (b "Lin" N N) N) (b "Tok" (b "Strs" N N) N)) (b "cat" (b "case" (b "abstract" N N) N) (b "data" (b "concrete" N N) N))) (b "include" (b "fun" (b "fn" (b "flags" N N) N) (b "in" (b "grammar" N N) N)) (b "interface" (b "instance" (b "incomplete" N N) N) (b "lin" (b "let" N N) N)))) (b "resource" (b "out" (b "of" (b "lintype" (b "lindef" N N) N) (b "oper" (b "open" N N) N)) (b "pattern" (b "param" (b "package" N N) N) (b "printname" (b "pre" N N) N))) (b "union" (b "table" (b "strs" (b "reuse" N N) N) (b "transfer" (b "tokenizer" N N) N)) (b "where" (b "variants" (b "var" N N) N) (b "with" N N))))
+   where b s = B s (TS s)
+
+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
+    _         -> []
+
+-------------------------------------------------------------------
+-- Alex wrapper code.
+-- A modified "posn" wrapper.
+-------------------------------------------------------------------
+
+data Posn = Pn !Int !Int !Int
+      deriving (Eq, Show,Ord)
+
+alexStartPos :: Posn
+alexStartPos = Pn 0 1 1
+
+alexMove :: Posn -> Char -> Posn
+alexMove (Pn a l c) '\t' = Pn (a+1)  l     (((c+7) `div` 8)*8+1)
+alexMove (Pn a l c) '\n' = Pn (a+1) (l+1)   1
+alexMove (Pn a l c) _    = Pn (a+1)  l     (c+1)
+
+type AlexInput = (Posn, -- current position,
+		  Char,	-- previous char
+		  String)	-- current input string
+
+tokens :: String -> [Token]
+tokens str = go (alexStartPos, '\n', str)
+    where
+      go :: (Posn, Char, String) -> [Token]
+      go inp@(pos, _, str) =
+    	  case alexScan inp 0 of
+    	    AlexEOF                -> []
+    	    AlexError (pos, _, _)  -> fail $ show pos ++ ": lexical error"
+    	    AlexSkip  inp' len     -> go inp'
+    	    AlexToken inp' len act -> act pos (take len str) : (go inp')
+
+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
+alexGetChar (p, c, [])    = Nothing
+alexGetChar (p, _, (c:s)) =
+    let p' = alexMove p c
+     in p' `seq` Just (c, (p', c, s))
+
+alexInputPrevChar :: AlexInput -> Char
+alexInputPrevChar (p, c, s) = c
+}

src-3.0/GF/Source/ParGF.y

@@ -0,0 +1,642 @@
+-- This Happy file was machine-generated by the BNF converter
+{
+{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}
+ module GF.Source.ParGF (pGrammar, pModDef, pOldGrammar, pExp, pModHeader, myLexer) where --H
+import GF.Source.AbsGF       --H
+import GF.Source.LexGF       --H
+import GF.Infra.Ident        --H
+import GF.Data.ErrM          --H
+}
+
+%name pGrammar Grammar
+%name pModDef ModDef
+%name pOldGrammar OldGrammar
+%name pExp Exp
+%partial pModHeader ModHeader
+
+-- no lexer declaration
+%monad { Err } { thenM } { returnM }
+%tokentype { Token }
+
+%token 
+ ';' { PT _ (TS ";") }
+ '=' { PT _ (TS "=") }
+ '{' { PT _ (TS "{") }
+ '}' { PT _ (TS "}") }
+ '(' { PT _ (TS "(") }
+ ')' { PT _ (TS ")") }
+ ':' { PT _ (TS ":") }
+ '->' { PT _ (TS "->") }
+ '**' { PT _ (TS "**") }
+ ',' { PT _ (TS ",") }
+ '[' { PT _ (TS "[") }
+ ']' { PT _ (TS "]") }
+ '-' { PT _ (TS "-") }
+ '.' { PT _ (TS ".") }
+ '|' { PT _ (TS "|") }
+ '%' { PT _ (TS "%") }
+ '?' { PT _ (TS "?") }
+ '<' { PT _ (TS "<") }
+ '>' { PT _ (TS ">") }
+ '@' { PT _ (TS "@") }
+ '#' { PT _ (TS "#") }
+ '!' { PT _ (TS "!") }
+ '*' { PT _ (TS "*") }
+ '+' { PT _ (TS "+") }
+ '++' { PT _ (TS "++") }
+ '\\' { PT _ (TS "\\") }
+ '=>' { PT _ (TS "=>") }
+ '_' { PT _ (TS "_") }
+ '$' { PT _ (TS "$") }
+ '/' { PT _ (TS "/") }
+ 'Lin' { PT _ (TS "Lin") }
+ 'PType' { PT _ (TS "PType") }
+ 'Str' { PT _ (TS "Str") }
+ 'Strs' { PT _ (TS "Strs") }
+ 'Tok' { PT _ (TS "Tok") }
+ 'Type' { PT _ (TS "Type") }
+ 'abstract' { PT _ (TS "abstract") }
+ 'case' { PT _ (TS "case") }
+ 'cat' { PT _ (TS "cat") }
+ 'concrete' { PT _ (TS "concrete") }
+ 'data' { PT _ (TS "data") }
+ 'def' { PT _ (TS "def") }
+ 'flags' { PT _ (TS "flags") }
+ 'fn' { PT _ (TS "fn") }
+ 'fun' { PT _ (TS "fun") }
+ 'grammar' { PT _ (TS "grammar") }
+ 'in' { PT _ (TS "in") }
+ 'include' { PT _ (TS "include") }
+ 'incomplete' { PT _ (TS "incomplete") }
+ 'instance' { PT _ (TS "instance") }
+ 'interface' { PT _ (TS "interface") }
+ 'let' { PT _ (TS "let") }
+ 'lin' { PT _ (TS "lin") }
+ 'lincat' { PT _ (TS "lincat") }
+ 'lindef' { PT _ (TS "lindef") }
+ 'lintype' { PT _ (TS "lintype") }
+ 'of' { PT _ (TS "of") }
+ 'open' { PT _ (TS "open") }
+ 'oper' { PT _ (TS "oper") }
+ 'out' { PT _ (TS "out") }
+ 'package' { PT _ (TS "package") }
+ 'param' { PT _ (TS "param") }
+ 'pattern' { PT _ (TS "pattern") }
+ 'pre' { PT _ (TS "pre") }
+ 'printname' { PT _ (TS "printname") }
+ 'resource' { PT _ (TS "resource") }
+ 'reuse' { PT _ (TS "reuse") }
+ 'strs' { PT _ (TS "strs") }
+ 'table' { PT _ (TS "table") }
+ 'tokenizer' { PT _ (TS "tokenizer") }
+ 'transfer' { PT _ (TS "transfer") }
+ 'union' { PT _ (TS "union") }
+ 'var' { PT _ (TS "var") }
+ 'variants' { PT _ (TS "variants") }
+ 'where' { PT _ (TS "where") }
+ 'with' { PT _ (TS "with") }
+
+L_integ  { PT _ (TI $$) }
+L_quoted { PT _ (TL $$) }
+L_doubl  { PT _ (TD $$) }
+L_LString { PT _ (T_LString $$) }
+L_PIdent { PT _ (T_PIdent _) }
+L_err    { _ }
+
+
+%%
+
+Integer :: { Integer } : L_integ  { (read $1) :: Integer }
+String  :: { String }  : L_quoted { $1 }
+Double  :: { Double }  : L_doubl  { (read $1) :: Double }
+LString    :: { LString} : L_LString { LString ($1)}
+PIdent    :: { PIdent} : L_PIdent { PIdent (mkPosToken $1)}
+
+Grammar :: { Grammar }
+Grammar : ListModDef { Gr (reverse $1) } 
+
+
+ListModDef :: { [ModDef] }
+ListModDef : {- empty -} { [] } 
+  | ListModDef ModDef { flip (:) $1 $2 }
+
+
+ModDef :: { ModDef }
+ModDef : ModDef ';' { $1 } 
+  | 'grammar' PIdent '=' '{' 'abstract' '=' PIdent ';' ListConcSpec '}' { MMain $2 $7 $9 }
+  | ComplMod ModType '=' ModBody { MModule $1 $2 $4 }
+
+
+ConcSpec :: { ConcSpec }
+ConcSpec : PIdent '=' ConcExp { ConcSpec $1 $3 } 
+
+
+ListConcSpec :: { [ConcSpec] }
+ListConcSpec : {- empty -} { [] } 
+  | ConcSpec { (:[]) $1 }
+  | ConcSpec ';' ListConcSpec { (:) $1 $3 }
+
+
+ConcExp :: { ConcExp }
+ConcExp : PIdent ListTransfer { ConcExp $1 (reverse $2) } 
+
+
+ListTransfer :: { [Transfer] }
+ListTransfer : {- empty -} { [] } 
+  | ListTransfer Transfer { flip (:) $1 $2 }
+
+
+Transfer :: { Transfer }
+Transfer : '(' 'transfer' 'in' Open ')' { TransferIn $4 } 
+  | '(' 'transfer' 'out' Open ')' { TransferOut $4 }
+
+
+ModHeader :: { ModDef }
+ModHeader : ComplMod ModType '=' ModHeaderBody { MModule $1 $2 $4 } 
+
+
+ModHeaderBody :: { ModBody }
+ModHeaderBody : Extend Opens { MBody $1 $2 [] } 
+  | ListIncluded { MNoBody $1 }
+  | Included 'with' ListOpen { MWith $1 $3 }
+  | Included 'with' ListOpen '**' Opens { MWithBody $1 $3 $5 [] }
+  | ListIncluded '**' Included 'with' ListOpen { MWithE $1 $3 $5 }
+  | ListIncluded '**' Included 'with' ListOpen '**' Opens { MWithEBody $1 $3 $5 $7 [] }
+  | 'reuse' PIdent { MReuse $2 }
+  | 'union' ListIncluded { MUnion $2 }
+
+
+ModType :: { ModType }
+ModType : 'abstract' PIdent { MTAbstract $2 } 
+  | 'resource' PIdent { MTResource $2 }
+  | 'interface' PIdent { MTInterface $2 }
+  | 'concrete' PIdent 'of' PIdent { MTConcrete $2 $4 }
+  | 'instance' PIdent 'of' PIdent { MTInstance $2 $4 }
+  | 'transfer' PIdent ':' Open '->' Open { MTTransfer $2 $4 $6 }
+
+
+ModBody :: { ModBody }
+ModBody : Extend Opens '{' ListTopDef '}' { MBody $1 $2 (reverse $4) } 
+  | ListIncluded { MNoBody $1 }
+  | Included 'with' ListOpen { MWith $1 $3 }
+  | Included 'with' ListOpen '**' Opens '{' ListTopDef '}' { MWithBody $1 $3 $5 (reverse $7) }
+  | ListIncluded '**' Included 'with' ListOpen { MWithE $1 $3 $5 }
+  | ListIncluded '**' Included 'with' ListOpen '**' Opens '{' ListTopDef '}' { MWithEBody $1 $3 $5 $7 (reverse $9) }
+  | 'reuse' PIdent { MReuse $2 }
+  | 'union' ListIncluded { MUnion $2 }
+
+
+ListTopDef :: { [TopDef] }
+ListTopDef : {- empty -} { [] } 
+  | ListTopDef TopDef { flip (:) $1 $2 }
+
+
+Extend :: { Extend }
+Extend : ListIncluded '**' { Ext $1 } 
+  | {- empty -} { NoExt }
+
+
+ListOpen :: { [Open] }
+ListOpen : {- empty -} { [] } 
+  | Open { (:[]) $1 }
+  | Open ',' ListOpen { (:) $1 $3 }
+
+
+Opens :: { Opens }
+Opens : {- empty -} { NoOpens } 
+  | 'open' ListOpen 'in' { OpenIn $2 }
+
+
+Open :: { Open }
+Open : PIdent { OName $1 } 
+  | '(' QualOpen PIdent ')' { OQualQO $2 $3 }
+  | '(' QualOpen PIdent '=' PIdent ')' { OQual $2 $3 $5 }
+
+
+ComplMod :: { ComplMod }
+ComplMod : {- empty -} { CMCompl } 
+  | 'incomplete' { CMIncompl }
+
+
+QualOpen :: { QualOpen }
+QualOpen : {- empty -} { QOCompl } 
+  | 'incomplete' { QOIncompl }
+  | 'interface' { QOInterface }
+
+
+ListIncluded :: { [Included] }
+ListIncluded : {- empty -} { [] } 
+  | Included { (:[]) $1 }
+  | Included ',' ListIncluded { (:) $1 $3 }
+
+
+Included :: { Included }
+Included : PIdent { IAll $1 } 
+  | PIdent '[' ListPIdent ']' { ISome $1 $3 }
+  | PIdent '-' '[' ListPIdent ']' { IMinus $1 $4 }
+
+
+Def :: { Def }
+Def : ListName ':' Exp { DDecl $1 $3 } 
+  | ListName '=' Exp { DDef $1 $3 }
+  | Name ListPatt '=' Exp { DPatt $1 $2 $4 }
+  | ListName ':' Exp '=' Exp { DFull $1 $3 $5 }
+
+
+TopDef :: { TopDef }
+TopDef : 'cat' ListCatDef { DefCat $2 } 
+  | 'fun' ListFunDef { DefFun $2 }
+  | 'data' ListFunDef { DefFunData $2 }
+  | 'def' ListDef { DefDef $2 }
+  | 'data' ListDataDef { DefData $2 }
+  | 'transfer' ListDef { DefTrans $2 }
+  | 'param' ListParDef { DefPar $2 }
+  | 'oper' ListDef { DefOper $2 }
+  | 'lincat' ListPrintDef { DefLincat $2 }
+  | 'lindef' ListDef { DefLindef $2 }
+  | 'lin' ListDef { DefLin $2 }
+  | 'printname' 'cat' ListPrintDef { DefPrintCat $3 }
+  | 'printname' 'fun' ListPrintDef { DefPrintFun $3 }
+  | 'flags' ListFlagDef { DefFlag $2 }
+  | 'printname' ListPrintDef { DefPrintOld $2 }
+  | 'lintype' ListDef { DefLintype $2 }
+  | 'pattern' ListDef { DefPattern $2 }
+  | 'package' PIdent '=' '{' ListTopDef '}' ';' { DefPackage $2 (reverse $5) }
+  | 'var' ListDef { DefVars $2 }
+  | 'tokenizer' PIdent ';' { DefTokenizer $2 }
+
+
+CatDef :: { CatDef }
+CatDef : PIdent ListDDecl { SimpleCatDef $1 (reverse $2) } 
+  | '[' PIdent ListDDecl ']' { ListCatDef $2 (reverse $3) }
+  | '[' PIdent ListDDecl ']' '{' Integer '}' { ListSizeCatDef $2 (reverse $3) $6 }
+
+
+FunDef :: { FunDef }
+FunDef : ListPIdent ':' Exp { FunDef $1 $3 } 
+
+
+DataDef :: { DataDef }
+DataDef : PIdent '=' ListDataConstr { DataDef $1 $3 } 
+
+
+DataConstr :: { DataConstr }
+DataConstr : PIdent { DataId $1 } 
+  | PIdent '.' PIdent { DataQId $1 $3 }
+
+
+ListDataConstr :: { [DataConstr] }
+ListDataConstr : {- empty -} { [] } 
+  | DataConstr { (:[]) $1 }
+  | DataConstr '|' ListDataConstr { (:) $1 $3 }
+
+
+ParDef :: { ParDef }
+ParDef : PIdent '=' ListParConstr { ParDefDir $1 $3 } 
+  | PIdent '=' '(' 'in' PIdent ')' { ParDefIndir $1 $5 }
+  | PIdent { ParDefAbs $1 }
+
+
+ParConstr :: { ParConstr }
+ParConstr : PIdent ListDDecl { ParConstr $1 (reverse $2) } 
+
+
+PrintDef :: { PrintDef }
+PrintDef : ListName '=' Exp { PrintDef $1 $3 } 
+
+
+FlagDef :: { FlagDef }
+FlagDef : PIdent '=' PIdent { FlagDef $1 $3 } 
+
+
+ListDef :: { [Def] }
+ListDef : Def ';' { (:[]) $1 } 
+  | Def ';' ListDef { (:) $1 $3 }
+
+
+ListCatDef :: { [CatDef] }
+ListCatDef : CatDef ';' { (:[]) $1 } 
+  | CatDef ';' ListCatDef { (:) $1 $3 }
+
+
+ListFunDef :: { [FunDef] }
+ListFunDef : FunDef ';' { (:[]) $1 } 
+  | FunDef ';' ListFunDef { (:) $1 $3 }
+
+
+ListDataDef :: { [DataDef] }
+ListDataDef : DataDef ';' { (:[]) $1 } 
+  | DataDef ';' ListDataDef { (:) $1 $3 }
+
+
+ListParDef :: { [ParDef] }
+ListParDef : ParDef ';' { (:[]) $1 } 
+  | ParDef ';' ListParDef { (:) $1 $3 }
+
+
+ListPrintDef :: { [PrintDef] }
+ListPrintDef : PrintDef ';' { (:[]) $1 } 
+  | PrintDef ';' ListPrintDef { (:) $1 $3 }
+
+
+ListFlagDef :: { [FlagDef] }
+ListFlagDef : FlagDef ';' { (:[]) $1 } 
+  | FlagDef ';' ListFlagDef { (:) $1 $3 }
+
+
+ListParConstr :: { [ParConstr] }
+ListParConstr : {- empty -} { [] } 
+  | ParConstr { (:[]) $1 }
+  | ParConstr '|' ListParConstr { (:) $1 $3 }
+
+
+ListPIdent :: { [PIdent] }
+ListPIdent : PIdent { (:[]) $1 } 
+  | PIdent ',' ListPIdent { (:) $1 $3 }
+
+
+Name :: { Name }
+Name : PIdent { IdentName $1 } 
+  | '[' PIdent ']' { ListName $2 }
+
+
+ListName :: { [Name] }
+ListName : Name { (:[]) $1 } 
+  | Name ',' ListName { (:) $1 $3 }
+
+
+LocDef :: { LocDef }
+LocDef : ListPIdent ':' Exp { LDDecl $1 $3 } 
+  | ListPIdent '=' Exp { LDDef $1 $3 }
+  | ListPIdent ':' Exp '=' Exp { LDFull $1 $3 $5 }
+
+
+ListLocDef :: { [LocDef] }
+ListLocDef : {- empty -} { [] } 
+  | LocDef { (:[]) $1 }
+  | LocDef ';' ListLocDef { (:) $1 $3 }
+
+
+Exp6 :: { Exp }
+Exp6 : PIdent { EIdent $1 } 
+  | '{' PIdent '}' { EConstr $2 }
+  | '%' PIdent '%' { ECons $2 }
+  | Sort { ESort $1 }
+  | String { EString $1 }
+  | Integer { EInt $1 }
+  | Double { EFloat $1 }
+  | '?' { EMeta }
+  | '[' ']' { EEmpty }
+  | 'data' { EData }
+  | '[' PIdent Exps ']' { EList $2 $3 }
+  | '[' String ']' { EStrings $2 }
+  | '{' ListLocDef '}' { ERecord $2 }
+  | '<' ListTupleComp '>' { ETuple $2 }
+  | '(' 'in' PIdent ')' { EIndir $3 }
+  | '<' Exp ':' Exp '>' { ETyped $2 $4 }
+  | '(' Exp ')' { $2 }
+  | LString { ELString $1 }
+
+
+Exp5 :: { Exp }
+Exp5 : Exp5 '.' Label { EProj $1 $3 } 
+  | '{' PIdent '.' PIdent '}' { EQConstr $2 $4 }
+  | '%' PIdent '.' PIdent { EQCons $2 $4 }
+  | Exp6 { $1 }
+
+
+Exp4 :: { Exp }
+Exp4 : Exp4 Exp5 { EApp $1 $2 } 
+  | 'table' '{' ListCase '}' { ETable $3 }
+  | 'table' Exp6 '{' ListCase '}' { ETTable $2 $4 }
+  | 'table' Exp6 '[' ListExp ']' { EVTable $2 $4 }
+  | 'case' Exp 'of' '{' ListCase '}' { ECase $2 $5 }
+  | 'variants' '{' ListExp '}' { EVariants $3 }
+  | 'pre' '{' Exp ';' ListAltern '}' { EPre $3 $5 }
+  | 'strs' '{' ListExp '}' { EStrs $3 }
+  | PIdent '@' Exp6 { EConAt $1 $3 }
+  | '#' Patt2 { EPatt $2 }
+  | 'pattern' Exp5 { EPattType $2 }
+  | Exp5 { $1 }
+  | 'Lin' PIdent { ELin $2 }
+
+
+Exp3 :: { Exp }
+Exp3 : Exp3 '!' Exp4 { ESelect $1 $3 } 
+  | Exp3 '*' Exp4 { ETupTyp $1 $3 }
+  | Exp3 '**' Exp4 { EExtend $1 $3 }
+  | Exp4 { $1 }
+
+
+Exp1 :: { Exp }
+Exp1 : Exp2 '+' Exp1 { EGlue $1 $3 } 
+  | Exp2 { $1 }
+
+
+Exp :: { Exp }
+Exp : Exp1 '++' Exp { EConcat $1 $3 } 
+  | '\\' ListBind '->' Exp { EAbstr $2 $4 }
+  | '\\' '\\' ListBind '=>' Exp { ECTable $3 $5 }
+  | Decl '->' Exp { EProd $1 $3 }
+  | Exp3 '=>' Exp { ETType $1 $3 }
+  | 'let' '{' ListLocDef '}' 'in' Exp { ELet $3 $6 }
+  | 'let' ListLocDef 'in' Exp { ELetb $2 $4 }
+  | Exp3 'where' '{' ListLocDef '}' { EWhere $1 $4 }
+  | 'fn' '{' ListEquation '}' { EEqs $3 }
+  | 'in' Exp5 String { EExample $2 $3 }
+  | Exp1 { $1 }
+
+
+Exp2 :: { Exp }
+Exp2 : Exp3 { $1 } 
+
+
+ListExp :: { [Exp] }
+ListExp : {- empty -} { [] } 
+  | Exp { (:[]) $1 }
+  | Exp ';' ListExp { (:) $1 $3 }
+
+
+Exps :: { Exps }
+Exps : {- empty -} { NilExp } 
+  | Exp6 Exps { ConsExp $1 $2 }
+
+
+Patt2 :: { Patt }
+Patt2 : '?' { PChar } 
+  | '[' String ']' { PChars $2 }
+  | '#' PIdent { PMacro $2 }
+  | '#' PIdent '.' PIdent { PM $2 $4 }
+  | '_' { PW }
+  | PIdent { PV $1 }
+  | '{' PIdent '}' { PCon $2 }
+  | PIdent '.' PIdent { PQ $1 $3 }
+  | Integer { PInt $1 }
+  | Double { PFloat $1 }
+  | String { PStr $1 }
+  | '{' ListPattAss '}' { PR $2 }
+  | '<' ListPattTupleComp '>' { PTup $2 }
+  | '(' Patt ')' { $2 }
+
+
+Patt1 :: { Patt }
+Patt1 : PIdent ListPatt { PC $1 $2 } 
+  | PIdent '.' PIdent ListPatt { PQC $1 $3 $4 }
+  | Patt2 '*' { PRep $1 }
+  | PIdent '@' Patt2 { PAs $1 $3 }
+  | '-' Patt2 { PNeg $2 }
+  | Patt2 { $1 }
+
+
+Patt :: { Patt }
+Patt : Patt '|' Patt1 { PDisj $1 $3 } 
+  | Patt '+' Patt1 { PSeq $1 $3 }
+  | Patt1 { $1 }
+
+
+PattAss :: { PattAss }
+PattAss : ListPIdent '=' Patt { PA $1 $3 } 
+
+
+Label :: { Label }
+Label : PIdent { LIdent $1 } 
+  | '$' Integer { LVar $2 }
+
+
+Sort :: { Sort }
+Sort : 'Type' { Sort_Type } 
+  | 'PType' { Sort_PType }
+  | 'Tok' { Sort_Tok }
+  | 'Str' { Sort_Str }
+  | 'Strs' { Sort_Strs }
+
+
+ListPattAss :: { [PattAss] }
+ListPattAss : {- empty -} { [] } 
+  | PattAss { (:[]) $1 }
+  | PattAss ';' ListPattAss { (:) $1 $3 }
+
+
+ListPatt :: { [Patt] }
+ListPatt : Patt2 { (:[]) $1 } 
+  | Patt2 ListPatt { (:) $1 $2 }
+
+
+Bind :: { Bind }
+Bind : PIdent { BIdent $1 } 
+  | '_' { BWild }
+
+
+ListBind :: { [Bind] }
+ListBind : {- empty -} { [] } 
+  | Bind { (:[]) $1 }
+  | Bind ',' ListBind { (:) $1 $3 }
+
+
+Decl :: { Decl }
+Decl : '(' ListBind ':' Exp ')' { DDec $2 $4 } 
+  | Exp4 { DExp $1 }
+
+
+TupleComp :: { TupleComp }
+TupleComp : Exp { TComp $1 } 
+
+
+PattTupleComp :: { PattTupleComp }
+PattTupleComp : Patt { PTComp $1 } 
+
+
+ListTupleComp :: { [TupleComp] }
+ListTupleComp : {- empty -} { [] } 
+  | TupleComp { (:[]) $1 }
+  | TupleComp ',' ListTupleComp { (:) $1 $3 }
+
+
+ListPattTupleComp :: { [PattTupleComp] }
+ListPattTupleComp : {- empty -} { [] } 
+  | PattTupleComp { (:[]) $1 }
+  | PattTupleComp ',' ListPattTupleComp { (:) $1 $3 }
+
+
+Case :: { Case }
+Case : Patt '=>' Exp { Case $1 $3 } 
+
+
+ListCase :: { [Case] }
+ListCase : Case { (:[]) $1 } 
+  | Case ';' ListCase { (:) $1 $3 }
+
+
+Equation :: { Equation }
+Equation : ListPatt '->' Exp { Equ $1 $3 } 
+
+
+ListEquation :: { [Equation] }
+ListEquation : {- empty -} { [] } 
+  | Equation { (:[]) $1 }
+  | Equation ';' ListEquation { (:) $1 $3 }
+
+
+Altern :: { Altern }
+Altern : Exp '/' Exp { Alt $1 $3 } 
+
+
+ListAltern :: { [Altern] }
+ListAltern : {- empty -} { [] } 
+  | Altern { (:[]) $1 }
+  | Altern ';' ListAltern { (:) $1 $3 }
+
+
+DDecl :: { DDecl }
+DDecl : '(' ListBind ':' Exp ')' { DDDec $2 $4 } 
+  | Exp6 { DDExp $1 }
+
+
+ListDDecl :: { [DDecl] }
+ListDDecl : {- empty -} { [] } 
+  | ListDDecl DDecl { flip (:) $1 $2 }
+
+
+OldGrammar :: { OldGrammar }
+OldGrammar : Include ListTopDef { OldGr $1 (reverse $2) } 
+
+
+Include :: { Include }
+Include : {- empty -} { NoIncl } 
+  | 'include' ListFileName { Incl $2 }
+
+
+FileName :: { FileName }
+FileName : String { FString $1 } 
+  | PIdent { FIdent $1 }
+  | '/' FileName { FSlash $2 }
+  | '.' FileName { FDot $2 }
+  | '-' FileName { FMinus $2 }
+  | PIdent FileName { FAddId $1 $2 }
+
+
+ListFileName :: { [FileName] }
+ListFileName : FileName ';' { (:[]) $1 } 
+  | FileName ';' ListFileName { (:) $1 $3 }
+
+
+
+{
+
+returnM :: a -> Err a
+returnM = return
+
+thenM :: Err a -> (a -> Err b) -> Err b
+thenM = (>>=)
+
+happyError :: [Token] -> Err a
+happyError ts =
+  Bad $ "syntax error at " ++ tokenPos ts ++ 
+  case ts of
+    [] -> []
+    [Err _] -> " due to lexer error"
+    _ -> " before " ++ unwords (map prToken (take 4 ts))
+
+myLexer = tokens
+}
+

src-3.0/GF/Source/PrintGF.hs

@@ -0,0 +1,532 @@
+{-# OPTIONS -fno-warn-incomplete-patterns #-}
+module GF.Source.PrintGF where
+
+-- pretty-printer generated by the BNF converter
+
+import GF.Source.AbsGF
+import Char
+
+-- the top-level printing method
+printTree :: Print a => a -> String
+printTree = render . prt 0
+
+type Doc = [ShowS] -> [ShowS]
+
+doc :: ShowS -> Doc
+doc = (:)
+
+render :: Doc -> String
+render d = rend 0 (map ($ "") $ d []) "" where
+  rend i ss = case ss of
+    "["      :ts -> showChar '[' . rend i ts
+    "("      :ts -> showChar '(' . rend i ts
+    "{"      :ts -> showChar '{' . new (i+1) . rend (i+1) ts
+    "}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts
+    "}"      :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
+    ";"      :ts -> showChar ';' . new i . rend i ts
+    t  : "," :ts -> showString t . space "," . rend i ts
+    t  : ")" :ts -> showString t . showChar ')' . rend i ts
+    t  : "]" :ts -> showString t . showChar ']' . rend i ts
+    t        :ts -> space t . rend i ts
+    _            -> id
+  new i   = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace
+  space t = showString t . (\s -> if null s then "" else (' ':s))
+
+parenth :: Doc -> Doc
+parenth ss = doc (showChar '(') . ss . doc (showChar ')')
+
+concatS :: [ShowS] -> ShowS
+concatS = foldr (.) id
+
+concatD :: [Doc] -> Doc
+concatD = foldr (.) id
+
+replicateS :: Int -> ShowS -> ShowS
+replicateS n f = concatS (replicate n f)
+
+-- the printer class does the job
+class Print a where
+  prt :: Int -> a -> Doc
+  prtList :: [a] -> Doc
+  prtList = concatD . map (prt 0)
+
+instance Print a => Print [a] where
+  prt _ = prtList
+
+instance Print Char where
+  prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
+  prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
+
+mkEsc :: Char -> Char -> ShowS
+mkEsc q s = case s of
+  _ | s == q -> showChar '\\' . showChar s
+  '\\'-> showString "\\\\"
+  '\n' -> showString "\\n"
+  '\t' -> showString "\\t"
+  _ -> showChar s
+
+prPrec :: Int -> Int -> Doc -> Doc
+prPrec i j = if j<i then parenth else id
+
+
+instance Print Integer where
+  prt _ x = doc (shows x)
+
+
+instance Print Double where
+  prt _ x = doc (shows x)
+
+
+
+instance Print LString where
+  prt _ (LString i) = doc (showString i)
+
+
+instance Print PIdent where
+  prt _ (PIdent (_,i)) = doc (showString i)
+  prtList es = case es of
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
+
+
+
+instance Print Grammar where
+  prt i e = case e of
+   Gr moddefs -> prPrec i 0 (concatD [prt 0 moddefs])
+
+
+instance Print ModDef where
+  prt i e = case e of
+   MMain pident0 pident concspecs -> prPrec i 0 (concatD [doc (showString "grammar") , prt 0 pident0 , doc (showString "=") , doc (showString "{") , doc (showString "abstract") , doc (showString "=") , prt 0 pident , doc (showString ";") , prt 0 concspecs , doc (showString "}")])
+   MModule complmod modtype modbody -> prPrec i 0 (concatD [prt 0 complmod , prt 0 modtype , doc (showString "=") , prt 0 modbody])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , prt 0 xs])
+
+instance Print ConcSpec where
+  prt i e = case e of
+   ConcSpec pident concexp -> prPrec i 0 (concatD [prt 0 pident , doc (showString "=") , prt 0 concexp])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print ConcExp where
+  prt i e = case e of
+   ConcExp pident transfers -> prPrec i 0 (concatD [prt 0 pident , prt 0 transfers])
+
+
+instance Print Transfer where
+  prt i e = case e of
+   TransferIn open -> prPrec i 0 (concatD [doc (showString "(") , doc (showString "transfer") , doc (showString "in") , prt 0 open , doc (showString ")")])
+   TransferOut open -> prPrec i 0 (concatD [doc (showString "(") , doc (showString "transfer") , doc (showString "out") , prt 0 open , doc (showString ")")])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , prt 0 xs])
+
+instance Print ModType where
+  prt i e = case e of
+   MTAbstract pident -> prPrec i 0 (concatD [doc (showString "abstract") , prt 0 pident])
+   MTResource pident -> prPrec i 0 (concatD [doc (showString "resource") , prt 0 pident])
+   MTInterface pident -> prPrec i 0 (concatD [doc (showString "interface") , prt 0 pident])
+   MTConcrete pident0 pident -> prPrec i 0 (concatD [doc (showString "concrete") , prt 0 pident0 , doc (showString "of") , prt 0 pident])
+   MTInstance pident0 pident -> prPrec i 0 (concatD [doc (showString "instance") , prt 0 pident0 , doc (showString "of") , prt 0 pident])
+   MTTransfer pident open0 open -> prPrec i 0 (concatD [doc (showString "transfer") , prt 0 pident , doc (showString ":") , prt 0 open0 , doc (showString "->") , prt 0 open])
+
+
+instance Print ModBody where
+  prt i e = case e of
+   MBody extend opens topdefs -> prPrec i 0 (concatD [prt 0 extend , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")])
+   MNoBody includeds -> prPrec i 0 (concatD [prt 0 includeds])
+   MWith included opens -> prPrec i 0 (concatD [prt 0 included , doc (showString "with") , prt 0 opens])
+   MWithBody included opens0 opens topdefs -> prPrec i 0 (concatD [prt 0 included , doc (showString "with") , prt 0 opens0 , doc (showString "**") , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")])
+   MWithE includeds included opens -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**") , prt 0 included , doc (showString "with") , prt 0 opens])
+   MWithEBody includeds included opens0 opens topdefs -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**") , prt 0 included , doc (showString "with") , prt 0 opens0 , doc (showString "**") , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")])
+   MReuse pident -> prPrec i 0 (concatD [doc (showString "reuse") , prt 0 pident])
+   MUnion includeds -> prPrec i 0 (concatD [doc (showString "union") , prt 0 includeds])
+
+
+instance Print Extend where
+  prt i e = case e of
+   Ext includeds -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**")])
+   NoExt  -> prPrec i 0 (concatD [])
+
+
+instance Print Opens where
+  prt i e = case e of
+   NoOpens  -> prPrec i 0 (concatD [])
+   OpenIn opens -> prPrec i 0 (concatD [doc (showString "open") , prt 0 opens , doc (showString "in")])
+
+
+instance Print Open where
+  prt i e = case e of
+   OName pident -> prPrec i 0 (concatD [prt 0 pident])
+   OQualQO qualopen pident -> prPrec i 0 (concatD [doc (showString "(") , prt 0 qualopen , prt 0 pident , doc (showString ")")])
+   OQual qualopen pident0 pident -> prPrec i 0 (concatD [doc (showString "(") , prt 0 qualopen , prt 0 pident0 , doc (showString "=") , prt 0 pident , doc (showString ")")])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
+
+instance Print ComplMod where
+  prt i e = case e of
+   CMCompl  -> prPrec i 0 (concatD [])
+   CMIncompl  -> prPrec i 0 (concatD [doc (showString "incomplete")])
+
+
+instance Print QualOpen where
+  prt i e = case e of
+   QOCompl  -> prPrec i 0 (concatD [])
+   QOIncompl  -> prPrec i 0 (concatD [doc (showString "incomplete")])
+   QOInterface  -> prPrec i 0 (concatD [doc (showString "interface")])
+
+
+instance Print Included where
+  prt i e = case e of
+   IAll pident -> prPrec i 0 (concatD [prt 0 pident])
+   ISome pident pidents -> prPrec i 0 (concatD [prt 0 pident , doc (showString "[") , prt 0 pidents , doc (showString "]")])
+   IMinus pident pidents -> prPrec i 0 (concatD [prt 0 pident , doc (showString "-") , doc (showString "[") , prt 0 pidents , doc (showString "]")])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
+
+instance Print Def where
+  prt i e = case e of
+   DDecl names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString ":") , prt 0 exp])
+   DDef names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString "=") , prt 0 exp])
+   DPatt name patts exp -> prPrec i 0 (concatD [prt 0 name , prt 0 patts , doc (showString "=") , prt 0 exp])
+   DFull names exp0 exp -> prPrec i 0 (concatD [prt 0 names , doc (showString ":") , prt 0 exp0 , doc (showString "=") , prt 0 exp])
+
+  prtList es = case es of
+   [x] -> (concatD [prt 0 x , doc (showString ";")])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print TopDef where
+  prt i e = case e of
+   DefCat catdefs -> prPrec i 0 (concatD [doc (showString "cat") , prt 0 catdefs])
+   DefFun fundefs -> prPrec i 0 (concatD [doc (showString "fun") , prt 0 fundefs])
+   DefFunData fundefs -> prPrec i 0 (concatD [doc (showString "data") , prt 0 fundefs])
+   DefDef defs -> prPrec i 0 (concatD [doc (showString "def") , prt 0 defs])
+   DefData datadefs -> prPrec i 0 (concatD [doc (showString "data") , prt 0 datadefs])
+   DefTrans defs -> prPrec i 0 (concatD [doc (showString "transfer") , prt 0 defs])
+   DefPar pardefs -> prPrec i 0 (concatD [doc (showString "param") , prt 0 pardefs])
+   DefOper defs -> prPrec i 0 (concatD [doc (showString "oper") , prt 0 defs])
+   DefLincat printdefs -> prPrec i 0 (concatD [doc (showString "lincat") , prt 0 printdefs])
+   DefLindef defs -> prPrec i 0 (concatD [doc (showString "lindef") , prt 0 defs])
+   DefLin defs -> prPrec i 0 (concatD [doc (showString "lin") , prt 0 defs])
+   DefPrintCat printdefs -> prPrec i 0 (concatD [doc (showString "printname") , doc (showString "cat") , prt 0 printdefs])
+   DefPrintFun printdefs -> prPrec i 0 (concatD [doc (showString "printname") , doc (showString "fun") , prt 0 printdefs])
+   DefFlag flagdefs -> prPrec i 0 (concatD [doc (showString "flags") , prt 0 flagdefs])
+   DefPrintOld printdefs -> prPrec i 0 (concatD [doc (showString "printname") , prt 0 printdefs])
+   DefLintype defs -> prPrec i 0 (concatD [doc (showString "lintype") , prt 0 defs])
+   DefPattern defs -> prPrec i 0 (concatD [doc (showString "pattern") , prt 0 defs])
+   DefPackage pident topdefs -> prPrec i 0 (concatD [doc (showString "package") , prt 0 pident , doc (showString "=") , doc (showString "{") , prt 0 topdefs , doc (showString "}") , doc (showString ";")])
+   DefVars defs -> prPrec i 0 (concatD [doc (showString "var") , prt 0 defs])
+   DefTokenizer pident -> prPrec i 0 (concatD [doc (showString "tokenizer") , prt 0 pident , doc (showString ";")])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , prt 0 xs])
+
+instance Print CatDef where
+  prt i e = case e of
+   SimpleCatDef pident ddecls -> prPrec i 0 (concatD [prt 0 pident , prt 0 ddecls])
+   ListCatDef pident ddecls -> prPrec i 0 (concatD [doc (showString "[") , prt 0 pident , prt 0 ddecls , doc (showString "]")])
+   ListSizeCatDef pident ddecls n -> prPrec i 0 (concatD [doc (showString "[") , prt 0 pident , prt 0 ddecls , doc (showString "]") , doc (showString "{") , prt 0 n , doc (showString "}")])
+
+  prtList es = case es of
+   [x] -> (concatD [prt 0 x , doc (showString ";")])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print FunDef where
+  prt i e = case e of
+   FunDef pidents exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString ":") , prt 0 exp])
+
+  prtList es = case es of
+   [x] -> (concatD [prt 0 x , doc (showString ";")])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print DataDef where
+  prt i e = case e of
+   DataDef pident dataconstrs -> prPrec i 0 (concatD [prt 0 pident , doc (showString "=") , prt 0 dataconstrs])
+
+  prtList es = case es of
+   [x] -> (concatD [prt 0 x , doc (showString ";")])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print DataConstr where
+  prt i e = case e of
+   DataId pident -> prPrec i 0 (concatD [prt 0 pident])
+   DataQId pident0 pident -> prPrec i 0 (concatD [prt 0 pident0 , doc (showString ".") , prt 0 pident])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs])
+
+instance Print ParDef where
+  prt i e = case e of
+   ParDefDir pident parconstrs -> prPrec i 0 (concatD [prt 0 pident , doc (showString "=") , prt 0 parconstrs])
+   ParDefIndir pident0 pident -> prPrec i 0 (concatD [prt 0 pident0 , doc (showString "=") , doc (showString "(") , doc (showString "in") , prt 0 pident , doc (showString ")")])
+   ParDefAbs pident -> prPrec i 0 (concatD [prt 0 pident])
+
+  prtList es = case es of
+   [x] -> (concatD [prt 0 x , doc (showString ";")])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print ParConstr where
+  prt i e = case e of
+   ParConstr pident ddecls -> prPrec i 0 (concatD [prt 0 pident , prt 0 ddecls])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs])
+
+instance Print PrintDef where
+  prt i e = case e of
+   PrintDef names exp -> prPrec i 0 (concatD [prt 0 names , doc (showString "=") , prt 0 exp])
+
+  prtList es = case es of
+   [x] -> (concatD [prt 0 x , doc (showString ";")])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print FlagDef where
+  prt i e = case e of
+   FlagDef pident0 pident -> prPrec i 0 (concatD [prt 0 pident0 , doc (showString "=") , prt 0 pident])
+
+  prtList es = case es of
+   [x] -> (concatD [prt 0 x , doc (showString ";")])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print Name where
+  prt i e = case e of
+   IdentName pident -> prPrec i 0 (concatD [prt 0 pident])
+   ListName pident -> prPrec i 0 (concatD [doc (showString "[") , prt 0 pident , doc (showString "]")])
+
+  prtList es = case es of
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
+
+instance Print LocDef where
+  prt i e = case e of
+   LDDecl pidents exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString ":") , prt 0 exp])
+   LDDef pidents exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString "=") , prt 0 exp])
+   LDFull pidents exp0 exp -> prPrec i 0 (concatD [prt 0 pidents , doc (showString ":") , prt 0 exp0 , doc (showString "=") , prt 0 exp])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print Exp where
+  prt i e = case e of
+   EIdent pident -> prPrec i 6 (concatD [prt 0 pident])
+   EConstr pident -> prPrec i 6 (concatD [doc (showString "{") , prt 0 pident , doc (showString "}")])
+   ECons pident -> prPrec i 6 (concatD [doc (showString "%") , prt 0 pident , doc (showString "%")])
+   ESort sort -> prPrec i 6 (concatD [prt 0 sort])
+   EString str -> prPrec i 6 (concatD [prt 0 str])
+   EInt n -> prPrec i 6 (concatD [prt 0 n])
+   EFloat d -> prPrec i 6 (concatD [prt 0 d])
+   EMeta  -> prPrec i 6 (concatD [doc (showString "?")])
+   EEmpty  -> prPrec i 6 (concatD [doc (showString "[") , doc (showString "]")])
+   EData  -> prPrec i 6 (concatD [doc (showString "data")])
+   EList pident exps -> prPrec i 6 (concatD [doc (showString "[") , prt 0 pident , prt 0 exps , doc (showString "]")])
+   EStrings str -> prPrec i 6 (concatD [doc (showString "[") , prt 0 str , doc (showString "]")])
+   ERecord locdefs -> prPrec i 6 (concatD [doc (showString "{") , prt 0 locdefs , doc (showString "}")])
+   ETuple tuplecomps -> prPrec i 6 (concatD [doc (showString "<") , prt 0 tuplecomps , doc (showString ">")])
+   EIndir pident -> prPrec i 6 (concatD [doc (showString "(") , doc (showString "in") , prt 0 pident , doc (showString ")")])
+   ETyped exp0 exp -> prPrec i 6 (concatD [doc (showString "<") , prt 0 exp0 , doc (showString ":") , prt 0 exp , doc (showString ">")])
+   EProj exp label -> prPrec i 5 (concatD [prt 5 exp , doc (showString ".") , prt 0 label])
+   EQConstr pident0 pident -> prPrec i 5 (concatD [doc (showString "{") , prt 0 pident0 , doc (showString ".") , prt 0 pident , doc (showString "}")])
+   EQCons pident0 pident -> prPrec i 5 (concatD [doc (showString "%") , prt 0 pident0 , doc (showString ".") , prt 0 pident])
+   EApp exp0 exp -> prPrec i 4 (concatD [prt 4 exp0 , prt 5 exp])
+   ETable cases -> prPrec i 4 (concatD [doc (showString "table") , doc (showString "{") , prt 0 cases , doc (showString "}")])
+   ETTable exp cases -> prPrec i 4 (concatD [doc (showString "table") , prt 6 exp , doc (showString "{") , prt 0 cases , doc (showString "}")])
+   EVTable exp exps -> prPrec i 4 (concatD [doc (showString "table") , prt 6 exp , doc (showString "[") , prt 0 exps , doc (showString "]")])
+   ECase exp cases -> prPrec i 4 (concatD [doc (showString "case") , prt 0 exp , doc (showString "of") , doc (showString "{") , prt 0 cases , doc (showString "}")])
+   EVariants exps -> prPrec i 4 (concatD [doc (showString "variants") , doc (showString "{") , prt 0 exps , doc (showString "}")])
+   EPre exp alterns -> prPrec i 4 (concatD [doc (showString "pre") , doc (showString "{") , prt 0 exp , doc (showString ";") , prt 0 alterns , doc (showString "}")])
+   EStrs exps -> prPrec i 4 (concatD [doc (showString "strs") , doc (showString "{") , prt 0 exps , doc (showString "}")])
+   EConAt pident exp -> prPrec i 4 (concatD [prt 0 pident , doc (showString "@") , prt 6 exp])
+   EPatt patt -> prPrec i 4 (concatD [doc (showString "#") , prt 2 patt])
+   EPattType exp -> prPrec i 4 (concatD [doc (showString "pattern") , prt 5 exp])
+   ESelect exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "!") , prt 4 exp])
+   ETupTyp exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "*") , prt 4 exp])
+   EExtend exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "**") , prt 4 exp])
+   EGlue exp0 exp -> prPrec i 1 (concatD [prt 2 exp0 , doc (showString "+") , prt 1 exp])
+   EConcat exp0 exp -> prPrec i 0 (concatD [prt 1 exp0 , doc (showString "++") , prt 0 exp])
+   EAbstr binds exp -> prPrec i 0 (concatD [doc (showString "\\") , prt 0 binds , doc (showString "->") , prt 0 exp])
+   ECTable binds exp -> prPrec i 0 (concatD [doc (showString "\\") , doc (showString "\\") , prt 0 binds , doc (showString "=>") , prt 0 exp])
+   EProd decl exp -> prPrec i 0 (concatD [prt 0 decl , doc (showString "->") , prt 0 exp])
+   ETType exp0 exp -> prPrec i 0 (concatD [prt 3 exp0 , doc (showString "=>") , prt 0 exp])
+   ELet locdefs exp -> prPrec i 0 (concatD [doc (showString "let") , doc (showString "{") , prt 0 locdefs , doc (showString "}") , doc (showString "in") , prt 0 exp])
+   ELetb locdefs exp -> prPrec i 0 (concatD [doc (showString "let") , prt 0 locdefs , doc (showString "in") , prt 0 exp])
+   EWhere exp locdefs -> prPrec i 0 (concatD [prt 3 exp , doc (showString "where") , doc (showString "{") , prt 0 locdefs , doc (showString "}")])
+   EEqs equations -> prPrec i 0 (concatD [doc (showString "fn") , doc (showString "{") , prt 0 equations , doc (showString "}")])
+   EExample exp str -> prPrec i 0 (concatD [doc (showString "in") , prt 5 exp , prt 0 str])
+   ELString lstring -> prPrec i 6 (concatD [prt 0 lstring])
+   ELin pident -> prPrec i 4 (concatD [doc (showString "Lin") , prt 0 pident])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print Exps where
+  prt i e = case e of
+   NilExp  -> prPrec i 0 (concatD [])
+   ConsExp exp exps -> prPrec i 0 (concatD [prt 6 exp , prt 0 exps])
+
+
+instance Print Patt where
+  prt i e = case e of
+   PChar  -> prPrec i 2 (concatD [doc (showString "?")])
+   PChars str -> prPrec i 2 (concatD [doc (showString "[") , prt 0 str , doc (showString "]")])
+   PMacro pident -> prPrec i 2 (concatD [doc (showString "#") , prt 0 pident])
+   PM pident0 pident -> prPrec i 2 (concatD [doc (showString "#") , prt 0 pident0 , doc (showString ".") , prt 0 pident])
+   PW  -> prPrec i 2 (concatD [doc (showString "_")])
+   PV pident -> prPrec i 2 (concatD [prt 0 pident])
+   PCon pident -> prPrec i 2 (concatD [doc (showString "{") , prt 0 pident , doc (showString "}")])
+   PQ pident0 pident -> prPrec i 2 (concatD [prt 0 pident0 , doc (showString ".") , prt 0 pident])
+   PInt n -> prPrec i 2 (concatD [prt 0 n])
+   PFloat d -> prPrec i 2 (concatD [prt 0 d])
+   PStr str -> prPrec i 2 (concatD [prt 0 str])
+   PR pattasss -> prPrec i 2 (concatD [doc (showString "{") , prt 0 pattasss , doc (showString "}")])
+   PTup patttuplecomps -> prPrec i 2 (concatD [doc (showString "<") , prt 0 patttuplecomps , doc (showString ">")])
+   PC pident patts -> prPrec i 1 (concatD [prt 0 pident , prt 0 patts])
+   PQC pident0 pident patts -> prPrec i 1 (concatD [prt 0 pident0 , doc (showString ".") , prt 0 pident , prt 0 patts])
+   PDisj patt0 patt -> prPrec i 0 (concatD [prt 0 patt0 , doc (showString "|") , prt 1 patt])
+   PSeq patt0 patt -> prPrec i 0 (concatD [prt 0 patt0 , doc (showString "+") , prt 1 patt])
+   PRep patt -> prPrec i 1 (concatD [prt 2 patt , doc (showString "*")])
+   PAs pident patt -> prPrec i 1 (concatD [prt 0 pident , doc (showString "@") , prt 2 patt])
+   PNeg patt -> prPrec i 1 (concatD [doc (showString "-") , prt 2 patt])
+
+  prtList es = case es of
+   [x] -> (concatD [prt 2 x])
+   x:xs -> (concatD [prt 2 x , prt 0 xs])
+
+instance Print PattAss where
+  prt i e = case e of
+   PA pidents patt -> prPrec i 0 (concatD [prt 0 pidents , doc (showString "=") , prt 0 patt])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print Label where
+  prt i e = case e of
+   LIdent pident -> prPrec i 0 (concatD [prt 0 pident])
+   LVar n -> prPrec i 0 (concatD [doc (showString "$") , prt 0 n])
+
+
+instance Print Sort where
+  prt i e = case e of
+   Sort_Type  -> prPrec i 0 (concatD [doc (showString "Type")])
+   Sort_PType  -> prPrec i 0 (concatD [doc (showString "PType")])
+   Sort_Tok  -> prPrec i 0 (concatD [doc (showString "Tok")])
+   Sort_Str  -> prPrec i 0 (concatD [doc (showString "Str")])
+   Sort_Strs  -> prPrec i 0 (concatD [doc (showString "Strs")])
+
+
+instance Print Bind where
+  prt i e = case e of
+   BIdent pident -> prPrec i 0 (concatD [prt 0 pident])
+   BWild  -> prPrec i 0 (concatD [doc (showString "_")])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
+
+instance Print Decl where
+  prt i e = case e of
+   DDec binds exp -> prPrec i 0 (concatD [doc (showString "(") , prt 0 binds , doc (showString ":") , prt 0 exp , doc (showString ")")])
+   DExp exp -> prPrec i 0 (concatD [prt 4 exp])
+
+
+instance Print TupleComp where
+  prt i e = case e of
+   TComp exp -> prPrec i 0 (concatD [prt 0 exp])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
+
+instance Print PattTupleComp where
+  prt i e = case e of
+   PTComp patt -> prPrec i 0 (concatD [prt 0 patt])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
+
+instance Print Case where
+  prt i e = case e of
+   Case patt exp -> prPrec i 0 (concatD [prt 0 patt , doc (showString "=>") , prt 0 exp])
+
+  prtList es = case es of
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print Equation where
+  prt i e = case e of
+   Equ patts exp -> prPrec i 0 (concatD [prt 0 patts , doc (showString "->") , prt 0 exp])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print Altern where
+  prt i e = case e of
+   Alt exp0 exp -> prPrec i 0 (concatD [prt 0 exp0 , doc (showString "/") , prt 0 exp])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   [x] -> (concatD [prt 0 x])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+instance Print DDecl where
+  prt i e = case e of
+   DDDec binds exp -> prPrec i 0 (concatD [doc (showString "(") , prt 0 binds , doc (showString ":") , prt 0 exp , doc (showString ")")])
+   DDExp exp -> prPrec i 0 (concatD [prt 6 exp])
+
+  prtList es = case es of
+   [] -> (concatD [])
+   x:xs -> (concatD [prt 0 x , prt 0 xs])
+
+instance Print OldGrammar where
+  prt i e = case e of
+   OldGr include topdefs -> prPrec i 0 (concatD [prt 0 include , prt 0 topdefs])
+
+
+instance Print Include where
+  prt i e = case e of
+   NoIncl  -> prPrec i 0 (concatD [])
+   Incl filenames -> prPrec i 0 (concatD [doc (showString "include") , prt 0 filenames])
+
+
+instance Print FileName where
+  prt i e = case e of
+   FString str -> prPrec i 0 (concatD [prt 0 str])
+   FIdent pident -> prPrec i 0 (concatD [prt 0 pident])
+   FSlash filename -> prPrec i 0 (concatD [doc (showString "/") , prt 0 filename])
+   FDot filename -> prPrec i 0 (concatD [doc (showString ".") , prt 0 filename])
+   FMinus filename -> prPrec i 0 (concatD [doc (showString "-") , prt 0 filename])
+   FAddId pident filename -> prPrec i 0 (concatD [prt 0 pident , prt 0 filename])
+
+  prtList es = case es of
+   [x] -> (concatD [prt 0 x , doc (showString ";")])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+
+

src-3.0/GF/Source/SkelGF.hs

@@ -0,0 +1,364 @@
+module GF.Source.SkelGF where
+
+-- Haskell module generated by the BNF converter
+
+import GF.Source.AbsGF
+import GF.Source.ErrM
+type Result = Err String
+
+failure :: Show a => a -> Result
+failure x = Bad $ "Undefined case: " ++ show x
+
+transLString :: LString -> Result
+transLString x = case x of
+  LString str  -> failure x
+
+
+transPIdent :: PIdent -> Result
+transPIdent x = case x of
+  PIdent str  -> failure x
+
+
+transGrammar :: Grammar -> Result
+transGrammar x = case x of
+  Gr moddefs  -> failure x
+
+
+transModDef :: ModDef -> Result
+transModDef x = case x of
+  MMain pident0 pident concspecs  -> failure x
+  MModule complmod modtype modbody  -> failure x
+
+
+transConcSpec :: ConcSpec -> Result
+transConcSpec x = case x of
+  ConcSpec pident concexp  -> failure x
+
+
+transConcExp :: ConcExp -> Result
+transConcExp x = case x of
+  ConcExp pident transfers  -> failure x
+
+
+transTransfer :: Transfer -> Result
+transTransfer x = case x of
+  TransferIn open  -> failure x
+  TransferOut open  -> failure x
+
+
+transModType :: ModType -> Result
+transModType x = case x of
+  MTAbstract pident  -> failure x
+  MTResource pident  -> failure x
+  MTInterface pident  -> failure x
+  MTConcrete pident0 pident  -> failure x
+  MTInstance pident0 pident  -> failure x
+  MTTransfer pident open0 open  -> failure x
+
+
+transModBody :: ModBody -> Result
+transModBody x = case x of
+  MBody extend opens topdefs  -> failure x
+  MNoBody includeds  -> failure x
+  MWith included opens  -> failure x
+  MWithBody included opens0 opens topdefs  -> failure x
+  MWithE includeds included opens  -> failure x
+  MWithEBody includeds included opens0 opens topdefs  -> failure x
+  MReuse pident  -> failure x
+  MUnion includeds  -> failure x
+
+
+transExtend :: Extend -> Result
+transExtend x = case x of
+  Ext includeds  -> failure x
+  NoExt  -> failure x
+
+
+transOpens :: Opens -> Result
+transOpens x = case x of
+  NoOpens  -> failure x
+  OpenIn opens  -> failure x
+
+
+transOpen :: Open -> Result
+transOpen x = case x of
+  OName pident  -> failure x
+  OQualQO qualopen pident  -> failure x
+  OQual qualopen pident0 pident  -> failure x
+
+
+transComplMod :: ComplMod -> Result
+transComplMod x = case x of
+  CMCompl  -> failure x
+  CMIncompl  -> failure x
+
+
+transQualOpen :: QualOpen -> Result
+transQualOpen x = case x of
+  QOCompl  -> failure x
+  QOIncompl  -> failure x
+  QOInterface  -> failure x
+
+
+transIncluded :: Included -> Result
+transIncluded x = case x of
+  IAll pident  -> failure x
+  ISome pident pidents  -> failure x
+  IMinus pident pidents  -> failure x
+
+
+transDef :: Def -> Result
+transDef x = case x of
+  DDecl names exp  -> failure x
+  DDef names exp  -> failure x
+  DPatt name patts exp  -> failure x
+  DFull names exp0 exp  -> failure x
+
+
+transTopDef :: TopDef -> Result
+transTopDef x = case x of
+  DefCat catdefs  -> failure x
+  DefFun fundefs  -> failure x
+  DefFunData fundefs  -> failure x
+  DefDef defs  -> failure x
+  DefData datadefs  -> failure x
+  DefTrans defs  -> 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
+  DefPackage pident topdefs  -> failure x
+  DefVars defs  -> failure x
+  DefTokenizer pident  -> failure x
+
+
+transCatDef :: CatDef -> Result
+transCatDef x = case x of
+  SimpleCatDef pident ddecls  -> failure x
+  ListCatDef pident ddecls  -> failure x
+  ListSizeCatDef pident ddecls n  -> failure x
+
+
+transFunDef :: FunDef -> Result
+transFunDef x = case x of
+  FunDef pidents exp  -> failure x
+
+
+transDataDef :: DataDef -> Result
+transDataDef x = case x of
+  DataDef pident dataconstrs  -> failure x
+
+
+transDataConstr :: DataConstr -> Result
+transDataConstr x = case x of
+  DataId pident  -> failure x
+  DataQId pident0 pident  -> failure x
+
+
+transParDef :: ParDef -> Result
+transParDef x = case x of
+  ParDefDir pident parconstrs  -> failure x
+  ParDefIndir pident0 pident  -> failure x
+  ParDefAbs pident  -> failure x
+
+
+transParConstr :: ParConstr -> Result
+transParConstr x = case x of
+  ParConstr pident ddecls  -> failure x
+
+
+transPrintDef :: PrintDef -> Result
+transPrintDef x = case x of
+  PrintDef names exp  -> failure x
+
+
+transFlagDef :: FlagDef -> Result
+transFlagDef x = case x of
+  FlagDef pident0 pident  -> failure x
+
+
+transName :: Name -> Result
+transName x = case x of
+  IdentName pident  -> failure x
+  ListName pident  -> failure x
+
+
+transLocDef :: LocDef -> Result
+transLocDef x = case x of
+  LDDecl pidents exp  -> failure x
+  LDDef pidents exp  -> failure x
+  LDFull pidents exp0 exp  -> failure x
+
+
+transExp :: Exp -> Result
+transExp x = case x of
+  EIdent pident  -> failure x
+  EConstr pident  -> failure x
+  ECons pident  -> failure x
+  ESort sort  -> failure x
+  EString str  -> failure x
+  EInt n  -> failure x
+  EFloat d  -> failure x
+  EMeta  -> failure x
+  EEmpty  -> failure x
+  EData  -> failure x
+  EList pident exps  -> failure x
+  EStrings str  -> failure x
+  ERecord locdefs  -> failure x
+  ETuple tuplecomps  -> failure x
+  EIndir pident  -> failure x
+  ETyped exp0 exp  -> failure x
+  EProj exp label  -> failure x
+  EQConstr pident0 pident  -> failure x
+  EQCons pident0 pident  -> failure x
+  EApp exp0 exp  -> failure x
+  ETable cases  -> failure x
+  ETTable exp cases  -> failure x
+  EVTable exp exps  -> failure x
+  ECase exp cases  -> failure x
+  EVariants exps  -> failure x
+  EPre exp alterns  -> failure x
+  EStrs exps  -> failure x
+  EConAt pident exp  -> failure x
+  EPatt patt  -> failure x
+  EPattType exp  -> failure x
+  ESelect exp0 exp  -> failure x
+  ETupTyp exp0 exp  -> failure x
+  EExtend exp0 exp  -> failure x
+  EGlue exp0 exp  -> failure x
+  EConcat exp0 exp  -> failure x
+  EAbstr binds exp  -> failure x
+  ECTable binds exp  -> failure x
+  EProd decl exp  -> failure x
+  ETType exp0 exp  -> failure x
+  ELet locdefs exp  -> failure x
+  ELetb locdefs exp  -> failure x
+  EWhere exp locdefs  -> failure x
+  EEqs equations  -> failure x
+  EExample exp str  -> failure x
+  ELString lstring  -> failure x
+  ELin pident  -> failure x
+
+
+transExps :: Exps -> Result
+transExps x = case x of
+  NilExp  -> failure x
+  ConsExp exp exps  -> failure x
+
+
+transPatt :: Patt -> Result
+transPatt x = case x of
+  PChar  -> failure x
+  PChars str  -> failure x
+  PMacro pident  -> failure x
+  PM pident0 pident  -> failure x
+  PW  -> failure x
+  PV pident  -> failure x
+  PCon pident  -> failure x
+  PQ pident0 pident  -> failure x
+  PInt n  -> failure x
+  PFloat d  -> failure x
+  PStr str  -> failure x
+  PR pattasss  -> failure x
+  PTup patttuplecomps  -> failure x
+  PC pident patts  -> failure x
+  PQC pident0 pident patts  -> failure x
+  PDisj patt0 patt  -> failure x
+  PSeq patt0 patt  -> failure x
+  PRep patt  -> failure x
+  PAs pident patt  -> failure x
+  PNeg patt  -> failure x
+
+
+transPattAss :: PattAss -> Result
+transPattAss x = case x of
+  PA pidents patt  -> failure x
+
+
+transLabel :: Label -> Result
+transLabel x = case x of
+  LIdent pident  -> 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
+
+
+transBind :: Bind -> Result
+transBind x = case x of
+  BIdent pident  -> 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 patt 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 pident  -> failure x
+  FSlash filename  -> failure x
+  FDot filename  -> failure x
+  FMinus filename  -> failure x
+  FAddId pident filename  -> failure x
+
+
+

src-3.0/GF/Source/SourceToGrammar.hs

@@ -0,0 +1,755 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : SourceToGrammar
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/10/04 11:05:07 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.28 $
+--
+-- based on the skeleton Haskell module generated by the BNF converter
+-----------------------------------------------------------------------------
+
+module GF.Source.SourceToGrammar ( transGrammar,
+			 transInclude,
+			 transModDef,
+			 transOldGrammar,
+			 transExp,
+			 newReservedWords
+		       ) where
+
+import qualified GF.Grammar.Grammar as G
+import qualified GF.Grammar.PrGrammar as GP
+import qualified GF.Infra.Modules as GM
+import qualified GF.Grammar.Macros as M
+import qualified GF.Compile.Update as U
+import qualified GF.Infra.Option as GO
+import qualified GF.Compile.ModDeps as GD
+import GF.Infra.Ident
+import GF.Source.AbsGF
+import GF.Source.PrintGF
+import GF.Compile.RemoveLiT --- for bw compat
+import GF.Data.Operations
+import GF.Infra.Option
+
+import Control.Monad
+import Data.Char
+import Data.List (genericReplicate)
+
+-- 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
+
+prPIdent :: PIdent -> String
+prPIdent (PIdent (_,c)) = c
+
+getIdentPos :: PIdent -> Err (Ident,Int)
+getIdentPos x = case x of
+  PIdent ((line,_),c) -> return (IC c,line)
+
+transIdent :: PIdent -> Err Ident
+transIdent = liftM fst . getIdentPos
+
+transName :: Name -> Err Ident
+transName n = case n of
+  IdentName i -> transIdent i
+  ListName  i -> liftM mkListId (transIdent i)
+
+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'))
+
+  MModule compl mtyp body -> do
+
+    let mstat' = transComplMod compl
+
+    (trDef, mtyp', id') <- case mtyp of
+      MTAbstract id -> do
+        id' <- transIdent id
+        return (transAbsDef, GM.MTAbstract, id')
+      MTResource id -> mkModRes id GM.MTResource body 
+      MTConcrete id open -> do
+        id'   <- transIdent id
+        open' <- transIdent open
+        return (transCncDef, GM.MTConcrete open', id')
+      MTTransfer id a b -> do
+        id'  <- transIdent id
+        a'   <- transOpen a
+        b'   <- transOpen a
+        return (transAbsDef, GM.MTTransfer a' b', id')
+      MTInterface id -> mkModRes id GM.MTInterface body
+      MTInstance id open -> do
+        open' <- transIdent open
+        mkModRes id (GM.MTInstance open') body
+
+    mkBody (mstat', trDef, mtyp', id') body
+  where
+      mkBody xx@(mstat', trDef, mtyp', id') bod = case bod of 
+       MNoBody incls -> do
+        mkBody xx $ MBody (Ext incls) NoOpens []
+       MBody extends opens defs -> do
+        extends' <- transExtend extends
+        opens'   <- transOpens opens
+        defs0    <- mapM trDef $ 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 mtyp' mstat' flags' extends' opens' defs'))
+       MReuse _ -> do
+        return (id', GM.ModMod (GM.Module mtyp' mstat' [] [] [] emptyBinTree))
+       MUnion imps -> do
+        imps' <- mapM transIncluded imps        
+        return (id', 
+          GM.ModMod (GM.Module (GM.MTUnion mtyp' imps') mstat' [] [] [] emptyBinTree))
+
+       MWith m insts -> mkBody xx $ MWithEBody [] m insts NoOpens []
+       MWithBody m insts opens defs -> mkBody xx $ MWithEBody [] m insts opens defs
+       MWithE extends m insts -> mkBody xx $ MWithEBody extends m insts NoOpens []
+       MWithEBody extends m insts opens defs -> do
+        extends' <- mapM transIncludedExt extends
+        m'       <- transIncludedExt m
+        insts'   <- mapM transOpen insts 
+        opens'   <- transOpens opens
+        defs0    <- mapM trDef $ getTopDefs defs
+        defs'    <- U.buildAnyTree [d | Left  ds <- defs0, d <- ds]
+        flags'   <- return       [f | Right fs <- defs0, f <- fs]
+        return (id',
+          GM.ModWith (GM.Module mtyp' mstat' flags' extends' opens' defs') m' insts')
+
+      mkModRes id mtyp body = do
+         id' <- transIdent id
+         case body of
+           MReuse c -> do
+             c' <- transIdent c
+             mtyp' <- trMReuseType mtyp c'
+             return (transResDef, GM.MTReuse mtyp', id')
+           _ -> return (transResDef, mtyp, id')
+      trMReuseType mtyp c = case mtyp of
+         GM.MTInterface -> return $ GM.MRInterface c
+         GM.MTInstance op -> return $ GM.MRInstance c op
+         GM.MTResource -> return $ GM.MRResource c
+
+
+transComplMod :: ComplMod -> GM.ModuleStatus
+transComplMod x = case x of
+  CMCompl  -> GM.MSComplete
+  CMIncompl  -> GM.MSIncomplete
+
+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 [(Ident,GM.MInclude Ident)]
+transExtend x = case x of
+  Ext ids  -> mapM transIncludedExt ids
+  NoExt -> return []
+
+transOpens :: Opens -> Err [GM.OpenSpec Ident]
+transOpens x = case x of
+  NoOpens  -> return []
+  OpenIn opens  -> mapM transOpen opens
+
+transOpen :: Open -> Err (GM.OpenSpec Ident)
+transOpen x = case x of
+  OName id     -> liftM   (GM.OSimple GM.OQNormal) $ transIdent id
+  OQualQO q id -> liftM2  GM.OSimple (transQualOpen q) (transIdent id)
+  OQual q id m -> liftM3  GM.OQualif  (transQualOpen q) (transIdent id) (transIdent m)
+
+transQualOpen :: QualOpen -> Err GM.OpenQualif
+transQualOpen x = case x of
+  QOCompl  -> return GM.OQNormal
+  QOInterface  -> return GM.OQInterface
+  QOIncompl  -> return GM.OQIncomplete
+
+transIncluded :: Included -> Err (Ident,[Ident])
+transIncluded x = case x of
+  IAll i        -> liftM (flip (curry id) []) $ transIdent i
+  ISome  i ids  -> liftM2 (curry id) (transIdent i) (mapM transIdent ids)
+  IMinus i ids  -> liftM2 (curry id) (transIdent i) (mapM transIdent ids) ----
+
+transIncludedExt :: Included -> Err (Ident, GM.MInclude Ident)
+transIncludedExt x = case x of
+  IAll i       -> liftM2 (,) (transIdent i) (return GM.MIAll)
+  ISome  i ids -> liftM2 (,) (transIdent i) (liftM GM.MIOnly   $ mapM transIdent ids) 
+  IMinus i ids -> liftM2 (,) (transIdent i) (liftM GM.MIExcept $ mapM transIdent ids)
+
+transAbsDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option])
+transAbsDef x = case x of
+  DefCat catdefs -> liftM (Left . concat) $ mapM transCatDef catdefs
+  DefFun fundefs -> do
+    fundefs' <- mapM transFunDef fundefs
+    returnl [(fun, G.AbsFun (yes typ) nope) | (funs,typ) <- fundefs', fun <- funs]
+  DefFunData fundefs -> do
+    fundefs' <- mapM transFunDef fundefs
+    returnl $
+      [(cat, G.AbsCat nope (yes [M.cn fun])) | (funs,typ) <- fundefs', 
+                                       fun <- funs, 
+                                       Ok (_,cat) <- [M.valCat typ]
+      ] ++
+      [(fun, G.AbsFun (yes typ) (yes G.EData)) | (funs,typ) <- fundefs', fun <- funs]
+  DefDef defs  -> do
+    defs' <- liftM concat $ mapM getDefsGen defs
+    returnl [(c, G.AbsFun nope pe) | (c,(_,pe)) <- defs']
+  DefData ds -> do
+    ds' <- mapM transDataDef ds
+    returnl $ 
+      [(c, G.AbsCat nope (yes ps)) | (c,ps) <- ds'] ++
+      [(f, G.AbsFun nope (yes G.EData))  | (_,fs) <- ds', tf <- fs, f <- funs tf]
+  DefTrans defs  -> do
+    defs' <- liftM concat $ mapM getDefsGen defs
+    returnl [(c, G.AbsTrans f) | (c,(_,Yes f)) <- defs']
+  DefFlag defs -> liftM Right $ mapM transFlagDef defs
+  _ -> Bad $ "illegal definition in abstract module:" ++++ printTree x
+ where
+   -- to get data constructors as terms
+   funs t = case t of
+     G.Cn f -> [f]
+     G.Q _ f -> [f]
+     G.QC _ f -> [f]
+     _ -> []
+
+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 (prPIdent f,[prPIdent x])
+
+-- | Cat definitions can also return some fun defs
+--   if it is a list category definition
+transCatDef :: CatDef -> Err [(Ident, G.Info)]
+transCatDef x = case x of
+  SimpleCatDef id ddecls        -> do
+    id' <- transIdent id
+    liftM (:[]) $ cat id' ddecls
+  ListCatDef id ddecls          -> listCat id ddecls 0
+  ListSizeCatDef id ddecls size -> listCat id ddecls size
+ where 
+   cat i ddecls = do
+		       -- i <- transIdent id
+		       cont <- liftM concat $ mapM transDDecl ddecls
+		       return (i, G.AbsCat (yes cont) nope)
+   listCat id ddecls size = do
+         id' <- transIdent id
+	 let 
+           li = mkListId id'
+           baseId = mkBaseId id'
+           consId = mkConsId id'
+	 catd0@(c,G.AbsCat (Yes cont0) _) <- cat li ddecls
+	 let
+  	   catd = (c,G.AbsCat (Yes cont0) (Yes [M.cn baseId,M.cn consId]))
+           cont = [(mkId x i,ty) | (i,(x,ty)) <- zip [0..] cont0]
+           xs = map (G.Vr . fst) cont 
+           cd = M.mkDecl (M.mkApp (G.Vr id') xs)
+	   lc = M.mkApp (G.Vr li) xs
+	   niltyp = M.mkProdSimple (cont ++ genericReplicate size cd) lc
+	   nilfund = (baseId, G.AbsFun (yes niltyp) (yes G.EData))
+	   constyp = M.mkProdSimple (cont ++ [cd, M.mkDecl lc]) lc
+	   consfund = (consId, G.AbsFun (yes constyp) (yes G.EData))
+	 return [catd,nilfund,consfund]
+   mkId x i = if isWildIdent x then (mkIdent "x" i) else x
+
+transFunDef :: FunDef -> Err ([Ident], G.Type)
+transFunDef x = case x of
+  FunDef ids typ  -> liftM2 (,) (mapM transIdent ids) (transExp typ)
+
+transDataDef :: DataDef -> Err (Ident,[G.Term])
+transDataDef x = case x of
+  DataDef id ds  -> liftM2 (,) (transIdent id) (mapM transData ds) 
+ where
+   transData d = case d of
+     DataId id  -> liftM G.Cn $ transIdent id
+     DataQId id0 id  -> liftM2 G.QC (transIdent id0) (transIdent id)
+
+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,Nothing)))) 
+                                     | (p,pars) <- pardefs']
+           ++ [(f, G.ResValue (yes (M.mkProdSimple co (G.Cn p),Nothing))) |
+                     (p,pars) <- pardefs', (f,co) <- pars]
+
+{-
+  ---- encoding of AnyInd without changing syntax. AR 20/9/2007
+  DefOper [DDef [c] (EApp (EInt status) (EIdent mo))] -> do
+    c' <- transName c
+    mo' <- transIdent mo
+    return $ Left [(c',G.AnyInd (status==1) mo')]
+-}
+  DefOper defs -> do
+    defs' <- liftM concat $ mapM getDefs defs
+    returnl $ concatMap mkOverload [(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
+ where
+   mkOverload (c,j) = case j of
+     G.ResOper _ (Yes (G.App keyw (G.R fs@(_:_:_)))) | 
+                                          isOverloading keyw c fs -> 
+       [(c,G.ResOverload [(ty,fu) | (_,(Just ty,fu)) <- fs])]
+
+     -- to enable separare type signature --- not type-checked
+     G.ResOper (Yes (G.App keyw (G.RecType fs@(_:_:_)))) _ | 
+                                          isOverloading keyw c fs -> []
+     _ -> [(c,j)]
+   isOverloading keyw c fs = 
+     GP.prt keyw == "overload" &&       -- overload is a "soft keyword"
+     all (== GP.prt c) (map (GP.prt . fst) fs)
+
+transParDef :: ParDef -> Err (Ident, [G.Param])
+transParDef x = case x of
+  ParDefDir 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]
+
+  _ -> errIn ("illegal definition in concrete syntax:") $ transResDef x
+
+transPrintDef :: PrintDef -> Err [(Ident,G.Term)]
+transPrintDef x = case x of
+  PrintDef ids exp  -> do
+    (ids,e) <- liftM2 (,) (mapM transName ids) (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 transName ids
+    t'   <- transExp t
+    return [(i,(yes t', nope)) | i <- ids']
+  DDef ids e -> do
+    ids' <- mapM transName ids
+    e'   <- transExp e
+    return [(i,(nope, yes e')) | i <- ids']
+  DFull ids t e -> do
+    ids' <- mapM transName ids
+    t'   <- transExp t
+    e'   <- transExp e
+    return [(i,(yes t', yes e')) | i <- ids']
+  DPatt id patts e  -> do
+    id' <- transName 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' <- transName 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 n
+  EFloat n      -> return $ G.EFloat n
+  EMeta         -> return $ M.meta $ M.int2meta 0
+  EEmpty        -> return G.Empty
+  -- [ C x_1 ... x_n ] becomes (ListC x_1 ... x_n)
+  EList i es    -> do
+    i' <- transIdent i
+    es' <- mapM transExp (exps2list es)
+    return $ foldl G.App (G.Vr (mkListId i')) es'
+  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)
+  EVTable exp cases -> 
+    liftM2 (\t c -> G.V t c) (transExp exp) (mapM transExp cases)
+  ECase exp cases  -> do
+    exp' <- transExp exp
+    cases' <- transCases cases
+    let annot = case exp' of
+          G.Typed _ t -> G.TTyped t
+          _ -> G.TRaw 
+    return $ G.S (G.T annot 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)
+  EExample exp str  -> liftM2 G.Example (transExp exp) (return str)
+
+  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"
+  ELetb defs exp -> transExp $ ELet defs exp
+  EWhere exp defs -> transExp $ ELet defs exp
+
+  EPattType typ -> liftM G.EPattType (transExp typ)
+  EPatt patt -> liftM G.EPatt (transPatt patt)
+
+  ELString (LString str) -> return $ G.K str 
+  ELin id -> liftM G.LiT $ transIdent id
+
+  EEqs eqs -> liftM G.Eqs $ mapM transEquation eqs
+
+  _ -> Bad $ "translation not yet defined for" +++ printTree x ----
+
+exps2list :: Exps -> [Exp]
+exps2list NilExp = []
+exps2list (ConsExp e es) = e : exps2list es
+
+--- 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 :: LocDef -> Err [(Ident, (Maybe G.Type, Maybe G.Type))]
+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 compatibility and should be removed
+  LIdent (PIdent (_,'v':ds@(_:_))) | all isDigit ds -> return $ G.LVar $ readIntArg ds 
+  
+  LIdent (PIdent (_, s)) -> return $ G.LIdent s
+  LVar x   -> return $ G.LVar $ fromInteger x
+
+transSort :: Sort -> Err String
+transSort x = case x of
+  _ -> return $ printTree x
+
+{-
+--- no more used 7/1/2006 AR
+transPatts :: Patt -> Err [G.Patt]
+transPatts p = case p of
+  PDisj p1 p2 -> liftM2 (++) (transPatts p1) (transPatts p2)
+  PC id patts -> liftM (map (G.PC id) . combinations) $ mapM transPatts patts
+  PQC q id patts -> liftM (map (G.PP q id) . combinations) (mapM transPatts patts)
+
+  PR pattasss -> do
+    let (lss,ps) = unzip [(ls,p) | PA ls p <- pattasss]
+        ls = map LIdent $ concat lss
+    ps0 <- mapM transPatts ps
+    let ps' = combinations ps0
+    lss' <- mapM trLabel ls
+    let rss = map (zip lss') ps'
+    return $ map G.PR rss
+  PTup pcs -> do
+    ps0 <- mapM transPatts [e | PTComp e <- pcs]
+    let ps' = combinations ps0
+    return $ map (G.PR . M.tuple2recordPatt) ps'
+  _ -> liftM singleton $ transPatt p
+-}
+
+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 n
+  PFloat n  -> return $ G.PFloat 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)
+  PDisj p1 p2 -> liftM2 G.PAlt (transPatt p1) (transPatt p2)
+  PSeq p1 p2  -> liftM2 G.PSeq (transPatt p1) (transPatt p2)
+  PRep p      -> liftM  G.PRep (transPatt p)
+  PNeg p      -> liftM  G.PNeg (transPatt p)
+  PAs x p     -> liftM2 G.PAs  (transIdent x) (transPatt p)
+  PChar -> return G.PChar
+  PChars s -> return $ G.PChars s
+  PMacro c -> liftM G.PMacro $ transIdent c
+  PM m c   -> liftM2 G.PM (transIdent m) (transIdent c)
+
+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 = mapM transCase
+
+transCase :: Case -> Err G.Case
+transCase (Case p exp) = do
+  patt <- transPatt p
+  exp'  <- transExp exp  
+  return (patt,exp')
+
+transEquation :: Equation -> Err G.Equation
+transEquation x = case x of
+  Equ apatts exp -> liftM2 (,) (mapM transPatt apatts) (transExp exp)
+
+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 :: Options -> FilePath -> OldGrammar -> Err G.SourceGrammar
+transOldGrammar opts name0 x = 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 ops r,mkCnc ops c] ++ map mkPack ps
+     where 
+       ops = map fst ps
+       (a,r,c,ps) = foldr srt ([],[],[],[]) ds
+   srt d (a,r,c,ps) = case d of
+     DefCat catdefs  -> (d:a,r,c,ps)
+     DefFun fundefs  -> (d:a,r,c,ps)
+     DefFunData fundefs -> (d:a,r,c,ps)
+     DefDef defs     -> (d:a,r,c,ps)
+     DefData pardefs -> (d:a,r,c,ps)
+     DefPar pardefs  -> (a,d:r,c,ps)
+     DefOper defs    -> (a,d:r,c,ps)
+     DefLintype defs -> (a,d:r,c,ps)
+     DefLincat defs  -> (a,r,d:c,ps)
+     DefLindef defs  -> (a,r,d:c,ps)
+     DefLin defs     -> (a,r,d:c,ps)
+     DefPattern defs -> (a,r,d:c,ps)
+     DefFlag defs    -> (a,r,d:c,ps) --- a guess
+     DefPrintCat printdefs  -> (a,r,d:c,ps)
+     DefPrintFun printdefs  -> (a,r,d:c,ps)
+     DefPrintOld printdefs  -> (a,r,d:c,ps)
+     DefPackage m ds        -> (a,r,c,(m,ds):ps)
+     _ -> (a,r,c,ps)
+   mkAbs a = MModule q (MTAbstract absName) (MBody ne (OpenIn [])  (topDefs a))
+   mkRes ps r = MModule q (MTResource resName) (MBody ne (OpenIn ops) (topDefs r))
+                  where ops = map OName ps
+   mkCnc ps r = MModule q (MTConcrete cncName absName) 
+                               (MBody ne (OpenIn (map OName (resName:ps))) (topDefs r))
+   mkPack (m, ds) = MModule q (MTResource m) (MBody ne  (OpenIn []) (topDefs ds))
+   topDefs t = t
+   ne = NoExt
+   q = CMCompl
+
+   name = maybe name0 (++ ".gf") $ getOptVal opts useName
+   absName = identPI $ maybe topic id $ getOptVal opts useAbsName
+   resName = identPI $ maybe ("Res" ++ lang) id $ getOptVal opts useResName
+   cncName = identPI $ maybe lang id $ getOptVal opts useCncName
+
+   identPI s = PIdent ((0,0),s)
+
+   (beg,rest) = span (/='.') name
+   (topic,lang) = case rest of -- to avoid overwriting old files
+     ".gf" -> ("Abs" ++ beg,"Cnc" ++ beg)
+     ".cf" -> ("Abs" ++ beg,"Cnc" ++ beg)
+     ".ebnf" -> ("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 (PIdent (_, s)) -> modif s
+     FSlash filename  -> '/' : trans filename
+     FDot filename  -> '.' : trans filename
+     FMinus filename  -> '-' : trans filename
+     FAddId (PIdent (_, s)) filename  -> modif s ++ trans filename
+   modif s = let s' = init s ++ [toLower (last s)] in 
+             if elem s' newReservedWords then s' else s 
+                      --- unsafe hack ; cf. GetGrammar.oldLexer
+
+
+newReservedWords :: [String]
+newReservedWords =
+  words $ "abstract concrete interface incomplete " ++ 
+          "instance out open resource reuse transfer union with where"
+
+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)
+
+mkListId,mkConsId,mkBaseId  :: Ident -> Ident
+mkListId = prefixId "List"
+mkConsId = prefixId "Cons"
+mkBaseId = prefixId "Base"
+
+prefixId :: String -> Ident -> Ident
+prefixId pref id = IC (pref ++ prIdent id)

src-3.0/GF/Source/TestGF.hs

@@ -0,0 +1,58 @@
+-- automatically generated by BNF Converter
+module Main where
+
+
+import IO ( stdin, hGetContents )
+import System ( getArgs, getProgName )
+
+import GF.Source.LexGF
+import GF.Source.ParGF
+import GF.Source.SkelGF
+import GF.Source.PrintGF
+import GF.Source.AbsGF
+
+
+
+
+import GF.Source.ErrM
+
+type ParseFun a = [Token] -> Err a
+
+myLLexer = myLexer
+
+type Verbosity = Int
+
+putStrV :: Verbosity -> String -> IO ()
+putStrV v s = if v > 1 then putStrLn s else return ()
+
+runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()
+runFile v p f = putStrLn f >> readFile f >>= run v p
+
+run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()
+run v p s = let ts = myLLexer s in case p ts of
+           Bad s    -> do putStrLn "\nParse              Failed...\n"
+                          putStrV v "Tokens:"
+                          putStrV v $ show ts
+                          putStrLn s
+           Ok  tree -> do putStrLn "\nParse Successful!"
+                          showTree v tree
+
+
+
+showTree :: (Show a, Print a) => Int -> a -> IO ()
+showTree v tree
+ = do
+      putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree
+      putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree
+
+main :: IO ()
+main = do args <- getArgs
+          case args of
+            [] -> hGetContents stdin >>= run 2 pGrammar
+            "-s":fs -> mapM_ (runFile 0 pGrammar) fs
+            fs -> mapM_ (runFile 2 pGrammar) fs
+
+
+
+
+