Move the register-inplace special-case stuff into the ghc-prim package

[ghc-hetmet.git] / compiler / types / Unify.lhs

diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs
index 9137150..7c8ad9d 100644 (file)
--- a/compiler/types/Unify.lhs
+++ b/compiler/types/Unify.lhs
@@ -158,23 +158,19 @@ match menv subst ty1 ty2 | Just ty1' <- coreView ty1 = match menv subst ty1' ty2
                         | Just ty2' <- coreView ty2 = match menv subst ty1 ty2'
 
 match menv subst (TyVarTy tv1) ty2
+  | Just ty1' <- lookupVarEnv subst tv1'       -- tv1' is already bound
+  = if tcEqTypeX (nukeRnEnvL rn_env) ty1' ty2
+       -- ty1 has no locally-bound variables, hence nukeRnEnvL
+       -- Note tcEqType...we are doing source-type matching here
+    then Just subst
+    else Nothing       -- ty2 doesn't match
+
   | tv1' `elemVarSet` me_tmpls menv
-  = case lookupVarEnv subst tv1' of
-       Nothing         -- No existing binding
-           | any (inRnEnvR rn_env) (varSetElems (tyVarsOfType ty2))
-           -> Nothing  -- Occurs check
-           | otherwise 
-           -> do { subst1 <- match_kind menv subst tv1 ty2
-                 ; return (extendVarEnv subst1 tv1' ty2) }
+  = if any (inRnEnvR rn_env) (varSetElems (tyVarsOfType ty2))
+    then Nothing       -- Occurs check
+    else do { subst1 <- match_kind menv subst tv1 ty2
                        -- Note [Matching kinds]
-
-       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
-           | otherwise -> Nothing      -- ty2 doesn't match
-           
+           ; return (extendVarEnv subst1 tv1' ty2) }
 
    | otherwise -- tv1 is not a template tyvar
    = case ty2 of
@@ -393,7 +389,7 @@ type InternalReft = TyVarEnv (Coercion, Type)
 
 instance Outputable Refinement where
   ppr (Reft _in_scope env)
-    = ptext SLIT("Refinement") <+>
+    = ptext (sLit "Refinement") <+>
         braces (ppr env)
 
 emptyRefinement :: Refinement
@@ -771,23 +767,23 @@ maybeErrToMaybe (Failed _)    = Nothing
 \begin{code}
 misMatch :: Type -> Type -> SDoc
 misMatch t1 t2
-  = ptext SLIT("Can't match types") <+> quotes (ppr t1) <+> 
-    ptext SLIT("and") <+> quotes (ppr t2)
+  = ptext (sLit "Can't match types") <+> quotes (ppr t1) <+> 
+    ptext (sLit "and") <+> quotes (ppr t2)
 
 lengthMisMatch :: [Type] -> [Type] -> SDoc
 lengthMisMatch tys1 tys2
-  = sep [ptext SLIT("Can't match unequal length lists"), 
+  = sep [ptext (sLit "Can't match unequal length lists"), 
         nest 2 (ppr tys1), nest 2 (ppr tys2) ]
 
 kindMisMatch :: TyVar -> Type -> SDoc
 kindMisMatch tv1 t2
-  = vcat [ptext SLIT("Can't match kinds") <+> quotes (ppr (tyVarKind tv1)) <+> 
-           ptext SLIT("and") <+> quotes (ppr (typeKind t2)),
-         ptext SLIT("when matching") <+> quotes (ppr tv1) <+> 
-               ptext SLIT("with") <+> quotes (ppr t2)]
+  = vcat [ptext (sLit "Can't match kinds") <+> quotes (ppr (tyVarKind tv1)) <+> 
+           ptext (sLit "and") <+> quotes (ppr (typeKind t2)),
+         ptext (sLit "when matching") <+> quotes (ppr tv1) <+> 
+               ptext (sLit "with") <+> quotes (ppr t2)]
 
 occursCheck :: TyVar -> Type -> SDoc
 occursCheck tv ty
-  = hang (ptext SLIT("Can't construct the infinite type"))
+  = hang (ptext (sLit "Can't construct the infinite type"))
        2 (ppr tv <+> equals <+> ppr ty)
 \end{code}