1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
|
----------------------------------------------------------------------
-- |
-- Module : Refresh
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:22:27 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.6 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Grammar.Refresh (refreshTerm, refreshTermN,
refreshModule
) where
import GF.Data.Operations
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Infra.Modules
import GF.Grammar.Macros
import Control.Monad
refreshTerm :: Term -> Err Term
refreshTerm = refreshTermN 0
refreshTermN :: Int -> Term -> Err Term
refreshTermN i e = liftM snd $ refreshTermKN i e
refreshTermKN :: Int -> Term -> Err (Int,Term)
refreshTermKN i e = liftM (\ (t,(_,i)) -> (i,t)) $
appSTM (refresh e) (initIdStateN i)
refresh :: Term -> STM IdState Term
refresh e = case e of
Vr x -> liftM Vr (lookVar x)
Abs x b -> liftM2 Abs (refVarPlus x) (refresh b)
Prod x a b -> do
a' <- refresh a
x' <- refVar x
b' <- refresh b
return $ Prod x' a' b'
Let (x,(mt,a)) b -> do
a' <- refresh a
mt' <- case mt of
Just t -> refresh t >>= (return . Just)
_ -> return mt
x' <- refVar x
b' <- refresh b
return (Let (x',(mt',a')) b')
R r -> liftM R $ refreshRecord r
ExtR r s -> liftM2 ExtR (refresh r) (refresh s)
T i cc -> liftM2 T (refreshTInfo i) (mapM refreshCase cc)
_ -> composOp refresh e
refreshCase :: (Patt,Term) -> STM IdState (Patt,Term)
refreshCase (p,t) = liftM2 (,) (refreshPatt p) (refresh t)
refreshPatt p = case p of
PV x -> liftM PV (refVar x)
PC c ps -> liftM (PC c) (mapM refreshPatt ps)
PP q c ps -> liftM (PP q c) (mapM refreshPatt ps)
PR r -> liftM PR (mapPairsM refreshPatt r)
PT t p' -> liftM2 PT (refresh t) (refreshPatt p')
PAs x p' -> liftM2 PAs (refVar x) (refreshPatt p')
PSeq p' q' -> liftM2 PSeq (refreshPatt p') (refreshPatt q')
PAlt p' q' -> liftM2 PAlt (refreshPatt p') (refreshPatt q')
PRep p' -> liftM PRep (refreshPatt p')
PNeg p' -> liftM PNeg (refreshPatt p')
_ -> return p
refreshRecord r = case r of
[] -> return r
(x,(mt,a)):b -> do
a' <- refresh a
mt' <- case mt of
Just t -> refresh t >>= (return . Just)
_ -> return mt
b' <- refreshRecord b
return $ (x,(mt',a')) : b'
refreshTInfo i = case i of
TTyped t -> liftM TTyped $ refresh t
TComp t -> liftM TComp $ refresh t
TWild t -> liftM TWild $ refresh t
_ -> return i
-- for abstract syntax
refreshEquation :: Equation -> Err ([Patt],Term)
refreshEquation pst = err Bad (return . fst) (appSTM (refr pst) initIdState) where
refr (ps,t) = liftM2 (,) (mapM refreshPatt ps) (refresh t)
-- for concrete and resource in grammar, before optimizing
refreshGrammar :: SourceGrammar -> Err SourceGrammar
refreshGrammar = liftM (MGrammar . snd) . foldM refreshModule (0,[]) . modules
refreshModule :: (Int,[SourceModule]) -> SourceModule -> Err (Int,[SourceModule])
refreshModule (k,ms) mi@(i,m) = case m of
ModMod mo@(Module mt fs st me ops js) | (isModCnc mo || isModRes mo) -> do
(k',js') <- foldM refreshRes (k,[]) $ tree2list js
return (k', (i, ModMod(Module mt fs st me ops (buildTree js'))) : ms)
_ -> return (k, mi:ms)
where
refreshRes (k,cs) ci@(c,info) = case info of
ResOper ptyp (Yes trm) -> do ---- refresh ptyp
(k',trm') <- refreshTermKN k trm
return $ (k', (c, ResOper ptyp (Yes trm')):cs)
CncCat mt (Yes trm) pn -> do ---- refresh mt, pn
(k',trm') <- refreshTermKN k trm
return $ (k', (c, CncCat mt (Yes trm') pn):cs)
CncFun mt (Yes trm) pn -> do ---- refresh pn
(k',trm') <- refreshTermKN k trm
return $ (k', (c, CncFun mt (Yes trm') pn):cs)
_ -> return (k, ci:cs)
|
