merge GF.Infra.Modules and GF.Grammar.Grammar. This is a preparation for the separate PGF building

2011-11-02 13:57:11 +00:00
parent 5fe49ed9f7
commit 734c66710e
30 changed files with 322 additions and 451 deletions
--- a/src/compiler/GF/Grammar/Grammar.hs
+++ b/src/compiler/GF/Grammar/Grammar.hs
@@ -14,11 +14,25 @@
 -- AR 23\/1\/2000 -- 30\/5\/2001 -- 4\/5\/2003
 -----------------------------------------------------------------------------

-module GF.Grammar.Grammar (SourceGrammar,
-        emptySourceGrammar,mGrammar,
-        SourceModInfo,
-        SourceModule,
-        mapSourceModule,
+module GF.Grammar.Grammar (
+        SourceGrammar, SourceModInfo(..), SourceModule, ModuleType(..),
+        emptySourceGrammar, mGrammar, modules, prependModule,
+
+        MInclude (..), OpenSpec(..),
+        extends, isInherited, inheritAll,
+        openedModule, depPathModule, allDepsModule, partOfGrammar,
+        allExtends, allExtendSpecs, allExtendsPlus, allExtensions, 
+        searchPathModule,
+        
+        lookupModule,
+        isModAbs, isModRes, isModCnc,
+        sameMType, isCompilableModule, isCompleteModule,
+        allAbstracts, greatestAbstract, allResources,
+        greatestResource, allConcretes, allConcreteModules,
+        abstractOfConcrete,
+
+        ModuleStatus(..),
+
        Info(..),
        Location(..), L(..), unLoc,
        Type,
@@ -47,23 +61,258 @@ module GF.Grammar.Grammar (SourceGrammar,

 import GF.Infra.Ident
 import GF.Infra.Option ---
-import GF.Infra.Modules

 import GF.Data.Operations

+import Data.List
+import qualified Data.Map as Map
 import qualified Data.ByteString.Char8 as BS
+import Text.PrettyPrint
+import System.FilePath

-- | grammar as presented to the compiler
-type SourceGrammar = MGrammar Info

-emptySourceGrammar = emptyMGrammar
+data SourceGrammar = MGrammar { 
+    moduleMap :: Map.Map Ident SourceModInfo,
+    modules :: [(Ident,SourceModInfo)]
+  }
+  deriving Show

-type SourceModInfo = ModInfo Info
+data SourceModInfo = ModInfo {
+    mtype   :: ModuleType,
+    mstatus :: ModuleStatus,
+    mflags  :: Options,
+    mextend :: [(Ident,MInclude)],
+    mwith   :: Maybe (Ident,MInclude,[(Ident,Ident)]),
+    mopens  :: [OpenSpec],
+    mexdeps :: [Ident],
+    msrc    :: FilePath,
+    jments  :: Map.Map Ident Info
+  }
+  deriving Show

 type SourceModule = (Ident, SourceModInfo)

-mapSourceModule :: (SourceModInfo -> SourceModInfo) -> (SourceModule -> SourceModule)
-mapSourceModule f (i,mi) = (i, f mi)
+-- | encoding the type of the module
+data ModuleType = 
+    MTAbstract 
+  | MTResource
+  | MTConcrete Ident
+  | MTInterface
+  | MTInstance (Ident,MInclude)
+  deriving (Eq,Show)
+
+data MInclude = MIAll | MIOnly [Ident] | MIExcept [Ident]
+  deriving (Eq,Show)
+
+extends :: SourceModInfo -> [Ident]
+extends = map fst . mextend
+
+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)
+
+addOpenQualif :: Ident -> Ident -> SourceModInfo -> SourceModInfo
+addOpenQualif i j (ModInfo mt ms fs me mw ops med src js) = ModInfo mt ms fs me mw (OQualif i j : ops) med src js
+
+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 :: SourceModInfo -> [OpenSpec]
+depPathModule m = fors m ++ exts m ++ mopens 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 :: SourceGrammar -> SourceModInfo -> [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 :: SourceGrammar -> (Ident,SourceModInfo) -> SourceGrammar
+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 :: 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
+    _    -> []
+
+-- | this plus that an instance extends its interface
+allExtendsPlus :: SourceGrammar -> 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 :: 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]
+
+prependModule (MGrammar mm ms) im@(i,m) = MGrammar (Map.insert i m mm) (im:ms)
+
+emptySourceGrammar :: SourceGrammar
+emptySourceGrammar = mGrammar []
+
+mGrammar ms = MGrammar (Map.fromList ms) ms
+
+
+-- | we store the module type with the identifier
+
+abstractOfConcrete :: SourceGrammar -> 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)
+
+lookupModule :: SourceGrammar -> Ident -> Err SourceModInfo
+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)))
+
+isModAbs :: SourceModInfo -> Bool
+isModAbs m =
+  case mtype m of
+    MTAbstract -> True
+    _          -> False
+
+isModRes :: SourceModInfo -> Bool
+isModRes m =
+  case mtype m of
+    MTResource   -> True
+    MTInterface  -> True ---
+    MTInstance _ -> True
+    _            -> False
+
+isModCnc :: SourceModInfo -> 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 :: SourceModInfo -> Bool
+isCompilableModule m =
+  case mtype m of
+    MTInterface -> False
+    _           -> mstatus m == MSComplete
+
+-- | interface and "incomplete M" are not complete
+isCompleteModule :: SourceModInfo -> Bool
+isCompleteModule m = mstatus m == MSComplete && mtype m /= MTInterface
+
+
+-- | all abstract modules sorted from least to most dependent
+allAbstracts :: SourceGrammar -> [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 :: SourceGrammar -> Maybe Ident
+greatestAbstract gr =
+  case allAbstracts gr of
+    [] -> Nothing
+    as -> return $ last as
+
+-- | all resource modules
+allResources :: SourceGrammar -> [Ident]
+allResources gr = [i | (i,m) <- modules gr, isModRes m || isModCnc m]
+
+-- | the greatest resource in dependency order
+greatestResource :: SourceGrammar -> 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 :: SourceGrammar -> Ident -> [Ident]
+allConcretes gr a =
+  [i | (i, m) <- modules gr, mtype m == MTConcrete a, isCompleteModule m]
+
+-- | all concrete modules for any abstract
+allConcreteModules :: SourceGrammar -> [Ident]
+allConcreteModules gr =
+  [i | (i, m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]
+
+

 -- | the constructors are judgements in 
 --