clean up the GF.Grammar API

1 files changed, 0 insertions, 733 deletions

diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs
deleted file mode 100644
index 21d670768..000000000
--- a/src/GF/Source/SourceToGrammar.hs
+++ /dev/null
@@ -1,733 +0,0 @@
-----------------------------------------------------------------------
--- |
--- 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.Grammar.Predef
-import GF.Infra.Ident
-import GF.Source.AbsGF
-import GF.Source.PrintGF
-import GF.Data.Operations
-import GF.Infra.Option
-
-import Control.Monad
-import Data.Char
-import Data.List (genericReplicate)
-import qualified Data.ByteString.Char8 as BS
-
--- 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
-
-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)
-
-transNamePos :: Name -> Err (Ident,Int)
-transNamePos n = case n of
-  IdentName i -> getIdentPos i
-  ListName  i -> liftM (\ (c,p) -> (mkListId c,p)) (getIdentPos i)
-
-transGrammar :: Grammar -> Err G.SourceGrammar
-transGrammar x = case x of
-  Gr moddefs  -> do
-    moddefs' <- mapM transModDef moddefs
-    GD.mkSourceGrammar moddefs'
-
-transModDef :: ModDef -> Err G.SourceModule
-transModDef x = case x of
-
-  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
-      poss = emptyBinTree ----
-
-      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
-        poss0    <- return [(i,p) | Left  ds <- defs0, (i,p,_) <- ds]
-        defs'    <- U.buildAnyTree id' [(i,d) | Left  ds <- defs0, (i,_,d) <- ds]
-        flags'   <- return $ concatOptions [o | Right o <- defs0]
-        let poss1 = buildPosTree id' poss0
-        return (id', GM.ModInfo mtyp' mstat' flags' extends' Nothing opens' [] defs' poss1)
-
-       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 transInst insts 
-        opens'   <- transOpens opens
-        defs0    <- mapM trDef $ getTopDefs defs
-        poss0    <- return [(i,p) | Left  ds <- defs0, (i,p,_) <- ds]
-        defs'    <- U.buildAnyTree id' [(i,d) | Left  ds <- defs0, (i,_,d) <- ds]
-        flags'   <- return $ concatOptions [o | Right o <- defs0]
-        let poss1 = buildPosTree id' poss0
-        return (id', GM.ModInfo mtyp' mstat' flags' extends' (Just (fst m',snd m',insts')) opens' [] defs' poss1)
-
-      mkModRes id mtyp body = do
-         id' <- transIdent id
-         return (transResDef, mtyp, id')
-
-
-transComplMod :: ComplMod -> GM.ModuleStatus
-transComplMod x = case x of
-  CMCompl  -> GM.MSComplete
-  CMIncompl  -> GM.MSIncomplete
-
-getTopDefs :: [TopDef] -> [TopDef]
-getTopDefs x = x
-
-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 (transIdent id)
-  OQualQO q id -> liftM  GM.OSimple (transIdent id)
-  OQual q id m -> liftM2 GM.OQualif (transIdent id) (transIdent m)
-
-transInst :: Open -> Err (Ident,Ident)
-transInst x = case x of
-  OQual q id m -> liftM2 (,) (transIdent id) (transIdent m)
-  _            -> Bad "qualified open expected"
-
-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)
-
---- where no position is saved
-nopos :: Int
-nopos = -1
-
-buildPosTree :: Ident -> [(Ident,Int)] -> BinTree Ident (String,(Int,Int))
-buildPosTree m = buildTree . mkPoss . filter ((>0) . snd) where
-  mkPoss cs = case cs of
-    (i,p):rest@((_,q):_) -> (i,(name,(p,max p (q-1)))) : mkPoss rest
-    (i,p):[]             -> (i,(name,(p,p+100))) : [] --- don't know last line
-    _ -> []
-  name = showIdent m ++ ".gf" ----
-
-transAbsDef :: TopDef -> Err (Either [(Ident, Int, G.Info)] GO.Options)
-transAbsDef x = case x of
-  DefCat catdefs -> liftM (Left . concat) $ mapM transCatDef catdefs
-  DefFun fundefs -> do
-    fundefs' <- mapM transFunDef fundefs
-    returnl [(fun, nopos, G.AbsFun (Just typ) Nothing) | (funs,typ) <- fundefs', fun <- funs]
-  DefFunData fundefs -> do
-    fundefs' <- mapM transFunDef fundefs
-    returnl $
-      [(cat, nopos, G.AbsCat Nothing (Just [G.Cn fun])) | (funs,typ) <- fundefs', 
-                                       fun <- funs, 
-                                       Ok (_,cat) <- [M.valCat typ]
-      ] ++
-      [(fun, nopos, G.AbsFun (Just typ) (Just G.EData)) | (funs,typ) <- fundefs', fun <- funs]
-  DefDef defs  -> do
-    defs' <- liftM concat $ mapM getDefsGen defs
-    returnl [(c, nopos, G.AbsFun Nothing pe) | ((c,p),(_,pe)) <- defs']
-  DefData ds -> do
-    ds' <- mapM transDataDef ds
-    returnl $ 
-      [(c, nopos, G.AbsCat Nothing (Just ps)) | (c,ps) <- ds'] ++
-      [(f, nopos, G.AbsFun Nothing (Just G.EData))  | (_,fs) <- ds', tf <- fs, f <- funs tf]
-  DefFlag defs -> liftM (Right . concatOptions) $ 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.Options
-transFlagDef x = case x of
-  FlagDef f x  -> parseModuleOptions ["--" ++ prPIdent f ++ "=" ++ prPIdent x]
-  where
-    prPIdent (PIdent (_,c)) = BS.unpack c
-
-
--- | Cat definitions can also return some fun defs
---   if it is a list category definition
-transCatDef :: CatDef -> Err [(Ident, Int, G.Info)]
-transCatDef x = case x of
-  SimpleCatDef id ddecls        -> do
-    (id',pos) <- getIdentPos id
-    liftM (:[]) $ cat id' pos ddecls
-  ListCatDef id ddecls          -> listCat id ddecls 0
-  ListSizeCatDef id ddecls size -> listCat id ddecls size
- where 
-   cat i pos ddecls = do
-		       -- i <- transIdent id
-		       cont <- liftM concat $ mapM transDDecl ddecls
-		       return (i, pos, G.AbsCat (Just cont) Nothing)
-   listCat id ddecls size = do
-         (id',pos) <- getIdentPos id
-	 let 
-           li = mkListId id'
-           baseId = mkBaseId id'
-           consId = mkConsId id'
-	 catd0@(c,p,G.AbsCat (Just cont0) _) <- cat li pos ddecls
-	 let
-  	   catd = (c,pos,G.AbsCat (Just cont0) (Just [G.Cn baseId,G.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, nopos, G.AbsFun (Just niltyp) (Just G.EData))
-	   constyp = M.mkProdSimple (cont ++ [cd, M.mkDecl lc]) lc
-	   consfund = (consId, nopos, G.AbsFun (Just constyp) (Just G.EData))
-	 return [catd,nilfund,consfund]
-   mkId x i = if isWildIdent x then (varX 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, Int, G.Info)] GO.Options)
-transResDef x = case x of
-  DefPar pardefs -> do
-    pardefs' <- mapM transParDef pardefs
-    returnl $ [(p, nopos, G.ResParam (if null pars 
-                                  then Nothing -- abstract param type 
-                                  else (Just (pars,Nothing)))) 
-                                     | (p,pars) <- pardefs']
-           ++ [(f, nopos, G.ResValue (Just (M.mkProdSimple co (G.Cn p),Nothing))) |
-                     (p,pars) <- pardefs', (f,co) <- pars]
-
-  DefOper defs -> do
-    defs' <- liftM concat $ mapM getDefs defs
-    returnl $ 
-      concatMap mkOverload [(f, p, G.ResOper pt pe) | ((f,p),(pt,pe)) <- defs']
-
-  DefLintype defs -> do
-    defs' <- liftM concat $ mapM getDefs defs
-    returnl [(f, p, G.ResOper pt pe) | ((f,p),(pt,pe)) <- defs']
-
-  DefFlag defs -> liftM (Right . concatOptions) $ mapM transFlagDef defs
-  _ -> Bad $ "illegal definition form in resource" +++ printTree x
- where
-   mkOverload op@(c,p,j) = case j of
-     G.ResOper _ (Just df) -> case M.appForm df of
-       (keyw, ts@(_:_)) | isOverloading keyw -> case last ts of
-         G.R fs -> 
-           [(c,p,G.ResOverload [m | G.Vr m <- ts] [(ty,fu) | (_,(Just ty,fu)) <- fs])]
-         _ -> [op]
-       _ -> [op]
-
-     -- to enable separare type signature --- not type-checked
-     G.ResOper (Just df) _ -> case M.appForm df of
-       (keyw, ts@(_:_)) | isOverloading keyw -> case last ts of
-         G.RecType _ -> [] 
-         _ -> [op]
-       _ -> [op]
-     _ -> [(c,p,j)]
-   isOverloading keyw = 
-     GP.prt keyw == "overload"       -- overload is a "soft keyword"
-   isRec t = case t of
-     G.R _ -> True
-     _ -> False
-
-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, Int, G.Info)] GO.Options)
-transCncDef x = case x of
-  DefLincat defs  -> do
-    defs' <- liftM concat $ mapM transPrintDef defs
-    returnl [(f, nopos, G.CncCat (Just t) Nothing Nothing) | (f,t) <- defs']
-  DefLindef defs  -> do
-    defs' <- liftM concat $ mapM getDefs defs
-    returnl [(f, p, G.CncCat pt pe Nothing) | ((f,p),(pt,pe)) <- defs']
-  DefLin defs  -> do
-    defs' <- liftM concat $ mapM getDefs defs
-    returnl [(f, p, G.CncFun Nothing pe Nothing) | ((f,p),(_,pe)) <- defs']
-  DefPrintCat defs -> do
-    defs' <- liftM concat $ mapM transPrintDef defs
-    returnl [(f, nopos, G.CncCat Nothing Nothing (Just e)) | (f,e) <- defs']    
-  DefPrintFun defs -> do
-    defs' <- liftM concat $ mapM transPrintDef defs
-    returnl [(f, nopos, G.CncFun Nothing Nothing (Just e)) | (f,e) <- defs']
-  DefPrintOld defs -> do  --- a guess, for backward compatibility
-    defs' <- liftM concat $ mapM transPrintDef defs
-    returnl [(f, nopos, G.CncFun Nothing Nothing (Just e)) | (f,e) <- defs']    
-  DefFlag defs -> liftM (Right . concatOptions) $ mapM transFlagDef defs
-  DefPattern defs  -> do
-    defs' <- liftM concat $ mapM getDefs defs
-    let defs2 = [(f, termInPattern t) | (f,(_,Just t)) <- defs']
-    returnl [(f, p, G.CncFun Nothing (Just t) Nothing) | ((f,p),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, Int),(Maybe G.Type, Maybe G.Term))]
-getDefsGen d = case d of
-  DDecl ids t -> do
-    ids' <- mapM transNamePos ids
-    t'   <- transExp t
-    return [(i,(Just t', Nothing)) | i <- ids']
-  DDef ids e -> do
-    ids' <- mapM transNamePos ids
-    e'   <- transExp e
-    return [(i,(Nothing, Just e')) | i <- ids']
-  DFull ids t e -> do
-    ids' <- mapM transNamePos ids
-    t'   <- transExp t
-    e'   <- transExp e
-    return [(i,(Just t', Just e')) | i <- ids']
-  DPatt id patts e  -> do
-    id' <- transNamePos id
-    ps' <- mapM transPatt patts
-    e'  <- transExp e
-    return [(id',(Nothing, Just (G.Eqs [(ps',e')])))]
-
--- | sometimes you need this special case, e.g. in linearization rules
-getDefs :: Def -> Err [((Ident,Int), (Maybe G.Type, Maybe G.Term))]
-getDefs d = case d of
-  DPatt id patts e  -> do
-    id' <- transNamePos id
-    xs  <- mapM tryMakeVar patts
-    e'  <- transExp e
-    return [(id',(Nothing, Just (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    -> return $ G.Sort $ transSort sort
-  EInt n        -> return $ G.EInt n
-  EFloat n      -> return $ G.EFloat n
-  EMeta         -> return $ G.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
-  EVariant exp0 exp -> do let fvList (G.FV xs) = xs
-                              fvList t         = [t]
-                          exp0' <- transExp exp0
-                          exp'  <- transExp exp
-                          return $ G.FV $ fvList exp0' ++ fvList exp'
-  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 (BS.unpack str)  -- use the grammar encoding here
-
-  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 (G.ident2label lab,ty)
-    _ -> Bad $ "illegal record type field" +++ GP.prt (fst f) --- manifest fields ?!
-  tryR f = case f of
-    (lab,(mty, Just t)) -> return (G.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
-  LIdent (PIdent (_, s)) -> return $ G.LIdent s
-  LVar x                 -> return $ G.LVar $ fromInteger x
-
-transSort :: Sort -> Ident
-transSort Sort_Type  = cType
-transSort Sort_PType = cPType
-transSort Sort_Tok   = cTok
-transSort Sort_Str   = cStr
-transSort Sort_Strs  = cStrs
-
-
-{-
---- 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.PW
-  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 two 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
-    transGrammar $ Gr moddefs
- where
-   sortTopDefs ds = [mkAbs a, mkCnc ops (c ++ r)]
-     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) -- OBSOLETE
-     _ -> (a,r,c,ps)
-   mkAbs a = MModule q (MTAbstract absName) (MBody ne (OpenIn [])  (topDefs a))
-   mkCnc ps r = MModule q (MTConcrete cncName absName) (MBody ne (OpenIn []) (topDefs r))
-   topDefs t = t
-   ne = NoExt
-   q = CMCompl
-
-   name = maybe name0 (++ ".gf") $ flag optName opts
-   absName = identPI $ maybe topic id $ flag optAbsName opts
-   resName = identPI $ maybe ("Res" ++ lang) id $ flag optResName opts
-   cncName = identPI $ maybe lang id $ flag optCncName opts
-
-   identPI s = PIdent ((0,0),BS.pack 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 = Bad "Old GF with includes no more supported in GF 3.0"
-
-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 (BS.pack "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 (BS.pack "List")
-mkConsId = prefixId (BS.pack "Cons")
-mkBaseId = prefixId (BS.pack "Base")
-
-prefixId :: BS.ByteString -> Ident -> Ident
-prefixId pref id = identC (BS.append pref (ident2bs id))