forked from GitHub/gf-core
0325f7264d
This speeds up the compilation of PhrasebookFin.pgf by 12%, mosly by speeding up calls to lookupModule in calls from lookupParamValues, in calls from allParamValues. The invariant "modules are stored in dependency order" is no longer respected! But the type MGrammar is now abstract, making it easier to maintain this or other invariants in the future.
350 lines
11 KiB
Haskell
350 lines
11 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- Module : Modules
|
|
-- Maintainer : AR
|
|
-- Stability : (stable)
|
|
-- Portability : (portable)
|
|
--
|
|
-- > CVS $Date: 2005/11/09 15:14:30 $
|
|
-- > CVS $Author: aarne $
|
|
-- > CVS $Revision: 1.26 $
|
|
--
|
|
-- Datastructures and functions for modules, common to GF and GFC.
|
|
--
|
|
-- AR 29\/4\/2003
|
|
--
|
|
-- The same structure will be used in both source code and canonical.
|
|
-- The parameters tell what kind of data is involved.
|
|
-----------------------------------------------------------------------------
|
|
|
|
module GF.Infra.Modules (
|
|
MGrammar, ModInfo(..), ModuleType(..),
|
|
MInclude (..),
|
|
mGrammar,modules,
|
|
extends, isInherited,inheritAll,
|
|
updateMGrammar, updateModule, replaceJudgements, addFlag,
|
|
addOpenQualif, flagsModule, allFlags, mapModules,
|
|
OpenSpec(..),
|
|
ModuleStatus(..),
|
|
openedModule, depPathModule, allDepsModule, partOfGrammar,
|
|
allExtends, allExtendSpecs, allExtendsPlus, allExtensions,
|
|
searchPathModule,
|
|
-- addModule,
|
|
emptyMGrammar, emptyModInfo,
|
|
abstractOfConcrete, abstractModOfConcrete,
|
|
lookupModule, lookupModuleType, lookupInfo,
|
|
isModAbs, isModRes, isModCnc,
|
|
sameMType, isCompilableModule, isCompleteModule,
|
|
allAbstracts, greatestAbstract, allResources,
|
|
greatestResource, allConcretes, allConcreteModules
|
|
) where
|
|
|
|
import GF.Infra.Ident
|
|
import GF.Infra.Option
|
|
import GF.Data.Operations
|
|
|
|
import Data.List
|
|
import qualified Data.Map as Map
|
|
import Text.PrettyPrint
|
|
|
|
-- AR 29/4/2003
|
|
|
|
-- The same structure will be used in both source code and canonical.
|
|
-- The parameters tell what kind of data is involved.
|
|
-- No longer maintained invariant (TH 2011-08-30):
|
|
-- modules are stored in dependency order
|
|
|
|
--mGrammar = MGrammar
|
|
--newtype MGrammar a = MGrammar {modules :: [(Ident,ModInfo a)]}
|
|
|
|
newtype MGrammar a = MGrammar {moduleMap :: Map.Map Ident (ModInfo a)}
|
|
deriving Show
|
|
modules = Map.toList . moduleMap
|
|
mGrammar = MGrammar . Map.fromList
|
|
|
|
data ModInfo a = ModInfo {
|
|
mtype :: ModuleType,
|
|
mstatus :: ModuleStatus,
|
|
flags :: Options,
|
|
extend :: [(Ident,MInclude)],
|
|
mwith :: Maybe (Ident,MInclude,[(Ident,Ident)]),
|
|
opens :: [OpenSpec],
|
|
mexdeps :: [Ident],
|
|
jments :: Map.Map Ident a
|
|
}
|
|
deriving Show
|
|
|
|
-- | encoding the type of the module
|
|
data ModuleType =
|
|
MTAbstract
|
|
| MTResource
|
|
| MTConcrete Ident
|
|
-- ^ up to this, also used in GFO. Below, source only.
|
|
| MTInterface
|
|
| MTInstance (Ident,MInclude)
|
|
deriving (Eq,Show)
|
|
|
|
data MInclude = MIAll | MIOnly [Ident] | MIExcept [Ident]
|
|
deriving (Eq,Show)
|
|
|
|
extends :: ModInfo a -> [Ident]
|
|
extends = map fst . extend
|
|
|
|
isInherited :: MInclude -> Ident -> Bool
|
|
isInherited c i = case c of
|
|
MIAll -> True
|
|
MIOnly is -> elem i is
|
|
MIExcept is -> notElem i is
|
|
|
|
inheritAll :: Ident -> (Ident,MInclude)
|
|
inheritAll i = (i,MIAll)
|
|
|
|
-- destructive update
|
|
|
|
-- | dep order preserved since old cannot depend on new (not anymore TH 2011-08-30)
|
|
updateMGrammar :: MGrammar a -> MGrammar a -> MGrammar a
|
|
updateMGrammar old new = mGrammar $
|
|
[(i,m) | (i,m) <- os, notElem i (map fst ns)] ++ ns
|
|
where
|
|
os = modules old
|
|
ns = modules new
|
|
|
|
updateModule :: ModInfo t -> Ident -> t -> ModInfo t
|
|
updateModule (ModInfo mt ms fs me mw ops med js) i t = ModInfo mt ms fs me mw ops med (updateTree (i,t) js)
|
|
|
|
replaceJudgements :: ModInfo t -> Map.Map Ident t -> ModInfo t
|
|
replaceJudgements (ModInfo mt ms fs me mw ops med _) js = ModInfo mt ms fs me mw ops med js
|
|
|
|
addOpenQualif :: Ident -> Ident -> ModInfo t -> ModInfo t
|
|
addOpenQualif i j (ModInfo mt ms fs me mw ops med js) = ModInfo mt ms fs me mw (OQualif i j : ops) med js
|
|
|
|
addFlag :: Options -> ModInfo t -> ModInfo t
|
|
addFlag f mo = mo {flags = flags mo `addOptions` f}
|
|
|
|
flagsModule :: (Ident,ModInfo a) -> Options
|
|
flagsModule (_,mi) = flags mi
|
|
|
|
allFlags :: MGrammar a -> Options
|
|
allFlags gr = concatOptions [flags m | (_,m) <- modules gr]
|
|
|
|
mapModules :: (ModInfo a -> ModInfo a) -> MGrammar a -> MGrammar a
|
|
--mapModules f (MGrammar ms) = MGrammar (map (onSnd f) ms)
|
|
mapModules f (MGrammar ms) = MGrammar (fmap f ms)
|
|
|
|
data OpenSpec =
|
|
OSimple Ident
|
|
| OQualif Ident Ident
|
|
deriving (Eq,Show)
|
|
|
|
data ModuleStatus =
|
|
MSComplete
|
|
| MSIncomplete
|
|
deriving (Eq,Ord,Show)
|
|
|
|
openedModule :: OpenSpec -> Ident
|
|
openedModule o = case o of
|
|
OSimple m -> m
|
|
OQualif _ m -> m
|
|
|
|
-- | initial dependency list
|
|
depPathModule :: ModInfo a -> [OpenSpec]
|
|
depPathModule m = fors m ++ exts m ++ opens m
|
|
where
|
|
fors m =
|
|
case mtype m of
|
|
MTConcrete i -> [OSimple i]
|
|
MTInstance (i,_) -> [OSimple i]
|
|
_ -> []
|
|
exts m = map OSimple (extends m)
|
|
|
|
-- | all dependencies
|
|
allDepsModule :: MGrammar a -> ModInfo a -> [OpenSpec]
|
|
allDepsModule gr m = iterFix add os0 where
|
|
os0 = depPathModule m
|
|
add os = [m | o <- os, Just n <- [lookup (openedModule o) mods],
|
|
m <- depPathModule n]
|
|
mods = modules gr
|
|
|
|
-- | select just those modules that a given one depends on, including itself
|
|
partOfGrammar :: MGrammar a -> (Ident,ModInfo a) -> MGrammar a
|
|
partOfGrammar gr (i,m) = mGrammar [mo | mo@(j,_) <- mods, elem j modsFor]
|
|
where
|
|
mods = modules gr
|
|
modsFor = (i:) $ map openedModule $ allDepsModule gr m
|
|
|
|
-- | all modules that a module extends, directly or indirectly, without restricts
|
|
allExtends :: MGrammar a -> 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 :: MGrammar a -> Ident -> [(Ident,MInclude)]
|
|
allExtendSpecs gr i =
|
|
case lookupModule gr i of
|
|
Ok m -> case extend m of
|
|
[] -> [(i,MIAll)]
|
|
is -> (i,MIAll) : concatMap (allExtendSpecs gr . fst) is
|
|
_ -> []
|
|
|
|
-- | this plus that an instance extends its interface
|
|
allExtendsPlus :: MGrammar a -> Ident -> [Ident]
|
|
allExtendsPlus gr i =
|
|
case lookupModule gr i of
|
|
Ok m -> i : concatMap (allExtendsPlus gr) (exts m)
|
|
_ -> []
|
|
where
|
|
exts m = extends m ++ [j | MTInstance (j,_) <- [mtype m]]
|
|
|
|
-- | conversely: all modules that extend a given module, incl. instances of interface
|
|
allExtensions :: MGrammar a -> 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 :: ModInfo a -> [Ident]
|
|
searchPathModule m = [i | OSimple i <- depPathModule m]
|
|
|
|
{-
|
|
-- | a new module can safely be added to the end, since nothing old can depend on it
|
|
addModule :: MGrammar a -> Ident -> ModInfo a -> MGrammar a
|
|
--addModule gr name mi = MGrammar $ (modules gr ++ [(name,mi)])
|
|
addModule gr name mi = MGrammar $ Map.insert name mi (moduleMap gr)
|
|
-}
|
|
|
|
emptyMGrammar :: MGrammar a
|
|
emptyMGrammar = mGrammar []
|
|
|
|
emptyModInfo :: ModInfo a
|
|
emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] emptyBinTree
|
|
|
|
-- | we store the module type with the identifier
|
|
|
|
abstractOfConcrete :: MGrammar a -> Ident -> Err Ident
|
|
abstractOfConcrete gr c = do
|
|
n <- lookupModule gr c
|
|
case mtype n of
|
|
MTConcrete a -> return a
|
|
_ -> Bad $ render (text "expected concrete" <+> ppIdent c)
|
|
|
|
abstractModOfConcrete :: MGrammar a -> Ident -> Err (ModInfo a)
|
|
abstractModOfConcrete gr c = do
|
|
a <- abstractOfConcrete gr c
|
|
lookupModule gr a
|
|
|
|
|
|
-- the canonical file name
|
|
|
|
--- canonFileName s = prt s ++ ".gfc"
|
|
|
|
lookupModule :: MGrammar a -> Ident -> Err (ModInfo a)
|
|
--lookupModule gr m = case lookup m (modules gr) of
|
|
lookupModule gr m = case Map.lookup m (moduleMap gr) of
|
|
Just i -> return i
|
|
Nothing -> Bad $ render (text "unknown module" <+> ppIdent m <+> text "among" <+> hsep (map (ppIdent . fst) (modules gr)))
|
|
|
|
lookupModuleType :: MGrammar a -> Ident -> Err ModuleType
|
|
lookupModuleType gr m = do
|
|
mi <- lookupModule gr m
|
|
return $ mtype mi
|
|
|
|
lookupInfo :: ModInfo a -> Ident -> Err a
|
|
lookupInfo mo i = lookupTree showIdent i (jments mo)
|
|
|
|
isModAbs :: ModInfo a -> Bool
|
|
isModAbs m =
|
|
case mtype m of
|
|
MTAbstract -> True
|
|
_ -> False
|
|
|
|
isModRes :: ModInfo a -> Bool
|
|
isModRes m =
|
|
case mtype m of
|
|
MTResource -> True
|
|
MTInterface -> True ---
|
|
MTInstance _ -> True
|
|
_ -> False
|
|
|
|
isModCnc :: ModInfo a -> Bool
|
|
isModCnc m =
|
|
case mtype m of
|
|
MTConcrete _ -> True
|
|
_ -> False
|
|
|
|
sameMType :: ModuleType -> ModuleType -> Bool
|
|
sameMType m n =
|
|
case (n,m) of
|
|
(MTConcrete _, MTConcrete _) -> True
|
|
|
|
(MTInstance _, MTInstance _) -> True
|
|
(MTInstance _, MTResource) -> True
|
|
(MTInstance _, MTConcrete _) -> True
|
|
|
|
(MTInterface, MTInstance _) -> True
|
|
(MTInterface, MTResource) -> True -- for reuse
|
|
(MTInterface, MTAbstract) -> True -- for reuse
|
|
(MTInterface, MTConcrete _) -> True -- for reuse
|
|
|
|
(MTResource, MTInstance _) -> True
|
|
(MTResource, MTConcrete _) -> True -- for reuse
|
|
|
|
_ -> m == n
|
|
|
|
-- | don't generate code for interfaces and for incomplete modules
|
|
isCompilableModule :: ModInfo a -> Bool
|
|
isCompilableModule m =
|
|
case mtype m of
|
|
MTInterface -> False
|
|
_ -> mstatus m == MSComplete
|
|
|
|
-- | interface and "incomplete M" are not complete
|
|
isCompleteModule :: ModInfo a -> Bool
|
|
isCompleteModule m = mstatus m == MSComplete && mtype m /= MTInterface
|
|
|
|
|
|
-- | all abstract modules sorted from least to most dependent
|
|
allAbstracts :: MGrammar a -> [Ident]
|
|
allAbstracts gr =
|
|
case topoTest [(i,extends m) | (i,m) <- modules gr, mtype m == MTAbstract] of
|
|
Left is -> is
|
|
Right cycles -> error $ render (text "Cyclic abstract modules:" <+> vcat (map (hsep . map ppIdent) cycles))
|
|
|
|
-- | the last abstract in dependency order (head of list)
|
|
greatestAbstract :: MGrammar a -> Maybe Ident
|
|
greatestAbstract gr =
|
|
case allAbstracts gr of
|
|
[] -> Nothing
|
|
as -> return $ last as
|
|
|
|
-- | all resource modules
|
|
allResources :: MGrammar a -> [Ident]
|
|
allResources gr = [i | (i,m) <- modules gr, isModRes m || isModCnc m]
|
|
|
|
-- | the greatest resource in dependency order
|
|
greatestResource :: MGrammar a -> Maybe Ident
|
|
greatestResource gr =
|
|
case allResources gr of
|
|
[] -> Nothing
|
|
a -> return $ head a ---- why not last as in Abstract? works though AR 24/5/2008
|
|
|
|
-- | all concretes for a given abstract
|
|
allConcretes :: MGrammar a -> Ident -> [Ident]
|
|
allConcretes gr a =
|
|
[i | (i, m) <- modules gr, mtype m == MTConcrete a, isCompleteModule m]
|
|
|
|
-- | all concrete modules for any abstract
|
|
allConcreteModules :: MGrammar a -> [Ident]
|
|
allConcreteModules gr =
|
|
[i | (i, m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]
|