summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Tc')
-rw-r--r--compiler/GHC/Tc/Deriv/Generate.hs10
-rw-r--r--compiler/GHC/Tc/Gen/Arrow.hs4
-rw-r--r--compiler/GHC/Tc/Gen/Bind.hs4
-rw-r--r--compiler/GHC/Tc/Gen/Pat.hs52
-rw-r--r--compiler/GHC/Tc/TyCl.hs10
-rw-r--r--compiler/GHC/Tc/TyCl/PatSyn.hs9
-rw-r--r--compiler/GHC/Tc/TyCl/Utils.hs2
-rw-r--r--compiler/GHC/Tc/Utils/Zonk.hs59
-rw-r--r--compiler/GHC/Tc/Validity.hs16
9 files changed, 96 insertions, 70 deletions
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index 5156bb0aa1..ad103ca7c8 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -532,9 +532,13 @@ unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
nlConWildPat :: DataCon -> LPat GhcPs
-- The pattern (K {})
-nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))
- (RecCon (HsRecFields { rec_flds = []
- , rec_dotdot = Nothing })))
+nlConWildPat con = noLoc $ ConPat
+ { pat_con_ext = noExtField
+ , pat_con = noLoc $ getRdrName con
+ , pat_args = RecCon $ HsRecFields
+ { rec_flds = []
+ , rec_dotdot = Nothing }
+ }
{-
************************************************************************
diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs
index 94e90acd24..69c5e67197 100644
--- a/compiler/GHC/Tc/Gen/Arrow.hs
+++ b/compiler/GHC/Tc/Gen/Arrow.hs
@@ -81,9 +81,9 @@ Note that
************************************************************************
-}
-tcProc :: InPat GhcRn -> LHsCmdTop GhcRn -- proc pat -> expr
+tcProc :: LPat GhcRn -> LHsCmdTop GhcRn -- proc pat -> expr
-> ExpRhoType -- Expected type of whole proc expression
- -> TcM (OutPat GhcTcId, LHsCmdTop GhcTcId, TcCoercion)
+ -> TcM (LPat GhcTc, LHsCmdTop GhcTcId, TcCoercion)
tcProc pat cmd exp_ty
= newArrowScope $
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index a8a8d027f0..44fd594849 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -506,8 +506,8 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds
recursivePatSynErr ::
- OutputableBndrId p =>
- SrcSpan -- ^ The location of the first pattern synonym binding
+ (OutputableBndrId p, CollectPass (GhcPass p))
+ => SrcSpan -- ^ The location of the first pattern synonym binding
-- (for error reporting)
-> LHsBinds (GhcPass p)
-> TcM a
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index 2ae1f1cfb9..0456677cc7 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -521,7 +521,7 @@ tc_pat penv (SumPat _ pat alt arity ) pat_ty thing_inside
------------------------
-- Data constructors
-tc_pat penv (ConPatIn con arg_pats) pat_ty thing_inside
+tc_pat penv (ConPat NoExtField con arg_pats) pat_ty thing_inside
= tcConPat penv con pat_ty arg_pats thing_inside
------------------------
@@ -872,12 +872,15 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty
-- (see Note [Arrows and patterns])
(arg_pats', res) <- tcConArgs (RealDataCon data_con) arg_tys'
arg_pats penv thing_inside
- ; let res_pat = ConPatOut { pat_con = header,
- pat_tvs = [], pat_dicts = [],
- pat_binds = emptyTcEvBinds,
- pat_args = arg_pats',
- pat_arg_tys = ctxt_res_tys,
- pat_wrap = idHsWrapper }
+ ; let res_pat = ConPat { pat_con = header
+ , pat_args = arg_pats'
+ , pat_con_ext = ConPatTc
+ { cpt_tvs = [], cpt_dicts = []
+ , cpt_binds = emptyTcEvBinds
+ , cpt_arg_tys = ctxt_res_tys
+ , cpt_wrap = idHsWrapper
+ }
+ }
; return (mkHsWrapPat wrap res_pat pat_ty, res) }
@@ -906,13 +909,17 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty
<- checkConstraints skol_info ex_tvs' given $
tcConArgs (RealDataCon data_con) arg_tys' arg_pats penv thing_inside
- ; let res_pat = ConPatOut { pat_con = header,
- pat_tvs = ex_tvs',
- pat_dicts = given,
- pat_binds = ev_binds,
- pat_args = arg_pats',
- pat_arg_tys = ctxt_res_tys,
- pat_wrap = idHsWrapper }
+ ; let res_pat = ConPat
+ { pat_con = header
+ , pat_args = arg_pats'
+ , pat_con_ext = ConPatTc
+ { cpt_tvs = ex_tvs'
+ , cpt_dicts = given
+ , cpt_binds = ev_binds
+ , cpt_arg_tys = ctxt_res_tys
+ , cpt_wrap = idHsWrapper
+ }
+ }
; return (mkHsWrapPat wrap res_pat pat_ty, res)
} }
@@ -957,13 +964,16 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside
tcConArgs (PatSynCon pat_syn) arg_tys' arg_pats penv thing_inside
; traceTc "checkConstraints }" (ppr ev_binds)
- ; let res_pat = ConPatOut { pat_con = L con_span $ PatSynCon pat_syn,
- pat_tvs = ex_tvs',
- pat_dicts = prov_dicts',
- pat_binds = ev_binds,
- pat_args = arg_pats',
- pat_arg_tys = mkTyVarTys univ_tvs',
- pat_wrap = req_wrap }
+ ; let res_pat = ConPat { pat_con = L con_span $ PatSynCon pat_syn
+ , pat_args = arg_pats'
+ , pat_con_ext = ConPatTc
+ { cpt_tvs = ex_tvs'
+ , cpt_dicts = prov_dicts'
+ , cpt_binds = ev_binds
+ , cpt_arg_tys = mkTyVarTys univ_tvs'
+ , cpt_wrap = req_wrap
+ }
+ }
; pat_ty <- readExpType pat_ty
; return (mkHsWrapPat wrap res_pat pat_ty, res) }
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index 07d1453a5c..e69990cb63 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -2178,9 +2178,9 @@ tcDefaultAssocDecl fam_tc
, text "pats" <+> ppr pats
, text "rhs_ty" <+> ppr rhs_ty
])
- ; pat_tvs <- zipWithM (extract_tv ppr_eqn) pats pats_vis
- ; check_all_distinct_tvs ppr_eqn $ zip pat_tvs pats_vis
- ; let subst = zipTvSubst pat_tvs (mkTyVarTys fam_tvs)
+ ; cpt_tvs <- zipWithM (extract_tv ppr_eqn) pats pats_vis
+ ; check_all_distinct_tvs ppr_eqn $ zip cpt_tvs pats_vis
+ ; let subst = zipTvSubst cpt_tvs (mkTyVarTys fam_tvs)
; pure $ Just (substTyUnchecked subst rhs_ty, loc)
-- We also perform other checks for well-formedness and validity
-- later, in checkValidClass
@@ -2217,8 +2217,8 @@ tcDefaultAssocDecl fam_tc
-- visibilities (the latter are only used for error
-- message purposes)
-> TcM ()
- check_all_distinct_tvs ppr_eqn pat_tvs_vis =
- let dups = findDupsEq ((==) `on` fst) pat_tvs_vis in
+ check_all_distinct_tvs ppr_eqn cpt_tvs_vis =
+ let dups = findDupsEq ((==) `on` fst) cpt_tvs_vis in
traverse_
(\d -> let (pat_tv, pat_vis) = NE.head d in failWithTc $
pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 797ff2f594..37ba4e3329 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -940,7 +940,7 @@ tcPatToExpr name args pat = go pat
go (L loc p) = L loc <$> go1 p
go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn)
- go1 (ConPatIn con info)
+ go1 (ConPat NoExtField con info)
= case info of
PrefixCon ps -> mkPrefixConExpr con ps
InfixCon l r -> mkPrefixConExpr con [l,r]
@@ -973,8 +973,6 @@ tcPatToExpr name args pat = go pat
= return $ unLoc $ foldl' nlHsApp (noLoc neg)
[noLoc (HsOverLit noExtField n)]
| otherwise = return $ HsOverLit noExtField n
- go1 (ConPatOut{}) = panic "ConPatOut in output of renamer"
- go1 (CoPat{}) = panic "CoPat in output of renamer"
go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
= go1 pat
go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety"
@@ -1124,10 +1122,11 @@ tcCollectEx pat = go pat
go1 (TuplePat _ ps _) = mergeMany . map go $ ps
go1 (SumPat _ p _ _) = go p
go1 (ViewPat _ _ p) = go p
- go1 con@ConPatOut{} = merge (pat_tvs con, pat_dicts con) $
+ go1 con@ConPat{ pat_con_ext = con' }
+ = merge (cpt_tvs con', cpt_dicts con') $
goConDetails $ pat_args con
go1 (SigPat _ p _) = go p
- go1 (CoPat _ _ p _) = go1 p
+ go1 (XPat (CoPat _ p _)) = go1 p
go1 (NPlusKPat _ n k _ geq subtract)
= pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract
go1 _ = empty
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index d12e7efce4..5ee3620db1 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -895,7 +895,7 @@ mkOneRecordSelector all_cons idDetails fl
mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname)
[L loc (mk_sel_pat con)]
(L loc (HsVar noExtField (L loc field_var)))
- mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)
+ mk_sel_pat con = ConPat NoExtField (L loc (getName con)) (RecCon rec_fields)
rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
rec_field = noLoc (HsRecField
{ hsRecFieldLbl
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 00f11c09ae..09caf5fefa 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -114,14 +114,16 @@ hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty
hsPatType (TuplePat tys _ bx) = mkTupleTy1 bx tys
-- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
hsPatType (SumPat tys _ _ _ ) = mkSumTy tys
-hsPatType (ConPatOut { pat_con = lcon
- , pat_arg_tys = tys })
+hsPatType (ConPat { pat_con = lcon
+ , pat_con_ext = ConPatTc
+ { cpt_arg_tys = tys
+ }
+ })
= conLikeResTy (unLoc lcon) tys
hsPatType (SigPat ty _ _) = ty
hsPatType (NPat ty _ _ _) = ty
hsPatType (NPlusKPat ty _ _ _ _ _) = ty
-hsPatType (CoPat _ _ _ ty) = ty
-hsPatType ConPatIn{} = panic "hsPatType: ConPatIn"
+hsPatType (XPat (CoPat _ _ ty)) = ty
hsPatType SplicePat{} = panic "hsPatType: SplicePat"
hsLitType :: HsLit (GhcPass p) -> TcType
@@ -1296,7 +1298,7 @@ mapIPNameTc f (Right x) = do r <- f x
************************************************************************
-}
-zonkPat :: ZonkEnv -> OutPat GhcTcId -> TcM (ZonkEnv, OutPat GhcTc)
+zonkPat :: ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc)
-- Extend the environment as we go, because it's possible for one
-- pattern to bind something that is used in another (inside or
-- to the right)
@@ -1358,13 +1360,16 @@ zonk_pat env (SumPat tys pat alt arity )
; (env', pat') <- zonkPat env pat
; return (env', SumPat tys' pat' alt arity) }
-zonk_pat env p@(ConPatOut { pat_arg_tys = tys
- , pat_tvs = tyvars
- , pat_dicts = evs
- , pat_binds = binds
- , pat_args = args
- , pat_wrap = wrapper
- , pat_con = L _ con })
+zonk_pat env p@(ConPat { pat_con = L _ con
+ , pat_args = args
+ , pat_con_ext = p'@(ConPatTc
+ { cpt_tvs = tyvars
+ , cpt_dicts = evs
+ , cpt_binds = binds
+ , cpt_wrap = wrapper
+ , cpt_arg_tys = tys
+ })
+ })
= ASSERT( all isImmutableTyVar tyvars )
do { new_tys <- mapM (zonkTcTypeToTypeX env) tys
@@ -1384,12 +1389,19 @@ zonk_pat env p@(ConPatOut { pat_arg_tys = tys
; (env2, new_binds) <- zonkTcEvBinds env1 binds
; (env3, new_wrapper) <- zonkCoFn env2 wrapper
; (env', new_args) <- zonkConStuff env3 args
- ; return (env', p { pat_arg_tys = new_tys,
- pat_tvs = new_tyvars,
- pat_dicts = new_evs,
- pat_binds = new_binds,
- pat_args = new_args,
- pat_wrap = new_wrapper}) }
+ ; pure ( env'
+ , p
+ { pat_args = new_args
+ , pat_con_ext = p'
+ { cpt_arg_tys = new_tys
+ , cpt_tvs = new_tyvars
+ , cpt_dicts = new_evs
+ , cpt_binds = new_binds
+ , cpt_wrap = new_wrapper
+ }
+ }
+ )
+ }
where
doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p
@@ -1420,19 +1432,20 @@ zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2)
; return (extendIdZonkEnv env2 n',
NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') }
-zonk_pat env (CoPat x co_fn pat ty)
+zonk_pat env (XPat (CoPat co_fn pat ty))
= do { (env', co_fn') <- zonkCoFn env co_fn
; (env'', pat') <- zonkPat env' (noLoc pat)
; ty' <- zonkTcTypeToTypeX env'' ty
- ; return (env'', CoPat x co_fn' (unLoc pat') ty') }
+ ; return (env'', XPat $ CoPat co_fn' (unLoc pat') ty')
+ }
zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)
---------------------------
zonkConStuff :: ZonkEnv
- -> HsConDetails (OutPat GhcTcId) (HsRecFields id (OutPat GhcTcId))
+ -> HsConDetails (LPat GhcTc) (HsRecFields id (LPat GhcTc))
-> TcM (ZonkEnv,
- HsConDetails (OutPat GhcTc) (HsRecFields id (OutPat GhcTc)))
+ HsConDetails (LPat GhcTc) (HsRecFields id (LPat GhcTc)))
zonkConStuff env (PrefixCon pats)
= do { (env', pats') <- zonkPats env pats
; return (env', PrefixCon pats') }
@@ -1451,7 +1464,7 @@ zonkConStuff env (RecCon (HsRecFields rpats dd))
-- Field selectors have declared types; hence no zonking
---------------------------
-zonkPats :: ZonkEnv -> [OutPat GhcTcId] -> TcM (ZonkEnv, [OutPat GhcTc])
+zonkPats :: ZonkEnv -> [LPat GhcTc] -> TcM (ZonkEnv, [LPat GhcTc])
zonkPats env [] = return (env, [])
zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
; (env', pats') <- zonkPats env1 pats
diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs
index 6e44a6c399..c72d4cd357 100644
--- a/compiler/GHC/Tc/Validity.hs
+++ b/compiler/GHC/Tc/Validity.hs
@@ -2155,8 +2155,8 @@ checkFamPatBinders fam_tc qtvs pats rhs
, ppr (mkTyConApp fam_tc pats)
, text "qtvs:" <+> ppr qtvs
, text "rhs_tvs:" <+> ppr (fvVarSet rhs_fvs)
- , text "pat_tvs:" <+> ppr pat_tvs
- , text "inj_pat_tvs:" <+> ppr inj_pat_tvs ]
+ , text "cpt_tvs:" <+> ppr cpt_tvs
+ , text "inj_cpt_tvs:" <+> ppr inj_cpt_tvs ]
-- Check for implicitly-bound tyvars, mentioned on the
-- RHS but not bound on the LHS
@@ -2176,23 +2176,23 @@ checkFamPatBinders fam_tc qtvs pats rhs
(text "used in")
}
where
- pat_tvs = tyCoVarsOfTypes pats
- inj_pat_tvs = fvVarSet $ injectiveVarsOfTypes False pats
+ cpt_tvs = tyCoVarsOfTypes pats
+ inj_cpt_tvs = fvVarSet $ injectiveVarsOfTypes False pats
-- The type variables that are in injective positions.
-- See Note [Dodgy binding sites in type family instances]
-- NB: The False above is irrelevant, as we never have type families in
-- patterns.
--
-- NB: It's OK to use the nondeterministic `fvVarSet` function here,
- -- since the order of `inj_pat_tvs` is never revealed in an error
+ -- since the order of `inj_cpt_tvs` is never revealed in an error
-- message.
rhs_fvs = tyCoFVsOfType rhs
- used_tvs = pat_tvs `unionVarSet` fvVarSet rhs_fvs
+ used_tvs = cpt_tvs `unionVarSet` fvVarSet rhs_fvs
bad_qtvs = filterOut (`elemVarSet` used_tvs) qtvs
-- Bound but not used at all
- bad_rhs_tvs = filterOut (`elemVarSet` inj_pat_tvs) (fvVarList rhs_fvs)
+ bad_rhs_tvs = filterOut (`elemVarSet` inj_cpt_tvs) (fvVarList rhs_fvs)
-- Used on RHS but not bound on LHS
- dodgy_tvs = pat_tvs `minusVarSet` inj_pat_tvs
+ dodgy_tvs = cpt_tvs `minusVarSet` inj_cpt_tvs
check_tvs tvs what what2
= unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $
View Lorry Controller Status