\section[Main_match]{The @match@ function}
\begin{code}
-module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) where
+module Match ( match, matchWrapper, matchSimply, matchSinglePat ) where
#include "HsVersions.h"
-import {-# SOURCE #-} DsExpr( dsExpr )
import CmdLineOpts ( DynFlag(..), dopt )
import HsSyn
-import TcHsSyn ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext, hsPatType )
+import TcHsSyn ( hsPatType )
import Check ( check, ExhaustivePat )
import CoreSyn
-import CoreUtils ( bindNonRec )
+import CoreUtils ( bindNonRec, exprType )
import DsMonad
+import DsBinds ( dsHsNestedBinds )
import DsGRHSs ( dsGRHSs )
import DsUtils
-import Id ( idType, recordSelectorFieldLabel, Id )
-import DataCon ( dataConFieldLabels, dataConInstOrigArgTys )
+import Id ( idName, idType, Id )
+import DataCon ( dataConFieldLabels, dataConInstOrigArgTys, isVanillaDataCon )
import MatchCon ( matchConFamily )
-import MatchLit ( matchLiterals )
+import MatchLit ( matchLiterals, matchNPlusKPats, matchNPats, tidyLitPat, tidyNPat )
import PrelInfo ( pAT_ERROR_ID )
-import TcType ( mkTyVarTys, Type, tcTyConAppArgs, tcEqType )
+import TcType ( Type, tcTyConAppArgs )
+import Type ( splitFunTysN )
import TysWiredIn ( consDataCon, mkTupleTy, mkListTy,
tupleCon, parrFakeCon, mkPArrTy )
import BasicTypes ( Boxity(..) )
-import UniqSet
-import SrcLoc ( noSrcLoc )x
-import Util ( lengthExceeds, isSingleton, notNull )
+import ListSetOps ( runs )
+import SrcLoc ( noSrcSpan, noLoc, unLoc, Located(..) )
+import Util ( lengthExceeds, notNull )
+import Name ( Name )
import Outputable
\end{code}
JJCQ 30-Nov-1997
\begin{code}
-matchExport :: [Id] -- Vars rep'ing the exprs we're matching with
+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!
-
-matchExport vars qs
+matchCheck ctx vars ty qs
= getDOptsDs `thenDs` \ dflags ->
- matchExport_really dflags vars qs
+ matchCheck_really dflags ctx vars ty qs
-matchExport_really dflags vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _)
+matchCheck_really dflags ctx vars ty qs
| incomplete && shadow =
dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
dsIncompleteWarn ctx pats `thenDs` \ () ->
- match vars qs
+ match vars ty qs
| incomplete =
dsIncompleteWarn ctx pats `thenDs` \ () ->
- match vars qs
+ match vars ty qs
| shadow =
dsShadowWarn ctx eqns_shadow `thenDs` \ () ->
- match vars qs
+ match vars ty qs
| otherwise =
- match vars qs
- where (pats,indexs) = check qs
- incomplete = dopt Opt_WarnIncompletePatterns dflags
- && (notNull pats)
+ 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
- && 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
+ && not (null eqns_shadow)
\end{code}
This variable shows the maximum number of lines of output generated for warnings.
| otherwise = empty
pp_context NoMatchContext msg rest_of_msg_fun
- = (noSrcLoc, ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id))
+ = (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 [ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]])
+ sep [ptext SLIT("In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]])
where
(ppr_match, pref)
= case kind of
ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`notElem`"), ppr pats]
-ppr_eqn prefixF kind (EqnInfo _ _ pats _) = prefixF (ppr_shadow_pats kind pats)
+ppr_eqn prefixF kind eqn = prefixF (ppr_shadow_pats kind (eqn_pats eqn))
\end{code}
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)
-> DsM MatchResult -- Desugared result!
\end{code}
And gluing the ``success expressions'' together isn't quite so pretty.
\begin{code}
-match [] eqns_info
- = returnDs (foldr1 combineMatchResults match_results)
+match [] ty eqns_info
+ = ASSERT( not (null eqns_info) )
+ returnDs (foldr1 combineMatchResults match_results)
where
- match_results = [ ASSERT( null pats) mr
- | EqnInfo _ _ pats mr <- eqns_info ]
+ match_results = [ ASSERT( null (eqn_pats eqn) )
+ eqn_rhs eqn
+ | eqn <- eqns_info ]
\end{code}
corresponds roughly to @matchVarCon@.
\begin{code}
-match vars@(v:vs) eqns_info
- = mapDs (tidyEqnInfo v) eqns_info `thenDs` \ tidy_eqns_info ->
- let
- tidy_eqns_blks = unmix_eqns tidy_eqns_info
- in
- mapDs (matchEqnBlock vars) tidy_eqns_blks `thenDs` \ match_results ->
- returnDs (foldr1 combineMatchResults match_results)
+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 ( (isWildPat p1 && isWildPat 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
+ 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@
\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.
--
-- 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')
-
+tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_rhs = rhs })
+ = tidy1 v pat rhs `thenDs` \ (pat', rhs') ->
+ returnDs (eqn { eqn_pats = pat' : pats, eqn_rhs = rhs' })
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 Id -- The pattern against which it is to be matched
+ -> MatchResult -- What to do afterwards
+ -> DsM (Pat Id, -- Equivalent pattern
+ MatchResult) -- Extra bindings around what to do afterwards
+
+-- 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
-- It eliminates many pattern forms (as-patterns, variable patterns,
-- list patterns, etc) yielding one of:
-- WildPat
--- ConPat
+-- ConPatOut
-- LitPat
-- NPat
-- NPlusKPat
---
-tidy1 v (ParPat pat) match_result
- = tidy1 v pat match_result
+tidy1 v (ParPat pat) wrap = tidy1 v (unLoc pat) wrap
+tidy1 v (SigPatOut pat _) wrap = tidy1 v (unLoc pat) wrap
+tidy1 v (WildPat ty) wrap = returnDs (WildPat ty, wrap)
-- 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
+tidy1 v (VarPat var) rhs
+ = returnDs (WildPat (idType var), bindOneInMatchResult var v rhs)
+
+tidy1 v (VarPatOut var binds) rhs
+ = do { prs <- dsHsNestedBinds binds
+ ; return (WildPat (idType var),
+ bindOneInMatchResult var v $
+ mkCoLetMatchResult (Rec prs) rhs) }
-- 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 (AsPat (L _ var) pat) rhs
+ = tidy1 v (unLoc pat) (bindOneInMatchResult var v rhs)
-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 :
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 (Var v) `thenDs` \ sel_binds ->
- returnDs (WildPat (idType v),
- mkCoLetsMatchResult [NonRec b rhs | (b,rhs) <- sel_binds] match_result)
+tidy1 v (LazyPat pat) rhs
+ = do { v' <- newSysLocalDs (idType v)
+ ; sel_prs <- mkSelectorBinds pat (Var v)
+ ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
+ ; returnDs (WildPat (idType v),
+ bindOneInMatchResult v' v $
+ mkCoLetsMatchResult sel_binds rhs) }
-- re-express <con-something> as (ConPat ...) [directly]
-tidy1 v (ConPatOut con ps pat_ty ex_tvs dicts) match_result
- = returnDs (ConPatOut con tidy_ps pat_ty ex_tvs dicts, match_result)
+tidy1 v (ConPatOut (L loc con) ex_tvs dicts binds ps pat_ty) rhs
+ = returnDs (ConPatOut (L loc con) ex_tvs dicts binds tidy_ps pat_ty, rhs)
where
- tidy_ps = PrefixCon (tidy_con con pat_ty ex_tvs ps)
+ tidy_ps = PrefixCon (tidy_con con pat_ty ps)
-tidy1 v (ListPat pats ty) match_result
- = returnDs (list_ConPat, match_result)
+tidy1 v (ListPat pats ty) rhs
+ = returnDs (unLoc list_ConPat, rhs)
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
+-- 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)
+tidy1 v (PArrPat pats ty) rhs
+ = returnDs (unLoc parrConPat, rhs)
where
arity = length pats
parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
-tidy1 v (TuplePat pats boxity) match_result
- = returnDs (tuple_ConPat, match_result)
+tidy1 v (TuplePat pats boxity) rhs
+ = returnDs (unLoc tuple_ConPat, rhs)
where
arity = length pats
tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats
(mkTupleTy boxity arity (map hsPatType pats))
-tidy1 v (DictPat dicts methods) match_result
+tidy1 v (DictPat dicts methods) rhs
= case num_of_d_and_ms of
- 0 -> tidy1 v (TuplePat [] Boxed) match_result
- 1 -> tidy1 v (head dict_and_method_pats) match_result
- _ -> tidy1 v (TuplePat dict_and_method_pats Boxed) match_result
+ 0 -> tidy1 v (TuplePat [] Boxed) rhs
+ 1 -> tidy1 v (unLoc (head dict_and_method_pats)) rhs
+ _ -> tidy1 v (TuplePat dict_and_method_pats Boxed) rhs
where
num_of_d_and_ms = length dicts + length methods
- dict_and_method_pats = map VarPat (dicts ++ methods)
+ dict_and_method_pats = map nlVarPat (dicts ++ methods)
-- LitPats: we *might* be able to replace these w/ a simpler form
-tidy1 v pat@(LitPat lit) match_result
- = returnDs (tidyLitPat lit pat, match_result)
+tidy1 v pat@(LitPat lit) rhs
+ = returnDs (unLoc (tidyLitPat lit (noLoc pat)), rhs)
-- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 v pat@(NPatOut lit lit_ty _) match_result
- = returnDs (tidyNPat lit lit_ty pat, match_result)
+tidy1 v pat@(NPatOut lit lit_ty _) rhs
+ = returnDs (unLoc (tidyNPat lit lit_ty (noLoc pat)), rhs)
-- and everything else goes through unchanged...
-tidy1 v non_interesting_pat match_result
- = returnDs (non_interesting_pat, match_result)
+tidy1 v non_interesting_pat rhs
+ = returnDs (non_interesting_pat, rhs)
-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)
+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 WildPat con_arg_tys'
+ map (noLoc . WildPat) con_arg_tys'
| otherwise
- = map mk_pat tagged_arg_tys
+ = 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
-- 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)
+ 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,
- recordSelectorFieldLabel sel_id == lbl
- ] of
- (pat:pats) -> ASSERT( null pats )
- pat
- [] -> WildPat arg_ty
+ 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}
\noindent
%************************************************************************
%* *
-%* match on an unmixed block: the real business *
-%* *
-%************************************************************************
-\subsection[matchEqnBlock]{@matchEqnBlock@: getting down to business}
-
-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}
-matchEqnBlock :: [Id]
- -> [EquationInfo]
- -> DsM MatchResult
-
-matchEqnBlock [] _ = panic "matchEqnBlock: no names"
-
-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
- -- 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
-
- | 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
-
- | 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@ *
%* *
%************************************************************************
\end{enumerate}
\begin{code}
-matchWrapper :: TypecheckedMatchContext -- For shadowing warning messages
- -> [TypecheckedMatch] -- Matches being desugared
+matchWrapper :: HsMatchContext Name -- For shadowing warning messages
+ -> MatchGroup Id -- Matches being desugared
-> DsM ([Id], CoreExpr) -- Results
\end{code}
JJQC 30-Nov-1997
\begin{code}
-matchWrapper ctxt matches
- = getDOptsDs `thenDs` \ dflags ->
- flattenMatches ctxt matches `thenDs` \ (result_ty, eqns_info) ->
- let
- EqnInfo _ _ arg_pats _ : _ = eqns_info
- error_string = matchContextErrString ctxt
- in
- mapDs selectMatchVar arg_pats `thenDs` \ new_vars ->
- match_fun dflags new_vars eqns_info `thenDs` \ match_result ->
-
- mkErrorAppDs pAT_ERROR_ID result_ty error_string `thenDs` \ fail_expr ->
- extractMatchResult match_result fail_expr `thenDs` \ result_expr ->
- returnDs (new_vars, result_expr)
- where match_fun dflags
- = case ctxt of
- LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchExport
- | otherwise -> match
- _ -> matchExport
+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_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}
%************************************************************************
\begin{code}
matchSimply :: CoreExpr -- Scrutinee
- -> TypecheckedMatchContext -- Match kind
- -> TypecheckedPat -- Pattern it should match
+ -> 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
- = getSrcLocDs `thenDs` \ locn ->
+ = getSrcSpanDs `thenDs` \ locn ->
let
- ctx = DsMatchContext kind [pat] locn
+ 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 match_result `thenDs` \ match_result' ->
+ matchSinglePat scrut ctx pat rhs_ty match_result `thenDs` \ match_result' ->
extractMatchResult match_result' fail_expr
-matchSinglePat :: CoreExpr -> DsMatchContext -> TypecheckedPat
- -> MatchResult -> DsM MatchResult
-
-matchSinglePat (Var var) ctx pat match_result
+matchSinglePat :: CoreExpr -> DsMatchContext -> LPat Id
+ -> Type -> MatchResult -> DsM MatchResult
+matchSinglePat (Var var) ctx pat ty match_result
= getDOptsDs `thenDs` \ dflags ->
- match_fn dflags [var] [EqnInfo 1 ctx [pat] match_result]
+ match_fn dflags [var] ty [EqnInfo { eqn_pats = [unLoc pat],
+ eqn_rhs = match_result }]
where
match_fn dflags
- | dopt Opt_WarnSimplePatterns dflags = matchExport
+ | dopt Opt_WarnSimplePatterns dflags = matchCheck ctx
| otherwise = match
-matchSinglePat scrut ctx pat match_result
- = selectMatchVar pat `thenDs` \ var ->
- matchSinglePat (Var var) ctx pat match_result `thenDs` \ match_result' ->
+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}
-%************************************************************************
-%* *
-%* flattenMatches : create a list of EquationInfo *
-%* *
-%************************************************************************
-
-\subsection[flattenMatches]{@flattenMatches@: create @[EquationInfo]@}
-
-This is actually local to @matchWrapper@.
-
-\begin{code}
-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 (tcEqType result_ty) result_tys )
- returnDs (result_ty, eqn_infos)
- where
- 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}
projects / ghc-hetmet.git / blobdiff