mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 13:09:33 -06:00
65 lines
2.1 KiB
Haskell
65 lines
2.1 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- 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
|