X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FMatch.lhs;h=282ba80464af9e09ae766438ce3fc8c651cbe06b;hb=ed10f2828652819fadfd4783a612c433361169c3;hp=f65de3c3f2d4624791d728ac7eb4ccbc731983fc;hpb=9bb6b6d0fbca6c82040027fab9859c9fcbc1ef7e;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index f65de3c..282ba80 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -8,10 +8,10 @@ module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) w #include "HsVersions.h" -import CmdLineOpts ( DynFlag(..), DynFlags, dopt ) +import {-# SOURCE #-} DsExpr( dsExpr ) +import CmdLineOpts ( DynFlag(..), dopt ) import HsSyn -import TcHsSyn ( TypecheckedPat, TypecheckedMatch ) -import DsHsSyn ( outPatType ) +import TcHsSyn ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext, hsPatType ) import Check ( check, ExhaustivePat ) import CoreSyn import CoreUtils ( bindNonRec ) @@ -23,11 +23,13 @@ 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 TcType ( mkTyVarTys, Type, tcTyConAppArgs, tcEqType ) +import TysWiredIn ( consDataCon, mkTupleTy, mkListTy, + tupleCon, parrFakeCon, mkPArrTy ) import BasicTypes ( Boxity(..) ) import UniqSet -import ErrUtils ( addErrLocHdrLine, dontAddErrLoc ) +import SrcLoc ( noSrcLoc ) +import Util ( lengthExceeds, isSingleton, notNull ) import Outputable \end{code} @@ -63,7 +65,7 @@ matchExport_really dflags vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _) match vars qs where (pats,indexs) = check qs incomplete = dopt Opt_WarnIncompletePatterns dflags - && (length pats /= 0) + && (notNull pats) shadow = dopt Opt_WarnOverlappingPatterns dflags && sizeUniqSet indexs < no_eqns no_eqns = length qs @@ -86,7 +88,7 @@ The next two functions create the warning message. dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM () dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn where - warn | length qs > maximum_output + 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("...")) @@ -104,80 +106,25 @@ dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn (take maximum_output pats)) $$ dots)) - dots | length pats > maximum_output = ptext SLIT("...") - | otherwise = empty + dots | pats `lengthExceeds` 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)) + = (noSrcLoc, ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id)) pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun - = case pp_match kind pats of - (ppr_match, pref) -> - addErrLocHdrLine loc message (nest 8 (rest_of_msg_fun pref)) - where - message = ptext SLIT("Pattern match(es)") <+> msg <+> ppr_match <> char ':' - where - pp_match (FunMatch fun) pats - = let ppr_fun = ppr fun in - ( hsep [ptext SLIT("in the definition of function"), quotes ppr_fun] - , (\ x -> ppr_fun <+> x) - ) - - pp_match CaseMatch pats - = (hang (ptext SLIT("in a group of case alternatives beginning")) - 4 (ppr_pats pats) - , id - ) - - pp_match RecUpdMatch pats - = (hang (ptext SLIT("in a record-update construct")) - 4 (ppr_pats pats) - , id - ) - - pp_match PatBindMatch pats - = ( hang (ptext SLIT("in a pattern binding")) - 4 (ppr_pats pats) - , id - ) - - pp_match LambdaMatch pats - = ( hang (ptext SLIT("in a lambda abstraction")) - 4 (ppr_pats pats) - , id - ) - - pp_match DoBindMatch pats - = ( hang (ptext SLIT("in a `do' pattern binding")) - 4 (ppr_pats pats) - , id - ) - - pp_match ListCompMatch pats - = ( hang (ptext SLIT("in a `list comprension' pattern binding")) - 4 (ppr_pats pats) - , id - ) - - pp_match LetMatch pats - = ( hang (ptext SLIT("in a `let' pattern binding")) - 4 (ppr_pats pats) - , id - ) + = (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) -separator (FunMatch _) = SLIT("=") -separator (CaseMatch) = SLIT("->") -separator (LambdaMatch) = SLIT("->") -separator (PatBindMatch) = panic "When is this used?" -separator (RecUpdMatch) = 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("...")] + = sep [ppr_pats pats, matchSeparator kind, ptext SLIT("...")] ppr_incomplete_pats kind (pats,[]) = ppr_pats pats ppr_incomplete_pats kind (pats,constraints) = @@ -274,7 +221,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} @@ -292,21 +239,13 @@ And gluing the ``success expressions'' together isn't quite so pretty. \begin{code} match [] eqns_info - = complete_matches eqns_info + = returnDs (foldr1 combineMatchResults match_results) where - complete_matches [eqn] - = complete_match eqn - - 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 + match_results = [ ASSERT( null pats) mr + | EqnInfo _ _ pats mr <- eqns_info ] \end{code} + %************************************************************************ %* * %* match: non-empty rule * @@ -331,7 +270,8 @@ match vars@(v:vs) eqns_info let tidy_eqns_blks = unmix_eqns tidy_eqns_info in - match_unmixed_eqn_blks vars tidy_eqns_blks + mapDs (matchEqnBlock vars) tidy_eqns_blks `thenDs` \ match_results -> + returnDs (foldr1 combineMatchResults match_results) where unmix_eqns [] = [] unmix_eqns [eqn] = [ [eqn] ] @@ -346,22 +286,6 @@ match vars@(v:vs) eqns_info 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 - -> DsM MatchResult - - match_unmixed_eqn_blks vars [] = panic "match_unmixed_eqn_blks" - - match_unmixed_eqn_blks vars [eqn_blk] = matchUnmixedEqns vars eqn_blk - - 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@ @@ -375,7 +299,8 @@ 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} @@ -394,7 +319,7 @@ The @VarPat@ information isn't needed any more after this. Float, Double, at least) are converted to unboxed form; e.g., \tr{(NPat (HsInt i) _ _)} is converted to: \begin{verbatim} -(ConPat I# _ _ [LitPat (HsIntPrim i) _]) +(ConPat I# _ _ [LitPat (HsIntPrim i)]) \end{verbatim} \end{description} @@ -410,26 +335,47 @@ tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo -- NPat -- LitPat -- NPlusKPat + -- SigPat -- 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') -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 :: 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 + +------------------------------------------------------- +-- (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 +-- ConPat +-- LitPat +-- NPat +-- NPlusKPat +-- + +tidy1 v (ParPat pat) match_result + = tidy1 v pat match_result + + -- case v of { x -> mr[] } + -- = case v of { _ -> let x=v in mr[] } tidy1 v (VarPat var) match_result = returnDs (WildPat (idType var), match_result') where match_result' | v == var = match_result | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result + -- case v of { x@p -> mr[] } + -- = case v of { p -> let x=v in mr[] } tidy1 v (AsPat var pat) match_result = tidy1 v pat match_result' where @@ -457,49 +403,34 @@ tidy1 v (LazyPat pat) match_result -- re-express as (ConPat ...) [directly] -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) +tidy1 v (ConPatOut con ps pat_ty ex_tvs dicts) match_result + = returnDs (ConPatOut con tidy_ps pat_ty ex_tvs dicts, 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' = 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 - mk_pat (arg_ty, lbl) = case [pat | (sel_id,pat,_) <- rpats, - recordSelectorFieldLabel sel_id == lbl - ] of - (pat:pats) -> ASSERT( null pats ) - pat - [] -> WildPat arg_ty + tidy_ps = PrefixCon (tidy_con con pat_ty ex_tvs ps) -tidy1 v (ListPat ty pats) match_result +tidy1 v (ListPat pats ty) match_result = returnDs (list_ConPat, match_result) where - list_ty = mkListTy ty - list_ConPat - = foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y]) - (ConPat nilDataCon list_ty [] [] []) - pats + 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 (PArrPat pats ty) match_result + = returnDs (parrConPat, match_result) + where + arity = length pats + parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty) tidy1 v (TuplePat pats boxity) match_result = returnDs (tuple_ConPat, match_result) where arity = length pats - tuple_ConPat - = ConPat (tupleCon boxity arity) - (mkTupleTy boxity arity (map outPatType pats)) [] [] - pats + tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats + (mkTupleTy boxity arity (map hsPatType pats)) tidy1 v (DictPat dicts methods) match_result = case num_of_d_and_ms of @@ -511,17 +442,44 @@ tidy1 v (DictPat dicts methods) match_result dict_and_method_pats = map VarPat (dicts ++ methods) -- LitPats: we *might* be able to replace these w/ a simpler form -tidy1 v pat@(LitPat lit lit_ty) match_result +tidy1 v pat@(LitPat lit) match_result = 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 +tidy1 v pat@(NPatOut lit lit_ty _) match_result = returnDs (tidyNPat lit lit_ty pat, match_result) -- and everything else goes through unchanged... tidy1 v non_interesting_pat match_result = returnDs (non_interesting_pat, match_result) + + +tidy_con data_con pat_ty ex_tvs (PrefixCon ps) = ps +tidy_con data_con pat_ty ex_tvs (InfixCon p1 p2) = [p1,p2] +tidy_con data_con pat_ty ex_tvs (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 WildPat con_arg_tys' + + | otherwise + = 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 + 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 + mk_pat (arg_ty, lbl) = case [pat | (sel_id,pat) <- rpats, + recordSelectorFieldLabel sel_id == lbl + ] of + (pat:pats) -> ASSERT( null pats ) + pat + [] -> WildPat arg_ty \end{code} \noindent @@ -594,20 +552,20 @@ 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} +\subsection[matchEqnBlock]{@matchEqnBlock@: getting down to business} -The function @matchUnmixedEqns@ is where the matching stuff sets to +The function @matchEqnBlock@ 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] - -> DsM MatchResult +matchEqnBlock :: [Id] + -> [EquationInfo] + -> DsM MatchResult -matchUnmixedEqns [] _ = panic "matchUnmixedEqns: no names" +matchEqnBlock [] _ = panic "matchEqnBlock: no names" -matchUnmixedEqns all_vars@(var:vars) eqns_info +matchEqnBlock 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 @@ -625,12 +583,55 @@ matchUnmixedEqns all_vars@(var:vars) eqns_info -- (ToDo: sort this out later) matchLiterals all_vars eqns_info + | isSigPat first_pat + = ASSERT( isSingleton eqns_info ) + matchSigPat all_vars (head eqns_info) where first_pat = head column_1_pats - column_1_pats = [pat | EqnInfo _ _ (pat:_) _ <- eqns_info] + 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} +A SigPat is a type coercion and must be handled one at at time. We can't +combine them unless the type of the pattern inside is identical, and we don't +bother to check for that. For example: + + data T = T1 Int | T2 Bool + f :: (forall a. a -> a) -> T -> t + f (g::Int->Int) (T1 i) = T1 (g i) + f (g::Bool->Bool) (T2 b) = T2 (g b) + +We desugar this as follows: + + f = \ g::(forall a. a->a) t::T -> + let gi = g Int + in case t of { T1 i -> T1 (gi i) + other -> + let gb = g Bool + in case t of { T2 b -> T2 (gb b) + other -> fail }} + +Note that we do not treat the first column of patterns as a +column of variables, because the coerced variables (gi, gb) +would be of different types. So we get rather grotty code. +But I don't think this is a common case, and if it was we could +doubtless improve it. + +Meanwhile, the strategy is: + * treat each SigPat coercion (always non-identity coercions) + as a separate block + * deal with the stuff inside, and then wrap a binding round + the result to bind the new variable (gi, gb, etc) + +\begin{code} +matchSigPat :: [Id] -> EquationInfo -> DsM MatchResult +matchSigPat (var:vars) (EqnInfo n ctx (SigPatOut pat ty co_fn : pats) result) + = selectMatchVar pat `thenDs` \ new_var -> + dsExpr (HsApp co_fn (HsVar var)) `thenDs` \ rhs -> + match (new_var:vars) [EqnInfo n ctx (pat:pats) result] `thenDs` \ result' -> + returnDs (adjustMatchResult (bindNonRec new_var rhs) result') +\end{code} + %************************************************************************ %* * %* matchWrapper: a convenient way to call @match@ * @@ -676,9 +677,8 @@ 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} @@ -705,11 +705,12 @@ one pattern, and match simply only accepts one pattern. JJQC 30-Nov-1997 \begin{code} -matchWrapper kind matches error_string +matchWrapper ctxt matches = getDOptsDs `thenDs` \ dflags -> - flattenMatches kind matches `thenDs` \ (result_ty, eqns_info) -> + 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 dflags new_vars eqns_info `thenDs` \ match_result -> @@ -718,10 +719,10 @@ matchWrapper kind matches error_string extractMatchResult match_result fail_expr `thenDs` \ result_expr -> returnDs (new_vars, result_expr) where match_fun dflags - = case kind of - LambdaMatch | dopt Opt_WarnSimplePatterns dflags -> matchExport - | otherwise -> match - _ -> matchExport + = case ctxt of + LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchExport + | otherwise -> match + _ -> matchExport \end{code} %************************************************************************ @@ -736,7 +737,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 @@ -780,20 +781,19 @@ 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 _ pats _ grhss, n) + 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)