From e6dbd74dc9ee8a98dba32b2af1843e4ae69fc304 Mon Sep 17 00:00:00 2001 From: "kr.angelov" Date: Mon, 23 Sep 2013 09:18:27 +0000 Subject: [PATCH] GF.Grammar.Grammar.allExtends now returns a list of source modules instead of just the module names. This saves extra lookups later --- src/compiler/GF/Compile/GrammarToPGF.hs | 3 +- src/compiler/GF/Compile/Rename.hs | 8 ++--- src/compiler/GF/Grammar/Grammar.hs | 40 +++++-------------------- src/compiler/GF/Grammar/Lookup.hs | 39 +++++++++++------------- 4 files changed, 30 insertions(+), 60 deletions(-) diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index b1a2c5d33..41f6f8ff0 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -65,8 +65,7 @@ mkCanon2pgf opts gr am = do [(0,i2i f) | ((m,f),AbsFun (Just (L _ ty)) _ _ (Just True),_) <- adefs, snd (GM.valCat ty) == cat] mkConcr cm = do - let cflags = concatOptions [mflags mo | (i,mo) <- modules gr, isModCnc mo, - Just r <- [lookup i (allExtendSpecs gr cm)]] + let cflags = concatOptions [mflags mo | (i,mo) <- modules gr, isModCnc mo] (seqs,cdefs) <- addMissingPMCFGs Map.empty diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs index 6031ab938..e81582bc9 100644 --- a/src/compiler/GF/Compile/Rename.hs +++ b/src/compiler/GF/Compile/Rename.hs @@ -125,10 +125,10 @@ tree2status o = case o of buildStatus :: SourceGrammar -> SourceModule -> Check Status buildStatus gr mo@(m,mi) = checkIn (ppLocation (msrc mi) NoLoc <> colon) $ do - let gr1 = prependModule gr mo - ops = [OSimple e | e <- allExtends gr1 m] ++ mopens mi - mods <- checkErr $ mapM (lookupModule gr1 . openedModule) ops - let sts = map modInfo2status $ zip ops mods + let gr1 = prependModule gr mo + exts = [(OSimple m,mi) | (m,mi) <- allExtends gr1 m] + ops <- checkErr $ mapM (\o -> lookupModule gr1 (openedModule o) >>= \mi -> return (o,mi)) (mopens mi) + let sts = map modInfo2status (exts++ops) return (if isModCnc mi then (emptyBinTree, reverse sts) -- the module itself does not define any names else (self2status m mi,reverse sts)) -- so the empty ident is not needed diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs index 2efec220b..8b2e174ee 100644 --- a/src/compiler/GF/Grammar/Grammar.hs +++ b/src/compiler/GF/Grammar/Grammar.hs @@ -21,7 +21,7 @@ module GF.Grammar.Grammar ( MInclude (..), OpenSpec(..), extends, isInherited, inheritAll, openedModule, depPathModule, allDepsModule, partOfGrammar, - allExtends, allExtendSpecs, allExtendsPlus, allExtensions, + allExtends, allExtendsPlus, searchPathModule, lookupModule, @@ -82,7 +82,7 @@ import Control.Monad.Identity data SourceGrammar = MGrammar { moduleMap :: Map.Map Ident SourceModInfo, - modules :: [(Ident,SourceModInfo)] + modules :: [SourceModule] } data SourceModInfo = ModInfo { @@ -165,25 +165,14 @@ partOfGrammar gr (i,m) = mGrammar [mo | mo@(j,_) <- mods, elem j modsFor] mods = modules gr modsFor = (i:) $ map openedModule $ allDepsModule gr m --- | all modules that a module extends, directly or indirectly, without restricts -allExtends :: SourceGrammar -> Ident -> [Ident] -allExtends gr i = - case lookupModule gr i of - Ok m -> case extends m of - [] -> [i] - is -> i : concatMap (allExtends gr) is - _ -> [] - -- | all modules that a module extends, directly or indirectly, with restricts -allExtendSpecs :: SourceGrammar -> Ident -> [(Ident,MInclude)] -allExtendSpecs gr i = - case lookupModule gr i of - Ok m -> case mextend m of - [] -> [(i,MIAll)] - is -> (i,MIAll) : concatMap (allExtendSpecs gr . fst) is - _ -> [] +allExtends :: SourceGrammar -> Ident -> [SourceModule] +allExtends gr m = + case lookupModule gr m of + Ok mi -> (m,mi) : concatMap (allExtends gr . fst) (mextend mi) + _ -> [] --- | this plus that an instance extends its interface +-- | the same as 'allExtends' plus that an instance extends its interface allExtendsPlus :: SourceGrammar -> Ident -> [Ident] allExtendsPlus gr i = case lookupModule gr i of @@ -192,19 +181,6 @@ allExtendsPlus gr i = where exts m = extends m ++ [j | MTInstance (j,_) <- [mtype m]] --- | conversely: all modules that extend a given module, incl. instances of interface -allExtensions :: SourceGrammar -> Ident -> [Ident] -allExtensions gr i = - case lookupModule gr i of - Ok m -> let es = exts i in es ++ concatMap (allExtensions gr) es - _ -> [] - where - exts i = [j | (j,m) <- mods, elem i (extends m) || isInstanceOf i m] - mods = modules gr - isInstanceOf i m = case mtype m of - MTInstance (j,_) -> j == i - _ -> False - -- | initial search path: the nonqualified dependencies searchPathModule :: SourceModInfo -> [Ident] searchPathModule m = [i | OSimple i <- depPathModule m] diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs index 6b9b4d869..b4f1de2b0 100644 --- a/src/compiler/GF/Grammar/Lookup.hs +++ b/src/compiler/GF/Grammar/Lookup.hs @@ -40,6 +40,7 @@ import GF.Grammar.Predef import GF.Grammar.Lockfield import Data.List (sortBy) +import Data.Maybe (maybe) import Control.Monad import Text.PrettyPrint import qualified Data.Map as Map @@ -193,30 +194,24 @@ lookupCatContext gr m c = do allOpers :: SourceGrammar -> [((Ident,Ident),Type,Location)] allOpers gr = - [((mo,op),typ,loc) | - (mo,minc) <- reachable, - Ok minfo <- [lookupModule gr mo], - (op,info) <- Map.toList $ jments minfo, - isInherited minc op, + [((m,op),typ,loc) | + (m,mi) <- maybe [] (allExtends gr) (greatestResource gr), + (op,info) <- Map.toList (jments mi), L loc typ <- typesIn info - ] - where - typesIn info = case info of - AbsFun (Just ltyp) _ _ _ -> [ltyp] - ResOper (Just ltyp) _ -> [ltyp] - ResValue ltyp -> [ltyp] - ResOverload _ tytrs -> [ltyp | (ltyp,_) <- tytrs] - CncFun (Just (i,ctx,typ)) _ _ _ -> - [L NoLoc (mkProdSimple ctx (lock' i typ))] - _ -> [] + ] + where + typesIn info = case info of + AbsFun (Just ltyp) _ _ _ -> [ltyp] + ResOper (Just ltyp) _ -> [ltyp] + ResValue ltyp -> [ltyp] + ResOverload _ tytrs -> [ltyp | (ltyp,_) <- tytrs] + CncFun (Just (i,ctx,typ)) _ _ _ -> + [L NoLoc (mkProdSimple ctx (lock' i typ))] + _ -> [] - lock' i typ = case lock i typ of - Ok t -> t - _ -> typ - - reachable = case greatestResource gr of - Just r -> allExtendSpecs gr r - _ -> [] + lock' i typ = case lock i typ of + Ok t -> t + _ -> typ --- not for dependent types allOpersTo :: SourceGrammar -> Type -> [((Ident,Ident),Type,Location)]