X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcPat.lhs;h=e8f108da88fa25e830d422deddf2a1d52b4e20e1;hb=80ef1f06253f1a20a63816c295e180e47cd9a347;hp=c2f758de68ff68e1f8eed533a99cba6c96a77bc3;hpb=a003ad80d59f8da861d874f7314b68c20e1afd67;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index c2f758d..e8f108d 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -130,7 +130,7 @@ tc_lam_pats ctxt pat_ty_prs (reft, res_ty) thing_inside
 	; let tys = map snd pat_ty_prs
 	; tcCheckExistentialPat pats' ex_tvs tys res_ty
 
-	; returnM (pats', res) }
+	; return (pats', res) }
 
 
 -----------------
@@ -386,6 +386,9 @@ tc_pat pstate lpat@(LazyPat pat) pat_ty thing_inside
 
 	; return (LazyPat pat', [], res) }
 
+tc_pat _ p@(QuasiQuotePat _) _ _
+  = pprPanic "Should never see QuasiQuotePat in type checker" (ppr p)
+
 tc_pat pstate (WildPat _) pat_ty thing_inside
   = do	{ pat_ty' <- unBoxWildCardType pat_ty	-- Make sure it's filled in with monotypes
 	; res <- thing_inside pstate
@@ -447,20 +450,25 @@ tc_pat pstate pat@(TypePat ty) pat_ty thing_inside
 -- Lists, tuples, arrays
 tc_pat pstate (ListPat pats _) pat_ty thing_inside
   = do	{ (elt_ty, coi) <- boxySplitListTy pat_ty
+        ; let scoi = mkSymCoI coi
 	; (pats', pats_tvs, res) <- tcMultiple (\p -> tc_lpat p elt_ty)
 					 	pats pstate thing_inside
- 	; return (mkCoPatCoI coi (ListPat pats' elt_ty) pat_ty, pats_tvs, res) }
+ 	; return (mkCoPatCoI scoi (ListPat pats' elt_ty) pat_ty, pats_tvs, res) 
+        }
 
 tc_pat pstate (PArrPat pats _) pat_ty thing_inside
   = do	{ (elt_ty, coi) <- boxySplitPArrTy pat_ty
+        ; let scoi = mkSymCoI coi
 	; (pats', pats_tvs, res) <- tcMultiple (\p -> tc_lpat p elt_ty)
 						pats pstate thing_inside 
-	; ifM (null pats) (zapToMonotype pat_ty)  -- c.f. ExplicitPArr in TcExpr
-	; return (mkCoPatCoI coi (PArrPat pats' elt_ty) pat_ty, pats_tvs, res) }
+	; when (null pats) (zapToMonotype pat_ty >> return ())  -- c.f. ExplicitPArr in TcExpr
+	; return (mkCoPatCoI scoi (PArrPat pats' elt_ty) pat_ty, pats_tvs, res)
+        }
 
 tc_pat pstate (TuplePat pats boxity _) pat_ty thing_inside
   = do	{ let tc = tupleTyCon boxity (length pats)
         ; (arg_tys, coi) <- boxySplitTyConApp tc pat_ty
+        ; let scoi = mkSymCoI coi
 	; (pats', pats_tvs, res) <- tcMultiple tc_lpat_pr (pats `zip` arg_tys)
 					       pstate thing_inside
 
@@ -477,7 +485,7 @@ tc_pat pstate (TuplePat pats boxity _) pat_ty thing_inside
 	        | otherwise		    = unmangled_result
 
  	; ASSERT( length arg_tys == length pats )      -- Syntactically enforced
-	  return (mkCoPatCoI coi possibly_mangled_result pat_ty, pats_tvs, res) 
+	  return (mkCoPatCoI scoi possibly_mangled_result pat_ty, pats_tvs, res)
         }
 
 ------------------------
@@ -498,7 +506,7 @@ tc_pat pstate (LitPat simple_lit) pat_ty thing_inside
 			-- pattern coercions have to
 			-- be of kind: pat_ty ~ lit_ty
 			-- hence, sym coi
-	; returnM (mkCoPatCoI (mkSymCoI coi) (LitPat simple_lit) pat_ty, 
+	; return (mkCoPatCoI (mkSymCoI coi) (LitPat simple_lit) pat_ty, 
                    [], res) }
 
 ------------------------
@@ -514,7 +522,7 @@ tc_pat pstate pat@(NPat over_lit mb_neg eq) pat_ty thing_inside
  			    do { neg' <- tcSyntaxOp orig neg (mkFunTy pat_ty pat_ty)
 			       ; return (Just neg') }
 	; res <- thing_inside pstate
-	; returnM (NPat lit' mb_neg' eq', [], res) }
+	; return (NPat lit' mb_neg' eq', [], res) }
 
 tc_pat pstate pat@(NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside
   = do	{ bndr_id <- setSrcSpan nm_loc (tcPatBndr pstate name pat_ty)
@@ -532,7 +540,7 @@ tc_pat pstate pat@(NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside
 	; instStupidTheta orig [mkClassPred icls [pat_ty']]	
     
 	; res <- tcExtendIdEnv1 name bndr_id (thing_inside pstate)
-	; returnM (NPlusKPat (L nm_loc bndr_id) lit' ge' minus', [], res) }
+	; return (NPlusKPat (L nm_loc bndr_id) lit' ge' minus', [], res) }
 
 tc_pat _ _other_pat _ _ = panic "tc_pat" 	-- ConPatOut, SigPatOut, VarPatOut
 \end{code}
@@ -610,18 +618,27 @@ tcConPat :: PatState -> SrcSpan -> DataCon -> TyCon
 	 -> HsConPatDetails Name -> (PatState -> TcM a)
 	 -> TcM (Pat TcId, [TcTyVar], a)
 tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
-  = do	{ let (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _) = dataConFullSig data_con
+  = do	{ let (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _)
+                = dataConFullSig data_con
 	      skol_info  = PatSkol data_con
 	      origin     = SigOrigin skol_info
 	      full_theta = eq_theta ++ dict_theta
 
 	  -- Instantiate the constructor type variables [a->ty]
-	  -- This may involve doing a family-instance coercion, and building a wrapper
+	  -- This may involve doing a family-instance coercion, and building a
+	  -- wrapper 
 	; (ctxt_res_tys, coi) <- boxySplitTyConAppWithFamily tycon pat_ty
-	; let pat_ty' = mkTyConApp tycon ctxt_res_tys
-                                     -- pat_ty /= pat_ty iff coi /= IdCo
-              wrap_res_pat res_pat
-		= mkCoPatCoI coi (unwrapFamInstScrutinee tycon ctxt_res_tys res_pat) pat_ty
+        ; let sym_coi = mkSymCoI coi  -- boxy split coercion oriented wrongly
+	      pat_ty' = mkTyConApp tycon ctxt_res_tys
+                                      -- pat_ty' /= pat_ty iff coi /= IdCo
+              
+              wrap_res_pat res_pat = mkCoPatCoI sym_coi uwScrut pat_ty
+                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
@@ -637,17 +654,21 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
 	  then do { -- The common case; no class bindings etc 
                     -- (see Note [Arrows and patterns])
 		    (arg_pats', inner_tvs, res) <- tcConArgs data_con arg_tys' 
-							       arg_pats pstate thing_inside
+						    arg_pats pstate thing_inside
 		  ; let res_pat = ConPatOut { pat_con = L con_span data_con, 
-			            	      pat_tvs = [], pat_dicts = [], pat_binds = emptyLHsBinds,
-					      pat_args = arg_pats', pat_ty = pat_ty' }
+			            	      pat_tvs = [], pat_dicts = [], 
+                                              pat_binds = emptyLHsBinds,
+					      pat_args = arg_pats', 
+                                              pat_ty = pat_ty' }
 
 		    ; return (wrap_res_pat res_pat, inner_tvs, res) }
 
 	  else do   -- The general case, with existential, and local equality 
                     -- constraints
 	{ let eq_preds = [mkEqPred (mkTyVarTy tv, ty) | (tv, ty) <- eq_spec]
-	      theta'   = substTheta tenv (full_theta ++ eq_preds)
+	      theta'   = substTheta tenv (eq_preds ++ full_theta)
+                           -- order is *important* as we generate the list of
+                           -- dictionary binders from theta'
 	      ctxt     = pat_ctxt pstate
 	; checkTc (case ctxt of { ProcPat -> False; other -> True })
 		  (existentialProcPat data_con)
@@ -849,11 +870,8 @@ refineAlt con pstate ex_tvs [] pat_ty
   = return pstate	-- Common case: no equational constraints
 
 refineAlt con pstate ex_tvs co_vars pat_ty
-  = do	{ opt_gadt <- doptM Opt_GADTs	-- No type-refinement unless GADTs are on
-	; if (not opt_gadt) then return pstate
-	  else do 
-
-	{ checkTc (isRigidTy pat_ty) (nonRigidMatch con)
+  = -- See Note [Flags and equational constraints]
+    do	{ checkTc (isRigidTy pat_ty) (nonRigidMatch con)
 	-- We are matching against a GADT constructor with non-trivial
 	-- constraints, but pattern type is wobbly.  For now we fail.
 	-- We can make sense of this, however:
@@ -881,9 +899,20 @@ refineAlt con pstate ex_tvs co_vars pat_ty
 				vcat [ ppr con <+> ppr ex_tvs,
 				       ppr [(v, tyVarKind v) | v <- co_vars],
 				       ppr reft]
-	} } }
+	} }
 \end{code}
 
+Note [Flags and equational constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If there are equational constraints, we take account of them
+regardless of flag settings; -XGADTs etc applies only to the
+*definition* of a data type.
+
+An alternative would be also to reject a program that *used*
+constructors with equational constraints.  But want we should avoid at
+all costs is simply to *ignore* the constraints, since that gives
+incomprehensible errors (Trac #2004).
+
 
 %************************************************************************
 %*									*
@@ -1089,11 +1118,11 @@ lazyPatErr pat tvs
 
 nonRigidMatch con
   =  hang (ptext SLIT("GADT pattern match in non-rigid context for") <+> quotes (ppr con))
-	2 (ptext SLIT("Tell GHC HQ if you'd like this to unify the context"))
+	2 (ptext SLIT("Solution: add a type signature"))
 
 nonRigidResult res_ty
   =  hang (ptext SLIT("GADT pattern match with non-rigid result type") <+> quotes (ppr res_ty))
-	2 (ptext SLIT("Tell GHC HQ if you'd like this to unify the context"))
+	2 (ptext SLIT("Solution: add a type signature"))
 
 inaccessibleAlt msg
   = hang (ptext SLIT("Inaccessible case alternative:")) 2 msg