[Git][ghc/ghc][master] 6 commits: Use `Checker` for `tc_pat`
Marge Bot
gitlab at gitlab.haskell.org
Thu May 21 16:17:41 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
964d3ea2 by John Ericson at 2020-05-21T12:17:30-04:00
Use `Checker` for `tc_pat`
- - - - -
b797aa42 by John Ericson at 2020-05-21T12:17:30-04:00
Use `Checker` for `tc_lpat` and `tc_lpats`
- - - - -
5108e84a by John Ericson at 2020-05-21T12:17:30-04:00
More judiciously panic in `ts_pat`
- - - - -
510e0451 by John Ericson at 2020-05-21T12:17:30-04:00
Put `PatEnv` first in `GHC.Tc.Gen.Pat.Checker`
- - - - -
cb4231db by John Ericson at 2020-05-21T12:17:30-04:00
Tiny cleaup eta-reduce away a function argument
In GHC, not in the code being compiled!
- - - - -
6890c38d by John Ericson at 2020-05-21T12:17:30-04:00
Use braces with do in `SplicePat` case for consistency
- - - - -
1 changed file:
- compiler/GHC/Tc/Gen/Pat.hs
Changes:
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -4,8 +4,10 @@
-}
-{-# LANGUAGE CPP, RankNTypes, TupleSections #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
@@ -87,7 +89,7 @@ tcLetPat sig_fn no_gen pat pat_ty thing_inside
, pe_ctxt = ctxt
, pe_orig = PatOrigin }
- ; tc_lpat pat pat_ty penv thing_inside }
+ ; tc_lpat pat_ty penv pat thing_inside }
-----------------
tcPats :: HsMatchContext GhcRn
@@ -108,7 +110,7 @@ tcPats :: HsMatchContext GhcRn
-- 4. Check that no existentials escape
tcPats ctxt pats pat_tys thing_inside
- = tc_lpats penv pats pat_tys thing_inside
+ = tc_lpats pat_tys penv pats thing_inside
where
penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }
@@ -117,7 +119,7 @@ tcInferPat :: HsMatchContext GhcRn -> LPat GhcRn
-> TcM ((LPat GhcTcId, a), TcSigmaType)
tcInferPat ctxt pat thing_inside
= tcInfer $ \ exp_ty ->
- tc_lpat pat exp_ty penv thing_inside
+ tc_lpat exp_ty penv pat thing_inside
where
penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }
@@ -134,7 +136,7 @@ tcCheckPat_O :: HsMatchContext GhcRn
-> TcM a -- Checker for body
-> TcM (LPat GhcTcId, a)
tcCheckPat_O ctxt orig pat pat_ty thing_inside
- = tc_lpat pat (mkCheckExpType pat_ty) penv thing_inside
+ = tc_lpat (mkCheckExpType pat_ty) penv pat thing_inside
where
penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = orig }
@@ -291,14 +293,17 @@ Hence the getErrCtxt/setErrCtxt stuff in tcMultiple
-}
--------------------
+
type Checker inp out = forall r.
- inp
- -> PatEnv
- -> TcM r
- -> TcM (out, r)
+ PatEnv
+ -> inp
+ -> TcM r -- Thing inside
+ -> TcM ( out
+ , r -- Result of thing inside
+ )
tcMultiple :: Checker inp out -> Checker [inp] [out]
-tcMultiple tc_pat args penv thing_inside
+tcMultiple tc_pat penv args thing_inside
= do { err_ctxt <- getErrCtxt
; let loop _ []
= do { res <- thing_inside
@@ -306,7 +311,7 @@ tcMultiple tc_pat args penv thing_inside
loop penv (arg:args)
= do { (p', (ps', res))
- <- tc_pat arg penv $
+ <- tc_pat penv arg $
setErrCtxt err_ctxt $
loop penv args
-- setErrCtxt: restore context before doing the next pattern
@@ -317,52 +322,46 @@ tcMultiple tc_pat args penv thing_inside
; loop penv args }
--------------------
-tc_lpat :: LPat GhcRn
- -> ExpSigmaType
- -> PatEnv
- -> TcM a
- -> TcM (LPat GhcTcId, a)
-tc_lpat (L span pat) pat_ty penv thing_inside
+tc_lpat :: ExpSigmaType
+ -> Checker (LPat GhcRn) (LPat GhcTcId)
+tc_lpat pat_ty penv (L span pat) thing_inside
= setSrcSpan span $
- do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty)
+ do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat pat_ty penv pat)
thing_inside
; return (L span pat', res) }
-tc_lpats :: PatEnv
- -> [LPat GhcRn] -> [ExpSigmaType]
- -> TcM a
- -> TcM ([LPat GhcTcId], a)
-tc_lpats penv pats tys thing_inside
+tc_lpats :: [ExpSigmaType]
+ -> Checker [LPat GhcRn] [LPat GhcTcId]
+tc_lpats tys penv pats
= ASSERT2( equalLength pats tys, ppr pats $$ ppr tys )
- tcMultiple (\(p,t) -> tc_lpat p t)
- (zipEqual "tc_lpats" pats tys)
- penv thing_inside
+ tcMultiple (\ penv' (p,t) -> tc_lpat t penv' p)
+ penv
+ (zipEqual "tc_lpats" pats tys)
--------------------
-tc_pat :: PatEnv
- -> Pat GhcRn
- -> ExpSigmaType -- Fully refined result type
- -> TcM a -- Thing inside
- -> TcM (Pat GhcTcId, -- Translated pattern
- a) -- Result of thing inside
-
-tc_pat penv (VarPat x (L l name)) pat_ty thing_inside
- = do { (wrap, id) <- tcPatBndr penv name pat_ty
+tc_pat :: ExpSigmaType
+ -- ^ Fully refined result type
+ -> Checker (Pat GhcRn) (Pat GhcTcId)
+ -- ^ Translated pattern
+tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
+
+ VarPat x (L l name) -> do
+ { (wrap, id) <- tcPatBndr penv name pat_ty
; res <- tcExtendIdEnv1 name id thing_inside
; pat_ty <- readExpType pat_ty
; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) }
-tc_pat penv (ParPat x pat) pat_ty thing_inside
- = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside
+ ParPat x pat -> do
+ { (pat', res) <- tc_lpat pat_ty penv pat thing_inside
; return (ParPat x pat', res) }
-tc_pat penv (BangPat x pat) pat_ty thing_inside
- = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside
+ BangPat x pat -> do
+ { (pat', res) <- tc_lpat pat_ty penv pat thing_inside
; return (BangPat x pat', res) }
-tc_pat penv (LazyPat x pat) pat_ty thing_inside
- = do { (pat', (res, pat_ct))
- <- tc_lpat pat pat_ty (makeLazy penv) $
+ LazyPat x pat -> do
+ { (pat', (res, pat_ct))
+ <- tc_lpat pat_ty (makeLazy penv) pat $
captureConstraints thing_inside
-- Ignore refined penv', revert to penv
@@ -376,16 +375,16 @@ tc_pat penv (LazyPat x pat) pat_ty thing_inside
; return (LazyPat x pat', res) }
-tc_pat _ (WildPat _) pat_ty thing_inside
- = do { res <- thing_inside
+ WildPat _ -> do
+ { res <- thing_inside
; pat_ty <- expTypeToType pat_ty
; return (WildPat pat_ty, res) }
-tc_pat penv (AsPat x (L nm_loc name) pat) pat_ty thing_inside
- = do { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty)
+ AsPat x (L nm_loc name) pat -> do
+ { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty)
; (pat', res) <- tcExtendIdEnv1 name bndr_id $
- tc_lpat pat (mkCheckExpType $ idType bndr_id)
- penv thing_inside
+ tc_lpat (mkCheckExpType $ idType bndr_id)
+ penv pat thing_inside
-- NB: if we do inference on:
-- \ (y@(x::forall a. a->a)) = e
-- we'll fail. The as-pattern infers a monotype for 'y', which then
@@ -397,8 +396,8 @@ tc_pat penv (AsPat x (L nm_loc name) pat) pat_ty thing_inside
; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty,
res) }
-tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside
- = do {
+ ViewPat _ expr pat -> do
+ {
-- We use tcInferRho here.
-- If we have a view function with types like:
-- blah -> forall b. burble
@@ -420,25 +419,25 @@ tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside
-- expr_wrap1 :: expr_ty "->" (inf_arg_ty -> inf_res_ty)
-- Check that overall pattern is more polymorphic than arg type
- ; expr_wrap2 <- tc_sub_type penv overall_pat_ty inf_arg_ty
- -- expr_wrap2 :: overall_pat_ty "->" inf_arg_ty
+ ; expr_wrap2 <- tc_sub_type penv pat_ty inf_arg_ty
+ -- expr_wrap2 :: pat_ty "->" inf_arg_ty
-- Pattern must have inf_res_ty
- ; (pat', res) <- tc_lpat pat (mkCheckExpType inf_res_ty) penv thing_inside
+ ; (pat', res) <- tc_lpat (mkCheckExpType inf_res_ty) penv pat thing_inside
- ; overall_pat_ty <- readExpType overall_pat_ty
+ ; pat_ty <- readExpType pat_ty
; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper
- overall_pat_ty inf_res_ty doc
+ pat_ty inf_res_ty doc
-- expr_wrap2' :: (inf_arg_ty -> inf_res_ty) "->"
- -- (overall_pat_ty -> inf_res_ty)
+ -- (pat_ty -> inf_res_ty)
expr_wrap = expr_wrap2' <.> expr_wrap1
doc = text "When checking the view pattern function:" <+> (ppr expr)
- ; return (ViewPat overall_pat_ty (mkLHsWrap expr_wrap expr') pat', res)}
+ ; return (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res)}
-- Type signatures in patterns
-- See Note [Pattern coercions] below
-tc_pat penv (SigPat _ pat sig_ty) pat_ty thing_inside
- = do { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv)
+ SigPat _ pat sig_ty -> do
+ { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv)
sig_ty pat_ty
-- Using tcExtendNameTyVarEnv is appropriate here
-- because we're not really bringing fresh tyvars into scope.
@@ -446,35 +445,35 @@ tc_pat penv (SigPat _ pat sig_ty) pat_ty thing_inside
-- from an outer scope to mention one of these tyvars in its kind.
; (pat', res) <- tcExtendNameTyVarEnv wcs $
tcExtendNameTyVarEnv tv_binds $
- tc_lpat pat (mkCheckExpType inner_ty) penv thing_inside
+ tc_lpat (mkCheckExpType inner_ty) penv pat thing_inside
; pat_ty <- readExpType pat_ty
; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) }
------------------------
-- Lists, tuples, arrays
-tc_pat penv (ListPat Nothing pats) pat_ty thing_inside
- = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty
- ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty))
- pats penv thing_inside
+ ListPat Nothing pats -> do
+ { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty
+ ; (pats', res) <- tcMultiple (tc_lpat $ mkCheckExpType elt_ty)
+ penv pats thing_inside
; pat_ty <- readExpType pat_ty
; return (mkHsWrapPat coi
(ListPat (ListPatTc elt_ty Nothing) pats') pat_ty, res)
}
-tc_pat penv (ListPat (Just e) pats) pat_ty thing_inside
- = do { tau_pat_ty <- expTypeToType pat_ty
+ ListPat (Just e) pats -> do
+ { tau_pat_ty <- expTypeToType pat_ty
; ((pats', res, elt_ty), e')
<- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)]
SynList $
\ [elt_ty] ->
- do { (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty))
- pats penv thing_inside
+ do { (pats', res) <- tcMultiple (tc_lpat $ mkCheckExpType elt_ty)
+ penv pats thing_inside
; return (pats', res, elt_ty) }
; return (ListPat (ListPatTc elt_ty (Just (tau_pat_ty,e'))) pats', res)
}
-tc_pat penv (TuplePat _ pats boxity) pat_ty thing_inside
- = do { let arity = length pats
+ TuplePat _ pats boxity -> do
+ { let arity = length pats
tc = tupleTyCon boxity arity
-- NB: tupleTyCon does not flatten 1-tuples
-- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
@@ -484,8 +483,8 @@ tc_pat penv (TuplePat _ pats boxity) pat_ty thing_inside
-- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys
Boxed -> arg_tys
- ; (pats', res) <- tc_lpats penv pats (map mkCheckExpType con_arg_tys)
- thing_inside
+ ; (pats', res) <- tc_lpats (map mkCheckExpType con_arg_tys)
+ penv pats thing_inside
; dflags <- getDynFlags
@@ -506,14 +505,14 @@ tc_pat penv (TuplePat _ pats boxity) pat_ty thing_inside
return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)
}
-tc_pat penv (SumPat _ pat alt arity ) pat_ty thing_inside
- = do { let tc = sumTyCon arity
+ SumPat _ pat alt arity -> do
+ { let tc = sumTyCon arity
; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
penv pat_ty
; -- Drop levity vars, we don't care about them here
let con_arg_tys = drop arity arg_tys
- ; (pat', res) <- tc_lpat pat (mkCheckExpType (con_arg_tys `getNth` (alt - 1)))
- penv thing_inside
+ ; (pat', res) <- tc_lpat (mkCheckExpType (con_arg_tys `getNth` (alt - 1)))
+ penv pat thing_inside
; pat_ty <- readExpType pat_ty
; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty
, res)
@@ -521,13 +520,13 @@ tc_pat penv (SumPat _ pat alt arity ) pat_ty thing_inside
------------------------
-- Data constructors
-tc_pat penv (ConPat NoExtField con arg_pats) pat_ty thing_inside
- = tcConPat penv con pat_ty arg_pats thing_inside
+ ConPat NoExtField con arg_pats ->
+ tcConPat penv con pat_ty arg_pats thing_inside
------------------------
-- Literal patterns
-tc_pat penv (LitPat x simple_lit) pat_ty thing_inside
- = do { let lit_ty = hsLitType simple_lit
+ LitPat x simple_lit -> do
+ { let lit_ty = hsLitType simple_lit
; wrap <- tc_sub_type penv pat_ty lit_ty
; res <- thing_inside
; pat_ty <- readExpType pat_ty
@@ -552,8 +551,8 @@ tc_pat penv (LitPat x simple_lit) pat_ty thing_inside
-- where lit_ty is the type of the overloaded literal 5.
--
-- When there is no negation, neg_lit_ty and lit_ty are the same
-tc_pat _ (NPat _ (L l over_lit) mb_neg eq) pat_ty thing_inside
- = do { let orig = LiteralOrigin over_lit
+ NPat _ (L l over_lit) mb_neg eq -> do
+ { let orig = LiteralOrigin over_lit
; ((lit', mb_neg'), eq')
<- tcSyntaxOp orig eq [SynType pat_ty, SynAny]
(mkCheckExpType boolTy) $
@@ -601,10 +600,9 @@ AST is used for the subtraction operation.
-}
-- See Note [NPlusK patterns]
-tc_pat penv (NPlusKPat _ (L nm_loc name)
- (L loc lit) _ ge minus) pat_ty
- thing_inside
- = do { pat_ty <- expTypeToType pat_ty
+ NPlusKPat _ (L nm_loc name)
+ (L loc lit) _ ge minus -> do
+ { pat_ty <- expTypeToType pat_ty
; let orig = LiteralOrigin lit
; (lit1', ge')
<- tcSyntaxOp orig ge [synKnownType pat_ty, SynRho]
@@ -650,12 +648,11 @@ tc_pat penv (NPlusKPat _ (L nm_loc name)
-- Here we get rid of it and add the finalizers to the global environment.
--
-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.
-tc_pat penv (SplicePat _ (HsSpliced _ mod_finalizers (HsSplicedPat pat)))
- pat_ty thing_inside
- = do addModFinalizersWithLclEnv mod_finalizers
- tc_pat penv pat pat_ty thing_inside
-
-tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut
+ SplicePat _ splice -> case splice of
+ (HsSpliced _ mod_finalizers (HsSplicedPat pat)) -> do
+ { addModFinalizersWithLclEnv mod_finalizers
+ ; tc_pat pat_ty penv pat thing_inside }
+ _ -> panic "invalid splice in splice pat"
{-
@@ -871,7 +868,7 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty
then do { -- The common case; no class bindings etc
-- (see Note [Arrows and patterns])
(arg_pats', res) <- tcConArgs (RealDataCon data_con) arg_tys'
- arg_pats penv thing_inside
+ penv arg_pats thing_inside
; let res_pat = ConPat { pat_con = header
, pat_args = arg_pats'
, pat_con_ext = ConPatTc
@@ -907,7 +904,7 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty
; given <- newEvVars theta'
; (ev_binds, (arg_pats', res))
<- checkConstraints skol_info ex_tvs' given $
- tcConArgs (RealDataCon data_con) arg_tys' arg_pats penv thing_inside
+ tcConArgs (RealDataCon data_con) arg_tys' penv arg_pats thing_inside
; let res_pat = ConPat
{ pat_con = header
@@ -961,7 +958,7 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside
; traceTc "checkConstraints {" Outputable.empty
; (ev_binds, (arg_pats', res))
<- checkConstraints skol_info ex_tvs' prov_dicts' $
- tcConArgs (PatSynCon pat_syn) arg_tys' arg_pats penv thing_inside
+ tcConArgs (PatSynCon pat_syn) arg_tys' penv arg_pats thing_inside
; traceTc "checkConstraints }" (ppr ev_binds)
; let res_pat = ConPat { pat_con = L con_span $ PatSynCon pat_syn
@@ -1070,46 +1067,48 @@ Suppose (coi, tys) = matchExpectedConType data_tc pat_ty
tcConArgs :: ConLike -> [TcSigmaType]
-> Checker (HsConPatDetails GhcRn) (HsConPatDetails GhcTc)
-tcConArgs con_like arg_tys (PrefixCon arg_pats) penv thing_inside
- = do { checkTc (con_arity == no_of_args) -- Check correct arity
+tcConArgs con_like arg_tys penv con_args thing_inside = case con_args of
+ PrefixCon arg_pats -> do
+ { checkTc (con_arity == no_of_args) -- Check correct arity
(arityErr (text "constructor") con_like con_arity no_of_args)
; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys
- ; (arg_pats', res) <- tcMultiple tcConArg pats_w_tys
- penv thing_inside
+ ; (arg_pats', res) <- tcMultiple tcConArg penv pats_w_tys
+ thing_inside
; return (PrefixCon arg_pats', res) }
- where
- con_arity = conLikeArity con_like
- no_of_args = length arg_pats
+ where
+ con_arity = conLikeArity con_like
+ no_of_args = length arg_pats
-tcConArgs con_like arg_tys (InfixCon p1 p2) penv thing_inside
- = do { checkTc (con_arity == 2) -- Check correct arity
+ InfixCon p1 p2 -> do
+ { checkTc (con_arity == 2) -- Check correct arity
(arityErr (text "constructor") con_like con_arity 2)
; let [arg_ty1,arg_ty2] = arg_tys -- This can't fail after the arity check
- ; ([p1',p2'], res) <- tcMultiple tcConArg [(p1,arg_ty1),(p2,arg_ty2)]
- penv thing_inside
+ ; ([p1',p2'], res) <- tcMultiple tcConArg penv [(p1,arg_ty1),(p2,arg_ty2)]
+ thing_inside
; return (InfixCon p1' p2', res) }
- where
- con_arity = conLikeArity con_like
+ where
+ con_arity = conLikeArity con_like
-tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside
- = do { (rpats', res) <- tcMultiple tc_field rpats penv thing_inside
+ RecCon (HsRecFields rpats dd) -> do
+ { (rpats', res) <- tcMultiple tc_field penv rpats thing_inside
; return (RecCon (HsRecFields rpats' dd), res) }
- where
- tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn))
- (LHsRecField GhcTcId (LPat GhcTcId))
- tc_field (L l (HsRecField (L loc (FieldOcc sel (L lr rdr))) pat pun))
- penv thing_inside
- = do { sel' <- tcLookupId sel
- ; pat_ty <- setSrcSpan loc $ find_field_ty sel
- (occNameFS $ rdrNameOcc rdr)
- ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside
- ; return (L l (HsRecField (L loc (FieldOcc sel' (L lr rdr))) pat'
- pun), res) }
-
-
- find_field_ty :: Name -> FieldLabelString -> TcM TcType
- find_field_ty sel lbl
- = case [ty | (fl, ty) <- field_tys, flSelector fl == sel] of
+ where
+ tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn))
+ (LHsRecField GhcTcId (LPat GhcTcId))
+ tc_field penv
+ (L l (HsRecField (L loc (FieldOcc sel (L lr rdr))) pat pun))
+ thing_inside
+ = do { sel' <- tcLookupId sel
+ ; pat_ty <- setSrcSpan loc $ find_field_ty sel
+ (occNameFS $ rdrNameOcc rdr)
+ ; (pat', res) <- tcConArg penv (pat, pat_ty) thing_inside
+ ; return (L l (HsRecField (L loc (FieldOcc sel' (L lr rdr))) pat'
+ pun), res) }
+
+
+ find_field_ty :: Name -> FieldLabelString -> TcM TcType
+ find_field_ty sel lbl
+ = case [ty | (fl, ty) <- field_tys, flSelector fl == sel ] of
-- No matching field; chances are this field label comes from some
-- other record type (or maybe none). If this happens, just fail,
@@ -1124,15 +1123,14 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside
traceTc "find_field" (ppr pat_ty <+> ppr extras)
ASSERT( null extras ) (return pat_ty)
- field_tys :: [(FieldLabel, TcType)]
- field_tys = zip (conLikeFieldLabels con_like) arg_tys
+ field_tys :: [(FieldLabel, TcType)]
+ field_tys = zip (conLikeFieldLabels con_like) arg_tys
-- Don't use zipEqual! If the constructor isn't really a record, then
-- dataConFieldLabels will be empty (and each field in the pattern
-- will generate an error below).
tcConArg :: Checker (LPat GhcRn, TcSigmaType) (LPat GhcTc)
-tcConArg (arg_pat, arg_ty) penv thing_inside
- = tc_lpat arg_pat (mkCheckExpType arg_ty) penv thing_inside
+tcConArg penv (arg_pat, arg_ty) = tc_lpat (mkCheckExpType arg_ty) penv arg_pat
addDataConStupidTheta :: DataCon -> [TcType] -> TcM ()
-- Instantiate the "stupid theta" of the data con, and throw
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0004ccb885e534c386ceae21580fc59ec7ad0ede...6890c38d4568ca444cccc47dd1a86c5e020c3521
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0004ccb885e534c386ceae21580fc59ec7ad0ede...6890c38d4568ca444cccc47dd1a86c5e020c3521
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200521/51c7d632/attachment-0001.html>
More information about the ghc-commits
mailing list