summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/HsToCore/Arrows.hs14
-rw-r--r--compiler/GHC/HsToCore/Coverage.hs4
-rw-r--r--compiler/GHC/HsToCore/Expr.hs12
-rw-r--r--compiler/GHC/HsToCore/GuardedRHSs.hs2
-rw-r--r--compiler/GHC/HsToCore/ListComp.hs6
-rw-r--r--compiler/GHC/HsToCore/Match.hs52
-rw-r--r--compiler/GHC/HsToCore/Match.hs-boot6
-rw-r--r--compiler/GHC/HsToCore/Match/Constructor.hs26
-rw-r--r--compiler/GHC/HsToCore/Match/Literal.hs8
-rw-r--r--compiler/GHC/HsToCore/Monad.hs2
-rw-r--r--compiler/GHC/HsToCore/Pmc.hs13
-rw-r--r--compiler/GHC/HsToCore/Pmc/Desugar.hs18
-rw-r--r--compiler/GHC/HsToCore/Quote.hs10
-rw-r--r--compiler/GHC/HsToCore/Utils.hs34
-rw-r--r--compiler/GHC/Tc/Gen/Arrow.hs8
-rw-r--r--compiler/GHC/Tc/Gen/Bind.hs10
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs11
-rw-r--r--compiler/GHC/Tc/Gen/Match.hs48
-rw-r--r--compiler/GHC/Tc/Gen/Pat.hs39
-rw-r--r--compiler/GHC/Tc/TyCl/Utils.hs4
-rw-r--r--compiler/GHC/Tc/Utils/Unify.hs132
-rw-r--r--compiler/GHC/Tc/Utils/Zonk.hs17
m---------utils/haddock0
23 files changed, 314 insertions, 162 deletions
diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs
index 3d93e0b7a5..5758ba8b74 100644
--- a/compiler/GHC/HsToCore/Arrows.hs
+++ b/compiler/GHC/HsToCore/Arrows.hs
@@ -286,8 +286,8 @@ dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr
fail_expr <- mkFailExpr (ArrowMatchCtxt ProcExpr) env_stk_ty
var <- selectSimpleMatchVarL Many pat
- match_code <- matchSimply (Var var) (ArrowMatchCtxt ProcExpr) pat env_stk_expr fail_expr
let pat_ty = hsLPatType pat
+ match_code <- matchSimply (Var var) (ArrowMatchCtxt ProcExpr) (mkVisPat pat) env_stk_expr fail_expr
let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty
(Lam var match_code)
core_cmd
@@ -559,7 +559,7 @@ dsCmd ids local_vars stack_ty res_ty
(HsCmdLamCase _ mg@MG { mg_ext = MatchGroupTc [Scaled arg_mult arg_ty] _ }) env_ids = do
arg_id <- newSysLocalDs arg_mult arg_ty
let case_cmd = noLocA $ HsCmdCase noExtField (nlHsVar arg_id) mg
- dsCmdLam ids local_vars stack_ty res_ty [nlVarPat arg_id] case_cmd env_ids
+ dsCmdLam ids local_vars stack_ty res_ty [mkVisPat (nlVarPat arg_id)] case_cmd env_ids
-- D; ys |-a cmd : stk --> t
-- ----------------------------------
@@ -691,7 +691,7 @@ dsCmdLam :: DsCmdEnv -- arrow combinators
-> IdSet -- set of local vars available to this command
-> Type -- type of the stack (right-nested tuple)
-> Type -- return type of the command
- -> [LPat GhcTc] -- argument patterns to desugar
+ -> [LMatchPat GhcTc] -- argument patterns to desugar
-> LHsCmd GhcTc -- body to desugar
-> [Id] -- list of vars in the input to this command
-- This is typically fed back,
@@ -699,7 +699,7 @@ dsCmdLam :: DsCmdEnv -- arrow combinators
-> DsM (CoreExpr, -- desugared expression
DIdSet) -- subset of local vars that occur free
dsCmdLam ids local_vars stack_ty res_ty pats body env_ids = do
- let pat_vars = mkVarSet (collectPatsBinders CollWithDictBinders pats)
+ let pat_vars = mkVarSet (collectLMatchPatsBinders CollWithDictBinders pats)
let local_vars' = pat_vars `unionVarSet` local_vars
(pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty
(core_body, free_vars, env_ids')
@@ -865,7 +865,7 @@ dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd) env_ids = do
fail_expr <- mkFailExpr (StmtCtxt (HsDoStmt (DoExpr Nothing))) out_ty
pat_id <- selectSimpleMatchVarL Many pat
match_code
- <- matchSimply (Var pat_id) (StmtCtxt (HsDoStmt (DoExpr Nothing))) pat body_expr fail_expr
+ <- matchSimply (Var pat_id) (StmtCtxt (HsDoStmt (DoExpr Nothing))) (mkVisPat pat) body_expr fail_expr
pair_id <- newSysLocalDs Many after_c_ty
let
proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)
@@ -1094,7 +1094,7 @@ dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []"
matchSimplys :: [CoreExpr] -- Scrutinees
-> HsMatchContext GhcRn -- Match kind
- -> [LPat GhcTc] -- Patterns they should match
+ -> [LMatchPat GhcTc] -- Patterns they should match
-> CoreExpr -- Return this if they all match
-> CoreExpr -- Return this if they don't
-> DsM CoreExpr
@@ -1111,7 +1111,7 @@ leavesMatch :: LMatch GhcTc (LocatedA (body GhcTc))
leavesMatch (L _ (Match { m_pats = pats
, m_grhss = GRHSs _ grhss binds }))
= let
- defined_vars = mkVarSet (collectPatsBinders CollWithDictBinders pats)
+ defined_vars = mkVarSet (collectLMatchPatsBinders CollWithDictBinders pats)
`unionVarSet`
mkVarSet (collectLocalBinders CollWithDictBinders binds)
in
diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs
index 2e45539fba..a6ebd06e38 100644
--- a/compiler/GHC/HsToCore/Coverage.hs
+++ b/compiler/GHC/HsToCore/Coverage.hs
@@ -667,7 +667,7 @@ addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)
-> TM (Match GhcTc (LHsExpr GhcTc))
addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats
, m_grhss = gRHSs }) =
- bindLocals (collectPatsBinders CollNoDictBinders pats) $ do
+ bindLocals (collectLMatchPatsBinders CollNoDictBinders pats) $ do
gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
return $ match { m_grhss = gRHSs' }
@@ -922,7 +922,7 @@ addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do
addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) =
- bindLocals (collectPatsBinders CollNoDictBinders pats) $ do
+ bindLocals (collectLMatchPatsBinders CollNoDictBinders pats) $ do
gRHSs' <- addTickCmdGRHSs gRHSs
return $ match { m_grhss = gRHSs' }
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index f818be46a1..e8a656203c 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -207,11 +207,11 @@ dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss
-- ==> case rhs of C x# y# -> body
do { match_nablas <- pmcGRHSs PatBindGuards grhss
; rhs <- dsGuarded grhss ty match_nablas
- ; let upat = unLoc pat
+ ; let upat = VisPat noExtField pat
eqn = EqnInfo { eqn_pats = [upat],
eqn_orig = FromSource,
eqn_rhs = cantFailMatchResult body }
- ; var <- selectMatchVar Many upat
+ ; var <- selectMatchPatVar Many upat
-- `var` will end up in a let binder, so the multiplicity
-- doesn't matter.
; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
@@ -722,7 +722,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left fields
, cpt_wrap = req_wrap
}
}
- ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) }
+ ; return (mkSimpleMatch RecUpd [mkVisPat pat] wrapped_rhs) }
{- Note [Scrutinee in Record updates]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -927,7 +927,7 @@ dsDo ctx stmts
= do { body <- goL stmts
; rhs' <- dsLExpr rhs
; var <- selectSimpleMatchVarL (xbstc_boundResultMult xbs) pat
- ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat
+ ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) (mkVisPat pat)
(xbstc_boundResultType xbs) (cantFailMatchResult body)
; match_code <- dsHandleMonadicFailure ctx pat match (xbstc_failOp xbs)
; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] }
@@ -948,7 +948,7 @@ dsDo ctx stmts
; let match_args (pat, fail_op) (vs,body)
= do { var <- selectSimpleMatchVarL Many pat
- ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat
+ ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) (mkVisPat pat)
body_ty (cantFailMatchResult body)
; match_code <- dsHandleMonadicFailure ctx pat match fail_op
; return (var:vs, match_code)
@@ -990,7 +990,7 @@ dsDo ctx stmts
mfix_arg = noLocA $ HsLam noExtField
(MG { mg_alts = noLocA [mkSimpleMatch
LambdaExpr
- [mfix_pat] body]
+ [mkVisPat mfix_pat] body]
, mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty
, mg_origin = Generated })
mfix_pat = noLocA $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats
diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs
index 8ecf6c84ed..8d440219b6 100644
--- a/compiler/GHC/HsToCore/GuardedRHSs.hs
+++ b/compiler/GHC/HsToCore/GuardedRHSs.hs
@@ -137,7 +137,7 @@ matchGuards (BindStmt _ pat bind_rhs : stmts) ctx nablas rhs rhs_ty = do
match_result <- matchGuards stmts ctx nablas rhs rhs_ty
core_rhs <- dsLExpr bind_rhs
match_result' <- matchSinglePatVar match_var (Just core_rhs) (StmtCtxt ctx)
- pat rhs_ty match_result
+ (mkVisPat pat) rhs_ty match_result
pure $ bindNonRec match_var core_rhs <$> match_result'
matchGuards (LastStmt {} : _) _ _ _ _ = panic "matchGuards LastStmt"
diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs
index 12a40e6c90..9c42d87c6c 100644
--- a/compiler/GHC/HsToCore/ListComp.hs
+++ b/compiler/GHC/HsToCore/ListComp.hs
@@ -285,7 +285,7 @@ deBindComp pat core_list1 quals core_list2 = do
letrec_body = App (Var h) core_list1
rest_expr <- deListComp quals core_fail
- core_match <- matchSimply (Var u2) (StmtCtxt (HsDoStmt ListComp)) pat rest_expr core_fail
+ core_match <- matchSimply (Var u2) (StmtCtxt (HsDoStmt ListComp)) (mkVisPat pat) rest_expr core_fail
let
rhs = Lam u1 $
@@ -374,7 +374,7 @@ dfBindComp c_id n_id (pat, core_list1) quals = do
-- build the pattern match
core_expr <- matchSimply (Var x) (StmtCtxt (HsDoStmt ListComp))
- pat core_rest (Var b)
+ (mkVisPat pat) core_rest (Var b)
-- now build the outermost foldr, and return
mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1
@@ -611,7 +611,7 @@ dsMcBindStmt :: LPat GhcTc
dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
= do { body <- dsMcStmts stmts
; var <- selectSimpleMatchVarL Many pat
- ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt (DoExpr Nothing))) pat
+ ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt (DoExpr Nothing))) (mkVisPat pat)
res1_ty (cantFailMatchResult body)
; match_code <- dsHandleMonadicFailure MonadComp pat match fail_op
; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index a4cdb78f6d..4a503051e4 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -275,7 +275,7 @@ matchBangs (var :| vars) ty eqns
matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
-- Apply the coercion to the match variable and then match that
matchCoercion (var :| vars) ty (eqns@(eqn1 :| _))
- = do { let XPat (CoPat co pat _) = firstPat eqn1
+ = do { let VisPat _ (L _ (XPat (CoPat co pat _))) = firstPat eqn1
; let pat_ty' = hsPatType pat
; var' <- newUniqueId var (idMult var) pat_ty'
; match_result <- match (var':vars) ty $ NEL.toList $
@@ -290,7 +290,7 @@ matchView (var :| vars) ty (eqns@(eqn1 :| _))
= do { -- we could pass in the expr from the PgView,
-- but this needs to extract the pat anyway
-- to figure out the type of the fresh variable
- let TcViewPat viewExpr pat = firstPat eqn1
+ let VisPat _ (L _ (TcViewPat viewExpr pat)) = firstPat eqn1
-- do the rest of the compilation
; let pat_ty' = hsPatType pat
; var' <- newUniqueId var (idMult var) pat_ty'
@@ -303,17 +303,17 @@ matchView (var :| vars) ty (eqns@(eqn1 :| _))
match_result) }
-- decompose the first pattern and leave the rest alone
-decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
+decomposeFirstPat :: (MatchPat GhcTc -> MatchPat GhcTc) -> EquationInfo -> EquationInfo
decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
= eqn { eqn_pats = extractpat pat : pats}
decomposeFirstPat _ _ = panic "decomposeFirstPat"
-getCoPat, getBangPat, getViewPat :: Pat GhcTc -> Pat GhcTc
-getCoPat (XPat (CoPat _ pat _)) = pat
+getCoPat, getBangPat, getViewPat :: MatchPat GhcTc -> MatchPat GhcTc
+getCoPat (VisPat _ (L _ (XPat (CoPat _ pat _)))) = VisPat noExtField (L noSrcSpanA pat)
getCoPat _ = panic "getCoPat"
-getBangPat (BangPat _ pat ) = unLoc pat
+getBangPat (VisPat _ (L _ (BangPat _ pat))) = VisPat noExtField pat
getBangPat _ = panic "getBangPat"
-getViewPat (TcViewPat _ pat) = pat
+getViewPat (VisPat _ (L _ (TcViewPat _ pat))) = VisPat noExtField (L noSrcSpanA pat)
getViewPat _ = panic "getViewPat"
-- | Use this pattern synonym to match on a 'ViewPat'.
@@ -403,9 +403,20 @@ tidyEqnInfo _ (EqnInfo { eqn_pats = [] })
= panic "tidyEqnInfo"
tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_orig = orig })
- = do { (wrap, pat') <- tidy1 v orig pat
+ = do { (wrap, pat') <- tidy1' v orig pat
; return (wrap, eqn { eqn_pats = pat' : pats }) }
+tidy1' :: Id
+ -> Origin
+ -> MatchPat GhcTc
+ -> DsM (DsWrapper,
+ MatchPat GhcTc)
+tidy1' v o (VisPat ty (L src pat)) =
+ do { (wrapper, pat') <- tidy1 v o pat
+ ; return (wrapper, VisPat ty (L src pat')) }
+tidy1' _ _ var@(InvisTyVarPat _ _) = return (idDsWrapper, var)
+tidy1' _ _ wild@(InvisWildTyPat _) = return (idDsWrapper, wild)
+
tidy1 :: Id -- The Id being scrutinised
-> Origin -- Was this a pattern the user wrote?
-> Pat GhcTc -- The pattern against which it is to be matched
@@ -752,10 +763,10 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
; new_vars <- case matches of
[] -> newSysLocalsDs arg_tys
(m:_) ->
- selectMatchVars (zipWithEqual "matchWrapper"
- (\a b -> (scaledMult a, unLoc b))
- arg_tys
- (hsLMatchPats m))
+ selectMatchPatVars (zipWithEqual "matchWrapper"
+ (\a b -> (scaledMult a, unLoc b))
+ arg_tys
+ (hsLMatchPats m))
-- Pattern match check warnings for /this match-group/.
-- @rhss_nablas@ is a flat list of covered Nablas for each RHS.
@@ -776,7 +787,7 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
mk_eqn_info :: LMatch GhcTc (LHsExpr GhcTc) -> (Nablas, NonEmpty Nablas) -> DsM EquationInfo
mk_eqn_info (L _ (Match { m_pats = pats, m_grhss = grhss })) (pat_nablas, rhss_nablas)
= do { dflags <- getDynFlags
- ; let upats = map (unLoc . decideBangHood dflags) pats
+ ; let upats = map (unLoc . decideBangHoodMatch dflags) pats
-- pat_nablas is the covered set *after* matching the pattern, but
-- before any of the GRHSs. We extend the environment with pat_nablas
-- (via updPmNablas) so that the where-clause of 'grhss' can profit
@@ -816,7 +827,7 @@ matchEquations ctxt vars eqns_info rhs_ty
-- pattern. It returns an expression.
matchSimply :: CoreExpr -- ^ Scrutinee
-> HsMatchContext GhcRn -- ^ Match kind
- -> LPat GhcTc -- ^ Pattern it should match
+ -> LMatchPat GhcTc -- ^ Pattern it should match
-> CoreExpr -- ^ Return this if it matches
-> CoreExpr -- ^ Return this if it doesn't
-> DsM CoreExpr
@@ -837,7 +848,7 @@ matchSimply scrut hs_ctx pat result_expr fail_expr = do
match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result
extractMatchResult match_result' fail_expr
-matchSinglePat :: CoreExpr -> HsMatchContext GhcRn -> LPat GhcTc
+matchSinglePat :: CoreExpr -> HsMatchContext GhcRn -> LMatchPat GhcTc
-> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
-- matchSinglePat ensures that the scrutinee is a variable
-- and then calls matchSinglePatVar
@@ -851,7 +862,7 @@ matchSinglePat (Var var) ctx pat ty match_result
= matchSinglePatVar var Nothing ctx pat ty match_result
matchSinglePat scrut hs_ctx pat ty match_result
- = do { var <- selectSimpleMatchVarL Many pat
+ = do { var <- selectMatchPatVarL Many pat
-- matchSinglePat is only used in matchSimply, which
-- is used in list comprehension, arrow notation,
-- and to create field selectors. All of which only
@@ -863,7 +874,7 @@ matchSinglePat scrut hs_ctx pat ty match_result
matchSinglePatVar :: Id -- See Note [Match Ids]
-> Maybe CoreExpr -- ^ The scrutinee the match id is bound to
- -> HsMatchContext GhcRn -> LPat GhcTc
+ -> HsMatchContext GhcRn -> LMatchPat GhcTc
-> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
matchSinglePatVar var mb_scrut ctx pat ty match_result
= assertPpr (isInternalName (idName var)) (ppr var) $
@@ -872,14 +883,13 @@ matchSinglePatVar var mb_scrut ctx pat ty match_result
-- Pattern match check warnings
; when (isMatchContextPmChecked dflags FromSource ctx) $
addCoreScrutTmCs mb_scrut [var] $
- pmcPatBind (DsMatchContext ctx locn) var (unLoc pat)
+ pmcMatchPatBind (DsMatchContext ctx locn) var (unLoc pat)
- ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]
+ ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHoodMatch dflags pat)]
, eqn_orig = FromSource
, eqn_rhs = match_result }
; match [var] ty [eqn_info] }
-
{-
************************************************************************
* *
@@ -931,7 +941,7 @@ groupEquations :: Platform -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInf
-- (b) none of the gi are empty
-- The ordering of equations is unchanged
groupEquations platform eqns
- = NEL.groupBy same_gp $ [(patGroup platform (firstPat eqn), eqn) | eqn <- eqns]
+ = NEL.groupBy same_gp $ [(patGroup platform (firstPat' eqn), eqn) | eqn <- eqns]
-- comprehension on NonEmpty
where
same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
diff --git a/compiler/GHC/HsToCore/Match.hs-boot b/compiler/GHC/HsToCore/Match.hs-boot
index e163a0bde2..7b16eb465f 100644
--- a/compiler/GHC/HsToCore/Match.hs-boot
+++ b/compiler/GHC/HsToCore/Match.hs-boot
@@ -5,7 +5,7 @@ import GHC.Types.Var ( Id )
import GHC.Tc.Utils.TcType ( Type )
import GHC.HsToCore.Monad ( DsM, EquationInfo, MatchResult )
import GHC.Core ( CoreExpr )
-import GHC.Hs ( LPat, HsMatchContext, MatchGroup, LHsExpr )
+import GHC.Hs ( LMatchPat, HsMatchContext, MatchGroup, LHsExpr )
import GHC.Hs.Extension ( GhcTc, GhcRn )
match :: [Id]
@@ -22,7 +22,7 @@ matchWrapper
matchSimply
:: CoreExpr
-> HsMatchContext GhcRn
- -> LPat GhcTc
+ -> LMatchPat GhcTc
-> CoreExpr
-> CoreExpr
-> DsM CoreExpr
@@ -31,7 +31,7 @@ matchSinglePatVar
:: Id
-> Maybe CoreExpr
-> HsMatchContext GhcRn
- -> LPat GhcTc
+ -> LMatchPat GhcTc
-> Type
-> MatchResult CoreExpr
-> DsM (MatchResult CoreExpr)
diff --git a/compiler/GHC/HsToCore/Match/Constructor.hs b/compiler/GHC/HsToCore/Match/Constructor.hs
index 1e56808278..ee0f57b362 100644
--- a/compiler/GHC/HsToCore/Match/Constructor.hs
+++ b/compiler/GHC/HsToCore/Match/Constructor.hs
@@ -154,21 +154,21 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct
}
shift (_, eqn@(EqnInfo
- { eqn_pats = ConPat
+ { eqn_pats = VisPat _ (L _ (ConPat
{ pat_args = args
, pat_con_ext = ConPatTc
{ cpt_tvs = tvs
, cpt_dicts = ds
, cpt_binds = bind
}
- } : pats
+ })) : pats
}))
= do ds_bind <- dsTcEvBinds bind
return ( wrapBinds (tvs `zip` tvs1)
. wrapBinds (ds `zip` dicts1)
. mkCoreLets ds_bind
, eqn { eqn_orig = Generated
- , eqn_pats = conArgPats val_arg_tys args ++ pats }
+ , eqn_pats = ((\pat -> VisPat noExtField (L noSrcSpanA pat)) <$> (conArgPats val_arg_tys args)) ++ pats }
)
shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)
; let scaled_arg_tys = map (scaleScaled mult) val_arg_tys
@@ -185,7 +185,7 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct
-- Divide into sub-groups; see Note [Record patterns]
; let groups :: [[(ConArgPats, EquationInfo)]]
- groups = groupBy compatible_pats [ (pat_args (firstPat eqn), eqn)
+ groups = groupBy compatible_pats [ (pat_args (firstPat' eqn), eqn)
| eqn <- eqn1:eqns ]
; match_results <- mapM (match_group arg_vars) groups
@@ -195,15 +195,15 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct
alt_wrapper = wrapper1,
alt_result = foldr1 combineMatchResults match_results } }
where
- ConPat { pat_con = L _ con1
- , pat_args = args1
- , pat_con_ext = ConPatTc
- { cpt_arg_tys = arg_tys
- , cpt_wrap = wrapper1
- , cpt_tvs = tvs1
- , cpt_dicts = dicts1
- }
- } = firstPat eqn1
+ VisPat _ (L _ (ConPat { pat_con = L _ con1
+ , pat_args = args1
+ , pat_con_ext = ConPatTc
+ { cpt_arg_tys = arg_tys
+ , cpt_wrap = wrapper1
+ , cpt_tvs = tvs1
+ , cpt_dicts = dicts1
+ }
+ })) = firstPat eqn1
fields1 = map flSelector (conLikeFieldLabels con1)
ex_tvs = conLikeExTyCoVars con1
diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs
index a581a961b5..b70a7f2c07 100644
--- a/compiler/GHC/HsToCore/Match/Literal.hs
+++ b/compiler/GHC/HsToCore/Match/Literal.hs
@@ -602,7 +602,7 @@ matchLiterals (var :| vars) ty sub_groups
match_group eqns@(firstEqn :| _)
= do { dflags <- getDynFlags
; let platform = targetPlatform dflags
- ; let LitPat _ hs_lit = firstPat firstEqn
+ ; let (VisPat _ (L _ (LitPat _ hs_lit))) = firstPat firstEqn
; match_result <- match vars ty (NEL.toList $ shiftEqns eqns)
; return (hsLitKey platform hs_lit, match_result) }
@@ -651,7 +651,7 @@ hsLitKey _ l = pprPanic "hsLitKey" (ppr l)
matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchNPats (var :| vars) ty (eqn1 :| eqns) -- All for the same literal
- = do { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1
+ = do { let VisPat _ (L _ (NPat _ (L _ lit) mb_neg eq_chk)) = firstPat eqn1
; lit_expr <- dsOverLit lit
; neg_lit <- case mb_neg of
Nothing -> return lit_expr
@@ -681,7 +681,7 @@ We generate:
matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
-- All NPlusKPats, for the *same* literal k
matchNPlusKPats (var :| vars) ty (eqn1 :| eqns)
- = do { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus
+ = do { let VisPat _ (L _ (NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus))
= firstPat eqn1
; lit1_expr <- dsOverLit lit1
; lit2_expr <- dsOverLit lit2
@@ -694,7 +694,7 @@ matchNPlusKPats (var :| vars) ty (eqn1 :| eqns)
fmap (foldr1 (.) wraps) $
match_result) }
where
- shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats })
+ shift n1 eqn@(EqnInfo { eqn_pats = VisPat _ (L _ (NPlusKPat _ (L _ n) _ _ _ _)) : pats })
= (wrapBind n n1, eqn { eqn_pats = pats })
-- The wrapBind is a no-op for the first equation
shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index 9211b52fd7..73e6b4a0bf 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -126,7 +126,7 @@ instance Outputable DsMatchContext where
ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match
data EquationInfo
- = EqnInfo { eqn_pats :: [Pat GhcTc]
+ = EqnInfo { eqn_pats :: [MatchPat GhcTc]
-- ^ The patterns for an equation
--
-- NB: We have /already/ applied 'decideBangHood' to
diff --git a/compiler/GHC/HsToCore/Pmc.hs b/compiler/GHC/HsToCore/Pmc.hs
index ab6479f75b..f2278b7472 100644
--- a/compiler/GHC/HsToCore/Pmc.hs
+++ b/compiler/GHC/HsToCore/Pmc.hs
@@ -34,7 +34,7 @@
-- 'ldiMatch'. See Section 4.1 of the paper.
module GHC.HsToCore.Pmc (
-- Checking and printing
- pmcPatBind, pmcMatches, pmcGRHSs,
+ pmcPatBind, pmcMatchPatBind, pmcMatches, pmcGRHSs,
isMatchContextPmChecked,
-- See Note [Long-distance information]
@@ -108,6 +108,17 @@ pmcPatBind ctxt@(DsMatchContext PatBindRhs loc) var p = do
formatReportWarnings cirbsPatBind ctxt [var] result
pmcPatBind _ _ _ = pure ()
+pmcMatchPatBind :: DsMatchContext -> Id -> MatchPat GhcTc -> DsM ()
+-- See Note [pmcPatBind only checks PatBindRhs]
+pmcMatchPatBind ctxt@(DsMatchContext PatBindRhs loc) var p = do
+ !missing <- getLdiNablas
+ pat_bind <- noCheckDs $ desugarMatchPatBind loc var p
+ tracePm "pmcPatBind {" (vcat [ppr ctxt, ppr var, ppr p, ppr pat_bind, ppr missing])
+ result <- unCA (checkPatBind pat_bind) missing
+ tracePm "}: " (ppr (cr_uncov result))
+ formatReportWarnings cirbsPatBind ctxt [var] result
+pmcMatchPatBind _ _ _ = pure ()
+
-- | Exhaustive for guard matches, is used for guards in pattern bindings and
-- in @MultiIf@ expressions. Returns the 'Nablas' covered by the RHSs.
pmcGRHSs
diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs
index 629f32f3cd..cadf70fea0 100644
--- a/compiler/GHC/HsToCore/Pmc/Desugar.hs
+++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs
@@ -11,7 +11,7 @@
-- In terms of the paper, this module is concerned with Sections 3.1, Figure 4,
-- in particular.
module GHC.HsToCore.Pmc.Desugar (
- desugarPatBind, desugarGRHSs, desugarMatches, desugarEmptyCase
+ desugarPatBind, desugarMatchPatBind, desugarGRHSs, desugarMatches, desugarEmptyCase
) where
import GHC.Prelude
@@ -254,6 +254,15 @@ desugarPatV pat = do
desugarLPat :: Id -> LPat GhcTc -> DsM [PmGrd]
desugarLPat x = desugarPat x . unLoc
+desugarMatchPat :: Id -> MatchPat GhcTc -> DsM [PmGrd]
+desugarMatchPat x (VisPat _ pat) = desugarLPat x pat
+desugarMatchPat x (InvisTyVarPat _ (L _ lidp)) =
+ return $ mkPmLetVar x lidp
+desugarMatchPat _ (InvisWildTyPat _) = pure []
+
+desugarLMatchPat :: Id -> LMatchPat GhcTc -> DsM [PmGrd]
+desugarLMatchPat id lmatchpat = desugarMatchPat id (unLoc lmatchpat)
+
-- | 'desugarLPat', but also select and return a new match var.
desugarLPatV :: LPat GhcTc -> DsM (Id, [PmGrd])
desugarLPatV = desugarPatV . unLoc
@@ -320,6 +329,11 @@ desugarPatBind :: SrcSpan -> Id -> Pat GhcTc -> DsM (PmPatBind Pre)
desugarPatBind loc var pat =
PmPatBind . flip PmGRHS (SrcInfo (L loc (ppr pat))) . GrdVec <$> desugarPat var pat
+desugarMatchPatBind :: SrcSpan -> Id -> MatchPat GhcTc -> DsM (PmPatBind Pre)
+ -- See 'GrdPatBind' for how this simply repurposes GrdGRHS.
+desugarMatchPatBind loc var pat =
+ PmPatBind . flip PmGRHS (SrcInfo (L loc (ppr pat))) . GrdVec <$> desugarMatchPat var pat
+
desugarEmptyCase :: Id -> DsM PmEmptyCase
desugarEmptyCase var = pure PmEmptyCase { pe_var = var }
@@ -332,7 +346,7 @@ desugarMatches vars matches =
-- Desugar a single match
desugarMatch :: [Id] -> LMatch GhcTc (LHsExpr GhcTc) -> DsM (PmMatch Pre)
desugarMatch vars (L match_loc (Match { m_pats = pats, m_grhss = grhss })) = do
- pats' <- concat <$> zipWithM desugarLPat vars pats
+ pats' <- concat <$> zipWithM desugarLMatchPat vars pats
grhss' <- desugarGRHSs (locA match_loc) (sep (map ppr pats)) grhss
-- tracePm "desugarMatch" (vcat [ppr pats, ppr pats', ppr grhss'])
return PmMatch { pm_pats = GrdVec pats', pm_grhss = grhss' }
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index d6db406b44..ad0c17e866 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -1667,7 +1667,7 @@ the choice in HsExpanded, but it seems simpler to consult the flag (again).
-- Building representations of auxiliary structures like Match, Clause, Stmt,
repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Match))
-repMatchTup (L _ (Match { m_pats = [p]
+repMatchTup (L _ (Match { m_pats = [L _ (VisPat _ p)]
, m_grhss = GRHSs _ guards wheres })) =
do { ss1 <- mkGenSyms (collectPatBinders CollNoDictBinders p)
; addBinds ss1 $ do {
@@ -1682,9 +1682,9 @@ repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Clause))
repClauseTup (L _ (Match { m_pats = ps
, m_grhss = GRHSs _ guards wheres })) =
- do { ss1 <- mkGenSyms (collectPatsBinders CollNoDictBinders ps)
+ do { ss1 <- mkGenSyms (collectLMatchPatsBinders CollNoDictBinders ps)
; addBinds ss1 $ do {
- ps1 <- repLPs ps
+ ps1 <- repLPs (toLPats ps)
; (ss2,ds) <- repBinds wheres
; addBinds ss2 $ do {
gs <- repGuards guards
@@ -2022,10 +2022,10 @@ repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Exp))
repLambda (L _ (Match { m_pats = ps
, m_grhss = GRHSs _ [L _ (GRHS _ [] e)]
(EmptyLocalBinds _) } ))
- = do { let bndrs = collectPatsBinders CollNoDictBinders ps ;
+ = do { let bndrs = collectLMatchPatsBinders CollNoDictBinders ps ;
; ss <- mkGenSyms bndrs
; lam <- addBinds ss (
- do { xs <- repLPs ps; body <- repLE e; repLam xs body })
+ do { xs <- repLPs (toLPats ps); body <- repLE e; repLam xs body })
; wrapGenSyms ss lam }
repLambda (L _ m) = notHandled (ThGuardedLambdas m)
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
index 2ea1bb3cbe..db86bb2cd4 100644
--- a/compiler/GHC/HsToCore/Utils.hs
+++ b/compiler/GHC/HsToCore/Utils.hs
@@ -16,7 +16,7 @@ This module exports some utility functions of no great interest.
-- | Utility functions for constructing Core syntax, principally for desugaring
module GHC.HsToCore.Utils (
EquationInfo(..),
- firstPat, shiftEqns,
+ firstPat, firstPat', shiftEqns,
MatchResult (..), CaseAlt(..),
cantFailMatchResult, alwaysFailMatchResult,
@@ -40,8 +40,9 @@ module GHC.HsToCore.Utils (
mkSelectorBinds,
- selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
- mkOptTickBox, mkBinaryTickBox, decideBangHood,
+ selectSimpleMatchVarL, selectMatchPatVarL, selectMatchVars, selectMatchVar,
+ selectMatchPatVar, selectMatchPatVars,
+ mkOptTickBox, mkBinaryTickBox, decideBangHood, decideBangHoodMatch,
isTrueLHsExpr
) where
@@ -146,6 +147,17 @@ selectMatchVar _w (VarPat _ var) = return (localiseId (unLoc var))
selectMatchVar _w (AsPat _ var _) = assert (isManyDataConTy _w ) (return (unLoc var))
selectMatchVar w other_pat = newSysLocalDs w (hsPatType other_pat)
+selectMatchPatVar :: Mult -> MatchPat GhcTc -> DsM Id
+selectMatchPatVar w (VisPat _ pat) = selectMatchVar w (unLoc pat)
+selectMatchPatVar _ (InvisTyVarPat _ id) = return (localiseId (unLoc id))
+selectMatchPatVar w (InvisWildTyPat ty) = newSysLocalDs w ty
+
+selectMatchPatVarL :: Mult -> LMatchPat GhcTc -> DsM Id
+selectMatchPatVarL w lmatchpat = selectMatchPatVar w (unLoc lmatchpat)
+
+selectMatchPatVars :: [(Mult, MatchPat GhcTc)] -> DsM [Id]
+selectMatchPatVars ps = mapM (uncurry selectMatchPatVar) ps
+
{- Note [Localise pattern binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider module M where
@@ -196,9 +208,12 @@ The ``equation info'' used by @match@ is relatively complicated and
worthy of a type synonym and a few handy functions.
-}
-firstPat :: EquationInfo -> Pat GhcTc
+firstPat :: EquationInfo -> MatchPat GhcTc
firstPat eqn = assert (notNull (eqn_pats eqn)) $ head (eqn_pats eqn)
+firstPat' :: EquationInfo -> Pat GhcTc
+firstPat' eqn = assert (notNull (eqn_pats eqn)) $ head (toPats . eqn_pats $ eqn)
+
shiftEqns :: Functor f => f EquationInfo -> f EquationInfo
-- Drop the first pattern in each equation
shiftEqns = fmap $ \eqn -> eqn { eqn_pats = tail (eqn_pats eqn) }
@@ -744,7 +759,7 @@ mkSelectorBinds ticks pat val_expr
; let mk_bind tick bndr_var
-- (mk_bind sv bv) generates bv = case sv of { pat -> bv }
-- Remember, 'pat' binds 'bv'
- = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat'
+ = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs (mkVisPat pat')
(Var bndr_var)
(Var bndr_var) -- Neat hack
-- Neat hack: since 'pat' can't fail, the
@@ -759,7 +774,7 @@ mkSelectorBinds ticks pat val_expr
| otherwise -- General case (C)
= do { tuple_var <- newSysLocalDs Many tuple_ty
; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat')
- ; tuple_expr <- matchSimply val_expr PatBindRhs pat
+ ; tuple_expr <- matchSimply val_expr PatBindRhs (mkVisPat pat)
local_tuple error_expr
; let mk_tup_bind tick binder
= (binder, mkOptTickBox tick $
@@ -1059,6 +1074,13 @@ decideBangHood dflags lpat
BangPat _ _ -> lp
_ -> L l (BangPat noExtField lp)
+decideBangHoodMatch :: DynFlags
+ -> LMatchPat GhcTc -- ^ Original pattern
+ -> LMatchPat GhcTc -- Pattern with bang if necessary
+decideBangHoodMatch dflags (L l (VisPat t lpat)) =
+ (L l (VisPat t (decideBangHood dflags lpat)))
+decideBangHoodMatch _ matchpat = matchpat
+
isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
-- Returns Just {..} if we're sure that the expression is True
diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs
index da8bf7901f..97c0fc7069 100644
--- a/compiler/GHC/Tc/Gen/Arrow.hs
+++ b/compiler/GHC/Tc/Gen/Arrow.hs
@@ -269,18 +269,18 @@ tc_cmd env
(cmd_stk, res_ty)
= addErrCtxt (pprMatchInCtxt match) $
do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk
+ ; arg_tys' <- sequenceA (map (readExpType . mkCheckExpType) arg_tys)
-- Check the patterns, and the GRHSs inside
- ; (pats', grhss') <- setSrcSpanA mtch_loc $
- tcPats (ArrowMatchCtxt KappaExpr)
- pats (map (unrestricted . mkCheckExpType) arg_tys) $
+ ; (pats', grhss') <- setSrcSpanA mtch_loc $
+ tcLMatchPats (ArrowMatchCtxt KappaExpr) pats (unrestricted <$> arg_tys') $
tc_grhss grhss cmd_stk' (mkCheckExpType res_ty)
; let match' = L mtch_loc (Match { m_ext = noAnn
, m_ctxt = ArrowMatchCtxt KappaExpr
, m_pats = pats'
, m_grhss = grhss' })
- arg_tys = map (unrestricted . hsLPatType) pats'
+ arg_tys = map (unrestricted . hsLMatchPatType) pats'
; _concrete_evs <-
zipWithM
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index 93fa9a7e2c..d4e65ba9fe 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -645,10 +645,10 @@ tcPolyCheck prag_fn
; mod <- getModule
; tick <- funBindTicks (locA nm_loc) poly_id mod prag_sigs
- ; let bind' = FunBind { fun_id = L nm_loc poly_id2
- , fun_matches = matches'
- , fun_ext = wrap_gen <.> wrap_res
- , fun_tick = tick }
+ ; let bind' = FunBind { fun_id = L nm_loc poly_id2
+ , fun_matches = matches'
+ , fun_ext = wrap_gen <.> wrap_res
+ , fun_tick = tick }
export = ABE { abe_ext = noExtField
, abe_wrap = idHsWrapper
@@ -1507,7 +1507,7 @@ getMonoBindInfo :: [LocatedA TcMonoBind] -> [MonoBindInfo]
getMonoBindInfo tc_binds
= foldr (get_info . unLoc) [] tc_binds
where
- get_info (TcFunBind info _ _) rest = info : rest
+ get_info (TcFunBind info _ _) rest = info : rest
get_info (TcPatBind infos _ _ _) rest = infos ++ rest
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index c9e9129251..0d7310e15c 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -83,6 +83,7 @@ import Control.Monad
import GHC.Core.Class(classTyCon)
import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet )
+import GHC.Data.FastString (fsLit)
import Data.Function
import Data.List (partition, sortBy, groupBy, intersect)
@@ -1036,13 +1037,15 @@ tcSynArgE orig sigma_ty syn_ty thing_inside
; return (result, mkWpCastN list_co) }
go rho_ty (SynFun arg_shape res_shape)
- = do { ( match_wrapper -- :: (arg_ty -> res_ty) "->" rho_ty
+ = do { uniq <- newUnique
+ ; let name = mkSystemName uniq (mkTyVarOccFS . fsLit $ "var")
+ ; ( match_wrapper -- :: (arg_ty -> res_ty) "->" rho_ty
, ( ( (result, arg_ty, res_ty, op_mult)
, res_wrapper ) -- :: res_ty_out "->" res_ty
, arg_wrapper1, [], arg_wrapper2 ) ) -- :: arg_ty "->" arg_ty_out
- <- matchExpectedFunTys herald GenSigCtxt 1 (mkCheckExpType rho_ty) $
+ <- matchExpectedFunTys herald GenSigCtxt [L noSrcSpanA (VisPat NoExtField (L noSrcSpanA (VarPat noExtField (L noSrcSpanA name))))] (mkCheckExpType rho_ty) $
\ [arg_ty] res_ty ->
- do { arg_tc_ty <- expTypeToType (scaledThing arg_ty)
+ do { let arg_tc_ty = varType arg_ty
; res_tc_ty <- expTypeToType res_ty
-- another nested arrow is too much for now,
@@ -1053,7 +1056,7 @@ tcSynArgE orig sigma_ty syn_ty thing_inside
(text "Too many nested arrows in SyntaxOpType" $$
pprCtOrigin orig)
- ; let arg_mult = scaledMult arg_ty
+ ; let arg_mult = Many
; tcSynArgA orig arg_tc_ty [] arg_shape $
\ arg_results arg_res_mults ->
tcSynArgE orig res_tc_ty res_shape $
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index 1b2ebf797a..e5f4974c38 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -53,6 +53,7 @@ import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep )
import GHC.Tc.Utils.Unify
import GHC.Tc.Types.Origin
import GHC.Tc.Types.Evidence
+import GHC.Types.Var ( Var(..) )
import GHC.Core.Multiplicity
import GHC.Core.UsageEnv
@@ -94,7 +95,7 @@ same number of arguments before using @tcMatches@ to do the work.
tcMatchesFun :: LocatedN Id -- MatchContext Id
-> MatchGroup GhcRn (LHsExpr GhcRn)
- -> ExpRhoType -- Expected type of function
+ -> ExpRhoType -- Expected type of function
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-- Returns type of body
tcMatchesFun fun_id matches exp_ty
@@ -107,7 +108,7 @@ tcMatchesFun fun_id matches exp_ty
traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)
; checkArgs fun_name matches
- ; matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty ->
+ ; matchExpectedFunTys herald ctxt lampats exp_ty $ \ pat_vars rhs_ty ->
-- NB: exp_type may be polymorphic, but
-- matchExpectedFunTys can cope with that
tcScalingUsage Many $
@@ -117,10 +118,10 @@ tcMatchesFun fun_id matches exp_ty
-- being scaled by Many. When let binders come with a
-- multiplicity, then @tcMatchesFun@ will have to take
-- a multiplicity argument, and scale accordingly.
- tcMatches match_ctxt pat_tys rhs_ty matches }
+ tcMatches match_ctxt pat_vars rhs_ty matches }
where
fun_name = idName (unLoc fun_id)
- arity = matchGroupArity matches
+ lampats = matchGroupLMatchPats matches
herald = text "The equation(s) for"
<+> quotes (ppr fun_name) <+> text "have"
ctxt = GenSigCtxt -- Was: FunSigCtxt fun_name True
@@ -153,8 +154,9 @@ tcMatchesCase :: (AnnoBody body) =>
-- Translated alternatives
-- wrapper goes from MatchGroup's ty to expected ty
-tcMatchesCase ctxt (Scaled scrut_mult scrut_ty) matches res_ty
- = tcMatches ctxt [Scaled scrut_mult (mkCheckExpType scrut_ty)] res_ty matches
+tcMatchesCase ctxt (Scaled _ scrut_ty) matches res_ty
+ = do { var <- newFlexiTyVar scrut_ty
+ ; tcMatches ctxt [var] res_ty matches }
tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify
-> TcMatchCtxt HsExpr
@@ -165,8 +167,8 @@ tcMatchLambda herald match_ctxt match res_ty
= matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty ->
tcMatches match_ctxt pat_tys rhs_ty match
where
- n_pats | isEmptyMatchGroup match = 1 -- must be lambda-case
- | otherwise = matchGroupArity match
+ n_pats | isEmptyMatchGroup match = [] -- must be lambda-case
+ | otherwise = matchGroupLMatchPats match
-- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
@@ -213,7 +215,7 @@ type AnnoBody body
-- | Type-check a MatchGroup.
tcMatches :: (AnnoBody body ) => TcMatchCtxt body
- -> [Scaled ExpSigmaType] -- Expected pattern types
+ -> [Var] -- Expected pattern types
-> ExpRhoType -- Expected result-type of the Match.
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
@@ -225,44 +227,44 @@ tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches
-- when in inference mode, so we must do it ourselves,
-- here, using expTypeToType
= do { tcEmitBindingUsage bottomUE
- ; pat_tys <- mapM scaledExpTypeToType pat_tys
+ ; let pat_tys' = map (unrestricted . varType) pat_tys
; rhs_ty <- expTypeToType rhs_ty
; _concrete_evs <- zipWithM
- (\ i (Scaled _ pat_ty) ->
+ (\ i pat_ty ->
hasFixedRuntimeRep (FRRMatch (mc_what ctxt) i) pat_ty)
- [1..] pat_tys
+ [1..] (varType <$> pat_tys)
; return (MG { mg_alts = L l []
- , mg_ext = MatchGroupTc pat_tys rhs_ty
+ , mg_ext = MatchGroupTc pat_tys' rhs_ty
, mg_origin = origin }) }
| otherwise
= do { umatches <- mapM (tcCollectingUsage . tcMatch ctxt pat_tys rhs_ty) matches
; let (usages,matches') = unzip umatches
; tcEmitBindingUsage $ supUEs usages
- ; pat_tys <- mapM readScaledExpType pat_tys
+ ; let pat_tys' = map (unrestricted . varType) pat_tys
; rhs_ty <- readExpType rhs_ty
; _concrete_evs <- zipWithM
- (\ i (Scaled _ pat_ty) ->
+ (\ i pat_ty ->
hasFixedRuntimeRep (FRRMatch (mc_what ctxt) i) pat_ty)
- [1..] pat_tys
+ [1..] (varType <$> pat_tys)
; return (MG { mg_alts = L l matches'
- , mg_ext = MatchGroupTc pat_tys rhs_ty
+ , mg_ext = MatchGroupTc pat_tys' rhs_ty
, mg_origin = origin }) }
-------------
tcMatch :: (AnnoBody body) => TcMatchCtxt body
- -> [Scaled ExpSigmaType] -- Expected pattern types
+ -> [Var] -- Expected pattern types
-> ExpRhoType -- Expected result-type of the Match.
-> LMatch GhcRn (LocatedA (body GhcRn))
-> TcM (LMatch GhcTc (LocatedA (body GhcTc)))
-tcMatch ctxt pat_tys rhs_ty match
- = wrapLocMA (tc_match ctxt pat_tys rhs_ty) match
+tcMatch ctxt vars rhs_ty match
+ = wrapLocMA (tc_match ctxt ((\var -> unrestricted (varType var)) <$> vars) rhs_ty) match
where
- tc_match ctxt pat_tys rhs_ty
- match@(Match { m_pats = pats, m_grhss = grhss })
+ tc_match ctxt vars rhs_ty
+ match@(Match { m_pats = lampats, m_grhss = grhss })
= add_match_ctxt match $
- do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
+ do { (pats', grhss') <- tcLMatchPats (mc_what ctxt) lampats vars $
tcGRHSs ctxt grhss rhs_ty
; return (Match { m_ext = noAnn
, m_ctxt = mc_what ctxt, m_pats = pats'
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index a09d77b6f7..b0177319ad 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -19,7 +19,7 @@ module GHC.Tc.Gen.Pat
, newLetBndr
, LetBndrSpec(..)
, tcCheckPat, tcCheckPat_O, tcInferPat
- , tcPats
+ , tcLMatchPats
, addDataConStupidTheta
, badFieldCon
, polyPatSig
@@ -99,11 +99,11 @@ tcLetPat sig_fn no_gen pat pat_ty thing_inside
; tc_lpat pat_ty penv pat thing_inside }
-----------------
-tcPats :: HsMatchContext GhcTc
- -> [LPat GhcRn] -- Patterns,
- -> [Scaled ExpSigmaType] -- and their types
- -> TcM a -- and the checker for the body
- -> TcM ([LPat GhcTc], a)
+tcLMatchPats :: HsMatchContext GhcTc
+ -> [LMatchPat GhcRn] -- Patterns,
+ -> [Scaled Type] -- and their types
+ -> TcM a -- and the checker for the body
+ -> TcM ([LMatchPat GhcTc], a)
-- This is the externally-callable wrapper function
-- Typecheck the patterns, extend the environment to bind the variables,
@@ -116,8 +116,8 @@ tcPats :: HsMatchContext GhcTc
-- 3. Check the body
-- 4. Check that no existentials escape
-tcPats ctxt pats pat_tys thing_inside
- = tc_lpats pat_tys penv pats thing_inside
+tcLMatchPats ctxt pats pat_tys thing_inside
+ = tc_lmatchpats pat_tys penv pats thing_inside
where
penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }
@@ -340,6 +340,21 @@ tc_lpat pat_ty penv (L span pat) thing_inside
thing_inside
; return (L span pat', res) }
+tc_lmatchpat :: Scaled Type
+ -> Checker (LMatchPat GhcRn) (LMatchPat GhcTc)
+tc_lmatchpat (Scaled mult ty') penv (L l (VisPat x pat)) thing_inside
+ = do { (pat', res) <- tc_lpat (Scaled mult (Check ty')) penv pat thing_inside
+ ; return (L l (VisPat x pat'), res) }
+tc_lmatchpat ty _ (L l' (InvisTyVarPat x (L l name))) thing_inside
+ = do { let ty' = scaledThing ty
+ ; let var = mkLocalIdOrCoVar name Many ty'
+ ; (res,_) <- tcCheckUsage name ty' $ tcExtendIdEnv1 name var thing_inside
+ ; return (L l' (InvisTyVarPat x (L l var)),res)
+ }
+tc_lmatchpat (Scaled _ ty) _ (L l' (InvisWildTyPat _)) thing_inside
+ = do { res <- thing_inside
+ ; return (L l' (InvisWildTyPat ty), res) }
+
tc_lpats :: [Scaled ExpSigmaType]
-> Checker [LPat GhcRn] [LPat GhcTc]
tc_lpats tys penv pats
@@ -348,6 +363,14 @@ tc_lpats tys penv pats
penv
(zipEqual "tc_lpats" pats tys)
+tc_lmatchpats :: [Scaled Type]
+ -> Checker [LMatchPat GhcRn] [LMatchPat GhcTc]
+tc_lmatchpats tys penv pats
+ = assertPpr (equalLength pats tys) (ppr pats $$ ppr tys) $
+ tcMultiple (\ penv' (p,t) -> tc_lmatchpat t penv' p)
+ penv
+ (zipEqual "tc_lampats" pats tys)
+
--------------------
-- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
checkManyPattern :: Scaled a -> TcM HsWrapper
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index 1ce9ef8f82..e5e9ffc35c 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -924,7 +924,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel
[] unit_rhs]
| otherwise = map mk_match cons_w_field ++ deflt
mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname)
- [L loc' (mk_sel_pat con)]
+ [L noSrcSpanA (VisPat noExtField (L loc' (mk_sel_pat con)))]
(L loc' (HsVar noExtField (L locn field_var)))
mk_sel_pat con = ConPat NoExtField (L locn (getName con)) (RecCon rec_fields)
rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
@@ -944,7 +944,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel
-- mentions this particular record selector
deflt | all dealt_with all_cons = []
| otherwise = [mkSimpleMatch CaseAlt
- [L loc' (WildPat noExtField)]
+ [L noSrcSpanA (VisPat noExtField (L loc' (WildPat noExtField)))]
(mkHsApp (L loc' (HsVar noExtField
(L locn (getName rEC_SEL_ERROR_ID))))
(L loc' (HsLit noComments msg_lit)))]
diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs
index a0b8106a8d..fc98de6ef4 100644
--- a/compiler/GHC/Tc/Utils/Unify.hs
+++ b/compiler/GHC/Tc/Utils/Unify.hs
@@ -45,7 +45,6 @@ import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr( debugPprType )
import GHC.Tc.Utils.Concrete ( mkWpFun )
import GHC.Tc.Utils.Env
-import GHC.Tc.Utils.Instantiate
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.TcType
@@ -59,9 +58,11 @@ import GHC.Tc.Types.Evidence
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Origin
import GHC.Types.Name( isSystemName )
-
+import GHC.Types.Id
+import GHC.Tc.Utils.Instantiate
import GHC.Core.TyCon
import GHC.Builtin.Types
+import GHC.Types.SrcLoc
import GHC.Types.Var as Var
import GHC.Types.Var.Set
import GHC.Types.Var.Env
@@ -75,9 +76,9 @@ import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Exts ( inline )
-import Control.Monad
import Control.Arrow ( second )
import qualified Data.Semigroup as S ( (<>) )
+import GHC.Data.FastString
{- *********************************************************************
* *
@@ -287,49 +288,52 @@ passed in.
matchExpectedFunTys :: forall a.
SDoc -- See Note [Herald for matchExpectedFunTys]
-> UserTypeCtxt
- -> Arity
- -> ExpRhoType -- Skolemised
- -> ([Scaled ExpSigmaType] -> ExpRhoType -> TcM a)
+ -> [LMatchPat GhcRn]
+ -> ExpSigmaType
+ -> ([Var] -> ExpSigmaType -> TcM a)
-> TcM (HsWrapper, a)
-- If matchExpectedFunTys n ty = (_, wrap)
-- then wrap : (t1 -> ... -> tn -> ty_r) ~> ty,
-- where [t1, ..., tn], ty_r are passed to the thing_inside
-matchExpectedFunTys herald ctx arity orig_ty thing_inside
+matchExpectedFunTys herald ctx lmatchpats orig_ty thing_inside
= case orig_ty of
- Check ty -> go [] arity ty
- _ -> defer [] arity orig_ty
+ Check ty -> go [] lmatchpats ty
+ _ -> defer [] lmatchpats orig_ty
where
- -- Skolemise any foralls /before/ the zero-arg case
- -- so that we guarantee to return a rho-type
- go acc_arg_tys n ty
+ go vars pats ty
| (tvs, theta, _) <- tcSplitSigmaTy ty
, not (null tvs && null theta)
= do { (wrap_gen, (wrap_res, result)) <- tcSkolemise ctx ty $ \ty' ->
- go acc_arg_tys n ty'
+ go vars pats ty'
+ ; return (wrap_gen <.> wrap_res, result) }
+
+ go vars (L _ (InvisTyVarPat _ (L _ _)): pats) (ForAllTy (Bndr var _) ty')
+ = do { (wrap_res, result) <- go (var : vars) pats ty'
+ ; let wrap_gen = WpTyLam var
; return (wrap_gen <.> wrap_res, result) }
-- No more args; do this /before/ tcView, so
-- that we do not unnecessarily unwrap synonyms
- go acc_arg_tys 0 rho_ty
- = do { result <- thing_inside (reverse acc_arg_tys) (mkCheckExpType rho_ty)
+ go vars [] ty
+ = do { result <- thing_inside (reverse vars) (mkCheckExpType ty)
; return (idHsWrapper, result) }
- go acc_arg_tys n ty
- | Just ty' <- tcView ty = go acc_arg_tys n ty'
+ go vars pats ty
+ | Just ty' <- tcView ty = go vars pats ty'
- go acc_arg_tys n (FunTy { ft_mult = mult, ft_af = af, ft_arg = arg_ty, ft_res = res_ty })
- = assert (af == VisArg) $
- do { (wrap_res, result) <- go ((Scaled mult $ mkCheckExpType arg_ty) : acc_arg_tys)
- (n-1) res_ty
+ go vars (L _ (VisPat _ _):pats) (FunTy { ft_mult = mult, ft_af = VisArg, ft_arg = arg_ty, ft_res = res_ty })
+ = do { name <- newMetaTyVarName (fsLit "arg")
+ ; let var = mkLocalId name mult arg_ty
+ ; (wrap_res, result) <- go (var : vars) pats res_ty
; fun_wrap <- mkWpFun idHsWrapper wrap_res (Scaled mult arg_ty) res_ty (WpFunFunExpTy orig_ty)
; return ( fun_wrap, result ) }
- go acc_arg_tys n ty@(TyVarTy tv)
+ go vars pats ty@(TyVarTy tv)
| isMetaTyVar tv
= do { cts <- readMetaTyVar tv
; case cts of
- Indirect ty' -> go acc_arg_tys n ty'
- Flexi -> defer acc_arg_tys n (mkCheckExpType ty) }
+ Indirect ty' -> go vars pats ty'
+ Flexi -> defer vars pats (mkCheckExpType ty) }
-- In all other cases we bale out into ordinary unification
-- However unlike the meta-tyvar case, we are sure that the
@@ -346,31 +350,79 @@ matchExpectedFunTys herald ctx arity orig_ty thing_inside
--
-- But in that case we add specialized type into error context
-- anyway, because it may be useful. See also #9605.
- go acc_arg_tys n ty = addErrCtxtM (mk_ctxt acc_arg_tys ty) $
- defer acc_arg_tys n (mkCheckExpType ty)
+ go acc_arg_tys vars ty = addErrCtxtM (mk_ctxt acc_arg_tys ty) $
+ defer acc_arg_tys vars (mkCheckExpType ty)
------------
- defer :: [Scaled ExpSigmaType] -> Arity -> ExpRhoType -> TcM (HsWrapper, a)
- defer acc_arg_tys n fun_ty
- = do { more_arg_tys <- replicateM n (mkScaled <$> newFlexiTyVarTy multiplicityTy <*> newInferExpType)
- ; res_ty <- newInferExpType
- ; result <- thing_inside (reverse acc_arg_tys ++ more_arg_tys) res_ty
- ; more_arg_tys <- mapM (\(Scaled m t) -> Scaled m <$> readExpType t) more_arg_tys
- ; res_ty <- readExpType res_ty
- ; let unif_fun_ty = mkVisFunTys more_arg_tys res_ty
+
+ defer :: [Var] -> [LMatchPat GhcRn] -> ExpSigmaType -> TcM (HsWrapper, a)
+ defer vars pats fun_ty
+ = do { arg_binds <- sequenceA (lmatch_pats_to_bndrs <$> pats)
+ ; res_ty <- newInferExpType
+ ; more_vars <- sequenceA (lampat_to_var <$> pats)
+ ; result <- thing_inside (reverse vars ++ more_vars) res_ty
+ ; res_ty <- expTypeToType res_ty
+ ; let unif_fun_ty = mkPiTys arg_binds res_ty
; wrap <- tcSubType AppOrigin ctx unif_fun_ty fun_ty
-- Not a good origin at all :-(
; return (wrap, result) }
+ lampat_to_var (L _ (VisPat _ _)) =
+ do { name <- newMetaTyVarName (fsLit "arg")
+ ; ty <- newInferExpType >>= expTypeToType
+ ; return $ mkLocalId name Many ty
+ }
+ lampat_to_var _ = newOpenFlexiTyVar
+
------------
- mk_ctxt :: [Scaled ExpSigmaType] -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
- mk_ctxt arg_tys res_ty env
- = mkFunTysMsg env herald arg_tys' res_ty arity
- where
- arg_tys' = map (\(Scaled u v) -> Scaled u (checkingExpType "matchExpectedFunTys" v)) $
- reverse arg_tys
+ mk_ctxt :: [Var] -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
+ mk_ctxt vars res_ty env
+ = mkPiTysMsg env herald vars res_ty lmatchpats
-- this is safe b/c we're called from "go"
+ lmatch_pats_to_bndrs :: LMatchPat GhcRn -> TcM TyCoBinder
+ lmatch_pats_to_bndrs (L _ (VisPat _ _))
+ = do { fresh <- newInferExpType
+ ; ty' <- mkScaled <$> newFlexiTyVarTy multiplicityTy <*> (expTypeToType fresh)
+ ; return $ Anon VisArg ty' }
+ lmatch_pats_to_bndrs (L _ (InvisTyVarPat _ _))
+ = do { var <- newOpenFlexiTyVar
+ ; return $ Named (Bndr var Specified) }
+ lmatch_pats_to_bndrs (L _ (InvisWildTyPat _))
+ = do { var <- newOpenFlexiTyVar
+ ; return $ Named (Bndr var Inferred) }
+
+mkPiTysMsg :: TidyEnv -> SDoc -> [Var] -> TcType -> [LMatchPat GhcRn]
+ -> TcM (TidyEnv, SDoc)
+mkPiTysMsg env herald vars res_ty lmatchpats
+ = do { let arg_binds = to_arg_bind <$> (zip vars lmatchpats)
+ ; let fun = mkPiTys arg_binds res_ty
+ ; (env', fun_ty) <- zonkTidyTcType env fun
+ ; let (all_arg_tys, _) = splitFunTys fun_ty
+ n_fun_args = length all_arg_tys
+ all_lpats = length (toLPats lmatchpats)
+
+ (all_forall_args, _) = splitForAllTyVars fun_ty
+ n_forall_args = length all_forall_args
+ all_invis_pats = length (toInvisPats lmatchpats)
+
+ full_herald = herald <+> speakNOf all_lpats (text "value argument")
+
+ msg | all_invis_pats <= n_forall_args && all_lpats <= n_fun_args -- Enough args, in the end
+ = text "In the result of a function call"
+ | otherwise
+ = hang (full_herald <> comma)
+ 2 (sep [ text "but its type" <+> quotes (pprType fun_ty)
+ , if n_fun_args == 0 then text "has none"
+ else text "has only" <+> speakN n_fun_args])
+
+ ; return (env', msg) }
+ where
+ to_arg_bind :: (Var, LMatchPat GhcRn) -> TyCoBinder
+ to_arg_bind (var, (L _ (VisPat _ _))) = Anon VisArg (Scaled (varMult var) (varType var))
+ to_arg_bind (var, (L _ (InvisTyVarPat _ _))) = Named (Bndr var Specified)
+ to_arg_bind (var, (L _ (InvisWildTyPat _))) = Named (Bndr var Inferred)
+
mkFunTysMsg :: TidyEnv -> SDoc -> [Scaled TcType] -> TcType -> Arity
-> TcM (TidyEnv, SDoc)
mkFunTysMsg env herald arg_tys res_ty n_val_args_in_call
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index fec8d90d5d..1bff9ce013 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -694,7 +694,7 @@ zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns
-> TcM (LMatch GhcTc (LocatedA (body GhcTc)))
zonkMatch env zBody (L loc match@(Match { m_pats = pats
, m_grhss = grhss }))
- = do { (env1, new_pats) <- zonkPats env pats
+ = do { (env1, new_pats) <- zonkLMatchPats env pats
; new_grhss <- zonkGRHSs env1 zBody grhss
; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) }
@@ -1338,6 +1338,15 @@ zonkPat :: ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc)
-- to the right)
zonkPat env pat = wrapLocSndMA (zonk_pat env) pat
+zonkLMatchPat :: ZonkEnv -> LMatchPat GhcTc -> TcM (ZonkEnv, LMatchPat GhcTc)
+zonkLMatchPat env (L l (VisPat x pat))
+ = do { (env', p') <- zonkPat env pat
+ ; return (env', L l (VisPat x p'))}
+zonkLMatchPat env (L l (InvisTyVarPat t (L l' idp)))
+ = do { (env', (L _ idp')) <- wrapLocSndM (zonkTyBndrX env) (L noSrcSpan idp)
+ ; return (env', L l (InvisTyVarPat t (L l' idp')))}
+zonkLMatchPat env p = return (env, p)
+
zonk_pat :: ZonkEnv -> Pat GhcTc -> TcM (ZonkEnv, Pat GhcTc)
zonk_pat env (ParPat x lpar p rpar)
= do { (env', p') <- zonkPat env p
@@ -1484,6 +1493,12 @@ zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
; (env', pats') <- zonkPats env1 pats
; return (env', pat':pats') }
+zonkLMatchPats :: ZonkEnv -> [LMatchPat GhcTc] -> TcM (ZonkEnv, [LMatchPat GhcTc])
+zonkLMatchPats env [] = return (env, [])
+zonkLMatchPats env (pat:pats) = do { (env1, pat') <- zonkLMatchPat env pat
+ ; (env', pats') <- zonkLMatchPats env1 pats
+ ; return (env', pat':pats') }
+
{-
************************************************************************
* *
diff --git a/utils/haddock b/utils/haddock
-Subproject 1ef24e617651955f07c4fb6f2d488806cc6785e
+Subproject d8b79d35ddd96c83f4a3a0303011defc209aa31
View Lorry Controller Status