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

1 files changed, 90 insertions, 163 deletions

diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs
index fc319f6b3..56cfb8063 100644
--- a/src/GF/Infra/Modules.hs
+++ b/src/GF/Infra/Modules.hs
@@ -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]
-
-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
+allFlags gr = concatOptions [flags m | (_,m) <- modules gr]
 
-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
-
-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
+  return $ mtype mi
 
-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]