X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FMatch.lhs;h=5aa3fdceef16a5614a279b397cdcccccce8b0477;hb=5d090a3148fd99c318b1e4b33c5f3c705e0a58c6;hp=096810e5356460c578822acfaa914e17a494e839;hpb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 096810e..5aa3fdc 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -8,39 +8,26 @@ module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) w #include "HsVersions.h" -import {-# SOURCE #-} DsExpr ( dsExpr, dsLet ) - -import CmdLineOpts ( opt_WarnIncompletePatterns, opt_WarnOverlappingPatterns, - opt_WarnSimplePatterns - ) +import CmdLineOpts ( DynFlag(..), dopt ) import HsSyn -import TcHsSyn ( TypecheckedPat, TypecheckedMatch ) +import TcHsSyn ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext ) import DsHsSyn ( outPatType ) import Check ( check, ExhaustivePat ) import CoreSyn -import CoreUtils ( coreExprType ) +import CoreUtils ( bindNonRec ) import DsMonad import DsGRHSs ( dsGRHSs ) import DsUtils import Id ( idType, recordSelectorFieldLabel, Id ) -import DataCon ( dataConFieldLabels, dataConArgTys ) +import DataCon ( dataConFieldLabels, dataConInstOrigArgTys ) import MatchCon ( matchConFamily ) import MatchLit ( matchLiterals ) -import PrelVals ( pAT_ERROR_ID ) -import Type ( isUnLiftedType, splitAlgTyConApp, - Type - ) -import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy, - addrPrimTy, wordPrimTy - ) -import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy, - charTy, charDataCon, intTy, intDataCon, - floatTy, floatDataCon, doubleTy, tupleCon, - doubleDataCon, addrTy, - addrDataCon, wordTy, wordDataCon, - mkUnboxedTupleTy, unboxedTupleCon - ) +import PrelInfo ( pAT_ERROR_ID ) +import TcType ( mkTyVarTys, Type, tcSplitTyConApp, tcEqType ) +import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy, tupleCon ) +import BasicTypes ( Boxity(..) ) import UniqSet +import ErrUtils ( addWarnLocHdrLine, dontAddErrLoc ) import Outputable \end{code} @@ -56,7 +43,12 @@ matchExport :: [Id] -- Vars rep'ing the exprs we're matching with -> [EquationInfo] -- Info about patterns, etc. (type synonym below) -> DsM MatchResult -- Desugared result! -matchExport vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _) + +matchExport vars qs + = getDOptsDs `thenDs` \ dflags -> + matchExport_really dflags vars qs + +matchExport_really dflags vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _) | incomplete && shadow = dsShadowWarn ctx eqns_shadow `thenDs` \ () -> dsIncompleteWarn ctx pats `thenDs` \ () -> @@ -70,15 +62,17 @@ matchExport vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _) | otherwise = match vars qs where (pats,indexs) = check qs - incomplete = opt_WarnIncompletePatterns && (length pats /= 0) - shadow = opt_WarnOverlappingPatterns && sizeUniqSet indexs < no_eqns + incomplete = dopt Opt_WarnIncompletePatterns dflags + && (length pats /= 0) + shadow = dopt Opt_WarnOverlappingPatterns dflags + && sizeUniqSet indexs < no_eqns no_eqns = length qs unused_eqns = uniqSetToList (mkUniqSet [1..no_eqns] `minusUniqSet` indexs) eqns_shadow = map (\n -> qs!!(n - 1)) unused_eqns \end{code} -This variable shows the maximun number of lines of output generated for warnings. -It will limit the number of patterns/equations displayed to maximum_output. +This variable shows the maximum number of lines of output generated for warnings. +It will limit the number of patterns/equations displayed to@ maximum_output@. (ToDo: add command-line option?) @@ -86,80 +80,50 @@ It will limit the number of patterns/equations displayed to maximum_output. maximum_output = 4 \end{code} -The next two functions creates the warning message. +The next two functions create the warning message. \begin{code} dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM () dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn where warn | length qs > maximum_output - = hang (pp_context ctx (ptext SLIT("are overlapped"))) - 12 ((vcat $ map (ppr_eqn kind) (take maximum_output qs)) - $$ ptext SLIT("...")) + = pp_context ctx (ptext SLIT("are overlapped")) + (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$ + ptext SLIT("...")) | otherwise - = hang (pp_context ctx (ptext SLIT("are overlapped"))) - 12 (vcat $ map (ppr_eqn kind) qs) + = 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 where - warn | length pats > maximum_output - = hang (pp_context ctx (ptext SLIT("are non-exhaustive"))) - 12 (hang (ptext SLIT("Patterns not recognized:")) - 4 ((vcat $ map (ppr_incomplete_pats kind) (take maximum_output pats)) - $$ ptext SLIT("..."))) - | otherwise - = hang (pp_context ctx (ptext SLIT("are non-exhaustive"))) - 12 (hang (ptext SLIT("Patterns not recognized:")) - 4 (vcat $ map (ppr_incomplete_pats kind) pats)) - -pp_context NoMatchContext msg = ptext SLIT("Some match(es)") <+> msg - -pp_context (DsMatchContext kind pats loc) msg - = hang (hcat [ppr loc, ptext SLIT(": ")]) - 4 (hang message - 4 (pp_match kind pats)) - where - message = ptext SLIT("Pattern match(es)") <+> msg - - pp_match (FunMatch fun) pats - = hsep [ptext SLIT("in the definition of function"), quotes (ppr fun)] - - pp_match CaseMatch pats - = hang (ptext SLIT("in a group of case alternatives beginning:")) - 4 (ppr_pats pats) - - pp_match PatBindMatch pats - = hang (ptext SLIT("in a pattern binding:")) - 4 (ppr_pats pats) - - pp_match LambdaMatch pats - = hang (ptext SLIT("in a lambda abstraction:")) - 4 (ppr_pats pats) - - pp_match DoBindMatch pats - = hang (ptext SLIT("in a `do' pattern binding:")) - 4 (ppr_pats pats) - - pp_match ListCompMatch pats - = hang (ptext SLIT("in a `list comprension' pattern binding:")) - 4 (ppr_pats pats) - - pp_match LetMatch pats - = hang (ptext SLIT("in a `let' pattern binding:")) - 4 (ppr_pats pats) + warn = pp_context ctx (ptext SLIT("are non-exhaustive")) + (\f -> hang (ptext SLIT("Patterns not matched:")) + 4 ((vcat $ map (ppr_incomplete_pats kind) + (take maximum_output pats)) + $$ dots)) + + dots | length pats > maximum_output = ptext SLIT("...") + | otherwise = empty + +pp_context NoMatchContext msg rest_of_msg_fun + = dontAddErrLoc (ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id)) + +pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun + = addWarnLocHdrLine loc + (ptext SLIT("Pattern match(es)") <+> msg) + (sep [ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]) + where + (ppr_match, pref) + = case kind of + FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) + other -> (pprMatchContext kind <+> ppr_pats pats, \ pp -> pp) ppr_pats pats = sep (map ppr pats) -separator (FunMatch _) = SLIT("=") -separator (CaseMatch) = SLIT("->") -separator (LambdaMatch) = SLIT("->") -separator (PatBindMatch) = panic "When is this used?" -separator (DoBindMatch) = SLIT("<-") -separator (ListCompMatch) = SLIT("<-") -separator (LetMatch) = SLIT("=") - -ppr_shadow_pats kind pats = sep [ppr_pats pats, ptext (separator kind), ptext SLIT("...")] +ppr_shadow_pats kind pats + = sep [ppr_pats pats, ptext (matchSeparator kind), ptext SLIT("...")] ppr_incomplete_pats kind (pats,[]) = ppr_pats pats ppr_incomplete_pats kind (pats,constraints) = @@ -167,9 +131,9 @@ ppr_incomplete_pats kind (pats,constraints) = sep (map ppr_constraint constraints)] -ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`not_elem`"), ppr pats] +ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`notElem`"), ppr pats] -ppr_eqn kind (EqnInfo _ _ pats _) = ppr_shadow_pats kind pats +ppr_eqn prefixF kind (EqnInfo _ _ pats _) = prefixF (ppr_shadow_pats kind pats) \end{code} @@ -318,9 +282,9 @@ match vars@(v:vs) eqns_info unmix_eqns [] = [] unmix_eqns [eqn] = [ [eqn] ] unmix_eqns (eq1@(EqnInfo _ _ (p1:p1s) _) : eq2@(EqnInfo _ _ (p2:p2s) _) : eqs) - = if ( (irrefutablePat p1 && irrefutablePat p2) - || (isConPat p1 && isConPat p2) - || (isLitPat p1 && isLitPat p2) ) then + = if ( (isWildPat p1 && isWildPat p2) + || (isConPat p1 && isConPat p2) + || (isLitPat p1 && isLitPat p2) ) then eq1 `tack_onto` unmixed_rest else [ eq1 ] : unmixed_rest @@ -385,6 +349,15 @@ tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo -- DsM'd because of internal call to "match". -- "tidy1" does the interesting stuff, looking at -- one pattern and fiddling the list of bindings. + -- + -- POST CONDITION: head pattern in the EqnInfo is + -- WildPat + -- ConPat + -- NPat + -- LitPat + -- NPlusKPat + -- but no other + tidyEqnInfo v (EqnInfo n ctx (pat : pats) match_result) = tidy1 v pat match_result `thenDs` \ (pat', match_result') -> returnDs (EqnInfo n ctx (pat' : pats) match_result') @@ -430,14 +403,21 @@ tidy1 v (LazyPat pat) match_result -- re-express as (ConPat ...) [directly] -tidy1 v (RecPat data_con pat_ty tvs dicts rpats) match_result - = returnDs (ConPat data_con pat_ty tvs dicts pats, match_result) +tidy1 v (RecPat data_con pat_ty ex_tvs dicts rpats) match_result + | null rpats + = -- Special case for C {}, which can be used for + -- a constructor that isn't declared to have + -- fields at all + returnDs (ConPat data_con pat_ty ex_tvs dicts (map WildPat con_arg_tys'), match_result) + + | otherwise + = returnDs (ConPat data_con pat_ty ex_tvs dicts pats, match_result) where pats = map mk_pat tagged_arg_tys -- Boring stuff to find the arg-tys of the constructor - (_, inst_tys, _) = splitAlgTyConApp pat_ty - con_arg_tys' = dataConArgTys data_con inst_tys + (_, inst_tys) = tcSplitTyConApp pat_ty + con_arg_tys' = dataConInstOrigArgTys data_con (inst_tys ++ mkTyVarTys ex_tvs) tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels data_con) -- mk_pat picks a WildPat of the appropriate type for absent fields, @@ -458,89 +438,31 @@ tidy1 v (ListPat ty pats) match_result (ConPat nilDataCon list_ty [] [] []) pats -tidy1 v (TuplePat pats True{-boxed-}) match_result - = returnDs (tuple_ConPat, match_result) - where - arity = length pats - tuple_ConPat - = ConPat (tupleCon arity) - (mkTupleTy arity (map outPatType pats)) [] [] - pats - -tidy1 v (TuplePat pats False{-unboxed-}) match_result +tidy1 v (TuplePat pats boxity) match_result = returnDs (tuple_ConPat, match_result) where arity = length pats tuple_ConPat - = ConPat (unboxedTupleCon arity) - (mkUnboxedTupleTy arity (map outPatType pats)) [] [] + = ConPat (tupleCon boxity arity) + (mkTupleTy boxity arity (map outPatType pats)) [] [] pats tidy1 v (DictPat dicts methods) match_result = case num_of_d_and_ms of - 0 -> tidy1 v (TuplePat [] True) match_result + 0 -> tidy1 v (TuplePat [] Boxed) match_result 1 -> tidy1 v (head dict_and_method_pats) match_result - _ -> tidy1 v (TuplePat dict_and_method_pats True) match_result + _ -> tidy1 v (TuplePat dict_and_method_pats Boxed) match_result where num_of_d_and_ms = length dicts + length methods dict_and_method_pats = map VarPat (dicts ++ methods) - --- deeply ugly mangling for some (common) NPats/LitPats - --- LitPats: the desugarer only sees these at well-known types - +-- LitPats: we *might* be able to replace these w/ a simpler form tidy1 v pat@(LitPat lit lit_ty) match_result - | isUnLiftedType lit_ty - = returnDs (pat, match_result) - - | lit_ty == charTy - = returnDs (ConPat charDataCon charTy [] [] [LitPat (mk_char lit) charPrimTy], - match_result) - - | otherwise = pprPanic "tidy1:LitPat:" (ppr pat) - where - mk_char (HsChar c) = HsCharPrim c + = returnDs (tidyLitPat lit pat, match_result) -- NPats: we *might* be able to replace these w/ a simpler form - - tidy1 v pat@(NPat lit lit_ty _) match_result - = returnDs (better_pat, match_result) - where - better_pat - | lit_ty == charTy = ConPat charDataCon lit_ty [] [] [LitPat (mk_char lit) charPrimTy] - | lit_ty == intTy = ConPat intDataCon lit_ty [] [] [LitPat (mk_int lit) intPrimTy] - | lit_ty == wordTy = ConPat wordDataCon lit_ty [] [] [LitPat (mk_word lit) wordPrimTy] - | lit_ty == addrTy = ConPat addrDataCon lit_ty [] [] [LitPat (mk_addr lit) addrPrimTy] - | lit_ty == floatTy = ConPat floatDataCon lit_ty [] [] [LitPat (mk_float lit) floatPrimTy] - | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy] - - -- Convert the literal pattern "" to the constructor pattern []. - | null_str_lit lit = ConPat nilDataCon lit_ty [] [] [] - - | otherwise = pat - - mk_int (HsInt i) = HsIntPrim i - mk_int l@(HsLitLit s) = l - - mk_char (HsChar c) = HsCharPrim c - mk_char l@(HsLitLit s) = l - - mk_word l@(HsLitLit s) = l - - mk_addr l@(HsLitLit s) = l - - mk_float (HsInt i) = HsFloatPrim (fromInteger i) - mk_float (HsFrac f) = HsFloatPrim f - mk_float l@(HsLitLit s) = l - - mk_double (HsInt i) = HsDoublePrim (fromInteger i) - mk_double (HsFrac f) = HsDoublePrim f - mk_double l@(HsLitLit s) = l - - null_str_lit (HsString s) = _NULL_ s - null_str_lit other_lit = False + = returnDs (tidyNPat lit lit_ty pat, match_result) -- and everything else goes through unchanged... @@ -548,7 +470,8 @@ tidy1 v non_interesting_pat match_result = returnDs (non_interesting_pat, match_result) \end{code} -PREVIOUS matchTwiddled STUFF: +\noindent +{\bf Previous @matchTwiddled@ stuff:} Now we get to the only interesting part; note: there are choices for translation [from Simon's notes]; translation~1: @@ -631,9 +554,10 @@ matchUnmixedEqns :: [Id] matchUnmixedEqns [] _ = panic "matchUnmixedEqns: no names" matchUnmixedEqns all_vars@(var:vars) eqns_info - | irrefutablePat first_pat - = ASSERT( irrefutablePats column_1_pats ) -- Sanity check + | isWildPat first_pat + = ASSERT( all isWildPat column_1_pats ) -- Sanity check -- Real true variables, just like in matchVar, SLPJ p 94 + -- No binding to do: they'll all be wildcards by now (done in tidy) match vars remaining_eqns_info | isConPat first_pat @@ -698,74 +622,52 @@ Call @match@ with all of this information! \end{enumerate} \begin{code} -matchWrapper :: DsMatchKind -- For shadowing warning messages - -> [TypecheckedMatch] -- Matches being desugared - -> String -- Error message if the match fails +matchWrapper :: TypecheckedMatchContext -- For shadowing warning messages + -> [TypecheckedMatch] -- Matches being desugared -> DsM ([Id], CoreExpr) -- Results \end{code} - a special case for the common ...: - just one Match - lots of (all?) unfailable pats - e.g., - f x y z = .... - - This special case have been ``undone'' due to problems with the new warnings - messages (Check.lhs.check). We need there the name of the variables to be able to - print later the equation. JJQC 30-11-97 - -\begin{old_code} -matchWrapper kind [(PatMatch (VarPat var) match)] error_string - = matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) -> - returnDs (var:vars, core_expr) - -matchWrapper kind [(PatMatch (WildPat ty) match)] error_string - = newSysLocalDs ty `thenDs` \ var -> - matchWrapper kind [match] error_string `thenDs` \ (vars, core_expr) -> - returnDs (var:vars, core_expr) - -matchWrapper kind [(GRHSMatch - (GRHSsAndBindsOut [GRHS [ExprStmt expr _]] binds _))] error_string - = dsExpr expr `thenDs` \ core_expr -> - dsLet binds core_expr `thenDs` \ rhs -> - returnDs ([], rhs) -\end{old_code} - - And all the rest... (general case) - - There is one small problem with the Lambda Patterns, when somebody writes something similar to: +\begin{verbatim} (\ (x:xs) -> ...) +\end{verbatim} he/she don't want a warning about incomplete patterns, that is done with - the flag opt_WarnSimplePatterns. - This problem also appears in the : - do patterns, but if the do can fail it creates another equation if the match can - fail (see DsExpr.doDo function) - let patterns, are treated by matchSimply - List Comprension Patterns, are treated by matchSimply also - -We can't call matchSimply with Lambda patterns, due to lambda patterns can have more than + the flag @opt_WarnSimplePatterns@. + This problem also appears in the: +\begin{itemize} +\item @do@ patterns, but if the @do@ can fail + it creates another equation if the match can fail + (see @DsExpr.doDo@ function) +\item @let@ patterns, are treated by @matchSimply@ + List Comprension Patterns, are treated by @matchSimply@ also +\end{itemize} + +We can't call @matchSimply@ with Lambda patterns, +due to the fact that lambda patterns can have more than one pattern, and match simply only accepts one pattern. JJQC 30-Nov-1997 - + \begin{code} -matchWrapper kind matches error_string - = flattenMatches kind matches `thenDs` \ (result_ty, eqns_info) -> +matchWrapper ctxt matches + = getDOptsDs `thenDs` \ dflags -> + flattenMatches ctxt matches `thenDs` \ (result_ty, eqns_info) -> let EqnInfo _ _ arg_pats _ : _ = eqns_info + error_string = matchContextErrString ctxt in - mapDs selectMatchVar arg_pats `thenDs` \ new_vars -> - match_fun new_vars eqns_info `thenDs` \ match_result -> + mapDs selectMatchVar arg_pats `thenDs` \ new_vars -> + match_fun dflags new_vars eqns_info `thenDs` \ match_result -> mkErrorAppDs pAT_ERROR_ID result_ty error_string `thenDs` \ fail_expr -> extractMatchResult match_result fail_expr `thenDs` \ result_expr -> returnDs (new_vars, result_expr) - where match_fun = case kind of - LambdaMatch | opt_WarnSimplePatterns -> matchExport - | otherwise -> match - _ -> matchExport + where match_fun dflags + = case ctxt of + LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchExport + | otherwise -> match + _ -> matchExport \end{code} %************************************************************************ @@ -780,7 +682,7 @@ pattern. It returns an expression. \begin{code} matchSimply :: CoreExpr -- Scrutinee - -> DsMatchKind -- Match kind + -> TypecheckedMatchContext -- Match kind -> TypecheckedPat -- Pattern it should match -> CoreExpr -- Return this if it matches -> CoreExpr -- Return this if it doesn't @@ -800,10 +702,12 @@ matchSinglePat :: CoreExpr -> DsMatchContext -> TypecheckedPat -> MatchResult -> DsM MatchResult matchSinglePat (Var var) ctx pat match_result - = match_fn [var] [EqnInfo 1 ctx [pat] match_result] + = getDOptsDs `thenDs` \ dflags -> + match_fn dflags [var] [EqnInfo 1 ctx [pat] match_result] where - match_fn | opt_WarnSimplePatterns = matchExport - | otherwise = match + match_fn dflags + | dopt Opt_WarnSimplePatterns dflags = matchExport + | otherwise = match matchSinglePat scrut ctx pat match_result = selectMatchVar pat `thenDs` \ var -> @@ -822,44 +726,20 @@ matchSinglePat scrut ctx pat match_result This is actually local to @matchWrapper@. \begin{code} -flattenMatches - :: DsMatchKind - -> [TypecheckedMatch] - -> DsM (Type, [EquationInfo]) +flattenMatches :: TypecheckedMatchContext + -> [TypecheckedMatch] + -> DsM (Type, [EquationInfo]) flattenMatches kind matches = mapAndUnzipDs flatten_match (matches `zip` [1..]) `thenDs` \ (result_tys, eqn_infos) -> let result_ty = head result_tys in - ASSERT( all (== result_ty) result_tys ) + ASSERT( all (tcEqType result_ty) result_tys ) returnDs (result_ty, eqn_infos) where - flatten_match (match, eqn_no) = flatten_match_help [] match eqn_no - - flatten_match_help :: [TypecheckedPat] -- Reversed list of patterns encountered so far - -> TypecheckedMatch - -> EqnNo - -> DsM (Type, EquationInfo) - - flatten_match_help pats_so_far (PatMatch pat match) n - = flatten_match_help (pat:pats_so_far) match n - - flatten_match_help pats_so_far (GRHSMatch (GRHSsAndBindsOut grhss binds ty)) n - = dsGRHSs kind pats grhss `thenDs` \ match_result -> + flatten_match (Match _ pats _ grhss, n) + = dsGRHSs kind pats grhss `thenDs` \ (ty, match_result) -> getSrcLocDs `thenDs` \ locn -> - returnDs (ty, EqnInfo n (DsMatchContext kind pats locn) pats - (adjustMatchResultDs (dsLet binds) match_result)) - -- NB: nested dsLet inside matchResult - where - pats = reverse pats_so_far -- They've accumulated in reverse order - - flatten_match_help pats_so_far (SimpleMatch expr) n - = dsExpr expr `thenDs` \ core_expr -> - getSrcLocDs `thenDs` \ locn -> - returnDs (coreExprType core_expr, - EqnInfo n (DsMatchContext kind pats locn) pats - (cantFailMatchResult core_expr)) - where - pats = reverse pats_so_far -- They've accumulated in reverse order + returnDs (ty, EqnInfo n (DsMatchContext kind pats locn) pats match_result) \end{code}