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
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
|
----------------------------------------------------------------------
-- |
-- Module : Update
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/30 18:39:44 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.8 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Compile.Update (buildAnyTree, extendModule, rebuildModule) where
import GF.Infra.Ident
import GF.Grammar.Grammar
import GF.Grammar.Printer
import GF.Grammar.Lookup
import GF.Infra.Modules
import GF.Infra.Option
import GF.Data.Operations
import Data.List
import qualified Data.Map as Map
import Control.Monad
import Text.PrettyPrint
-- | combine a list of definitions into a balanced binary search tree
buildAnyTree :: Ident -> [(Ident,Info)] -> Err (BinTree Ident Info)
buildAnyTree m = go Map.empty
where
go map [] = return map
go map ((c,j):is) = do
case Map.lookup c map of
Just i -> case unifyAnyInfo m i j of
Ok k -> go (Map.insert c k map) is
Bad _ -> fail $ render (text "cannot unify the informations" $$
nest 4 (ppJudgement Qualified (c,i)) $$
text "and" $+$
nest 4 (ppJudgement Qualified (c,j)) $$
text "in module" <+> ppIdent m)
Nothing -> go (Map.insert c j map) is
extendModule :: SourceGrammar -> SourceModule -> Err SourceModule
extendModule gr (name,m)
---- Just to allow inheritance in incomplete concrete (which are not
---- compiled anyway), extensions are not built for them.
---- Should be replaced by real control. AR 4/2/2005
| mstatus m == MSIncomplete && isModCnc m = return (name,m)
| otherwise = do m' <- foldM extOne m (extend m)
return (name,m')
where
extOne mo (n,cond) = do
m0 <- lookupModule gr n
-- test that the module types match, and find out if the old is complete
testErr (sameMType (mtype m) (mtype mo))
("illegal extension type to module" +++ showIdent name)
let isCompl = isCompleteModule m0
-- build extension in a way depending on whether the old module is complete
js1 <- extendMod gr isCompl (n, isInherited cond) name (jments m0) (jments mo)
-- if incomplete, throw away extension information
return $
if isCompl
then mo {jments = js1}
else mo {extend = filter ((/=n) . fst) (extend mo)
,mexdeps= nub (n : mexdeps mo)
,jments = js1
}
-- | rebuilding instance + interface, and "with" modules, prior to renaming.
-- AR 24/10/2003
rebuildModule :: SourceGrammar -> SourceModule -> Err SourceModule
rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do
---- deps <- moduleDeps ms
---- is <- openInterfaces deps i
let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005
mi' <- case mw of
-- add the information given in interface into an instance module
Nothing -> do
testErr (null is || mstatus mi == MSIncomplete)
("module" +++ showIdent i +++
"has open interfaces and must therefore be declared incomplete")
case mt of
MTInstance i0 -> do
m1 <- lookupModule gr i0
testErr (isModRes m1) ("interface expected instead of" +++ showIdent i0)
js' <- extendMod gr False (i0,const True) i (jments m1) (jments mi)
--- to avoid double inclusions, in instance I of I0 = J0 ** ...
case extends mi of
[] -> return $ replaceJudgements mi js'
j0s -> do
m0s <- mapM (lookupModule gr) j0s
let notInM0 c _ = all (not . isInBinTree c . jments) m0s
let js2 = filterBinTree notInM0 js'
return $ (replaceJudgements mi js2)
{positions = Map.union (positions m1) (positions mi)}
_ -> return mi
-- add the instance opens to an incomplete module "with" instances
Just (ext,incl,ops) -> do
let (infs,insts) = unzip ops
let stat' = ifNull MSComplete (const MSIncomplete)
[i | i <- is, notElem i infs]
testErr (stat' == MSComplete || stat == MSIncomplete)
("module" +++ showIdent i +++ "remains incomplete")
ModInfo mt0 _ fs me' _ ops0 _ js ps0 <- lookupModule gr ext
let ops1 = nub $
ops_ ++ -- N.B. js has been name-resolved already
[OQualif i j | (i,j) <- ops] ++
[o | o <- ops0, notElem (openedModule o) infs] ++
[OQualif i i | i <- insts] ++
[OSimple i | i <- insts]
--- check if me is incomplete
let fs1 = fs `addOptions` fs_ -- new flags have priority
let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c]
let js1 = buildTree (tree2list js_ ++ js0)
let ps1 = Map.union ps_ ps0
let med1= nub (ext : infs ++ insts ++ med_)
return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 js1 ps1
return (i,mi')
-- | When extending a complete module: new information is inserted,
-- and the process is interrupted if unification fails.
-- If the extended module is incomplete, its judgements are just copied.
extendMod :: SourceGrammar ->
Bool -> (Ident,Ident -> Bool) -> Ident ->
BinTree Ident Info -> BinTree Ident Info ->
Err (BinTree Ident Info)
extendMod gr isCompl (name,cond) base old new = foldM try new $ Map.toList old
where
try new (c,i)
| not (cond c) = return new
| otherwise = case Map.lookup c new of
Just j -> case unifyAnyInfo name i j of
Ok k -> return $ updateTree (c,k) new
Bad _ -> do (base,j) <- case j of
AnyInd _ m -> lookupOrigInfo gr m c
_ -> return (base,j)
(name,i) <- case i of
AnyInd _ m -> lookupOrigInfo gr m c
_ -> return (name,i)
fail $ render (text "cannot unify the information" $$
nest 4 (ppJudgement Qualified (c,i)) $$
text "in module" <+> ppIdent name <+> text "with" $$
nest 4 (ppJudgement Qualified (c,j)) $$
text "in module" <+> ppIdent base)
Nothing-> if isCompl
then return $ updateTree (c,indirInfo name i) new
else return $ updateTree (c,i) new
indirInfo :: Ident -> Info -> Info
indirInfo n info = AnyInd b n' where
(b,n') = case info of
ResValue _ -> (True,n)
ResParam _ _ -> (True,n)
AbsFun _ _ Nothing -> (True,n)
AnyInd b k -> (b,k)
_ -> (False,n) ---- canonical in Abs
unifyAnyInfo :: Ident -> Info -> Info -> Err Info
unifyAnyInfo m i j = case (i,j) of
(AbsCat mc1 mf1, AbsCat mc2 mf2) ->
liftM2 AbsCat (unifMaybe mc1 mc2) (unifConstrs mf1 mf2) -- adding constrs
(AbsFun mt1 ma1 md1, AbsFun mt2 ma2 md2) ->
liftM3 AbsFun (unifMaybe mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) -- adding defs
(ResParam mt1 mv1, ResParam mt2 mv2) ->
liftM2 ResParam (unifMaybe mt1 mt2) (unifMaybe mv1 mv2)
(ResValue t1, ResValue t2)
| t1==t2 -> return (ResValue t1)
| otherwise -> fail ""
(_, ResOverload ms t) | elem m ms ->
return $ ResOverload ms t
(ResOper mt1 m1, ResOper mt2 m2) ->
liftM2 ResOper (unifMaybe mt1 mt2) (unifMaybe m1 m2)
(CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) ->
liftM3 CncCat (unifMaybe mc1 mc2) (unifMaybe mf1 mf2) (unifMaybe mp1 mp2)
(CncFun m mt1 md1, CncFun _ mt2 md2) ->
liftM2 (CncFun m) (unifMaybe mt1 mt2) (unifMaybe md1 md2) ---- adding defs
(AnyInd b1 m1, AnyInd b2 m2) -> do
testErr (b1 == b2) $ "indirection status"
testErr (m1 == m2) $ "different sources of indirection"
return i
_ -> fail "informations"
-- | this is what happens when matching two values in the same module
unifMaybe :: Eq a => Maybe a -> Maybe a -> Err (Maybe a)
unifMaybe Nothing Nothing = return Nothing
unifMaybe (Just p1) Nothing = return (Just p1)
unifMaybe Nothing (Just p2) = return (Just p2)
unifMaybe (Just p1) (Just p2)
| p1==p2 = return (Just p1)
| otherwise = fail ""
unifAbsArrity :: Maybe Int -> Maybe Int -> Err (Maybe Int)
unifAbsArrity Nothing Nothing = return Nothing
unifAbsArrity (Just a ) Nothing = return (Just a )
unifAbsArrity Nothing (Just a ) = return (Just a )
unifAbsArrity (Just a1) (Just a2)
| a1==a2 = return (Just a1)
| otherwise = fail ""
unifAbsDefs :: Maybe [Equation] -> Maybe [Equation] -> Err (Maybe [Equation])
unifAbsDefs Nothing Nothing = return Nothing
unifAbsDefs (Just _ ) Nothing = fail ""
unifAbsDefs Nothing (Just _ ) = fail ""
unifAbsDefs (Just xs) (Just ys) = return (Just (xs ++ ys))
unifConstrs :: Maybe [Term] -> Maybe [Term] -> Err (Maybe [Term])
unifConstrs p1 p2 = case (p1,p2) of
(Nothing, _) -> return p2
(_, Nothing) -> return p1
(Just bs, Just ds) -> return $ Just $ bs ++ ds
|
