diff options
23 files changed, 403 insertions, 427 deletions
diff --git a/src/GF/Devel/CheckM.hs b/src/GF/Devel/CheckM.hs index 7f85b0570..d26dbc07c 100644 --- a/src/GF/Devel/CheckM.hs +++ b/src/GF/Devel/CheckM.hs @@ -20,8 +20,7 @@ module GF.Devel.CheckM (Check, ) where import GF.Data.Operations -import GF.Devel.Grammar.Modules -import GF.Devel.Grammar.Terms +import GF.Devel.Grammar.Grammar import GF.Infra.Ident import GF.Devel.Grammar.PrGF diff --git a/src/GF/Devel/Compile/CheckGrammar.hs b/src/GF/Devel/Compile/CheckGrammar.hs index d2f7af8fd..55f499d38 100644 --- a/src/GF/Devel/Compile/CheckGrammar.hs +++ b/src/GF/Devel/Compile/CheckGrammar.hs @@ -29,10 +29,8 @@ module GF.Devel.Compile.CheckGrammar ( topoSortOpers ) where -import GF.Devel.Grammar.Modules -import GF.Devel.Grammar.Judgements -import GF.Devel.Grammar.Terms -import GF.Devel.Grammar.MkJudgements +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct import GF.Devel.Grammar.Macros import GF.Devel.Grammar.PrGF import GF.Devel.Grammar.Lookup @@ -187,19 +185,19 @@ checkCompleteGrammar abs cnc = do js' <- foldM checkOne js fs return $ cnc {mjments = js'} where - checkOne js i@(c, Left ju) = case jform ju of + checkOne js i@(c, ju) = case jform ju of JFun -> case Map.lookup c js of - Just (Left j) | jform j == JLin -> return js + Just j | jform j == JLin -> return js _ -> do checkWarn $ "WARNING: no linearization of" +++ prt c return js JCat -> case Map.lookup c js of - Just (Left j) | jform ju == JLincat -> return js + Just j | jform ju == JLincat -> return js _ -> do ---- TODO: other things to check here checkWarn $ "Warning: no linearization type for" +++ prt c ++ ", inserting default {s : Str}" - return $ Map.insert c (Left (cncCat defLinType)) js + return $ Map.insert c (cncCat defLinType) js _ -> return js checkResInfo :: GF -> Ident -> Ident -> Judgement -> Check Judgement @@ -1055,12 +1053,12 @@ linTypeOfType cnc m typ = do -- | dependency check, detecting circularities and returning topo-sorted list -allOperDependencies :: Ident -> Map.Map Ident JEntry -> [(Ident,[Ident])] +allOperDependencies :: Ident -> Map.Map Ident Judgement -> [(Ident,[Ident])] allOperDependencies m = allDependencies (==m) -allDependencies :: (Ident -> Bool) -> Map.Map Ident JEntry -> [(Ident,[Ident])] +allDependencies :: (Ident -> Bool) -> Map.Map Ident Judgement -> [(Ident,[Ident])] allDependencies ism b = - [(f, nub (concatMap opersIn (pts i))) | (f,Left i) <- Map.assocs b] + [(f, nub (concatMap opersIn (pts i))) | (f,i) <- Map.assocs b] where opersIn t = case t of Q n c | ism n -> [c] diff --git a/src/GF/Devel/Compile/Compile.hs b/src/GF/Devel/Compile/Compile.hs index 729a40df7..df3ea079e 100644 --- a/src/GF/Devel/Compile/Compile.hs +++ b/src/GF/Devel/Compile/Compile.hs @@ -9,9 +9,8 @@ import GF.Devel.Compile.Refresh import GF.Devel.Compile.Optimize import GF.Devel.Compile.Factorize -import GF.Devel.Grammar.Terms -import GF.Devel.Grammar.Modules -import GF.Devel.Grammar.Judgements +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct import GF.Infra.Ident import GF.Devel.Grammar.PrGF ----import GF.Devel.Grammar.Lookup diff --git a/src/GF/Devel/Compile/Extend.hs b/src/GF/Devel/Compile/Extend.hs index 8dbbe0382..2f1aae65b 100644 --- a/src/GF/Devel/Compile/Extend.hs +++ b/src/GF/Devel/Compile/Extend.hs @@ -20,9 +20,8 @@ module GF.Devel.Compile.Extend ( extendModule ) where -import GF.Devel.Grammar.Modules -import GF.Devel.Grammar.Judgements -import GF.Devel.Grammar.MkJudgements +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct import GF.Devel.Grammar.PrGF import GF.Devel.Grammar.Lookup import GF.Devel.Grammar.Macros @@ -71,28 +70,23 @@ extendModule gf nmo0 = do -- and the process is interrupted if unification fails. -- If the extended module is incomplete, its judgements are just copied. extendMod :: Bool -> Ident -> (Ident -> Bool) -> Ident -> - MapJudgement -> MapJudgement -> Err MapJudgement + Map Ident Judgement -> Map Ident Judgement -> + Err (Map Ident Judgement) extendMod isCompl name cond base old new = foldM try new $ assocs old where try t i@(c,_) | not (cond c) = return t try t i@(c,_) = errIn ("constant" +++ prt c) $ tryInsert (extendAnyInfo isCompl name base) indirIf t i indirIf = if isCompl then indirInfo name else id -indirInfo :: Ident -> JEntry -> JEntry -indirInfo n info = Right $ case info of - Right (k,b) -> (k,b) -- original link is passed - Left j -> (n,isConstructor j) +indirInfo :: Ident -> Judgement -> Judgement +indirInfo n ju = case jform ju of + JLink -> ju -- original link is passed + _ -> linkInherited (isConstructor ju) n -extendAnyInfo :: Bool -> Ident -> Ident -> JEntry -> JEntry -> Err JEntry +extendAnyInfo :: Bool -> Ident -> Ident -> Judgement -> Judgement -> Err Judgement extendAnyInfo isc n o i j = - errIn ("building extension for" +++ prt n +++ "in" +++ prt o) $ case (i,j) of - (Left j1,Left j2) -> liftM Left $ unifyJudgement j1 j2 - (Right (m1,b1), Right (m2,b2)) -> do - testErr (b1 == b2) "inconsistent indirection status" - testErr (m1 == m2) $ - "different sources of inheritance:" +++ show m1 +++ show m2 - return i - _ -> Bad $ "cannot unify information in" ++++ prJEntry i ++++ prJEntry j + errIn ("building extension for" +++ prt n +++ "in" +++ prt o) $ + unifyJudgement i j tryInsert :: Ord a => (b -> b -> Err b) -> (b -> b) -> Map a b -> (a,b) -> Err (Map a b) diff --git a/src/GF/Devel/Compile/Factorize.hs b/src/GF/Devel/Compile/Factorize.hs index 4f732181e..cb9a684ff 100644 --- a/src/GF/Devel/Compile/Factorize.hs +++ b/src/GF/Devel/Compile/Factorize.hs @@ -24,10 +24,8 @@ module GF.Devel.Compile.Factorize ( shareModule ) where -import GF.Devel.Grammar.Modules -import GF.Devel.Grammar.Judgements -import GF.Devel.Grammar.Terms -import GF.Devel.Grammar.MkJudgements +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct import GF.Devel.Grammar.PrGF (prt) import qualified GF.Devel.Grammar.Macros as C @@ -53,10 +51,11 @@ unshareModule :: GF -> SourceModule -> SourceModule unshareModule gr = processModule (const (unoptim gr)) processModule :: (Ident -> Term -> Term) -> SourceModule -> SourceModule -processModule opt (i,m) = (i, C.judgementOpModule (shareInfo (opt i)) m) +processModule opt (i,mo) = + (i, mo {mjments = Map.map (shareInfo (opt i)) (mjments mo)}) -shareInfo :: (Term -> Term) -> Judgement -> Err Judgement -shareInfo opt ju = return $ ju {jdef = opt (jdef ju)} +shareInfo :: (Term -> Term) -> Judgement -> Judgement +shareInfo opt ju = ju {jdef = opt (jdef ju)} -- the function putting together optimizations optim :: Ident -> Term -> Term @@ -169,34 +168,25 @@ cse is possible in the grammar. It is used by the flag pg -printer=subs. -} subexpModule :: SourceModule -> SourceModule -subexpModule (mo,m) = errVal (mo,m) $ case m of - M.ModMod (M.Module mt st fs me ops js) -> do - (tree,_) <- appSTM (getSubtermsMod mo (tree2list js)) (Map.empty,0) - js2 <- liftM buildTree $ addSubexpConsts mo tree $ tree2list js - return (mo,M.ModMod (M.Module mt st fs me ops js2)) - _ -> return (mo,m) +subexpModule (m,mo) = errVal (m,mo) $ case mtype mo of + MTAbstract -> return (m,mo) + _ -> do + let js = listJudgements mo + (tree,_) <- appSTM (getSubtermsMod m js) (Map.empty,0) + js2 <- addSubexpConsts m tree js + return (m, mo{mjments = Map.fromList js2}) unsubexpModule :: SourceModule -> SourceModule -unsubexpModule mo@(i,m) = case m of - M.ModMod (M.Module mt st fs me ops js) | hasSub ljs -> - (i, M.ModMod (M.Module mt st fs me ops - (rebuild (map unparInfo ljs)))) - where ljs = tree2list js - _ -> (i,m) +unsubexpModule (m,mo) = (m, mo{mjments = rebuild (mjments mo)}) where - -- perform this iff the module has opers - hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs] - unparInfo (c,info) = case info of - CncFun xs (Yes t) m -> [(c, CncFun xs (Yes (unparTerm t)) m)] - ResOper (Yes (EInt 8)) _ -> [] -- subexp-generated opers - ResOper pty (Yes t) -> [(c, ResOper pty (Yes (unparTerm t)))] - _ -> [(c,info)] + unparInfo (c, ju) = case jtype ju of + EInt 8 -> [] -- subexp-generated opers + _ -> [(c, ju {jdef = unparTerm (jdef ju)})] unparTerm t = case t of - Q m c@(IC ('A':'\'':'\'':_)) -> --- name convention of subexp opers - errVal t $ liftM unparTerm $ lookupResDef gr m c + Q _ c@(IC ('_':'A':_)) -> --- name convention of subexp opers + maybe t (unparTerm . jdef) $ Map.lookup c (mjments mo) _ -> C.composSafeOp unparTerm t - gr = M.MGrammar [mo] - rebuild = buildTree . concat + rebuild = Map.fromList . concat . map unparInfo . Map.assocs -- implementation @@ -204,20 +194,20 @@ type TermList = Map Term (Int,Int) -- number of occs, id type TermM a = STM (TermList,Int) a addSubexpConsts :: - Ident -> Map Term (Int,Int) -> [(Ident,Info)] -> Err [(Ident,Info)] + Ident -> Map Term (Int,Int) -> [(Ident,Judgement)] -> Err [(Ident,Judgement)] addSubexpConsts mo tree lins = do let opers = [oper id trm | (trm,(_,id)) <- list] mapM mkOne $ opers ++ lins where - mkOne (f,def) = (f,def {jdef = recomp f (jdef def)}) + mkOne (f, def) = return (f, def {jdef = recomp f (jdef def)}) recomp f t = case Map.lookup t tree of - Just (_,id) | ident id /= f -> return $ Q mo (ident id) - _ -> C.composOp (recomp f) t + Just (_,id) | ident id /= f -> Q mo (ident id) + _ -> C.composSafeOp (recomp f) t list = Map.toList tree - oper id trm = (ident id, resOper (EInt 8) (Yes trm)) + oper id trm = (ident id, resOper (EInt 8) trm) --- impossible type encoding generated opers getSubtermsMod :: Ident -> [(Ident,Judgement)] -> TermM (Map Term (Int,Int)) @@ -226,7 +216,7 @@ getSubtermsMod mo js = do (tree0,_) <- readSTM return $ Map.filter (\ (nu,_) -> nu > 1) tree0 where - getInfo get fi@(f,i) = do + getInfo get fi@(_,i) = do get (jdef i) return $ fi diff --git a/src/GF/Devel/Grammar/GF.cf b/src/GF/Devel/Compile/GF.cf index 6fc9307b2..6fc9307b2 100644 --- a/src/GF/Devel/Grammar/GF.cf +++ b/src/GF/Devel/Compile/GF.cf diff --git a/src/GF/Devel/Compile/GetGrammar.hs b/src/GF/Devel/Compile/GetGrammar.hs index 493a35de2..b90bd912c 100644 --- a/src/GF/Devel/Compile/GetGrammar.hs +++ b/src/GF/Devel/Compile/GetGrammar.hs @@ -15,17 +15,18 @@ module GF.Devel.Compile.GetGrammar where import GF.Devel.UseIO -import GF.Devel.Grammar.Modules +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct ----import GF.Devel.PrGrammar -import GF.Devel.Grammar.SourceToGF +import GF.Devel.Compile.SourceToGF ---- import Macros ---- import Rename --- import Custom -import GF.Devel.Grammar.ParGF -import qualified GF.Devel.Grammar.LexGF as L +import GF.Devel.Compile.ParGF +import qualified GF.Devel.Compile.LexGF as L import GF.Data.Operations -import qualified GF.Devel.Grammar.ErrM as E ---- +import qualified GF.Devel.Compile.ErrM as E ---- import GF.Infra.Option ---- import GF.Devel.ReadFiles ---- diff --git a/src/GF/Devel/Compile/Optimize.hs b/src/GF/Devel/Compile/Optimize.hs index 311715b19..9ed2860fd 100644 --- a/src/GF/Devel/Compile/Optimize.hs +++ b/src/GF/Devel/Compile/Optimize.hs @@ -14,9 +14,8 @@ module GF.Devel.Compile.Optimize (optimizeModule) where -import GF.Devel.Grammar.Modules ---import GF.Devel.Grammar.Judgements ---import GF.Devel.Grammar.Terms +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct import GF.Devel.Grammar.Macros --import GF.Devel.Grammar.PrGF import GF.Devel.Grammar.Compute diff --git a/src/GF/Devel/Compile/Refresh.hs b/src/GF/Devel/Compile/Refresh.hs index 2a7054851..d512ed39f 100644 --- a/src/GF/Devel/Compile/Refresh.hs +++ b/src/GF/Devel/Compile/Refresh.hs @@ -18,8 +18,8 @@ module GF.Devel.Compile.Refresh ( refreshTermN ) where -import GF.Devel.Grammar.Modules -import GF.Devel.Grammar.Terms +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct import GF.Devel.Grammar.Macros import GF.Infra.Ident diff --git a/src/GF/Devel/Compile/Rename.hs b/src/GF/Devel/Compile/Rename.hs index df2867f08..fe4f8175f 100644 --- a/src/GF/Devel/Compile/Rename.hs +++ b/src/GF/Devel/Compile/Rename.hs @@ -24,9 +24,8 @@ module GF.Devel.Compile.Rename ( renameModule ) where -import GF.Devel.Grammar.Modules -import GF.Devel.Grammar.Judgements -import GF.Devel.Grammar.Terms +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct import GF.Devel.Grammar.Macros import GF.Devel.Grammar.PrGF import GF.Infra.Ident @@ -61,7 +60,8 @@ renameIdentTerm :: RenameEnv -> Term -> Err Term renameIdentTerm (gf, (name,mo)) trm = case trm of Vr i -> looks i Con i -> looks i - Q m i -> getQualified m >>= look i + Q m i -> getQualified m >>= look i + QC m i -> getQualified m >>= look i _ -> return trm where looks i = do @@ -76,10 +76,10 @@ renameIdentTerm (gf, (name,mo)) trm = case trm of (return t) ---- _ -> fail $ unwords $ "identifier" : prt i : "ambiguous:" : map prt ts look i m = do - entry <- lookupIdent gf m i - return $ case entry of - Left j -> if isConstructor j then QC m i else Q m i - Right (n,b) -> if b then QC n i else Q n i + ju <- lookupIdent gf m i + return $ case jform ju of + JLink -> if isConstructor ju then QC (jlink ju) i else Q (jlink ju) i + _ -> if isConstructor ju then QC m i else Q m i pool = nub $ name : maybe name id (interfaceName mo) : IC "Predef" : diff --git a/src/GF/Devel/Grammar/SourceToGF.hs b/src/GF/Devel/Compile/SourceToGF.hs index e09b9964c..103982147 100644 --- a/src/GF/Devel/Grammar/SourceToGF.hs +++ b/src/GF/Devel/Compile/SourceToGF.hs @@ -12,7 +12,7 @@ -- based on the skeleton Haskell module generated by the BNF converter ----------------------------------------------------------------------------- -module GF.Devel.Grammar.SourceToGF ( +module GF.Devel.Compile.SourceToGF ( transGrammar, transModDef, transExp, @@ -21,18 +21,15 @@ module GF.Devel.Grammar.SourceToGF ( newReservedWords ) where -import qualified GF.Devel.Grammar.Terms as G -----import qualified GF.Grammar.PrGrammar as GP -import GF.Devel.Grammar.Judgements -import GF.Devel.Grammar.MkJudgements -import GF.Devel.Grammar.Modules +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.Grammar.AbsGF -import GF.Devel.Grammar.PrintGF (printTree) +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 @@ -64,14 +61,14 @@ transName n = case n of PIdentName i -> transIdent i ListName i -> transIdent (mkListId i) -transGrammar :: Grammar -> Err GF +transGrammar :: Grammar -> Err G.GF transGrammar x = case x of Gr moddefs -> do moddefs' <- mapM transModDef moddefs let mos = Map.fromList moddefs' - return $ emptyGF {gfmodules = mos} + return $ emptyGF {G.gfmodules = mos} -transModDef :: ModDef -> Err (Ident,Module) +transModDef :: ModDef -> Err (Ident, G.Module) transModDef x = case x of MModule compl mtyp body -> do @@ -80,17 +77,17 @@ transModDef x = case x of (trDef, mtyp', id') <- case mtyp of MAbstract id -> do id' <- transIdent id - return (transAbsDef, MTAbstract, id') - MGrammar id -> mkModRes id MTGrammar body - MResource id -> mkModRes id MTGrammar body + 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, MTConcrete open', id') - MInterface id -> mkModRes id MTInterface body + return (transCncDef, G.MTConcrete open', id') + MInterface id -> mkModRes id G.MTInterface body MInstance id open -> do open' <- transIdent open - mkModRes id (MTInstance open') body + mkModRes id (G.MTInstance open') body mkBody (isCompl, trDef, mtyp', id') body where @@ -102,9 +99,9 @@ transModDef x = case x of opens' <- transOpens opens defs0 <- mapM trDef $ getTopDefs defs let defs' = Map.fromListWith unifyJudgements - [(i,Left d) | Left ds <- defs0, (i,d) <- ds] + [(i,d) | Left ds <- defs0, (i,d) <- ds] let flags' = Map.fromList [f | Right fs <- defs0, f <- fs] - return (id', Module mtyp' isc [] [] extends' opens' flags' defs') + 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 @@ -116,9 +113,9 @@ transModDef x = case x of opens' <- transOpens opens defs0 <- mapM trDef $ getTopDefs defs let defs' = Map.fromListWith unifyJudgements - [(i,Left d) | Left ds <- defs0, (i,d) <- ds] + [(i,d) | Left ds <- defs0, (i,d) <- ds] let flags' = Map.fromList [f | Right fs <- defs0, f <- fs] - return (id', Module mtyp' isc [] [(m',insts')] extends' opens' flags' defs') + return (id', G.Module mtyp' isc [] [(m',insts')] extends' opens' flags' defs') _ -> fail "deprecated module form" @@ -135,7 +132,7 @@ transComplMod x = case x of CMCompl -> True CMIncompl -> False -transExtend :: Extend -> Err [(Ident,MInclude)] +transExtend :: Extend -> Err [(Ident,G.MInclude)] transExtend x = case x of Ext ids -> mapM transIncludedExt ids NoExt -> return [] @@ -150,13 +147,13 @@ 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 :: Included -> Err (Ident, G.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) + 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,Judgement)] [(Ident,String)]) +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 @@ -209,7 +206,7 @@ transFlagDef x = case x of -- | Cat definitions can also return some fun defs -- if it is a list category definition -transCatDef :: CatDef -> Err [(Ident, Judgement)] +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 @@ -233,9 +230,9 @@ transCatDef x = case x of 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 + niltyp = mkProd (cont ++ genericReplicate size cd) lc nilfund = (baseId, absFun niltyp) ---- (yes niltyp) (yes G.EData)) - constyp = M.mkProd (cont ++ [cd, M.mkDecl lc]) lc + 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 @@ -254,7 +251,7 @@ transDataDef x = case x of DataQId id0 id -> liftM2 G.QC (transIdent id0) (transIdent id) -} -transResDef :: TopDef -> Err (Either [(Ident,Judgement)] [(Ident,String)]) +transResDef :: TopDef -> Err (Either [(Ident,G.Judgement)] [(Ident,String)]) transResDef x = case x of DefPar pardefs -> do pardefs' <- mapM transParDef pardefs @@ -274,10 +271,10 @@ transResDef x = case x of mkParamDefs (p,pars) = if null pars - then [(p,addJType M.meta0 (emptyJudgement JParam))] -- in an interface + then [(p,addJType M.meta0 (emptyJudgement G.JParam))] -- in an interface else (p,resParam pars) : paramConstructors p pars - mkOverload (c,j) = case (jtype j, jdef j) of + 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])] @@ -293,7 +290,7 @@ 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,Judgement)] [(Ident,String)]) +transCncDef :: TopDef -> Err (Either [(Ident,G.Judgement)] [(Ident,String)]) transCncDef x = case x of DefLincat defs -> do defs' <- liftM concat $ mapM transPrintDef defs @@ -425,7 +422,7 @@ transExp x = case x of 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) + 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) @@ -506,7 +503,7 @@ transSort x = case x of transPatt :: Patt -> Err G.Patt transPatt x = case x of - PW -> return G.wildPatt + 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 []) diff --git a/src/GF/Devel/Grammar/AppPredefined.hs b/src/GF/Devel/Grammar/AppPredefined.hs index 41abf4886..c8d2988fd 100644 --- a/src/GF/Devel/Grammar/AppPredefined.hs +++ b/src/GF/Devel/Grammar/AppPredefined.hs @@ -18,7 +18,8 @@ module GF.Devel.Grammar.AppPredefined ( appPredefined ) where -import GF.Devel.Grammar.Terms +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct import GF.Devel.Grammar.Macros import GF.Devel.Grammar.PrGF (prt,prt_,prtBad) import GF.Infra.Ident diff --git a/src/GF/Devel/Grammar/Compute.hs b/src/GF/Devel/Grammar/Compute.hs index 82417ec99..449cd3b90 100644 --- a/src/GF/Devel/Grammar/Compute.hs +++ b/src/GF/Devel/Grammar/Compute.hs @@ -18,8 +18,8 @@ module GF.Devel.Grammar.Compute ( computeTermRec ) where -import GF.Devel.Grammar.Modules -import GF.Devel.Grammar.Terms +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct import GF.Devel.Grammar.Macros import GF.Devel.Grammar.Lookup import GF.Devel.Grammar.PrGF diff --git a/src/GF/Devel/Grammar/Construct.hs b/src/GF/Devel/Grammar/Construct.hs new file mode 100644 index 000000000..92e88b577 --- /dev/null +++ b/src/GF/Devel/Grammar/Construct.hs @@ -0,0 +1,216 @@ +module GF.Devel.Grammar.Construct where + +import GF.Devel.Grammar.Grammar +import GF.Infra.Ident + +import GF.Data.Operations + +import Control.Monad +import Data.Map +import Debug.Trace (trace) + +------------------ +-- abstractions on Grammar +------------------ + +-- abstractions on GF + +emptyGF :: GF +emptyGF = GF Nothing [] empty empty + +type SourceModule = (Ident,Module) + +listModules :: GF -> [SourceModule] +listModules = assocs.gfmodules + +addModule :: Ident -> Module -> GF -> GF +addModule c m gf = gf {gfmodules = insert c m (gfmodules gf)} + +-- abstractions on Module + +emptyModule :: Ident -> Module +emptyModule m = Module MTGrammar True [] [] [] [] empty empty + +isCompleteModule :: Module -> Bool +isCompleteModule = miscomplete + +isInterface :: Module -> Bool +isInterface m = case mtype m of + MTInterface -> True + MTAbstract -> True + _ -> False + +interfaceName :: Module -> Maybe Ident +interfaceName mo = case mtype mo of + MTInstance i -> return i + MTConcrete i -> return i + _ -> Nothing + +listJudgements :: Module -> [(Ident,Judgement)] +listJudgements = assocs . mjments + +isInherited :: MInclude -> Ident -> Bool +isInherited mi i = case mi of + MIExcept is -> notElem i is + MIOnly is -> elem i is + _ -> True + +-- abstractions on Judgement + +isConstructor :: Judgement -> Bool +isConstructor j = jdef j == EData + +isLink :: Judgement -> Bool +isLink j = jform j == JLink + +-- constructing judgements from parse tree + +emptyJudgement :: JudgementForm -> Judgement +emptyJudgement form = Judgement form meta meta meta (identC "#NOLINK") 0 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} + +linkInherited :: Bool -> Ident -> Judgement +linkInherited can mo = (emptyJudgement JLink){ + jlink = mo, + jdef = if can then EData else Meta 0 + } + +absCat :: Context -> Judgement +absCat co = addJType (mkProd co typeType) (emptyJudgement JCat) + +absFun :: Type -> Judgement +absFun ty = addJType ty (emptyJudgement JFun) + +cncCat :: Type -> Judgement +cncCat ty = addJType ty (emptyJudgement JLincat) + +cncFun :: Term -> Judgement +cncFun tr = addJDef tr (emptyJudgement JLin) + +resOperType :: Type -> Judgement +resOperType ty = addJType ty (emptyJudgement JOper) + +resOperDef :: Term -> Judgement +resOperDef tr = addJDef tr (emptyJudgement JOper) + +resOper :: Type -> Term -> Judgement +resOper ty tr = addJDef tr (resOperType ty) + +resOverload :: [(Type,Term)] -> Judgement +resOverload tts = resOperDef (Overload tts) + +-- param p = ci gi is encoded as p : ((ci : gi) -> EData) -> Type +-- we use EData instead of p to make circularity check easier +resParam :: [(Ident,Context)] -> Judgement +resParam 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 p = c g, as c : g -> p = EData +paramConstructors :: Ident -> [(Ident,Context)] -> [(Ident,Judgement)] +paramConstructors p cs = + [(c,resOper (mkProd co (Con p)) EData) | (c,co) <- cs] + +-- unifying contents of judgements + +---- used in SourceToGF; make error-free and informative +unifyJudgements j k = case unifyJudgement j k of + Ok l -> l + Bad s -> error s + +unifyJudgement :: Judgement -> Judgement -> Err Judgement +unifyJudgement old new = do + testErr (jform old == jform new) "different judment forms" + [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 + (Meta _,t) -> return t + (t,Meta _) -> return t + _ -> do + if (nterm /= oterm) + then (trace (unwords ["illegal update of",show oterm,"to",show nterm]) + (return ())) + else return () ---- to recover from spurious qualification conflicts +---- testErr (nterm == oterm) +---- (unwords ["illegal update of",prt oterm,"to",prt nterm]) + return nterm + + + +-- abstractions on Term + +type Cat = QIdent +type Fun = QIdent +type QIdent = (Ident,Ident) + +-- | branches à la Alfa +newtype Branch = Branch (Con,([Ident],Term)) deriving (Eq, Ord,Show,Read) +type Con = Ident --- + +varLabel :: Int -> Label +varLabel = LVar + +wildPatt :: Patt +wildPatt = PW + +type Trm = Term + +mkProd :: Context -> Type -> Type +mkProd = flip (foldr (uncurry Prod)) + +-- type constants + +typeType :: Type +typeType = Sort "Type" + +typePType :: Type +typePType = Sort "PType" + +typeStr :: Type +typeStr = Sort "Str" + +typeTok :: Type ---- deprecated +typeTok = Sort "Tok" + +cPredef :: Ident +cPredef = identC "Predef" + +cPredefAbs :: Ident +cPredefAbs = identC "PredefAbs" + +typeString, typeFloat, typeInt :: Term +typeInts :: Integer -> Term + +typeString = constPredefRes "String" +typeInt = constPredefRes "Int" +typeFloat = constPredefRes "Float" +typeInts i = App (constPredefRes "Ints") (EInt i) + +isTypeInts :: Term -> Bool +isTypeInts ty = case ty of + App c _ -> c == constPredefRes "Ints" + _ -> False + +cnPredef = constPredefRes + +constPredefRes :: String -> Term +constPredefRes s = Q (IC "Predef") (identC s) + +isPredefConstant :: Term -> Bool +isPredefConstant t = case t of + Q (IC "Predef") _ -> True + Q (IC "PredefAbs") _ -> True + _ -> False + + diff --git a/src/GF/Devel/Grammar/GFtoSource.hs b/src/GF/Devel/Grammar/GFtoSource.hs index 2866c0446..9ac65469a 100644 --- a/src/GF/Devel/Grammar/GFtoSource.hs +++ b/src/GF/Devel/Grammar/GFtoSource.hs @@ -9,11 +9,10 @@ module GF.Devel.Grammar.GFtoSource ( ) where -import GF.Devel.Grammar.Modules -import GF.Devel.Grammar.Judgements -import GF.Devel.Grammar.Terms +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct import GF.Devel.Grammar.Macros (contextOfType) -import qualified GF.Devel.Grammar.AbsGF as P +import qualified GF.Devel.Compile.AbsGF as P import GF.Infra.Ident import GF.Data.Operations @@ -43,7 +42,7 @@ trModule (i,mo) = P.MModule compl typ body where body = P.MBody (trExtends (mextends mo)) (mkOpens (map trOpen (mopens mo))) - (concatMap trAnyDef [(c,j) | (c,Left j) <- listJudgements mo] ++ + (concatMap trAnyDef [(c,j) | (c,j) <- listJudgements mo] ++ map trFlag (Map.assocs (mflags mo))) trExtends :: [(Ident,MInclude)] -> P.Extend @@ -89,6 +88,7 @@ trAnyDef (i,ju) = let JLin -> [P.DefLin [trDef i (Meta 0) (jdef ju)]] ---- ++ [P.DefPrintFun [P.DDef [mkName i] (trt pr)] | Yes pr <- [ppr]] + JLink -> [] {- ---- encoding of AnyInd without changing syntax. AR 20/9/2007 AnyInd s b -> diff --git a/src/GF/Devel/Grammar/Terms.hs b/src/GF/Devel/Grammar/Grammar.hs index d57e7c160..eb6d2218a 100644 --- a/src/GF/Devel/Grammar/Terms.hs +++ b/src/GF/Devel/Grammar/Grammar.hs @@ -1,14 +1,69 @@ -module GF.Devel.Grammar.Terms where +module GF.Devel.Grammar.Grammar where import GF.Infra.Ident import GF.Data.Operations -type Type = Term -type Cat = QIdent -type Fun = QIdent +import Data.Map + + +------------------ +-- definitions -- +------------------ + +data GF = GF { + gfabsname :: Maybe Ident , + gfcncnames :: [Ident] , + gflags :: Map Ident String , -- value of a global flag + gfmodules :: Map Ident Module + } + +data Module = Module { + mtype :: ModuleType, + miscomplete :: Bool, + minterfaces :: [(Ident,Ident)], -- non-empty for functors + minstances :: [((Ident,MInclude),[(Ident,Ident)])], -- non-empty for instant'ions + mextends :: [(Ident,MInclude)], + mopens :: [(Ident,Ident)], -- used name, original name + mflags :: Map Ident String, + mjments :: Map Ident Judgement + } + +data ModuleType = + MTAbstract + | MTConcrete Ident + | MTInterface + | MTInstance Ident + | MTGrammar + deriving Eq + +data MInclude = + MIAll + | MIExcept [Ident] + | MIOnly [Ident] + +type Indirection = (Ident,Bool) -- module of origin, whether canonical + +data Judgement = Judgement { + 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 - - + jlink :: Ident, + jposition :: Int + } + +data JudgementForm = + JCat + | JFun + | JLincat + | JLin + | JOper + | JParam + | JLink + deriving Eq -type QIdent = (Ident,Ident) +type Type = Term data Term = Vr Ident -- ^ variable @@ -104,15 +159,3 @@ type Assign = (Label, (Maybe Type, Term)) type Case = (Patt, Term) type LocalDef = (Ident, (Maybe Type, Term)) - --- | branches à la Alfa -newtype Branch = Branch (Con,([Ident],Term)) deriving (Eq, Ord,Show,Read) -type Con = Ident --- - -varLabel :: Int -> Label -varLabel = LVar - -wildPatt :: Patt -wildPatt = PW - -type Trm = Term diff --git a/src/GF/Devel/Grammar/Judgements.hs b/src/GF/Devel/Grammar/Judgements.hs deleted file mode 100644 index b09576e50..000000000 --- a/src/GF/Devel/Grammar/Judgements.hs +++ /dev/null @@ -1,21 +0,0 @@ -module GF.Devel.Grammar.Judgements where - -import GF.Devel.Grammar.Terms -import GF.Infra.Ident - -data Judgement = Judgement { - 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/Grammar/Lookup.hs b/src/GF/Devel/Grammar/Lookup.hs index 756345f2e..ac55aec62 100644 --- a/src/GF/Devel/Grammar/Lookup.hs +++ b/src/GF/Devel/Grammar/Lookup.hs @@ -1,9 +1,8 @@ module GF.Devel.Grammar.Lookup where -import GF.Devel.Grammar.Modules -import GF.Devel.Grammar.Judgements +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct import GF.Devel.Grammar.Macros -import GF.Devel.Grammar.Terms import GF.Devel.Grammar.PrGF import GF.Infra.Ident @@ -103,15 +102,19 @@ lookupModule :: GF -> Ident -> Err Module lookupModule gf m = do maybe (raiseIdent "module not found:" m) return $ mlookup m (gfmodules gf) -lookupIdent :: GF -> Ident -> Ident -> Err JEntry +-- this finds the immediate definition, which can be a link +lookupIdent :: GF -> Ident -> Ident -> Err Judgement lookupIdent gf m c = do mo <- lookupModule gf m - maybe (raiseIdent "constant not found" c) return $ mlookup c (mjments mo) + maybe (raiseIdent "constant not found:" c) return $ mlookup c (mjments mo) +-- this follows the link lookupJudgement :: GF -> Ident -> Ident -> Err Judgement lookupJudgement gf m c = do - eji <- lookupIdent gf m c - either return (\n -> lookupJudgement gf (fst n) c) eji + ju <- lookupIdent gf m c + case jform ju of + JLink -> lookupJudgement gf (jlink ju) c + _ -> return ju mlookup = Data.Map.lookup diff --git a/src/GF/Devel/Grammar/Macros.hs b/src/GF/Devel/Grammar/Macros.hs index 0eebfda16..a9059578c 100644 --- a/src/GF/Devel/Grammar/Macros.hs +++ b/src/GF/Devel/Grammar/Macros.hs @@ -1,8 +1,7 @@ module GF.Devel.Grammar.Macros where -import GF.Devel.Grammar.Terms -import GF.Devel.Grammar.Judgements -import GF.Devel.Grammar.Modules +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct import GF.Infra.Ident import GF.Data.Str @@ -81,9 +80,6 @@ typeSkeleton typ = do -- construct types and terms -mkProd :: Context -> Type -> Type -mkProd = flip (foldr (uncurry Prod)) - mkFunType :: [Type] -> Type -> Type mkFunType tt t = mkProd ([(wildIdent, ty) | ty <- tt]) t -- nondep prod @@ -156,49 +152,6 @@ plusRecord t1 t2 = zipAssign :: [Label] -> [Term] -> [Assign] zipAssign ls ts = [assign l t | (l,t) <- zip ls ts] --- type constants - -typeType :: Type -typeType = Sort "Type" - -typePType :: Type -typePType = Sort "PType" - -typeStr :: Type -typeStr = Sort "Str" - -typeTok :: Type ---- deprecated -typeTok = Sort "Tok" - -cPredef :: Ident -cPredef = identC "Predef" - -cPredefAbs :: Ident -cPredefAbs = identC "PredefAbs" - -typeString, typeFloat, typeInt :: Term -typeInts :: Integer -> Term - -typeString = constPredefRes "String" -typeInt = constPredefRes "Int" -typeFloat = constPredefRes "Float" -typeInts i = App (constPredefRes "Ints") (EInt i) - -isTypeInts :: Term -> Bool -isTypeInts ty = case ty of - App c _ -> c == constPredefRes "Ints" - _ -> False - -cnPredef = constPredefRes - -constPredefRes :: String -> Term -constPredefRes s = Q (IC "Predef") (identC s) - -isPredefConstant :: Term -> Bool -isPredefConstant t = case t of - Q (IC "Predef") _ -> True - Q (IC "PredefAbs") _ -> True - _ -> False defLinType :: Type defLinType = RecType [(LIdent "s", typeStr)] @@ -230,10 +183,8 @@ termOpModule f = judgementOpModule fj where judgementOpModule :: Monad m => (Judgement -> m Judgement) -> Module -> m Module judgementOpModule f m = do - mjs <- mapMapM fj (mjments m) + mjs <- mapMapM f (mjments m) return m {mjments = mjs} - where - fj = either (liftM Left . f) (return . Right) entryOpModule :: Monad m => (Ident -> Judgement -> m Judgement) -> Module -> m Module @@ -241,8 +192,7 @@ entryOpModule f m = do mjs <- liftM Map.fromAscList $ mapm $ Map.assocs $ mjments m return $ m {mjments = mjs} where - mapm = mapM (\ (i,j) -> liftM ((,) i) (fe i j)) - fe i j = either (liftM Left . f i) (return . Right) j + mapm = mapM (\ (i,j) -> liftM ((,) i) (f i j)) termOpJudgement :: Monad m => (Term -> m Term) -> Judgement -> m Judgement termOpJudgement f j = do diff --git a/src/GF/Devel/Grammar/MkJudgements.hs b/src/GF/Devel/Grammar/MkJudgements.hs deleted file mode 100644 index 01b5f97d7..000000000 --- a/src/GF/Devel/Grammar/MkJudgements.hs +++ /dev/null @@ -1,93 +0,0 @@ -module GF.Devel.Grammar.MkJudgements where - -import GF.Devel.Grammar.Macros -import GF.Devel.Grammar.Judgements -import GF.Devel.Grammar.Terms -import GF.Devel.Grammar.PrGF -import GF.Infra.Ident - -import GF.Data.Operations - -import Control.Monad -import Data.Map - -import Debug.Trace (trace) ---- - --- constructing judgements from parse tree - -emptyJudgement :: JudgementForm -> Judgement -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 = addJType (mkProd co typeType) (emptyJudgement JCat) - -absFun :: Type -> Judgement -absFun ty = addJType ty (emptyJudgement JFun) - -cncCat :: Type -> Judgement -cncCat ty = addJType ty (emptyJudgement JLincat) - -cncFun :: Term -> Judgement -cncFun tr = addJDef tr (emptyJudgement JLin) - -resOperType :: Type -> Judgement -resOperType ty = addJType ty (emptyJudgement JOper) - -resOperDef :: Term -> Judgement -resOperDef tr = addJDef tr (emptyJudgement JOper) - -resOper :: Type -> Term -> Judgement -resOper ty tr = addJDef tr (resOperType ty) - -resOverload :: [(Type,Term)] -> Judgement -resOverload tts = resOperDef (Overload tts) - --- param p = ci gi is encoded as p : ((ci : gi) -> EData) -> Type --- we use EData instead of p to make circularity check easier -resParam :: [(Ident,Context)] -> Judgement -resParam 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 p = c g, as c : g -> p = EData -paramConstructors :: Ident -> [(Ident,Context)] -> [(Ident,Judgement)] -paramConstructors p cs = - [(c,resOper (mkProd co (Con p)) EData) | (c,co) <- cs] - --- unifying contents of judgements - ----- used in SourceToGF; make error-free and informative -unifyJudgements (Left j) (Left k) = Left $ case unifyJudgement j k of - Ok l -> l - Bad s -> error s - -unifyJudgement :: Judgement -> Judgement -> Err Judgement -unifyJudgement old new = do - testErr (jform old == jform new) "different judment forms" - [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 - (Meta _,t) -> return t - (t,Meta _) -> return t - _ -> do - if (nterm /= oterm) - then (trace (unwords ["illegal update of",prt oterm,"to",prt nterm]) - (return ())) - else return () ---- to recover from spurious qualification conflicts ----- testErr (nterm == oterm) ----- (unwords ["illegal update of",prt oterm,"to",prt nterm]) - return nterm - diff --git a/src/GF/Devel/Grammar/Modules.hs b/src/GF/Devel/Grammar/Modules.hs deleted file mode 100644 index 43458ce90..000000000 --- a/src/GF/Devel/Grammar/Modules.hs +++ /dev/null @@ -1,96 +0,0 @@ -module GF.Devel.Grammar.Modules where - -import GF.Devel.Grammar.Judgements -import GF.Devel.Grammar.Terms -import GF.Infra.Ident - -import GF.Data.Operations - -import Control.Monad -import Data.Map - - -data GF = GF { - gfabsname :: Maybe Ident , - gfcncnames :: [Ident] , - gflags :: Map Ident String , -- value of a global flag - gfmodules :: Map Ident Module - } - -emptyGF :: GF -emptyGF = GF Nothing [] empty empty - -type SourceModule = (Ident,Module) - -listModules :: GF -> [SourceModule] -listModules = assocs.gfmodules - -addModule :: Ident -> Module -> GF -> GF -addModule c m gf = gf {gfmodules = insert c m (gfmodules gf)} - -data Module = Module { - mtype :: ModuleType, - miscomplete :: Bool, - minterfaces :: [(Ident,Ident)], -- non-empty for functors - minstances :: [((Ident,MInclude),[(Ident,Ident)])], -- non-empty for instant'ions - mextends :: [(Ident,MInclude)], - mopens :: [(Ident,Ident)], -- used name, original name - mflags :: Map Ident String, - mjments :: MapJudgement - } - -emptyModule :: Ident -> Module -emptyModule m = Module MTGrammar True [] [] [] [] empty empty - -type MapJudgement = Map Ident JEntry -- def or indirection - -isCompleteModule :: Module -> Bool -isCompleteModule = miscomplete ---- Prelude.null . minterfaces - -isInterface :: Module -> Bool -isInterface m = case mtype m of - MTInterface -> True - MTAbstract -> True - _ -> False - -interfaceName :: Module -> Maybe Ident -interfaceName mo = case mtype mo of - MTInstance i -> return i - MTConcrete i -> return i - _ -> Nothing - -listJudgements :: Module -> [(Ident,JEntry)] -listJudgements = assocs . mjments - -type JEntry = Either Judgement Indirection - -data ModuleType = - MTAbstract - | MTConcrete Ident - | MTInterface - | MTInstance Ident - | MTGrammar - deriving Eq - -data MInclude = - MIAll - | MIExcept [Ident] - | MIOnly [Ident] - -type Indirection = (Ident,Bool) -- module of origin, whether canonical - -isConstructorEntry :: Either Judgement Indirection -> Bool -isConstructorEntry ji = case ji of - Left j -> isConstructor j - Right i -> snd i - -isConstructor :: Judgement -> Bool -isConstructor j = jdef j == EData - -isInherited :: MInclude -> Ident -> Bool -isInherited mi i = case mi of - MIExcept is -> notElem i is - MIOnly is -> elem i is - _ -> True - - diff --git a/src/GF/Devel/Grammar/PatternMatch.hs b/src/GF/Devel/Grammar/PatternMatch.hs index 193694a27..076aaa25a 100644 --- a/src/GF/Devel/Grammar/PatternMatch.hs +++ b/src/GF/Devel/Grammar/PatternMatch.hs @@ -18,7 +18,7 @@ module GF.Devel.Grammar.PatternMatch (matchPattern, ) where -import GF.Devel.Grammar.Terms +import GF.Devel.Grammar.Grammar import GF.Devel.Grammar.Macros import GF.Devel.Grammar.PrGF import GF.Infra.Ident diff --git a/src/GF/Devel/Grammar/PrGF.hs b/src/GF/Devel/Grammar/PrGF.hs index 83ab4c7f1..09df91efc 100644 --- a/src/GF/Devel/Grammar/PrGF.hs +++ b/src/GF/Devel/Grammar/PrGF.hs @@ -21,11 +21,10 @@ module GF.Devel.Grammar.PrGF where -import qualified GF.Devel.Grammar.PrintGF as P +import qualified GF.Devel.Compile.PrintGF as P import GF.Devel.Grammar.GFtoSource -import GF.Devel.Grammar.Modules -import GF.Devel.Grammar.Judgements -import GF.Devel.Grammar.Terms +import GF.Devel.Grammar.Grammar +import GF.Devel.Grammar.Construct ----import GF.Grammar.Values ----import GF.Infra.Option @@ -68,9 +67,6 @@ prGF = cprintTree . trGrammar prModule :: SourceModule -> String prModule = cprintTree . trModule -prJEntry :: JEntry -> String -prJEntry = either prt show - instance Print Judgement where prt j = cprintTree $ trAnyDef (wildIdent, j) ---- prt_ = prExp |