\section[Main_match]{The @match@ function}
\begin{code}
-module Match ( match, matchWrapper, matchSimply, matchSinglePat ) where
+module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where
#include "HsVersions.h"
import DynFlags ( DynFlag(..), dopt )
import HsSyn
-import TcHsSyn ( hsPatType )
+import TcHsSyn ( mkVanillaTuplePat )
import Check ( check, ExhaustivePat )
import CoreSyn
import CoreUtils ( bindNonRec, exprType )
import DsMonad
-import DsBinds ( dsHsNestedBinds )
+import DsBinds ( dsLHsBinds )
import DsGRHSs ( dsGRHSs )
import DsUtils
import Id ( idName, idType, Id )
import MatchLit ( matchLiterals, matchNPlusKPats, matchNPats, tidyLitPat, tidyNPat )
import PrelInfo ( pAT_ERROR_ID )
import TcType ( Type, tcTyConAppArgs )
-import Type ( splitFunTysN )
-import TysWiredIn ( consDataCon, mkTupleTy, mkListTy,
+import Type ( splitFunTysN, mkTyVarTys )
+import TysWiredIn ( consDataCon, mkListTy, unitTy,
tupleCon, parrFakeCon, mkPArrTy )
import BasicTypes ( Boxity(..) )
import ListSetOps ( runs )
-import SrcLoc ( noSrcSpan, noLoc, unLoc, Located(..) )
+import SrcLoc ( noLoc, unLoc, Located(..) )
import Util ( lengthExceeds, notNull )
import Name ( Name )
import Outputable
where (pats, eqns_shadow) = check qs
incomplete = want_incomplete && (notNull pats)
want_incomplete = case ctx of
- DsMatchContext RecUpd _ _ ->
+ DsMatchContext RecUpd _ ->
dopt Opt_WarnIncompletePatternsRecUpd dflags
_ ->
dopt Opt_WarnIncompletePatterns dflags
\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)
+dsShadowWarn ctx@(DsMatchContext kind loc) qs
+ = putSrcSpanDs loc (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
+dsIncompleteWarn ctx@(DsMatchContext kind loc) pats
+ = putSrcSpanDs loc (dsWarn warn)
where
warn = pp_context ctx (ptext SLIT("are non-exhaustive"))
(\f -> hang (ptext SLIT("Patterns not matched:"))
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)]])
+pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun
+ = 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
\begin{code}
tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo
- -- DsM'd because of internal call to dsHsNestedBinds
+ -- DsM'd because of internal call to dsLHsBinds
-- and mkSelectorBinds.
-- "tidy1" does the interesting stuff, looking at
-- one pattern and fiddling the list of bindings.
= returnDs (wrap . wrapBind var v, WildPat (idType var))
tidy1 v wrap (VarPatOut var binds)
- = do { prs <- dsHsNestedBinds binds
+ = do { prs <- dsLHsBinds binds
; return (wrap . wrapBind var v . mkDsLet (Rec prs),
WildPat (idType var)) }
tidy1 v wrap (AsPat (L _ var) pat)
= tidy1 v (wrap . wrapBind var v) (unLoc pat)
+tidy1 v wrap (BangPat pat)
+ = tidy1 v (wrap . seqVar v) (unLoc pat)
{- now, here we handle lazy patterns:
tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
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)
+ tidy_ps = PrefixCon (tidy_con con ex_tvs pat_ty ps)
tidy1 v wrap (ListPat pats ty)
= returnDs (wrap, unLoc list_ConPat)
arity = length pats
parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
-tidy1 v wrap (TuplePat pats boxity)
+tidy1 v wrap (TuplePat pats boxity ty)
= returnDs (wrap, unLoc tuple_ConPat)
where
arity = length pats
- tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats
- (mkTupleTy boxity arity (map hsPatType pats))
+ tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty
tidy1 v wrap (DictPat dicts methods)
= case num_of_d_and_ms of
- 0 -> tidy1 v wrap (TuplePat [] Boxed)
+ 0 -> tidy1 v wrap (TuplePat [] Boxed unitTy)
1 -> tidy1 v wrap (unLoc (head dict_and_method_pats))
- _ -> tidy1 v wrap (TuplePat dict_and_method_pats Boxed)
+ _ -> tidy1 v wrap (mkVanillaTuplePat dict_and_method_pats Boxed)
where
num_of_d_and_ms = length dicts + length methods
dict_and_method_pats = map nlVarPat (dicts ++ methods)
= returnDs (wrap, non_interesting_pat)
-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)
+tidy_con data_con ex_tvs pat_ty (PrefixCon ps) = ps
+tidy_con data_con ex_tvs pat_ty (InfixCon p1 p2) = [p1,p2]
+tidy_con data_con ex_tvs pat_ty (RecCon rpats)
| null rpats
= -- Special case for C {}, which can be used for
-- a constructor that isn't declared to have
map (noLoc . WildPat) con_arg_tys'
| 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
+ = 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
+ inst_tys | isVanillaDataCon data_con = tcTyConAppArgs pat_ty -- Newtypes must be opaque
+ | otherwise = mkTyVarTys ex_tvs
+
con_arg_tys' = dataConInstOrigArgTys data_con inst_tys
tagged_arg_tys = con_arg_tys' `zip` dataConFieldLabels data_con
\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
+ = do { eqns_info <- mapM mk_eqn_info matches
+ ; new_vars <- selectMatchVars arg_pats pat_tys
+ ; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty
; return (new_vars, result_expr) }
- where
+ where
arg_pats = map unLoc (hsLMatchPats (head matches))
n_pats = length arg_pats
(pat_tys, rhs_ty) = splitFunTysN n_pats match_ty
; match_result <- dsGRHSs ctxt upats grhss rhs_ty
; return (EqnInfo { eqn_wrap = idWrapper,
eqn_pats = upats,
- eqn_rhs = match_result}) }
+ eqn_rhs = match_result}) }
+
+
+matchEquations :: HsMatchContext Name
+ -> [Id] -> [EquationInfo] -> Type
+ -> DsM CoreExpr
+matchEquations ctxt vars eqns_info rhs_ty
+ = do { dflags <- getDOptsDs
+ ; locn <- getSrcSpanDs
+ ; let ds_ctxt = DsMatchContext ctxt locn
+ error_string = matchContextErrString ctxt
+
+ ; match_result <- match_fun dflags ds_ctxt vars rhs_ty eqns_info
+ ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string
+ ; extractMatchResult match_result fail_expr }
+ where
match_fun dflags ds_ctxt
= case ctxt of
LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchCheck ds_ctxt
| dopt Opt_WarnSimplePatterns dflags = matchCheck ds_ctx
| otherwise = match
where
- ds_ctx = DsMatchContext hs_ctx [pat] locn
+ ds_ctx = DsMatchContext hs_ctx locn
in
match_fn dflags [var] ty [EqnInfo { eqn_wrap = idWrapper,
eqn_pats = [pat],
projects / ghc-hetmet.git / blobdiff