summaryrefslogtreecommitdiff
path: root/src/GF/Compile/RemoveLiT.hs
diff options
context:
space:
mode:
authoraarne <aarne@cs.chalmers.se>2008-06-25 16:54:35 +0000
committeraarne <aarne@cs.chalmers.se>2008-06-25 16:54:35 +0000
commite9e80fc389365e24d4300d7d5390c7d833a96c50 (patch)
treef0b58473adaa670bd8fc52ada419d8cad470ee03 /src/GF/Compile/RemoveLiT.hs
parentb96b36f43de3e2f8b58d5f539daa6f6d47f25870 (diff)
changed names of resource-1.3; added a note on homepage on release
Diffstat (limited to 'src/GF/Compile/RemoveLiT.hs')
-rw-r--r--src/GF/Compile/RemoveLiT.hs64
1 files changed, 64 insertions, 0 deletions
diff --git a/src/GF/Compile/RemoveLiT.hs b/src/GF/Compile/RemoveLiT.hs
new file mode 100644
index 000000000..d06b80400
--- /dev/null
+++ b/src/GF/Compile/RemoveLiT.hs
@@ -0,0 +1,64 @@
+----------------------------------------------------------------------
+-- |
+-- Module : RemoveLiT
+-- Maintainer : AR
+-- Stability : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:45 $
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.6 $
+--
+-- remove obsolete (Lin C) expressions before doing anything else. AR 21/6/2003
+--
+-- What the program does is replace the occurrences of Lin C with the actual
+-- definition T given in lincat C = T ; with {s : Str} if no lincat is found.
+-- The procedure is uncertain, if T contains another Lin.
+-----------------------------------------------------------------------------
+
+module GF.Compile.RemoveLiT (removeLiT) where
+
+import GF.Grammar.Grammar
+import GF.Infra.Ident
+import GF.Infra.Modules
+import GF.Grammar.Macros
+import GF.Grammar.Lookup
+import GF.Grammar.Predef
+
+import GF.Data.Operations
+
+import Control.Monad
+
+removeLiT :: SourceGrammar -> Err SourceGrammar
+removeLiT gr = liftM MGrammar $ mapM (remlModule gr) (modules gr)
+
+remlModule :: SourceGrammar -> (Ident,SourceModInfo) -> Err (Ident,SourceModInfo)
+remlModule gr mi@(name,mod) = case mod of
+ ModMod mo -> do
+ js1 <- mapMTree (remlResInfo gr) (jments mo)
+ let mod2 = ModMod $ mo {jments = js1}
+ return $ (name,mod2)
+ _ -> return mi
+
+remlResInfo :: SourceGrammar -> (Ident,Info) -> Err (Ident,Info)
+remlResInfo gr mi@(i,info) = case info of
+ ResOper pty ptr -> liftM ((,) i) $ liftM2 ResOper (ren pty) (ren ptr)
+ CncCat pty ptr ppr -> liftM ((,) i) $ liftM3 CncCat (ren pty) (ren ptr) (ren ppr)
+ CncFun mt ptr ppr -> liftM ((,) i) $ liftM2 (CncFun mt) (ren ptr) (ren ppr)
+ _ -> return mi
+ where
+ ren = remlPerh gr
+
+remlPerh gr pt = case pt of
+ Yes t -> liftM Yes $ remlTerm gr t
+ _ -> return pt
+
+remlTerm :: SourceGrammar -> Term -> Err Term
+remlTerm gr trm = case trm of
+ LiT c -> look c >>= remlTerm gr
+ _ -> composOp (remlTerm gr) trm
+ where
+ look c = err (const $ return defLinType) return $ lookupLincat gr m c
+ m = case [cnc | (cnc,ModMod m) <- modules gr, isModCnc m] of
+ cnc:_ -> cnc -- actually there is always exactly one
+ _ -> cCNC