Merge.hs revision f3a94a197960e548ecd6520bb768cb0d547457bb
e9458b1a7a19a63aa4c179f9ab20f4d50681c168Jens ElknerModule : $Header$
09249711700a6acbc40a2e337688b434d7aafa28Christian MaederCopyright : (c) Christian Maeder and Uni Bremen 2003
abd8dd44106c507dd2cb64359b63d7d56fa0a9c8Christian MaederLicense : similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt
abd8dd44106c507dd2cb64359b63d7d56fa0a9c8Christian MaederMaintainer : maeder@tzi.de
3f69b6948966979163bdfe8331c38833d5d90ecdChristian MaederStability : experimental
abd8dd44106c507dd2cb64359b63d7d56fa0a9c8Christian MaederPortability : portable
f3a94a197960e548ecd6520bb768cb0d547457bbChristian Maedermerging parts of local environment
72b9099aeec0762bae4546db3bc4b48721027bf4Christian Maederimport qualified Common.Lib.Map as Map
3c5cc698b0c061209ff83eb8de027daef5ae922aChristian Maeder-- | merge together repeated or extended items
3c5cc698b0c061209ff83eb8de027daef5ae922aChristian Maederclass Mergeable a where
3c5cc698b0c061209ff83eb8de027daef5ae922aChristian Maeder merge :: a -> a -> Result a
413db961f13e112716509b6d61d7a7bbf50c98b2Christian Maederinstance (Ord a, PosItem a, PrettyPrint a, Mergeable b)
413db961f13e112716509b6d61d7a7bbf50c98b2Christian Maeder => Mergeable (Map.Map a b) where
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder merge = mergeMap id merge
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaederimproveDiag :: (PosItem a, PrettyPrint a) => a -> Diagnosis -> Diagnosis
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaederimproveDiag v d = d { diagString = let f:l = lines $ diagString d in
8452387b4c54b8dd36c012b216e0b0c5004ca6f1Christian Maeder unlines $ (f ++ " of '" ++ showPretty v "'") : l
c18e9c3c6d5039618f1f2c05526ece84c7794ea3Christian Maeder , diagPos = get_pos v
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaedermergeMap :: (Ord a, PosItem a, PrettyPrint a) =>
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder (b -> b) -> (b -> b -> Result b)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder -> Map.Map a b -> Map.Map a b -> Result (Map.Map a b)
8f88a86e9656713ea4608541b8b47bb47a755bffChristian MaedermergeMap e f m1 m2 = foldM ( \ m (k, v) ->
2f6227e9ec96ca827cc40078916f18d54a075136Christian Maeder Nothing -> return $ Map.insert k (e v) m
2f6227e9ec96ca827cc40078916f18d54a075136Christian Maeder let Result ds mu = f (e v) w
2f6227e9ec96ca827cc40078916f18d54a075136Christian Maeder ns = map (improveDiag k) ds
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder in case mu of
120efeede54a5f7650cda8e91363bd6832eac9a9Christian Maeder Nothing -> Result ns $ Nothing
120efeede54a5f7650cda8e91363bd6832eac9a9Christian Maeder Just u -> Result ns $ Just $ Map.insert k u m)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maederinstance Mergeable a => Mergeable (Maybe a) where
df33a9af92444f63ad545da6bb326aac9284318eChristian Maeder merge m1 m2 = case m1 of
df33a9af92444f63ad545da6bb326aac9284318eChristian Maeder Nothing -> return m2
df33a9af92444f63ad545da6bb326aac9284318eChristian Maeder Just v1 -> case m2 of
df33a9af92444f63ad545da6bb326aac9284318eChristian Maeder Nothing -> return m1
df33a9af92444f63ad545da6bb326aac9284318eChristian Maeder Just v2 -> do v <- merge v1 v2
df33a9af92444f63ad545da6bb326aac9284318eChristian Maeder return $ Just v
df33a9af92444f63ad545da6bb326aac9284318eChristian Maederinstance Mergeable ClassInfo where
df33a9af92444f63ad545da6bb326aac9284318eChristian Maeder merge = mergeA "super classes"
df33a9af92444f63ad545da6bb326aac9284318eChristian Maederinstance Mergeable Kind where
df33a9af92444f63ad545da6bb326aac9284318eChristian Maeder merge = mergeA "super kinds"
120efeede54a5f7650cda8e91363bd6832eac9a9Christian MaedermergeTypeInfo :: TypeInfo -> TypeInfo -> Result TypeInfo
ce3928e71520030ad0275b72050a8f4377f9313cChristian MaedermergeTypeInfo t1 t2 =
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder do k <- merge (typeKind t1) $ typeKind t2
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder o <- merge (otherTypeKinds t1) $ otherTypeKinds t2
abd8dd44106c507dd2cb64359b63d7d56fa0a9c8Christian Maeder s <- merge (superTypes t1) $ superTypes t2
c4e912fc181d72c8d0e0e38d0351278182f0d0b5Christian Maeder d <- mergeTypeDefn (typeDefn t1) $ typeDefn t2
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder return $ TypeInfo k o s d
2f6227e9ec96ca827cc40078916f18d54a075136Christian MaedermergeTypeDefn :: TypeDefn -> TypeDefn -> Result TypeDefn
2f6227e9ec96ca827cc40078916f18d54a075136Christian MaedermergeTypeDefn d1 d2 =
2f6227e9ec96ca827cc40078916f18d54a075136Christian Maeder case (d1, d2) of
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder (TypeVarDefn 0, TypeVarDefn _) -> return d2
92aa1b88f02d2a413da60dba78acd34312e6f29aChristian Maeder (TypeVarDefn _, TypeVarDefn 0) -> return d1
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder (TypeVarDefn c1, TypeVarDefn c2) -> do
6b1153c560b677f9f5da2a60ee8a10de75ff90c5Christian Maeder c <- mergeA "TypeVarDefn" c1 c2
36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder return $ TypeVarDefn c
81946e2b3f6dde6167f48769bd02c7a634736856Christian Maeder (TypeVarDefn _, _) -> fail "merge: TypeVarDefn"
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder (_, TypeVarDefn _) -> fail "merge: TypeVarDefn"
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder (_, DatatypeDefn _) -> return d2
6cb518d88084543c13aa7e56db767c14ee97ab77Christian Maeder (PreDatatype, _) -> fail "expected data type definition"
6cb518d88084543c13aa7e56db767c14ee97ab77Christian Maeder (_, PreDatatype) -> return d1
2f6227e9ec96ca827cc40078916f18d54a075136Christian Maeder (NoTypeDefn, _) -> return d2
024621f43239cfe9629e35d35a8669fad7acbba2Christian Maeder (_, NoTypeDefn) -> return d1
99f16a0f9ca757410960ff51a79b034503384fe2Christian Maeder (AliasTypeDefn s1, AliasTypeDefn s2) ->
2f6227e9ec96ca827cc40078916f18d54a075136Christian Maeder do s <- mergeScheme s1 s2
d48085f765fca838c1d972d2123601997174583dChristian Maeder return $ AliasTypeDefn s
68485f7bfab1b4c6f963ce6837cba5fb148ed625Christian Maeder (Supertype v1 s1 t1, Supertype v2 s2 t2) ->
68485f7bfab1b4c6f963ce6837cba5fb148ed625Christian Maeder do s <- mergeScheme s1 s2
d48085f765fca838c1d972d2123601997174583dChristian Maeder v <- merge v1 v2
a59f2017dfc311ece7afcea3e8a3ceceac77ba5aChristian Maeder t <- mergeTerm Warning t1 t2
8452387b4c54b8dd36c012b216e0b0c5004ca6f1Christian Maeder return $ Supertype v s t
8452387b4c54b8dd36c012b216e0b0c5004ca6f1Christian Maeder (_, _) -> mergeA "TypeDefn" d1 d2
a59f2017dfc311ece7afcea3e8a3ceceac77ba5aChristian Maederinstance Mergeable Vars where
a59f2017dfc311ece7afcea3e8a3ceceac77ba5aChristian Maeder merge = mergeA "variables for subtype definition"
8452387b4c54b8dd36c012b216e0b0c5004ca6f1Christian MaedermergeScheme :: TypeScheme -> TypeScheme -> Result TypeScheme
a59f2017dfc311ece7afcea3e8a3ceceac77ba5aChristian MaedermergeScheme s1@(TypeScheme a1 t1 _)
a59f2017dfc311ece7afcea3e8a3ceceac77ba5aChristian Maeder s2@(TypeScheme a2 t2 _) =
a59f2017dfc311ece7afcea3e8a3ceceac77ba5aChristian Maeder let v1 = genVarsOf t1
df33a9af92444f63ad545da6bb326aac9284318eChristian Maeder v2 = genVarsOf t2
2f6227e9ec96ca827cc40078916f18d54a075136Christian Maeder mp v = mapArg $ zip v [(1::Int)..]
2f6227e9ec96ca827cc40078916f18d54a075136Christian Maeder if t1 == t2 then
2f6227e9ec96ca827cc40078916f18d54a075136Christian Maeder if null a1 && null a2 || isSingle a1 && isSingle a2 then
68485f7bfab1b4c6f963ce6837cba5fb148ed625Christian Maeder else if map (mp v1) a1 == map (mp v2) a2 then return s1
413db961f13e112716509b6d61d7a7bbf50c98b2Christian Maeder else fail ("differently bound type variables"
df33a9af92444f63ad545da6bb326aac9284318eChristian Maeder ++ expected s1 s2)
04a1ed0b360858b85de6f449b84df4eab81b3fc9Christian Maeder else fail ("wrong type scheme" ++ expected s1 s2)
2f6227e9ec96ca827cc40078916f18d54a075136Christian Maederinstance Mergeable OpAttr where
932f71e6f6f404ac139399c3d6a2b906ba055cbdChristian Maeder merge (UnitOpAttr t1 p1) (UnitOpAttr t2 p2) =
2f6227e9ec96ca827cc40078916f18d54a075136Christian Maeder do t <- mergeTerm Warning t1 t2
2f6227e9ec96ca827cc40078916f18d54a075136Christian Maeder return $ UnitOpAttr t (p1 ++ p2)
72909c6c1cfe9702f5910d0a135c8b55729c7917Christian Maeder merge a1 a2 = mergeA "attributes" a1 a2
72909c6c1cfe9702f5910d0a135c8b55729c7917Christian Maederinstance Mergeable OpBrand where
68485f7bfab1b4c6f963ce6837cba5fb148ed625Christian Maeder merge Pred _ = return Pred
e997f1724fcc2c5bb49f44e9f45e8354e0f3a2d6Christian Maeder merge _ Pred = return Pred
e997f1724fcc2c5bb49f44e9f45e8354e0f3a2d6Christian Maeder merge Op _ = return Op
e997f1724fcc2c5bb49f44e9f45e8354e0f3a2d6Christian Maeder merge _ Op = return Op
e997f1724fcc2c5bb49f44e9f45e8354e0f3a2d6Christian Maeder merge _ _ = return Fun
932f71e6f6f404ac139399c3d6a2b906ba055cbdChristian Maederinstance Mergeable OpDefn where
e997f1724fcc2c5bb49f44e9f45e8354e0f3a2d6Christian Maeder merge VarDefn VarDefn = return VarDefn
2f6227e9ec96ca827cc40078916f18d54a075136Christian Maeder merge VarDefn _ = fail "illegal redeclaration of a variable"
99f16a0f9ca757410960ff51a79b034503384fe2Christian Maeder merge _ VarDefn = fail "illegal redeclaration as variable"
99f16a0f9ca757410960ff51a79b034503384fe2Christian Maeder merge (NoOpDefn _) d = return d
413db961f13e112716509b6d61d7a7bbf50c98b2Christian Maeder merge d (NoOpDefn _) = return d
413db961f13e112716509b6d61d7a7bbf50c98b2Christian Maeder merge (ConstructData d1) (ConstructData _d2) = do
68485f7bfab1b4c6f963ce6837cba5fb148ed625Christian Maeder-- d <- mergeA "constructor target type" d1 d2
932f71e6f6f404ac139399c3d6a2b906ba055cbdChristian Maeder return $ ConstructData d1
2f6227e9ec96ca827cc40078916f18d54a075136Christian Maeder merge (SelectData c1 d1) (SelectData c2 _d2) = do
2f6227e9ec96ca827cc40078916f18d54a075136Christian Maeder-- d <- mergeA "selector source type" d1 d2
2f6227e9ec96ca827cc40078916f18d54a075136Christian Maeder c <- merge c1 c2
2f6227e9ec96ca827cc40078916f18d54a075136Christian Maeder return $ SelectData c d1
2f6227e9ec96ca827cc40078916f18d54a075136Christian Maeder merge (Definition b1 d1) (Definition b2 d2) =
2f6227e9ec96ca827cc40078916f18d54a075136Christian Maeder do d <- mergeTerm Hint d1 d2
2f6227e9ec96ca827cc40078916f18d54a075136Christian Maeder b <- merge b1 b2
2f6227e9ec96ca827cc40078916f18d54a075136Christian Maeder return $ Definition b d
2f6227e9ec96ca827cc40078916f18d54a075136Christian Maeder merge _d1 _d2 = fail "illegal redefinition"
932f71e6f6f404ac139399c3d6a2b906ba055cbdChristian Maederinstance Eq a => Mergeable [a] where
35cd0c10843c2cdbbe29f00a2a5d7e5e4f2d0064Christian Maeder merge [] l2 = return l2
2f6227e9ec96ca827cc40078916f18d54a075136Christian Maeder merge (e:l1) l2 = do
2f6227e9ec96ca827cc40078916f18d54a075136Christian Maeder l3 <- merge l1 l2
e997f1724fcc2c5bb49f44e9f45e8354e0f3a2d6Christian Maeder return $ if any (e==) l2 then l3
68485f7bfab1b4c6f963ce6837cba5fb148ed625Christian MaedermergeOpInfos :: TypeMap -> OpInfos -> OpInfos -> Result OpInfos
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaedermergeOpInfos tm (OpInfos l1) (OpInfos l2) =
6e2c88c65d50b2e44f7afa165e6a5fac0724f08cChristian Maeder do l <- mergeOps (addUnit tm) l1 l2
6e2c88c65d50b2e44f7afa165e6a5fac0724f08cChristian Maeder return $ OpInfos l
6e2c88c65d50b2e44f7afa165e6a5fac0724f08cChristian MaedermergeOps :: TypeMap -> [OpInfo] -> [OpInfo] -> Result [OpInfo]
6e2c88c65d50b2e44f7afa165e6a5fac0724f08cChristian MaedermergeOps _ [] l = return l
6e2c88c65d50b2e44f7afa165e6a5fac0724f08cChristian MaedermergeOps tm (o:os) l2 = do
413db961f13e112716509b6d61d7a7bbf50c98b2Christian Maeder let (es, us) = partition (isUnifiable tm 1
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder (opType o) . opType) l2
6e2c88c65d50b2e44f7afa165e6a5fac0724f08cChristian Maeder l1 <- mergeOps tm os us
48c4688439e0aade4faeebf25ca8b16d661e47afChristian Maeder if null es then return (o : l1)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder else do r <- mergeOpInfo tm o $ head es
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder return (r : l1)
413db961f13e112716509b6d61d7a7bbf50c98b2Christian MaedermergeOpInfo :: TypeMap -> OpInfo -> OpInfo -> Result OpInfo
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian MaedermergeOpInfo tm o1 o2 =
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder do let s1 = opType o1
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder s2 = opType o2
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder sc <- if instScheme tm 1 s2 s1 then return s1
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder else if instScheme tm 1 s1 s2 then return s2
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder else fail "overlapping but incompatible type schemes"
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder as <- merge (opAttrs o1) $ opAttrs o2
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder d <- merge (opDefn o1) $ opDefn o2
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder return $ OpInfo sc as d
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maederinstance Mergeable Env where
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder merge e1 e2 =
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder do cMap <- merge (classMap e1) $ classMap e2
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder tMap <- mergeMap id mergeTypeInfo
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder (typeMap e1) $ typeMap e2
8452387b4c54b8dd36c012b216e0b0c5004ca6f1Christian Maeder as <- mergeMap (OpInfos .
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder map (mapOpInfo (id, expandAlias tMap)) . opInfos)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder (mergeOpInfos tMap)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder (assumps e1) $ assumps e2
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder return initialEnv { classMap = cMap
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder , typeMap = tMap
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder , assumps = as }
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaedermergeA :: (PrettyPrint a, Eq a) => String -> a -> a -> Result a
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaedermergeA str t1 t2 = if t1 == t2 then return t1 else
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder fail ("different " ++ str ++ expected t1 t2)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaedermergeTerm :: DiagKind -> Term -> Term -> Result Term
24f79601ad5e42ce74f4152a36aad257d7c4d7b5Christian MaedermergeTerm k t1 t2 = if t1 == t2 then return t1 else
24f79601ad5e42ce74f4152a36aad257d7c4d7b5Christian Maeder Result [Diag k ("different terms" ++ expected t1 t2)
24f79601ad5e42ce74f4152a36aad257d7c4d7b5Christian Maeder []] $ Just t2