X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FMatch.lhs;h=d72d6adf173a55e47c5e9db12720bbfac13a96da;hb=3c245de9199f522f75ace92219256badbd928bd6;hp=c0ad86d312d32668308e54f16ed15b5caf6e2d5e;hpb=36436bc62a98f53e126ec02fe946337c4c766c3f;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index c0ad86d..d72d6ad 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -4,13 +4,13 @@ \section[Main_match]{The @match@ function} \begin{code} -module Match ( match, matchWrapper, matchSimply, matchSinglePat ) where +module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where #include "HsVersions.h" import DynFlags ( DynFlag(..), dopt ) import HsSyn -import TcHsSyn ( hsPatType ) +import TcHsSyn ( mkVanillaTuplePat ) import Check ( check, ExhaustivePat ) import CoreSyn import CoreUtils ( bindNonRec, exprType ) @@ -25,7 +25,7 @@ import MatchLit ( matchLiterals, matchNPlusKPats, matchNPats, tidyLitPat, tidyN import PrelInfo ( pAT_ERROR_ID ) import TcType ( Type, tcTyConAppArgs ) import Type ( splitFunTysN, mkTyVarTys ) -import TysWiredIn ( consDataCon, mkTupleTy, mkListTy, +import TysWiredIn ( consDataCon, mkListTy, unitTy, tupleCon, parrFakeCon, mkPArrTy ) import BasicTypes ( Boxity(..) ) import ListSetOps ( runs ) @@ -69,7 +69,7 @@ matchCheck_really dflags ctx vars ty qs where (pats, eqns_shadow) = check qs incomplete = want_incomplete && (notNull pats) want_incomplete = case ctx of - DsMatchContext RecUpd _ _ -> + DsMatchContext RecUpd _ -> dopt Opt_WarnIncompletePatternsRecUpd dflags _ -> dopt Opt_WarnIncompletePatterns dflags @@ -90,7 +90,7 @@ The next two functions create the warning message. \begin{code} dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM () -dsShadowWarn ctx@(DsMatchContext kind _ loc) qs +dsShadowWarn ctx@(DsMatchContext kind loc) qs = putSrcSpanDs loc (dsWarn warn) where warn | qs `lengthExceeds` maximum_output @@ -103,7 +103,7 @@ dsShadowWarn ctx@(DsMatchContext kind _ loc) qs dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM () -dsIncompleteWarn ctx@(DsMatchContext kind _ loc) pats +dsIncompleteWarn ctx@(DsMatchContext kind loc) pats = putSrcSpanDs loc (dsWarn warn) where warn = pp_context ctx (ptext SLIT("are non-exhaustive")) @@ -115,7 +115,7 @@ dsIncompleteWarn ctx@(DsMatchContext kind _ loc) pats dots | pats `lengthExceeds` maximum_output = ptext SLIT("...") | otherwise = empty -pp_context (DsMatchContext kind pats _loc) msg rest_of_msg_fun +pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun = vcat [ptext SLIT("Pattern match(es)") <+> msg, sep [ptext SLIT("In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]] where @@ -410,6 +410,8 @@ tidy1 v wrap (VarPatOut var binds) tidy1 v wrap (AsPat (L _ var) pat) = tidy1 v (wrap . wrapBind var v) (unLoc pat) +tidy1 v wrap (BangPat pat) + = tidy1 v (wrap . seqVar v) (unLoc pat) {- now, here we handle lazy patterns: tidy1 v ~p bs = (v, v1 = case v of p -> v1 : @@ -452,18 +454,17 @@ tidy1 v wrap (PArrPat pats ty) arity = length pats parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty) -tidy1 v wrap (TuplePat pats boxity) +tidy1 v wrap (TuplePat pats boxity ty) = returnDs (wrap, unLoc tuple_ConPat) where arity = length pats - tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats - (mkTupleTy boxity arity (map hsPatType pats)) + tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty tidy1 v wrap (DictPat dicts methods) = case num_of_d_and_ms of - 0 -> tidy1 v wrap (TuplePat [] Boxed) + 0 -> tidy1 v wrap (TuplePat [] Boxed unitTy) 1 -> tidy1 v wrap (unLoc (head dict_and_method_pats)) - _ -> tidy1 v wrap (TuplePat dict_and_method_pats Boxed) + _ -> tidy1 v wrap (mkVanillaTuplePat dict_and_method_pats Boxed) where num_of_d_and_ms = length dicts + length methods dict_and_method_pats = map nlVarPat (dicts ++ methods) @@ -649,19 +650,11 @@ JJQC 30-Nov-1997 \begin{code} matchWrapper ctxt (MatchGroup matches match_ty) - = do { eqns_info <- mapM mk_eqn_info matches - ; dflags <- getDOptsDs - ; locn <- getSrcSpanDs - ; let ds_ctxt = DsMatchContext ctxt arg_pats locn - error_string = matchContextErrString ctxt - - ; new_vars <- selectMatchVars arg_pats pat_tys - ; match_result <- match_fun dflags ds_ctxt new_vars rhs_ty eqns_info - - ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string - ; result_expr <- extractMatchResult match_result fail_expr + = do { eqns_info <- mapM mk_eqn_info matches + ; new_vars <- selectMatchVars arg_pats pat_tys + ; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty ; return (new_vars, result_expr) } - where + where arg_pats = map unLoc (hsLMatchPats (head matches)) n_pats = length arg_pats (pat_tys, rhs_ty) = splitFunTysN n_pats match_ty @@ -671,8 +664,23 @@ matchWrapper ctxt (MatchGroup matches match_ty) ; match_result <- dsGRHSs ctxt upats grhss rhs_ty ; return (EqnInfo { eqn_wrap = idWrapper, eqn_pats = upats, - eqn_rhs = match_result}) } + eqn_rhs = match_result}) } + +matchEquations :: HsMatchContext Name + -> [Id] -> [EquationInfo] -> Type + -> DsM CoreExpr +matchEquations ctxt vars eqns_info rhs_ty + = do { dflags <- getDOptsDs + ; locn <- getSrcSpanDs + ; let ds_ctxt = DsMatchContext ctxt locn + error_string = matchContextErrString ctxt + + ; match_result <- match_fun dflags ds_ctxt vars rhs_ty eqns_info + + ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string + ; extractMatchResult match_result fail_expr } + where match_fun dflags ds_ctxt = case ctxt of LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchCheck ds_ctxt @@ -718,7 +726,7 @@ matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result | dopt Opt_WarnSimplePatterns dflags = matchCheck ds_ctx | otherwise = match where - ds_ctx = DsMatchContext hs_ctx [pat] locn + ds_ctx = DsMatchContext hs_ctx locn in match_fn dflags [var] ty [EqnInfo { eqn_wrap = idWrapper, eqn_pats = [pat],