diff options
Diffstat (limited to 'compiler/deSugar/Match.lhs')
| -rw-r--r-- | compiler/deSugar/Match.lhs | 35 |
1 files changed, 21 insertions, 14 deletions
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 0433d873d5..a14027862a 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -6,6 +6,8 @@ The @match@ function \begin{code} +{-# LANGUAGE CPP #-} + module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where #include "HsVersions.h" @@ -40,7 +42,7 @@ import Maybes import Util import Name import Outputable -import BasicTypes ( boxityNormalTupleSort ) +import BasicTypes ( boxityNormalTupleSort, isGenerated ) import FastString import Control.Monad( when ) @@ -552,9 +554,8 @@ tidy1 v (LazyPat pat) tidy1 _ (ListPat pats ty Nothing) = return (idDsWrapper, unLoc list_ConPat) where - list_ty = mkListTy ty - list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty) - (mkNilPat list_ty) + list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty]) + (mkNilPat ty) pats -- Introduce fake parallel array constructors to be able to handle parallel @@ -563,13 +564,13 @@ tidy1 _ (PArrPat pats ty) = return (idDsWrapper, unLoc parrConPat) where arity = length pats - parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty) + parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty] -tidy1 _ (TuplePat pats boxity ty) +tidy1 _ (TuplePat pats boxity tys) = return (idDsWrapper, unLoc tuple_ConPat) where arity = length pats - tuple_ConPat = mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) pats ty + tuple_ConPat = mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) pats tys -- LitPats: we *might* be able to replace these w/ a simpler form tidy1 _ (LitPat lit) @@ -586,8 +587,6 @@ tidy1 _ non_interesting_pat -------------------- tidy_bang_pat :: Id -> SrcSpan -> Pat Id -> DsM (DsWrapper, Pat Id) --- BangPatterns: Pattern matching is already strict in constructors, --- tuples etc, so the last case strips off the bang for those patterns. -- Discard bang around strict pattern tidy_bang_pat v _ p@(ListPat {}) = tidy1 v p @@ -596,8 +595,7 @@ tidy_bang_pat v _ p@(PArrPat {}) = tidy1 v p tidy_bang_pat v _ p@(ConPatOut {}) = tidy1 v p tidy_bang_pat v _ p@(LitPat {}) = tidy1 v p --- Discard lazy/par/sig under a bang -tidy_bang_pat v _ (LazyPat (L l p)) = tidy_bang_pat v l p +-- Discard par/sig under a bang tidy_bang_pat v _ (ParPat (L l p)) = tidy_bang_pat v l p tidy_bang_pat v _ (SigPatOut (L l p) _) = tidy_bang_pat v l p @@ -607,7 +605,10 @@ tidy_bang_pat v l (AsPat v' p) = tidy1 v (AsPat v' (L l (BangPat p))) tidy_bang_pat v l (CoPat w p t) = tidy1 v (CoPat w (BangPat (L l p)) t) -- Default case, leave the bang there: --- VarPat, WildPat, ViewPat, NPat, NPlusKPat +-- VarPat, LazyPat, WildPat, ViewPat, NPat, NPlusKPat +-- For LazyPat, remember that it's semantically like a VarPat +-- i.e. !(~p) is not like ~p, or p! (Trac #8952) + tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p)) -- NB: SigPatIn, ConPatIn should not happen \end{code} @@ -752,12 +753,14 @@ JJQC 30-Nov-1997 \begin{code} matchWrapper ctxt (MG { mg_alts = matches , mg_arg_tys = arg_tys - , mg_res_ty = rhs_ty }) + , mg_res_ty = rhs_ty + , mg_origin = origin }) = do { eqns_info <- mapM mk_eqn_info matches ; new_vars <- case matches of [] -> mapM newSysLocalDs arg_tys (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m)) - ; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty + ; result_expr <- handleWarnings $ + matchEquations ctxt new_vars eqns_info rhs_ty ; return (new_vars, result_expr) } where mk_eqn_info (L _ (Match pats _ grhss)) @@ -765,6 +768,10 @@ matchWrapper ctxt (MG { mg_alts = matches ; match_result <- dsGRHSs ctxt upats grhss rhs_ty ; return (EqnInfo { eqn_pats = upats, eqn_rhs = match_result}) } + handleWarnings = if isGenerated origin + then discardWarningsDs + else id + matchEquations :: HsMatchContext Name -> [Id] -> [EquationInfo] -> Type |