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
|
module Modules where
import Ident
import Option
import Operations
import List
-- AR 29/4/2003
-- The same structure will be used in both source code and canonical.
-- The parameters tell what kind of data is involved.
-- Invariant: modules are stored in dependency order
data MGrammar i f a = MGrammar {modules :: [(i,ModInfo i f a)]}
deriving Show
data ModInfo i f a =
ModMainGrammar (MainGrammar i)
| ModMod (Module i f a)
deriving Show
data Module i f a = Module {
mtype :: ModuleType i ,
flags :: [f] ,
extends :: Maybe i ,
opens :: [OpenSpec i] ,
jments :: BinTree (i,a)
}
deriving Show
-- destructive update
--- dep order preserved since old cannot depend on new
updateMGrammar :: Ord i => MGrammar i f a -> MGrammar i f a -> MGrammar i f a
updateMGrammar old new = MGrammar $
[(i,m) | (i,m) <- os, notElem i (map fst ns)] ++ ns
where
os = modules old
ns = modules new
updateModule :: Ord i => Module i f t -> i -> t -> Module i f t
updateModule (Module mt fs me ops js) i t =
Module mt fs me ops (updateTree (i,t) js)
data MainGrammar i = MainGrammar {
mainAbstract :: i ,
mainConcretes :: [MainConcreteSpec i]
}
deriving Show
data MainConcreteSpec i = MainConcreteSpec {
concretePrintname :: i ,
concreteName :: i ,
transferIn :: Maybe (OpenSpec i) , -- if there is an in-transfer
transferOut :: Maybe (OpenSpec i) -- if there is an out-transfer
}
deriving Show
data OpenSpec i = OSimple i | OQualif i i
deriving (Eq,Show)
openedModule :: OpenSpec i -> i
openedModule o = case o of
OSimple m -> m
OQualif _ m -> m
-- initial dependency list
depPathModule :: Ord i => Module i f a -> [OpenSpec i]
depPathModule m = fors m ++ exts m ++ opens m where
fors m = case mtype m of
MTTransfer i j -> [i,j]
MTConcrete i -> [OSimple i]
_ -> []
exts m = map OSimple $ maybe [] return $ extends m
-- all modules that a module extends, directly or indirectly
allExtends :: (Show i,Ord i) => MGrammar i f a -> i -> [i]
allExtends gr i = case lookupModule gr i of
Ok (ModMod m) -> case extends m of
Just i1 -> i : allExtends gr i1
_ -> [i]
_ -> []
-- initial search path: the nonqualified dependencies
searchPathModule :: Ord i => Module i f a -> [i]
searchPathModule m = [i | OSimple i <- depPathModule m]
-- a new module can safely be added to the end, since nothing old can depend on it
addModule :: Ord i =>
MGrammar i f a -> i -> ModInfo i f a -> MGrammar i f a
addModule gr name mi = MGrammar $ (modules gr ++ [(name,mi)])
emptyMGrammar :: MGrammar i f a
emptyMGrammar = MGrammar []
-- we store the module type with the identifier
data IdentM i = IdentM {
identM :: i ,
typeM :: ModuleType i
}
deriving (Eq,Show)
-- encoding the type of the module
data ModuleType i =
MTAbstract
| MTTransfer (OpenSpec i) (OpenSpec i)
| MTResource
| MTResourceInt
| MTResourceImpl i
| MTConcrete i
| MTConcreteInt i i
| MTConcreteImpl i i i
| MTReuse i
deriving (Eq,Show)
typeOfModule mi = case mi of
ModMod m -> mtype m
isResourceModule mi = case typeOfModule mi of
MTResource -> True
MTReuse _ -> True
MTResourceInt -> True
MTResourceImpl _ -> True
_ -> False
abstractOfConcrete :: (Show i, Eq i) => MGrammar i f a -> i -> Err i
abstractOfConcrete gr c = do
m <- lookupModule gr c
case m of
ModMod n -> case mtype n of
MTConcrete a -> return a
_ -> Bad $ "expected concrete" +++ show c
_ -> Bad $ "expected concrete" +++ show c
abstractModOfConcrete :: (Show i, Eq i) =>
MGrammar i f a -> i -> Err (Module i f a)
abstractModOfConcrete gr c = do
a <- abstractOfConcrete gr c
m <- lookupModule gr a
case m of
ModMod n -> return n
_ -> Bad $ "expected abstract" +++ show c
-- the canonical file name
--- canonFileName s = prt s ++ ".gfc"
lookupModule :: (Show i,Eq i) => MGrammar i f a -> i -> Err (ModInfo i f a)
lookupModule gr m = case lookup m (modules gr) of
Just i -> return i
_ -> Bad $ "unknown module" +++ show m
+++ "among" +++ unwords (map (show . fst) (modules gr)) ---- debug
lookupModuleType :: (Show i,Eq i) => MGrammar i f a -> i -> Err (ModuleType i)
lookupModuleType gr m = do
mi <- lookupModule gr m
return $ typeOfModule mi
lookupInfo :: (Show i, Ord i) => Module i f a -> i -> Err a
lookupInfo mo i = lookupTree show i (jments mo)
isModAbs m = case mtype m of
MTAbstract -> True
_ -> False
isModRes m = case mtype m of
MTResource -> True
_ -> False
isModCnc m = case mtype m of
MTConcrete _ -> True
_ -> False
sameMType m n = case (m,n) of
(MTConcrete _, MTConcrete _) -> True
_ -> m == n
|
