path: root/src/GF/Source/SourceToGrammar.hs

----------------------------------------------------------------------
-- |
-- 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 = prIdent 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.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 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))