restructured some of the new GF format; modules now in place up to gfo generation

1 files changed, 667 insertions, 0 deletions

diff --git a/src/GF/Devel/Compile/SourceToGF.hs b/src/GF/Devel/Compile/SourceToGF.hs
new file mode 100644
index 000000000..103982147
--- /dev/null
+++ b/src/GF/Devel/Compile/SourceToGF.hs
@@ -0,0 +1,667 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : SourceToGF
+-- 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.Devel.Compile.SourceToGF ( 
+  transGrammar,
+  transModDef,
+  transExp,
+----  transOldGrammar,
+----  transInclude,
+  newReservedWords
+  ) where
+
+import qualified GF.Devel.Grammar.Grammar as G
+import GF.Devel.Grammar.Construct
+import qualified GF.Devel.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.Devel.Compile.AbsGF
+import GF.Devel.Compile.PrintGF (printTree)
+----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 qualified Data.Map as Map
+import Data.List (genericReplicate)
+
+import Debug.Trace (trace) ----
+
+-- 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
+  PIdentName i -> transIdent i
+  ListName  i  -> transIdent (mkListId i)
+
+transGrammar :: Grammar -> Err G.GF
+transGrammar x = case x of
+  Gr moddefs  -> do
+    moddefs' <- mapM transModDef moddefs
+    let mos = Map.fromList moddefs'
+    return $ emptyGF {G.gfmodules = mos}
+
+transModDef :: ModDef -> Err (Ident, G.Module)
+transModDef x = case x of
+  MModule compl mtyp body -> do
+
+    let isCompl = transComplMod compl
+
+    (trDef, mtyp', id') <- case mtyp of
+      MAbstract id -> do
+        id' <- transIdent id
+        return (transAbsDef, G.MTAbstract, id')
+      MGrammar id -> mkModRes id G.MTGrammar body 
+      MResource id -> mkModRes id G.MTGrammar body 
+      MConcrete id open -> do
+        id'   <- transIdent id
+        open' <- transIdent open
+        return (transCncDef, G.MTConcrete open', id')
+      MInterface id -> mkModRes id G.MTInterface body
+      MInstance id open -> do
+        open' <- transIdent open
+        mkModRes id (G.MTInstance open') body
+
+    mkBody (isCompl, trDef, mtyp', id') body
+  where
+      mkBody xx@(isc, 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
+        let defs' = Map.fromListWith unifyJudgements 
+                       [(i,d) | Left ds <- defs0, (i,d) <- ds]
+        let flags' = Map.fromList [f | Right fs <- defs0, f <- fs]
+        return (id', G.Module mtyp' isc [] [] extends' opens' flags' defs')
+
+       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
+        let defs'  = Map.fromListWith unifyJudgements 
+                       [(i,d) | Left ds <- defs0, (i,d) <- ds]
+        let flags' = Map.fromList [f | Right fs <- defs0, f <- fs]
+        return (id', G.Module mtyp' isc [] [(m',insts')] extends' opens' flags' defs')
+       _ -> fail "deprecated module form"
+
+
+      mkModRes id mtyp body = do
+        id' <- transIdent id
+        return (transResDef, mtyp, id')
+
+
+getTopDefs :: [TopDef] -> [TopDef]
+getTopDefs x = x
+
+transComplMod :: ComplMod -> Bool
+transComplMod x = case x of
+  CMCompl   -> True
+  CMIncompl -> False
+
+transExtend :: Extend -> Err [(Ident,G.MInclude)]
+transExtend x = case x of
+  Ext ids  -> mapM transIncludedExt ids
+  NoExt -> return []
+
+transOpens :: Opens -> Err [(Ident,Ident)]
+transOpens x = case x of
+  NoOpens  -> return []
+  OpenIn opens  -> mapM transOpen opens
+
+transOpen :: Open -> Err (Ident,Ident)
+transOpen x = case x of
+  OName id   -> transIdent id >>= \y -> return (y,y)
+  OQual id m -> liftM2 (,) (transIdent id) (transIdent m)
+
+transIncludedExt :: Included -> Err (Ident, G.MInclude)
+transIncludedExt x = case x of
+  IAll i       -> liftM2 (,) (transIdent i) (return G.MIAll)
+  ISome  i ids -> liftM2 (,) (transIdent i) (liftM G.MIOnly   $ mapM transIdent ids)
+  IMinus i ids -> liftM2 (,) (transIdent i) (liftM G.MIExcept $ mapM transIdent ids)
+
+transAbsDef :: TopDef -> Err (Either [(Ident,G.Judgement)] [(Ident,String)])
+transAbsDef x = case x of
+  DefCat catdefs -> liftM (Left . concat) $ mapM transCatDef catdefs
+  DefFun fundefs -> do
+    fundefs' <- mapM transFunDef fundefs
+    returnl [(fun, absFun typ) | (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]
+-}
+  DefFlag defs -> liftM (Right . concat) $ mapM transFlagDef defs
+  _ -> return $ Left [] ----  
+----  _ -> Bad $ "illegal definition in abstract module:" ++++ printTree x
+ where
+   -- to get data constructors as terms
+   funs t = case t of
+     G.Con f -> [f]
+     G.Q _ f -> [f]
+     G.QC _ f -> [f]
+     _ -> []
+
+returnl :: a -> Err (Either a b)
+returnl = return . Left
+
+transFlagDef :: Def -> Err [(Ident,String)]
+transFlagDef x = case x of
+  DDef f x -> do
+    fs <- mapM transName f
+    x' <- transExp x
+    v <- case x' of
+      G.K s -> return s
+      G.Vr (IC s) -> return s
+      G.EInt i -> return $ show i
+      _ -> fail $ "illegal flag value" +++ printTree x
+    return $ [(f',v) | f' <- fs]
+
+
+-- | Cat definitions can also return some fun defs
+--   if it is a list category definition
+transCatDef :: CatDef -> Err [(Ident, G.Judgement)]
+transCatDef x = case x of
+  SimpleCatDef id ddecls        -> liftM (:[]) $ cat id ddecls
+  ListCatDef id ddecls          -> listCat id ddecls 0
+  ListSizeCatDef id ddecls size -> listCat id ddecls size
+ where 
+   cat id ddecls = do
+		       i <- transIdent id
+		       cont <- liftM concat $ mapM transDDecl ddecls
+		       return (i, absCat cont)
+   listCat id ddecls size = do
+	 let li = mkListId id
+         li' <- transIdent $ li
+         baseId <- transIdent $ mkBaseId id
+         consId <- transIdent $ mkConsId id
+	 catd0@(c,ju) <- cat li ddecls
+         id' <- transIdent id
+	 let
+           cont0 = [] ---- cat context
+  	   catd = (c,ju) ----(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 = mkProd (cont ++ genericReplicate size cd) lc
+	   nilfund = (baseId, absFun niltyp) ---- (yes niltyp) (yes G.EData))
+	   constyp = mkProd (cont ++ [cd, M.mkDecl lc]) lc
+	   consfund = (consId, absFun constyp) ---- (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
+  FDecl ids typ  -> liftM2 (,) (mapM transName 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.Con $ transIdent id
+     DataQId id0 id  -> liftM2 G.QC (transIdent id0) (transIdent id)
+-}
+
+transResDef :: TopDef -> Err (Either [(Ident,G.Judgement)] [(Ident,String)])
+transResDef x = case x of
+  DefPar pardefs -> do
+    pardefs' <- mapM transParDef pardefs
+    returnl $ concatMap mkParamDefs pardefs'   
+
+  DefOper defs -> do
+    defs' <- liftM concat $ mapM getDefs defs
+    returnl $ concatMap mkOverload [(f, resOper pt pe) | (f,(pt,pe)) <- defs']
+
+  DefLintype defs -> do
+    defs' <- liftM concat $ mapM getDefs defs
+    returnl [(f, resOper pt pe) | (f,(pt,pe)) <- defs']
+
+  DefFlag defs -> liftM (Right . concat) $ mapM transFlagDef defs
+  _ -> Bad $ "illegal definition form in resource" +++ printTree x
+ where
+
+   mkParamDefs (p,pars) =
+     if null pars 
+       then [(p,addJType M.meta0 (emptyJudgement G.JParam))]  -- in an interface
+       else (p,resParam pars) : paramConstructors p pars
+
+   mkOverload (c,j) = case (G.jtype j, G.jdef j) of
+     (_,G.App keyw (G.R fs@(_:_:_))) | isOverloading keyw c fs -> 
+         [(c,resOverload [(ty,fu) | (_,(Just ty,fu)) <- fs])]
+
+     -- to enable separare type signature --- not type-checked
+     (G.App keyw (G.RecType fs@(_:_:_)),_) | isOverloading keyw c fs -> []
+     _ -> [(c,j)]
+   isOverloading (G.Vr keyw) c fs = 
+     prIdent keyw == "overload" &&       -- overload is a "soft keyword"
+     True ---- all (== GP.prt c) (map (GP.prt . fst) fs)
+
+transParDef :: ParDef -> Err (Ident, [(Ident,G.Context)])
+transParDef x = case x of
+  ParDefDir id params  -> liftM2 (,) (transIdent id) (mapM transParConstr params)
+  ParDefAbs id -> liftM2 (,) (transIdent id) (return [])
+
+transCncDef :: TopDef -> Err (Either [(Ident,G.Judgement)] [(Ident,String)])
+transCncDef x = case x of
+  DefLincat defs  -> do
+    defs' <- liftM concat $ mapM transPrintDef defs
+    returnl [(f, cncCat t) | (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, cncFun pe) | (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 :: Def -> Err [(Ident,G.Term)]
+transPrintDef x = case x of
+  DDef ids exp  -> do
+    (ids,e) <- liftM2 (,) (mapM transName ids) (transExp exp)
+    return $ [(i,e) | i <- ids]
+
+getDefsGen :: Def -> Err [(Ident, (G.Type, G.Term))]
+getDefsGen d = case d of
+  DDecl ids t -> do
+    ids' <- mapM transName ids
+    t'   <- transExp t
+    return [(i,(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')])))]
+ where
+   yes = id
+   nope = G.Meta 0
+
+-- | sometimes you need this special case, e.g. in linearization rules
+getDefs :: Def -> Err [(Ident, (G.Type, 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, (M.mkAbs xs e')))]
+  _ -> getDefsGen d
+ where
+   nope = G.Meta 0
+
+-- | 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" +++ show p'
+
+transExp :: Exp -> Err G.Term
+transExp x = case x of
+  EPIdent id    -> liftM G.Vr $ transIdent id
+  EConstr id    -> liftM G.Con $ transIdent id
+  ECons id      -> liftM G.Con $ 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 $ G.Meta 0
+  EEmpty        -> return G.Empty
+  -- [ C x_1 ... x_n ] becomes (ListC x_1 ... x_n)
+  EList i es    -> transExp $ foldl EApp (EPIdent (mkListId i)) (exps2list 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.FV $ 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 mkProd (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" +++ prIdent c +++ "without value"
+  ELetb defs exp -> transExp $ ELet defs exp
+  EWhere exp defs -> transExp $ ELet defs exp
+
+  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" +++ show (fst f) --- manifest fields ?!
+  tryR f = case f of
+    (lab,(mty, Just t)) -> return (M.ident2label lab,(mty,t))
+    _ -> Bad $ "illegal record field" +++ show (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 compatibiity and should be removed
+  LPIdent (PIdent (_,'v':ds)) | all isDigit ds -> return $ G.LVar $ readIntArg ds 
+  
+  LPIdent (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
+
+transPatt :: Patt -> Err G.Patt
+transPatt x = case x of
+  PW  -> return 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 LPIdent $ 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)
+
+
+
+transBind :: Bind -> Err Ident
+transBind x = case x of
+  BPIdent 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 (Ident,G.Context)
+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 = identC $ maybe topic id $ getOptVal opts useAbsName
+   resName = identC $ maybe ("Res" ++ lang) id $ getOptVal opts useResName
+   cncName = identC $ maybe lang id $ getOptVal opts useCncName
+
+   (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 (IC s) -> modif s
+     FSlash filename  -> '/' : trans filename
+     FDot filename  -> '.' : trans filename
+     FMinus filename  -> '-' : trans filename
+     FAddId (IC 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  :: PIdent -> PIdent
+mkListId = prefixId "List"
+mkConsId = prefixId "Cons"
+mkBaseId = prefixId "Base"
+
+prefixId :: String -> PIdent -> PIdent
+prefixId pref (PIdent (p,id)) = PIdent (p, pref ++ id)