extended functor syntax

doc/tutorial/music/MusicEng.gf

@@ -1,7 +1,11 @@
 --# -path=.:present:api:prelude
 
-  concrete MusicEng of Music = MusicEng0 - [PropKind] ** 
+  concrete MusicEng of Music = 
-      open SyntaxEng in {
+    MusicI - [PropKind] 
+      with
+        (Syntax = SyntaxEng),
+        (MusicLex = MusicLexEng) ** 
+    open SyntaxEng in {
   lin
     PropKind k p = mkCN k (mkRS (mkRCl which_RP (mkVP p))) ;
   }

doc/tutorial/music/MusicEng0.gf

@@ -1,3 +0,0 @@
-  concrete MusicEng0 of Music = MusicI with
-    (Syntax = SyntaxEng),
-    (MusicLex = MusicLexEng) ;

src/GF/Compile/Rebuild.hs

@@ -25,6 +25,8 @@ import GF.Infra.Ident
 import GF.Infra.Modules
 import GF.Data.Operations
 
+import Data.List (nub)
+
 -- | rebuilding instance + interface, and "with" modules, prior to renaming. 
 -- AR 24/10/2003
 rebuildModule :: [SourceModule] -> SourceModule -> Err SourceModule
@@ -58,7 +60,8 @@ rebuildModule ms mo@(i,mi) = do
         _ -> return mi
 
     -- add the instance opens to an incomplete module "with" instances
-    ModWith mt stat ext me ops -> do
+    --      ModWith mt stat ext me ops -> do
+    ModWith (Module mt stat fs_ me ops_ js_) (ext,incl) ops -> do
       let insts = [(inf,inst) | OQualif _ inf inst <- ops]
       let infs  = map fst insts
       let stat' = ifNull MSComplete (const MSIncomplete)
@@ -66,12 +69,17 @@ rebuildModule ms mo@(i,mi) = do
       testErr (stat' == MSComplete || stat == MSIncomplete) 
               ("module" +++ prt i +++ "remains incomplete")
       Module mt0 _ fs me' ops0 js <- lookupModMod gr ext
-      let ops1 = ops ++ [o | o <- ops0, notElem (openedModule o) infs]
+      let ops1 = nub $
-                     ++ [oQualif i i | i <- map snd insts] ----
+                   ops_ ++ -- N.B. js has been name-resolved already
-                     ++ [oSimple i   | i <- map snd insts] ----
+                   ops ++ [o | o <- ops0, notElem (openedModule o) infs]
-               ----      ++ [oSimple ext] ---- to encode dependence
+                       ++ [oQualif i i | i <- map snd insts] ----
+                       ++ [oSimple i   | i <- map snd insts] ----
+
       --- check if me is incomplete
-      return $ ModMod $ Module mt0 stat' fs me ops1 js 
+      let fs1 = fs_ ++ fs                            -- new flags have priority
+      let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c]
+      let js1 = buildTree (tree2list js_ ++ js0)
+      return $ ModMod $ Module mt0 stat' fs1 me ops1 js1 
                           ---- (mapTree (qualifInstanceInfo insts) js) -- not needed
 
     _ -> return mi

src/GF/Infra/Modules.hs

@@ -58,7 +58,7 @@ data MGrammar i f a = MGrammar {modules :: [(i,ModInfo i f a)]}
 data ModInfo i f a =
     ModMainGrammar (MainGrammar i)
   | ModMod  (Module i f a)
-  | ModWith (ModuleType i) ModuleStatus i [(i,MInclude i)] [OpenSpec i]
+  | ModWith (Module i f a) (i,MInclude i) [OpenSpec i]
   deriving Show
 
 data Module i f a = Module {
@@ -213,7 +213,8 @@ partOfGrammar gr (i,m) = MGrammar [mo | mo@(j,_) <- mods, elem j modsFor]
     mods = modules gr
     modsFor = case m of
       ModMod n -> (i:) $ map openedModule $ allDepsModule gr n
-      _ -> [i] ---- ModWith?
+      ---- ModWith n i os -> i : map openedModule os ++ partOfGrammar (ModMod n) ----
+      _ -> [i]
 
 
 -- | all modules that a module extends, directly or indirectly

src/GF/Source/AbsGF.hs

@@ -38,9 +38,12 @@ data ModType =
   deriving (Eq,Ord,Show)
 
 data ModBody =
-   MBody Extend Opens [TopDef]
+   MNoBody [Included]
- | MWith Ident [Open]
+ | MWithBody Included [Open] Opens [TopDef]
- | MWithE [Included] Ident [Open]
+ | MWithEBody [Included] Included [Open] Opens [TopDef]
+ | MBody Extend Opens [TopDef]
+ | MWith Included [Open]
+ | MWithE [Included] Included [Open]
  | MReuse Ident
  | MUnion [Included]
   deriving (Eq,Ord,Show)

src/GF/Source/GF.cf

@@ -43,9 +43,14 @@ MTConcrete.  ModType ::= "concrete" Ident "of" Ident ;
 MTInstance.  ModType ::= "instance" Ident "of" Ident ;
 MTTransfer.  ModType ::= "transfer" Ident ":" Open "->" Open ;
 
-MBody.  ModBody ::= Extend Opens "{" [TopDef] "}" ;
+
-MWith.  ModBody ::=              Ident "with" [Open] ;
+MBody.      ModBody ::= Extend Opens "{" [TopDef] "}" ;
-MWithE. ModBody ::= [Included] "**" Ident "with" [Open] ;
+MNoBody.    ModBody ::= [Included] ;
+MWith.      ModBody ::=                 Included "with" [Open] ;
+MWithBody.  ModBody ::=                 Included "with" [Open] "**" Opens "{" [TopDef] "}" ; 
+MWithE.     ModBody ::= [Included] "**" Included "with" [Open] ;
+MWithEBody. ModBody ::= [Included] "**" Included "with" [Open] "**" Opens "{" [TopDef] "}" ; 
+
 MReuse. ModBody ::= "reuse" Ident ; --%
 MUnion. ModBody ::= "union" [Included] ;--%
 

src/GF/Source/PrintGF.hs

@@ -144,13 +144,15 @@ instance Print ModType where
 
 instance Print ModBody where
   prt i e = case e of
+   MNoBody includeds -> prPrec i 0 (concatD [prt 0 includeds])
+   MWithBody included opens0 opens topdefs -> prPrec i 0 (concatD [prt 0 included , doc (showString "with") , prt 0 opens0 , doc (showString "**") , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")])
+   MWithEBody includeds included opens0 opens topdefs -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**") , prt 0 included , doc (showString "with") , prt 0 opens0 , doc (showString "**") , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")])
    MBody extend opens topdefs -> prPrec i 0 (concatD [prt 0 extend , prt 0 opens , doc (showString "{") , prt 0 topdefs , doc (showString "}")])
-   MWith id opens -> prPrec i 0 (concatD [prt 0 id , doc (showString "with") , prt 0 opens])
+   MWith included opens -> prPrec i 0 (concatD [prt 0 included , doc (showString "with") , prt 0 opens])
-   MWithE includeds id opens -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**") , prt 0 id , doc (showString "with") , prt 0 opens])
+   MWithE includeds included opens -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**") , prt 0 included , doc (showString "with") , prt 0 opens])
    MReuse id -> prPrec i 0 (concatD [doc (showString "reuse") , prt 0 id])
    MUnion includeds -> prPrec i 0 (concatD [doc (showString "union") , prt 0 includeds])
 
-
 instance Print Extend where
   prt i e = case e of
    Ext includeds -> prPrec i 0 (concatD [prt 0 includeds , doc (showString "**")])

src/GF/Source/SourceToGrammar.hs

@@ -92,32 +92,40 @@ transModDef x = case x of
         open' <- transIdent open
         mkModRes id (GM.MTInstance open') body
 
-    case body of 
+    mkBody (mstat', trDef, mtyp', id') body
-      MBody extends opens defs -> do
+  where
+      mkBody xx@(mstat', trDef, mtyp', id') bod = case bod of 
+       MNoBody incls -> do
+        mkBody xx $ MBody (Ext incls) NoOpens []
+       MBody extends opens defs -> do
         extends' <- transExtend extends
         opens'   <- transOpens opens
         defs0    <- mapM trDef $ getTopDefs defs
         defs'    <- U.buildAnyTree [d | Left  ds <- defs0, d <- ds]
         flags'   <- return       [f | Right fs <- defs0, f <- fs]
         return (id',GM.ModMod (GM.Module mtyp' mstat' flags' extends' opens' defs'))
-      MReuse _ -> do
+       MReuse _ -> do
         return (id', GM.ModMod (GM.Module mtyp' mstat' [] [] [] emptyBinTree))
-      MUnion imps -> do
+       MUnion imps -> do
         imps' <- mapM transIncluded imps        
         return (id', 
           GM.ModMod (GM.Module (GM.MTUnion mtyp' imps') mstat' [] [] [] emptyBinTree))
 
-      MWith m opens -> do
+       MWith m insts -> mkBody xx $ MWithEBody [] m insts NoOpens []
-        m'       <- transIdent m
+       MWithBody m insts opens defs -> mkBody xx $ MWithEBody [] m insts opens defs
-        opens'   <- mapM transOpen opens 
+       MWithE extends m insts -> mkBody xx $ MWithEBody extends m insts NoOpens []
-        return (id', GM.ModWith mtyp' mstat' m' [] opens')
+       MWithEBody extends m insts opens defs -> do
-      MWithE extends m opens -> do
         extends' <- mapM transIncludedExt extends
-        m'       <- transIdent m
+        m'       <- transIncludedExt m
-        opens'   <- mapM transOpen opens 
+        insts'   <- mapM transOpen insts 
-        return (id', GM.ModWith mtyp' mstat' m' extends' opens')
+        opens'   <- transOpens opens
- where
+        defs0    <- mapM trDef $ getTopDefs defs
-       mkModRes id mtyp body = do
+        defs'    <- U.buildAnyTree [d | Left  ds <- defs0, d <- ds]
+        flags'   <- return       [f | Right fs <- defs0, f <- fs]
+        return (id',
+          GM.ModWith (GM.Module mtyp' mstat' flags' extends' opens' defs') m' insts')
+
+      mkModRes id mtyp body = do
          id' <- transIdent id
          case body of
            MReuse c -> do
@@ -125,7 +133,7 @@ transModDef x = case x of
              mtyp' <- trMReuseType mtyp c'
              return (transResDef, GM.MTReuse mtyp', id')
            _ -> return (transResDef, mtyp, id')
-       trMReuseType mtyp c = case mtyp of
+      trMReuseType mtyp c = case mtyp of
          GM.MTInterface -> return $ GM.MRInterface c
          GM.MTInstance op -> return $ GM.MRInstance c op
          GM.MTResource -> return $ GM.MRResource c