X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FdeSugar%2FMatch.lhs;h=282ba80464af9e09ae766438ce3fc8c651cbe06b;hb=95f1b72e5398f6d4b694ff7a62e73243dd9a6ee9;hp=1f9fcdadf26c6477e97a8d4f5c8546293b41a688;hpb=10fcd78ccde892feccda3f5eacd221c1de75feea;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 1f9fcda..282ba80 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -11,7 +11,7 @@ module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) w import {-# SOURCE #-} DsExpr( dsExpr ) import CmdLineOpts ( DynFlag(..), dopt ) import HsSyn -import TcHsSyn ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext, outPatType ) +import TcHsSyn ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext, hsPatType ) import Check ( check, ExhaustivePat ) import CoreSyn import CoreUtils ( bindNonRec ) @@ -24,12 +24,12 @@ import MatchCon ( matchConFamily ) import MatchLit ( matchLiterals ) import PrelInfo ( pAT_ERROR_ID ) import TcType ( mkTyVarTys, Type, tcTyConAppArgs, tcEqType ) -import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy, +import TysWiredIn ( consDataCon, mkTupleTy, mkListTy, tupleCon, parrFakeCon, mkPArrTy ) import BasicTypes ( Boxity(..) ) import UniqSet -import ErrUtils ( addWarnLocHdrLine, dontAddErrLoc ) -import Util ( lengthExceeds ) +import SrcLoc ( noSrcLoc ) +import Util ( lengthExceeds, isSingleton, notNull ) import Outputable \end{code} @@ -65,7 +65,7 @@ matchExport_really dflags vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _) match vars qs where (pats,indexs) = check qs incomplete = dopt Opt_WarnIncompletePatterns dflags - && (not (null pats)) + && (notNull pats) shadow = dopt Opt_WarnOverlappingPatterns dflags && sizeUniqSet indexs < no_eqns no_eqns = length qs @@ -110,22 +110,21 @@ dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn | 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 - = addWarnLocHdrLine loc - (ptext SLIT("Pattern match(es)") <+> msg) - (sep [ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]) + = (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 <+> ppr_pats pats, \ pp -> pp) + 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, ptext (matchSeparator 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) = @@ -222,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} @@ -271,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] ] @@ -286,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@ @@ -335,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} @@ -351,42 +335,53 @@ 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 match_result' | v == var = match_result | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result -tidy1 v (SigPat pat ty fn) match_result - = selectMatchVar pat `thenDs` \ v' -> - tidy1 v' pat match_result `thenDs` \ (WildPat _, match_result') -> - -- The ice is a little thin here - -- We only expect a SigPat (with a non-trivial coercion) wrapping - -- a variable pattern. If it was a constructor or literal pattern - -- there would be no interesting polymorphism, and hence no coercion. - dsExpr (HsApp fn (HsVar v)) `thenDs` \ e -> - returnDs (WildPat ty, adjustMatchResult (bindNonRec v' e) match_result') - tidy1 v (WildPat ty) match_result = returnDs (WildPat ty, match_result) @@ -408,58 +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 + tidy_ps = PrefixCon (tidy_con con pat_ty ex_tvs ps) - -- 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 - -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 ty pats) match_result +tidy1 v (PArrPat pats ty) match_result = returnDs (parrConPat, match_result) where arity = length pats - parrConPat = ConPat (parrFakeCon arity) (mkPArrTy ty) [] [] 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 @@ -471,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 @@ -554,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 @@ -585,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] 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@ *