X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FdeSugar%2FMatch.lhs;h=a537ee8164595207456be32bdf0f122738a33992;hb=1c62b517711ac232a8024d91fd4b317a6804d28e;hp=a0cdb445a4e00b41d310972042cb2587f9b7623c;hpb=44f98be5b3bc7aaf2c5961667b16ee8eca3e67c1;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index a0cdb44..a537ee8 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -1,63 +1,142 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[Main_match]{The @match@ function} \begin{code} -#include "HsVersions.h" - -module Match ( match, matchWrapper, matchSimply ) where +module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) where -IMP_Ubiq() -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(DsLoop) -- here for paranoia-checking reasons - -- and to break dsExpr/dsBinds-ish loop -#else -import {-# SOURCE #-} DsExpr ( dsExpr ) -import {-# SOURCE #-} DsBinds ( dsBinds ) -#endif +#include "HsVersions.h" -import CmdLineOpts ( opt_WarnIncompletePatterns, opt_WarnOverlappedPatterns ) +import CmdLineOpts ( DynFlag(..), dopt ) import HsSyn -import TcHsSyn ( SYN_IE(TypecheckedPat), SYN_IE(TypecheckedMatch), - SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) ) -import DsHsSyn ( outPatType, collectTypedPatBinders ) +import TcHsSyn ( TypecheckedPat, TypecheckedMatch ) +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, dataConInstOrigArgTys ) import MatchCon ( matchConFamily ) import MatchLit ( matchLiterals ) +import PrelInfo ( pAT_ERROR_ID ) +import Type ( splitAlgTyConApp, mkTyVarTys, Type ) +import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy, tupleCon ) +import BasicTypes ( Boxity(..) ) +import UniqSet +import ErrUtils ( addWarnLocHdrLine, dontAddErrLoc ) +import Outputable +\end{code} -import FieldLabel ( FieldLabel {- Eq instance -} ) -import Id ( idType, dataConFieldLabels, - dataConArgTys, recordSelectorFieldLabel, - GenId{-instance-}, SYN_IE(Id) - ) -import Name ( Name {--O only-} ) -import Outputable ( PprStyle(..), Outputable(..) ) -import PprType ( GenType{-instance-}, GenTyVar{-ditto-} ) -import Pretty ( Doc ) -import PrelVals ( pAT_ERROR_ID ) -import Type ( isPrimType, eqTy, getAppDataTyConExpandingDicts, - instantiateTauTy, SYN_IE(Type) - ) -import TyVar ( GenTyVar{-instance Eq-}, SYN_IE(TyVar) ) -import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy, - addrPrimTy, wordPrimTy - ) -import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy, - charTy, charDataCon, intTy, intDataCon, - floatTy, floatDataCon, doubleTy, tupleCon, - doubleDataCon, stringTy, addrTy, - addrDataCon, wordTy, wordDataCon - ) -import Unique ( Unique{-instance Eq-} ) -import Util ( panic, pprPanic, assertPanic ) +This function is a wrapper of @match@, it must be called from all the parts where +it was called match, but only substitutes the firs call, .... +if the associated flags are declared, warnings will be issued. +It can not be called matchWrapper because this name already exists :-( + +JJCQ 30-Nov-1997 + +\begin{code} +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 + = 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` \ () -> + match vars qs + | incomplete = + dsIncompleteWarn ctx pats `thenDs` \ () -> + match vars qs + | shadow = + dsShadowWarn ctx eqns_shadow `thenDs` \ () -> + match vars qs + | otherwise = + match vars qs + where (pats,indexs) = check qs + 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 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?) + +\begin{code} +maximum_output = 4 +\end{code} + +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 + = 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 + where + 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 message (nest 8 (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) + + message = ptext SLIT("Pattern match(es)") <+> msg <+> ppr_match <> char ':' + +ppr_pats pats = sep (map ppr pats) + +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) = + sep [ppr_pats pats, ptext SLIT("with"), + sep (map ppr_constraint constraints)] + + +ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`notElem`"), ppr pats] + +ppr_eqn prefixF kind (EqnInfo _ _ pats _) = prefixF (ppr_shadow_pats kind pats) +\end{code} + + The function @match@ is basically the same as in the Wadler chapter, except it is monadised, to carry around the name supply, info about annotations, etc. @@ -112,7 +191,6 @@ So, the full type signature: \begin{code} match :: [Id] -- Variables rep'ing the exprs we're matching with -> [EquationInfo] -- Info about patterns, etc. (type synonym below) - -> [EquationInfo] -- Potentially shadowing equations above this one -> DsM MatchResult -- Desugared result! \end{code} @@ -159,29 +237,20 @@ than the Wadler-chapter code for @match@ (p.~93, first @match@ clause). And gluing the ``success expressions'' together isn't quite so pretty. \begin{code} -match [] eqns_info shadows - = complete_matches eqns_info (any eqn_cant_fail shadows) +match [] eqns_info + = complete_matches eqns_info where - complete_matches [eqn] is_shadowed - = complete_match eqn is_shadowed + complete_matches [eqn] + = complete_match eqn - complete_matches (eqn:eqns) is_shadowed - = complete_match eqn is_shadowed `thenDs` \ match_result1 -> - complete_matches eqns (is_shadowed || eqn_cant_fail eqn) `thenDs` \ match_result2 -> - combineMatchResults match_result1 match_result2 - - -- If at this stage we find that at least one of the shadowing - -- equations is guaranteed not to fail, then warn of an overlapping pattern - complete_match (EqnInfo [] match_result@(MatchResult _ _ _ cxt)) is_shadowed - | opt_WarnOverlappedPatterns && is_shadowed = - dsShadowWarn cxt `thenDs` \ _ -> - returnDs match_result - - | otherwise = returnDs match_result - - eqn_cant_fail :: EquationInfo -> Bool - eqn_cant_fail (EqnInfo [] (MatchResult CanFail _ _ _)) = False - eqn_cant_fail (EqnInfo [] (MatchResult CantFail _ _ _)) = True + complete_matches (eqn:eqns) + = complete_match eqn `thenDs` \ match_result1 -> + complete_matches eqns `thenDs` \ match_result2 -> + returnDs (combineMatchResults match_result1 match_result2) + + complete_match (EqnInfo _ _ pats match_result) + = ASSERT( null pats ) + returnDs match_result \end{code} %************************************************************************ @@ -203,20 +272,19 @@ Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@ corresponds roughly to @matchVarCon@. \begin{code} -match vars@(v:vs) eqns_info shadows +match vars@(v:vs) eqns_info = mapDs (tidyEqnInfo v) eqns_info `thenDs` \ tidy_eqns_info -> - mapDs (tidyEqnInfo v) shadows `thenDs` \ tidy_shadows -> let tidy_eqns_blks = unmix_eqns tidy_eqns_info in - match_unmixed_eqn_blks vars tidy_eqns_blks tidy_shadows + match_unmixed_eqn_blks vars tidy_eqns_blks where 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 + unmix_eqns (eq1@(EqnInfo _ _ (p1:p1s) _) : eq2@(EqnInfo _ _ (p2:p2s) _) : eqs) + = if ( (isWildPat p1 && isWildPat p2) + || (isConPat p1 && isConPat p2) + || (isLitPat p1 && isLitPat p2) ) then eq1 `tack_onto` unmixed_rest else [ eq1 ] : unmixed_rest @@ -230,19 +298,16 @@ match vars@(v:vs) eqns_info shadows -- subsequent blocks create a "fail expr" for the first one... match_unmixed_eqn_blks :: [Id] -> [ [EquationInfo] ] -- List of eqn BLOCKS - -> [EquationInfo] -- Shadows -> DsM MatchResult - match_unmixed_eqn_blks vars [] shadows = panic "match_unmixed_eqn_blks" + match_unmixed_eqn_blks vars [] = panic "match_unmixed_eqn_blks" - match_unmixed_eqn_blks vars [eqn_blk] shadows = matchUnmixedEqns vars eqn_blk shadows + match_unmixed_eqn_blks vars [eqn_blk] = matchUnmixedEqns vars eqn_blk - match_unmixed_eqn_blks vars (eqn_blk:eqn_blks) shadows - = matchUnmixedEqns vars eqn_blk shadows `thenDs` \ match_result1 -> -- try to match with first blk - match_unmixed_eqn_blks vars eqn_blks shadows' `thenDs` \ match_result2 -> - combineMatchResults match_result1 match_result2 - where - shadows' = eqn_blk ++ shadows + match_unmixed_eqn_blks vars (eqn_blk:eqn_blks) + = matchUnmixedEqns vars eqn_blk `thenDs` \ match_result1 -> -- try to match with first blk + match_unmixed_eqn_blks vars eqn_blks `thenDs` \ match_result2 -> + returnDs (combineMatchResults match_result1 match_result2) \end{code} Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@ @@ -284,9 +349,18 @@ 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. -tidyEqnInfo v (EqnInfo (pat : pats) match_result) + -- + -- 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 (pat' : pats) match_result') + returnDs (EqnInfo n ctx (pat' : pats) match_result') tidy1 :: Id -- The Id being scrutinised -> TypecheckedPat -- The pattern against which it is to be matched @@ -297,17 +371,16 @@ tidy1 :: Id -- The Id being scrutinised -- of new bindings to be added to the front tidy1 v (VarPat var) match_result - = returnDs (WildPat (idType var), - mkCoLetsMatchResult extra_binds match_result) + = returnDs (WildPat (idType var), match_result') where - extra_binds | v == var = [] - | otherwise = [NonRec var (Var v)] + match_result' | v == var = match_result + | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result tidy1 v (AsPat var pat) match_result - = tidy1 v pat (mkCoLetsMatchResult extra_binds match_result) + = tidy1 v pat match_result' where - extra_binds | v == var = [] - | otherwise = [NonRec var (Var v)] + match_result' | v == var = match_result + | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result tidy1 v (WildPat ty) match_result = returnDs (WildPat ty, match_result) @@ -330,18 +403,22 @@ tidy1 v (LazyPat pat) match_result -- re-express as (ConPat ...) [directly] -tidy1 v (ConOpPat pat1 id pat2 ty) match_result - = returnDs (ConPat id ty [pat1, pat2], 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) -tidy1 v (RecPat con_id pat_ty rpats) match_result - = returnDs (ConPat con_id pat_ty pats, 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, _) = getAppDataTyConExpandingDicts pat_ty - con_arg_tys' = dataConArgTys con_id inst_tys - tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels con_id) + (_, inst_tys, _) = splitAlgTyConApp 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, -- and the specified pattern for present fields @@ -357,84 +434,35 @@ tidy1 v (ListPat ty pats) match_result where list_ty = mkListTy ty list_ConPat - = foldr (\ x -> \y -> ConPat consDataCon list_ty [x, y]) - (ConPat nilDataCon list_ty []) + = foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y]) + (ConPat nilDataCon list_ty [] [] []) pats -tidy1 v (TuplePat pats) match_result +tidy1 v (TuplePat pats boxity) match_result = returnDs (tuple_ConPat, match_result) where arity = length pats tuple_ConPat - = ConPat (tupleCon arity) - (mkTupleTy 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 []) 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) 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 - | isPrimType lit_ty - = returnDs (pat, match_result) - - | lit_ty `eqTy` charTy - = returnDs (ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy], - match_result) - - | otherwise = pprPanic "tidy1:LitPat:" (ppr PprDebug 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 `eqTy` charTy = ConPat charDataCon lit_ty [LitPat (mk_char lit) charPrimTy] - | lit_ty `eqTy` intTy = ConPat intDataCon lit_ty [LitPat (mk_int lit) intPrimTy] - | lit_ty `eqTy` wordTy = ConPat wordDataCon lit_ty [LitPat (mk_word lit) wordPrimTy] - | lit_ty `eqTy` addrTy = ConPat addrDataCon lit_ty [LitPat (mk_addr lit) addrPrimTy] - | lit_ty `eqTy` floatTy = ConPat floatDataCon lit_ty [LitPat (mk_float lit) floatPrimTy] - | lit_ty `eqTy` 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... @@ -442,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: @@ -520,36 +549,32 @@ Its arguments and results are the same as for the ``top-level'' @match@. \begin{code} matchUnmixedEqns :: [Id] -> [EquationInfo] - -> [EquationInfo] -- Shadows -> DsM MatchResult -matchUnmixedEqns [] _ _ = panic "matchUnmixedEqns: no names" +matchUnmixedEqns [] _ = panic "matchUnmixedEqns: no names" -matchUnmixedEqns all_vars@(var:vars) eqns_info shadows - | irrefutablePat first_pat - = ASSERT( irrefutablePats column_1_pats ) -- Sanity check +matchUnmixedEqns all_vars@(var:vars) eqns_info + | isWildPat first_pat + = ASSERT( all isWildPat column_1_pats ) -- Sanity check -- Real true variables, just like in matchVar, SLPJ p 94 - match vars remaining_eqns_info remaining_shadows + -- No binding to do: they'll all be wildcards by now (done in tidy) + match vars remaining_eqns_info | isConPat first_pat = ASSERT( patsAreAllCons column_1_pats ) - matchConFamily all_vars eqns_info shadows + matchConFamily all_vars eqns_info | isLitPat first_pat = ASSERT( patsAreAllLits column_1_pats ) -- see notes in MatchLiteral -- not worried about the same literal more than once in a column -- (ToDo: sort this out later) - matchLiterals all_vars eqns_info shadows + matchLiterals all_vars eqns_info where first_pat = head column_1_pats - column_1_pats = [pat | EqnInfo (pat:_) _ <- eqns_info] - remaining_eqns_info = [EqnInfo pats match_result | EqnInfo (_:pats) match_result <- eqns_info] - remaining_shadows = [EqnInfo pats match_result | EqnInfo (pat:pats) match_result <- shadows, - irrefutablePat pat ] - -- Discard shadows which can be refuted, since they don't shadow - -- a variable + column_1_pats = [pat | EqnInfo _ _ (pat:_) _ <- eqns_info] + remaining_eqns_info = [EqnInfo n ctx pats match_result | EqnInfo n ctx (_:pats) match_result <- eqns_info] \end{code} %************************************************************************ @@ -597,53 +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 :: HsMatchContext -- For shadowing warning messages + -> [TypecheckedMatch] -- Matches being desugared + -> String -- Error message if the match fails -> 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 = .... - -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) + 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: +\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} -matchWrapper kind [(GRHSMatch - (GRHSsAndBindsOut [OtherwiseGRHS expr _] binds _))] error_string - = dsBinds False{-don't auto-scc-} binds `thenDs` \ core_binds -> - dsExpr expr `thenDs` \ core_expr -> - returnDs ([], mkCoLetsAny core_binds core_expr) +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. ----------------------------------------------------------------------------- --- and all the rest... (general case) +JJQC 30-Nov-1997 +\begin{code} matchWrapper kind matches error_string - = flattenMatches kind matches `thenDs` \ eqns_info@(EqnInfo arg_pats (MatchResult _ result_ty _ _) : _) -> - - selectMatchVars arg_pats `thenDs` \ new_vars -> - match new_vars eqns_info [] `thenDs` \ match_result -> + = getDOptsDs `thenDs` \ dflags -> + flattenMatches kind matches `thenDs` \ (result_ty, eqns_info) -> + let + EqnInfo _ _ arg_pats _ : _ = eqns_info + in + 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 -> - - -- Check for incomplete pattern match - (case match_result of - MatchResult CanFail result_ty match_fn cxt - | opt_WarnIncompletePatterns - -> dsIncompleteWarn cxt - other -> returnDs () - ) `thenDs` \ _ -> - extractMatchResult match_result fail_expr `thenDs` \ result_expr -> returnDs (new_vars, result_expr) + where match_fun dflags + = case kind of + LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchExport + | otherwise -> match + _ -> matchExport \end{code} %************************************************************************ @@ -657,35 +681,38 @@ situation where we want to match a single expression against a single pattern. It returns an expression. \begin{code} -matchSimply :: CoreExpr -- Scrutinee - -> TypecheckedPat -- Pattern it should match - -> Type -- Type of result - -> CoreExpr -- Return this if it matches - -> CoreExpr -- Return this if it does +matchSimply :: CoreExpr -- Scrutinee + -> HsMatchContext -- Match kind + -> TypecheckedPat -- Pattern it should match + -> CoreExpr -- Return this if it matches + -> CoreExpr -- Return this if it doesn't -> DsM CoreExpr -matchSimply (Var var) pat result_ty result_expr fail_expr - = match [var] [eqn_info] [] `thenDs` \ match_result -> - extractMatchResult match_result fail_expr - where - eqn_info = EqnInfo [pat] initial_match_result - initial_match_result = MatchResult CantFail - result_ty - (\ ignore -> result_expr) - NoMatchContext - -matchSimply scrut_expr pat result_ty result_expr msg - = newSysLocalDs (outPatType pat) `thenDs` \ scrut_var -> - matchSimply (Var scrut_var) pat result_ty result_expr msg `thenDs` \ expr -> - returnDs (Let (NonRec scrut_var scrut_expr) expr) +matchSimply scrut kind pat result_expr fail_expr + = getSrcLocDs `thenDs` \ locn -> + let + ctx = DsMatchContext kind [pat] locn + match_result = cantFailMatchResult result_expr + in + matchSinglePat scrut ctx pat match_result `thenDs` \ match_result' -> + extractMatchResult match_result' fail_expr -extractMatchResult (MatchResult CantFail _ match_fn _) fail_expr - = returnDs (match_fn (error "It can't fail!")) +matchSinglePat :: CoreExpr -> DsMatchContext -> TypecheckedPat + -> MatchResult -> DsM MatchResult -extractMatchResult (MatchResult CanFail result_ty match_fn cxt) fail_expr - = mkFailurePair result_ty `thenDs` \ (fail_bind_fn, if_it_fails) -> - returnDs (Let (fail_bind_fn fail_expr) (match_fn if_it_fails)) +matchSinglePat (Var var) ctx pat match_result + = getDOptsDs `thenDs` \ dflags -> + match_fn dflags [var] [EqnInfo 1 ctx [pat] match_result] + where + match_fn dflags + | dopt Opt_WarnSimplePatterns dflags = matchExport + | otherwise = match + +matchSinglePat scrut ctx pat match_result + = selectMatchVar pat `thenDs` \ var -> + matchSinglePat (Var var) ctx pat match_result `thenDs` \ match_result' -> + returnDs (adjustMatchResult (bindNonRec var scrut) match_result') \end{code} %************************************************************************ @@ -693,48 +720,26 @@ extractMatchResult (MatchResult CanFail result_ty match_fn cxt) fail_expr %* flattenMatches : create a list of EquationInfo * %* * %************************************************************************ + \subsection[flattenMatches]{@flattenMatches@: create @[EquationInfo]@} This is actually local to @matchWrapper@. \begin{code} -flattenMatches - :: DsMatchKind - -> [TypecheckedMatch] - -> DsM [EquationInfo] +flattenMatches :: HsMatchContext + -> [TypecheckedMatch] + -> DsM (Type, [EquationInfo]) -flattenMatches kind [] = returnDs [] - -flattenMatches kind (match : matches) - = flatten_match [] match `thenDs` \ eqn_info -> - flattenMatches kind matches `thenDs` \ eqn_infos -> - returnDs (eqn_info : eqn_infos) +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 ) + returnDs (result_ty, eqn_infos) where - flatten_match :: [TypecheckedPat] -- Reversed list of patterns encountered so far - -> TypecheckedMatch - -> DsM EquationInfo - - flatten_match pats_so_far (PatMatch pat match) - = flatten_match (pat:pats_so_far) match - - flatten_match pats_so_far (GRHSMatch (GRHSsAndBindsOut grhss binds ty)) - = dsBinds False{-don't auto-scc-} binds `thenDs` \ core_binds -> - dsGRHSs ty kind pats grhss `thenDs` \ match_result -> - returnDs (EqnInfo pats (mkCoLetsMatchResult core_binds match_result)) - where - pats = reverse pats_so_far -- They've accumulated in reverse order - - flatten_match pats_so_far (SimpleMatch expr) - = dsExpr expr `thenDs` \ core_expr -> - getSrcLocDs `thenDs` \ locn -> - returnDs (EqnInfo pats - (MatchResult CantFail (coreExprType core_expr) - (\ ignore -> core_expr) - (DsMatchContext kind pats locn))) - - -- the matching can't fail, so we won't generate an error message. - where - pats = reverse pats_so_far -- They've accumulated in reverse order - + 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 match_result) \end{code} -