Merge.hs revision ad187062b0009820118c1b773a232e29b879a2fa
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
c797f343be2f3619bb1f5569753166ec49d27bdbChristian MaederModule : $Header$
10397bcc134edbcfbe3ae2c7ea4c6080036aae22Christian MaederDescription : union of signature parts
97018cf5fa25b494adffd7e9b4e87320dae6bf47Christian MaederCopyright : (c) Christian Maeder and Uni Bremen 2003-2005
c797f343be2f3619bb1f5569753166ec49d27bdbChristian MaederLicense : similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt
c797f343be2f3619bb1f5569753166ec49d27bdbChristian MaederMaintainer : Christian.Maeder@dfki.de
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaederStability : experimental
f3a94a197960e548ecd6520bb768cb0d547457bbChristian MaederPortability : portable
462ec4b2fa3e0e788eb60dcb4aebc518298f342cChristian Maedermerging parts of local environment
ad270004874ce1d0697fb30d7309f180553bb315Christian Maederimport qualified Data.Map as Map
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maederimport qualified Data.Set as Set
8b9fda012e5ee53b7b2320c0638896a0ff6e99f3Christian Maeder-- | merge together repeated or extended items
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maederclass Mergeable a where
8b9fda012e5ee53b7b2320c0638896a0ff6e99f3Christian Maeder merge :: a -> a -> Result a
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maederinstance (Ord a, PosItem a, Pretty a, Mergeable b)
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder => Mergeable (Map.Map a b) where
04dada28736b4a237745e92063d8bdd49a362debChristian Maeder merge = mergeMap id merge
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaederimproveDiag :: (PosItem a, Pretty a) => a -> Diagnosis -> Diagnosis
4ef2a978e66e2246ff0b7f00c77deb7aabb28b8eChristian MaederimproveDiag v d = d { diagString = let f:l = lines $ diagString d in
42c01284bba8d7c8d995c8dfb96ace57d28ed1bcTill Mossakowski unlines $ (f ++ " of '" ++ showDoc v "'") : l
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder , diagPos = getRange v
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaedermergeMap :: (Ord a, PosItem a, Pretty a) =>
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder (b -> b) -> (b -> b -> Result b)
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder -> Map.Map a b -> Map.Map a b -> Result (Map.Map a b)
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian MaedermergeMap e f m1 m2 = foldM ( \ m (k, v) ->
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder Nothing -> return $ Map.insert k (e v) m
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder let Result ds mu = f (e v) w
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder ns = map (improveDiag k) ds
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder in case mu of
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder Nothing -> Result ns $ Nothing
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder Just u -> Result ns $ Just $ Map.insert k u m)
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maederinstance Mergeable a => Mergeable (Maybe a) where
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder merge m1 m2 = case m1 of
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder Nothing -> return m2
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder Just v1 -> case m2 of
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder Nothing -> return m1
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder Just v2 -> do v <- merge v1 v2
462ec4b2fa3e0e788eb60dcb4aebc518298f342cChristian Maeder return $ Just v
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maederinstance Mergeable ClassInfo where
462ec4b2fa3e0e788eb60dcb4aebc518298f342cChristian Maeder merge = mergeA "super classes"
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maederinstance (Pretty a, Ord a) => Mergeable (AnyKind a) where
462ec4b2fa3e0e788eb60dcb4aebc518298f342cChristian Maeder merge = mergeA "super kinds"
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaedermergeTypeInfo :: TypeInfo -> TypeInfo -> Result TypeInfo
f4741f6b7da52b5417899c8fcbe4349b920b006eChristian MaedermergeTypeInfo t1 t2 =
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder do k <- merge (typeKind t1) $ typeKind t2
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder o <- merge (otherTypeKinds t1) $ otherTypeKinds t2
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder s <- merge (superTypes t1) $ superTypes t2
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder d <- mergeTypeDefn (typeDefn t1) $ typeDefn t2
462ec4b2fa3e0e788eb60dcb4aebc518298f342cChristian Maeder return $ TypeInfo k o s d
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaedermergeTypeDefn :: TypeDefn -> TypeDefn -> Result TypeDefn
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaedermergeTypeDefn d1 d2 =
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder case (d1, d2) of
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder (_, DatatypeDefn _) -> return d2
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder (PreDatatype, _) -> fail "expected data type definition"
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder (_, PreDatatype) -> return d1
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder (NoTypeDefn, _) -> return d2
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder (_, NoTypeDefn) -> return d1
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder (AliasTypeDefn s1, AliasTypeDefn s2) ->
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder do s <- mergeAlias s1 s2
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder return $ AliasTypeDefn s
462ec4b2fa3e0e788eb60dcb4aebc518298f342cChristian Maeder (_, _) -> mergeA "TypeDefn" d1 d2
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maederinstance Mergeable Vars where
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder merge = mergeA "variables for subtype definition"
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian MaedermergeAlias :: Type -> Type -> Result Type
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaedermergeAlias s1 s2 = if s1 == s2 then return s1
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder else fail $ "wrong type" ++ expected s1 s2
36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maederinstance Mergeable OpAttr where
36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder merge (UnitOpAttr t1 p1) (UnitOpAttr t2 p2) =
36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder do t <- mergeTerm Warning t1 t2
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder return $ UnitOpAttr t (p1 `appRange` p2)
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder merge a1 a2 = mergeA "attributes" a1 a2
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maederinstance Mergeable OpBrand where
36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder merge b1 b2 = return $ case (b1, b2) of
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder (Pred, _) -> Pred
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder (_, Pred) -> Pred
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder (Op, _) -> Op
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder (_, Op) -> Op
15bb922b665fcd44c6230a1202785d0c7890e90cChristian Maederinstance Mergeable OpDefn where
42c01284bba8d7c8d995c8dfb96ace57d28ed1bcTill Mossakowski merge d1 d2 = case (d1, d2) of
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder (NoOpDefn b1, NoOpDefn b2) -> do
04dada28736b4a237745e92063d8bdd49a362debChristian Maeder b <- merge b1 b2
76fa667489c5e0868ac68de9f0253ac10f73d0b5Christian Maeder return $ NoOpDefn b
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder (SelectData c1 s, SelectData c2 _) -> do
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder c <- merge c1 c2
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder return $ SelectData c s
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder (Definition b1 e1, Definition b2 e2) -> do
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder d <- mergeTerm Hint e1 e2
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder b <- merge b1 b2
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder return $ Definition b d
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder (NoOpDefn b1, Definition b2 e2) -> do
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder b <- merge b1 b2
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder return $ Definition b e2
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder (Definition b1 e1, NoOpDefn b2) -> do
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder b <- merge b1 b2
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder return $ Definition b e1
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder (ConstructData _, SelectData _ _) ->
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder fail "illegal selector as constructor redefinition"
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder (SelectData _ _, ConstructData _) ->
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder fail "illegal constructor as selector redefinition"
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder (ConstructData _, _) -> return d1
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder (_, ConstructData _) -> return d2
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder (SelectData _ _, _) -> return d1
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder (_, SelectData _ _) -> return d2
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maederinstance Eq a => Mergeable [a] where
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder merge l1 l2 = case l1 of
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder [] -> return l2
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder l3 <- merge l l2
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder return $ if any (e==) l2 then l3 else e : l3
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maederinstance Ord a => Mergeable (Set.Set a) where
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder merge s1 s2 = return $ Set.union s1 s2
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaedermergeOpInfos :: TypeMap -> Set.Set OpInfo -> Set.Set OpInfo
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder -> Result (Set.Set OpInfo)
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian MaedermergeOpInfos tm s1 s2 = mergeOps (addUnit tm) s1 s2
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaedermergeOps :: TypeMap -> Set.Set OpInfo -> Set.Set OpInfo
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder -> Result (Set.Set OpInfo)
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaedermergeOps tm s1 s2 = if Set.null s1 then return s2 else do
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder (es, us) = Set.partition (isUnifiable tm 1 (opType o) . opType) s2
975642b989852fc24119c59cf40bc1af653608ffChristian Maeder s <- mergeOps tm os us
975642b989852fc24119c59cf40bc1af653608ffChristian Maeder r <- foldM (mergeOpInfo tm) o $ Set.toList es
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaedermergeOpInfo :: TypeMap -> OpInfo -> OpInfo -> Result OpInfo
b984ff0ba75221f64451c1e69b3977967d4e99a1Christian MaedermergeOpInfo tm o1 o2 =
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder do let s1 = opType o1
ee9eddfa6953868fd6fbaff0d9ff68675a13675aChristian Maeder s2 = opType o2
b984ff0ba75221f64451c1e69b3977967d4e99a1Christian Maeder sc <- if instScheme tm 1 s2 s1 then return s1
b984ff0ba75221f64451c1e69b3977967d4e99a1Christian Maeder else if instScheme tm 1 s1 s2 then return s2
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder else fail "overlapping but incompatible type schemes"
b984ff0ba75221f64451c1e69b3977967d4e99a1Christian Maeder as <- merge (opAttrs o1) $ opAttrs o2
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder d <- merge (opDefn o1) $ opDefn o2
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder return $ OpInfo sc as d
962d5c684e2b86d1f9c556c096b426e10cc74026Christian Maederinstance Mergeable Env where
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder merge e1 e2 =
b984ff0ba75221f64451c1e69b3977967d4e99a1Christian Maeder do cMap <- merge (classMap e1) $ classMap e2
962d5c684e2b86d1f9c556c096b426e10cc74026Christian Maeder tMap <- mergeMap id mergeTypeInfo
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder (typeMap e1) $ typeMap e2
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder case filterAliases tMap of
962d5c684e2b86d1f9c556c096b426e10cc74026Christian Maeder as <- mergeMap (Set.map $ mapOpInfo (id, expandAliases tAs))
962d5c684e2b86d1f9c556c096b426e10cc74026Christian Maeder (mergeOpInfos tMap)
962d5c684e2b86d1f9c556c096b426e10cc74026Christian Maeder (assumps e1) $ assumps e2
962d5c684e2b86d1f9c556c096b426e10cc74026Christian Maeder return initialEnv { classMap = cMap
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder , typeMap = tMap
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder , assumps = as }
ee9eddfa6953868fd6fbaff0d9ff68675a13675aChristian MaedermergeA :: (Pretty a, Eq a) => String -> a -> a -> Result a
ee9eddfa6953868fd6fbaff0d9ff68675a13675aChristian MaedermergeA str t1 t2 = if t1 == t2 then return t1 else
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder fail ("different " ++ str ++ expected t1 t2)
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian MaedermergeTerm :: DiagKind -> Term -> Term -> Result Term
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaedermergeTerm k t1 t2 = if t1 == t2 then return t1 else
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder Result [Diag k ("different terms" ++ expected t1 t2)
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder nullRange] $ Just t2