Started with unions.

src/GF/Compile/Compile.hs

@@ -10,6 +10,7 @@ import Modules
 import ReadFiles
 import ShellState
 import MkResource
+import MkUnion
 
 -- the main compiler passes
 import GetGrammar
@@ -177,6 +178,9 @@ makeSourceModule opts env@(k,gr,can) mo@(i,mi) = case mi of
           mos = modules gr
       --- putp "  type checking reused" $ ioeErr $ showCheckModule mos mo2
       return $ (k,mo2)
+    MTUnion ty imps -> do
+      mo' <- ioeErr $ makeUnion gr i ty imps
+      compileSourceModule opts env mo'
     _ -> compileSourceModule opts env mo
   _ -> compileSourceModule opts env mo
  where

src/GF/Compile/GetGrammar.hs

@@ -79,5 +79,5 @@ oldLexer = map change . L.tokens where
     (L.PT p (L.TS s)) | elem s new -> (L.PT p (L.TV (init s ++ "Z")))
     _ -> t
   new = words $ "abstract concrete interface incomplete " ++ 
-                "instance out open resource reuse transfer with where"
+                "instance out open resource reuse transfer union with where"
 

src/GF/Compile/MkUnion.hs

@@ -0,0 +1,19 @@
+module MkUnion (makeUnion) where
+
+import Grammar
+import Ident
+import Modules
+import Macros
+import PrGrammar
+
+import Operations
+
+import Monad
+
+-- building union of modules
+-- AR 21/8/2002 -- 22/6/2003 for GF with modules
+
+makeUnion :: SourceGrammar -> Ident -> ModuleType Ident -> [(Ident,[Ident])] ->
+             Err SourceModule
+makeUnion gr m ty imps = do
+  Bad "Sorry: unions not yet implemented"

src/GF/Grammar/ReservedWords.hs

@@ -13,8 +13,8 @@ isResWord s = isInTree s resWordTree
 resWordTree :: BTree
 resWordTree = 
 --  mapTree fst $ sorted2tree $ flip zip (repeat ()) $ sort allReservedWords
-    B "let" (B "concrete" (B "Tok" (B "Str" (B "PType" (B "Lin" N N) N) (B "Strs" N N)) (B "case" (B "abstract" (B "Type" N N) N) (B "cat" N N))) (B "fun" (B "flags" (B "def" (B "data" N N) N) (B "fn" N N)) (B "in" (B "grammar" N N) (B "include" N N)))) (B "pattern" (B "of" (B "lindef" (B "lincat" (B "lin" N N) N) (B "lintype" N N)) (B "out" (B "oper" (B "open" N N) N) (B "param" N N))) (B "strs" (B "resource" (B "printname" (B "pre" N N) N) (B "reuse" N N)) (B "transfer" (B "table" N N) (B "variants" N N))))
+--  nowadays obtained from LexGF.hs
-
+    B "let" (B "data" (B "Type" (B "Str" (B "PType" (B "Lin" N N) N) (B "Tok" (B "Strs" N N) N)) (B "cat" (B "case" (B "abstract" N N) N) (B "concrete" N N))) (B "in" (B "fn" (B "flags" (B "def" N N) N) (B "grammar" (B "fun" N N) N)) (B "instance" (B "incomplete" (B "include" N N) N) (B "interface" N N)))) (B "pre" (B "open" (B "lindef" (B "lincat" (B "lin" N N) N) (B "of" (B "lintype" N N) N)) (B "param" (B "out" (B "oper" N N) N) (B "pattern" N N))) (B "transfer" (B "reuse" (B "resource" (B "printname" N N) N) (B "table" (B "strs" N N) N)) (B "where" (B "variants" (B "union" N N) N) (B "with" N N))))
 
 isResWordGFC :: String -> Bool
 isResWordGFC s = isInTree s $

src/GF/Infra/Modules.hs

@@ -44,6 +44,7 @@ data ModuleType i =
   | MTInterface
   | MTInstance i 
   | MTReuse (MReuseType i)
+  | MTUnion (ModuleType i) [(i,[i])] --- not meant to be recursive
   deriving (Eq,Show)
 
 data MReuseType i = MRInterface i | MRInstance i i | MRResource i
@@ -245,21 +246,25 @@ lookupInfo mo i = lookupTree show i (jments mo)
 
 isModAbs m = case mtype m of
   MTAbstract -> True
+----  MTUnion t -> isModAbs t
   _ -> False
 
 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 m = case mtype m of
   MTConcrete _ -> True
+----  MTUnion t -> isModCnc t
   _ -> False
 
 isModTrans m = case mtype m of
   MTTransfer _ _ -> True
+----  MTUnion t -> isModTrans t
   _ -> False
 
 sameMType m n = case (m,n) of

src/GF/Infra/ReadFiles.hs

@@ -181,16 +181,21 @@ importsOfFile =
   getModuleHeader .          -- analyse into mod header
   filter (not . spec) .      -- ignore keywords and special symbols
   unqual .                   -- take away qualifiers
+  unrestr .                  -- take away union restrictions
   takeWhile (not . term) .   -- read until curly or semic
   lexs .                     -- analyse into lexical tokens
   unComm                     -- ignore comments before the headed line
  where
     term = flip elem ["{",";"]
-    spec = flip elem ["of", "open","in",":", "->","=", "(", ")",",","**"]
+    spec = flip elem ["of", "open","in",":", "->","=", "(", ")",",","**","union"]
     unqual ws = case ws of
       "(":q:ws' -> unqual ws'
       w:ws' -> w:unqual ws'
       _ -> ws
+    unrestr ws = case ws of
+      "[":ws' -> unrestr $ tail $ dropWhile (/="]") ws'
+      w:ws' -> w:unrestr ws'
+      _ -> ws
 
 getModuleHeader :: [String] -> ModuleHeader -- with, reuse
 getModuleHeader ws = case ws of

src/GF/Source/AbsGF.hs

@@ -41,6 +41,7 @@ data ModBody =
    MBody Extend Opens [TopDef]
  | MWith Ident [Open]
  | MReuse Ident
+ | MUnion [Included]
   deriving (Eq,Ord,Show)
 
 data Extend =
@@ -70,6 +71,11 @@ data QualOpen =
  | QOInterface
   deriving (Eq,Ord,Show)
 
+data Included =
+   IAll Ident
+ | ISome Ident [Ident]
+  deriving (Eq,Ord,Show)
+
 data Def =
    DDecl [Ident] Exp
  | DDef [Ident] Exp

src/GF/Source/GF.cf

@@ -41,6 +41,7 @@ MTTransfer.  ModType ::= "transfer" Ident ":" Open "->" Open ;
 MBody.  ModBody ::= Extend Opens "{" [TopDef] "}" ;
 MWith.  ModBody ::= Ident "with" [Open] ;
 MReuse. ModBody ::= "reuse" Ident ;
+MUnion. ModBody ::= "union" [Included] ;
 
 separator TopDef "" ;
 
@@ -62,6 +63,11 @@ QOCompl.     QualOpen ::= ;
 QOIncompl.   QualOpen ::= "incomplete" ;
 QOInterface. QualOpen ::= "interface" ;
 
+separator Included "," ;
+
+IAll.  Included ::= Ident ;
+ISome. Included ::= Ident "[" [Ident] "]" ;
+
 -- definitions after the $oper$ keywords
 
 DDecl.  Def ::= [Ident] ":" Exp ;

src/GF/Source/LexGF.hs

@@ -55,7 +55,7 @@ tokens_scan = load_scan (tokens_acts,stop_act) tokens_lx
 eitherResIdent :: (String -> Tok) -> String -> Tok
 eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where
   isResWord s = isInTree s $
-    B "interface" (B "data" (B "Type" (B "Str" (B "PType" (B "Lin" N N) N) (B "Tok" (B "Strs" N N) N)) (B "cat" (B "case" (B "abstract" N N) N) (B "concrete" N N))) (B "grammar" (B "fn" (B "flags" (B "def" N N) N) (B "fun" N N)) (B "incomplete" (B "include" (B "in" N N) N) (B "instance" N N)))) (B "pattern" (B "of" (B "lincat" (B "lin" (B "let" N N) N) (B "lintype" (B "lindef" N N) N)) (B "out" (B "oper" (B "open" N N) N) (B "param" N N))) (B "strs" (B "resource" (B "printname" (B "pre" N N) N) (B "reuse" N N)) (B "variants" (B "transfer" (B "table" N N) N) (B "with" N N))))
+    B "let" (B "data" (B "Type" (B "Str" (B "PType" (B "Lin" N N) N) (B "Tok" (B "Strs" N N) N)) (B "cat" (B "case" (B "abstract" N N) N) (B "concrete" N N))) (B "in" (B "fn" (B "flags" (B "def" N N) N) (B "grammar" (B "fun" N N) N)) (B "instance" (B "incomplete" (B "include" N N) N) (B "interface" N N)))) (B "pre" (B "open" (B "lindef" (B "lincat" (B "lin" N N) N) (B "of" (B "lintype" N N) N)) (B "param" (B "out" (B "oper" N N) N) (B "pattern" N N))) (B "transfer" (B "reuse" (B "resource" (B "printname" N N) N) (B "table" (B "strs" N N) N)) (B "where" (B "variants" (B "union" N N) N) (B "with" N N))))
 
 data BTree = N | B String BTree BTree deriving (Show)
 

src/GF/Source/PrintGF.hs

@@ -134,7 +134,7 @@ instance Print ModBody where
    MBody extend opens topdefs -> prPrec i 0 (concat [prt 0 extend , prt 0 opens , ["{"] , prt 0 topdefs , ["}"]])
    MWith id opens -> prPrec i 0 (concat [prt 0 id , ["with"] , prt 0 opens])
    MReuse id -> prPrec i 0 (concat [["reuse"] , prt 0 id])
-
+   MUnion includeds -> prPrec i 0 (concat [["union"] , prt 0 includeds])
 
 instance Print Extend where
   prt i e = case e of
@@ -171,6 +171,15 @@ instance Print QualOpen where
    QOIncompl  -> prPrec i 0 (concat [["incomplete"]])
    QOInterface  -> prPrec i 0 (concat [["interface"]])
 
+instance Print Included where
+  prt i e = case e of
+   IAll id -> prPrec i 0 (concat [prt 0 id])
+   ISome id ids -> prPrec i 0 (concat [prt 0 id , ["["] , prt 0 ids , ["]"]])
+
+  prtList es = case es of
+   [] -> (concat [])
+   [x] -> (concat [prt 0 x])
+   x:xs -> (concat [prt 0 x , [","] , prt 0 xs])
 
 instance Print Def where
   prt i e = case e of

src/GF/Source/SkelGF.hs

@@ -61,6 +61,7 @@ transModBody x = case x of
   MBody extend opens topdefs  -> failure x
   MWith id opens  -> failure x
   MReuse id  -> failure x
+  MUnion includeds  -> failure x
 
 
 transExtend :: Extend -> Result
@@ -95,6 +96,12 @@ transQualOpen x = case x of
   QOInterface  -> failure x
 
 
+transIncluded :: Included -> Result
+transIncluded x = case x of
+  IAll id  -> failure x
+  ISome id ids  -> failure x
+
+
 transDef :: Def -> Result
 transDef x = case x of
   DDecl ids exp  -> failure x
@@ -209,6 +216,8 @@ transExp x = case x of
   EConcat exp0 exp  -> failure x
   EGlue exp0 exp  -> failure x
   ELet locdefs exp  -> failure x
+  ELetb locdefs exp  -> failure x
+  EWhere exp locdefs  -> failure x
   EEqs equations  -> failure x
   ELString lstring  -> failure x
   ELin id  -> failure x

src/GF/Source/SourceToGrammar.hs

@@ -76,6 +76,11 @@ transModDef x = case x of
         return (id',GM.ModMod (GM.Module mtyp' mstat' flags' extends' opens' defs'))
       MReuse _ -> do
         return (id', GM.ModMod (GM.Module mtyp' mstat' [] Nothing [] NT))
+      MUnion imps -> do
+        imps' <- mapM transIncluded imps        
+        return (id', 
+          GM.ModMod (GM.Module (GM.MTUnion mtyp' imps') mstat' [] Nothing [] NT))
+  
       MWith m opens -> do
         m'     <- transIdent m
         opens' <- mapM transOpen opens 
@@ -154,6 +159,12 @@ transQualOpen x = case x of
   QOInterface  -> return GM.OQInterface
   QOIncompl  -> return GM.OQIncomplete
 
+transIncluded :: Included -> Err (Ident,[Ident])
+transIncluded x = case x of
+  IAll i  -> liftM (flip (curry id) []) $ transIdent i
+  ISome i ids  -> liftM2 (curry id) (transIdent i) (mapM transIdent ids)
+
+
 transAbsDef :: TopDef -> Err (Either [(Ident, G.Info)] [GO.Option])
 transAbsDef x = case x of
   DefCat catdefs -> do

src/Today.hs

@@ -1 +1 @@
-module Today where today = "Thu Feb 26 16:08:20 CET 2004"
+module Today where today = "Fri Feb 27 09:29:09 CET 2004"