GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3

src-3.0/GF/Compile/MkUnion.hs

@@ -0,0 +1,83 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : MkUnion
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:39 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.7 $
+--
+-- building union of modules.
+-- AR 1\/3\/2004 --- OBSOLETE 15\/9\/2004 with multiple inheritance
+-----------------------------------------------------------------------------
+
+module GF.Compile.MkUnion (makeUnion) where
+
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Infra.Modules
+import GF.Grammar.Macros
+import GF.Grammar.PrGrammar
+
+import GF.Data.Operations
+import GF.Infra.Option
+
+import Data.List
+import Control.Monad
+
+makeUnion :: SourceGrammar -> Ident -> ModuleType Ident -> [(Ident,[Ident])] ->
+             Err SourceModule
+makeUnion gr m ty imps = do
+  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
+