X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FMatch.lhs;h=d72d6adf173a55e47c5e9db12720bbfac13a96da;hb=3c245de9199f522f75ace92219256badbd928bd6;hp=cc87907e110d883d2236cba95c1f3b017a38db8c;hpb=d551dbfef0b710f5ede21ee0c54ee7e80dd53b64;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index cc87907..d72d6ad 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -4,18 +4,18 @@ \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 ) import DsMonad -import DsBinds ( dsHsNestedBinds ) +import DsBinds ( dsLHsBinds ) import DsGRHSs ( dsGRHSs ) import DsUtils import Id ( idName, idType, Id ) @@ -24,12 +24,12 @@ import MatchCon ( matchConFamily ) import MatchLit ( matchLiterals, matchNPlusKPats, matchNPats, tidyLitPat, tidyNPat ) import PrelInfo ( pAT_ERROR_ID ) import TcType ( Type, tcTyConAppArgs ) -import Type ( splitFunTysN ) -import TysWiredIn ( consDataCon, mkTupleTy, mkListTy, +import Type ( splitFunTysN, mkTyVarTys ) +import TysWiredIn ( consDataCon, mkListTy, unitTy, tupleCon, parrFakeCon, mkPArrTy ) import BasicTypes ( Boxity(..) ) import ListSetOps ( runs ) -import SrcLoc ( noSrcSpan, noLoc, unLoc, Located(..) ) +import SrcLoc ( noLoc, unLoc, Located(..) ) import Util ( lengthExceeds, notNull ) import Name ( Name ) import Outputable @@ -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,19 +90,21 @@ The next two functions create the warning message. \begin{code} dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM () -dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn - where - warn | qs `lengthExceeds` maximum_output - = pp_context ctx (ptext SLIT("are overlapped")) - (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$ - ptext SLIT("...")) - | otherwise - = pp_context ctx (ptext SLIT("are overlapped")) - (\ f -> vcat $ map (ppr_eqn f kind) qs) +dsShadowWarn ctx@(DsMatchContext kind loc) qs + = putSrcSpanDs loc (dsWarn warn) + where + warn | qs `lengthExceeds` maximum_output + = pp_context ctx (ptext SLIT("are overlapped")) + (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$ + ptext SLIT("...")) + | otherwise + = pp_context ctx (ptext SLIT("are overlapped")) + (\ f -> vcat $ map (ppr_eqn f kind) qs) dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM () -dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn +dsIncompleteWarn ctx@(DsMatchContext kind loc) pats + = putSrcSpanDs loc (dsWarn warn) where warn = pp_context ctx (ptext SLIT("are non-exhaustive")) (\f -> hang (ptext SLIT("Patterns not matched:")) @@ -113,12 +115,9 @@ dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn dots | pats `lengthExceeds` maximum_output = ptext SLIT("...") | otherwise = empty -pp_context NoMatchContext msg rest_of_msg_fun - = (noSrcSpan, ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id)) - -pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun - = (loc, vcat [ptext SLIT("Pattern match(es)") <+> msg, - sep [ptext SLIT("In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]) +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 (ppr_match, pref) = case kind of @@ -344,7 +343,7 @@ Float, Double, at least) are converted to unboxed form; e.g., \begin{code} tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo - -- DsM'd because of internal call to dsHsNestedBinds + -- DsM'd because of internal call to dsLHsBinds -- and mkSelectorBinds. -- "tidy1" does the interesting stuff, looking at -- one pattern and fiddling the list of bindings. @@ -402,7 +401,7 @@ tidy1 v wrap (VarPat var) = returnDs (wrap . wrapBind var v, WildPat (idType var)) tidy1 v wrap (VarPatOut var binds) - = do { prs <- dsHsNestedBinds binds + = do { prs <- dsLHsBinds binds ; return (wrap . wrapBind var v . mkDsLet (Rec prs), WildPat (idType var)) } @@ -411,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 : @@ -435,7 +436,7 @@ tidy1 v wrap (LazyPat pat) tidy1 v wrap (ConPatOut (L loc con) ex_tvs dicts binds ps pat_ty) = returnDs (wrap, ConPatOut (L loc con) ex_tvs dicts binds tidy_ps pat_ty) where - tidy_ps = PrefixCon (tidy_con con pat_ty ps) + tidy_ps = PrefixCon (tidy_con con ex_tvs pat_ty ps) tidy1 v wrap (ListPat pats ty) = returnDs (wrap, unLoc list_ConPat) @@ -453,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) @@ -483,9 +483,9 @@ tidy1 v wrap non_interesting_pat = returnDs (wrap, non_interesting_pat) -tidy_con data_con pat_ty (PrefixCon ps) = ps -tidy_con data_con pat_ty (InfixCon p1 p2) = [p1,p2] -tidy_con data_con pat_ty (RecCon rpats) +tidy_con data_con ex_tvs pat_ty (PrefixCon ps) = ps +tidy_con data_con ex_tvs pat_ty (InfixCon p1 p2) = [p1,p2] +tidy_con data_con ex_tvs pat_ty (RecCon rpats) | null rpats = -- Special case for C {}, which can be used for -- a constructor that isn't declared to have @@ -493,14 +493,13 @@ tidy_con data_con pat_ty (RecCon rpats) map (noLoc . WildPat) con_arg_tys' | otherwise - = ASSERT( isVanillaDataCon data_con ) - -- We're in a record case, so the data con must be vanilla - -- and hence no existentials to worry about - map mk_pat tagged_arg_tys + = map mk_pat tagged_arg_tys where -- Boring stuff to find the arg-tys of the constructor - inst_tys = tcTyConAppArgs pat_ty -- Newtypes must be opaque + inst_tys | isVanillaDataCon data_con = tcTyConAppArgs pat_ty -- Newtypes must be opaque + | otherwise = mkTyVarTys ex_tvs + con_arg_tys' = dataConInstOrigArgTys data_con inst_tys tagged_arg_tys = con_arg_tys' `zip` dataConFieldLabels data_con @@ -651,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 @@ -673,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 @@ -720,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],