X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyFuns.lhs;h=3bd5fb60213d14148117dcf0548e09fb8e8481a5;hb=b5a8dd88e3939cf547be50ab62bae84f5bf0398d;hp=82e397f554cd23a23472bda17885983b9277cba8;hpb=583e2422f9f70c8ff69f948a3be788f5d412c862;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcTyFuns.lhs b/compiler/typecheck/TcTyFuns.lhs
index 82e397f..3bd5fb6 100644
--- a/compiler/typecheck/TcTyFuns.lhs
+++ b/compiler/typecheck/TcTyFuns.lhs
@@ -7,8 +7,6 @@ module TcTyFuns (
 
 	normaliseGivenEqs, normaliseGivenDicts, 
 	normaliseWantedEqs, normaliseWantedDicts,
-	solveWantedEqs,
-	substEqInDictInsts,
 	
         -- errors
         misMatchMsg, failWithMisMatch
@@ -311,38 +309,12 @@ normaliseGivenEqs givens
 \end{code}
 
 \begin{code}
-normaliseWantedEqs :: [Inst] -> TcM [Inst]
-normaliseWantedEqs insts 
-  = do { traceTc (text "normaliseWantedEqs <-" <+> ppr insts)
-       ; result <- liftM fst $ rewriteToFixedPoint Nothing
-		     [ ("(ZONK)",    dontRerun $ zonkInsts)
-		     , ("(TRIVIAL)", dontRerun $ trivialRule)
-		     , ("(DECOMP)",  decompRule)
-		     , ("(TOP)",     topRule)
-		     , ("(UNIFY)",   unifyMetaRule)      -- incl. occurs check
-		     , ("(SUBST)",   substRule)          -- incl. occurs check
-                     ] insts
-       ; traceTc (text "normaliseWantedEqs ->" <+> ppr result)
-       ; return result
-       }
-\end{code}
-
-
-%************************************************************************
-%*									*
-\section{Solving of wanted constraints with respect to a given set}
-%*									*
-%************************************************************************
-
-The set of given equalities must have been normalised already.
-
-\begin{code}
-solveWantedEqs :: [Inst]        -- givens
-	     -> [Inst] 	        -- wanteds
-	     -> TcM [Inst]	-- irreducible wanteds
-solveWantedEqs givens wanteds 
-  = do { traceTc $ text "solveWantedEqs <-" <+> ppr wanteds <+> text "with" <+> 
-                   ppr givens
+normaliseWantedEqs :: [Inst]        -- givens
+	           -> [Inst] 	    -- wanteds
+	           -> TcM [Inst]    -- irreducible wanteds
+normaliseWantedEqs givens wanteds 
+  = do { traceTc $ text "normaliseWantedEqs <-" <+> ppr wanteds 
+                   <+> text "with" <+> ppr givens
        ; result <- liftM fst $ rewriteToFixedPoint Nothing
                      [ ("(ZONK)",    dontRerun $ zonkInsts)
                      , ("(TRIVIAL)", dontRerun $ trivialRule)
@@ -350,8 +322,9 @@ solveWantedEqs givens wanteds
                      , ("(TOP)",     topRule)
                      , ("(GIVEN)",   substGivens givens) -- incl. occurs check
                      , ("(UNIFY)",   unifyMetaRule)      -- incl. occurs check
+		     , ("(SUBST)",   substRule)          -- incl. occurs check
                      ] wanteds
-       ; traceTc (text "solveWantedEqs ->" <+> ppr result)
+       ; traceTc (text "normaliseWantedEqs ->" <+> ppr result)
        ; return result
        }
   where
@@ -986,26 +959,30 @@ unifyMetaRule insts
         uMeta _swapped _tv (IndirectTv _) _ty _cotv
           = return ([inst], False)
 
-        -- signature skolem meets non-variable type
-        -- => cannot update!
-        uMeta _swapped _tv (DoneTv (MetaTv (SigTv _) _)) ty _cotv
-          | not $ isTyVarTy ty
-          = return ([inst], False)
-
         -- type variable meets type variable
         -- => check that tv2 hasn't been updated yet and choose which to update
 	uMeta swapped tv1 (DoneTv details1) (TyVarTy tv2) cotv
+	  | tv1 == tv2
+ 	  = return ([inst], False)	-- The two types are already identical
+
+	  | otherwise
 	  = do { lookupTV2 <- lookupTcTyVar tv2
                ; case lookupTV2 of
-                   IndirectTv ty  -> uMeta swapped tv1 (DoneTv details1) ty cotv
-                   DoneTv details2 -> 
-                     uMetaVar swapped tv1 details1 tv2 details2 cotv
+                   IndirectTv ty   -> uMeta swapped tv1 (DoneTv details1) ty cotv
+                   DoneTv details2 -> uMetaVar swapped tv1 details1 tv2 details2 cotv
 	       }
 
+	------ Beyond this point we know that ty2 is not a type variable
+
+        -- signature skolem meets non-variable type
+        -- => cannot update!
+        uMeta _swapped _tv (DoneTv (MetaTv (SigTv _) _)) _non_tv_ty _cotv
+          = return ([inst], False)
+
         -- updatable meta variable meets non-variable type
         -- => occurs check, monotype check, and kinds match check, then update
-	uMeta swapped tv (DoneTv (MetaTv _ ref)) ty cotv
-	  = do { mb_ty' <- checkTauTvUpdate tv ty    -- occurs + monotype check
+	uMeta swapped tv (DoneTv (MetaTv _ ref)) non_tv_ty cotv
+	  = do { mb_ty' <- checkTauTvUpdate tv non_tv_ty    -- occurs + monotype check
                ; case mb_ty' of
                    Nothing  -> return ([inst], False)  -- tv occurs in faminst
                    Just ty' ->
@@ -1017,6 +994,7 @@ unifyMetaRule insts
 
         uMeta _ _ _ _ _ = panic "uMeta"
 
+	-- uMetaVar: unify two type variables
         -- meta variable meets skolem 
         -- => just update
         uMetaVar swapped tv1 (MetaTv _ ref) tv2 (SkolemTv _) cotv