GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-01 23:32:51 -06:00
Code Issues Packages Projects Releases Wiki Activity

refactor the GF.Grammar.Grammar syntax. The obsolete constructions are removed

Browse Source
This commit is contained in:
krasimir
2009-01-19 13:23:03 +00:00
parent fa7ab84471
commit d95ca4a103
25 changed files with 325 additions and 542 deletions
Download Patch File Download Diff File Expand all files Collapse all files

253
src/GF/Infra/Modules.hs
View File

@@ -19,23 +19,22 @@
-----------------------------------------------------------------------------
module GF.Infra.Modules (
MGrammar(..), ModInfo(..), Module(..), ModuleType(..),
MReuseType(..), MInclude (..),
MGrammar(..), ModInfo(..), ModuleType(..),
MInclude (..),
extends, isInherited,inheritAll,
updateMGrammar, updateModule, replaceJudgements, addFlag,
addOpenQualif, flagsModule, allFlags, mapModules, mapModules',
MainGrammar(..), MainConcreteSpec(..), OpenSpec(..), OpenQualif(..),
oSimple, oQualif,
addOpenQualif, flagsModule, allFlags, mapModules,
OpenSpec(..),
ModuleStatus(..),
openedModule, allOpens, depPathModule, allDepsModule, partOfGrammar,
allExtends, allExtendSpecs, allExtendsPlus, allExtensions,
searchPathModule, addModule,
emptyMGrammar, emptyModInfo, emptyModule,
emptyMGrammar, emptyModInfo,
IdentM(..),
typeOfModule, abstractOfConcrete, abstractModOfConcrete,
lookupModule, lookupModuleType, lookupModMod, lookupInfo,
abstractOfConcrete, abstractModOfConcrete,
lookupModule, lookupModuleType, lookupInfo,
lookupPosition, showPosition,
allModMod, isModAbs, isModRes, isModCnc, isModTrans,
isModAbs, isModRes, isModCnc, isModTrans,
sameMType, isCompilableModule, isCompleteModule,
allAbstracts, greatestAbstract, allResources,
greatestResource, allConcretes, allConcreteModules
@@ -54,27 +53,22 @@ import Data.List
-- The parameters tell what kind of data is involved.
-- Invariant: modules are stored in dependency order
data MGrammar i a = MGrammar {modules :: [(i,ModInfo i a)]}
newtype MGrammar i a = MGrammar {modules :: [(i,ModInfo i a)]}
deriving Show
data ModInfo i a =
ModMainGrammar (MainGrammar i)
| ModMod (Module i a)
| ModWith (Module i a) (i,MInclude i) [OpenSpec i]
deriving Show
data Module i a = Module {
data ModInfo i a = ModInfo {
mtype :: ModuleType i ,
mstatus :: ModuleStatus ,
flags :: Options,
extend :: [(i,MInclude i)],
mwith :: Maybe (i,MInclude i,[OpenSpec i]),
opens :: [OpenSpec i] ,
jments :: BinTree i a ,
positions :: BinTree i (String,(Int,Int)) -- file, first line, last line
}
--- deriving Show
instance Show (Module i a) where
show _ = "cannot show Module with FiniteMap"
instance Show (ModInfo i a) where
show _ = "cannot show ModInfo with FiniteMap"
-- | encoding the type of the module
data ModuleType i =
@@ -85,17 +79,12 @@ data ModuleType i =
-- ^ up to this, also used in GFC. Below, source only.
| MTInterface
| MTInstance i
| MTReuse (MReuseType i)
| MTUnion (ModuleType i) [(i,[i])] -- ^ not meant to be recursive
deriving (Eq,Ord,Show)
data MReuseType i = MRInterface i | MRInstance i i | MRResource i
deriving (Eq,Ord,Show)
data MInclude i = MIAll | MIOnly [i] | MIExcept [i]
deriving (Eq,Ord,Show)
extends :: Module i a -> [i]
extends :: ModInfo i a -> [i]
extends = map fst . extend
isInherited :: Eq i => MInclude i -> i -> Bool
@@ -117,68 +106,32 @@ updateMGrammar old new = MGrammar $
os = modules old
ns = modules new
updateModule :: Ord i => Module i t -> i -> t -> Module i t
updateModule (Module mt ms fs me ops js ps) i t =
Module mt ms fs me ops (updateTree (i,t) js) ps
updateModule :: Ord i => ModInfo i t -> i -> t -> ModInfo i t
updateModule (ModInfo mt ms fs me mw ops js ps) i t = ModInfo mt ms fs me mw ops (updateTree (i,t) js) ps
replaceJudgements :: Module i t -> BinTree i t -> Module i t
replaceJudgements (Module mt ms fs me ops _ ps) js = Module mt ms fs me ops js ps
replaceJudgements :: ModInfo i t -> BinTree i t -> ModInfo i t
replaceJudgements (ModInfo mt ms fs me mw ops _ ps) js = ModInfo mt ms fs me mw ops js ps
addOpenQualif :: i -> i -> Module i t -> Module i t
addOpenQualif i j (Module mt ms fs me ops js ps) =
Module mt ms fs me (oQualif i j : ops) js ps
addOpenQualif :: i -> i -> ModInfo i t -> ModInfo i t
addOpenQualif i j (ModInfo mt ms fs me mw ops js ps) = ModInfo mt ms fs me mw (OQualif i j : ops) js ps
addFlag :: Options -> Module i t -> Module i t
addFlag :: Options -> ModInfo i t -> ModInfo i t
addFlag f mo = mo {flags = flags mo `addOptions` f}
flagsModule :: (i,ModInfo i a) -> Options
flagsModule (_,mi) = case mi of
ModMod m -> flags m
_ -> noOptions
flagsModule (_,mi) = flags mi
allFlags :: MGrammar i a -> Options
allFlags gr = concatOptions $ map flags $ [m | (_, ModMod m) <- modules gr]
allFlags gr = concatOptions [flags m | (_,m) <- modules gr]
mapModules :: (Module i a -> Module i a)
-> MGrammar i a -> MGrammar i a
mapModules f = MGrammar . map (onSnd (mapModules' f)) . modules
mapModules' :: (Module i a -> Module i a)
-> ModInfo i a -> ModInfo i a
mapModules' f (ModMod m) = ModMod (f m)
mapModules' _ m = m
data MainGrammar i = MainGrammar {
mainAbstract :: i ,
mainConcretes :: [MainConcreteSpec i]
}
deriving Show
data MainConcreteSpec i = MainConcreteSpec {
concretePrintname :: i ,
concreteName :: i ,
transferIn :: Maybe (OpenSpec i) , -- ^ if there is an in-transfer
transferOut :: Maybe (OpenSpec i) -- ^ if there is an out-transfer
}
deriving Show
mapModules :: (ModInfo i a -> ModInfo i a) -> MGrammar i a -> MGrammar i a
mapModules f (MGrammar ms) = MGrammar (map (onSnd f) ms)
data OpenSpec i =
OSimple OpenQualif i
| OQualif OpenQualif i i
OSimple i
| OQualif i i
deriving (Eq,Ord,Show)
data OpenQualif =
OQNormal
| OQInterface
| OQIncomplete
deriving (Eq,Ord,Show)
oSimple :: i -> OpenSpec i
oSimple = OSimple OQNormal
oQualif :: i -> i -> OpenSpec i
oQualif = OQualif OQNormal
data ModuleStatus =
MSComplete
| MSIncomplete
@@ -186,29 +139,31 @@ data ModuleStatus =
openedModule :: OpenSpec i -> i
openedModule o = case o of
OSimple _ m -> m
OQualif _ _ m -> m
OSimple m -> m
OQualif _ m -> m
allOpens :: Module i a -> [OpenSpec i]
allOpens :: ModInfo i a -> [OpenSpec i]
allOpens m = case mtype m of
MTTransfer a b -> a : b : opens m
_ -> opens m
-- | initial dependency list
depPathModule :: Ord i => Module i a -> [OpenSpec i]
depPathModule m = fors m ++ exts m ++ opens m where
fors m = case mtype m of
MTTransfer i j -> [i,j]
MTConcrete i -> [oSimple i]
MTInstance i -> [oSimple i]
_ -> []
exts m = map oSimple $ extends m
depPathModule :: Ord i => ModInfo i a -> [OpenSpec i]
depPathModule m = fors m ++ exts m ++ opens m
where
fors m =
case mtype m of
MTTransfer i j -> [i,j]
MTConcrete i -> [OSimple i]
MTInstance i -> [OSimple i]
_ -> []
exts m = map OSimple (extends m)
-- | all dependencies
allDepsModule :: Ord i => MGrammar i a -> Module i a -> [OpenSpec i]
allDepsModule :: Ord i => MGrammar i a -> ModInfo i a -> [OpenSpec i]
allDepsModule gr m = iterFix add os0 where
os0 = depPathModule m
add os = [m | o <- os, Just (ModMod n) <- [lookup (openedModule o) mods],
add os = [m | o <- os, Just n <- [lookup (openedModule o) mods],
m <- depPathModule n]
mods = modules gr
@@ -217,48 +172,49 @@ partOfGrammar :: Ord i => MGrammar i a -> (i,ModInfo i a) -> MGrammar i a
partOfGrammar gr (i,m) = MGrammar [mo | mo@(j,_) <- mods, elem j modsFor]
where
mods = modules gr
modsFor = case m of
ModMod n -> (i:) $ map openedModule $ allDepsModule gr n
---- ModWith n i os -> i : map openedModule os ++ partOfGrammar (ModMod n) ----
_ -> [i]
modsFor = (i:) $ map openedModule $ allDepsModule gr m
-- | all modules that a module extends, directly or indirectly, without restricts
allExtends :: (Show i,Ord i) => MGrammar i a -> i -> [i]
allExtends gr i = case lookupModule gr i of
Ok (ModMod m) -> case extends m of
[] -> [i]
is -> i : concatMap (allExtends gr) is
_ -> []
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 :: (Show i,Ord i) => MGrammar i a -> i -> [(i,MInclude i)]
allExtendSpecs gr i = case lookupModule gr i of
Ok (ModMod m) -> case extend m of
[] -> [(i,MIAll)]
is -> (i,MIAll) : concatMap (allExtendSpecs gr . fst) is
_ -> []
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 :: (Show i,Ord i) => MGrammar i a -> i -> [i]
allExtendsPlus gr i = case lookupModule gr i of
Ok (ModMod m) -> i : concatMap (allExtendsPlus gr) (exts m)
_ -> []
where
exts m = extends m ++ [j | MTInstance j <- [mtype m]]
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 :: (Show i,Ord i) => MGrammar i a -> i -> [i]
allExtensions gr i = case lookupModule gr i of
Ok (ModMod m) -> let es = exts i in es ++ concatMap (allExtensions gr) es
_ -> []
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)
|| elem (MTInstance i) [mtype m]]
mods = [(j,m) | (j,ModMod m) <- modules gr]
mods = modules gr
-- | initial search path: the nonqualified dependencies
searchPathModule :: Ord i => Module i a -> [i]
searchPathModule m = [i | OSimple _ i <- depPathModule m]
searchPathModule :: Ord i => ModInfo i a -> [i]
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 :: Ord i =>
@@ -269,11 +225,7 @@ emptyMGrammar :: MGrammar i a
emptyMGrammar = MGrammar []
emptyModInfo :: ModInfo i a
emptyModInfo = ModMod emptyModule
emptyModule :: Module i a
emptyModule = Module
MTResource MSComplete noOptions [] [] emptyBinTree emptyBinTree
emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] emptyBinTree emptyBinTree
-- | we store the module type with the identifier
data IdentM i = IdentM {
@@ -282,27 +234,18 @@ data IdentM i = IdentM {
}
deriving (Eq,Ord,Show)
typeOfModule :: ModInfo i a -> ModuleType i
typeOfModule mi = case mi of
ModMod m -> mtype m
abstractOfConcrete :: (Show i, Eq i) => MGrammar i a -> i -> Err i
abstractOfConcrete gr c = do
m <- lookupModule gr c
case m of
ModMod n -> case mtype n of
MTConcrete a -> return a
_ -> Bad $ "expected concrete" +++ show c
n <- lookupModule gr c
case mtype n of
MTConcrete a -> return a
_ -> Bad $ "expected concrete" +++ show c
abstractModOfConcrete :: (Show i, Eq i) =>
MGrammar i a -> i -> Err (Module i a)
MGrammar i a -> i -> Err (ModInfo i a)
abstractModOfConcrete gr c = do
a <- abstractOfConcrete gr c
m <- lookupModule gr a
case m of
ModMod n -> return n
_ -> Bad $ "expected abstract" +++ show c
lookupModule gr a
-- the canonical file name
@@ -318,56 +261,41 @@ lookupModule gr m = case lookup m (modules gr) of
lookupModuleType :: (Show i,Eq i) => MGrammar i a -> i -> Err (ModuleType i)
lookupModuleType gr m = do
mi <- lookupModule gr m
return $ typeOfModule mi
return $ mtype mi
lookupModMod :: (Show i,Eq i) => MGrammar i a -> i -> Err (Module i a)
lookupModMod gr i = do
mo <- lookupModule gr i
case mo of
ModMod m -> return m
_ -> Bad $ "expected proper module, not" +++ show i
lookupInfo :: (Show i, Ord i) => Module i a -> i -> Err a
lookupInfo :: (Show i, Ord i) => ModInfo i a -> i -> Err a
lookupInfo mo i = lookupTree show i (jments mo)
lookupPosition :: (Show i, Ord i) => Module i a -> i -> Err (String,(Int,Int))
lookupPosition :: (Show i, Ord i) => ModInfo i a -> i -> Err (String,(Int,Int))
lookupPosition mo i = lookupTree show i (positions mo)
showPosition :: (Show i, Ord i) => Module i a -> i -> String
showPosition :: (Show i, Ord i) => ModInfo i a -> i -> String
showPosition mo i = case lookupPosition mo i of
Ok (f,(b,e)) | b == e -> "in" +++ f ++ ", line" +++ show b
Ok (f,(b,e)) -> "in" +++ f ++ ", lines" +++ show b ++ "-" ++ show e
_ -> ""
allModMod :: (Show i,Eq i) => MGrammar i a -> [(i,Module i a)]
allModMod gr = [(i,m) | (i, ModMod m) <- modules gr]
isModAbs :: Module i a -> Bool
isModAbs :: ModInfo i a -> Bool
isModAbs m = case mtype m of
MTAbstract -> True
---- MTUnion t -> isModAbs t
_ -> False
isModRes :: Module i a -> Bool
isModRes :: ModInfo i a -> Bool
isModRes m = case mtype m of
MTResource -> True
MTReuse _ -> True
---- MTUnion t -> isModRes t --- maybe not needed, since eliminated early
MTInterface -> True ---
MTInstance _ -> True
_ -> False
isModCnc :: Module i a -> Bool
isModCnc :: ModInfo i a -> Bool
isModCnc m = case mtype m of
MTConcrete _ -> True
---- MTUnion t -> isModCnc t
_ -> False
isModTrans :: Module i a -> Bool
isModTrans :: ModInfo i a -> Bool
isModTrans m = case mtype m of
MTTransfer _ _ -> True
---- MTUnion t -> isModTrans t
_ -> False
sameMType :: Eq i => ModuleType i -> ModuleType i -> Bool
@@ -390,21 +318,20 @@ sameMType m n = case (n,m) of
-- | don't generate code for interfaces and for incomplete modules
isCompilableModule :: ModInfo i a -> Bool
isCompilableModule m = case m of
ModMod m -> case mtype m of
isCompilableModule m =
case mtype m of
MTInterface -> False
_ -> mstatus m == MSComplete
_ -> False ---
_ -> mstatus m == MSComplete
-- | interface and "incomplete M" are not complete
isCompleteModule :: (Eq i) => Module i a -> Bool
isCompleteModule :: (Eq i) => ModInfo i a -> Bool
isCompleteModule m = mstatus m == MSComplete && mtype m /= MTInterface
-- | all abstract modules sorted from least to most dependent
allAbstracts :: (Ord i, Show i) => MGrammar i a -> [i]
allAbstracts gr =
case topoTest [(i,extends m) | (i,ModMod m) <- modules gr, mtype m == MTAbstract] of
case topoTest [(i,extends m) | (i,m) <- modules gr, mtype m == MTAbstract] of
Left is -> is
Right cycles -> error $ "Cyclic abstract modules: " ++ show cycles
@@ -416,7 +343,7 @@ greatestAbstract gr = case allAbstracts gr of
-- | all resource modules
allResources :: MGrammar i a -> [i]
allResources gr = [i | (i,ModMod m) <- modules gr, isModRes m || isModCnc m]
allResources gr = [i | (i,m) <- modules gr, isModRes m || isModCnc m]
-- | the greatest resource in dependency order
greatestResource :: MGrammar i a -> Maybe i
@@ -427,9 +354,9 @@ greatestResource gr = case allResources gr of
-- | all concretes for a given abstract
allConcretes :: Eq i => MGrammar i a -> i -> [i]
allConcretes gr a =
[i | (i, ModMod m) <- modules gr, mtype m == MTConcrete a, isCompleteModule m]
[i | (i, m) <- modules gr, mtype m == MTConcrete a, isCompleteModule m]
-- | all concrete modules for any abstract
allConcreteModules :: Eq i => MGrammar i a -> [i]
allConcreteModules gr =
[i | (i, ModMod m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]
[i | (i, m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]