Merge.hs revision fc816c737e569f135d8e2f79fc83521c85fae667
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian MaederModule : $Header$
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian MaederCopyright : (c) Christian Maeder and Uni Bremen 2003
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian MaederLicence : similar to LGPL, see HetCATS/LICENCE.txt or LIZENZ.txt
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian MaederMaintainer : hets@tzi.de
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian MaederStability : experimental
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian MaederPortability : portable
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian Maeder merging parts of local environment
e59da4ae089bcbbdc655bae5b00d57703dc96bb4Christian Maederimport qualified Common.Lib.Map as Map
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maederimport Data.List(nub, partition, nubBy)
32562a567baac248a00782d2727716c13117dc4aChristian Maederinstance (Ord a, PosItem a, PrettyPrint a, Mergeable b)
e59da4ae089bcbbdc655bae5b00d57703dc96bb4Christian Maeder => Mergeable (Map.Map a b) where
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian Maeder merge = mergeMap merge
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian MaederimproveDiag :: (PosItem a, PrettyPrint a) => a -> Diagnosis -> Diagnosis
904efdc72d29946a966c65fcc624068f38127c84Christian MaederimproveDiag v d = d { diagString = let f:l = lines $ diagString d in
904efdc72d29946a966c65fcc624068f38127c84Christian Maeder unlines $ (f ++ " of '" ++ showPretty v "'") : l
904efdc72d29946a966c65fcc624068f38127c84Christian Maeder , diagPos = getMyPos v
904efdc72d29946a966c65fcc624068f38127c84Christian Maeder , diagKind = case diagKind d of
904efdc72d29946a966c65fcc624068f38127c84Christian Maeder FatalError -> Error
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian MaedermergeMap :: (Ord a, PosItem a, PrettyPrint a) => (b -> b -> Result b)
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian Maeder -> Map.Map a b -> Map.Map a b -> Result (Map.Map a b)
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian MaedermergeMap f m1 m2 = foldM ( \ m (k, v) ->
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder Nothing -> return $ Map.insert k v m
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian Maeder let Result ds mu = f v w
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder ns = map (improveDiag k) ds
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder in case mu of
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian Maeder Nothing -> Result ns $ Nothing
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian Maeder Just u -> Result ns $ Just $ Map.insert k u m)
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian Maederinstance Mergeable a => Mergeable (Maybe a) where
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian Maeder merge m1 m2 = case m1 of
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian Maeder Nothing -> return m2
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian Maeder Just v1 -> case m2 of
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian Maeder Nothing -> return m1
dcf7a9c571e15547fd5302de8064663a486c26faChristian Maeder Just v2 -> do v <- merge v1 v2
918c36f05614a959f186fe02bd4f943e0a1d91e3Christian Maeder return $ Just v
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian Maederinstance Mergeable ClassInfo where
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian Maeder merge c1 c2 = if c1 == c2 then
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian Maeder else fail "merge: non-equal super classes"
7868299829c1318b888152243ec2cea4f598b568Christian Maederinstance Mergeable Kind where
7868299829c1318b888152243ec2cea4f598b568Christian Maeder merge k1 k2 = if k1 == k2 then return k1
7868299829c1318b888152243ec2cea4f598b568Christian Maeder else fail "merge: non-equal kinds"
7868299829c1318b888152243ec2cea4f598b568Christian MaedermergeList :: Eq a => [a] -> [a] -> Result [a]
dcf7a9c571e15547fd5302de8064663a486c26faChristian MaedermergeList l1 l2 = return $ nub (l1 ++ l2)
7868299829c1318b888152243ec2cea4f598b568Christian MaedermergeTypeInfo :: TypeMap -> Int -> TypeInfo -> TypeInfo -> Result TypeInfo
7868299829c1318b888152243ec2cea4f598b568Christian MaedermergeTypeInfo tm c t1 t2 =
7868299829c1318b888152243ec2cea4f598b568Christian Maeder do k <- merge (typeKind t1) $ typeKind t2
7868299829c1318b888152243ec2cea4f598b568Christian Maeder o <- mergeList (otherTypeKinds t1) $ otherTypeKinds t2
7868299829c1318b888152243ec2cea4f598b568Christian Maeder s <- mergeList (superTypes t1) $ superTypes t2
7868299829c1318b888152243ec2cea4f598b568Christian Maeder d <- mergeTypeDefn tm c (typeDefn t1) $ typeDefn t2
7868299829c1318b888152243ec2cea4f598b568Christian Maeder return $ TypeInfo k o s d
f92ea4a057e99e7ef2f8f5f6f2bad2ab5b5e256bChristian MaedermergeTypeDefn :: TypeMap -> Int -> TypeDefn -> TypeDefn -> Result TypeDefn
7868299829c1318b888152243ec2cea4f598b568Christian MaedermergeTypeDefn tm c d1 d2 =
dcf7a9c571e15547fd5302de8064663a486c26faChristian Maeder case (d1, d2) of
7868299829c1318b888152243ec2cea4f598b568Christian Maeder (TypeVarDefn, TypeVarDefn) -> return d1
7868299829c1318b888152243ec2cea4f598b568Christian Maeder (TypeVarDefn, _) -> fail "merge: TypeVarDefn"
7868299829c1318b888152243ec2cea4f598b568Christian Maeder (_, TypeVarDefn) -> fail "merge: TypeVarDefn"
7868299829c1318b888152243ec2cea4f598b568Christian Maeder (_, DatatypeDefn _ _ _) -> return d2
7868299829c1318b888152243ec2cea4f598b568Christian Maeder (PreDatatype, _) -> fail "expected data type definition"
7868299829c1318b888152243ec2cea4f598b568Christian Maeder (_, PreDatatype) -> return d1
7868299829c1318b888152243ec2cea4f598b568Christian Maeder-- (NoTypeDefn, AliasTypeDefn _) -> fail "merge: AliasTypeDefn"
7868299829c1318b888152243ec2cea4f598b568Christian Maeder-- (AliasTypeDefn _, NoTypeDefn) -> fail "merge: AliasTypeDefn"
7868299829c1318b888152243ec2cea4f598b568Christian Maeder (NoTypeDefn, _) -> return d2
7868299829c1318b888152243ec2cea4f598b568Christian Maeder (_, NoTypeDefn) -> return d1
7868299829c1318b888152243ec2cea4f598b568Christian Maeder (AliasTypeDefn s1, AliasTypeDefn s2) ->
dcf7a9c571e15547fd5302de8064663a486c26faChristian Maeder do s <- mergeScheme tm c s1 s2
7868299829c1318b888152243ec2cea4f598b568Christian Maeder return $ AliasTypeDefn s
7868299829c1318b888152243ec2cea4f598b568Christian Maeder (Supertype v1 s1 t1, Supertype v2 s2 t2) ->
7868299829c1318b888152243ec2cea4f598b568Christian Maeder do s <- mergeScheme tm c s1 s2
7868299829c1318b888152243ec2cea4f598b568Christian Maeder v <- merge v1 v2
7868299829c1318b888152243ec2cea4f598b568Christian Maeder t <- merge t1 t2
f92ea4a057e99e7ef2f8f5f6f2bad2ab5b5e256bChristian Maeder return $ Supertype v s t
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder (_, _) -> if d1 == d2 then return d1 else
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder fail "merge: TypeDefn"
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maederinstance Mergeable Vars where
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder merge t1 t2 = if t1 == t2 then return t1
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder else fail ("different variables for subtype definition\n\t"
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian Maeder ++ showPretty t1 "\n\t"
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder ++ showPretty t2 "\n\t")
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian MaedermergeScheme :: TypeMap -> Int -> TypeScheme -> TypeScheme -> Result TypeScheme
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian MaedermergeScheme tm c s1 s2 = let b = instScheme tm c s2 s1 in
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder if instScheme tm c s1 s2 then
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder if b then return s1
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder else fail ("found scheme is only a subsitution instance"
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder ++ expected s1 s2)
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder else if b then
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian Maeder fail ("expected scheme is only a subsitution instance"
6e0d665ee3ea887134ce2d54431fb25568a702e4Christian Maeder ++ expected s1 s2)
6e0d665ee3ea887134ce2d54431fb25568a702e4Christian Maeder else fail ("wrong type scheme" ++ expected s1 s2)
6e0d665ee3ea887134ce2d54431fb25568a702e4Christian MaedermergeOpInfo :: TypeMap -> Int -> OpInfo -> OpInfo -> Result OpInfo
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian MaedermergeOpInfo tm c o1 o2 =
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian Maeder do sc <- mergeScheme tm c (opType o1) $ opType o2
6e0d665ee3ea887134ce2d54431fb25568a702e4Christian Maeder as <- mergeAttrs (opAttrs o1) $ opAttrs o2
6e0d665ee3ea887134ce2d54431fb25568a702e4Christian Maeder d <- mergeOpDefn tm (opDefn o1) $ opDefn o2
6e0d665ee3ea887134ce2d54431fb25568a702e4Christian Maeder return $ OpInfo sc as d
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian Maeder-- instance Mergeable [OpAttr] where
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian MaedermergeAttrs :: [OpAttr] -> [OpAttr] -> Result [OpAttr]
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian MaedermergeAttrs l1 l2 =
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder let binAttr a = case a of BinOpAttr _ _ -> True
4eeeca8e688ff5fb58bad5610d12f3f7a9866e85Christian Maeder (l1b, l1u) = partition binAttr l1
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder (l2b, l2u) = partition binAttr l2
e59da4ae089bcbbdc655bae5b00d57703dc96bb4Christian Maeder lb = nubBy ( \ (BinOpAttr b1 _) (BinOpAttr b2 _) -> b1 == b2)
e59da4ae089bcbbdc655bae5b00d57703dc96bb4Christian Maeder in if null l1u || null l2u then
e59da4ae089bcbbdc655bae5b00d57703dc96bb4Christian Maeder return (l1u ++ l2u ++ lb)
e59da4ae089bcbbdc655bae5b00d57703dc96bb4Christian Maeder else do u <- merge (head l1u) (head l2u)
32562a567baac248a00782d2727716c13117dc4aChristian Maeder return (u : lb)
32562a567baac248a00782d2727716c13117dc4aChristian Maederinstance Mergeable OpAttr where
32562a567baac248a00782d2727716c13117dc4aChristian Maeder merge (UnitOpAttr t1 p1) (UnitOpAttr t2 p2) =
32562a567baac248a00782d2727716c13117dc4aChristian Maeder do t <- merge t1 t2
32562a567baac248a00782d2727716c13117dc4aChristian Maeder return $ UnitOpAttr t (p1 ++ p2)
32562a567baac248a00782d2727716c13117dc4aChristian Maeder merge _ _ = fail "merge: OpAttr"
32562a567baac248a00782d2727716c13117dc4aChristian Maederinstance Mergeable OpBrand where
32562a567baac248a00782d2727716c13117dc4aChristian Maeder merge Pred _ = return Pred
32562a567baac248a00782d2727716c13117dc4aChristian Maeder merge _ Pred = return Pred
32562a567baac248a00782d2727716c13117dc4aChristian Maeder merge Op _ = return Op
32562a567baac248a00782d2727716c13117dc4aChristian Maeder merge _ Op = return Op
32562a567baac248a00782d2727716c13117dc4aChristian Maeder merge _ _ = return Fun
57a32fb13a6acc1748bb1c68028cb2382d6bdb3fChristian Maeder-- instance Mergeable OpDefn where
e59da4ae089bcbbdc655bae5b00d57703dc96bb4Christian MaedermergeOpDefn :: TypeMap -> OpDefn -> OpDefn -> Result OpDefn
e59da4ae089bcbbdc655bae5b00d57703dc96bb4Christian MaedermergeOpDefn _ VarDefn VarDefn = return VarDefn
e59da4ae089bcbbdc655bae5b00d57703dc96bb4Christian MaedermergeOpDefn _ VarDefn _ = fail "illegal redeclaration of a variable"
e59da4ae089bcbbdc655bae5b00d57703dc96bb4Christian MaedermergeOpDefn _ _ VarDefn = fail "illegal redeclaration as variable"
32562a567baac248a00782d2727716c13117dc4aChristian MaedermergeOpDefn _ (NoOpDefn _) d = return d
e59da4ae089bcbbdc655bae5b00d57703dc96bb4Christian MaedermergeOpDefn _ d (NoOpDefn _) = return d
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian MaedermergeOpDefn tm d@(ConstructData d1) (ConstructData d2) =
e39a1626bee36d6ad13a2c0014a80ef179a65bcbChristian Maeder if relatedTypeIds tm d1 d2 then return d else
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder fail ("wrong constructor target type" ++
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder expected d1 d2)
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian MaedermergeOpDefn tm (SelectData c1 d1) (SelectData c2 d2) =
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder if relatedTypeIds tm d1 d2 then
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder do c <- mergeConstrInfos tm c1 c2
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder return $ SelectData c d1
0243238805d31e597195ef974e8e7eccb587a390Christian Maeder else fail ("wrong selector's source type" ++
0243238805d31e597195ef974e8e7eccb587a390Christian Maeder expected d1 d2)
904efdc72d29946a966c65fcc624068f38127c84Christian MaedermergeOpDefn _ (Definition b1 d1) (Definition b2 d2) =
0243238805d31e597195ef974e8e7eccb587a390Christian Maeder do d <- merge d1 d2
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder b <- merge b1 b2
e59da4ae089bcbbdc655bae5b00d57703dc96bb4Christian Maeder return $ Definition b d
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian MaedermergeOpDefn _ _d1 _d2 = fail "illegal redefinition"
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian MaedermergeConstrInfos :: TypeMap -> [ConstrInfo] -> [ConstrInfo]
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder -> Result [ConstrInfo]
e68cfdc781c4fd65d42f99173efc2aef342ce0eeChristian MaedermergeConstrInfos _ [] c2 = return c2
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian MaedermergeConstrInfos tm (c : r) c2 =
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder do c3 <- mergeConstrInfos tm r c2
0243238805d31e597195ef974e8e7eccb587a390Christian Maeder let cs = filter (isUnifiable tm 0 (constrType c) . constrType) c2
0243238805d31e597195ef974e8e7eccb587a390Christian Maeder if null cs then
4eeeca8e688ff5fb58bad5610d12f3f7a9866e85Christian Maeder return (c : c3)
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder else return c3
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maederinstance Mergeable Term where
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder merge t1 t2 = if t1 == t2 then return t1
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder else fail ("different terms\n\t"
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder ++ showPretty t1 "\n\t"
14a6ec72de5c35d65c2adcd54b6fecbd8bc271b6Christian Maeder ++ showPretty t2 "\n\t")