X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FMatch.lhs;h=474f7bf63faf692a100c46c9b10e057be7790405;hb=296058a1cafa80dec0b3f998348bce7c65f668b0;hp=100a2b564310f0ce5c84b790feea1658126d607c;hpb=4da93ad236882128b7b446e83a2c159ef17d7ffa;p=ghc-hetmet.git

diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index 100a2b5..474f7bf 100644
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -519,6 +519,21 @@ tidy1 _ (LitPat lit)
 tidy1 _ (NPat lit mb_neg eq)
   = return (idDsWrapper, tidyNPat lit mb_neg eq)
 
+-- BangPatterns: Pattern matching is already strict in constructors,
+-- tuples etc, so the last case strips off the bang for thoses patterns.
+tidy1 v (BangPat (L _ (LazyPat p)))       = tidy1 v (BangPat p)
+tidy1 v (BangPat (L _ (ParPat p)))        = tidy1 v (BangPat p)
+tidy1 _ p@(BangPat (L _(VarPat _)))       = return (idDsWrapper, p)
+tidy1 _ p@(BangPat (L _(VarPatOut _ _)))  = return (idDsWrapper, p)
+tidy1 _ p@(BangPat (L _ (WildPat _)))     = return (idDsWrapper, p)
+tidy1 _ p@(BangPat (L _ (CoPat _ _ _)))   = return (idDsWrapper, p)
+tidy1 _ p@(BangPat (L _ (SigPatIn _ _)))  = return (idDsWrapper, p)
+tidy1 _ p@(BangPat (L _ (SigPatOut _ _))) = return (idDsWrapper, p)
+tidy1 v (BangPat (L _ (AsPat (L _ var) pat)))
+  = do	{ (wrap, pat') <- tidy1 v (BangPat pat)
+        ; return (wrapBind var v . wrap, pat') }
+tidy1 v (BangPat (L _ p))                   = tidy1 v p
+
 -- Everything else goes through unchanged...
 
 tidy1 _ non_interesting_pat
@@ -687,11 +702,11 @@ matchEquations ctxt vars eqns_info rhs_ty
   = do	{ dflags <- getDOptsDs
 	; locn   <- getSrcSpanDs
 	; let   ds_ctxt      = DsMatchContext ctxt locn
-		error_string = matchContextErrString ctxt
+		error_doc = matchContextErrString ctxt
 
 	; match_result <- match_fun dflags ds_ctxt vars rhs_ty eqns_info
 
-	; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string
+	; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc
 	; extractMatchResult match_result fail_expr }
   where 
     match_fun dflags ds_ctxt