From c3796cf04ca77a8ded570678291fd65d5e17ed0f Mon Sep 17 00:00:00 2001
From: aarne <unknown>
Date: Mon, 1 Mar 2004 21:03:25 +0000
Subject: [PATCH] Unions: a first version.

---
 src/GF/Compile/MkUnion.hs | 56 +++++++++++++++++++++++++++++++++++++--
 src/Today.hs              |  2 +-
 2 files changed, 55 insertions(+), 3 deletions(-)

diff --git a/src/GF/Compile/MkUnion.hs b/src/GF/Compile/MkUnion.hs
index f612b92b6..e6260e6dc 100644
--- a/src/GF/Compile/MkUnion.hs
+++ b/src/GF/Compile/MkUnion.hs
@@ -7,13 +7,65 @@ import Macros
 import PrGrammar
 
 import Operations
+import Option
 
+import List
 import Monad
 
 -- building union of modules
--- AR 21/8/2002 -- 22/6/2003 for GF with modules
+-- AR 1/3/2004
 
 makeUnion :: SourceGrammar -> Ident -> ModuleType Ident -> [(Ident,[Ident])] ->
              Err SourceModule
 makeUnion gr m ty imps = do
-  Bad "Sorry: unions not yet implemented"
+  ms    <- mapM (lookupModMod gr . fst) imps
+  typ   <- return ty ---- getTyp ms
+  ext   <- getExt [i | Just i <- map extends ms]
+  ops   <- return $ nub $ concatMap opens ms
+  flags <- return $ concatMap flags ms
+  js    <- liftM (buildTree . concat) $ mapM getJments imps
+  return $ (m, ModMod (Module typ MSComplete flags ext ops js))
+
+ where
+   getExt es = case es of
+     [] -> return Nothing
+     i:is -> if all (==i) is then return (Just i) 
+               else Bad "different extended modules in union forbidden"
+   getJments (i,fs) = do
+     m  <- lookupModMod gr i
+     let js = jments m
+     if null fs 
+       then 
+         return (map (unqual i) $ tree2list js) 
+       else do
+         ds <- mapM (flip justLookupTree js) fs
+         return $ map (unqual i) $ zip fs ds
+
+   unqual i (f,d) = curry id f $ case d of
+     AbsCat  pty pts -> AbsCat (qualCo pty) (qualPs pts)
+     AbsFun  pty pt -> AbsFun (qualP pty) (qualP pt)
+     AbsTrans t     -> AbsTrans $ qual t
+     ResOper pty pt -> ResOper (qualP pty) (qualP pt)
+     CncCat  pty pt pp -> CncCat (qualP pty) (qualP pt) (qualP pp)
+     CncFun  mp pt pp -> CncFun (qualLin mp) (qualP pt) (qualP pp) ---- mp
+     ResParam (Yes ps) -> ResParam (yes (map qualParam ps)) 
+     ResValue pty ->  ResValue (qualP pty)
+     _ -> d
+    where
+     qualP pt = case pt of
+       Yes t -> yes $ qual t
+       _ -> pt
+     qualPs pt = case pt of
+       Yes ts -> yes $ map qual ts
+       _ -> pt
+     qualCo pco = case pco of
+       Yes co -> yes $ [(x,qual t) | (x,t) <- co]
+       _ -> pco
+     qual t = case t of
+       Q m c  | m==i -> Cn c
+       QC m c | m==i -> Cn c
+       _ -> composSafeOp qual t
+     qualParam (p,co) = (p,[(x,qual t) | (x,t) <- co])
+     qualLin (Just (c,(co,t))) = (Just (c,([(x,qual t) | (x,t) <- co], qual t)))
+     qualLin Nothing = Nothing
+     
diff --git a/src/Today.hs b/src/Today.hs
index 521ca1186..b9a4cd59a 100644
--- a/src/Today.hs
+++ b/src/Today.hs
@@ -1 +1 @@
-module Today where today = "Fri Feb 27 09:29:09 CET 2004"
+module Today where today = "Mon Mar  1 10:50:38 CET 2004"