diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/GF/Devel/Grammar/GF.cf | 332 | ||||
| -rw-r--r-- | src/GF/Devel/Grammar/SourceToGF.hs | 659 | ||||
| -rw-r--r-- | src/GF/Devel/Judgements.hs | 11 | ||||
| -rw-r--r-- | src/GF/Devel/Lookup.hs | 8 | ||||
| -rw-r--r-- | src/GF/Devel/Macros.hs | 17 | ||||
| -rw-r--r-- | src/GF/Devel/MkJudgements.hs | 35 | ||||
| -rw-r--r-- | src/GF/Devel/Modules.hs | 15 |
7 files changed, 1045 insertions, 32 deletions
diff --git a/src/GF/Devel/Grammar/GF.cf b/src/GF/Devel/Grammar/GF.cf new file mode 100644 index 000000000..0e2a6a0d8 --- /dev/null +++ b/src/GF/Devel/Grammar/GF.cf @@ -0,0 +1,332 @@ +-- 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 "{-" "-}" ; + + +-- identifiers + +position token PIdent (letter | '_') (letter | digit | '_' | '\'')* ; + +-- the top-level grammar + +Gr. Grammar ::= [ModDef] ; + +-- semicolon after module is permitted but not obligatory + +terminator ModDef "" ; +_. ModDef ::= ModDef ";" ; + +-- the individual modules + +MModule. ModDef ::= ComplMod ModType "=" ModBody ; + +MAbstract. ModType ::= "abstract" PIdent ; +MResource. ModType ::= "resource" PIdent ; +MGrammar. ModType ::= "grammar" PIdent ; +MInterface. ModType ::= "interface" PIdent ; +MConcrete. ModType ::= "concrete" PIdent "of" PIdent ; +MInstance. ModType ::= "instance" PIdent "of" PIdent ; +MTransfer. 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 ::= "(" PIdent ")" ; --% +OQual. Open ::= "(" PIdent "=" PIdent ")" ; + +CMCompl. ComplMod ::= ; +CMIncompl. ComplMod ::= "incomplete" ; + +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 + +PIdentName. 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 + +EPIdent. 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] "}" ; +EPre. Exp4 ::= "pre" "{" Exp ";" [Altern] "}" ; +EStrs. Exp4 ::= "strs" "{" [Exp] "}" ; + +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 + +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 + +LPIdent. 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 + +BPIdent. 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 ";" ; --% + +FPIdent. 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 ";" ; --% diff --git a/src/GF/Devel/Grammar/SourceToGF.hs b/src/GF/Devel/Grammar/SourceToGF.hs new file mode 100644 index 000000000..a7b8b7a09 --- /dev/null +++ b/src/GF/Devel/Grammar/SourceToGF.hs @@ -0,0 +1,659 @@ +---------------------------------------------------------------------- +-- | +-- 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.Grammar.SourceToGF ( + transGrammar, + transInclude, + transModDef, + transOldGrammar, + transExp, + newReservedWords + ) where + +import qualified GF.Devel.Terms as G +----import qualified GF.Grammar.PrGrammar as GP +import GF.Devel.Judgements +import GF.Devel.MkJudgements +import GF.Devel.Modules +import qualified GF.Devel.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.Grammar.AbsGF +import GF.Devel.Grammar.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) + +-- 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 GF +transGrammar x = case x of + Gr moddefs -> do + moddefs' <- mapM transModDef moddefs + let mos = Map.fromList moddefs' + return $ emptyGF {gfmodules = mos} + +transModDef :: ModDef -> Err (Ident,Module) +transModDef x = case x of + MModule compl mtyp body -> do + + ---- let mstat' = transComplMod compl + + (trDef, mtyp', id') <- case mtyp of + MAbstract id -> do + id' <- transIdent id + return (transAbsDef, MTAbstract, id') + MResource id -> mkModRes id MTGrammar body + MConcrete id open -> do + id' <- transIdent id + open' <- transIdent open + return (transCncDef, MTConcrete open', id') + MInterface id -> mkModRes id MTAbstract body + MInstance id open -> do + open' <- transIdent open + mkModRes id (MTConcrete open') body + + mkBody (trDef, mtyp', id') body + where + mkBody xx@(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' <- return $ Map.fromList [d | Left ds <- defs0, d <- ds] + flags' <- return Map.empty ---- [f | Right fs <- defs0, f <- fs] + return (id', Module mtyp' [] [] 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 + defs' <- return $ Map.fromList [d | Left ds <- defs0, d <- ds] + flags' <- return Map.empty ---- [f | Right fs <- defs0, f <- fs] + return (id', Module mtyp' [] [(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 + +transExtend :: Extend -> Err [(Ident,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, MInclude) +transIncludedExt x = case x of + IAll i -> liftM2 (,) (transIdent i) (return MIAll) + ISome i ids -> liftM2 (,) (transIdent i) (liftM MIOnly $ mapM transIdent ids) + IMinus i ids -> liftM2 (,) (transIdent i) (liftM MIExcept $ mapM transIdent ids) + +transAbsDef :: TopDef -> Err (Either [(Ident,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 $ mapM transFlagDef defs +-} + _ -> 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 :: FlagDef -> Err [(Ident,String)] +transFlagDef x = case x of + FlagDef f x -> do + f' <- transIdent f + x' <- transIdent f + return $ [(f',prIdent x')] + + +-- | Cat definitions can also return some fun defs +-- if it is a list category definition +transCatDef :: CatDef -> Err [(Ident, 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 = M.mkProd (cont ++ genericReplicate size cd) lc + nilfund = (baseId, absFun niltyp) ---- (yes niltyp) (yes G.EData)) + constyp = M.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 + 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.Con $ transIdent id + DataQId id0 id -> liftM2 G.QC (transIdent id0) (transIdent id) +-} + +transResDef :: TopDef -> Err (Either [(Ident,Judgement)] [(Ident,String)]) +transResDef x = case x of + DefPar pardefs -> do + pardefs' <- mapM transParDef pardefs + returnl $ [] + ---- [(p, resParam (if null pars + ---- then nope -- abstract param type + ---- else (yes (pars,Nothing)))) + ---- | (p,pars) <- pardefs'] + ---- ++ [(f, G.ResValue (yes (M.mkProd co (G.Con p),Nothing))) | + ---- (p,pars) <- pardefs', (f,co) <- pars] + + 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 $ 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 = + printTree keyw == "overload" && -- overload is a "soft keyword" + False ---- 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 []) + _ -> Bad $ "illegal definition in resource:" ++++ printTree x + +transCncDef :: TopDef -> Err (Either [(Ident,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 :: 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.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 M.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 $ exp' ---- 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 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 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) diff --git a/src/GF/Devel/Judgements.hs b/src/GF/Devel/Judgements.hs index 9d2afdc6a..7be565bf0 100644 --- a/src/GF/Devel/Judgements.hs +++ b/src/GF/Devel/Judgements.hs @@ -4,16 +4,17 @@ import GF.Devel.Terms import GF.Infra.Ident data Judgement = Judgement { - jform :: JudgementForm, -- cat fun oper param - jtype :: Type, -- context type type constructors - jdef :: Term, -- lindef def - values - jlin :: Term, -- lincat lin def - - jprintname :: Term -- printname printname - - + jform :: JudgementForm, -- cat fun lincat lin oper param + jtype :: Type, -- context type lincat - type constrs + jdef :: Term, -- lindef def lindef lin def values + jprintname :: Term -- - - prname prname - - } data JudgementForm = JCat | JFun + | JLincat + | JLin | JOper | JParam deriving Eq diff --git a/src/GF/Devel/Lookup.hs b/src/GF/Devel/Lookup.hs index 13e854480..741c65472 100644 --- a/src/GF/Devel/Lookup.hs +++ b/src/GF/Devel/Lookup.hs @@ -31,16 +31,16 @@ lookupFunType :: GF -> Ident -> Ident -> Err Term lookupFunType = lookupJField jtype lookupLin :: GF -> Ident -> Ident -> Err Term -lookupLin = lookupJField jlin +lookupLin = lookupJField jdef lookupLincat :: GF -> Ident -> Ident -> Err Term -lookupLincat = lookupJField jlin +lookupLincat = lookupJField jtype lookupOperType :: GF -> Ident -> Ident -> Err Term lookupOperType = lookupJField jtype lookupOperDef :: GF -> Ident -> Ident -> Err Term -lookupOperDef = lookupJField jlin +lookupOperDef = lookupJField jdef lookupParams :: GF -> Ident -> Ident -> Err [(Ident,Context)] lookupParams gf m c = do @@ -48,7 +48,7 @@ lookupParams gf m c = do return [(k,contextOfType t) | (k,t) <- contextOfType ty] lookupParamConstructor :: GF -> Ident -> Ident -> Err Type -lookupParamConstructor = lookupJField jlin +lookupParamConstructor = lookupJField jtype lookupParamValues :: GF -> Ident -> Ident -> Err [Term] lookupParamValues gf m c = do diff --git a/src/GF/Devel/Macros.hs b/src/GF/Devel/Macros.hs index 8e6e5d78f..afaf71c52 100644 --- a/src/GF/Devel/Macros.hs +++ b/src/GF/Devel/Macros.hs @@ -33,9 +33,24 @@ appForm tr = (f,reverse xs) where mkProd :: Context -> Type -> Type mkProd = flip (foldr (uncurry Prod)) +mkApp :: Term -> [Term] -> Term +mkApp = foldl App + +mkAbs :: [Ident] -> Term -> Term +mkAbs xs t = foldr Abs t xs + +mkDecl :: Term -> Decl +mkDecl typ = (wildIdent, typ) + typeType :: Type typeType = Sort "Type" +ident2label :: Ident -> Label +ident2label c = LIdent (prIdent c) + +----label2ident :: Label -> Ident +----label2ident = identC . prLabel + -- to apply a term operation to every term in a judgement, module, grammar termOpGF :: Monad m => (Term -> m Term) -> GF -> m GF @@ -56,12 +71,10 @@ termOpJudgement :: Monad m => (Term -> m Term) -> Judgement -> m Judgement termOpJudgement f j = do jtyp <- f (jtype j) jde <- f (jdef j) - jli <- f (jlin j) jpri <- f (jprintname j) return $ j { jtype = jtyp, jdef = jde, - jlin = jli, jprintname = jpri } diff --git a/src/GF/Devel/MkJudgements.hs b/src/GF/Devel/MkJudgements.hs index 070e2ad6f..dbe57b0f1 100644 --- a/src/GF/Devel/MkJudgements.hs +++ b/src/GF/Devel/MkJudgements.hs @@ -13,36 +13,45 @@ import Data.Map -- constructing judgements from parse tree emptyJudgement :: JudgementForm -> Judgement -emptyJudgement form = Judgement form meta meta meta meta where +emptyJudgement form = Judgement form meta meta meta where meta = Meta 0 +addJType :: Type -> Judgement -> Judgement +addJType tr ju = ju {jtype = tr} + +addJDef :: Term -> Judgement -> Judgement +addJDef tr ju = ju {jdef = tr} + +addJPrintname :: Term -> Judgement -> Judgement +addJPrintname tr ju = ju {jprintname = tr} + + absCat :: Context -> Judgement -absCat co = (emptyJudgement JCat) {jtype = mkProd co typeType} +absCat co = addJType (mkProd co typeType) (emptyJudgement JCat) absFun :: Type -> Judgement -absFun ty = (emptyJudgement JFun) {jtype = ty} +absFun ty = addJType ty (emptyJudgement JFun) cncCat :: Type -> Judgement -cncCat ty = (emptyJudgement JCat) {jlin = ty} +cncCat ty = addJType ty (emptyJudgement JLincat) cncFun :: Term -> Judgement -cncFun tr = (emptyJudgement JFun) {jlin = tr} +cncFun tr = addJDef tr (emptyJudgement JLin) resOperType :: Type -> Judgement -resOperType ty = (emptyJudgement JOper) {jtype = ty} +resOperType ty = addJType ty (emptyJudgement JOper) resOperDef :: Term -> Judgement -resOperDef tr = (emptyJudgement JOper) {jlin = tr} +resOperDef tr = addJDef tr (emptyJudgement JOper) resOper :: Type -> Term -> Judgement -resOper ty tr = (emptyJudgement JOper) {jtype = ty, jlin = tr} +resOper ty tr = addJDef tr (resOperType ty) -- param m.p = c g is encoded as p : (ci : gi -> EData) -> Type -- we use EData instead of m.p to make circularity check easier resParam :: Ident -> Ident -> [(Ident,Context)] -> Judgement -resParam m p cos = (emptyJudgement JParam) { - jtype = mkProd [(c,mkProd co EData) | (c,co) <- cos] typeType - } +resParam m p cos = addJType constrs (emptyJudgement JParam) where + constrs = mkProd [(c,mkProd co EData) | (c,co) <- cos] typeType -- to enable constructor type lookup: -- create an oper for each constructor m.p = c g, as c : g -> m.p = EData @@ -55,8 +64,8 @@ paramConstructors m p cs = unifyJudgement :: Judgement -> Judgement -> Err Judgement unifyJudgement old new = do testErr (jform old == jform new) "different judment forms" - [jty,jde,jli,jpri] <- mapM unifyField [jtype,jdef,jlin,jprintname] - return $ old{jtype = jty, jdef = jde, jlin = jli, jprintname = jpri} + [jty,jde,jpri] <- mapM unifyField [jtype,jdef,jprintname] + return $ old{jtype = jty, jdef = jde, jprintname = jpri} where unifyField field = unifyTerm (field old) (field new) unifyTerm oterm nterm = case (oterm,nterm) of diff --git a/src/GF/Devel/Modules.hs b/src/GF/Devel/Modules.hs index ff02af404..112cca221 100644 --- a/src/GF/Devel/Modules.hs +++ b/src/GF/Devel/Modules.hs @@ -22,25 +22,24 @@ emptyGF = GF Nothing [] empty empty data Module = Module { mtype :: ModuleType, - mof :: Ident, -- other for concrete, same for rest - minterfaces :: [(Ident,Ident)], -- non-empty for functors + minterfaces :: [(Ident,Ident)], -- non-empty for functors + minstances :: [((Ident,MInclude),[(Ident,Ident)])], -- non-empty for instant'ions mextends :: [(Ident,MInclude)], - minstances :: [(Ident,Ident)], -- non-empty for instantiations - mopens :: [(Ident,Ident)], -- used name, original name + mopens :: [(Ident,Ident)], -- used name, original name mflags :: Map Ident String, mjments :: Map Ident (Either Judgement Ident) -- def or indirection } emptyModule :: Ident -> Module -emptyModule m = Module MGrammar m [] [] [] [] empty empty +emptyModule m = Module MTGrammar [] [] [] [] empty empty listJudgements :: Module -> [(Ident,Either Judgement Ident)] listJudgements = assocs . mjments data ModuleType = - MAbstract - | MConcrete - | MGrammar + MTAbstract + | MTConcrete Ident + | MTGrammar data MInclude = MIAll |