diff options
| author | aarne <aarne@cs.chalmers.se> | 2008-06-25 16:43:48 +0000 |
|---|---|---|
| committer | aarne <aarne@cs.chalmers.se> | 2008-06-25 16:43:48 +0000 |
| commit | b96b36f43de3e2f8b58d5f539daa6f6d47f25870 (patch) | |
| tree | 0992334be13cec6538a1dea22fbbf26ad6bdf224 /src/GF/Compile/MkUnion.hs | |
| parent | fe367412e0aeb4ad5c02de68e6eca382e0f96984 (diff) | |
removed src for 2.9
Diffstat (limited to 'src/GF/Compile/MkUnion.hs')
| -rw-r--r-- | src/GF/Compile/MkUnion.hs | 83 |
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 - |
