+\begin{code}
+checkValue tv1 ps_ty2 non_var_ty2
+-- Do the occurs check, and check that we are not
+-- unifying a type variable with a polytype
+-- Return the type to update the type variable with, or fail
+
+-- Basically we want to update tv1 := ps_ty2
+-- because ps_ty2 has type-synonym info, which improves later error messages
+--
+-- But consider
+-- type A a = ()
+--
+-- f :: (A a -> a -> ()) -> ()
+-- f = \ _ -> ()
+--
+-- x :: ()
+-- x = f (\ x p -> p x)
+--
+-- In the application (p x), we try to match "t" with "A t". If we go
+-- ahead and bind t to A t (= ps_ty2), we'll lead the type checker into
+-- an infinite loop later.
+-- But we should not reject the program, because A t = ().
+-- Rather, we should bind t to () (= non_var_ty2).
+--
+-- That's why we have this two-state occurs-check
+ = zonkTcType ps_ty2 `thenNF_Tc` \ ps_ty2' ->
+ case okToUnifyWith tv1 ps_ty2' of {
+ Nothing -> returnTc ps_ty2' ; -- Success
+ other ->
+
+ zonkTcType non_var_ty2 `thenNF_Tc` \ non_var_ty2' ->
+ case okToUnifyWith tv1 non_var_ty2' of
+ Nothing -> -- This branch rarely succeeds, except in strange cases
+ -- like that in the example above
+ returnTc non_var_ty2'
+
+ Just problem -> failWithTcM (unifyCheck problem tv1 ps_ty2')
+ }
+
+data Problem = OccurCheck | NotMonoType
+
+okToUnifyWith :: TcTyVar -> TcType -> Maybe Problem
+-- (okToUnifyWith tv ty) checks whether it's ok to unify
+-- tv :=: ty
+-- Nothing => ok
+-- Just p => not ok, problem p
+
+okToUnifyWith tv ty
+ = ok ty
+ where
+ ok (TyVarTy tv') | tv == tv' = Just OccurCheck
+ | otherwise = Nothing
+ ok (AppTy t1 t2) = ok t1 `and` ok t2
+ ok (FunTy t1 t2) = ok t1 `and` ok t2
+ ok (TyConApp _ ts) = oks ts
+ ok (ForAllTy _ _) = Just NotMonoType
+ ok (SourceTy st) = ok_st st
+ ok (NoteTy (FTVNote _) t) = ok t
+ ok (NoteTy (SynNote t1) t2) = ok t1 `and` ok t2
+ -- Type variables may be free in t1 but not t2
+ -- A forall may be in t2 but not t1
+
+ oks ts = foldr (and . ok) Nothing ts
+
+ ok_st (ClassP _ ts) = oks ts
+ ok_st (IParam _ t) = ok t
+ ok_st (NType _ ts) = oks ts
+
+ Nothing `and` m = m
+ Just p `and` m = Just p
+\end{code}