Proper error message for unsupported pattern signatures

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

diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index 6a30754..fd28455 100644 (file)
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -422,7 +422,10 @@ tc_pat pstate (orig@(ViewPat expr pat _)) overall_pat_ty thing_inside
 -- Type signatures in patterns
 -- See Note [Pattern coercions] below
 tc_pat pstate (SigPatIn pat sig_ty) pat_ty thing_inside
-  = do { (inner_ty, tv_binds) <- tcPatSig (patSigCtxt pstate) sig_ty pat_ty
+  = do { (inner_ty, tv_binds, coi) <- tcPatSig (patSigCtxt pstate) sig_ty 
+                                                                    pat_ty
+        ; unless (isIdentityCoercion coi) $ 
+            failWithTc (badSigPat pat_ty)
        ; (pat', tvs, res) <- tcExtendTyVarEnv2 tv_binds $
                              tc_lpat pat inner_ty pstate thing_inside
        ; return (SigPatOut pat' inner_ty, tvs, res) }
@@ -617,10 +620,6 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
                 where
                   uwScrut = unwrapFamInstScrutinee tycon ctxt_res_tys res_pat
 
-        ; traceTc $ case sym_coi of
-                      IdCo -> text "sym_coi:IdCo" 
-                      ACo co -> text "sym_coi: ACoI" <+> ppr co
-
          -- Add the stupid theta
        ; addDataConStupidTheta data_con ctxt_res_tys
 
@@ -655,7 +654,7 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
           -- ex_tvs was non-null.
 --        ; unless (null theta') $
           -- FIXME: AT THE MOMENT WE CHEAT!  We only perform the rigidity test
-          --   if we explicit or implicit (by a GADT def) have equality 
+          --   if we explicitly or implicitly (by a GADT def) have equality 
           --   constraints.
         ; let eq_preds = [mkEqPred (mkTyVarTy tv, ty) | (tv, ty) <- eq_spec]
              theta'   = substTheta tenv (eq_preds ++ full_theta)
@@ -665,8 +664,8 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
              pstate' | no_equalities = pstate
                      | otherwise     = pstate { pat_eqs = True }
 
-       ; unless no_equalities (checkTc (isRigidTy pat_ty)
-                                        (nonRigidMatch data_con))
+       ; unless no_equalities $ 
+            checkTc (isRigidTy pat_ty) (nonRigidMatch data_con)
 
        ; ((arg_pats', inner_tvs, res), lie_req) <- getLIE $
                tcConArgs data_con arg_tys' arg_pats pstate' thing_inside
@@ -719,7 +718,6 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
       | otherwise
       = pat
 
-
 tcConArgs :: DataCon -> [TcSigmaType]
          -> Checker (HsConPatDetails Name) (HsConPatDetails Id)
 
@@ -799,7 +797,9 @@ addDataConStupidTheta data_con inst_tys
        -- The origin should always report "occurrence of C"
        -- even when C occurs in a pattern
     stupid_theta = dataConStupidTheta data_con
-    tenv = zipTopTvSubst (dataConUnivTyVars data_con) inst_tys
+    tenv = mkTopTvSubst (dataConUnivTyVars data_con `zip` inst_tys)
+        -- NB: inst_tys can be longer than the univ tyvars
+        --     because the constructor might have existentials
     inst_theta = substTheta tenv stupid_theta
 \end{code}
 
@@ -995,6 +995,10 @@ polyPatSig sig_ty
   = hang (ptext (sLit "Illegal polymorphic type signature in pattern:"))
        2 (ppr sig_ty)
 
+badSigPat :: TcType -> SDoc
+badSigPat pat_ty = ptext (sLit "Pattern signature must exactly match:") <+> 
+                   ppr pat_ty
+
 badTypePat :: Pat Name -> SDoc
 badTypePat pat = ptext (sLit "Illegal type pattern") <+> ppr pat