summaryrefslogtreecommitdiff
path: root/src/GF/Compile/MkUnion.hs
diff options
context:
space:
mode:
authoraarne <aarne@cs.chalmers.se>2008-06-25 16:43:48 +0000
committeraarne <aarne@cs.chalmers.se>2008-06-25 16:43:48 +0000
commitb96b36f43de3e2f8b58d5f539daa6f6d47f25870 (patch)
tree0992334be13cec6538a1dea22fbbf26ad6bdf224 /src/GF/Compile/MkUnion.hs
parentfe367412e0aeb4ad5c02de68e6eca382e0f96984 (diff)
removed src for 2.9
Diffstat (limited to 'src/GF/Compile/MkUnion.hs')
-rw-r--r--src/GF/Compile/MkUnion.hs83
1 files changed, 0 insertions, 83 deletions
diff --git a/src/GF/Compile/MkUnion.hs b/src/GF/Compile/MkUnion.hs
deleted file mode 100644
index b4b1f40c8..000000000
--- a/src/GF/Compile/MkUnion.hs
+++ /dev/null
@@ -1,83 +0,0 @@
-----------------------------------------------------------------------
--- |
--- 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
-