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
|
----------------------------------------------------------------------
-- |
-- Module : Extend
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/30 21:08:14 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.18 $
--
-- AR 14\/5\/2003 -- 11\/11
-- 4/12/2007 this module is still very very messy... ----
--
-- The top-level function 'extendModule'
-- extends a module symbol table by indirections to the module it extends
-----------------------------------------------------------------------------
module GF.Devel.Compile.Extend (
extendModule
) where
import GF.Devel.Grammar.Modules
import GF.Devel.Grammar.Judgements
import GF.Devel.Grammar.MkJudgements
import GF.Devel.Grammar.PrGF
import GF.Devel.Grammar.Lookup
import GF.Devel.Grammar.Macros
import GF.Infra.Ident
import GF.Data.Operations
import Data.List (nub)
import Data.Map
import Control.Monad
extendModule :: GF -> SourceModule -> Err SourceModule
extendModule gf nmo0 = do
(name,mo) <- rebuildModule gf nmo0
case mtype mo of
---- 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
MTConcrete _ | not (isCompleteModule mo) -> return (name,mo)
_ -> do
mo' <- foldM (extOne name) mo (mextends mo)
return (name, mo')
where
extOne name mo (n,cond) = do
(m0,isCompl) <- do
m <- lookupModule gf n
-- test that the module types match, and find out if the old is complete
testErr True ---- (mtype mo == mtype m)
("illegal extension type to module" +++ prt name)
return (m, isCompleteModule m)
-- build extension in a way depending on whether the old module is complete
js0 <- extendMod isCompl n (isInherited cond) name (mjments m0) (mjments mo)
-- if incomplete, throw away extension information
let me' = mextends mo ----if isCompl then es else (filter ((/=n) . fst) es)
return $ mo {mextends = me', mjments = js0}
-- | 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 :: Bool -> Ident -> (Ident -> Bool) -> Ident ->
MapJudgement -> MapJudgement -> Err MapJudgement
extendMod isCompl name cond base old new = foldM try new $ assocs old where
try t i@(c,_) | not (cond c) = return t
try t i@(c,_) = errIn ("constant" +++ prt c) $
tryInsert (extendAnyInfo isCompl name base) indirIf t i
indirIf = if isCompl then indirInfo name else id
indirInfo :: Ident -> JEntry -> JEntry
indirInfo n info = Right $ case info of
Right (k,b) -> (k,b) -- original link is passed
Left j -> (n,isConstructor j)
extendAnyInfo :: Bool -> Ident -> Ident -> JEntry -> JEntry -> Err JEntry
extendAnyInfo isc n o i j =
errIn ("building extension for" +++ prt n +++ "in" +++ prt o) $ case (i,j) of
(Left j1,Left j2) -> liftM Left $ unifyJudgement j1 j2
(Right (m1,b1), Right (m2,b2)) -> do
testErr (b1 == b2) "inconsistent indirection status"
testErr (m1 == m2) $
"different sources of inheritance:" +++ show m1 +++ show m2
return i
_ -> Bad $ "cannot unify information in"---- ++++ prt i ++++ "and" ++++ prt j
tryInsert :: Ord a => (b -> b -> Err b) -> (b -> b) ->
Map a b -> (a,b) -> Err (Map a b)
tryInsert unif indir tree z@(x, info) = case Data.Map.lookup x tree of
Just info0 -> do
info1 <- unif info info0
return $ insert x info1 tree
_ -> return $ insert x (indir info) tree
-- | rebuilding instance + interface, and "with" modules, prior to renaming.
-- AR 24/10/2003
rebuildModule :: GF -> SourceModule -> Err SourceModule
rebuildModule gr mo@(i,mi) = case mtype mi of
MTInstance i0 -> do
m1 <- lookupModule gr i0
testErr (mtype m1 == MTInterface)
("interface expected as type of" +++ prt i0)
js' <- extendMod False i0 (const True) i (mjments m1) (mjments mi)
--- to avoid double inclusions, in instance I of I0 = J0 ** ...
case mextends mi of
[] -> return $ (i,mi {mjments = js'})
j0s -> do
m0s <- mapM (lookupModule gr . fst) j0s ---- restricted?? 12/2007
let notInM0 c _ = all (notMember c . mjments) m0s
let js2 = filterWithKey notInM0 js'
return $ (i,mi {mjments = js2})
-- add the instance opens to an incomplete module "with" instances
-- ModWith mt stat ext me ops -> do
-- ModWith (Module mt stat fs_ me ops_ js_) (ext,incl) ops -> do
_ -> case minstances mi of
[((ext,incl),ops)] -> do
let infs = Prelude.map fst ops
let stat' = Prelude.null [i | (_,i) <- minterfaces mi, notElem i infs]
testErr stat' ("module" +++ prt i +++ "remains incomplete")
-- Module mt0 _ fs me' ops0 js <- lookupModMod gr ext
mo0 <- lookupModule gr ext
let ops1 = nub $
mopens mi ++ -- N.B. mo0 has been name-resolved already
ops ++
[(n,o) | (n,o) <- mopens mo0, notElem o infs] ++
[(i,i) | i <- Prelude.map snd ops] ----
---- ++ [oSimple i | i <- map snd ops] ----
--- check if me is incomplete
let fs1 = union (mflags mi) (mflags mo0) -- new flags have priority
let js0 = [ci | ci@(c,_) <- assocs (mjments mo0), isInherited incl c]
let js1 = fromList (assocs (mjments mi) ++ js0)
return $ (i,mo0 {
mflags = fs1,
mextends = mextends mi,
mopens = ops1,
mjments = js1
})
_ -> return (i,mi)
|
