X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FMatch.lhs;h=43471d8f85a9bd3fbac81ecbe7f8e67a8cc4cc89;hb=6d36af4aff6e12afa50dae2fad3993c385f8081d;hp=5f1eaea9c8bfd7c88394c66d35b2a346fe1514d7;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 5f1eaea..43471d8 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -1,53 +1,147 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[Main_match]{The @match@ function} \begin{code} -module Match ( - match, matchWrapper, matchSimply - ) where +module Match ( match, matchWrapper, matchSimply, matchSinglePat ) where #include "HsVersions.h" -import AbsSyn -- the stuff being desugared -import PlainCore -- the output of desugaring; - -- importing this module also gets all the - -- CoreSyn utility functions -import DsMonad -- the monadery used in the desugarer - -import AbsPrel ( nilDataCon, consDataCon, mkTupleTy, mkListTy, - charTy, charDataCon, intTy, intDataCon, floatTy, - floatDataCon, doubleTy, doubleDataCon, - integerTy, intPrimTy, charPrimTy, - floatPrimTy, doublePrimTy, mkFunTy, stringTy, - addrTy, addrPrimTy, addrDataCon, - wordTy, wordPrimTy, wordDataCon -#ifdef DPH - ,mkProcessorTy -#endif {- Data Parallel Haskell -} - ) -import PrimKind ( PrimKind(..) ) -- Rather ugly import; ToDo??? - -import AbsUniType ( isPrimType ) -import DsBinds ( dsBinds ) -import DsExpr ( dsExpr ) +import CmdLineOpts ( DynFlag(..), dopt ) +import HsSyn +import TcHsSyn ( hsPatType ) +import Check ( check, ExhaustivePat ) +import CoreSyn +import CoreUtils ( bindNonRec, exprType ) +import DsMonad +import DsBinds ( dsHsNestedBinds ) import DsGRHSs ( dsGRHSs ) import DsUtils -#ifdef DPH -import Id ( eqId, getIdUniType, mkTupleCon, mkProcessorCon ) -import MatchProc ( matchProcessor) -#else -import Id ( eqId, getIdUniType, mkTupleCon, DataCon(..), Id ) -#endif {- Data Parallel Haskell -} -import Maybes ( Maybe(..) ) +import Id ( idName, idType, Id ) +import DataCon ( dataConFieldLabels, dataConInstOrigArgTys, isVanillaDataCon ) import MatchCon ( matchConFamily ) -import MatchLit ( matchLiterals ) -import Outputable -- all for one "panic"... -import Pretty -import Util +import MatchLit ( matchLiterals, matchNPlusKPats, matchNPats, tidyLitPat, tidyNPat ) +import PrelInfo ( pAT_ERROR_ID ) +import TcType ( Type, tcTyConAppArgs ) +import Type ( splitFunTysN ) +import TysWiredIn ( consDataCon, mkTupleTy, mkListTy, + tupleCon, parrFakeCon, mkPArrTy ) +import BasicTypes ( Boxity(..) ) +import ListSetOps ( runs ) +import SrcLoc ( noSrcSpan, noLoc, unLoc, Located(..) ) +import Util ( lengthExceeds, notNull ) +import Name ( Name ) +import Outputable \end{code} +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} +matchCheck :: DsMatchContext + -> [Id] -- Vars rep'ing the exprs we're matching with + -> Type -- Type of the case expression + -> [EquationInfo] -- Info about patterns, etc. (type synonym below) + -> DsM MatchResult -- Desugared result! + +matchCheck ctx vars ty qs + = getDOptsDs `thenDs` \ dflags -> + matchCheck_really dflags ctx vars ty qs + +matchCheck_really dflags ctx vars ty qs + | incomplete && shadow = + dsShadowWarn ctx eqns_shadow `thenDs` \ () -> + dsIncompleteWarn ctx pats `thenDs` \ () -> + match vars ty qs + | incomplete = + dsIncompleteWarn ctx pats `thenDs` \ () -> + match vars ty qs + | shadow = + dsShadowWarn ctx eqns_shadow `thenDs` \ () -> + match vars ty qs + | otherwise = + match vars ty qs + where (pats, eqns_shadow) = check qs + incomplete = want_incomplete && (notNull pats) + want_incomplete = case ctx of + DsMatchContext RecUpd _ _ -> + dopt Opt_WarnIncompletePatternsRecUpd dflags + _ -> + dopt Opt_WarnIncompletePatterns dflags + shadow = dopt Opt_WarnOverlappingPatterns dflags + && not (null eqns_shadow) +\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 | 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 + 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 | 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)]]) + where + (ppr_match, pref) + = case kind of + FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) + other -> (pprMatchContext kind, \ pp -> pp) + +ppr_pats pats = sep (map ppr pats) + +ppr_shadow_pats kind pats + = sep [ppr_pats pats, 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 eqn = prefixF (ppr_shadow_pats kind (eqn_pats eqn)) +\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. @@ -67,7 +161,7 @@ the $m$ equations: \item the $n$ patterns for that equation, and \item -a list of Core bindings [@(Id, PlainCoreExpr)@ pairs] to be ``stuck on +a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on the front'' of the matching code, as in: \begin{verbatim} let @@ -90,19 +184,19 @@ showed no benefit. \item A default expression---what to evaluate if the overall pattern-match fails. This expression will (almost?) always be -a measly expression @CoVar@, unless we know it will only be used once +a measly expression @Var@, unless we know it will only be used once (as we do in @glue_success_exprs@). Leaving out this third argument to @match@ (and slamming in lots of -@CoVar "fail"@s) is a positively {\em bad} idea, because it makes it +@Var "fail"@s) is a positively {\em bad} idea, because it makes it impossible to share the default expressions. (Also, it stands no chance of working in our post-upheaval world of @Locals@.) \end{enumerate} So, the full type signature: \begin{code} match :: [Id] -- Variables rep'ing the exprs we're matching with + -> Type -- Type of the case expression -> [EquationInfo] -- Info about patterns, etc. (type synonym below) - -> [EquationInfo] -- Potentially shadowing equations above this one -> DsM MatchResult -- Desugared result! \end{code} @@ -132,7 +226,7 @@ Now {\em unmix} the equations into {\em blocks} [w/ local function patterns in column~1, or they all have constructor patterns in ... (see ``the mixture rule'' in SLPJ). \item -Call @matchUnmixedEqns@ on each block of equations; it will do the +Call @matchEqnBlock@ on each block of equations; it will do the appropriate thing for each kind of column-1 pattern, usually ending up in a recursive call to @match@. \end{enumerate} @@ -149,34 +243,16 @@ 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 - = pin_eqns eqns_info `thenDs` \ match_result@(MatchResult _ _ _ cxt) -> - - -- 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 - if not (all shadow_can_fail shadows) then - dsShadowError cxt `thenDs` \ _ -> - returnDs match_result - else - returnDs match_result - +match [] ty eqns_info + = ASSERT( not (null eqns_info) ) + returnDs (foldr1 combineMatchResults match_results) where - pin_eqns [EqnInfo [] match_result] = returnDs match_result - -- Last eqn... can't have pats ... - - pin_eqns (EqnInfo [] match_result1 : more_eqns) - = pin_eqns more_eqns `thenDs` \ match_result2 -> - combineMatchResults match_result1 match_result2 - - pin_eqns other_pat = panic "match: pin_eqns" - - shadow_can_fail :: EquationInfo -> Bool - - shadow_can_fail (EqnInfo [] (MatchResult CanFail _ _ _)) = True - shadow_can_fail (EqnInfo [] (MatchResult CantFail _ _ _)) = False - shadow_can_fail other = panic "match:shadow_can_fail" + match_results = [ ASSERT( null (eqn_pats eqn) ) + adjustMatchResult (eqn_wrap eqn) (eqn_rhs eqn) + | eqn <- eqns_info ] \end{code} + %************************************************************************ %* * %* match: non-empty rule * @@ -196,46 +272,39 @@ Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@ corresponds roughly to @matchVarCon@. \begin{code} -match vars@(v:vs) eqns_info shadows - = 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 vars@(v:_) ty eqns_info + = do { tidy_eqns <- mappM (tidyEqnInfo v) eqns_info + ; let eqns_blks = runs same_family tidy_eqns + ; match_results <- mappM match_block eqns_blks + ; ASSERT( not (null match_results) ) + return (foldr1 combineMatchResults match_results) } where - unmix_eqns [] = [] - unmix_eqns [eqn] = [ [eqn] ] - unmix_eqns (eq1@(EqnInfo (p1:p1s) _) : eq2@(EqnInfo (p2:p2s) _) : eqs) - = if ( (unfailablePat p1 && unfailablePat p2) - || (isConPat p1 && isConPat p2) - || (isLitPat p1 && isLitPat p2) ) then - eq1 `tack_onto` unmixed_rest - else - [ eq1 ] : unmixed_rest - where - unmixed_rest = unmix_eqns (eq2:eqs) - - x `tack_onto` xss = ( x : head xss) : tail xss - - ----------------------------------------------------------------------- - -- loop through the blocks: - -- 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 [eqn_blk] shadows = matchUnmixedEqns vars eqn_blk shadows - - 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 + same_family eqn1 eqn2 + = samePatFamily (firstPat eqn1) (firstPat eqn2) + + match_block eqns + = case firstPat (head eqns) of + WildPat {} -> matchVariables vars ty eqns + ConPatOut {} -> matchConFamily vars ty eqns + NPlusKPatOut {} -> matchNPlusKPats vars ty eqns + NPatOut {} -> matchNPats vars ty eqns + LitPat {} -> matchLiterals vars ty eqns + +-- After tidying, there are only five kinds of patterns +samePatFamily (WildPat {}) (WildPat {}) = True +samePatFamily (ConPatOut {}) (ConPatOut {}) = True +samePatFamily (NPlusKPatOut {}) (NPlusKPatOut {}) = True +samePatFamily (NPatOut {}) (NPatOut {}) = True +samePatFamily (LitPat {}) (LitPat {}) = True +samePatFamily _ _ = False + +matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +-- Real true variables, just like in matchVar, SLPJ p 94 +-- No binding to do: they'll all be wildcards by now (done in tidy) +matchVariables (var:vars) ty eqns = match vars ty (shiftEqns eqns) +\end{code} + + \end{code} Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@ @@ -249,7 +318,10 @@ Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@. \item Removing lazy (irrefutable) patterns (you don't want to know...). \item -Converting explicit tuple- and list-pats into ordinary @ConPats@. +Converting explicit tuple-, list-, and parallel-array-pats into ordinary +@ConPats@. +\item +Convert the literal pat "" to []. \end{itemize} The result of this tidying is that the column of patterns will include @@ -261,47 +333,84 @@ The @VarPat@ information isn't needed any more after this. \item[@ConPats@:] @ListPats@, @TuplePats@, etc., are all converted into @ConPats@. -\item[@LitPats@ and @NPats@ (and @NPlusKPats@):] -@LitPats@/@NPats@/@NPlusKPats@ of ``known friendly types'' (Int, Char, +\item[@LitPats@ and @NPats@:] +@LitPats@/@NPats@ of ``known friendly types'' (Int, Char, Float, Double, at least) are converted to unboxed form; e.g., -\tr{(NPat (IntLit i) _ _)} is converted to: +\tr{(NPat (HsInt i) _ _)} is converted to: \begin{verbatim} -(ConPat I# _ _ [LitPat (IntPrimLit i) _]) +(ConPat I# _ _ [LitPat (HsIntPrim i)]) \end{verbatim} \end{description} \begin{code} tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo - -- DsM'd because of internal call to "match". + -- DsM'd because of internal call to dsHsNestedBinds + -- and mkSelectorBinds. -- "tidy1" does the interesting stuff, looking at -- one pattern and fiddling the list of bindings. -tidyEqnInfo v (EqnInfo (pat : pats) match_result) - = tidy1 v pat match_result `thenDs` \ (pat', match_result') -> - returnDs (EqnInfo (pat' : pats) match_result') - -tidy1 :: Id -- The Id being scrutinised - -> TypecheckedPat -- The pattern against which it is to be matched - -> MatchResult -- Current thing do do after matching - -> DsM (TypecheckedPat, -- Equivalent pattern - MatchResult) -- Augmented thing to do afterwards - -- The augmentation usually takes the form - -- of new bindings to be added to the front - -tidy1 v (VarPat var) match_result - = returnDs (WildPat (getIdUniType var), - mkCoLetsMatchResult extra_binds match_result) - where - extra_binds | v `eqId` var = [] - | otherwise = [CoNonRec var (CoVar v)] + -- + -- POST CONDITION: head pattern in the EqnInfo is + -- WildPat + -- ConPat + -- NPat + -- LitPat + -- NPlusKPat + -- but no other + +tidyEqnInfo v eqn@(EqnInfo { eqn_wrap = wrap, eqn_pats = pat : pats }) + = tidy1 v wrap pat `thenDs` \ (wrap', pat') -> + returnDs (eqn { eqn_wrap = wrap', eqn_pats = pat' : pats }) + +tidy1 :: Id -- The Id being scrutinised + -> DsWrapper -- Previous wrapping bindings + -> Pat Id -- The pattern against which it is to be matched + -> DsM (DsWrapper, -- Extra bindings around what to do afterwards + Pat Id) -- Equivalent pattern + +-- The extra bindings etc are all wrapped around the RHS of the match +-- so they are only available when matching is complete. But that's ok +-- becuase, for example, in the pattern x@(...), the x can only be +-- used in the RHS, not in the nested pattern, nor subsquent patterns +-- +-- However this does have an awkward consequence. The bindings in +-- a VarPatOut get wrapped around the result in right to left order, +-- rather than left to right. This only matters if one set of +-- bindings can mention things used in another, and that can happen +-- if we allow equality dictionary bindings of form d1=d2. +-- bindIInstsOfLocalFuns is now careful not to do this, but it's a wart. +-- (Without this care in bindInstsOfLocalFuns, compiling +-- Data.Generics.Schemes.hs fails in function everywhereBut.) + +------------------------------------------------------- +-- (pat', mr') = tidy1 v pat mr +-- tidies the *outer level only* of pat, giving pat' +-- It eliminates many pattern forms (as-patterns, variable patterns, +-- list patterns, etc) yielding one of: +-- WildPat +-- ConPatOut +-- LitPat +-- NPat +-- NPlusKPat + +tidy1 v wrap (ParPat pat) = tidy1 v wrap (unLoc pat) +tidy1 v wrap (SigPatOut pat _) = tidy1 v wrap (unLoc pat) +tidy1 v wrap (WildPat ty) = returnDs (wrap, WildPat ty) + + -- case v of { x -> mr[] } + -- = case v of { _ -> let x=v in mr[] } +tidy1 v wrap (VarPat var) + = returnDs (wrap . wrapBind var v, WildPat (idType var)) + +tidy1 v wrap (VarPatOut var binds) + = do { prs <- dsHsNestedBinds binds + ; return (wrap . wrapBind var v . mkDsLet (Rec prs), + WildPat (idType var)) } + + -- case v of { x@p -> mr[] } + -- = case v of { p -> let x=v in mr[] } +tidy1 v wrap (AsPat (L _ var) pat) + = tidy1 v (wrap . wrapBind var v) (unLoc pat) -tidy1 v (AsPat var pat) match_result - = tidy1 v pat (mkCoLetsMatchResult extra_binds match_result) - where - extra_binds | v `eqId` var = [] - | otherwise = [CoNonRec var (CoVar v)] - -tidy1 v (WildPat ty) match_result - = returnDs (WildPat ty, match_result) {- now, here we handle lazy patterns: tidy1 v ~p bs = (v, v1 = case v of p -> v1 : @@ -311,125 +420,100 @@ tidy1 v (WildPat ty) match_result ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing? - The case expr for v_i is just: match [v] [(p, [], \ x -> CoVar v_i)] any_expr + The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr -} -tidy1 v (LazyPat pat) match_result - = mkSelectorBinds [] pat l_to_l (CoVar v) `thenDs` \ sel_binds -> - returnDs (WildPat (getIdUniType v), - mkCoLetsMatchResult [CoNonRec b rhs | (b,rhs) <- sel_binds] match_result) - where - l_to_l = binders `zip` binders -- Boring - binders = collectTypedPatBinders pat +tidy1 v wrap (LazyPat pat) + = do { v' <- newSysLocalDs (idType v) + ; sel_prs <- mkSelectorBinds pat (Var v) + ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] + ; returnDs (wrap . wrapBind v' v . mkDsLets sel_binds, + WildPat (idType v)) } -- re-express as (ConPat ...) [directly] -tidy1 v (ConOpPat pat1 id pat2 ty) match_result - = returnDs (ConPat id ty [pat1, pat2], match_result) +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) -tidy1 v (ListPat ty pats) match_result - = returnDs (list_ConPat, match_result) +tidy1 v wrap (ListPat pats ty) + = returnDs (wrap, unLoc list_ConPat) + where + list_ty = mkListTy ty + list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty) + (mkNilPat list_ty) + pats + +-- Introduce fake parallel array constructors to be able to handle parallel +-- arrays with the existing machinery for constructor pattern +tidy1 v wrap (PArrPat pats ty) + = returnDs (wrap, unLoc parrConPat) where - list_ty = mkListTy ty - list_ConPat - = foldr (\ x -> \y -> ConPat consDataCon list_ty [x, y]) - (ConPat nilDataCon list_ty []) - pats - -tidy1 v (TuplePat pats) match_result - = returnDs (tuple_ConPat, match_result) + arity = length pats + parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty) + +tidy1 v wrap (TuplePat pats boxity) + = returnDs (wrap, unLoc tuple_ConPat) where arity = length pats - tuple_ConPat - = ConPat (mkTupleCon arity) - (mkTupleTy arity (map typeOfPat pats)) - pats - -#ifdef DPH -tidy1 v (ProcessorPat pats convs pat) match_result - = returnDs ((ProcessorPat pats convs pat), match_result) -{- -tidy1 v (ProcessorPat pats _ _ pat) match_result - = returnDs (processor_ConPat, match_result) + tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats + (mkTupleTy boxity arity (map hsPatType pats)) + +tidy1 v wrap (DictPat dicts methods) + = case num_of_d_and_ms of + 0 -> tidy1 v wrap (TuplePat [] Boxed) + 1 -> tidy1 v wrap (unLoc (head dict_and_method_pats)) + _ -> tidy1 v wrap (TuplePat dict_and_method_pats Boxed) where - processor_ConPat - = ConPat (mkProcessorCon (length pats)) - (mkProcessorTy (map typeOfPat pats) (typeOfPat pat)) - (pats++[pat]) --} -#endif {- Data Parallel Haskell -} + num_of_d_and_ms = length dicts + length methods + dict_and_method_pats = map nlVarPat (dicts ++ methods) --- deeply ugly mangling for some (common) NPats/LitPats +-- LitPats: we *might* be able to replace these w/ a simpler form +tidy1 v wrap pat@(LitPat lit) + = returnDs (wrap, unLoc (tidyLitPat lit (noLoc pat))) --- LitPats: the desugarer only sees these at well-known types +-- NPats: we *might* be able to replace these w/ a simpler form +tidy1 v wrap pat@(NPatOut lit lit_ty _) + = returnDs (wrap, unLoc (tidyNPat lit lit_ty (noLoc pat))) -tidy1 v pat@(LitPat lit lit_ty) match_result - | isPrimType lit_ty - = returnDs (pat, match_result) +-- and everything else goes through unchanged... - | lit_ty == charTy - = returnDs (ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy], - match_result) +tidy1 v wrap non_interesting_pat + = returnDs (wrap, non_interesting_pat) - | otherwise = pprPanic "tidy1:LitPat:" (ppr PprDebug pat) - where - mk_char (CharLit c) = CharPrimLit c --- NPats: we *might* be able to replace these w/ a simpler form +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) + | null rpats + = -- Special case for C {}, which can be used for + -- a constructor that isn't declared to have + -- fields at all + map (noLoc . WildPat) con_arg_tys' -tidy1 v pat@(NPat lit lit_ty _) match_result - = returnDs (better_pat, match_result) + | 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 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] - | otherwise = pat - - mk_int (IntLit i) = IntPrimLit i - mk_int l@(LitLitLit s _) = l - - mk_char (CharLit c)= CharPrimLit c - mk_char l@(LitLitLit s _) = l - - mk_word l@(LitLitLit s _) = l - - mk_addr l@(LitLitLit s _) = l - - mk_float (IntLit i) = FloatPrimLit (fromInteger i) -#if __GLASGOW_HASKELL__ <= 22 - mk_float (FracLit f)= FloatPrimLit (fromRational f) -- ToDo??? -#else - mk_float (FracLit f)= FloatPrimLit f -#endif - mk_float l@(LitLitLit s _) = l - - mk_double (IntLit i) = DoublePrimLit (fromInteger i) -#if __GLASGOW_HASKELL__ <= 22 - mk_double (FracLit f)= DoublePrimLit (fromRational f) -- ToDo??? -#else - mk_double (FracLit f)= DoublePrimLit f -#endif - mk_double l@(LitLitLit s _) = l - -{- OLD: and wrong! I don't think we can do anything - useful with n+k patterns, so drop through to default case - -tidy1 v pat@(NPlusKPat n k lit_ty and so on) match_result - = returnDs (NPlusKPat v k lit_ty and so on, - (if v `eqId` n then id else (mkCoLet (CoNonRec n (CoVar v)))) . match_result) --} - --- and everything else goes through unchanged... - -tidy1 v non_interesting_pat match_result - = returnDs (non_interesting_pat, match_result) + -- Boring stuff to find the arg-tys of the constructor + + inst_tys = tcTyConAppArgs pat_ty -- Newtypes must be opaque + con_arg_tys' = dataConInstOrigArgTys data_con inst_tys + 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 + mk_pat (arg_ty, lbl) = + case [ pat | (sel_id,pat) <- rpats, idName (unLoc sel_id) == lbl] of + (pat:pats) -> ASSERT( null pats ) pat + [] -> noLoc (WildPat arg_ty) \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: @@ -495,55 +579,6 @@ Presumably just a variant on the constructor case (as it is now). %************************************************************************ %* * -%* match on an unmixed block: the real business * -%* * -%************************************************************************ -\subsection[matchUnmixedEqns]{@matchUnmixedEqns@: getting down to business} - -The function @matchUnmixedEqns@ is where the matching stuff sets to -work a block of equations, to which the mixture rule has been applied. -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 all_vars@(var:vars) eqns_info shadows - | unfailablePats column_1_pats -- Could check just one; we know they've been tidied, unmixed; - -- this way is (arguably) a sanity-check - = -- Real true variables, just like in matchVar, SLPJ p 94 - match vars remaining_eqns_info remaining_shadows - -#ifdef DPH - | patsAreAllProcessor column_1_pats - = -- ToDo: maybe check just one... - matchProcessor all_vars eqns_info -#endif {- Data Parallel Haskell -} - - | patsAreAllCons column_1_pats -- ToDo: maybe check just one... - = matchConFamily all_vars eqns_info shadows - - | patsAreAllLits column_1_pats -- ToDo: maybe check just one... - = -- 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 - - where - 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 -\end{code} - -%************************************************************************ -%* * %* matchWrapper: a convenient way to call @match@ * %* * %************************************************************************ @@ -567,7 +602,7 @@ As results, @matchWrapper@ produces: A list of variables (@Locals@) that the caller must ``promise'' to bind to appropriate values; and \item -a @PlainCoreExpr@, the desugared output (main result). +a @CoreExpr@, the desugared output (main result). \end{itemize} The main actions of @matchWrapper@ include: @@ -587,126 +622,111 @@ 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 - -> DsM ([Id], PlainCoreExpr) -- Results - --- 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) - -matchWrapper kind [(GRHSMatch - (GRHSsAndBindsOut [OtherwiseGRHS expr _] binds _))] error_string - = dsBinds binds `thenDs` \ core_binds -> - dsExpr expr `thenDs` \ core_expr -> - returnDs ([], mkCoLetsAny core_binds core_expr) - ----------------------------------------------------------------------------- --- and all the rest... (general case) - -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 -> - - getSrcLocDs `thenDs` \ (src_file, src_line) -> - newSysLocalDs stringTy `thenDs` \ str_var -> -- to hold the String - let - src_loc_str = escErrorMsg ('"' : src_file) ++ "%l" ++ src_line - fail_expr = mkErrorCoApp result_ty str_var (src_loc_str++": "++error_string) - in - extractMatchResult match_result fail_expr `thenDs` \ result_expr -> - returnDs (new_vars, result_expr) +matchWrapper :: HsMatchContext Name -- For shadowing warning messages + -> MatchGroup Id -- Matches being desugared + -> DsM ([Id], CoreExpr) -- Results \end{code} -%************************************************************************ -%* * -\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern} -%* * -%************************************************************************ - -@mkSimpleMatch@ is a wrapper for @match@ which deals with the -situation where we want to match a single expression against a single -pattern. It returns an expression. - -\begin{code} -matchSimply :: PlainCoreExpr -- Scrutinee - -> TypecheckedPat -- Pattern it should match - -> UniType -- Type of result - -> PlainCoreExpr -- Return this if it matches - -> PlainCoreExpr -- Return this if it does - -> DsM PlainCoreExpr - -matchSimply (CoVar 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 (typeOfPat pat) `thenDs` \ scrut_var -> - matchSimply (CoVar scrut_var) pat result_ty result_expr msg `thenDs` \ expr -> - returnDs (CoLet (CoNonRec scrut_var scrut_expr) 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} +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. -extractMatchResult (MatchResult CantFail _ match_fn _) fail_expr - = returnDs (match_fn (error "It can't fail!")) +JJQC 30-Nov-1997 -extractMatchResult (MatchResult CanFail result_ty match_fn _) fail_expr - = mkFailurePair result_ty `thenDs` \ (fail_bind_fn, if_it_fails) -> - returnDs (CoLet (fail_bind_fn fail_expr) (match_fn if_it_fails)) +\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 + ; return (new_vars, result_expr) } + where + arg_pats = map unLoc (hsLMatchPats (head matches)) + n_pats = length arg_pats + (pat_tys, rhs_ty) = splitFunTysN n_pats match_ty + + mk_eqn_info (L _ (Match pats _ grhss)) + = do { let upats = map unLoc pats + ; match_result <- dsGRHSs ctxt upats grhss rhs_ty + ; return (EqnInfo { eqn_wrap = idWrapper, + eqn_pats = upats, + eqn_rhs = match_result}) } + + match_fun dflags ds_ctxt + = case ctxt of + LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchCheck ds_ctxt + | otherwise -> match + _ -> matchCheck ds_ctxt \end{code} %************************************************************************ %* * -%* flattenMatches : create a list of EquationInfo * +\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern} %* * %************************************************************************ -\subsection[flattenMatches]{@flattenMatches@: create @[EquationInfo]@} -This is actually local to @matchWrapper@. +@mkSimpleMatch@ is a wrapper for @match@ which deals with the +situation where we want to match a single expression against a single +pattern. It returns an expression. \begin{code} -flattenMatches - :: DsMatchKind - -> [TypecheckedMatch] - -> DsM [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) +matchSimply :: CoreExpr -- Scrutinee + -> HsMatchContext Name -- Match kind + -> LPat Id -- Pattern it should match + -> CoreExpr -- Return this if it matches + -> CoreExpr -- Return this if it doesn't + -> DsM CoreExpr + +matchSimply scrut kind pat result_expr fail_expr + = getSrcSpanDs `thenDs` \ locn -> + let + ctx = DsMatchContext kind [unLoc pat] locn + match_result = cantFailMatchResult result_expr + rhs_ty = exprType fail_expr + -- Use exprType of fail_expr, because won't refine in the case of failure! + in + matchSinglePat scrut ctx pat rhs_ty match_result `thenDs` \ match_result' -> + extractMatchResult match_result' fail_expr + + +matchSinglePat :: CoreExpr -> DsMatchContext -> LPat Id + -> Type -> MatchResult -> DsM MatchResult +matchSinglePat (Var var) ctx pat ty match_result + = getDOptsDs `thenDs` \ dflags -> + match_fn dflags [var] ty [EqnInfo { eqn_wrap = idWrapper, + eqn_pats = [unLoc pat], + eqn_rhs = match_result }] 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 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 + match_fn dflags + | dopt Opt_WarnSimplePatterns dflags = matchCheck ctx + | otherwise = match + +matchSinglePat scrut ctx pat ty match_result + = selectSimpleMatchVarL pat `thenDs` \ var -> + matchSinglePat (Var var) ctx pat ty match_result `thenDs` \ match_result' -> + returnDs (adjustMatchResult (bindNonRec var scrut) match_result') \end{code} +