Unify.hs revision 1738d16957389457347bee85075d3d33d002158f
abd8dd44106c507dd2cb64359b63d7d56fa0a9c8Christian MaederModule : $Header$
abd8dd44106c507dd2cb64359b63d7d56fa0a9c8Christian MaederCopyright : (c) Christian Maeder and Uni Bremen 2003
97018cf5fa25b494adffd7e9b4e87320dae6bf47Christian MaederLicence : similar to LGPL, see HetCATS/LICENCE.txt or LIZENZ.txt
b4fbc96e05117839ca409f5f20f97b3ac872d1edTill MossakowskiMaintainer : maeder@tzi.de
abd8dd44106c507dd2cb64359b63d7d56fa0a9c8Christian MaederStability : experimental
413db961f13e112716509b6d61d7a7bbf50c98b2Christian MaederPortability : portable
f3a94a197960e548ecd6520bb768cb0d547457bbChristian Maeder substitution and unification of types
47d6bc7bc9a708427f96be8d805f712697ad3d9eChristian Maederimport qualified Common.Lib.Map as Map
23a00c966f2aa8da525d7a7c51933c99964426c0Christian Maederimport qualified Common.Lib.Set as Set
3c5cc698b0c061209ff83eb8de027daef5ae922aChristian Maeder-- | check for unbound type variables
3c5cc698b0c061209ff83eb8de027daef5ae922aChristian MaederunboundTypevars :: [TypeArg] -> Type -> [Diagnosis]
3c5cc698b0c061209ff83eb8de027daef5ae922aChristian MaederunboundTypevars args ct =
413db961f13e112716509b6d61d7a7bbf50c98b2Christian Maeder let restVars = varsOf ct List.\\ args in
413db961f13e112716509b6d61d7a7bbf50c98b2Christian Maeder if null restVars then []
413db961f13e112716509b6d61d7a7bbf50c98b2Christian Maeder else [mkDiag Error ("unbound type variable(s)\n\t"
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder ++ showSepList ("," ++) showPretty
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder restVars " in") ct]
8452387b4c54b8dd36c012b216e0b0c5004ca6f1Christian MaedervarsOf :: Type -> [TypeArg]
c18e9c3c6d5039618f1f2c05526ece84c7794ea3Christian MaedervarsOf = leaves (/=0)
ce3928e71520030ad0275b72050a8f4377f9313cChristian Maeder-- | vars or other ids
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maederleaves :: (Int -> Bool) -> Type -> [TypeArg]
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder TypeName j k i -> if b(i)
eab576044505ba1fbc64610323053490fbd9e82cChristian Maeder then [TypeArg j k Other []]
81946e2b3f6dde6167f48769bd02c7a634736856Christian Maeder TypeAppl t1 t2 -> leaves b t1 `List.union` leaves b t2
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder ExpandedType _ t2 -> leaves b t2
eab576044505ba1fbc64610323053490fbd9e82cChristian Maeder KindedType tk _ _ -> leaves b tk
eab576044505ba1fbc64610323053490fbd9e82cChristian Maeder LazyType tl _ -> leaves b tl
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder ProductType l _ -> foldl List.union [] $ map (leaves b) l
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder FunType t1 _ t2 _ -> leaves b t1 `List.union` leaves b t2
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder _ -> error ("leaves: " ++ show t)
a59f2017dfc311ece7afcea3e8a3ceceac77ba5aChristian Maeder-- | composition (reversed: first substitution first!)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaedercompSubst :: Subst -> Subst -> Subst
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaedercompSubst s1 s2 = Map.union (Map.map (subst s2) s1) s2
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder-- | unifiability of type schemes including instantiation with fresh variables
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder-- (and looking up type aliases)
abd8dd44106c507dd2cb64359b63d7d56fa0a9c8Christian MaederisUnifiable :: TypeMap -> Int -> TypeScheme -> TypeScheme -> Bool
c4e912fc181d72c8d0e0e38d0351278182f0d0b5Christian MaederisUnifiable tm c = asSchemes c (unify tm)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder-- | test if second scheme is a substitution instance
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaederinstScheme :: TypeMap -> Int -> TypeScheme -> TypeScheme -> Bool
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaederinstScheme tm c = asSchemes c (subsume tm)
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder-- | lift 'State' Int to 'State' Env
92aa1b88f02d2a413da60dba78acd34312e6f29aChristian MaedertoEnvState :: State Int a -> State Env a
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaedertoEnvState p =
36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder let (r, c) = runState p $ counter s
81946e2b3f6dde6167f48769bd02c7a634736856Christian Maeder put s { counter = c }
413db961f13e112716509b6d61d7a7bbf50c98b2Christian MaedertoSchemes :: (Type -> Type -> a) -> TypeScheme -> TypeScheme -> State Int a
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaedertoSchemes f sc1 sc2 =
413db961f13e112716509b6d61d7a7bbf50c98b2Christian Maeder do t1 <- freshInst sc1
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder t2 <- freshInst sc2
36c6cc568751e4235502cfee00ba7b597dae78dcChristian Maeder return $ f t1 t2
d48085f765fca838c1d972d2123601997174583dChristian MaederasSchemes :: Int -> (Type -> Type -> a) -> TypeScheme -> TypeScheme -> a
d48085f765fca838c1d972d2123601997174583dChristian MaederasSchemes c f sc1 sc2 = fst $ runState (toSchemes f sc1 sc2) c
68485f7bfab1b4c6f963ce6837cba5fb148ed625Christian Maeder-- -------------------------------------------------------------------------
d48085f765fca838c1d972d2123601997174583dChristian MaederfreshInst :: TypeScheme -> State Int Type
a59f2017dfc311ece7afcea3e8a3ceceac77ba5aChristian MaederfreshInst (TypeScheme tArgs (_ :=> t) _) =
8452387b4c54b8dd36c012b216e0b0c5004ca6f1Christian Maeder do m <- mkSubst tArgs
8452387b4c54b8dd36c012b216e0b0c5004ca6f1Christian Maeder return $ repl (Map.fromList $ zip tArgs $ map snd m) t
a59f2017dfc311ece7afcea3e8a3ceceac77ba5aChristian MaederfreshVar :: Pos -> State Int (Id, Int)
a59f2017dfc311ece7afcea3e8a3ceceac77ba5aChristian Maeder return (simpleIdToId $ Token ("_var_" ++ show c) p, c)
a59f2017dfc311ece7afcea3e8a3ceceac77ba5aChristian MaedermkSingleSubst :: TypeArg -> State Int (Int, Type)
68485f7bfab1b4c6f963ce6837cba5fb148ed625Christian MaedermkSingleSubst tv@(TypeArg _ k _ _) =
413db961f13e112716509b6d61d7a7bbf50c98b2Christian Maeder do (ty, c) <- freshVar $ posOfTypeArg tv
413db961f13e112716509b6d61d7a7bbf50c98b2Christian Maeder return (c, TypeName ty k c)
d48085f765fca838c1d972d2123601997174583dChristian MaedermkSubst :: [TypeArg] -> State Int [(Int, Type)]
2986838ec286d67e7c199e7ea81e7364ca36ad25Christian MaedermkSubst tas = mapM mkSingleSubst tas
68485f7bfab1b4c6f963ce6837cba5fb148ed625Christian Maedertype Subst = Map.Map Int Type
413db961f13e112716509b6d61d7a7bbf50c98b2Christian Maederclass Unifiable a where
68485f7bfab1b4c6f963ce6837cba5fb148ed625Christian Maeder subst :: Subst -> a -> a
68485f7bfab1b4c6f963ce6837cba5fb148ed625Christian Maeder match :: TypeMap -> (Bool, a) -> (Bool, a) -> Result Subst
d48085f765fca838c1d972d2123601997174583dChristian Maeder-- | most general unifier via 'match'
413db961f13e112716509b6d61d7a7bbf50c98b2Christian Maeder-- where both sides may contribute substitutions
413db961f13e112716509b6d61d7a7bbf50c98b2Christian Maedermgu :: Unifiable a => TypeMap -> a -> a -> Result Subst
413db961f13e112716509b6d61d7a7bbf50c98b2Christian Maedermgu tm a b = match tm (True, a) (True, b)
68485f7bfab1b4c6f963ce6837cba5fb148ed625Christian Maederunify :: Unifiable a => TypeMap -> a -> a -> Bool
413db961f13e112716509b6d61d7a7bbf50c98b2Christian Maederunify tm a b = isJust $ maybeResult $ mgu tm a b
413db961f13e112716509b6d61d7a7bbf50c98b2Christian Maedersubsume :: Unifiable a => TypeMap -> a -> a -> Bool
d48085f765fca838c1d972d2123601997174583dChristian Maedersubsume tm a b = isJust $ maybeResult $ match tm (False, a) (True, b)
413db961f13e112716509b6d61d7a7bbf50c98b2Christian MaederequalSubs :: Unifiable a => TypeMap -> a -> a -> Bool
68485f7bfab1b4c6f963ce6837cba5fb148ed625Christian MaederequalSubs tm a b = subsume tm a b && subsume tm b a
d48085f765fca838c1d972d2123601997174583dChristian Maeder-- | get the type variable
413db961f13e112716509b6d61d7a7bbf50c98b2Christian MaedergetTypeVar :: TypeArg -> Id
68485f7bfab1b4c6f963ce6837cba5fb148ed625Christian MaedergetTypeVar(TypeArg v _ _ _) = v
68485f7bfab1b4c6f963ce6837cba5fb148ed625Christian MaederidsOf :: (Int -> Bool) -> Type -> Set.Set TypeId
d48085f765fca838c1d972d2123601997174583dChristian MaederidsOf b = Set.fromList . map getTypeVar . leaves b
68485f7bfab1b4c6f963ce6837cba5fb148ed625Christian MaederoccursIn :: TypeMap -> TypeId -> Type -> Bool
d48085f765fca838c1d972d2123601997174583dChristian MaederoccursIn tm i = Set.any (relatedTypeIds tm i) . idsOf (const True)
d48085f765fca838c1d972d2123601997174583dChristian MaederrelatedTypeIds :: TypeMap -> TypeId -> TypeId -> Bool
68485f7bfab1b4c6f963ce6837cba5fb148ed625Christian MaederrelatedTypeIds tm i1 i2 =
68485f7bfab1b4c6f963ce6837cba5fb148ed625Christian Maeder not $ Set.disjoint (allRelIds tm i1) $ allRelIds tm i2
d48085f765fca838c1d972d2123601997174583dChristian MaederallRelIds :: TypeMap -> TypeId -> Set.Set TypeId
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaederallRelIds tm i = Set.union (superIds tm i) $ subIds tm i
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaedermapType :: IdMap -> Type -> Type
68485f7bfab1b4c6f963ce6837cba5fb148ed625Christian MaedermapType m ty = if Map.isEmpty m then ty else
68485f7bfab1b4c6f963ce6837cba5fb148ed625Christian Maeder rename ( \ i k n ->
eab576044505ba1fbc64610323053490fbd9e82cChristian Maeder let t = TypeName i k n in
a59f2017dfc311ece7afcea3e8a3ceceac77ba5aChristian Maeder if n == 0 then
eab576044505ba1fbc64610323053490fbd9e82cChristian Maeder Just j -> TypeName j k 0
68485f7bfab1b4c6f963ce6837cba5fb148ed625Christian Maederrename :: (TypeId -> Kind -> Int -> Type) -> Type -> Type
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maederrename m t = case t of
413db961f13e112716509b6d61d7a7bbf50c98b2Christian Maeder TypeName i k n -> m i k n
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder TypeAppl t1 t2 -> TypeAppl (rename m t1) (rename m t2)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder ExpandedType t1 t2 -> ExpandedType (rename m t1) (rename m t2)
413db961f13e112716509b6d61d7a7bbf50c98b2Christian Maeder TypeToken _ -> t
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder BracketType b l ps ->
48c4688439e0aade4faeebf25ca8b16d661e47afChristian Maeder BracketType b (map (rename m) l) ps
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder KindedType tk k ps ->
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder KindedType (rename m tk) k ps
37354e3ed68875fb527338105a610df481f98cb0Christian Maeder MixfixType l -> MixfixType $ map (rename m) l
413db961f13e112716509b6d61d7a7bbf50c98b2Christian Maeder LazyType tl ps -> LazyType (rename m tl) ps
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder ProductType l ps -> ProductType (map (rename m) l) ps
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder FunType t1 a t2 ps -> FunType (rename m t1) a (rename m t2) ps
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maederinstance Unifiable Type where
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder subst m = rename (\ i k n ->
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder _ -> TypeName i k n)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder match m (a, s) (b, t) = mm m (a, expandAlias m s)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder (b, expandAlias m t)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder mm tm t1 (b2, ExpandedType _ t2) = mm tm t1 (b2, t2)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder mm tm (b1, ExpandedType _ t1) t2 = mm tm (b1, t1) t2
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder mm tm t1 (b2, LazyType t2 _) = mm tm t1 (b2, t2)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder mm tm (b1, LazyType t1 _) t2 = mm tm (b1, t1) t2
8452387b4c54b8dd36c012b216e0b0c5004ca6f1Christian Maeder mm tm t1 (b2, KindedType t2 _ _) = mm tm t1 (b2, t2)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder mm tm (b1, KindedType t1 _ _) t2 = mm tm (b1, t1) t2
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder mm tm (b1, t1@(TypeName i1 _ v1)) (b2, t2@(TypeName i2 _ v2)) =
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder if relatedTypeIds tm i1 i2
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder then return eps
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder else if v1 > 0 && b1 then return $
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder else if v2 > 0 && b2 then return $
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder else uniResult "typename" i1
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder "is not unifiable with typename" i2
f875f7eebac7f69bf9da98c93479a542d0a8056fChristian Maeder mm tm (b1, TypeName i1 _ v1) (_, t2) =
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder if v1 > 0 && b1 then
24f79601ad5e42ce74f4152a36aad257d7c4d7b5Christian Maeder if occursIn tm i1 t2 then
24f79601ad5e42ce74f4152a36aad257d7c4d7b5Christian Maeder uniResult "var" i1 "occurs in" t2
24f79601ad5e42ce74f4152a36aad257d7c4d7b5Christian Maeder else return $
24f79601ad5e42ce74f4152a36aad257d7c4d7b5Christian Maeder else uniResult "typename" i1
24f79601ad5e42ce74f4152a36aad257d7c4d7b5Christian Maeder "is not unifiable with type" t2
24f79601ad5e42ce74f4152a36aad257d7c4d7b5Christian Maeder mm tm t2 t1@(_, TypeName _ _ _) = mm tm t1 t2
24f79601ad5e42ce74f4152a36aad257d7c4d7b5Christian Maeder mm tm (b1, TypeAppl t1 t2) (b2, TypeAppl t3 t4) =
24f79601ad5e42ce74f4152a36aad257d7c4d7b5Christian Maeder match tm (b1, (t1, t2)) (b2, (t3, t4))
24f79601ad5e42ce74f4152a36aad257d7c4d7b5Christian Maeder mm tm (b1, ProductType p1 _) (b2, ProductType p2 _) =
f8a1ab8012a1f36060d6ce9b63399fa4a8a2981cChristian Maeder match tm (b1, p1) (b2, p2)
8452387b4c54b8dd36c012b216e0b0c5004ca6f1Christian Maeder mm tm (b1, FunType t1 _ t2 _) (b2, FunType t3 _ t4 _) =
8452387b4c54b8dd36c012b216e0b0c5004ca6f1Christian Maeder match tm (b1, (t1, t2)) (b2, (t3, t4))
f8a1ab8012a1f36060d6ce9b63399fa4a8a2981cChristian Maeder mm _ (_,t1) (_,t2) = uniResult "type" t1
f8a1ab8012a1f36060d6ce9b63399fa4a8a2981cChristian Maeder "is not unifiable with type" t2
f875f7eebac7f69bf9da98c93479a542d0a8056fChristian MaedershowPrettyWithPos :: (PrettyPrint a, PosItem a) => a -> ShowS
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaedershowPrettyWithPos a = let p = getMyPos a in
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder showChar '\'' . showPretty a . showChar '\''
ce3928e71520030ad0275b72050a8f4377f9313cChristian Maeder . noShow (nullPos == p) (showChar ' ' .
8452387b4c54b8dd36c012b216e0b0c5004ca6f1Christian Maeder showParen True (showPos p))
f8a1ab8012a1f36060d6ce9b63399fa4a8a2981cChristian MaederuniResult :: (PrettyPrint a, PosItem a, PrettyPrint b, PosItem b) =>
f875f7eebac7f69bf9da98c93479a542d0a8056fChristian Maeder String -> a -> String -> b -> Result Subst
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaederuniResult s1 a s2 b =
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder Result [Diag Hint ("in type\n" ++ " " ++ s1 ++ " " ++
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder showPrettyWithPos a "\n " ++ s2 ++ " " ++
f875f7eebac7f69bf9da98c93479a542d0a8056fChristian Maeder showPrettyWithPos b "") nullPos] Nothing
ce3928e71520030ad0275b72050a8f4377f9313cChristian Maederinstance (Unifiable a, Unifiable b) => Unifiable (a, b) where
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder subst s (t1, t2) = (subst s t1, subst s t2)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder match tm (b1, (t1, t2)) (b2, (t3, t4)) =
f875f7eebac7f69bf9da98c93479a542d0a8056fChristian Maeder let r1@(Result _ m1) = match tm (b1, t1) (b2, t3) in
68485f7bfab1b4c6f963ce6837cba5fb148ed625Christian Maeder Nothing -> r1
f875f7eebac7f69bf9da98c93479a542d0a8056fChristian Maeder Just s1 -> let r2@(Result _ m2) =
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder match tm (b1, if b1 then subst s1 t2 else t2)
8452387b4c54b8dd36c012b216e0b0c5004ca6f1Christian Maeder (b2, if b2 then subst s1 t4 else t4)
24f79601ad5e42ce74f4152a36aad257d7c4d7b5Christian Maeder in case m2 of
ce3928e71520030ad0275b72050a8f4377f9313cChristian Maeder Nothing -> r2
8452387b4c54b8dd36c012b216e0b0c5004ca6f1Christian Maeder Just s2 -> return $ compSubst s1 s2
5581c4644d91dcb9b7e2e7f6052f7cbf5f97b6deChristian Maederinstance (PrettyPrint a, PosItem a, Unifiable a) => Unifiable [a] where
5581c4644d91dcb9b7e2e7f6052f7cbf5f97b6deChristian Maeder subst s = map (subst s)
5581c4644d91dcb9b7e2e7f6052f7cbf5f97b6deChristian Maeder match _ (_, []) (_, []) = return eps
5581c4644d91dcb9b7e2e7f6052f7cbf5f97b6deChristian Maeder match tm (b1, a1:r1) (b2, a2:r2) = match tm (b1, (a1, r1)) (b2, (a2, r2))
f875f7eebac7f69bf9da98c93479a542d0a8056fChristian Maeder match tm (b1, []) l = match tm l (b1, [])
8a6b503b50c0be589f12eb0d4ebeb4b4312fd491Christian Maeder match _ (_, (a:_)) (_, []) = uniResult "type component" a
f875f7eebac7f69bf9da98c93479a542d0a8056fChristian Maeder "is not unifiable with the empty list"
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder (mkSimpleId "[]")
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maederinstance (PrettyPrint a, PosItem a, Unifiable a) => Unifiable (Maybe a) where
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder subst s = fmap (subst s)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder match _ (_, Nothing) _ = return eps
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder match _ _ (_, Nothing) = return eps
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder match tm (b1, Just a1) (b2, Just a2) = match tm (b1, a1) (b2, a2)
f875f7eebac7f69bf9da98c93479a542d0a8056fChristian Maederrepl :: Map.Map TypeArg Type -> Type -> Type
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maederrepl m = rename ( \ i k n ->
5581c4644d91dcb9b7e2e7f6052f7cbf5f97b6deChristian Maeder case Map.lookup (TypeArg i k Other []) m of
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder Nothing -> TypeName i k n)
413db961f13e112716509b6d61d7a7bbf50c98b2Christian MaederexpandAlias :: TypeMap -> Type -> Type
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian MaederexpandAlias tm t =
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder let (ps, as, ta, b) = expandAliases tm t in
966e627a1c06b302a06d59d08b8ab45905f3509cChristian Maeder if b && length ps == length as then
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder ExpandedType t $ repl (Map.fromList (zip ps $ reverse as)) ta
ce3928e71520030ad0275b72050a8f4377f9313cChristian MaederexpandAliases :: TypeMap -> Type -> ([TypeArg], [Type], Type, Bool)
8452387b4c54b8dd36c012b216e0b0c5004ca6f1Christian MaederexpandAliases tm t = case t of
eab576044505ba1fbc64610323053490fbd9e82cChristian Maeder TypeName i _ _ -> case Map.lookup i tm of
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder Just (TypeInfo _ _ _
f875f7eebac7f69bf9da98c93479a542d0a8056fChristian Maeder (AliasTypeDefn (TypeScheme l (_ :=> ts) _))) ->
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder (l, [], ts, True)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder Just (TypeInfo _ _ _
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder (Supertype _ (TypeScheme l (_ :=> ts) _) _)) ->
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder (l, [], ts, True)
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder TypeAppl t1 t2 ->
028f19cdb09d52bb2fd207399b6fa874540d1670Christian Maeder let (ps, as, ta, b) = expandAliases tm t1
68485f7bfab1b4c6f963ce6837cba5fb148ed625Christian Maeder t3 = expandAlias tm t2
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder (ps, t3:as, ta, b) -- reverse later on
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder else wrap $ TypeAppl t1 t3
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder FunType t1 a t2 ps ->
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder wrap $ FunType (expandAlias tm t1) a (expandAlias tm t2) ps
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder ProductType ts ps -> wrap $ ProductType (map (expandAlias tm) ts) ps
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder LazyType ty ps -> wrap $ LazyType (expandAlias tm ty) ps
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder ExpandedType t1 t2 -> wrap $ ExpandedType t1 $ expandAlias tm t2
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder KindedType ty k ps -> wrap $ KindedType (expandAlias tm ty) k ps
5a13581acc5a76d392c1dec01657bb3efd4dcf2dChristian Maeder where wrap ty = ([], [], ty, False)
d703a61b7fa9f85d92ac8f768d7c290b7c0a41c5Christian Maeder-- | super type ids
028f19cdb09d52bb2fd207399b6fa874540d1670Christian MaedersuperIds :: TypeMap -> Id -> Set.Set Id
028f19cdb09d52bb2fd207399b6fa874540d1670Christian MaedersuperIds tm = supIds tm Set.empty . Set.single
028f19cdb09d52bb2fd207399b6fa874540d1670Christian MaedersubIds :: TypeMap -> Id -> Set.Set Id
028f19cdb09d52bb2fd207399b6fa874540d1670Christian MaedersubIds tm i = foldr ( \ j s ->
028f19cdb09d52bb2fd207399b6fa874540d1670Christian Maeder if Set.member i $ superIds tm j then
028f19cdb09d52bb2fd207399b6fa874540d1670Christian Maeder Set.insert j s else s) Set.empty $ Map.keys tm
028f19cdb09d52bb2fd207399b6fa874540d1670Christian MaedersupIds :: TypeMap -> Set.Set Id -> Set.Set Id -> Set.Set Id
028f19cdb09d52bb2fd207399b6fa874540d1670Christian MaedersupIds tm known new =
028f19cdb09d52bb2fd207399b6fa874540d1670Christian Maeder if Set.isEmpty new then known else
028f19cdb09d52bb2fd207399b6fa874540d1670Christian Maeder let more = Set.unions $ map superTypeToId $
8452387b4c54b8dd36c012b216e0b0c5004ca6f1Christian Maeder concatMap ( \ i -> superTypes
028f19cdb09d52bb2fd207399b6fa874540d1670Christian Maeder $ Map.findWithDefault starTypeInfo i tm)
028f19cdb09d52bb2fd207399b6fa874540d1670Christian Maeder newKnown = Set.union known new
028f19cdb09d52bb2fd207399b6fa874540d1670Christian Maeder in supIds tm newKnown (more Set.\\ newKnown)
028f19cdb09d52bb2fd207399b6fa874540d1670Christian MaederstarTypeInfo :: TypeInfo
028f19cdb09d52bb2fd207399b6fa874540d1670Christian MaederstarTypeInfo = TypeInfo star [] [] NoTypeDefn
028f19cdb09d52bb2fd207399b6fa874540d1670Christian MaedersuperTypeToId :: Type -> Set.Set Id
028f19cdb09d52bb2fd207399b6fa874540d1670Christian MaedersuperTypeToId t =
028f19cdb09d52bb2fd207399b6fa874540d1670Christian Maeder TypeName i _ _ -> Set.single i