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
|
module Extend where
import Grammar
import Ident
import PrGrammar
import Modules
import Update
import Macros
import Operations
import Monad
-- AR 14/5/2003 -- 11/11
-- The top-level function $extendModule$
-- extends a module symbol table by indirections to the module it extends
extendModule :: [SourceModule] -> SourceModule -> Err SourceModule
extendModule ms (name,mod) = case mod of
ModMod (Module mt st fs me ops js) -> do
{- --- building the {s : Str} lincat from js0
js <- case mt of
MTConcrete a -> do
ModMod ma <- lookupModule (MGrammar ms) a
let cats = [c | (c,AbsCat _ _) <- tree2list $ jments ma]
jscs = [(c,CncCat (yes defLinType) nope nope) | c <- cats]
return $ updatesTreeNondestr jscs js0
_ -> return js0
-}
case me of
-- if the module is an extension of another one...
Just n -> do
(m0,isCompl) <- do
m <- lookupModMod (MGrammar ms) n
-- test that the module types match, and find out if the old is complete
testErr (sameMType (mtype m) mt)
("illegal extension type to module" +++ prt name)
return (m,isCompleteModule m)
-- build extension in a way depending on whether the old module is complete
js1 <- extendMod isCompl n (jments m0) js
-- if incomplete, throw away extension information
let me' = if isCompl then me else Nothing
return $ (name,ModMod (Module mt st fs me' ops js1))
-- if the module is not an extension, just return it
_ -> return (name,mod)
-- 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 -> BinTree (Ident,Info) -> BinTree (Ident,Info) ->
Err (BinTree (Ident,Info))
extendMod isCompl name old new = foldM try new $ tree2list old where
try t i@(c,_) = errIn ("constant" +++ prt c) $
tryInsert (extendAnyInfo isCompl name) indirIf t i
indirIf = if isCompl then indirInfo name else id
indirInfo :: Ident -> Info -> Info
indirInfo n info = AnyInd b n' where
(b,n') = case info of
ResValue _ -> (True,n)
ResParam _ -> (True,n)
AbsFun _ (Yes EData) -> (True,n)
AnyInd b k -> (b,k)
_ -> (False,n) ---- canonical in Abs
perhIndir :: Ident -> Perh a -> Perh a
perhIndir n p = case p of
Yes _ -> May n
_ -> p
extendAnyInfo :: Bool -> Ident -> Info -> Info -> Err Info
extendAnyInfo isc n i j = errIn ("building extension for" +++ prt n) $ case (i,j) of
(AbsCat mc1 mf1, AbsCat mc2 mf2) ->
liftM2 AbsCat (updn mc1 mc2) (updn mf1 mf2) --- add cstrs
(AbsFun mt1 md1, AbsFun mt2 md2) ->
liftM2 AbsFun (updn mt1 mt2) (updn md1 md2) --- add defs
(ResParam mt1, ResParam mt2) ->
liftM ResParam $ updn mt1 mt2
(ResValue mt1, ResValue mt2) ->
liftM ResValue $ updn mt1 mt2
(ResOper mt1 m1, ResOper mt2 m2) -> ---- extendResOper n mt1 m1 mt2 m2
liftM2 ResOper (updn mt1 mt2) (updn m1 m2)
(CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) ->
liftM3 CncCat (updn mc1 mc2) (updn mf1 mf2) (updn mp1 mp2)
(CncFun m mt1 md1, CncFun _ mt2 md2) ->
liftM2 (CncFun m) (updn mt1 mt2) (updn md1 md2)
---- (AnyInd _ _, ResOper _ _) -> return j ----
_ -> Bad $ "cannot unify information in" ++++ show i ++++ "and" ++++ show j
where
updn = if isc then (updatePerhaps n) else (updatePerhapsHard n)
{- ---- no more needed: this is done in Rebuild
-- opers declared in an interface and defined in an instance are a special case
extendResOper n mt1 m1 mt2 m2 = case (m1,m2) of
(Nope,_) -> return $ ResOper (strip mt1) m2
_ -> liftM2 ResOper (updatePerhaps n mt1 mt2) (updatePerhaps n m1 m2)
where
strip (Yes t) = Yes $ strp t
strip m = m
strp t = case t of
Q _ c -> Vr c
QC _ c -> Vr c
_ -> composSafeOp strp t
-}
|
