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

8 files changed, 269 insertions, 29 deletions

diff --git a/src/compiler/GF/Grammar/Analyse.hs b/src/compiler/GF/Grammar/Analyse.hs
index 78ad3e53f..1c9358816 100644
--- a/src/compiler/GF/Grammar/Analyse.hs
+++ b/src/compiler/GF/Grammar/Analyse.hs
@@ -11,7 +11,6 @@ module GF.Grammar.Analyse (
 import GF.Grammar.Grammar
 import GF.Infra.Ident
 import GF.Infra.Option ---
-import GF.Infra.Modules
 import GF.Grammar.Macros
 import GF.Grammar.Lookup
 
diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs
index 7c79be361..2298ed018 100644
--- a/src/compiler/GF/Grammar/Binary.hs
+++ b/src/compiler/GF/Grammar/Binary.hs
@@ -16,7 +16,6 @@ import qualified Data.ByteString.Char8 as BS
 import GF.Data.Operations

 import GF.Infra.Ident

 import GF.Infra.Option

-import GF.Infra.Modules

 import GF.Grammar.Grammar

 

 instance Binary Ident where

@@ -26,12 +25,12 @@ instance Binary Ident where
                 then return identW

                 else return (identC bs)

 

-instance Binary a => Binary (MGrammar a) where

+instance Binary SourceGrammar where

   put = put . modules

   get = fmap mGrammar get

 

-instance Binary a => Binary (ModInfo a) where

-  put mi = do put (mtype mi,mstatus mi,flags mi,extend mi,mwith mi,opens mi,mexdeps mi,msrc mi,jments mi)

+instance Binary SourceModInfo where

+  put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,jments mi)

   get    = do (mtype,mstatus,flags,extend,mwith,opens,med,src,jments) <- get

               return (ModInfo mtype mstatus flags extend mwith opens med src jments)

 

diff --git a/src/compiler/GF/Grammar/CF.hs b/src/compiler/GF/Grammar/CF.hs
index 10f7a71fd..5a10612ec 100644
--- a/src/compiler/GF/Grammar/CF.hs
+++ b/src/compiler/GF/Grammar/CF.hs
@@ -17,7 +17,6 @@ module GF.Grammar.CF (getCF,CFItem,CFCat,CFFun,cf2gf,CFRule) where
 import GF.Grammar.Grammar
 import GF.Grammar.Macros
 import GF.Infra.Ident
-import GF.Infra.Modules
 import GF.Infra.Option
 import GF.Infra.UseIO
 
@@ -84,9 +83,8 @@ type CFFun = String
 
 cf2gf :: FilePath -> CF -> SourceGrammar
 cf2gf fpath cf = mGrammar [
-  (aname, addFlag (modifyFlags (\fs -> fs{optStartCat = Just cat}))
-          (emptyModInfo{mtype = MTAbstract, msrc=fpath, jments = abs})),
-  (cname, emptyModInfo{mtype = MTConcrete aname, msrc=fpath, jments = cnc})
+  (aname, ModInfo MTAbstract MSComplete (modifyFlags (\fs -> fs{optStartCat = Just cat})) [] Nothing [] [] fpath abs),
+  (cname, ModInfo (MTConcrete aname) MSComplete noOptions [] Nothing [] [] fpath cnc)
   ]
  where
    name = justModuleName fpath
diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs
index 627355033..acf2153bc 100644
--- 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 
 --
diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs
index 651fde4d0..7e743dd16 100644
--- a/src/compiler/GF/Grammar/Lookup.hs
+++ b/src/compiler/GF/Grammar/Lookup.hs
@@ -17,7 +17,6 @@
 
 module GF.Grammar.Lookup (
            lookupIdent,
---         lookupIdentInfo,
            lookupOrigInfo,
            allOrigInfos,
            lookupResDef,
@@ -34,7 +33,6 @@ module GF.Grammar.Lookup (
 
 import GF.Data.Operations
 import GF.Infra.Ident
-import GF.Infra.Modules
 import GF.Grammar.Macros
 import GF.Grammar.Grammar
 import GF.Grammar.Printer
@@ -57,10 +55,10 @@ lookupIdent c t =
     Ok v  -> return v
     Bad _ -> Bad ("unknown identifier" +++ showIdent c)
 
-lookupIdentInfo :: ModInfo a -> Ident -> Err a
+lookupIdentInfo :: SourceModInfo -> Ident -> Err Info
 lookupIdentInfo mo i = lookupIdent i (jments mo)
 
-lookupQIdentInfo :: MGrammar info -> QIdent -> Err info
+lookupQIdentInfo :: SourceGrammar -> QIdent -> Err Info
 lookupQIdentInfo gr (m,c) = flip lookupIdentInfo c =<< lookupModule gr m
 
 lookupResDef :: SourceGrammar -> QIdent -> Err Term
diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs
index 38b22aaa2..8af343fc6 100644
--- a/src/compiler/GF/Grammar/Macros.hs
+++ b/src/compiler/GF/Grammar/Macros.hs
@@ -21,7 +21,6 @@ module GF.Grammar.Macros where
 import GF.Data.Operations
 import GF.Data.Str
 import GF.Infra.Ident
-import GF.Infra.Modules
 import GF.Grammar.Grammar
 import GF.Grammar.Values
 import GF.Grammar.Predef
@@ -584,4 +583,4 @@ pSeq p1 p2 =
     (PSeq p11 (PString s1),PSeq (PString s2) p22) ->
         PSeq p11 (PSeq (PString (s1++s2)) p22)
     _ -> PSeq p1 p2
--}
\ No newline at end of file
+-}
diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y
index 26b7e123b..6c83d72a0 100644
--- a/src/compiler/GF/Grammar/Parser.y
+++ b/src/compiler/GF/Grammar/Parser.y
@@ -9,7 +9,6 @@ module GF.Grammar.Parser
          ) where
 
 import GF.Infra.Ident
-import GF.Infra.Modules
 import GF.Infra.Option
 import GF.Data.Operations
 import GF.Grammar.Predef
diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs
index ce8562db7..f65d26f89 100644
--- a/src/compiler/GF/Grammar/Printer.hs
+++ b/src/compiler/GF/Grammar/Printer.hs
@@ -22,7 +22,6 @@ module GF.Grammar.Printer
            ) where

 

 import GF.Infra.Ident

-import GF.Infra.Modules

 import GF.Infra.Option

 import GF.Grammar.Values

 import GF.Grammar.Grammar