summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Tc')
-rw-r--r--compiler/GHC/Tc/Deriv/Functor.hs12
-rw-r--r--compiler/GHC/Tc/Deriv/Generate.hs10
-rw-r--r--compiler/GHC/Tc/Gen/Match.hs44
-rw-r--r--compiler/GHC/Tc/Gen/Pat.hs10
-rw-r--r--compiler/GHC/Tc/Module.hs2
-rw-r--r--compiler/GHC/Tc/TyCl/Instance.hs2
-rw-r--r--compiler/GHC/Tc/TyCl/PatSyn.hs4
-rw-r--r--compiler/GHC/Tc/TyCl/Utils.hs4
-rw-r--r--compiler/GHC/Tc/Types/Origin.hs2
9 files changed, 60 insertions, 30 deletions
diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs
index d61b7180ef..7b9d538f65 100644
--- a/compiler/GHC/Tc/Deriv/Functor.hs
+++ b/compiler/GHC/Tc/Deriv/Functor.hs
@@ -163,7 +163,7 @@ gen_Functor_binds loc tycon _
fmap_eqns = [mkSimpleMatch fmap_match_ctxt
[nlWildPat]
coerce_Expr]
- fmap_match_ctxt = mkPrefixFunRhs fmap_name
+ fmap_match_ctxt = mkPrefixFunRhs (mapLoc CtxIdRdrName fmap_name)
gen_Functor_binds loc tycon tycon_args
= (listToBag [fmap_bind, replace_bind], emptyBag)
@@ -173,7 +173,7 @@ gen_Functor_binds loc tycon tycon_args
-- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns
- fmap_match_ctxt = mkPrefixFunRhs fmap_name
+ fmap_match_ctxt = mkPrefixFunRhs (mapLoc CtxIdRdrName fmap_name)
fmap_eqn con = flip evalState bs_RDRs $
match_for_con fmap_match_ctxt [f_Pat] con parts
@@ -212,7 +212,7 @@ gen_Functor_binds loc tycon tycon_args
-- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns
- replace_match_ctxt = mkPrefixFunRhs replace_name
+ replace_match_ctxt = mkPrefixFunRhs (mapLoc CtxIdRdrName replace_name)
replace_eqn con = flip evalState bs_RDRs $
match_for_con replace_match_ctxt [z_Pat] con parts
@@ -797,7 +797,7 @@ gen_Foldable_binds loc tycon _
foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt
[nlWildPat, nlWildPat]
mempty_Expr]
- foldMap_match_ctxt = mkPrefixFunRhs foldMap_name
+ foldMap_match_ctxt = mkPrefixFunRhs (mapLoc CtxIdRdrName foldMap_name)
gen_Foldable_binds loc tycon tycon_args
| null data_cons -- There's no real point producing anything but
@@ -840,7 +840,7 @@ gen_Foldable_binds loc tycon tycon_args
go (NullM a) = Just (Just a)
null_name = L (noAnnSrcSpan loc) null_RDR
- null_match_ctxt = mkPrefixFunRhs null_name
+ null_match_ctxt = mkPrefixFunRhs (mapLoc CtxIdRdrName null_name)
null_bind = mkRdrFunBind null_name null_eqns
null_eqns = map null_eqn data_cons
null_eqn con
@@ -1027,7 +1027,7 @@ gen_Traversable_binds loc tycon _
[mkSimpleMatch traverse_match_ctxt
[nlWildPat, z_Pat]
(nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])]
- traverse_match_ctxt = mkPrefixFunRhs traverse_name
+ traverse_match_ctxt = mkPrefixFunRhs (mapLoc CtxIdRdrName traverse_name)
gen_Traversable_binds loc tycon tycon_args
= (unitBag traverse_bind, emptyBag)
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index 5f2f69bee2..93eadc0b8f 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -1974,7 +1974,7 @@ gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty
-- @(a -> [T x] -> c -> Int)
-- op
mkRdrFunBind loc_meth_RDR [mkSimpleMatch
- (mkPrefixFunRhs loc_meth_RDR)
+ (mkPrefixFunRhs (mapLoc CtxIdRdrName loc_meth_RDR))
[] rhs_expr]
, -- The derived instance signature, e.g.,
--
@@ -2245,7 +2245,7 @@ mkFunBindSE :: Arity -> SrcSpan -> RdrName
mkFunBindSE arity loc fun pats_and_exprs
= mkRdrFunBindSE arity (L (noAnnSrcSpan loc) fun) matches
where
- matches = [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun))
+ matches = [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) (CtxIdRdrName fun)))
(map (parenthesizePat appPrec) p) e
emptyLocalBinds
| (p,e) <-pats_and_exprs]
@@ -2266,7 +2266,7 @@ mkFunBindEC :: Arity -> SrcSpan -> RdrName
mkFunBindEC arity loc fun catch_all pats_and_exprs
= mkRdrFunBindEC arity catch_all (L (noAnnSrcSpan loc) fun) matches
where
- matches = [ mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun))
+ matches = [ mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) (CtxIdRdrName fun)))
(map (parenthesizePat appPrec) p) e
emptyLocalBinds
| (p,e) <- pats_and_exprs ]
@@ -2293,7 +2293,7 @@ mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches
-- which can happen with -XEmptyDataDecls
-- See #4302
matches' = if null matches
- then [mkMatch (mkPrefixFunRhs fun)
+ then [mkMatch (mkPrefixFunRhs (mapLoc CtxIdRdrName fun))
(replicate (arity - 1) nlWildPat ++ [z_Pat])
(catch_all $ nlHsCase z_Expr [])
emptyLocalBinds]
@@ -2313,7 +2313,7 @@ mkRdrFunBindSE arity fun@(L loc fun_rdr) matches
-- which can happen with -XEmptyDataDecls
-- See #4302
matches' = if null matches
- then [mkMatch (mkPrefixFunRhs fun)
+ then [mkMatch (mkPrefixFunRhs (mapLoc CtxIdRdrName fun))
(replicate arity nlWildPat)
(error_Expr str) emptyLocalBinds]
else matches
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index 2f62d3d712..b4e57d0093 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -123,7 +123,7 @@ tcMatchesFun fn@(L _ fun_name) matches exp_ty
<+> quotes (ppr fun_name) <+> text "have"
ctxt = GenSigCtxt -- Was: FunSigCtxt fun_name True
-- But that's wrong for f :: Int -> forall a. blah
- what = FunRhs { mc_fun = fn, mc_fixity = Prefix, mc_strictness = strictness }
+ what = FunRhs { mc_fun = mapLoc CtxIdName fn, mc_fixity = Prefix, mc_strictness = strictness }
match_ctxt = MC { mc_what = what, mc_body = tcBody }
strictness
| [L _ match] <- unLoc $ mg_alts matches
@@ -186,12 +186,42 @@ tcGRHSsPat grhss res_ty
********************************************************************* -}
data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module
- = MC { mc_what :: HsMatchContext GhcRn, -- What kind of thing this is
+ = MC { mc_what :: HsMatchContext GhcTc, -- What kind of thing this is
mc_body :: LocatedA (body GhcRn) -- Type checker for a body of
-- an alternative
-> ExpRhoType
-> TcM (LocatedA (body GhcTc)) }
+tcCtxId :: CtxIdP GhcRn -> CtxIdP GhcTc
+tcCtxId (CtxIdName name) = CtxIdName name
+
+tcMatchCtxt :: HsMatchContext GhcRn -> HsMatchContext GhcTc
+tcMatchCtxt ctx = case ctx of
+ FunRhs name fxt stx -> FunRhs (mapLoc tcCtxId name) fxt stx
+ LambdaExpr -> LambdaExpr
+ CaseAlt -> CaseAlt
+ IfAlt -> IfAlt
+ ProcExpr -> ProcExpr
+ PatBindRhs -> PatBindRhs
+ PatBindGuards -> PatBindGuards
+ RecUpd -> RecUpd
+ StmtCtxt sc -> StmtCtxt (tcStmtCtxt sc)
+ ThPatSplice -> ThPatSplice
+ ThPatQuote -> ThPatQuote
+ PatSyn -> PatSyn
+
+tcStmtCtxt :: HsStmtContext GhcRn -> HsStmtContext GhcTc
+tcStmtCtxt ctx = case ctx of
+ ListComp -> ListComp
+ MonadComp -> MonadComp
+ DoExpr mn -> DoExpr mn
+ MDoExpr mn -> MDoExpr mn
+ ArrowExpr -> ArrowExpr
+ GhciStmtCtxt -> GhciStmtCtxt
+ PatGuard mc -> PatGuard (tcMatchCtxt mc)
+ ParStmtCtxt sc -> ParStmtCtxt (tcStmtCtxt sc)
+ TransStmtCtxt sc -> TransStmtCtxt (tcStmtCtxt sc)
+
type AnnoBody body
= ( Outputable (body GhcRn)
, Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
@@ -299,7 +329,7 @@ tcGRHS ctxt res_ty (GRHS _ guards rhs)
************************************************************************
-}
-tcDoStmts :: HsStmtContext GhcRn
+tcDoStmts :: HsStmtContext GhcTc
-> LocatedL [LStmt GhcRn (LHsExpr GhcRn)]
-> ExpRhoType
-> TcM (HsExpr GhcTc) -- Returns a HsDo
@@ -346,13 +376,13 @@ type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType
type TcCmdStmtChecker = TcStmtChecker HsCmd TcRhoType
type TcStmtChecker body rho_type
- = forall thing. HsStmtContext GhcRn
+ = forall thing. HsStmtContext GhcTc
-> Stmt GhcRn (LocatedA (body GhcRn))
-> rho_type -- Result type for comprehension
-> (rho_type -> TcM thing) -- Checker for what follows the stmt
-> TcM (Stmt GhcTc (LocatedA (body GhcTc)), thing)
-tcStmts :: (AnnoBody body) => HsStmtContext GhcRn
+tcStmts :: (AnnoBody body) => HsStmtContext GhcTc
-> TcStmtChecker body rho_type -- NB: higher-rank type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
@@ -362,7 +392,7 @@ tcStmts ctxt stmt_chk stmts res_ty
const (return ())
; return stmts' }
-tcStmtsAndThen :: (AnnoBody body) => HsStmtContext GhcRn
+tcStmtsAndThen :: (AnnoBody body) => HsStmtContext GhcTc
-> TcStmtChecker body rho_type -- NB: higher-rank type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
@@ -1000,7 +1030,7 @@ join :: tn -> res_ty
-}
tcApplicativeStmts
- :: HsStmtContext GhcRn
+ :: HsStmtContext GhcTc
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpRhoType -- rhs_ty
-> (TcRhoType -> TcM t) -- thing_inside
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index c652ae73da..d2808f9176 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -95,7 +95,7 @@ tcLetPat sig_fn no_gen pat pat_ty thing_inside
; tc_lpat pat_ty penv pat thing_inside }
-----------------
-tcPats :: HsMatchContext GhcRn
+tcPats :: HsMatchContext GhcTc
-> [LPat GhcRn] -- Patterns,
-> [Scaled ExpSigmaType] -- and their types
-> TcM a -- and the checker for the body
@@ -117,7 +117,7 @@ tcPats ctxt pats pat_tys thing_inside
where
penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }
-tcInferPat :: HsMatchContext GhcRn -> LPat GhcRn
+tcInferPat :: HsMatchContext GhcTc -> LPat GhcRn
-> TcM a
-> TcM ((LPat GhcTc, a), TcSigmaType)
tcInferPat ctxt pat thing_inside
@@ -126,14 +126,14 @@ tcInferPat ctxt pat thing_inside
where
penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }
-tcCheckPat :: HsMatchContext GhcRn
+tcCheckPat :: HsMatchContext GhcTc
-> LPat GhcRn -> Scaled TcSigmaType
-> TcM a -- Checker for body
-> TcM (LPat GhcTc, a)
tcCheckPat ctxt = tcCheckPat_O ctxt PatOrigin
-- | A variant of 'tcPat' that takes a custom origin
-tcCheckPat_O :: HsMatchContext GhcRn
+tcCheckPat_O :: HsMatchContext GhcTc
-> CtOrigin -- ^ origin to use if the type needs inst'ing
-> LPat GhcRn -> Scaled TcSigmaType
-> TcM a -- Checker for body
@@ -160,7 +160,7 @@ data PatEnv
data PatCtxt
= LamPat -- Used for lambdas, case etc
- (HsMatchContext GhcRn)
+ (HsMatchContext GhcTc)
| LetPat -- Used only for let(rec) pattern bindings
-- See Note [Typing patterns in pattern bindings]
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 09edfcb8c3..e67a6608d0 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -2231,7 +2231,7 @@ tcUserStmt (L loc (BodyStmt _ expr _ _))
; let loc' = noAnnSrcSpan $ locA loc
; interPrintName <- getInteractivePrintName
; let fresh_it = itName uniq (locA loc)
- matches = [mkMatch (mkPrefixFunRhs (L loc' fresh_it)) [] rn_expr
+ matches = [mkMatch (mkPrefixFunRhs (L loc' (CtxIdRdrName fresh_it))) [] rn_expr
emptyLocalBinds]
-- [it = expr]
the_bind = L loc $ (mkTopFunBind FromSource
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index f2b1c87ad6..22a10d5606 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -2082,7 +2082,7 @@ mkDefMethBind dfun_id clas sel_id dm_name
, tyConBinderArgFlag tcb /= Inferred ]
rhs = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys
bind = noLocA $ mkTopFunBind Generated fn $
- [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]
+ [mkSimpleMatch (mkPrefixFunRhs (mapLoc CtxIdName fn)) [] rhs]
; liftIO (dumpIfSet_dyn logger dflags Opt_D_dump_deriv "Filling in method body"
FormatHaskell
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 642429d61b..2b89943b75 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -802,7 +802,7 @@ tcPatSynMatcher (L loc name) lpat prag_fn
, mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty
, mg_origin = Generated
}
- match = mkMatch (mkPrefixFunRhs (L loc name)) []
+ match = mkMatch (mkPrefixFunRhs (L loc (CtxIdName name))) []
(mkHsLams (rr_tv:res_tv:univ_tvs)
req_dicts body')
(EmptyLocalBinds noExtField)
@@ -939,7 +939,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
where
builder_args = [L (na2la loc) (VarPat noExtField (L loc n))
| L loc n <- args]
- builder_match = mkMatch (mkPrefixFunRhs ps_lname)
+ builder_match = mkMatch (mkPrefixFunRhs (mapLoc CtxIdName ps_lname))
builder_args body
(EmptyLocalBinds noExtField)
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index 6c8daa0d56..0393721df0 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -912,10 +912,10 @@ mkOneRecordSelector all_cons idDetails fl has_sel
-- where cons_w_field = [C2,C7]
sel_bind = mkTopFunBind Generated sel_lname alts
where
- alts | is_naughty = [mkSimpleMatch (mkPrefixFunRhs sel_lname)
+ alts | is_naughty = [mkSimpleMatch (mkPrefixFunRhs (mapLoc CtxIdName sel_lname))
[] unit_rhs]
| otherwise = map mk_match cons_w_field ++ deflt
- mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname)
+ mk_match con = mkSimpleMatch (mkPrefixFunRhs (mapLoc CtxIdName sel_lname))
[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)
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index 4ddb0ee000..cced5ed447 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -200,7 +200,7 @@ data SkolemInfo
| FamInstSkol -- Bound at a family instance decl
| PatSkol -- An existential type variable bound by a pattern for
ConLike -- a data constructor with an existential type.
- (HsMatchContext GhcRn)
+ (HsMatchContext GhcTc)
-- e.g. data T = forall a. Eq a => MkT a
-- f (MkT x) = ...
-- The pattern MkT x will allocate an existential type
View Lorry Controller Status