hets/HasCASL/Merge.hs

	Merge.hs revision f454c20b6c126bea7d31d400cc8824b9ee8cc6ea
c797f343be2f3619bb1f5569753166ec49d27bdbChristian Maeder{- |
c797f343be2f3619bb1f5569753166ec49d27bdbChristian MaederModule      :  $Header$
81d182b21020b815887e9057959228546cf61b6bChristian MaederDescription :  union of signature parts
10397bcc134edbcfbe3ae2c7ea4c6080036aae22Christian MaederCopyright   :  (c) Christian Maeder and Uni Bremen 2003-2005
97018cf5fa25b494adffd7e9b4e87320dae6bf47Christian MaederLicense     :  similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt
c797f343be2f3619bb1f5569753166ec49d27bdbChristian Maeder
3f69b6948966979163bdfe8331c38833d5d90ecdChristian MaederMaintainer  :  Christian.Maeder@dfki.de
c797f343be2f3619bb1f5569753166ec49d27bdbChristian MaederStability   :  experimental
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaederPortability :  portable
f3a94a197960e548ecd6520bb768cb0d547457bbChristian Maeder
f3a94a197960e548ecd6520bb768cb0d547457bbChristian Maedermerging parts of local environment
462ec4b2fa3e0e788eb60dcb4aebc518298f342cChristian Maeder-}
462ec4b2fa3e0e788eb60dcb4aebc518298f342cChristian Maeder
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maedermodule HasCASL.Merge
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder    ( merge
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder    , improveDiag
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder    , mergeTypeDefn
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder    , mergeOpInfo
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder    ) where
462ec4b2fa3e0e788eb60dcb4aebc518298f342cChristian Maeder
462ec4b2fa3e0e788eb60dcb4aebc518298f342cChristian Maederimport Common.Id
23a00c966f2aa8da525d7a7c51933c99964426c0Christian Maederimport Common.DocUtils
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maederimport Common.Result
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder
462ec4b2fa3e0e788eb60dcb4aebc518298f342cChristian Maederimport HasCASL.As
462ec4b2fa3e0e788eb60dcb4aebc518298f342cChristian Maederimport HasCASL.Le
462ec4b2fa3e0e788eb60dcb4aebc518298f342cChristian Maederimport HasCASL.AsUtils
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maederimport HasCASL.ClassAna
10397bcc134edbcfbe3ae2c7ea4c6080036aae22Christian Maederimport HasCASL.TypeAna
b645cf3dc1e449038ed291bbd11fcc6e02b2fc7fChristian Maederimport HasCASL.PrintLe()
04dada28736b4a237745e92063d8bdd49a362debChristian Maederimport HasCASL.Unify
b984ff0ba75221f64451c1e69b3977967d4e99a1Christian Maederimport HasCASL.Builtin
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maederimport HasCASL.MapTerm
ad270004874ce1d0697fb30d7309f180553bb315Christian Maederimport qualified Data.Map as Map
ad270004874ce1d0697fb30d7309f180553bb315Christian Maederimport qualified Data.Set as Set
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder
89054b2b95a3f92e78324dc852f3d34704e2ca49Christian Maederimport Control.Monad(foldM)
b984ff0ba75221f64451c1e69b3977967d4e99a1Christian Maederimport Data.List
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaederimproveDiag :: (PosItem a, Pretty a) => a -> Diagnosis -> Diagnosis
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaederimproveDiag v d = d { diagString = let f:l = lines $ diagString d in
4ef2a978e66e2246ff0b7f00c77deb7aabb28b8eChristian Maeder                      unlines $ (f ++ " of '" ++ showDoc v "'") : l
42c01284bba8d7c8d995c8dfb96ace57d28ed1bcTill Mossakowski                    , diagPos = getRange v
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder                    }
b190f5c7cf3ddda73724efe5ce82b9585ed76be1Christian Maeder
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaedermergeMap :: (Ord a, PosItem a, Pretty a) =>
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder            (b -> b) -> (b -> b -> Result b)
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder         -> Map.Map a b -> Map.Map a b -> Result  (Map.Map a b)
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaedermergeMap e f m1 m2 = foldM ( \ m (k, v) ->
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder                          case k `Map.lookup` m of
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder                          Nothing -> return $ Map.insert k (e v) m
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder                          Just w ->
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder                              let Result ds mu = f (e v) w
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder                                  ns = map (improveDiag k) ds
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder                              in case mu of
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder                                 Nothing -> Result ns $ Nothing
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder                                 Just u -> Result ns $ Just $ Map.insert k u m)
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder                  Map.empty (Map.toList m1 ++ Map.toList m2)
462ec4b2fa3e0e788eb60dcb4aebc518298f342cChristian Maeder
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian MaedermergeClassInfo :: ClassInfo -> ClassInfo -> Result ClassInfo
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian MaedermergeClassInfo c1 c2 = do
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder    k <- mergeA "class raw kind" (rawKind c1) $ rawKind c2
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder    return $ ClassInfo k $ Set.union (classKinds c1) $ classKinds c2
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian MaedermergeTypeInfo :: ClassMap -> TypeInfo -> TypeInfo -> Result TypeInfo
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian MaedermergeTypeInfo cm t1 t2 =
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder    do k <- mergeA "tye raw kind" (typeKind t1) $ typeKind t2
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder       let o = keepMinKinds cm [otherTypeKinds t1, otherTypeKinds t2]
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder       let s = Set.union (superTypes t1) $ superTypes t2
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder       d <- mergeTypeDefn (typeDefn t1) $ typeDefn t2
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder       return $ TypeInfo k o s d
462ec4b2fa3e0e788eb60dcb4aebc518298f342cChristian Maeder
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian MaedermergeTypeDefn :: TypeDefn -> TypeDefn -> Result TypeDefn
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaedermergeTypeDefn d1 d2 =
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder        case (d1, d2) of
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder            (_, DatatypeDefn _) -> return d2
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder            (PreDatatype, _) -> fail "expected data type definition"
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder            (_, PreDatatype) -> return d1
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder            (NoTypeDefn, _) -> return d2
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder            (_, NoTypeDefn) -> return d1
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder            (AliasTypeDefn s1, AliasTypeDefn s2) ->
27912d626bf179b82fcb337077e5cd9653bb71cfChristian Maeder                do s <- mergeAlias s1 s2
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder                   return $ AliasTypeDefn s
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder            (_, _) -> mergeA "TypeDefn" d1 d2
462ec4b2fa3e0e788eb60dcb4aebc518298f342cChristian Maeder
27912d626bf179b82fcb337077e5cd9653bb71cfChristian MaedermergeAlias :: Type -> Type -> Result Type
27912d626bf179b82fcb337077e5cd9653bb71cfChristian MaedermergeAlias s1 s2 = if s1 == s2 then return s1
27912d626bf179b82fcb337077e5cd9653bb71cfChristian Maeder    else fail $ "wrong type" ++ expected s1 s2
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian MaedermergeOpBrand :: OpBrand -> OpBrand -> OpBrand
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian MaedermergeOpBrand b1 b2 = case (b1, b2) of
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder      (Pred, _) -> Pred
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder      (_, Pred) -> Pred
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder      (Op, _) -> Op
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder      (_, Op) -> Op
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder      _ -> Fun
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian MaedermergeOpDefn :: OpDefn -> OpDefn -> Result OpDefn
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian MaedermergeOpDefn d1 d2 = case (d1, d2) of
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder      (NoOpDefn b1, NoOpDefn b2) -> do
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder        let b = mergeOpBrand b1 b2
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder        return $ NoOpDefn b
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder      (SelectData c1 s, SelectData c2 _) -> do
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder        let c = Set.union c1 c2
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder        return $ SelectData c s
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder      (Definition b1 e1, Definition b2 e2) -> do
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder        d <- mergeTerm Hint e1 e2
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder        let b = mergeOpBrand b1 b2
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder        return $ Definition b d
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder      (NoOpDefn b1, Definition b2 e2) -> do
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder        let b = mergeOpBrand b1 b2
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder        return $ Definition b e2
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder      (Definition b1 e1, NoOpDefn b2) -> do
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder        let b = mergeOpBrand b1 b2
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder        return $ Definition b e1
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian 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
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder
ad187062b0009820118c1b773a232e29b879a2faChristian MaedermergeOpInfos :: TypeMap -> Set.Set OpInfo -> Set.Set OpInfo
ad187062b0009820118c1b773a232e29b879a2faChristian Maeder             -> Result (Set.Set OpInfo)
ad187062b0009820118c1b773a232e29b879a2faChristian MaedermergeOpInfos tm s1 s2 = mergeOps (addUnit tm) s1 s2
ad187062b0009820118c1b773a232e29b879a2faChristian Maeder
ad187062b0009820118c1b773a232e29b879a2faChristian MaedermergeOps :: TypeMap -> Set.Set OpInfo -> Set.Set OpInfo
ad187062b0009820118c1b773a232e29b879a2faChristian Maeder         -> Result (Set.Set OpInfo)
ad187062b0009820118c1b773a232e29b879a2faChristian MaedermergeOps tm s1 s2 = if Set.null s1 then return s2 else do
ad187062b0009820118c1b773a232e29b879a2faChristian Maeder    let (o, os) = Set.deleteFindMin s1
ad187062b0009820118c1b773a232e29b879a2faChristian Maeder        (es, us) = Set.partition (isUnifiable tm 1 (opType o) . opType) s2
ad187062b0009820118c1b773a232e29b879a2faChristian Maeder    s <- mergeOps tm os us
ad187062b0009820118c1b773a232e29b879a2faChristian Maeder    r <- foldM (mergeOpInfo tm) o $ Set.toList es
ad187062b0009820118c1b773a232e29b879a2faChristian Maeder    return $ Set.insert r s
b984ff0ba75221f64451c1e69b3977967d4e99a1Christian Maeder
962d5c684e2b86d1f9c556c096b426e10cc74026Christian MaedermergeOpInfo ::  TypeMap -> OpInfo -> OpInfo -> Result OpInfo
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaedermergeOpInfo tm o1 o2 =
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder        do let s1 = opType o1
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder               s2 = opType o2
962d5c684e2b86d1f9c556c096b426e10cc74026Christian Maeder           sc <- if instScheme tm 1 s2 s1 then return s1
962d5c684e2b86d1f9c556c096b426e10cc74026Christian Maeder                    else if instScheme tm 1 s1 s2 then return s2
962d5c684e2b86d1f9c556c096b426e10cc74026Christian Maeder                    else fail "overlapping but incompatible type schemes"
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder           let as = Set.union (opAttrs o1) $ opAttrs o2
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder           d <- mergeOpDefn (opDefn o1) $ opDefn o2
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder           return $ OpInfo sc as d
b984ff0ba75221f64451c1e69b3977967d4e99a1Christian Maeder
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maedermerge :: Env -> Env -> Result Env
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maedermerge e1 e2 =
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder        do cMap <- mergeMap id mergeClassInfo (classMap e1) $ classMap e2
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder           let clMap = Map.map (\ ci -> ci { classKinds =
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder                          keepMinKinds cMap [classKinds ci] }) cMap
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder           tMap <- mergeMap id (mergeTypeInfo clMap)
6cca02cb6a5ae882d887a879f8b7a71941c3715cChristian Maeder                   (typeMap e1) $ typeMap e2
27912d626bf179b82fcb337077e5cd9653bb71cfChristian Maeder           case filterAliases tMap of
27912d626bf179b82fcb337077e5cd9653bb71cfChristian Maeder             tAs -> do
ad187062b0009820118c1b773a232e29b879a2faChristian Maeder               as <- mergeMap (Set.map $ mapOpInfo (id, expandAliases tAs))
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder                   (mergeOpInfos tMap) (assumps e1) $ assumps e2
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder               return initialEnv
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder                          { classMap = clMap
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder                          , typeMap = tMap
f454c20b6c126bea7d31d400cc8824b9ee8cc6eaChristian Maeder                          , assumps = as }
ee9eddfa6953868fd6fbaff0d9ff68675a13675aChristian Maeder
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaedermergeA :: (Pretty a, Eq a) => String -> a -> a -> Result a
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian MaedermergeA str t1 t2 = if t1 == t2 then return t1 else
4fb19f237193a3bd6778f8aee3b6dd8da5856665Christian Maeder    fail ("different " ++ str ++ expected t1 t2)
c797f343be2f3619bb1f5569753166ec49d27bdbChristian Maeder
15bb922b665fcd44c6230a1202785d0c7890e90cChristian MaedermergeTerm :: DiagKind -> Term -> Term -> Result Term
15bb922b665fcd44c6230a1202785d0c7890e90cChristian MaedermergeTerm k t1 t2 = if t1 == t2 then return t1 else
e95bbf384f5cbcb7eb23286d5f15dffbd471db17Christian Maeder            Result [Diag k ("different terms" ++ expected t1 t2)
42c01284bba8d7c8d995c8dfb96ace57d28ed1bcTill Mossakowski                    nullRange] $ Just t2