projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
More refactoring of constraint simplification
[ghc-hetmet.git]
/
compiler
/
types
/
Unify.lhs
diff --git
a/compiler/types/Unify.lhs
b/compiler/types/Unify.lhs
index
0f810da
..
5a1dbbc
100644
(file)
--- a/
compiler/types/Unify.lhs
+++ b/
compiler/types/Unify.lhs
@@
-1,3
+1,7
@@
+%
+% (c) The University of Glasgow 2006
+%
+
\begin{code}
module Unify (
-- Matching of types:
\begin{code}
module Unify (
-- Matching of types:
@@
-8,13
+12,11
@@
module Unify (
#include "HsVersions.h"
#include "HsVersions.h"
-import Var ( Var, TyVar, tyVarKind )
+import Var
import VarEnv
import VarSet
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}
import Outputable
import Maybes
\end{code}
@@
-118,24
+120,26
@@
match :: MatchEnv -- For the most part this is pushed downwards
-- it respects NewTypes and PredType
match menv subst ty1 ty2 | Just ty1' <- tcView ty1 = match menv subst ty1' ty2
-- 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
= case lookupVarEnv subst tv1' of
match menv subst (TyVarTy tv1) ty2
| 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
-- 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
| otherwise -- tv1 is not a template tyvar
= case ty2 of
@@
-159,6
+163,7
@@
match menv subst (FunTy ty1a ty1b) (FunTy ty2a ty2b)
; match menv subst' ty1b ty2b }
match menv subst (AppTy ty1a ty1b) ty2
| Just (ty2a, ty2b) <- repSplitAppTy_maybe ty2
; 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 }
= do { subst' <- match menv subst ty1a ty2a
; match menv subst' ty1b ty2b }