Merge.hs revision 3f69b6948966979163bdfe8331c38833d5d90ecd
c298a419605037f5352b5ad0f67b3e06db094051Felix Gabriel ManceModule : $Header$
81ec673ac5ab1493568d9ef7798b752ab8ee0e61Felix Gabriel ManceCopyright : (c) Christian Maeder and Uni Bremen 2003-2005
c298a419605037f5352b5ad0f67b3e06db094051Felix Gabriel ManceLicense : similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt
c298a419605037f5352b5ad0f67b3e06db094051Felix Gabriel ManceMaintainer : Christian.Maeder@dfki.de
c298a419605037f5352b5ad0f67b3e06db094051Felix Gabriel ManceStability : experimental
5d801400993c9671010d244646936d8fd435638cChristian MaederPortability : portable
ffa6044b04fa0e31242141ff56a5d80c4233b676Felix Gabriel Mancemerging parts of local environment
b1162cc13e8371724e3382ae6d1cfdeb43891fbbChristian Maederimport qualified Data.Map as Map
668c9c725a11c0f77057152148570af853a1bc0dFelix Gabriel Manceimport qualified Data.Set as Set
668c9c725a11c0f77057152148570af853a1bc0dFelix Gabriel Mance-- | merge together repeated or extended items
668c9c725a11c0f77057152148570af853a1bc0dFelix Gabriel Manceclass Mergeable a where
668c9c725a11c0f77057152148570af853a1bc0dFelix Gabriel Mance merge :: a -> a -> Result a
c298a419605037f5352b5ad0f67b3e06db094051Felix Gabriel Manceinstance (Ord a, PosItem a, Pretty a, Mergeable b)
c298a419605037f5352b5ad0f67b3e06db094051Felix Gabriel Mance => Mergeable (Map.Map a b) where
c298a419605037f5352b5ad0f67b3e06db094051Felix Gabriel Mance merge = mergeMap id merge
c298a419605037f5352b5ad0f67b3e06db094051Felix Gabriel ManceimproveDiag :: (PosItem a, Pretty a) => a -> Diagnosis -> Diagnosis
c298a419605037f5352b5ad0f67b3e06db094051Felix Gabriel ManceimproveDiag v d = d { diagString = let f:l = lines $ diagString d in
668c9c725a11c0f77057152148570af853a1bc0dFelix Gabriel Mance unlines $ (f ++ " of '" ++ showDoc v "'") : l
0ec1551231bc5dfdcb3f2bd68fec7457fade7bfdFelix Gabriel Mance , diagPos = getRange v
968930c7674ae3b63d308bf4fa651400aa263054Christian MaedermergeMap :: (Ord a, PosItem a, Pretty a) =>
c298a419605037f5352b5ad0f67b3e06db094051Felix Gabriel Mance (b -> b) -> (b -> b -> Result b)
ffa6044b04fa0e31242141ff56a5d80c4233b676Felix Gabriel Mance -> Map.Map a b -> Map.Map a b -> Result (Map.Map a b)
e40758c36e3e5312669558ad189b24b3eaf10c59Mihai CodescumergeMap e f m1 m2 = foldM ( \ m (k, v) ->
ffa6044b04fa0e31242141ff56a5d80c4233b676Felix Gabriel Mance Nothing -> return $ Map.insert k (e v) m
ffa6044b04fa0e31242141ff56a5d80c4233b676Felix Gabriel Mance let Result ds mu = f (e v) w
ffa6044b04fa0e31242141ff56a5d80c4233b676Felix Gabriel Mance ns = map (improveDiag k) ds
68de80eb2800338cbd16512106fcadab79325d8bChristian Maeder Nothing -> Result ns $ Nothing
68de80eb2800338cbd16512106fcadab79325d8bChristian Maeder Just u -> Result ns $ Just $ Map.insert k u m)
68de80eb2800338cbd16512106fcadab79325d8bChristian Maederinstance Mergeable a => Mergeable (Maybe a) where
68de80eb2800338cbd16512106fcadab79325d8bChristian Maeder merge m1 m2 = case m1 of
68de80eb2800338cbd16512106fcadab79325d8bChristian Maeder Nothing -> return m2
fc7bd98aabe1bc26058660085e8c77d60a97bcecChristian Maeder Just v1 -> case m2 of
fc7bd98aabe1bc26058660085e8c77d60a97bcecChristian Maeder Nothing -> return m1
68de80eb2800338cbd16512106fcadab79325d8bChristian Maeder Just v2 -> do v <- merge v1 v2
fc7bd98aabe1bc26058660085e8c77d60a97bcecChristian Maeder return $ Just v
68de80eb2800338cbd16512106fcadab79325d8bChristian Maederinstance Mergeable ClassInfo where
c298a419605037f5352b5ad0f67b3e06db094051Felix Gabriel Mance merge = mergeA "super classes"
c298a419605037f5352b5ad0f67b3e06db094051Felix Gabriel Manceinstance (Pretty a, Eq a) => Mergeable (AnyKind a) where
852bd6145634dc2832b61c44678fe539bc1682d5Christian Maeder merge = mergeA "super kinds"
c298a419605037f5352b5ad0f67b3e06db094051Felix Gabriel MancemergeTypeInfo :: TypeInfo -> TypeInfo -> Result TypeInfo
c298a419605037f5352b5ad0f67b3e06db094051Felix Gabriel MancemergeTypeInfo t1 t2 =
c298a419605037f5352b5ad0f67b3e06db094051Felix Gabriel Mance do k <- merge (typeKind t1) $ typeKind t2
c298a419605037f5352b5ad0f67b3e06db094051Felix Gabriel Mance o <- merge (otherTypeKinds t1) $ otherTypeKinds t2
c298a419605037f5352b5ad0f67b3e06db094051Felix Gabriel Mance s <- merge (superTypes t1) $ superTypes t2
c298a419605037f5352b5ad0f67b3e06db094051Felix Gabriel Mance d <- mergeTypeDefn (typeDefn t1) $ typeDefn t2
668c9c725a11c0f77057152148570af853a1bc0dFelix Gabriel Mance return $ TypeInfo k o s d
544989bc1f6ed4bc0813334ffd934db0fb0010eaFelix Gabriel MancemergeTypeDefn :: TypeDefn -> TypeDefn -> Result TypeDefn
544989bc1f6ed4bc0813334ffd934db0fb0010eaFelix Gabriel MancemergeTypeDefn d1 d2 =
544989bc1f6ed4bc0813334ffd934db0fb0010eaFelix Gabriel Mance case (d1, d2) of
544989bc1f6ed4bc0813334ffd934db0fb0010eaFelix Gabriel Mance (_, DatatypeDefn _) -> return d2
544989bc1f6ed4bc0813334ffd934db0fb0010eaFelix Gabriel Mance (PreDatatype, _) -> fail "expected data type definition"
f8c3d045dda224e92bf6bcb6288e1ee75ab54d1eChristian Maeder (_, PreDatatype) -> return d1
6856a07e36551ed6fadd7c01e7152a3a28878a6fChristian Maeder (NoTypeDefn, _) -> return d2
6856a07e36551ed6fadd7c01e7152a3a28878a6fChristian Maeder (_, NoTypeDefn) -> return d1
6856a07e36551ed6fadd7c01e7152a3a28878a6fChristian Maeder (AliasTypeDefn s1, AliasTypeDefn s2) ->
6856a07e36551ed6fadd7c01e7152a3a28878a6fChristian Maeder do s <- mergeAlias s1 s2
f8c3d045dda224e92bf6bcb6288e1ee75ab54d1eChristian Maeder return $ AliasTypeDefn s
c298a419605037f5352b5ad0f67b3e06db094051Felix Gabriel Mance (_, _) -> mergeA "TypeDefn" d1 d2
c298a419605037f5352b5ad0f67b3e06db094051Felix Gabriel Manceinstance Mergeable Vars where
c298a419605037f5352b5ad0f67b3e06db094051Felix Gabriel Mance merge = mergeA "variables for subtype definition"
c298a419605037f5352b5ad0f67b3e06db094051Felix Gabriel MancemergeAlias :: Type -> Type -> Result Type
852bd6145634dc2832b61c44678fe539bc1682d5Christian MaedermergeAlias s1 s2 = if s1 == s2 then return s1
852bd6145634dc2832b61c44678fe539bc1682d5Christian Maeder else fail $ "wrong type" ++ expected s1 s2
ea3f858eb531d981df3ed00beeadd99cf025adecChristian Maederinstance Mergeable OpAttr where
ea3f858eb531d981df3ed00beeadd99cf025adecChristian Maeder merge (UnitOpAttr t1 p1) (UnitOpAttr t2 p2) =
ea3f858eb531d981df3ed00beeadd99cf025adecChristian Maeder do t <- mergeTerm Warning t1 t2
75aaf82c430ad2a5cf159962b1c5c09255010fb4Felix Gabriel Mance return $ UnitOpAttr t (p1 `appRange` p2)
668c9c725a11c0f77057152148570af853a1bc0dFelix Gabriel Mance merge a1 a2 = mergeA "attributes" a1 a2
ffa6044b04fa0e31242141ff56a5d80c4233b676Felix Gabriel Manceinstance Mergeable OpBrand where
ffa6044b04fa0e31242141ff56a5d80c4233b676Felix Gabriel Mance merge b1 b2 = return $ case (b1, b2) of
ffa6044b04fa0e31242141ff56a5d80c4233b676Felix Gabriel Mance (Pred, _) -> Pred
1b1144abf7f95a4b23405b8d5604813cfe7b036aFelix Gabriel Mance (_, Pred) -> Pred
668c9c725a11c0f77057152148570af853a1bc0dFelix Gabriel Manceinstance Mergeable OpDefn where
668c9c725a11c0f77057152148570af853a1bc0dFelix Gabriel Mance merge d1 d2 = case (d1, d2) of
c298a419605037f5352b5ad0f67b3e06db094051Felix Gabriel Mance (NoOpDefn b1, NoOpDefn b2) -> do
8af00c8930672188ae80c8829428859160d329d0Felix Gabriel Mance b <- merge b1 b2
c298a419605037f5352b5ad0f67b3e06db094051Felix Gabriel Mance return $ NoOpDefn b
1b90322eaf59ded3de24fc891bd67bbd73ec2bfaFelix Gabriel Mance (SelectData c1 s, SelectData c2 _) -> do
1b90322eaf59ded3de24fc891bd67bbd73ec2bfaFelix Gabriel Mance c <- merge c1 c2
1b90322eaf59ded3de24fc891bd67bbd73ec2bfaFelix Gabriel Mance return $ SelectData c s
1b90322eaf59ded3de24fc891bd67bbd73ec2bfaFelix Gabriel Mance (Definition b1 e1, Definition b2 e2) -> do
1b90322eaf59ded3de24fc891bd67bbd73ec2bfaFelix Gabriel Mance d <- mergeTerm Hint e1 e2
1b90322eaf59ded3de24fc891bd67bbd73ec2bfaFelix Gabriel Mance b <- merge b1 b2
1b90322eaf59ded3de24fc891bd67bbd73ec2bfaFelix Gabriel Mance return $ Definition b d
1b90322eaf59ded3de24fc891bd67bbd73ec2bfaFelix Gabriel Mance (NoOpDefn b1, Definition b2 e2) -> do
8af00c8930672188ae80c8829428859160d329d0Felix Gabriel Mance b <- merge b1 b2
8af00c8930672188ae80c8829428859160d329d0Felix Gabriel Mance return $ Definition b e2
8af00c8930672188ae80c8829428859160d329d0Felix Gabriel Mance (Definition b1 e1, NoOpDefn b2) -> do
8af00c8930672188ae80c8829428859160d329d0Felix Gabriel Mance b <- merge b1 b2
8af00c8930672188ae80c8829428859160d329d0Felix Gabriel Mance return $ Definition b e1
8af00c8930672188ae80c8829428859160d329d0Felix Gabriel Mance (ConstructData _, SelectData _ _) ->
8af00c8930672188ae80c8829428859160d329d0Felix Gabriel Mance fail "illegal selector as constructor redefinition"
8af00c8930672188ae80c8829428859160d329d0Felix Gabriel Mance (SelectData _ _, ConstructData _) ->
8af00c8930672188ae80c8829428859160d329d0Felix Gabriel Mance fail "illegal constructor as selector redefinition"
9cb6af1a7632f12b60f592ce5eb2ac51e6bd33bbFelix Gabriel Mance (ConstructData _, _) -> return d1
8af00c8930672188ae80c8829428859160d329d0Felix Gabriel Mance (_, ConstructData _) -> return d2
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Mance (SelectData _ _, _) -> return d1
968930c7674ae3b63d308bf4fa651400aa263054Christian Maeder (_, SelectData _ _) -> return d2
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Manceinstance Eq a => Mergeable [a] where
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Mance merge l1 l2 = case l1 of
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Mance [] -> return l2
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Mance l3 <- merge l l2
ffa6044b04fa0e31242141ff56a5d80c4233b676Felix Gabriel Mance return $ if any (e==) l2 then l3 else e : l3
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Manceinstance Ord a => Mergeable (Set.Set a) where
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Mance merge s1 s2 = return $ Set.union s1 s2
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel MancemergeOpInfos :: TypeMap -> OpInfos -> OpInfos -> Result OpInfos
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel MancemergeOpInfos tm (OpInfos l1) (OpInfos l2) =
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Mance do l <- mergeOps (addUnit tm) l1 l2
ffa6044b04fa0e31242141ff56a5d80c4233b676Felix Gabriel Mance return $ OpInfos l
ffa6044b04fa0e31242141ff56a5d80c4233b676Felix Gabriel MancemergeOps :: TypeMap -> [OpInfo] -> [OpInfo] -> Result [OpInfo]
ffa6044b04fa0e31242141ff56a5d80c4233b676Felix Gabriel MancemergeOps _ [] l = return l
ffa6044b04fa0e31242141ff56a5d80c4233b676Felix Gabriel MancemergeOps tm (o:os) l2 = do
ffa6044b04fa0e31242141ff56a5d80c4233b676Felix Gabriel Mance let (es, us) = partition (isUnifiable tm 1
ffa6044b04fa0e31242141ff56a5d80c4233b676Felix Gabriel Mance (opType o) . opType) l2
ffa6044b04fa0e31242141ff56a5d80c4233b676Felix Gabriel Mance l1 <- mergeOps tm os us
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Mance if null es then return (o : l1)
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Mance else do r <- mergeOpInfo tm o $ head es
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Mance return (r : l1)
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel MancemergeOpInfo :: TypeMap -> OpInfo -> OpInfo -> Result OpInfo
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel MancemergeOpInfo tm o1 o2 =
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Mance do let s1 = opType o1
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Mance s2 = opType o2
968930c7674ae3b63d308bf4fa651400aa263054Christian Maeder sc <- if instScheme tm 1 s2 s1 then return s1
a921ae1da1302f673204e7b63cdce01439a9bd5eFelix Gabriel Mance else if instScheme tm 1 s1 s2 then return s2
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Mance else fail "overlapping but incompatible type schemes"
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Mance as <- merge (opAttrs o1) $ opAttrs o2
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Mance d <- merge (opDefn o1) $ opDefn o2
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Mance return $ OpInfo sc as d
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Manceinstance Mergeable Env where
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Mance do cMap <- merge (classMap e1) $ classMap e2
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Mance tMap <- mergeMap id mergeTypeInfo
c298a419605037f5352b5ad0f67b3e06db094051Felix Gabriel Mance (typeMap e1) $ typeMap e2
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Mance case filterAliases tMap of
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Mance as <- mergeMap (OpInfos .
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Mance map (mapOpInfo (id, expandAliases tAs)) . opInfos)
097bc9f18b722812d480df0f5c634d09cbca8e21Felix Gabriel Mance (mergeOpInfos tMap)
ffa6044b04fa0e31242141ff56a5d80c4233b676Felix Gabriel Mance (assumps e1) $ assumps e2
ffa6044b04fa0e31242141ff56a5d80c4233b676Felix Gabriel Mance return initialEnv { classMap = cMap
ffa6044b04fa0e31242141ff56a5d80c4233b676Felix Gabriel Mance , typeMap = tMap
ffa6044b04fa0e31242141ff56a5d80c4233b676Felix Gabriel Mance , assumps = as }
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel MancemergeA :: (Pretty a, Eq a) => String -> a -> a -> Result a
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel MancemergeA str t1 t2 = if t1 == t2 then return t1 else
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Mance fail ("different " ++ str ++ expected t1 t2)
8af00c8930672188ae80c8829428859160d329d0Felix Gabriel MancemergeTerm :: DiagKind -> Term -> Term -> Result Term
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel MancemergeTerm k t1 t2 = if t1 == t2 then return t1 else
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Mance Result [Diag k ("different terms" ++ expected t1 t2)
c77c0efe19dc6556ac872828bfb4cfc5fbca5ac5Felix Gabriel Mance nullRange] $ Just t2