X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcUnify.lhs;h=ecee5ac4e8a130a5ee7e842ab0a8127fe0ab4104;hp=d7282b6c2ae3ea3d588c5da7326d78099def8785;hb=bb7ffa1642e2110e26e1243c42a8a24adafa985d;hpb=08652e67c4d5d9a40687f93c286021a867c1bca0

diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index d7282b6..ecee5ac 100644
--- a/compiler/typecheck/TcUnify.lhs
+++ b/compiler/typecheck/TcUnify.lhs
@@ -996,7 +996,7 @@ unifyTheta :: TcThetaType -> TcThetaType -> TcM [CoercionI]
 unifyTheta theta1 theta2
   = do  { checkTc (equalLength theta1 theta2)
                   (vcat [ptext (sLit "Contexts differ in length"),
-                         nest 2 $ parens $ ptext (sLit "Use -fglasgow-exts to allow this")])
+                         nest 2 $ parens $ ptext (sLit "Use -XRelaxedPolyRec to allow this")])
         ; uList unifyPred theta1 theta2
         }
 
@@ -1507,7 +1507,7 @@ uMetaVar :: Outer
 -- tv1 is an un-filled-in meta type variable (maybe boxy, maybe tau)
 -- ty2 is not a type variable
 
-uMetaVar _ swapped tv1 BoxTv ref1 ps_ty2 _
+uMetaVar outer swapped tv1 BoxTv ref1 ps_ty2 ty2
   =     -- tv1 is a BoxTv.  So we must unbox ty2, to ensure
         -- that any boxes in ty2 are filled with monotypes
         --
@@ -1516,15 +1516,21 @@ uMetaVar _ swapped tv1 BoxTv ref1 ps_ty2 _
         -- it does, the unbox operation will fill it, and the debug code
         -- checks for that.
     do { final_ty <- unBox ps_ty2
-       ; when debugIsOn $ do
-           { meta_details <- readMutVar ref1
-           ; case meta_details of
-                 Indirect ty -> WARN( True, ppr tv1 <+> ppr ty )
-                                return () -- This really should *not* happen
-                 Flexi -> return ()
-           }
-        ; checkUpdateMeta swapped tv1 ref1 final_ty
-        ; return IdCo
+       ; meta_details <- readMutVar ref1
+       ; case meta_details of
+                 Indirect _ ->   -- This *can* happen due to an occurs check,
+			    -- just as it can in checkTauTvUpdate in the next
+			    -- equation of uMetaVar; see Trac #2414
+			    -- Note [Occurs check]
+			-- Go round again.  Probably there's an immediate
+			-- error, but maybe not (a type function might discard
+			-- its argument).  Next time round we'll end up in the
+			-- TauTv case of uMetaVar.
+		   uVar outer swapped tv1 False ps_ty2 ty2
+			-- Setting for nb2::InBox is irrelevant
+
+                 Flexi -> do { checkUpdateMeta swapped tv1 ref1 final_ty
+			; return IdCo }
         }
 
 uMetaVar outer swapped tv1 _ ref1 ps_ty2 _
@@ -1539,6 +1545,18 @@ uMetaVar outer swapped tv1 _ ref1 ps_ty2 _
                  }
         }
 
+{- Note [Occurs check]
+   ~~~~~~~~~~~~~~~~~~~
+An eager occurs check is made in checkTauTvUpdate, deferring tricky
+cases by calling defer_unification (see notes with
+checkTauTvUpdate). An occurs check can also (and does) happen in the
+BoxTv case, but unBox doesn't check for occurrences, and in any case
+doesn't have the type-function-related complexity that
+checkTauTvUpdate has.  So we content ourselves with spotting the potential
+occur check (by the fact that tv1 is now filled), and going round again.
+Next time round we'll get the TauTv case of uMetaVar.
+-}
+
 ----------------
 uUnfilledVars :: Outer
               -> SwapFlag
@@ -1912,7 +1930,7 @@ checkExpectedKind ty act_kind exp_kind
   | otherwise = do
     (_errs, mb_r) <- tryTc (unifyKind exp_kind act_kind)
     case mb_r of
-        Just _  -> return () ;  -- Unification succeeded
+        Just _  -> return ()  -- Unification succeeded
         Nothing -> do
 
         -- So there's definitely an error