+%
+% (c) The University of Glasgow 2006
+%
+
\begin{code}
module Unify (
-- Matching of types:
-- the "tc" prefix indicates that matching always
-- respects newtypes (rather than looking through them)
- tcMatchTys, tcMatchTyX, ruleMatchTyX, tcMatchPreds, MatchEnv(..)
+ tcMatchTy, tcMatchTys, tcMatchTyX,
+ ruleMatchTyX, tcMatchPreds, MatchEnv(..)
) where
#include "HsVersions.h"
-import Var ( Var, TyVar, tyVarKind )
+import Var
import VarEnv
import VarSet
-import Type ( typeKind, tyVarsOfType, tyVarsOfTypes, tyVarsOfTheta,
- TvSubstEnv, emptyTvSubstEnv, TvSubst(..), tcEqTypeX,
- tcView, isSubKind, repSplitAppTy_maybe )
-import TypeRep ( Type(..), PredType(..) )
+import Type
+import TypeRep
import Outputable
import Maybes
\end{code}
, me_env :: RnEnv2 -- Renaming envt for nested foralls
} -- In-scope set includes template tyvars
+tcMatchTy :: TyVarSet -- Template tyvars
+ -> Type -- Template
+ -> Type -- Target
+ -> Maybe TvSubst -- One-shot; in principle the template
+ -- variables could be free in the target
+
+tcMatchTy tmpls ty1 ty2
+ = case match menv emptyTvSubstEnv ty1 ty2 of
+ Just subst_env -> Just (TvSubst in_scope subst_env)
+ Nothing -> Nothing
+ where
+ menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope }
+ in_scope = mkInScopeSet (tmpls `unionVarSet` tyVarsOfType ty2)
+ -- We're assuming that all the interesting
+ -- tyvars in tys1 are in tmpls
+
tcMatchTys :: TyVarSet -- Template tyvars
- -> [Type] -- Template
- -> [Type] -- Target
- -> Maybe TvSubst -- One-shot; in principle the template
+ -> [Type] -- Template
+ -> [Type] -- Target
+ -> Maybe TvSubst -- One-shot; in principle the template
-- variables could be free in the target
tcMatchTys tmpls tys1 tys2
-- it respects NewTypes and PredType
match menv subst ty1 ty2 | Just ty1' <- tcView ty1 = match menv subst ty1' ty2
-match menv subst ty1 ty2 | Just ty2' <- tcView ty2 = match menv subst ty1 ty2'
+ | Just ty2' <- tcView ty2 = match menv subst ty1 ty2'
match menv subst (TyVarTy tv1) ty2
- | tv1 `elemVarSet` me_tmpls menv
+ | tv1' `elemVarSet` me_tmpls menv
= case lookupVarEnv subst tv1' of
- Nothing | any (inRnEnvR rn_env) (varSetElems (tyVarsOfType ty2))
- -> Nothing -- Occurs check
- | not (typeKind ty2 `isSubKind` tyVarKind tv1)
- -> Nothing -- Kind mis-match
- | otherwise
- -> Just (extendVarEnv subst tv1 ty2)
-
- Just ty1' | tcEqTypeX (nukeRnEnvL rn_env) ty1' ty2
+ Nothing -- No existing binding
+ | any (inRnEnvR rn_env) (varSetElems (tyVarsOfType ty2))
+ -> Nothing -- Occurs check
+ | not (typeKind ty2 `isSubKind` tyVarKind tv1)
+ -> Nothing -- Kind mis-match
+ | otherwise
+ -> Just (extendVarEnv subst tv1' ty2)
+
+ Just ty1' -- There is an existing binding; check whether ty2 matches it
+ | tcEqTypeX (nukeRnEnvL rn_env) ty1' ty2
-- ty1 has no locally-bound variables, hence nukeRnEnvL
-- Note tcEqType...we are doing source-type matching here
- -> Just subst
-
- other -> Nothing
+ -> Just subst
+ | otherwise -> Nothing -- ty2 doesn't match
+
| otherwise -- tv1 is not a template tyvar
= case ty2 of
; match menv subst' ty1b ty2b }
match menv subst (AppTy ty1a ty1b) ty2
| Just (ty2a, ty2b) <- repSplitAppTy_maybe ty2
+ -- 'repSplit' used because the tcView stuff is done above
= do { subst' <- match menv subst ty1a ty2a
; match menv subst' ty1b ty2b }