FIX Trac #1935: generate superclass constraints for derived classes

[ghc-hetmet.git] / compiler / typecheck / TcPat.lhs

diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index fca172f..9c845b6 100644 (file)
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -421,7 +421,9 @@ tc_pat pstate (orig@(ViewPat expr pat _)) overall_pat_ty thing_inside
          -- (view -> f)    where view :: _ -> forall b. b
          -- we will only be able to use view at one instantation in the
          -- rest of the view
-       ; (expr_coerc, pat_ty) <- tcInfer (\ pat_ty -> tcSubExp (expr'_expected pat_ty) expr'_inferred)
+       ; (expr_coerc, pat_ty) <- tcInfer $ \ pat_ty -> 
+               tcSubExp ViewPatOrigin (expr'_expected pat_ty) expr'_inferred
+
          -- pattern must have pat_ty
        ; (pat', tvs, res) <- tc_lpat pat pat_ty pstate thing_inside
          -- this should get zonked later on, but we unBox it here
@@ -717,9 +719,10 @@ tcConArgs data_con arg_tys (PrefixCon arg_pats) pstate thing_inside
     con_arity  = dataConSourceArity data_con
     no_of_args = length arg_pats
 
-tcConArgs data_con [arg_ty1,arg_ty2] (InfixCon p1 p2) pstate thing_inside
+tcConArgs data_con arg_tys (InfixCon p1 p2) pstate thing_inside
   = do { checkTc (con_arity == 2)      -- Check correct arity
                  (arityErr "Constructor" data_con con_arity 2)
+       ; let [arg_ty1,arg_ty2] = arg_tys       -- This can't fail after the arity check
        ; ([p1',p2'], tvs, res) <- tcMultiple tcConArg [(p1,arg_ty1),(p2,arg_ty2)]
                                              pstate thing_inside
        ; return (InfixCon p1' p2', tvs, res) }