From e2ea933f1d859a32f2dee0c1e916233350013c86 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simon.peytonjones@gmail.com>
Date: Sun, 4 Feb 2024 16:18:33 +0300
Subject: [PATCH] Refactoring in preparation for lazy skolemisation
* Make HsMatchContext and HsStmtContext be parameterised over the
function name itself, rather than over the pass.
See [mc_fun field of FunRhs] in Language.Haskell.Syntax.Expr
- Replace types
HsMatchContext GhcPs --> HsMatchContextPs
HsMatchContext GhcRn --> HsMatchContextRn
HsMatchContext GhcTc --> HsMatchContextRn (sic! not Tc)
HsStmtContext GhcRn --> HsStmtContextRn
- Kill off convertHsMatchCtxt
* Split GHC.Tc.Type.BasicTypes.TcSigInfo so that TcCompleteSig (describing
a complete user-supplied signature) is its own data type.
- Split TcIdSigInfo(CompleteSig, PartialSig) into
TcCompleteSig(CSig)
TcPartialSig(PSig)
- Use TcCompleteSig in tcPolyCheck, CheckGen
- Rename types and data constructors:
TcIdSigInfo --> TcIdSig
TcPatSynInfo(TPSI) --> TcPatSynSig(PatSig)
- Shuffle around helper functions:
tcSigInfoName (moved to GHC.Tc.Types.BasicTypes)
completeSigPolyId_maybe (moved to GHC.Tc.Types.BasicTypes)
tcIdSigName (inlined and removed)
tcIdSigLoc (introduced)
- Rearrange the pattern match in chooseInferredQuantifiers
* Rename functions and types:
tcMatchesCase --> tcCaseMatches
tcMatchesFun --> tcFunBindMatches
tcMatchLambda --> tcLambdaMatches
tcPats --> tcMatchPats
matchActualFunTysRho --> matchActualFunTys
matchActualFunTySigma --> matchActualFunTy
* Add HasDebugCallStack constraints to:
mkBigCoreVarTupTy, mkBigCoreTupTy, boxTy,
mkPiTy, mkPiTys, splitAppTys, splitTyConAppNoView_maybe
* Use `penv` from the outer context in the inner loop of
GHC.Tc.Gen.Pat.tcMultiple
* Move tcMkVisFunTy, tcMkInvisFunTy, tcMkScaledFunTys down the file,
factor out and export tcMkScaledFunTy.
* Move isPatSigCtxt down the file.
* Formatting and comments
Co-authored-by: Vladislav Zavialov <vlad.z.4096@gmail.com>
---
compiler/GHC/Core/Make.hs | 6 +-
compiler/GHC/Core/TyCo/Rep.hs | 55 ++++-----
compiler/GHC/Core/Type.hs | 4 +-
compiler/GHC/Hs/Expr.hs | 54 +++++----
compiler/GHC/Hs/Instances.hs | 9 +-
compiler/GHC/Hs/Utils.hs | 16 +--
compiler/GHC/HsToCore/Arrows.hs | 2 +-
compiler/GHC/HsToCore/Errors/Ppr.hs | 4 +-
compiler/GHC/HsToCore/Errors/Types.hs | 8 +-
compiler/GHC/HsToCore/GuardedRHSs.hs | 6 +-
compiler/GHC/HsToCore/Match.hs | 10 +-
compiler/GHC/HsToCore/Match.hs-boot | 9 +-
compiler/GHC/HsToCore/Monad.hs | 2 +-
compiler/GHC/HsToCore/Pmc.hs | 2 +-
compiler/GHC/HsToCore/Pmc/Utils.hs | 10 +-
compiler/GHC/HsToCore/Utils.hs | 4 +-
compiler/GHC/Iface/Ext/Ast.hs | 38 +++---
compiler/GHC/Parser/PostProcess.hs | 4 +-
compiler/GHC/Rename/Bind.hs | 12 +-
compiler/GHC/Rename/Env.hs | 12 +-
compiler/GHC/Rename/Expr.hs | 42 +++----
compiler/GHC/Rename/Expr.hs-boot | 2 +-
compiler/GHC/Rename/Pat.hs | 10 +-
compiler/GHC/Rename/Utils.hs | 2 +-
compiler/GHC/Tc/Deriv/Functor.hs | 6 +-
compiler/GHC/Tc/Errors/Types.hs | 12 +-
compiler/GHC/Tc/Gen/App.hs | 26 ++---
compiler/GHC/Tc/Gen/Arrow.hs | 6 +-
compiler/GHC/Tc/Gen/Bind.hs | 93 +++++++--------
compiler/GHC/Tc/Gen/Expr.hs | 12 +-
compiler/GHC/Tc/Gen/Head.hs | 16 +--
compiler/GHC/Tc/Gen/Match.hs | 124 ++++++++------------
compiler/GHC/Tc/Gen/Match.hs-boot | 10 +-
compiler/GHC/Tc/Gen/Pat.hs | 36 +++---
compiler/GHC/Tc/Gen/Sig.hs | 91 ++++++---------
compiler/GHC/Tc/TyCl/Class.hs | 6 +-
compiler/GHC/Tc/TyCl/Instance.hs | 7 +-
compiler/GHC/Tc/TyCl/PatSyn.hs | 18 +--
compiler/GHC/Tc/TyCl/Utils.hs | 11 +-
compiler/GHC/Tc/Types.hs | 7 +-
compiler/GHC/Tc/Types/BasicTypes.hs | 143 +++++++++++++----------
compiler/GHC/Tc/Types/Origin.hs | 6 +-
compiler/GHC/Tc/Utils/Unify.hs | 42 +++----
compiler/GHC/ThToHs.hs | 6 +-
compiler/GHC/Types/Var.hs | 4 +-
compiler/Language/Haskell/Syntax/Expr.hs | 97 ++++++++-------
46 files changed, 539 insertions(+), 563 deletions(-)
diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs
index e5e55e21fb75..7dd09bdf7f8a 100644
--- a/compiler/GHC/Core/Make.hs
+++ b/compiler/GHC/Core/Make.hs
@@ -468,12 +468,12 @@ mkBigCoreTup exprs = mkChunkified mkCoreTup (map wrapBox exprs)
-- | Build the type of a big tuple that holds the specified variables
-- One-tuples are flattened; see Note [Flattening one-tuples]
-mkBigCoreVarTupTy :: [Id] -> Type
+mkBigCoreVarTupTy :: HasDebugCallStack => [Id] -> Type
mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids)
-- | Build the type of a big tuple that holds the specified type of thing
-- One-tuples are flattened; see Note [Flattening one-tuples]
-mkBigCoreTupTy :: [Type] -> Type
+mkBigCoreTupTy :: HasDebugCallStack => [Type] -> Type
mkBigCoreTupTy tys = mkChunkified mkBoxedTupleTy $
map boxTy tys
@@ -498,7 +498,7 @@ wrapBox e
where
e_ty = exprType e
-boxTy :: Type -> Type
+boxTy :: HasDebugCallStack => Type -> Type
-- ^ `boxTy ty` is the boxed version of `ty`. That is,
-- if `e :: ty`, then `wrapBox e :: boxTy ty`.
-- Note that if `ty :: Type`, `boxTy ty` just returns `ty`.
diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs
index d57b18c25413..5009707ae421 100644
--- a/compiler/GHC/Core/TyCo/Rep.hs
+++ b/compiler/GHC/Core/TyCo/Rep.hs
@@ -48,7 +48,7 @@ module GHC.Core.TyCo.Rep (
mkFunTy, mkNakedFunTy,
mkVisFunTy, mkScaledFunTys,
mkInvisFunTy, mkInvisFunTys,
- tcMkVisFunTy, tcMkInvisFunTy, tcMkScaledFunTys,
+ tcMkVisFunTy, tcMkInvisFunTy, tcMkScaledFunTy, tcMkScaledFunTys,
mkForAllTy, mkForAllTys, mkInvisForAllTys,
mkPiTy, mkPiTys,
mkVisFunTyMany, mkVisFunTysMany,
@@ -735,22 +735,6 @@ mkInvisFunTys args res
where
af = invisArg (typeTypeOrConstraint res)
-tcMkVisFunTy :: Mult -> Type -> Type -> Type
--- Always TypeLike, user-specified multiplicity.
--- Does not have the assert-checking in mkFunTy: used by the typechecker
--- to avoid looking at the result kind, which may not be zonked
-tcMkVisFunTy mult arg res
- = FunTy { ft_af = visArgTypeLike, ft_mult = mult
- , ft_arg = arg, ft_res = res }
-
-tcMkInvisFunTy :: TypeOrConstraint -> Type -> Type -> Type
--- Always TypeLike, invisible argument
--- Does not have the assert-checking in mkFunTy: used by the typechecker
--- to avoid looking at the result kind, which may not be zonked
-tcMkInvisFunTy res_torc arg res
- = FunTy { ft_af = invisArg res_torc, ft_mult = manyDataConTy
- , ft_arg = arg, ft_res = res }
-
mkVisFunTy :: HasDebugCallStack => Mult -> Type -> Type -> Type
-- Always TypeLike, user-specified multiplicity.
mkVisFunTy = mkFunTy visArgTypeLike
@@ -777,14 +761,6 @@ mkScaledFunTys tys ty = foldr (mkScaledFunTy af) ty tys
where
af = visArg (typeTypeOrConstraint ty)
-tcMkScaledFunTys :: [Scaled Type] -> Type -> Type
--- All visible args
--- Result type must be TypeLike
--- No mkFunTy assert checking; result kind may not be zonked
-tcMkScaledFunTys tys ty = foldr mk ty tys
- where
- mk (Scaled mult arg) res = tcMkVisFunTy mult arg res
-
---------------
-- | Like 'mkTyCoForAllTy', but does not check the occurrence of the binder
-- See Note [Unused coercion variable in ForAllTy]
@@ -809,11 +785,11 @@ mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
mkInvisForAllTys :: [InvisTVBinder] -> Type -> Type
mkInvisForAllTys tyvars = mkForAllTys (tyVarSpecToBinders tyvars)
-mkPiTy :: PiTyBinder -> Type -> Type
+mkPiTy :: HasDebugCallStack => PiTyBinder -> Type -> Type
mkPiTy (Anon ty1 af) ty2 = mkScaledFunTy af ty1 ty2
mkPiTy (Named bndr) ty = mkForAllTy bndr ty
-mkPiTys :: [PiTyBinder] -> Type -> Type
+mkPiTys :: HasDebugCallStack => [PiTyBinder] -> Type -> Type
mkPiTys tbs ty = foldr mkPiTy ty tbs
-- | 'mkNakedTyConTy' creates a nullary 'TyConApp'. In general you
@@ -824,6 +800,31 @@ mkPiTys tbs ty = foldr mkPiTy ty tbs
mkNakedTyConTy :: TyCon -> Type
mkNakedTyConTy tycon = TyConApp tycon []
+tcMkVisFunTy :: Mult -> Type -> Type -> Type
+-- Always TypeLike result, user-specified multiplicity.
+-- Does not have the assert-checking in mkFunTy: used by the typechecker
+-- to avoid looking at the result kind, which may not be zonked
+tcMkVisFunTy mult arg res
+ = FunTy { ft_af = visArgTypeLike, ft_mult = mult
+ , ft_arg = arg, ft_res = res }
+
+tcMkInvisFunTy :: TypeOrConstraint -> Type -> Type -> Type
+-- Always invisible (constraint) argument, result specified by res_torc
+-- Does not have the assert-checking in mkFunTy: used by the typechecker
+-- to avoid looking at the result kind, which may not be zonked
+tcMkInvisFunTy res_torc arg res
+ = FunTy { ft_af = invisArg res_torc, ft_mult = manyDataConTy
+ , ft_arg = arg, ft_res = res }
+
+tcMkScaledFunTys :: [Scaled Type] -> Type -> Type
+-- All visible args
+-- Result type must be TypeLike
+-- No mkFunTy assert checking; result kind may not be zonked
+tcMkScaledFunTys tys ty = foldr tcMkScaledFunTy ty tys
+
+tcMkScaledFunTy :: Scaled Type -> Type -> Type
+tcMkScaledFunTy (Scaled mult arg) res = tcMkVisFunTy mult arg res
+
{-
%************************************************************************
%* *
diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs
index 61bb2b991d9b..5a259b6a80b1 100644
--- a/compiler/GHC/Core/Type.hs
+++ b/compiler/GHC/Core/Type.hs
@@ -1149,7 +1149,7 @@ tcSplitAppTyNoView_maybe ty
= splitAppTyNoView_maybe ty
-------------
-splitAppTys :: Type -> (Type, [Type])
+splitAppTys :: HasDebugCallStack => Type -> (Type, [Type])
-- ^ Recursively splits a type as far as is possible, leaving a residual
-- type being applied to and the type arguments applied to it. Never fails,
-- even if that means returning an empty list of type applications.
@@ -1600,7 +1600,7 @@ splitTyConApp ty = splitTyConApp_maybe ty `orElse` pprPanic "splitTyConApp" (ppr
splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe ty = splitTyConAppNoView_maybe (coreFullView ty)
-splitTyConAppNoView_maybe :: Type -> Maybe (TyCon, [Type])
+splitTyConAppNoView_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])
-- Same as splitTyConApp_maybe but without looking through synonyms
splitTyConAppNoView_maybe ty
= case ty of
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index e65df0c53df6..a22048e03f0f 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -75,6 +75,7 @@ import qualified Data.Kind
import Data.Maybe (isJust)
import Data.Foldable ( toList )
import Data.List.NonEmpty (NonEmpty)
+import Data.Void (Void)
{- *********************************************************************
* *
@@ -280,8 +281,8 @@ type instance XExplicitSum GhcRn = NoExtField
type instance XExplicitSum GhcTc = [Type]
type instance XCase GhcPs = EpAnn EpAnnHsCase
-type instance XCase GhcRn = HsMatchContext GhcTc
-type instance XCase GhcTc = HsMatchContext GhcTc
+type instance XCase GhcRn = HsMatchContextRn
+type instance XCase GhcTc = HsMatchContextRn
type instance XIf GhcPs = EpAnn AnnsIf
type instance XIf GhcRn = NoExtField
@@ -1486,7 +1487,7 @@ matchGroupArity :: MatchGroup (GhcPass id) body -> Arity
-- This is called before type checking, when mg_arg_tys is not set
matchGroupArity (MG { mg_alts = alts })
| L _ (alt1:_) <- alts = length (hsLMatchPats alt1)
- | otherwise = panic "matchGroupArity"
+ | otherwise = panic "matchGroupArity"
hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)]
hsLMatchPats (L _ (Match { m_pats = pats })) = pats
@@ -1531,7 +1532,7 @@ pprPatBind :: forall bndr p . (OutputableBndrId bndr,
=> LPat (GhcPass bndr) -> GRHSs (GhcPass p) (LHsExpr (GhcPass p)) -> SDoc
pprPatBind pat grhss
= sep [ppr pat,
- nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (GhcPass p)) grhss)]
+ nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext Void) grhss)]
pprMatch :: (OutputableBndrId idR, Outputable body)
=> Match (GhcPass idR) body -> SDoc
@@ -1580,7 +1581,7 @@ pprMatch (Match { m_pats = pats, m_ctxt = ctxt, m_grhss = grhss })
_ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)
pprGRHSs :: (OutputableBndrId idR, Outputable body)
- => HsMatchContext passL -> GRHSs (GhcPass idR) body -> SDoc
+ => HsMatchContext fn -> GRHSs (GhcPass idR) body -> SDoc
pprGRHSs ctxt (GRHSs _ grhss binds)
= vcat (map (pprGRHS ctxt . unLoc) grhss)
-- Print the "where" even if the contents of the binds is empty. Only
@@ -1589,17 +1590,17 @@ pprGRHSs ctxt (GRHSs _ grhss binds)
(text "where" $$ nest 4 (pprBinds binds))
pprGRHS :: (OutputableBndrId idR, Outputable body)
- => HsMatchContext passL -> GRHS (GhcPass idR) body -> SDoc
+ => HsMatchContext fn -> GRHS (GhcPass idR) body -> SDoc
pprGRHS ctxt (GRHS _ [] body)
= pp_rhs ctxt body
pprGRHS ctxt (GRHS _ guards body)
= sep [vbar <+> interpp'SP guards, pp_rhs ctxt body]
-pp_rhs :: Outputable body => HsMatchContext passL -> body -> SDoc
+pp_rhs :: Outputable body => HsMatchContext fn -> body -> SDoc
pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
-matchSeparator :: HsMatchContext p -> SDoc
+matchSeparator :: HsMatchContext fn -> SDoc
matchSeparator FunRhs{} = text "="
matchSeparator CaseAlt = text "->"
matchSeparator LamAlt{} = text "->"
@@ -2063,7 +2064,12 @@ pp_dotdot = text " .. "
************************************************************************
-}
-instance OutputableBndrId p => Outputable (HsMatchContext (GhcPass p)) where
+type HsMatchContextPs = HsMatchContext (LIdP GhcPs)
+type HsMatchContextRn = HsMatchContext (LIdP GhcRn)
+
+type HsStmtContextRn = HsStmtContext (LIdP GhcRn)
+
+instance Outputable fn => Outputable (HsMatchContext fn) where
ppr m@(FunRhs{}) = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m)
ppr CaseAlt = text "CaseAlt"
ppr (LamAlt lam_variant) = text "LamAlt" <+> ppr lam_variant
@@ -2104,14 +2110,12 @@ pprHsArrType HsFirstOrderApp = text "first order arrow application"
-----------------
-instance OutputableBndrId p
- => Outputable (HsStmtContext (GhcPass p)) where
+instance Outputable fn => Outputable (HsStmtContext fn) where
ppr = pprStmtContext
-- Used to generate the string for a *runtime* error message
-matchContextErrString :: OutputableBndrId p
- => HsMatchContext (GhcPass p) -> SDoc
-matchContextErrString (FunRhs{mc_fun=L _ fun}) = text "function" <+> ppr fun
+matchContextErrString :: Outputable fn => HsMatchContext fn -> SDoc
+matchContextErrString (FunRhs{mc_fun=fun}) = text "function" <+> ppr fun
matchContextErrString CaseAlt = text "case"
matchContextErrString (LamAlt lam_variant) = lamCaseKeyword lam_variant
matchContextErrString IfAlt = text "multi-way if"
@@ -2150,10 +2154,10 @@ pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match)
pprStmtInCtxt :: (OutputableBndrId idL,
OutputableBndrId idR,
- OutputableBndrId ctx,
+ Outputable fn,
Outputable body,
Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA)
- => HsStmtContext (GhcPass ctx)
+ => HsStmtContext fn
-> StmtLR (GhcPass idL) (GhcPass idR) body
-> SDoc
pprStmtInCtxt ctxt (LastStmt _ e _ _)
@@ -2169,8 +2173,7 @@ pprStmtInCtxt ctxt stmt
, trS_form = form }) = pprTransStmt by using form
ppr_stmt stmt = pprStmt stmt
-pprMatchContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))
- => HsMatchContext p -> SDoc
+pprMatchContext :: Outputable fn => HsMatchContext fn -> SDoc
pprMatchContext ctxt
| want_an ctxt = text "an" <+> pprMatchContextNoun ctxt
| otherwise = text "a" <+> pprMatchContextNoun ctxt
@@ -2181,10 +2184,8 @@ pprMatchContext ctxt
want_an LazyPatCtx = True
want_an _ = False
-pprMatchContextNoun :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))
- => HsMatchContext p -> SDoc
-pprMatchContextNoun (FunRhs {mc_fun=fun}) = text "equation for"
- <+> quotes (ppr (unXRec @(NoGhcTc p) fun))
+pprMatchContextNoun :: Outputable fn => HsMatchContext fn -> SDoc
+pprMatchContextNoun (FunRhs {mc_fun=fun}) = text "equation for" <+> quotes (ppr fun)
pprMatchContextNoun CaseAlt = text "case alternative"
pprMatchContextNoun (LamAlt LamSingle) = text "lambda abstraction"
pprMatchContextNoun (LamAlt lam_variant) = lamCaseKeyword lam_variant
@@ -2201,10 +2202,8 @@ pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"
pprMatchContextNoun PatSyn = text "pattern synonym declaration"
pprMatchContextNoun LazyPatCtx = text "irrefutable pattern"
-pprMatchContextNouns :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))
- => HsMatchContext p -> SDoc
-pprMatchContextNouns (FunRhs {mc_fun=fun}) = text "equations for"
- <+> quotes (ppr (unXRec @(NoGhcTc p) fun))
+pprMatchContextNouns :: Outputable fn => HsMatchContext fn -> SDoc
+pprMatchContextNouns (FunRhs {mc_fun=fun}) = text "equations for" <+> quotes (ppr fun)
pprMatchContextNouns PatBindGuards = text "pattern binding guards"
pprMatchContextNouns (ArrowMatchCtxt c) = pprArrowMatchContextNouns c
pprMatchContextNouns (StmtCtxt ctxt) = text "pattern bindings in"
@@ -2226,8 +2225,7 @@ pprArrowMatchContextNouns (ArrowLamAlt lam_variant) = lamCaseKeyword lam_variant
pprArrowMatchContextNouns ctxt = pprArrowMatchContextNoun ctxt <> char 's'
-----------------
-pprAStmtContext, pprStmtContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))
- => HsStmtContext p -> SDoc
+pprAStmtContext, pprStmtContext :: Outputable fn => HsStmtContext fn -> SDoc
pprAStmtContext (HsDoStmt flavour) = pprAHsDoFlavour flavour
pprAStmtContext ctxt = text "a" <+> pprStmtContext ctxt
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index b06b64e3de56..4917e18a85dd 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -382,15 +382,10 @@ deriving instance Data (ApplicativeArg GhcPs)
deriving instance Data (ApplicativeArg GhcRn)
deriving instance Data (ApplicativeArg GhcTc)
-deriving instance Data (HsStmtContext GhcPs)
-deriving instance Data (HsStmtContext GhcRn)
-deriving instance Data (HsStmtContext GhcTc)
-
deriving instance Data HsArrowMatchContext
-deriving instance Data (HsMatchContext GhcPs)
-deriving instance Data (HsMatchContext GhcRn)
-deriving instance Data (HsMatchContext GhcTc)
+deriving instance Data fn => Data (HsStmtContext fn)
+deriving instance Data fn => Data (HsMatchContext fn)
-- deriving instance (DataIdLR p p) => Data (HsUntypedSplice p)
deriving instance Data (HsUntypedSplice GhcPs)
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 49b6c4decdb1..942b3f6db011 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -186,7 +186,7 @@ mkSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA,
Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ EpAnn NoEpAnns)
- => HsMatchContext (GhcPass p)
+ => HsMatchContext (LIdP (NoGhcTc (GhcPass p)))
-> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch ctxt pats rhs
@@ -894,18 +894,20 @@ mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
-> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind loc fun pats expr
= L (noAnnSrcSpan loc) $ mkFunBind (Generated OtherExpansion SkipPmc) (L (noAnnSrcSpan loc) fun)
- [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun)) pats expr
- emptyLocalBinds]
+ [mkMatch ctxt pats expr emptyLocalBinds]
+ where
+ ctxt :: HsMatchContextPs
+ ctxt = mkPrefixFunRhs (L (noAnnSrcSpan loc) fun)
-- | Make a prefix, non-strict function 'HsMatchContext'
-mkPrefixFunRhs :: LIdP (NoGhcTc p) -> HsMatchContext p
-mkPrefixFunRhs n = FunRhs { mc_fun = n
- , mc_fixity = Prefix
+mkPrefixFunRhs :: fn -> HsMatchContext fn
+mkPrefixFunRhs n = FunRhs { mc_fun = n
+ , mc_fixity = Prefix
, mc_strictness = NoSrcStrict }
------------
mkMatch :: forall p. IsPass p
- => HsMatchContext (GhcPass p)
+ => HsMatchContext (LIdP (NoGhcTc (GhcPass p)))
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> HsLocalBinds (GhcPass p)
diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs
index 37c8678f9cdf..9456c5915990 100644
--- a/compiler/GHC/HsToCore/Arrows.hs
+++ b/compiler/GHC/HsToCore/Arrows.hs
@@ -1190,7 +1190,7 @@ dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []"
-- Match a list of expressions against a list of patterns, left-to-right.
matchSimplys :: [CoreExpr] -- Scrutinees
- -> HsMatchContext GhcTc -- Match kind
+ -> HsMatchContextRn -- Match kind
-> [LPat GhcTc] -- Patterns they should match
-> CoreExpr -- Return this if they all match
-> CoreExpr -- Return this if they don't
diff --git a/compiler/GHC/HsToCore/Errors/Ppr.hs b/compiler/GHC/HsToCore/Errors/Ppr.hs
index 18a6996da22d..99284678a641 100644
--- a/compiler/GHC/HsToCore/Errors/Ppr.hs
+++ b/compiler/GHC/HsToCore/Errors/Ppr.hs
@@ -304,11 +304,11 @@ badMonadBind elt_ty
2 (quotes (ppr elt_ty))
-- Print a single clause (for redundant/with-inaccessible-rhs)
-pprEqn :: HsMatchContext GhcTc -> SDoc -> String -> SDoc
+pprEqn :: HsMatchContextRn -> SDoc -> String -> SDoc
pprEqn ctx q txt = pprContext True ctx (text txt) $ \f ->
f (q <+> matchSeparator ctx <+> text "...")
-pprContext :: Bool -> HsMatchContext GhcTc -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
+pprContext :: Bool -> HsMatchContextRn -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
pprContext singular kind msg rest_of_msg_fun
= vcat [text txt <+> msg,
sep [ text "In" <+> ppr_match <> char ':'
diff --git a/compiler/GHC/HsToCore/Errors/Types.hs b/compiler/GHC/HsToCore/Errors/Types.hs
index a5b85218fad5..390b0d49d9fa 100644
--- a/compiler/GHC/HsToCore/Errors/Types.hs
+++ b/compiler/GHC/HsToCore/Errors/Types.hs
@@ -86,18 +86,18 @@ data DsMessage
-- FIXME(adn) Use a proper type instead of 'SDoc', but unfortunately
-- 'SrcInfo' gives us an 'SDoc' to begin with.
- | DsRedundantBangPatterns !(HsMatchContext GhcTc) !SDoc
+ | DsRedundantBangPatterns !HsMatchContextRn !SDoc
-- FIXME(adn) Use a proper type instead of 'SDoc', but unfortunately
-- 'SrcInfo' gives us an 'SDoc' to begin with.
- | DsOverlappingPatterns !(HsMatchContext GhcTc) !SDoc
+ | DsOverlappingPatterns !HsMatchContextRn !SDoc
-- FIXME(adn) Use a proper type instead of 'SDoc'
- | DsInaccessibleRhs !(HsMatchContext GhcTc) !SDoc
+ | DsInaccessibleRhs !HsMatchContextRn !SDoc
| DsMaxPmCheckModelsReached !MaxPmCheckModels
- | DsNonExhaustivePatterns !(HsMatchContext GhcTc)
+ | DsNonExhaustivePatterns !HsMatchContextRn
!ExhaustivityCheckType
!MaxUncoveredPatterns
[Id]
diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs
index acb4a89dd1b8..a21d8f73cffe 100644
--- a/compiler/GHC/HsToCore/GuardedRHSs.hs
+++ b/compiler/GHC/HsToCore/GuardedRHSs.hs
@@ -54,7 +54,7 @@ dsGuarded grhss rhs_ty rhss_nablas = do
-- In contrast, @dsGRHSs@ produces a @MatchResult CoreExpr@.
-dsGRHSs :: HsMatchContext GhcTc
+dsGRHSs :: HsMatchContextRn
-> GRHSs GhcTc (LHsExpr GhcTc) -- ^ Guarded RHSs
-> Type -- ^ Type of RHS
-> NonEmpty Nablas -- ^ Refined pattern match checking
@@ -75,7 +75,7 @@ dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty rhss_nablas
-- NB: nested dsLet inside matchResult
; return match_result2 }
-dsGRHS :: HsMatchContext GhcTc -> Type -> Nablas -> LGRHS GhcTc (LHsExpr GhcTc)
+dsGRHS :: HsMatchContextRn -> Type -> Nablas -> LGRHS GhcTc (LHsExpr GhcTc)
-> DsM (MatchResult CoreExpr)
dsGRHS hs_ctx rhs_ty rhs_nablas (L _ (GRHS _ guards rhs))
= matchGuards (map unLoc guards) hs_ctx rhs_nablas rhs rhs_ty
@@ -89,7 +89,7 @@ dsGRHS hs_ctx rhs_ty rhs_nablas (L _ (GRHS _ guards rhs))
-}
matchGuards :: [GuardStmt GhcTc] -- Guard
- -> HsMatchContext GhcTc -- Context
+ -> HsMatchContextRn -- Context
-> Nablas -- The RHS's covered set for PmCheck
-> LHsExpr GhcTc -- RHS
-> Type -- Type of RHS of guard
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index a0905f5559cc..f75d73790f8a 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -735,7 +735,7 @@ Call @match@ with all of this information!
-- p2 q2 -> ...
matchWrapper
- :: HsMatchContext GhcTc -- ^ For shadowing warning messages
+ :: HsMatchContextRn -- ^ For shadowing warning messages
-> Maybe [LHsExpr GhcTc] -- ^ Scrutinee(s)
-- see Note [matchWrapper scrutinees]
-> MatchGroup GhcTc (LHsExpr GhcTc) -- ^ Matches being desugared
@@ -898,7 +898,7 @@ the expression (in this case, it will end up recursively calling 'matchWrapper'
on the user-written case statement).
-}
-matchEquations :: HsMatchContext GhcTc
+matchEquations :: HsMatchContextRn
-> [MatchId] -> [EquationInfo] -> Type
-> DsM CoreExpr
matchEquations ctxt vars eqns_info rhs_ty
@@ -912,7 +912,7 @@ matchEquations ctxt vars eqns_info rhs_ty
-- situation where we want to match a single expression against a single
-- pattern. It returns an expression.
matchSimply :: CoreExpr -- ^ Scrutinee
- -> HsMatchContext GhcTc -- ^ Match kind
+ -> HsMatchContextRn -- ^ Match kind
-> Mult -- ^ Scaling factor of the case expression
-> LPat GhcTc -- ^ Pattern it should match
-> CoreExpr -- ^ Return this if it matches
@@ -935,7 +935,7 @@ matchSimply scrut hs_ctx mult pat result_expr fail_expr = do
match_result' <- matchSinglePat scrut hs_ctx pat mult rhs_ty match_result
extractMatchResult match_result' fail_expr
-matchSinglePat :: CoreExpr -> HsMatchContext GhcTc -> LPat GhcTc -> Mult
+matchSinglePat :: CoreExpr -> HsMatchContextRn -> LPat GhcTc -> Mult
-> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
-- matchSinglePat ensures that the scrutinee is a variable
-- and then calls matchSinglePatVar
@@ -956,7 +956,7 @@ matchSinglePat scrut hs_ctx pat mult ty match_result
matchSinglePatVar :: Id -- See Note [Match Ids]
-> Maybe CoreExpr -- ^ The scrutinee the match id is bound to
- -> HsMatchContext GhcTc -> LPat GhcTc
+ -> HsMatchContextRn -> LPat GhcTc
-> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
matchSinglePatVar var mb_scrut ctx pat ty match_result
= assertPpr (isInternalName (idName var)) (ppr var) $
diff --git a/compiler/GHC/HsToCore/Match.hs-boot b/compiler/GHC/HsToCore/Match.hs-boot
index 5ee1fbd0d666..31632225e3b3 100644
--- a/compiler/GHC/HsToCore/Match.hs-boot
+++ b/compiler/GHC/HsToCore/Match.hs-boot
@@ -5,7 +5,8 @@ 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, Mult )
+import GHC.Hs ( LPat, MatchGroup, LHsExpr, Mult )
+import GHC.Hs.Expr ( HsMatchContextRn )
import GHC.Hs.Extension ( GhcTc )
match :: [Id]
@@ -14,14 +15,14 @@ match :: [Id]
-> DsM (MatchResult CoreExpr)
matchWrapper
- :: HsMatchContext GhcTc
+ :: HsMatchContextRn
-> Maybe [LHsExpr GhcTc]
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchSimply
:: CoreExpr
- -> HsMatchContext GhcTc
+ -> HsMatchContextRn
-> Mult
-> LPat GhcTc
-> CoreExpr
@@ -31,7 +32,7 @@ matchSimply
matchSinglePatVar
:: Id
-> Maybe CoreExpr
- -> HsMatchContext GhcTc
+ -> HsMatchContextRn
-> LPat GhcTc
-> Type
-> MatchResult CoreExpr
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index 5b101f9560c9..dd331cf9abec 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -125,7 +125,7 @@ import qualified Data.Set as S
-}
data DsMatchContext
- = DsMatchContext (HsMatchContext GhcTc) SrcSpan
+ = DsMatchContext HsMatchContextRn SrcSpan
deriving ()
instance Outputable DsMatchContext where
diff --git a/compiler/GHC/HsToCore/Pmc.hs b/compiler/GHC/HsToCore/Pmc.hs
index fd6d813fc713..1b760e180ce6 100644
--- a/compiler/GHC/HsToCore/Pmc.hs
+++ b/compiler/GHC/HsToCore/Pmc.hs
@@ -128,7 +128,7 @@ pmcPatBind ctxt@(DsMatchContext match_ctxt loc) var p
-- | Exhaustive for guard matches, is used for guards in pattern bindings and
-- in @MultiIf@ expressions. Returns the 'Nablas' covered by the RHSs.
pmcGRHSs
- :: HsMatchContext GhcTc -- ^ Match context, for warning messages
+ :: HsMatchContextRn -- ^ Match context, for warning messages
-> GRHSs GhcTc (LHsExpr GhcTc) -- ^ The GRHSs to check
-> DsM (NonEmpty Nablas) -- ^ Covered 'Nablas' for each RHS, for long
-- distance info
diff --git a/compiler/GHC/HsToCore/Pmc/Utils.hs b/compiler/GHC/HsToCore/Pmc/Utils.hs
index ed8d3f2a8afd..95b5bfdc543b 100644
--- a/compiler/GHC/HsToCore/Pmc/Utils.hs
+++ b/compiler/GHC/HsToCore/Pmc/Utils.hs
@@ -65,13 +65,13 @@ allPmCheckWarnings =
]
-- | Check whether the redundancy checker should run (redundancy only)
-overlapping :: DynFlags -> HsMatchContext id -> Bool
+overlapping :: DynFlags -> HsMatchContext fn -> Bool
-- See Note [Inaccessible warnings for record updates]
overlapping _ RecUpd = False
overlapping dflags _ = wopt Opt_WarnOverlappingPatterns dflags
-- | Check whether the exhaustiveness checker should run (exhaustiveness only)
-exhaustive :: DynFlags -> HsMatchContext id -> Bool
+exhaustive :: DynFlags -> HsMatchContext fn -> Bool
exhaustive dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag
-- | Check whether unnecessary bangs should be warned about
@@ -81,7 +81,7 @@ redundantBang dflags = wopt Opt_WarnRedundantBangPatterns dflags
-- | Denotes whether an exhaustiveness check is supported, and if so,
-- via which 'WarningFlag' it's controlled.
-- Returns 'Nothing' if check is not supported.
-exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag
+exhaustiveWarningFlag :: HsMatchContext fn -> Maybe WarningFlag
exhaustiveWarningFlag FunRhs{} = Just Opt_WarnIncompletePatterns
exhaustiveWarningFlag CaseAlt = Just Opt_WarnIncompletePatterns
exhaustiveWarningFlag IfAlt = Just Opt_WarnIncompletePatterns
@@ -109,14 +109,14 @@ arrowMatchContextExhaustiveWarningFlag = \ case
-- | Check whether any part of pattern match checking is enabled for this
-- 'HsMatchContext' (does not matter whether it is the redundancy check or the
-- exhaustiveness check).
-isMatchContextPmChecked :: DynFlags -> Origin -> HsMatchContext id -> Bool
+isMatchContextPmChecked :: DynFlags -> Origin -> HsMatchContext fn -> Bool
isMatchContextPmChecked dflags origin ctxt
= requiresPMC origin
&& (overlapping dflags ctxt || exhaustive dflags ctxt)
-- | Check whether exhaustivity checks are enabled for this 'HsMatchContext',
-- when dealing with a single pattern (using the 'matchSinglePatVar' function).
-isMatchContextPmChecked_SinglePat :: DynFlags -> Origin -> HsMatchContext id -> LPat GhcTc -> Bool
+isMatchContextPmChecked_SinglePat :: DynFlags -> Origin -> HsMatchContext fn -> LPat GhcTc -> Bool
isMatchContextPmChecked_SinglePat dflags origin ctxt pat
| not (needToRunPmCheck dflags origin)
= False
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
index a7ac0bcaf246..eb87b024456d 100644
--- a/compiler/GHC/HsToCore/Utils.hs
+++ b/compiler/GHC/HsToCore/Utils.hs
@@ -459,7 +459,7 @@ For uniformity, calls to 'error' in both cases are wrapped even if -XLinearTypes
is disabled.
-}
-mkFailExpr :: HsMatchContext GhcTc -> Type -> DsM CoreExpr
+mkFailExpr :: HsMatchContextRn -> Type -> DsM CoreExpr
mkFailExpr ctxt ty
= mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)
@@ -736,7 +736,7 @@ work out well:
-- to select Many as the multiplicity of every let-expression introduced.
mkSelectorBinds :: [[CoreTickish]] -- ^ ticks to add, possibly
-> LPat GhcTc -- ^ The pattern
- -> HsMatchContext GhcTc -- ^ Where the pattern occurs
+ -> HsMatchContextRn -- ^ Where the pattern occurs
-> CoreExpr -- ^ Expression to which the pattern is bound
-> DsM (Id,[(Id,CoreExpr)])
-- ^ Id the rhs is bound to, for desugaring strict
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 4c4a04997c53..11bf27223885 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -928,28 +928,34 @@ instance ( HiePass p
) => ToHie (LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))) where
toHie (L span m ) = concatM $ makeNodeA m span : case m of
Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } ->
- [ toHie mctx
+ [ toHieHsMatchContext @p mctx
, let rhsScope = mkScope $ grhss_span grhss
in toHie $ patScopes Nothing rhsScope NoScope pats
, toHie grhss
]
-instance HiePass p => ToHie (HsMatchContext (GhcPass p)) where
- toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name'
- where
+toHieHsMatchContext :: forall p. HiePass p => HsMatchContext (LIdP (NoGhcTc (GhcPass p)))
+ -> HieM [HieAST Type]
+toHieHsMatchContext ctxt
+ = case ctxt of
+ FunRhs{mc_fun=name} -> toHie $ C MatchBind (get_name name)
+ StmtCtxt a -> toHieHsStmtContext @p a
+ _ -> pure []
+ where
-- See a paragraph about Haddock in #20415.
- name' :: LocatedN Name
- name' = case hiePass @p of
- HieRn -> name
- HieTc -> name
- toHie (StmtCtxt a) = toHie a
- toHie _ = pure []
-
-instance HiePass p => ToHie (HsStmtContext (GhcPass p)) where
- toHie (PatGuard a) = toHie a
- toHie (ParStmtCtxt a) = toHie a
- toHie (TransStmtCtxt a) = toHie a
- toHie _ = pure []
+ get_name :: LIdP (NoGhcTc (GhcPass p)) -> LocatedN Name
+ get_name name = case hiePass @p of
+ HieRn -> name
+ HieTc -> name
+
+toHieHsStmtContext :: forall p. HiePass p => HsStmtContext (LIdP (NoGhcTc (GhcPass p)))
+ -> HieM [HieAST Type]
+toHieHsStmtContext ctxt
+ = case ctxt of
+ PatGuard a -> toHieHsMatchContext @p a
+ ParStmtCtxt a -> toHieHsStmtContext @p a
+ TransStmtCtxt a -> toHieHsStmtContext @p a
+ _ -> pure []
instance HiePass p => ToHie (PScoped (LocatedA (Pat (GhcPass p)))) where
toHie (PS rsp scope pscope lpat@(L ospan opat)) =
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 75ebca80f8c5..7cab30d90591 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -58,7 +58,7 @@ module GHC.Parser.PostProcess (
checkPattern_details,
incompleteDoBlock,
ParseContext(..),
- checkMonadComp, -- P (HsStmtContext GhcPs)
+ checkMonadComp,
checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
checkValSigLhs,
LRuleTyTmVar, RuleTyTmVar(..),
@@ -2329,7 +2329,7 @@ data Frame
-- ^ If-expression: if p then x else y
| FrameCase LFrame [LFrameMatch]
-- ^ Case-expression: case x of { p1 -> e1; p2 -> e2 }
- | FrameDo (HsStmtContext GhcRn) [LFrameStmt]
+ | FrameDo HsStmtContextRn [LFrameStmt]
-- ^ Do-expression: do { s1; a <- s2; s3 }
...
| FrameExpr (HsExpr GhcPs) -- unambiguously an expression
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index f153b68ac359..51839e3a4395 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -1276,7 +1276,7 @@ type AnnoBody body
-- \cases expressions or commands. In that case, or if we encounter an empty
-- MatchGroup but -XEmptyCases is disabled, we add an error.
-rnMatchGroup :: (Outputable (body GhcPs), AnnoBody body) => HsMatchContext GhcRn
+rnMatchGroup :: (Outputable (body GhcPs), AnnoBody body) => HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> MatchGroup GhcPs (LocatedA (body GhcPs))
-> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars)
@@ -1292,14 +1292,14 @@ rnMatchGroup ctxt rnBody (MG { mg_alts = L lm ms, mg_ext = origin })
_ -> not <$> xoptM LangExt.EmptyCase
rnMatch :: AnnoBody body
- => HsMatchContext GhcRn
+ => HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> LMatch GhcPs (LocatedA (body GhcPs))
-> RnM (LMatch GhcRn (LocatedA (body GhcRn)), FreeVars)
rnMatch ctxt rnBody = wrapLocFstMA (rnMatch' ctxt rnBody)
rnMatch' :: (AnnoBody body)
- => HsMatchContext GhcRn
+ => HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> Match GhcPs (LocatedA (body GhcPs))
-> RnM (Match GhcRn (LocatedA (body GhcRn)), FreeVars)
@@ -1323,7 +1323,7 @@ rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss })
-}
rnGRHSs :: AnnoBody body
- => HsMatchContext GhcRn
+ => HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> GRHSs GhcPs (LocatedA (body GhcPs))
-> RnM (GRHSs GhcRn (LocatedA (body GhcRn)), FreeVars)
@@ -1333,13 +1333,13 @@ rnGRHSs ctxt rnBody (GRHSs _ grhss binds)
return (GRHSs emptyComments grhss' binds', fvGRHSs)
rnGRHS :: AnnoBody body
- => HsMatchContext GhcRn
+ => HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> LGRHS GhcPs (LocatedA (body GhcPs))
-> RnM (LGRHS GhcRn (LocatedA (body GhcRn)), FreeVars)
rnGRHS ctxt rnBody = wrapLocFstMA (rnGRHS' ctxt rnBody)
-rnGRHS' :: HsMatchContext GhcRn
+rnGRHS' :: HsMatchContextRn
-> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-> GRHS GhcPs (LocatedA (body GhcPs))
-> RnM (GRHS GhcRn (LocatedA (body GhcRn)), FreeVars)
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index b90b306d39fd..8a0bf59ff469 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -2345,16 +2345,13 @@ by the Opt_QualifiedDo dynamic flag.
-- Lookup operations for a qualified do. If the context is not a qualified
-- do, then use lookupSyntaxExpr. See Note [QualifiedDo].
-lookupQualifiedDoExpr :: HsStmtContext p -> Name -> RnM (HsExpr GhcRn, FreeVars)
+lookupQualifiedDoExpr :: HsStmtContext fn -> Name -> RnM (HsExpr GhcRn, FreeVars)
lookupQualifiedDoExpr ctxt std_name
= first nl_HsVar <$> lookupQualifiedDoName ctxt std_name
-- Like lookupQualifiedDoExpr but for producing SyntaxExpr.
-- See Note [QualifiedDo].
-lookupQualifiedDo
- :: HsStmtContext p
- -> Name
- -> RnM (SyntaxExpr GhcRn, FreeVars)
+lookupQualifiedDo :: HsStmtContext fn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
lookupQualifiedDo ctxt std_name
= first mkSyntaxExpr <$> lookupQualifiedDoExpr ctxt std_name
@@ -2364,10 +2361,7 @@ lookupNameWithQualifier std_name modName
; return (qname, unitFV qname) }
-- See Note [QualifiedDo].
-lookupQualifiedDoName
- :: HsStmtContext p
- -> Name
- -> RnM (Name, FreeVars)
+lookupQualifiedDoName :: HsStmtContext fn -> Name -> RnM (Name, FreeVars)
lookupQualifiedDoName ctxt std_name
= case qualifiedDoModuleName_maybe ctxt of
Nothing -> lookupSyntaxName std_name
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 36783056f32e..4f95d37354e2 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -1101,7 +1101,7 @@ type AnnoBody body
-- | Rename some Stmts
rnStmts :: AnnoBody body
- => HsStmtContext GhcRn
+ => HsStmtContextRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-- ^ How to rename the body of each statement (e.g. rnLExpr)
-> [LStmt GhcPs (LocatedA (body GhcPs))]
@@ -1137,14 +1137,14 @@ postProcessStmtsForApplicativeDo ctxt stmts
-- | strip the FreeVars annotations from statements
noPostProcessStmts
- :: HsStmtContext GhcRn
+ :: HsStmtContextRn
-> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
-> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet)
rnStmtsWithFreeVars :: AnnoBody body
- => HsStmtContext GhcRn
+ => HsStmtContextRn
-> ((body GhcPs) -> RnM ((body GhcRn), FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
@@ -1207,7 +1207,7 @@ At one point we failed to make this distinction, leading to #11216.
-}
rnStmt :: AnnoBody body
- => HsStmtContext GhcRn
+ => HsStmtContextRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-- ^ How to rename the body of the statement
-> LStmt GhcPs (LocatedA (body GhcPs))
@@ -1352,7 +1352,7 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for
rnStmt _ _ (L _ ApplicativeStmt{}) _ =
panic "rnStmt: ApplicativeStmt"
-rnParallelStmts :: forall thing. HsStmtContext GhcRn
+rnParallelStmts :: forall thing. HsStmtContextRn
-> SyntaxExpr GhcRn
-> [ParStmtBlock GhcPs GhcPs]
-> ([Name] -> RnM (thing, FreeVars))
@@ -1384,7 +1384,7 @@ rnParallelStmts ctxt return_op segs thing_inside
dupErr vs = addErr $ TcRnListComprehensionDuplicateBinding (NE.head vs)
-lookupQualifiedDoStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
+lookupQualifiedDoStmtName :: HsStmtContextRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
-- Like lookupStmtName, but respects QualifiedDo
lookupQualifiedDoStmtName ctxt n
= case qualifiedDoModuleName_maybe ctxt of
@@ -1392,7 +1392,7 @@ lookupQualifiedDoStmtName ctxt n
Just modName ->
first (mkSyntaxExpr . nl_HsVar) <$> lookupNameWithQualifier n modName
-lookupStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
+lookupStmtName :: HsStmtContextRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
-- Like lookupSyntax, but respects contexts
lookupStmtName ctxt n
| rebindableContext ctxt
@@ -1400,7 +1400,7 @@ lookupStmtName ctxt n
| otherwise
= return (mkRnSyntaxExpr n, emptyFVs)
-lookupStmtNamePoly :: HsStmtContext GhcRn -> Name -> RnM (HsExpr GhcRn, FreeVars)
+lookupStmtNamePoly :: HsStmtContextRn -> Name -> RnM (HsExpr GhcRn, FreeVars)
lookupStmtNamePoly ctxt name
| rebindableContext ctxt
= do { rebindable_on <- xoptM LangExt.RebindableSyntax
@@ -1416,7 +1416,7 @@ lookupStmtNamePoly ctxt name
-- | Is this a context where we respect RebindableSyntax?
-- but ListComp are never rebindable
-- Neither is ArrowExpr, which has its own desugarer in GHC.HsToCore.Arrows
-rebindableContext :: HsStmtContext GhcRn -> Bool
+rebindableContext :: HsStmtContextRn -> Bool
rebindableContext ctxt = case ctxt of
HsDoStmt flavour -> rebindableDoStmtContext flavour
ArrowExpr -> False
@@ -1472,7 +1472,7 @@ type Segment stmts = (Defs,
-- wrapper that does both the left- and right-hand sides
rnRecStmtsAndThen :: AnnoBody body
- => HsStmtContext GhcRn
+ => HsStmtContextRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-- assumes that the FreeVars returned includes
@@ -1577,7 +1577,7 @@ rn_rec_stmts_lhs fix_env stmts
-- right-hand-sides
rn_rec_stmt :: AnnoBody body =>
- HsStmtContext GhcRn
+ HsStmtContextRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [Name]
-> (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
@@ -1636,7 +1636,7 @@ rn_rec_stmt _ _ _ stmt@(L _ (ApplicativeStmt {}), _)
= pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)
rn_rec_stmts :: AnnoBody body
- => HsStmtContext GhcRn
+ => HsStmtContextRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [Name]
-> [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
@@ -1646,7 +1646,7 @@ rn_rec_stmts ctxt rnBody bndrs stmts
; return (concat segs_s) }
---------------------------------------------
-segmentRecStmts :: SrcSpan -> HsStmtContext GhcRn
+segmentRecStmts :: SrcSpan -> HsStmtContextRn
-> Stmt GhcRn (LocatedA (body GhcRn))
-> [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
-> (FreeVars, Bool)
@@ -1786,7 +1786,7 @@ in which case that function conservatively assumes that everything might well
be used later.
-}
-glomSegments :: HsStmtContext GhcRn
+glomSegments :: HsStmtContextRn
-> [Segment (LStmt GhcRn body)]
-> [Segment [LStmt GhcRn body]]
-- Each segment has a non-empty list of Stmts
@@ -2528,7 +2528,7 @@ isReturnApp monad_names (L loc e) mb_pure = case e of
************************************************************************
-}
-checkEmptyStmts :: HsStmtContext GhcRn -> RnM ()
+checkEmptyStmts :: HsStmtContextRn -> RnM ()
-- We've seen an empty sequence of Stmts... is that ok?
checkEmptyStmts ctxt
= mapM_ (addErr . TcRnEmptyStmtsGroup) mb_err
@@ -2542,7 +2542,7 @@ checkEmptyStmts ctxt
----------------------
checkLastStmt :: AnnoBody body
- => HsStmtContext GhcRn
+ => HsStmtContextRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> RnM (LStmt GhcPs (LocatedA (body GhcPs)))
checkLastStmt ctxt lstmt@(L loc stmt)
@@ -2574,7 +2574,7 @@ checkLastStmt ctxt lstmt@(L loc stmt)
-- Checking when a particular Stmt is ok
checkStmt :: AnnoBody body
- => HsStmtContext GhcRn
+ => HsStmtContextRn
-> LStmt GhcPs (LocatedA (body GhcPs))
-> RnM ()
checkStmt ctxt (L _ stmt)
@@ -2590,7 +2590,7 @@ emptyInvalid :: Validity' (Maybe LangExt.Extension)
emptyInvalid = NotValid Nothing -- Invalid, and no extension to suggest
okStmt, okDoStmt, okCompStmt, okParStmt
- :: DynFlags -> HsStmtContext GhcRn
+ :: DynFlags -> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity' (Maybe LangExt.Extension)
-- Return Nothing if OK, (Just extra) if not ok
-- The "extra" is an SDoc that is appended to a generic error message
@@ -2604,7 +2604,7 @@ okStmt dflags ctxt stmt
TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
okDoFlavourStmt
- :: DynFlags -> HsDoFlavour -> HsStmtContext GhcRn
+ :: DynFlags -> HsDoFlavour -> HsStmtContextRn
-> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity' (Maybe LangExt.Extension)
okDoFlavourStmt dflags flavour ctxt stmt = case flavour of
DoExpr{} -> okDoStmt dflags ctxt stmt
@@ -2675,7 +2675,7 @@ badIpBinds = TcRnIllegalImplicitParameterBindings
---------
monadFailOp :: LPat GhcPs
- -> HsStmtContext GhcRn
+ -> HsStmtContextRn
-> RnM (FailOperator GhcRn, FreeVars)
monadFailOp pat ctxt = do
dflags <- getDynFlags
@@ -2726,7 +2726,7 @@ using fromString:
Nothing -> M.fail (fromString "Pattern match error")
-}
-getMonadFailOp :: HsStmtContext p -> RnM (FailOperator GhcRn, FreeVars) -- Syntax expr fail op
+getMonadFailOp :: HsStmtContext fn -> RnM (FailOperator GhcRn, FreeVars) -- Syntax expr fail op
getMonadFailOp ctxt
= do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags
; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags
diff --git a/compiler/GHC/Rename/Expr.hs-boot b/compiler/GHC/Rename/Expr.hs-boot
index 8a077146a098..b73e50eae2b1 100644
--- a/compiler/GHC/Rename/Expr.hs-boot
+++ b/compiler/GHC/Rename/Expr.hs-boot
@@ -18,7 +18,7 @@ type AnnoBody body
)
rnStmts :: --forall thing body.
- AnnoBody body => HsStmtContext GhcRn
+ AnnoBody body => HsStmtContextRn
-> (body GhcPs -> RnM (body GhcRn, FreeVars))
-> [LStmt GhcPs (LocatedA (body GhcPs))]
-> ([Name] -> RnM (thing, FreeVars))
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index 211d872ecfca..5665c282b9eb 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -227,7 +227,7 @@ isTopRecNameMaker _ = False
localRecNameMaker :: MiniFixityEnv -> NameMaker
localRecNameMaker fix_env = LetMk NotTopLevel fix_env
-matchNameMaker :: HsMatchContext a -> NameMaker
+matchNameMaker :: HsMatchContext fn -> NameMaker
matchNameMaker ctxt = LamMk report_unused
where
-- Do not report unused names in interactive contexts
@@ -418,7 +418,7 @@ There are various entry points to renaming patterns, depending on
-- * unused and duplicate checking
-- * no fixities
rnPats :: Traversable f
- => HsMatchContext GhcRn -- for error messages
+ => HsMatchContextRn -- For error messages
-> f (LPat GhcPs)
-> (f (LPat GhcRn) -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
@@ -445,10 +445,10 @@ rnPats ctxt pats thing_inside
; thing_inside pats' } }
where
doc_pat = text "In" <+> pprMatchContext ctxt
-{-# SPECIALIZE rnPats :: HsMatchContext GhcRn -> [LPat GhcPs] -> ([LPat GhcRn] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) #-}
-{-# SPECIALIZE rnPats :: HsMatchContext GhcRn -> Identity (LPat GhcPs) -> (Identity (LPat GhcRn) -> RnM (a, FreeVars)) -> RnM (a, FreeVars) #-}
+{-# SPECIALIZE rnPats :: HsMatchContextRn -> [LPat GhcPs] -> ([LPat GhcRn] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) #-}
+{-# SPECIALIZE rnPats :: HsMatchContextRn -> Identity (LPat GhcPs) -> (Identity (LPat GhcRn) -> RnM (a, FreeVars)) -> RnM (a, FreeVars) #-}
-rnPat :: HsMatchContext GhcRn -- for error messages
+rnPat :: HsMatchContextRn -- For error messages
-> LPat GhcPs
-> (LPat GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars) -- Variables bound by pattern do not
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index ea01e8195741..88807e5821c1 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -817,7 +817,7 @@ genSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA,
Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ EpAnnCO)
- => HsMatchContext (GhcPass p)
+ => HsMatchContext (LIdP (NoGhcTc (GhcPass p)))
-> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
genSimpleMatch ctxt pats rhs
diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs
index 9b5032531c61..2503cc5c2960 100644
--- a/compiler/GHC/Tc/Deriv/Functor.hs
+++ b/compiler/GHC/Tc/Deriv/Functor.hs
@@ -247,7 +247,7 @@ gen_Functor_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon
-- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
match_for_con :: Monad m
- => HsMatchContext GhcPs
+ => HsMatchContextPs
-> [LPat GhcPs] -> DataCon
-> [LHsExpr GhcPs -> m (LHsExpr GhcPs)]
-> m (LMatch GhcPs (LHsExpr GhcPs))
@@ -629,7 +629,7 @@ mkSimpleLam2 lam =
-- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@
-- and its arguments, applying an expression (from @insides@) to each of the
-- respective arguments of @con@.
-mkSimpleConMatch :: Monad m => HsMatchContext GhcPs
+mkSimpleConMatch :: Monad m => HsMatchContextPs
-> (RdrName -> [a] -> m (LHsExpr GhcPs))
-> [LPat GhcPs]
-> DataCon
@@ -664,7 +664,7 @@ mkSimpleConMatch ctxt fold extra_pats con insides = do
--
-- See Note [Generated code for DeriveFoldable and DeriveTraversable]
mkSimpleConMatch2 :: Monad m
- => HsMatchContext GhcPs
+ => HsMatchContextPs
-> (LHsExpr GhcPs -> [LHsExpr GhcPs]
-> m (LHsExpr GhcPs))
-> [LPat GhcPs]
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 9f197aac0175..c855e6d3dc58 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -1040,7 +1040,7 @@ data TcRnMessage where
Test cases: typecheck/should_compile/T11339
-}
- TcRnOverloadedSig :: TcIdSigInfo -> TcRnMessage
+ TcRnOverloadedSig :: TcIdSig -> TcRnMessage
{-| TcRnTupleConstraintInst is an error that occurs whenever an instance
for a tuple constraint is specified.
@@ -2403,7 +2403,7 @@ data TcRnMessage where
typecheck/should_fail/T20768_fail
-}
TcRnMatchesHaveDiffNumArgs
- :: !(HsMatchContext GhcTc) -- ^ Pattern match specifics
+ :: !HsMatchContextRn -- ^ Pattern match specifics
-> !MatchArgBadMatches
-> TcRnMessage
@@ -2878,7 +2878,7 @@ data TcRnMessage where
parser/should_fail/readFail028
-}
TcRnLastStmtNotExpr
- :: HsStmtContext GhcRn
+ :: HsStmtContextRn
-> UnexpectedStatement
-> TcRnMessage
@@ -2892,7 +2892,7 @@ data TcRnMessage where
parser/should_fail/readFail043
-}
TcRnUnexpectedStatementInContext
- :: HsStmtContext GhcRn
+ :: HsStmtContextRn
-> UnexpectedStatement
-> Maybe LangExt.Extension
-> TcRnMessage
@@ -3009,7 +3009,7 @@ data TcRnMessage where
Test cases: rename/should_fail/RnEmptyCaseFail
-}
- TcRnEmptyCase :: HsMatchContext GhcRn -> TcRnMessage
+ TcRnEmptyCase :: HsMatchContextRn -> TcRnMessage
{-| TcRnNonStdGuards is a warning thrown when a user uses
non-standard guards (e.g. patterns in guards) without
@@ -5813,7 +5813,7 @@ data MatchArgsContext
= EquationArgs
!Name -- ^ Name of the function
| PatternArgs
- !(HsMatchContext GhcTc) -- ^ Pattern match specifics
+ !HsMatchContextRn -- ^ Pattern match specifics
-- | The information necessary to report mismatched
-- numbers of arguments in a match group.
diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs
index ce8779665203..7387cd7275ca 100644
--- a/compiler/GHC/Tc/Gen/App.hs
+++ b/compiler/GHC/Tc/Gen/App.hs
@@ -606,6 +606,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
= go delta acc so_far fun_ty rest_args
-- Rule IALL from Fig 4 of the QL paper
+ -- Instantiate invisible foralls and dictionaries.
-- c.f. GHC.Tc.Utils.Instantiate.topInstantiate
go1 delta acc so_far fun_ty args
| (tvs, body1) <- tcSplitSomeForAllTyVars (inst_fun args) fun_ty
@@ -674,10 +675,10 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
-- Suppose b is instantiated by kappa. Then we want to make fresh
-- instantiation variables nu1, nu2, and set kappa := nu1 -> nu2
--
- -- In principle what is happening here is not unlike matchActualFunTysRho
+ -- In principle what is happening here is not unlike matchActualFunTys
-- but there are many small differences:
-- - We know that the function type in unfilled meta-tyvar
- -- matchActualFunTysRho is much more general, has a loop, etc.
+ -- matchActualFunTys is much more general, has a loop, etc.
-- - We must be sure to actually update the variable right now,
-- not defer in any way, because this is a QL instantiation variable.
-- - We need the freshly allocated unification variables, to extend
@@ -686,7 +687,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
do { let val_args = leadingValArgs args
val_args_count = length val_args
- -- Create metavariables for the arguments. Following matchActualFunTySigma,
+ -- Create metavariables for the arguments. Following matchActualFunTy,
-- we create nu_i :: TYPE kappa_i[conc], ensuring that the arguments
-- have concrete runtime representations.
-- When we come to unify the nus (in qlUnify), we will call
@@ -723,21 +724,20 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
VAExpansion (OrigStmt{}) _ _ -> ExpectedFunTySyntaxOp DoOrigin tc_fun
_ -> ExpectedFunTyArg (HsExprTcThing tc_fun) (unLoc arg)
; (wrap, arg_ty, res_ty) <-
- -- NB: matchActualFunTySigma does the rep-poly check.
+ -- NB: matchActualFunTy does the rep-poly check.
-- For example, suppose we have f :: forall r (a::TYPE r). a -> Int
-- In an application (f x), we need 'x' to have a fixed runtime
- -- representation; matchActualFunTySigma checks that when
+ -- representation; matchActualFunTy checks that when
-- taking apart the arrow type (a -> Int).
- matchActualFunTySigma
- herald
+ matchActualFunTy herald
(Just $ HsExprTcThing tc_fun)
(n_val_args, so_far) fun_ty
; (delta', arg') <- if do_ql
- then addArgCtxt ctxt arg $
- -- Context needed for constraints
- -- generated by calls in arg
- quickLookArg delta arg arg_ty
- else return (delta, ValArg arg)
+ then addArgCtxt ctxt arg $
+ -- Context needed for constraints
+ -- generated by calls in arg
+ quickLookArg delta arg arg_ty
+ else return (delta, ValArg arg)
; let acc' = eva { eva_arg = arg', eva_arg_ty = arg_ty }
: addArgWrap wrap acc
; go delta' acc' (arg_ty:so_far) res_ty rest_args }
@@ -1304,7 +1304,7 @@ Proposal #281.
Typechecking type abstractions
------------------------------
-Type abstractions are checked alongside ordinary patterns in GHC.Tc.Gen.Pat.tcPats.
+Type abstractions are checked alongside ordinary patterns in GHC.Tc.Gen.Pat.tcMatchPats.
One of its inputs is a list of ExpPatType that has two constructors
* ExpFunPatTy ... -- the type A of a function A -> B
* ExpForAllPatTy ... -- the binder (a::A) of forall (a::A) -> B
diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs
index aa76e3948ac0..9de6772ca67f 100644
--- a/compiler/GHC/Tc/Gen/Arrow.hs
+++ b/compiler/GHC/Tc/Gen/Arrow.hs
@@ -319,9 +319,9 @@ tcCmdMatches :: CmdEnv
-> CmdType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc))
tcCmdMatches env scrut_ty matches (stk, res_ty)
- = tcMatchesCase match_body_checker (unrestricted scrut_ty) matches (mkCheckExpType res_ty)
+ = tcCaseMatches tc_body (unrestricted scrut_ty) matches (mkCheckExpType res_ty)
where
- match_body_checker body res_ty' = do { res_ty' <- expTypeToType res_ty'
+ tc_body body res_ty' = do { res_ty' <- expTypeToType res_ty'
; tcCmd env body (stk, res_ty') }
-- | Typechecking for 'HsCmdLam' and 'HsCmdLamCase'.
@@ -352,7 +352,7 @@ tcCmdMatchLambda env
-- Check the patterns, and the GRHSs inside
tc_match arg_tys cmd_stk' (L mtch_loc (Match { m_pats = pats, m_grhss = grhss }))
= do { (pats', grhss') <- setSrcSpanA mtch_loc $
- tcPats match_ctxt pats (map ExpFunPatTy arg_tys) $
+ tcMatchPats match_ctxt pats (map ExpFunPatTy arg_tys) $
tc_grhss grhss cmd_stk' (mkCheckExpType res_ty)
; return $ L mtch_loc (Match { m_ext = noAnn
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index 9bfbcdbb1d8e..f6bf57bbf6f3 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -23,7 +23,7 @@ where
import GHC.Prelude
-import {-# SOURCE #-} GHC.Tc.Gen.Match ( tcGRHSsPat, tcMatchesFun )
+import {-# SOURCE #-} GHC.Tc.Gen.Match ( tcGRHSsPat, tcFunBindMatches )
import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcCheckMonoExpr )
import {-# SOURCE #-} GHC.Tc.TyCl.PatSyn ( tcPatSynDecl, tcPatSynBuilderBind )
@@ -615,16 +615,14 @@ tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
********************************************************************* -}
tcPolyCheck :: TcPragEnv
- -> TcIdSigInfo -- Must be a complete signature
+ -> TcCompleteSig
-> LHsBind GhcRn -- Must be a FunBind
-> TcM (LHsBinds GhcTc, [Scaled TcId])
-- There is just one binding,
-- it is a FunBind
-- it has a complete type signature,
tcPolyCheck prag_fn
- (CompleteSig { sig_bndr = poly_id
- , sig_ctxt = ctxt
- , sig_loc = sig_loc })
+ (CSig { sig_bndr = poly_id, sig_ctxt = ctxt, sig_loc = sig_loc })
(L bind_loc (FunBind { fun_id = L nm_loc name
, fun_matches = matches }))
= do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc)
@@ -642,11 +640,11 @@ tcPolyCheck prag_fn
let mono_id = mkLocalId mono_name (varMult poly_id) rho_ty in
tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $
-- Why mono_id in the BinderStack?
- -- See Note [Relevant bindings and the binder stack]
+ -- See Note [Relevant bindings and the binder stack]
setSrcSpanA bind_loc $
- tcMatchesFun (L nm_loc (idName mono_id)) mult matches
- (mkCheckExpType rho_ty)
+ tcFunBindMatches (L nm_loc (idName mono_id)) mult matches
+ (mkCheckExpType rho_ty)
-- We make a funny AbsBinds, abstracting over nothing,
-- just so we have somewhere to put the SpecPrags.
@@ -664,8 +662,7 @@ tcPolyCheck prag_fn
; let bind' = FunBind { fun_id = L nm_loc poly_id2
, fun_matches = matches'
- , fun_ext = (wrap_gen <.> wrap_res, tick)
- }
+ , fun_ext = (wrap_gen <.> wrap_res, tick) }
export = ABE { abe_wrap = idHsWrapper
, abe_poly = poly_id
@@ -833,8 +830,8 @@ checkMonomorphismRestriction mbis lbinds
no_mr_name (MBI { mbi_sig = Just sig })
| TISI { sig_inst_sig = info, sig_inst_theta = theta, sig_inst_wcx = wcx } <- sig
= case info of
- CompleteSig { sig_bndr = bndr } -> Just (idName bndr)
- PartialSig { psig_name = nm }
+ TcCompleteSig (CSig { sig_bndr = bndr }) -> Just (idName bndr)
+ TcPartialSig (PSig { psig_name = nm })
| null theta, isNothing wcx -> Nothing -- f :: _ -> _
| otherwise -> Just nm -- f :: Num a => a -> _
-- For the latter case, we don't want the MR:
@@ -862,13 +859,12 @@ checkOverloadedSig :: MonoBindInfo -> TcM ()
-- The MR applies, but the signature is overloaded, and it's
-- best to complain about this directly
-- c.f #11339
-checkOverloadedSig (MBI { mbi_sig = mb_sig })
- | Just (TISI { sig_inst_sig = orig_sig, sig_inst_theta = theta, sig_inst_wcx = wcx }) <- mb_sig
+checkOverloadedSig (MBI { mbi_sig = Just sig })
+ | TISI { sig_inst_sig = orig_sig, sig_inst_theta = theta, sig_inst_wcx = wcx } <- sig
, not (null theta && isNothing wcx)
- = setSrcSpan (sig_loc orig_sig) $
+ = setSrcSpan (tcIdSigLoc orig_sig) $
failWith $ TcRnOverloadedSig orig_sig
- | otherwise
- = return ()
+checkOverloadedSig _ = return ()
{- Note [When the MR applies]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -988,7 +984,7 @@ mkInferredPolyId :: WantedConstraints -- the residual constraints, already emi
-> TcM TcId
mkInferredPolyId residual insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty
| Just (TISI { sig_inst_sig = sig }) <- mb_sig_inst
- , CompleteSig { sig_bndr = poly_id } <- sig
+ , TcCompleteSig (CSig { sig_bndr = poly_id }) <- sig
= return poly_id
| otherwise -- Either no type sig or partial type sig
@@ -1047,10 +1043,9 @@ chooseInferredQuantifiers _residual inferred_theta tau_tvs qtvs Nothing
; return (binders, my_theta) }
chooseInferredQuantifiers residual inferred_theta tau_tvs qtvs
- (Just (TISI { sig_inst_sig = sig@(PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty })
- , sig_inst_wcx = wcx
- , sig_inst_theta = annotated_theta
- , sig_inst_skols = annotated_tvs }))
+ (Just (TISI { sig_inst_sig = sig, sig_inst_wcx = wcx
+ , sig_inst_theta = annotated_theta, sig_inst_skols = annotated_tvs }))
+ | TcPartialSig (PSig { psig_name = fn_name, psig_hs_ty = hs_ty }) <- sig
= -- Choose quantifiers for a partial type signature
do { let (psig_qtv_nms, psig_qtv_bndrs) = unzip annotated_tvs
; psig_qtv_bndrs <- liftZonkM $ mapM zonkInvisTVBinder psig_qtv_bndrs
@@ -1063,14 +1058,15 @@ chooseInferredQuantifiers residual inferred_theta tau_tvs qtvs
-- Check whether the quantified variables of the
-- partial signature have been unified together
-- See Note [Quantified variables in partial type signatures]
- ; mapM_ report_dup_tyvar_tv_err (findDupTyVarTvs psig_qtv_prs)
+ ; mapM_ (report_dup_tyvar_tv_err fn_name hs_ty) $
+ findDupTyVarTvs psig_qtv_prs
-- Check whether a quantified variable of the partial type
-- signature is not actually quantified. How can that happen?
-- See Note [Quantification and partial signatures] Wrinkle 4
-- in GHC.Tc.Solver
- ; mapM_ report_mono_sig_tv_err [ pr | pr@(_,tv) <- psig_qtv_prs
- , not (tv `elem` qtvs) ]
+ ; mapM_ (report_mono_sig_tv_err fn_name hs_ty)
+ [ pr | pr@(_,tv) <- psig_qtv_prs, not (tv `elem` qtvs) ]
; annotated_theta <- liftZonkM $ zonkTcTypes annotated_theta
; (free_tvs, my_theta) <- choose_psig_context psig_qtv_set annotated_theta wcx
@@ -1147,10 +1143,10 @@ chooseInferredQuantifiers residual inferred_theta tau_tvs qtvs
-- Return (annotated_theta ++ diff_theta)
-- See Note [Extra-constraints wildcards]
- report_dup_tyvar_tv_err (n1,n2)
+ report_dup_tyvar_tv_err fn_name hs_ty (n1,n2)
= addErrTc (TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty)
- report_mono_sig_tv_err (n,tv)
+ report_mono_sig_tv_err fn_name hs_ty (n,tv)
= addErrTc (TcRnPartialTypeSigBadQuantifier n fn_name m_unif_ty hs_ty)
where
m_unif_ty = listToMaybe
@@ -1163,7 +1159,7 @@ chooseInferredQuantifiers residual inferred_theta tau_tvs qtvs
, Just lhs_tv <- [ getTyVar_maybe lhs ]
, lhs_tv == tv ]
-chooseInferredQuantifiers _ _ _ _ (Just (TISI { sig_inst_sig = sig@(CompleteSig {}) }))
+chooseInferredQuantifiers _ _ _ _ (Just sig)
= pprPanic "chooseInferredQuantifiers" (ppr sig)
mk_inf_msg :: Name -> TcType -> TidyEnv -> ZonkM (TidyEnv, SDoc)
@@ -1370,19 +1366,20 @@ tcMonoBinds is_rec sig_fn no_gen
; ((co_fn, matches'), rhs_ty')
<- tcInferFRR (FRRBinder name) $ \ exp_ty ->
- -- tcInferFRR: the type of a let-binder must have
- -- a fixed runtime rep. See #23176
- tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $
- -- We extend the error context even for a non-recursive
- -- function so that in type error messages we show the
- -- type of the thing whose rhs we are type checking
- tcMatchesFun (L nm_loc name) mult matches exp_ty
+ -- tcInferFRR: the type of a let-binder must have
+ -- a fixed runtime rep. See #23176
+ tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $
+ -- We extend the error context even for a non-recursive
+ -- function so that in type error messages we show the
+ -- type of the thing whose rhs we are type checking.
+ -- See Note [Relevant bindings and the binder stack]
+ tcFunBindMatches (L nm_loc name) mult matches exp_ty
; mono_id <- newLetBndr no_gen name mult rhs_ty'
; return (unitBag $ L b_loc $
- FunBind { fun_id = L nm_loc mono_id,
+ FunBind { fun_id = L nm_loc mono_id,
fun_matches = matches',
- fun_ext = (co_fn, []) },
+ fun_ext = (co_fn, []) },
[MBI { mbi_poly_name = name
, mbi_sig = Nothing
, mbi_mono_id = mono_id
@@ -1603,7 +1600,7 @@ tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_mult = mult_a
bndr_names = collectPatBinders CollNoDictBinders pat
(nosig_names, sig_names) = partitionWith find_sig bndr_names
- find_sig :: Name -> Either Name (Name, TcIdSigInfo)
+ find_sig :: Name -> Either Name (Name, TcIdSig)
find_sig name = case sig_fn name of
Just (TcIdSig sig) -> Right (name, sig)
_ -> Left name
@@ -1625,7 +1622,7 @@ lookupMBI name
, mbi_mono_mult = idMult mono_id }) }
-------------------
-tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo
+tcLhsSigId :: LetBndrSpec -> (Name, TcIdSig) -> TcM MonoBindInfo
tcLhsSigId no_gen (name, sig)
= do { inst_sig <- tcInstSig sig
; mono_id <- newSigLetBndr no_gen name inst_sig
@@ -1637,7 +1634,7 @@ tcLhsSigId no_gen (name, sig)
------------
newSigLetBndr :: LetBndrSpec -> Name -> TcIdSigInst -> TcM TcId
newSigLetBndr (LetGblBndr prags) name (TISI { sig_inst_sig = id_sig })
- | CompleteSig { sig_bndr = poly_id } <- id_sig
+ | TcCompleteSig (CSig { sig_bndr = poly_id }) <- id_sig
= addInlinePrags poly_id (lookupPragEnv prags name)
newSigLetBndr no_gen name (TISI { sig_inst_tau = tau })
= newLetBndr no_gen name ManyTy tau
@@ -1652,11 +1649,11 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
= tcExtendIdBinderStackForRhs [info] $
tcExtendTyVarEnvForRhs mb_sig $
do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
- ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) (idName mono_id)) mult
- matches (mkCheckExpType $ idType mono_id)
- ; return ( FunBind { fun_id = L (noAnnSrcSpan loc) mono_id
+ ; (co_fn, matches') <- tcFunBindMatches (L (noAnnSrcSpan loc) (idName mono_id)) mult
+ matches (mkCheckExpType $ idType mono_id)
+ ; return ( FunBind { fun_id = L (noAnnSrcSpan loc) mono_id
, fun_matches = matches'
- , fun_ext = (co_fn, [])
+ , fun_ext = (co_fn, [])
} ) }
tcRhs (TcPatBind infos pat' mult mult_ann grhss pat_ty)
@@ -1849,7 +1846,7 @@ data GeneralisationPlan
| CheckGen -- One FunBind with a complete signature:
(LHsBind GhcRn) -- do explicit generalisation
- TcIdSigInfo -- Always CompleteSig
+ TcCompleteSig
-- A consequence of the no-AbsBinds choice (NoGen) is that there is
-- no "polymorphic Id" and "monmomorphic Id"; there is just the one
@@ -1888,7 +1885,7 @@ decideGeneralisationPlan dflags top_lvl closed sig_fn lbinds
-- except a single function binding with a complete signature
one_funbind_with_sig
| [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds
- , Just (TcIdSig sig@(CompleteSig {})) <- sig_fn (unLoc v)
+ , Just (TcIdSig (TcCompleteSig sig)) <- sig_fn (unLoc v)
= Just (lbind, sig)
| otherwise
= Nothing
@@ -1896,8 +1893,8 @@ decideGeneralisationPlan dflags top_lvl closed sig_fn lbinds
binders = collectHsBindListBinders CollNoDictBinders lbinds
has_partial_sigs = any has_partial_sig binders
has_partial_sig nm = case sig_fn nm of
- Just (TcIdSig (PartialSig {})) -> True
- _ -> False
+ Just (TcIdSig (TcPartialSig {})) -> True
+ _ -> False
has_mult_anns_and_pats = any has_mult_ann_and_pat lbinds
has_mult_ann_and_pat (L _ (PatBind{pat_mult=HsNoMultAnn{}})) = False
has_mult_ann_and_pat (L _ (PatBind{pat_lhs=(L _ (VarPat{}))})) = False
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index b63e0862af10..b8c7fd49635f 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -117,7 +117,7 @@ tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType
-> TcM (LHsExpr GhcTc)
tcPolyLExpr (L loc expr) res_ty
- = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad
+ = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad
addExprCtxt expr $ -- Note [Error contexts in generated code]
do { expr' <- tcPolyExpr expr res_ty
; return (L loc expr') }
@@ -262,7 +262,7 @@ tcExpr e@(HsIPVar _ x) res_ty
origin = IPOccOrigin x
tcExpr e@(HsLam x lam_variant matches) res_ty
- = do { (wrap, matches') <- tcMatchLambda herald matches res_ty
+ = do { (wrap, matches') <- tcLambdaMatches herald matches res_ty
; return (mkHsWrap wrap $ HsLam x lam_variant matches') }
where
herald = ExpectedFunTyLam lam_variant e
@@ -365,7 +365,7 @@ tcExpr (HsCase ctxt scrut matches) res_ty
mult <- newFlexiTyVarTy multiplicityTy
-- Typecheck the scrutinee. We use tcInferRho but tcInferSigma
- -- would also be possible (tcMatchesCase accepts sigma-types)
+ -- would also be possible (tcCaseMatches accepts sigma-types)
-- Interesting litmus test: do these two behave the same?
-- case id of {..}
-- case (\v -> v) of {..}
@@ -373,7 +373,7 @@ tcExpr (HsCase ctxt scrut matches) res_ty
; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut
; hasFixedRuntimeRep_syntactic FRRCase scrut_ty
- ; (mult_co_wrap, matches') <- tcMatchesCase tcBody (Scaled mult scrut_ty) matches res_ty
+ ; (mult_co_wrap, matches') <- tcCaseMatches tcBody (Scaled mult scrut_ty) matches res_ty
; return (HsCase ctxt (mkLHsWrap mult_co_wrap scrut') matches') }
tcExpr (HsIf x pred b1 b2) res_ty
@@ -895,8 +895,8 @@ tcSynArgA :: CtOrigin
-- and a wrapper to be applied to the overall expression
tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside
= do { (match_wrapper, arg_tys, res_ty)
- <- matchActualFunTysRho herald orig Nothing
- (length arg_shapes) sigma_ty
+ <- matchActualFunTys herald orig Nothing
+ (length arg_shapes) sigma_ty
-- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)
; ((result, res_wrapper), arg_wrappers)
<- tc_syn_args_e (map scaledThing arg_tys) arg_shapes $ \ arg_results arg_res_mults ->
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index 02157ffa7bfc..e5d7d7a4c996 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -421,7 +421,7 @@ rebuild_hs_apps fun ctxt (arg : args)
We cannot have representation-polymorphic or levity-polymorphic
function arguments. See Note [Representation polymorphism invariants]
in GHC.Core. That is checked in 'GHC.Tc.Gen.App.tcInstFun', see the call
-to 'matchActualFunTySigma', which performs the representation-polymorphism
+to 'matchActualFunTy', which performs the representation-polymorphism
check.
However, some special Ids have representation-polymorphic argument
@@ -1003,15 +1003,15 @@ tcExprWithSig expr hs_ty
loc = getLocA (dropWildCards hs_ty)
ctxt = ExprSigCtxt (lhsSigWcTypeContextSpan hs_ty)
-tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcSigmaType)
-tcExprSig ctxt expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })
+tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSig -> TcM (LHsExpr GhcTc, TcSigmaType)
+tcExprSig ctxt expr (TcCompleteSig (CSig { sig_bndr = poly_id, sig_loc = loc }))
= setSrcSpan loc $ -- Sets the location for the implication constraint
do { let poly_ty = idType poly_id
; (wrap, expr') <- tcSkolemiseScoped ctxt poly_ty $ \rho_ty ->
tcCheckMonoExprNC expr rho_ty
; return (mkLHsWrap wrap expr', poly_ty) }
-tcExprSig _ expr sig@(PartialSig { psig_name = name, sig_loc = loc })
+tcExprSig _ expr sig@(TcPartialSig (PSig { psig_name = name, psig_loc = loc }))
= setSrcSpan loc $ -- Sets the location for the implication constraint
do { (tclvl, wanted, (expr', sig_inst))
<- pushLevelAndCaptureConstraints $
@@ -1102,8 +1102,8 @@ tcInferOverLit lit@(OverLit { ol_val = val
thing = NameThing from_name
mb_thing = Just thing
herald = ExpectedFunTyArg thing (HsLit noAnn hs_lit)
- ; (wrap2, sarg_ty, res_ty) <- matchActualFunTySigma herald mb_thing
- (1, []) from_ty
+ ; (wrap2, sarg_ty, res_ty) <- matchActualFunTy herald mb_thing
+ (1, []) from_ty
; co <- unifyType mb_thing (hsLitType hs_lit) (scaledThing sarg_ty)
-- See Note [Source locations for implicit function calls] in GHC.Iface.Ext.Ast
@@ -1396,7 +1396,7 @@ Wrinkles
A. Any arguments to such lambda abstractions are guaranteed to have
a fixed runtime representation. This is enforced in 'tcApp' by
- 'matchActualFunTySigma'.
+ 'matchActualFunTy'.
B. If there are fewer arguments than there are bound term variables,
we will ensure that the appropriate type arguments are instantiated
@@ -1639,7 +1639,7 @@ addStmtCtxt stmt thing_inside
= do let err_doc = pprStmtInCtxt (HsDoStmt (DoExpr Nothing)) stmt
addErrCtxt err_doc thing_inside
where
- pprStmtInCtxt :: HsStmtContext GhcRn -> StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> SDoc
+ pprStmtInCtxt :: HsStmtContextRn -> StmtLR GhcRn GhcRn (LHsExpr GhcRn) -> SDoc
pprStmtInCtxt ctxt stmt
= vcat [ hang (text "In a stmt of"
<+> pprAStmtContext ctxt <> colon) 2 (pprStmt stmt)
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index d216e80e3336..c45200d1321e 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -16,11 +16,11 @@
-- | Typecheck some @Matches@
module GHC.Tc.Gen.Match
- ( tcMatchesFun
+ ( tcFunBindMatches
, tcGRHS
, tcGRHSsPat
- , tcMatchesCase
- , tcMatchLambda
+ , tcCaseMatches
+ , tcLambdaMatches
, TcMatchAltChecker
, TcStmtChecker
, TcExprStmtChecker
@@ -90,30 +90,30 @@ import qualified GHC.LanguageExtensions as LangExt
{-
************************************************************************
* *
-\subsection{tcMatchesFun, tcMatchesCase}
+\subsection{tcFunBindMatches, tcCaseMatches}
* *
************************************************************************
-@tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
-@FunMonoBind@. The second argument is the name of the function, which
+`tcFunBindMatches` typechecks a `[Match]` list which occurs in a
+`FunMonoBind`. The second argument is the name of the function, which
is used in error messages. It checks that all the equations have the
-same number of arguments before using @tcMatches@ to do the work.
+same number of arguments before using `tcMatches` to do the work.
-}
-tcMatchesFun :: LocatedN Name -- MatchContext Id
- -> Mult -- The multiplicity of the binder
- -> MatchGroup GhcRn (LHsExpr GhcRn)
- -> ExpRhoType -- Expected type of function
- -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
- -- Returns type of body
-tcMatchesFun fun_name mult matches exp_ty
+tcFunBindMatches :: LocatedN Name -- MatchContext Id
+ -> Mult -- The multiplicity of the binder
+ -> MatchGroup GhcRn (LHsExpr GhcRn)
+ -> ExpRhoType -- Expected type of function
+ -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
+ -- Returns type of body
+tcFunBindMatches fun_name mult matches exp_ty
= do { -- Check that they all have the same no of arguments
-- Location is in the monad, set the caller so that
-- any inter-equation error messages get some vaguely
-- sensible location. Note: we have to do this odd
-- ann-grabbing, because we don't always have annotations in
- -- hand when we call tcMatchesFun...
- traceTc "tcMatchesFun" (ppr fun_name $$ ppr mult $$ ppr exp_ty $$ ppr arity)
+ -- hand when we call tcFunBindMatches...
+ traceTc "tcFunBindMatches" (ppr fun_name $$ ppr mult $$ ppr exp_ty $$ ppr arity)
; checkArgCounts (Just what) matches
; (wrapper, (mult_co_wrap, r)) <- matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty ->
@@ -138,27 +138,27 @@ tcMatchesFun fun_name mult matches exp_ty
= NoSrcStrict
{-
-@tcMatchesCase@ doesn't do the argument-count check because the
+@tcCaseMatches@ doesn't do the argument-count check because the
parser guarantees that each equation has exactly one argument.
-}
-tcMatchesCase :: (AnnoBody body, Outputable (body GhcTc)) =>
- TcMatchAltChecker body -- ^ Case context
- -> Scaled TcSigmaTypeFRR -- ^ Type of scrutinee
- -> MatchGroup GhcRn (LocatedA (body GhcRn)) -- ^ The case alternatives
- -> ExpRhoType -- ^ Type of the whole case expression
- -> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (body GhcTc)))
- -- Translated alternatives
- -- wrapper goes from MatchGroup's ty to expected ty
+tcCaseMatches :: (AnnoBody body, Outputable (body GhcTc))
+ => TcMatchAltChecker body -- ^ Case context
+ -> Scaled TcSigmaTypeFRR -- ^ Type of scrutinee
+ -> MatchGroup GhcRn (LocatedA (body GhcRn)) -- ^ The case alternatives
+ -> ExpRhoType -- ^ Type of the whole case expression
+ -> TcM (HsWrapper, MatchGroup GhcTc (LocatedA (body GhcTc)))
+ -- Translated alternatives
+ -- wrapper goes from MatchGroup's ty to expected ty
-tcMatchesCase ctxt (Scaled scrut_mult scrut_ty) matches res_ty
+tcCaseMatches ctxt (Scaled scrut_mult scrut_ty) matches res_ty
= tcMatches ctxt [ExpFunPatTy (Scaled scrut_mult (mkCheckExpType scrut_ty))] res_ty matches
-tcMatchLambda :: ExpectedFunTyOrigin -- see Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify
- -> MatchGroup GhcRn (LHsExpr GhcRn)
- -> ExpRhoType
- -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-tcMatchLambda herald match res_ty
+tcLambdaMatches :: ExpectedFunTyOrigin -- see Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify
+ -> MatchGroup GhcRn (LHsExpr GhcRn)
+ -> ExpRhoType
+ -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
+tcLambdaMatches herald match res_ty
= do { checkArgCounts Nothing match
; (wrapper, (mult_co_wrap, r)) <- matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty ->
-- checking argument counts since this is also used for \cases
@@ -203,7 +203,7 @@ tcGRHSsPat mult grhss res_ty
********************************************************************* -}
-- | Type checker for a body of a match alternative
-type TcMatchAltChecker body
+type TcMatchAltChecker body -- c.f. TcStmtChecker, also in this module
= LocatedA (body GhcRn)
-> ExpRhoType
-> TcM (LocatedA (body GhcTc))
@@ -221,8 +221,8 @@ type AnnoBody body
)
-- | Type-check a MatchGroup.
-tcMatches :: (AnnoBody body, Outputable (body GhcTc)) =>
- TcMatchAltChecker body
+tcMatches :: (AnnoBody body, Outputable (body GhcTc))
+ => TcMatchAltChecker body
-> [ExpPatType] -- ^ Expected pattern types.
-> ExpRhoType -- ^ Expected result-type of the Match.
-> MatchGroup GhcRn (LocatedA (body GhcRn))
@@ -262,7 +262,8 @@ tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches
match_fun_pat_ty ExpForAllPatTy{} = Nothing
-------------
-tcMatch :: (AnnoBody body) => TcMatchAltChecker body
+tcMatch :: (AnnoBody body)
+ => TcMatchAltChecker body
-> [ExpPatType] -- Expected pattern types
-> ExpRhoType -- Expected result-type of the Match.
-> LMatch GhcRn (LocatedA (body GhcRn))
@@ -275,13 +276,12 @@ tcMatch alt_checker pat_tys rhs_ty match
tc_match match_alt_checker pat_tys rhs_ty
match@(Match { m_ctxt = ctxt, m_pats = pats, m_grhss = grhss })
= add_match_ctxt match $
- do { (pats', (wrapper, grhss')) <- tcPats ctxt' pats pat_tys $
- tcGRHSs ctxt' match_alt_checker grhss rhs_ty
+ do { (pats', (wrapper, grhss')) <- tcMatchPats ctxt pats pat_tys $
+ tcGRHSs ctxt match_alt_checker grhss rhs_ty
; return (wrapper, Match { m_ext = noAnn
- , m_ctxt = ctxt'
+ , m_ctxt = ctxt
, m_pats = filter_out_type_pats pats'
, m_grhss = grhss' }) }
- where ctxt' = convertHsMatchCtxt ctxt
-- For (\x -> e), tcExpr has already said "In the expression \x->e"
-- so we don't want to add "In the lambda abstraction \x->e"
-- But for \cases with many alternatives, it is helpful to say
@@ -300,36 +300,12 @@ tcMatch alt_checker pat_tys rhs_ty match
is_fun_pat_ty ExpFunPatTy{} = True
is_fun_pat_ty ExpForAllPatTy{} = False
-
--- | Ths function converts HsMatchContext GhcRn to HsMatchContext GhcTc
--- It is a little silly to do it this way as all except for FunRhs constructor, are independent
--- of the GhcPass index parameter.
-convertHsMatchCtxt :: HsMatchContext GhcRn -> HsMatchContext GhcTc
-convertHsStmtCtxt :: HsStmtContext GhcRn -> HsStmtContext GhcTc
-
-convertHsMatchCtxt CaseAlt = CaseAlt
-convertHsMatchCtxt (LamAlt x) = LamAlt x
-convertHsMatchCtxt IfAlt = IfAlt
-convertHsMatchCtxt (ArrowMatchCtxt x) = ArrowMatchCtxt x
-convertHsMatchCtxt PatBindRhs = PatBindRhs
-convertHsMatchCtxt LazyPatCtx = LazyPatCtx
-convertHsMatchCtxt PatBindGuards = CaseAlt
-convertHsMatchCtxt RecUpd = RecUpd
-convertHsMatchCtxt (StmtCtxt x) = StmtCtxt $ convertHsStmtCtxt x
-convertHsMatchCtxt ThPatSplice = ThPatSplice
-convertHsMatchCtxt ThPatQuote = ThPatQuote
-convertHsMatchCtxt PatSyn = PatSyn
-convertHsMatchCtxt (FunRhs x y z) = FunRhs x y z
-
-convertHsStmtCtxt (HsDoStmt x) = HsDoStmt x
-convertHsStmtCtxt (PatGuard x) = PatGuard $ convertHsMatchCtxt x
-convertHsStmtCtxt (ParStmtCtxt x) = ParStmtCtxt $ convertHsStmtCtxt x
-convertHsStmtCtxt (TransStmtCtxt x) = TransStmtCtxt $ convertHsStmtCtxt x
-convertHsStmtCtxt ArrowExpr = ArrowExpr
-
-------------
tcGRHSs :: AnnoBody body
- => HsMatchContext GhcTc -> TcMatchAltChecker body -> GRHSs GhcRn (LocatedA (body GhcRn)) -> ExpRhoType
+ => HsMatchContextRn
+ -> TcMatchAltChecker body
+ -> GRHSs GhcRn (LocatedA (body GhcRn))
+ -> ExpRhoType
-> TcM (HsWrapper, GRHSs GhcTc (LocatedA (body GhcTc)))
-- Notice that we pass in the full res_ty, so that we get
-- good inference from simple things like
@@ -345,7 +321,7 @@ tcGRHSs ctxt alt_checker (GRHSs _ grhss binds) res_ty
; return grhss' }
; return (wrapper, GRHSs emptyComments grhss' binds') }
-------------
-tcGRHS :: HsMatchContext GhcTc -> TcMatchAltChecker body -> ExpRhoType -> GRHS GhcRn (LocatedA (body GhcRn))
+tcGRHS :: HsMatchContextRn -> TcMatchAltChecker body -> ExpRhoType -> GRHS GhcRn (LocatedA (body GhcRn))
-> TcM (GRHS GhcTc (LocatedA (body GhcTc)))
tcGRHS ctxt alt_checker res_ty (GRHS _ guards rhs)
= do { (guards', rhs')
@@ -421,13 +397,13 @@ type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType
type TcCmdStmtChecker = TcStmtChecker HsCmd TcRhoType
type TcStmtChecker body rho_type
- = forall thing. HsStmtContext GhcTc
+ = forall thing. HsStmtContextRn
-> 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 GhcTc
+tcStmts :: (AnnoBody body) => HsStmtContextRn
-> TcStmtChecker body rho_type -- NB: higher-rank type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
@@ -437,7 +413,7 @@ tcStmts ctxt stmt_chk stmts res_ty
const (return ())
; return stmts' }
-tcStmtsAndThen :: (AnnoBody body) => HsStmtContext GhcTc
+tcStmtsAndThen :: (AnnoBody body) => HsStmtContextRn
-> TcStmtChecker body rho_type -- NB: higher-rank type
-> [LStmt GhcRn (LocatedA (body GhcRn))]
-> rho_type
@@ -1107,7 +1083,7 @@ To achieve this we:
-}
tcApplicativeStmts
- :: HsStmtContext GhcTc
+ :: HsStmtContextRn
-> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-> ExpRhoType -- rhs_ty
-> (TcRhoType -> TcM t) -- thing_inside
@@ -1225,7 +1201,7 @@ the variables they bind into scope, and typecheck the thing_inside.
-- | @checkArgCounts@ takes a @[RenamedMatch]@ and decides whether the same
-- number of args are used in each equation.
checkArgCounts :: AnnoBody body
- => Maybe (HsMatchContext GhcTc)
+ => Maybe HsMatchContextRn
-> MatchGroup GhcRn (LocatedA (body GhcRn))
-> TcM ()
checkArgCounts _ (MG { mg_alts = L _ [] })
@@ -1242,7 +1218,7 @@ checkArgCounts mb_ctxt (MG { mg_alts = L _ (match1:matches) })
= return ()
where
ctxt = case mb_ctxt of
- Nothing -> convertHsMatchCtxt $ m_ctxt (unLoc match1)
+ Nothing -> m_ctxt (unLoc match1)
Just x -> x
n_args1 = args_in_match match1
mb_bad_matches = NE.nonEmpty [m | m <- matches, args_in_match m /= n_args1]
diff --git a/compiler/GHC/Tc/Gen/Match.hs-boot b/compiler/GHC/Tc/Gen/Match.hs-boot
index c6f91bfdca8d..d48a5974336d 100644
--- a/compiler/GHC/Tc/Gen/Match.hs-boot
+++ b/compiler/GHC/Tc/Gen/Match.hs-boot
@@ -12,8 +12,8 @@ tcGRHSsPat :: Mult
-> ExpRhoType
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
-tcMatchesFun :: LocatedN Name
- -> Mult
- -> MatchGroup GhcRn (LHsExpr GhcRn)
- -> ExpSigmaType
- -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
+tcFunBindMatches :: LocatedN Name
+ -> Mult
+ -> MatchGroup GhcRn (LHsExpr GhcRn)
+ -> ExpSigmaType
+ -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index 658db74518bc..64a9d8f24176 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -18,7 +18,7 @@ module GHC.Tc.Gen.Pat
, newLetBndr
, LetBndrSpec(..)
, tcCheckPat, tcCheckPat_O, tcInferPat
- , tcPats
+ , tcMatchPats
, addDataConStupidTheta
, isIrrefutableHsPatRnTcM
)
@@ -123,11 +123,11 @@ tcLetPat sig_fn no_gen pat pat_ty thing_inside
not_xstrict _ = checkManyPattern pat_ty
-----------------
-tcPats :: HsMatchContext GhcTc
- -> [LPat GhcRn] -- ^ patterns
- -> [ExpPatType] -- ^ types of the patterns
- -> TcM a -- ^ checker for the body
- -> TcM ([LPat GhcTc], a)
+tcMatchPats :: HsMatchContextRn
+ -> [LPat GhcRn] -- ^ patterns
+ -> [ExpPatType] -- ^ types of the patterns
+ -> TcM a -- ^ checker for the body
+ -> TcM ([LPat GhcTc], a)
-- This is the externally-callable wrapper function
-- Typecheck the patterns, extend the environment to bind the variables,
@@ -140,13 +140,13 @@ tcPats :: HsMatchContext GhcTc
-- 3. Check the body
-- 4. Check that no existentials escape
-tcPats ctxt pats pat_tys thing_inside
+tcMatchPats ctxt pats pat_tys thing_inside
= tc_tt_lpats pat_tys penv pats thing_inside
where
penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }
tcInferPat :: FixedRuntimeRepContext
- -> HsMatchContext GhcTc
+ -> HsMatchContextRn
-> LPat GhcRn
-> TcM a
-> TcM ((LPat GhcTc, a), TcSigmaTypeFRR)
@@ -156,14 +156,14 @@ tcInferPat frr_orig ctxt pat thing_inside
where
penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }
-tcCheckPat :: HsMatchContext GhcTc
+tcCheckPat :: HsMatchContextRn
-> LPat GhcRn -> Scaled TcSigmaTypeFRR
-> 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 GhcTc
+tcCheckPat_O :: HsMatchContextRn
-> CtOrigin -- ^ origin to use if the type needs inst'ing
-> LPat GhcRn -> Scaled TcSigmaTypeFRR
-> TcM a -- Checker for body
@@ -190,7 +190,7 @@ data PatEnv
data PatCtxt
= LamPat -- Used for lambdas, case etc
- (HsMatchContext GhcTc)
+ HsMatchContextRn
| LetPat -- Used only for let(rec) pattern bindings
-- See Note [Typing patterns in pattern bindings]
@@ -346,21 +346,21 @@ tcMultiple_ tc_pat penv args thing_inside
tcMultiple :: Checker inp out -> Checker [inp] [out]
tcMultiple tc_pat penv args thing_inside
= do { err_ctxt <- getErrCtxt
- ; let loop _ []
+ ; let loop []
= do { res <- thing_inside
; return ([], res) }
- loop penv (arg:args)
+ loop (arg:args)
= do { (p', (ps', res))
<- tc_pat penv arg $
setErrCtxt err_ctxt $
- loop penv args
+ loop args
-- setErrCtxt: restore context before doing the next pattern
-- See Note [Nesting] above
; return (p':ps', res) }
- ; loop penv args }
+ ; loop args }
--------------------
tc_lpat :: Scaled ExpSigmaTypeFRR
@@ -565,7 +565,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
-- Expression must be a function
; let herald = ExpectedFunTyViewPat $ unLoc expr
; (expr_wrap1, Scaled _mult inf_arg_ty, inf_res_sigma)
- <- matchActualFunTySigma herald (Just . HsExprRnThing $ unLoc expr) (1,[]) expr_ty
+ <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,[]) expr_ty
-- See Note [View patterns and polymorphism]
-- expr_wrap1 :: expr_ty "->" (inf_arg_ty -> inf_res_sigma)
@@ -582,7 +582,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
(Scaled w pat_ty) inf_res_sigma
-- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->"
-- (pat_ty -> inf_res_sigma)
- -- NB: pat_ty comes from matchActualFunTySigma, so it has a
+ -- NB: pat_ty comes from matchActualFunTy, so it has a
-- fixed RuntimeRep, as needed to call mkWpFun.
; let
expr_wrap = expr_wrap2' <.> expr_wrap1 <.> mult_wrap
@@ -604,7 +604,7 @@ arrow type (t1 -> t2); hence using (tcInferRho expr).
Then, when taking that arrow apart we want to get a *sigma* type
(forall b. b->(Int,b)), because that's what we want to bind 'x' to.
-Fortunately that's what matchActualFunTySigma returns anyway.
+Fortunately that's what matchActualFunTy returns anyway.
-}
-- Type signatures in patterns
diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs
index 94b62a7ca4db..eee5e648cdce 100644
--- a/compiler/GHC/Tc/Gen/Sig.hs
+++ b/compiler/GHC/Tc/Gen/Sig.hs
@@ -8,12 +8,9 @@
{-# LANGUAGE TypeFamilies #-}
module GHC.Tc.Gen.Sig(
- TcSigInfo(..),
- TcIdSigInfo(..), TcIdSigInst,
- TcPatSynInfo(..),
- TcSigFun,
+ TcSigInfo(..), TcIdSig(..), TcSigFun,
- isPartialSig, hasCompleteSig, tcIdSigName, tcSigInfoName,
+ isPartialSig, hasCompleteSig, tcSigInfoName, tcIdSigLoc,
completeSigPolyId_maybe, isCompleteHsSig,
lhsSigWcTypeContextSpan, lhsSigTypeContextSpan,
@@ -94,16 +91,16 @@ especially on value bindings. Here's an overview.
* When starting a mutually recursive group, like f/g above, we
call tcTySig on each signature in the group.
-* tcTySig: Sig -> TcIdSigInfo
+* tcTySig: Sig -> TcIdSig
- For a /complete/ signature, like 'f' above, tcTySig kind-checks
- the HsType, producing a Type, and wraps it in a CompleteSig, and
+ the HsType, producing a Type, and wraps it in a TcCompleteSig, and
extend the type environment with this polymorphic 'f'.
- For a /partial/signature, like 'g' above, tcTySig does nothing
Instead it just wraps the pieces in a PartialSig, to be handled
later.
-* tcInstSig: TcIdSigInfo -> TcIdSigInst
+* tcInstSig: TcIdSig -> TcIdSigInst
In tcMonoBinds, when looking at an individual binding, we use
tcInstSig to instantiate the signature forall's in the signature,
and attribute that instantiated (monomorphic) type to the
@@ -144,28 +141,6 @@ errors were dealt with by the renamer.
-}
-
-{- *********************************************************************
-* *
- Utility functions for TcSigInfo
-* *
-********************************************************************* -}
-
-tcIdSigName :: TcIdSigInfo -> Name
-tcIdSigName (CompleteSig { sig_bndr = id }) = idName id
-tcIdSigName (PartialSig { psig_name = n }) = n
-
-tcSigInfoName :: TcSigInfo -> Name
-tcSigInfoName (TcIdSig idsi) = tcIdSigName idsi
-tcSigInfoName (TcPatSynSig tpsi) = patsig_name tpsi
-
-completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId
-completeSigPolyId_maybe sig
- | TcIdSig sig_info <- sig
- , CompleteSig { sig_bndr = id } <- sig_info = Just id
- | otherwise = Nothing
-
-
{- *********************************************************************
* *
Typechecking user signatures
@@ -195,7 +170,7 @@ tcTySig (L _ (XSig (IdSig id)))
-- NoRRC: do not report redundant constraints
-- The user has no control over the signature!
sig = completeSigFromId ctxt id
- ; return [TcIdSig sig] }
+ ; return [TcIdSig (TcCompleteSig sig)] }
tcTySig (L loc (TypeSig _ names sig_ty))
= setSrcSpanA loc $
@@ -212,8 +187,7 @@ tcTySig (L loc (PatSynSig _ names sig_ty))
tcTySig _ = return []
-tcUserTypeSig :: SrcSpan -> LHsSigWcType GhcRn -> Maybe Name
- -> TcM TcIdSigInfo
+tcUserTypeSig :: SrcSpan -> LHsSigWcType GhcRn -> Maybe Name -> TcM TcIdSig
-- A function or expression type signature
-- Returns a fully quantified type signature; even the wildcards
-- are quantified with ordinary skolems that should be instantiated
@@ -229,23 +203,23 @@ tcUserTypeSig loc hs_sig_ty mb_name
| isCompleteHsSig hs_sig_ty
= do { sigma_ty <- tcHsSigWcType ctxt_no_rrc hs_sig_ty
; traceTc "tcuser" (ppr sigma_ty)
- ; return $
- CompleteSig { sig_bndr = mkLocalId name ManyTy sigma_ty
+ ; return $ TcCompleteSig $
+ CSig { sig_bndr = mkLocalId name ManyTy sigma_ty
-- We use `Many' as the multiplicity here,
-- as if this identifier corresponds to
-- anything, it is a top-level
-- definition. Which are all unrestricted in
-- the current implementation.
- , sig_ctxt = ctxt_rrc -- Report redundant constraints
- , sig_loc = loc } }
- -- Location of the <type> in f :: <type>
+ , sig_ctxt = ctxt_rrc -- Report redundant constraints
+ , sig_loc = loc } } -- Location of the <type> in f :: <type>
-- Partial sig with wildcards
| otherwise
- = return (PartialSig { psig_name = name, psig_hs_ty = hs_sig_ty
- , sig_ctxt = ctxt_no_rrc, sig_loc = loc })
+ = return $ TcPartialSig $
+ PSig { psig_name = name, psig_hs_ty = hs_sig_ty
+ , psig_ctxt = ctxt_no_rrc, psig_loc = loc }
where
- name = case mb_name of
+ name = case mb_name of
Just n -> n
Nothing -> mkUnboundName (mkVarOccFS (fsLit "<expression>"))
@@ -275,12 +249,12 @@ lhsSigTypeContextSpan (L _ HsSig { sig_body = sig_ty }) = go sig_ty
go (L _ (HsParTy _ hs_ty)) = go hs_ty -- Look under parens
go _ = NoRRC -- Did not find it
-completeSigFromId :: UserTypeCtxt -> Id -> TcIdSigInfo
+completeSigFromId :: UserTypeCtxt -> Id -> TcCompleteSig
-- Used for instance methods and record selectors
completeSigFromId ctxt id
- = CompleteSig { sig_bndr = id
- , sig_ctxt = ctxt
- , sig_loc = getSrcSpan id }
+ = CSig { sig_bndr = id
+ , sig_ctxt = ctxt
+ , sig_loc = getSrcSpan id }
isCompleteHsSig :: LHsSigWcType GhcRn -> Bool
-- ^ If there are no wildcards, return a LHsSigWcType
@@ -400,7 +374,7 @@ later. Pattern synonyms are top-level, so there's no problem with
completely solving them.
-}
-tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcPatSynInfo
+tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcPatSynSig
-- See Note [Pattern synonym signatures]
-- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType
tcPatSynSig name sig_ty@(L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = hs_ty}))
@@ -475,13 +449,14 @@ tcPatSynSig name sig_ty@(L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = hs_ty
, text "ex_tvs" <+> ppr_tvs (binderVars ex_bndrs)
, text "prov" <+> ppr prov
, text "body_ty" <+> ppr body_ty ]
- ; return (TPSI { patsig_name = name
- , patsig_implicit_bndrs = kv_bndrs ++ implicit_bndrs
- , patsig_univ_bndrs = univ_bndrs
- , patsig_req = req
- , patsig_ex_bndrs = ex_bndrs
- , patsig_prov = prov
- , patsig_body_ty = body_ty }) }
+ ; return $
+ PatSig { patsig_name = name
+ , patsig_implicit_bndrs = kv_bndrs ++ implicit_bndrs
+ , patsig_univ_bndrs = univ_bndrs
+ , patsig_req = req
+ , patsig_ex_bndrs = ex_bndrs
+ , patsig_prov = prov
+ , patsig_body_ty = body_ty } }
where
ctxt = PatSynCtxt name
@@ -513,9 +488,9 @@ ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv)
********************************************************************* -}
-tcInstSig :: TcIdSigInfo -> TcM TcIdSigInst
+tcInstSig :: TcIdSig -> TcM TcIdSigInst
-- Instantiate a type signature; only used with plan InferGen
-tcInstSig hs_sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc })
+tcInstSig hs_sig@(TcCompleteSig (CSig { sig_bndr = poly_id, sig_loc = loc }))
= setSrcSpan loc $ -- Set the binding site of the tyvars
do { (tv_prs, theta, tau) <- tcInstTypeBndrs (idType poly_id)
-- See Note [Pattern bindings and complete signatures]
@@ -527,9 +502,9 @@ tcInstSig hs_sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc })
, sig_inst_theta = theta
, sig_inst_tau = tau }) }
-tcInstSig hs_sig@(PartialSig { psig_hs_ty = hs_ty
- , sig_ctxt = ctxt
- , sig_loc = loc })
+tcInstSig hs_sig@(TcPartialSig (PSig { psig_hs_ty = hs_ty
+ , psig_ctxt = ctxt
+ , psig_loc = loc }))
= setSrcSpan loc $ -- Set the binding site of the tyvars
do { traceTc "Staring partial sig {" (ppr hs_sig)
; (wcs, wcx, tv_prs, theta, tau) <- tcHsPartialSigType ctxt hs_ty
diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs
index 3105419f03cb..72e7bc56c2cf 100644
--- a/compiler/GHC/Tc/TyCl/Class.hs
+++ b/compiler/GHC/Tc/TyCl/Class.hs
@@ -295,9 +295,9 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
ctxt = FunSigCtxt sel_name warn_redundant
; let local_dm_id = mkLocalId local_dm_name ManyTy local_dm_ty
- local_dm_sig = CompleteSig { sig_bndr = local_dm_id
- , sig_ctxt = ctxt
- , sig_loc = getLocA hs_ty }
+ local_dm_sig = CSig { sig_bndr = local_dm_id
+ , sig_ctxt = ctxt
+ , sig_loc = getLocA hs_ty }
; (ev_binds, (tc_bind, _))
<- checkConstraints skol_info tyvars [this_dict] $
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index f41cd8e9d07b..0966d5de0c85 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -2056,10 +2056,9 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
-- WantRCC <=> check for redundant constraints in the
-- user-specified instance signature
inner_meth_id = mkLocalId inner_meth_name ManyTy sig_ty
- inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id
- , sig_ctxt = ctxt
- , sig_loc = getLocA hs_sig_ty }
-
+ inner_meth_sig = CSig { sig_bndr = inner_meth_id
+ , sig_ctxt = ctxt
+ , sig_loc = getLocA hs_sig_ty }
; (tc_bind, [Scaled _ inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index f3b0a7c2a33d..69e9faa68ddd 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -87,9 +87,9 @@ tcPatSynDecl (L loc psb@(PSB { psb_id = L _ name })) sig_fn prag_fn
<+> quotes (ppr name)) $
-- See Note [Pattern synonym error recovery]
case sig_fn name of
- Nothing -> tcInferPatSynDecl psb prag_fn
- Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi prag_fn
- _ -> panic "tcPatSynDecl"
+ Nothing -> tcInferPatSynDecl psb prag_fn
+ Just (TcPatSynSig patsig) -> tcCheckPatSynDecl psb patsig prag_fn
+ _ -> panic "tcPatSynDecl"
{- Note [Pattern synonym error recovery]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -351,15 +351,15 @@ Hence the call to doNotQuantifyTyVars here.
-}
tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn
- -> TcPatSynInfo
+ -> TcPatSynSig
-> TcPragEnv
-> TcM (LHsBinds GhcTc, TcGblEnv)
tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
, psb_def = lpat, psb_dir = dir }
- TPSI{ patsig_implicit_bndrs = implicit_bndrs
- , patsig_univ_bndrs = explicit_univ_bndrs, patsig_req = req_theta
- , patsig_ex_bndrs = explicit_ex_bndrs, patsig_prov = prov_theta
- , patsig_body_ty = sig_body_ty }
+ PatSig{ patsig_implicit_bndrs = implicit_bndrs
+ , patsig_univ_bndrs = explicit_univ_bndrs, patsig_req = req_theta
+ , patsig_ex_bndrs = explicit_ex_bndrs, patsig_prov = prov_theta
+ , patsig_body_ty = sig_body_ty }
prag_fn
= do { traceTc "tcCheckPatSynDecl" $
vcat [ ppr implicit_bndrs, ppr explicit_univ_bndrs, ppr req_theta
@@ -563,7 +563,7 @@ We don't know Q's arity from the pattern signature, so we have to wait
until we see the pattern declaration itself before deciding res_ty is,
and hence which variables are existential and which are universal.
-And that in turn is why TcPatSynInfo has a separate field,
+And that in turn is why TcPatSynSig has a separate field,
patsig_implicit_bndrs, to capture the implicitly bound type variables,
because we don't yet know how to split them up.
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index aac22b5cff35..30cc7cd973a0 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -880,6 +880,8 @@ mkOneRecordSelector all_cons idDetails fl has_sel
locc = noAnnSrcSpan loc
lbl = flLabel fl
sel_name = flSelector fl
+ sel_lname = L locn sel_name
+ match_ctxt = mkPrefixFunRhs sel_lname
sel_id = mkExportedLocalId rec_details sel_name sel_ty
@@ -935,10 +937,9 @@ mkOneRecordSelector all_cons idDetails fl has_sel
-- where cons_w_field = [C2,C7]
sel_bind = mkTopFunBind (Generated OtherExpansion SkipPmc) sel_lname alts
where
- alts | is_naughty = [mkSimpleMatch (mkPrefixFunRhs sel_lname)
- [] unit_rhs]
+ alts | is_naughty = [mkSimpleMatch match_ctxt [] unit_rhs]
| otherwise = map mk_match cons_w_field ++ deflt
- mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname)
+ mk_match con = mkSimpleMatch match_ctxt
[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)
@@ -951,15 +952,13 @@ mkOneRecordSelector all_cons idDetails fl has_sel
, hfbRHS
= L loc' (VarPat noExtField (L locn field_var))
, hfbPun = False })
- sel_lname = L locn sel_name
field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc
-- Add catch-all default case unless the case is exhaustive
-- We do this explicitly so that we get a nice error message that
-- mentions this particular record selector
deflt | all dealt_with all_cons = []
- | otherwise = [mkSimpleMatch CaseAlt
- [genWildPat]
+ | otherwise = [mkSimpleMatch match_ctxt [genWildPat]
(genLHsApp
(genHsVar (getName rEC_SEL_ERROR_ID))
(genLHsLit msg_lit))]
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index a210ec2ca7b9..fe3aa4b5e88a 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -67,9 +67,12 @@ module GHC.Tc.Types(
ArrowCtxt(..),
-- TcSigInfo
- TcSigFun, TcSigInfo(..), TcIdSigInfo(..),
- TcIdSigInst(..), TcPatSynInfo(..),
+ TcSigFun,
+ TcSigInfo(..), TcIdSig(..),
+ TcCompleteSig(..), TcPartialSig(..), TcPatSynSig(..),
+ TcIdSigInst(..),
isPartialSig, hasCompleteSig,
+ tcIdSigLoc, tcSigInfoName, completeSigPolyId_maybe,
-- Misc other types
TcId,
diff --git a/compiler/GHC/Tc/Types/BasicTypes.hs b/compiler/GHC/Tc/Types/BasicTypes.hs
index 7287b6c123c1..ae9efd5515de 100644
--- a/compiler/GHC/Tc/Types/BasicTypes.hs
+++ b/compiler/GHC/Tc/Types/BasicTypes.hs
@@ -5,13 +5,11 @@ module GHC.Tc.Types.BasicTypes (
, TcBinder(..)
-- * Signatures
- , TcSigFun
- , TcIdSigInfo(..)
- , TcSigInfo(..)
- , TcPatSynInfo(..)
+ , TcSigFun, TcSigInfo(..), TcIdSig(..)
+ , TcCompleteSig(..), TcPartialSig(..), TcPatSynSig(..)
, TcIdSigInst(..)
- , isPartialSig
- , hasCompleteSig
+ , isPartialSig, hasCompleteSig
+ , tcSigInfoName, tcIdSigLoc, completeSigPolyId_maybe
-- * TcTyThing
, TcTyThing(..)
@@ -101,33 +99,50 @@ instance HasOccName TcBinder where
type TcSigFun = Name -> Maybe TcSigInfo
-data TcSigInfo = TcIdSig TcIdSigInfo
- | TcPatSynSig TcPatSynInfo
+-- TcSigInfo is simply the range of TcSigFun
+data TcSigInfo = TcIdSig TcIdSig
+ | TcPatSynSig TcPatSynSig -- For a pattern synonym
-data TcIdSigInfo -- See Note [Complete and partial type signatures]
- = CompleteSig -- A complete signature with no wildcards,
- -- so the complete polymorphic type is known.
- { sig_bndr :: TcId -- The polymorphic Id with that type
+-- See Note [Complete and partial type signatures]
+data TcIdSig -- For an Id
+ = TcCompleteSig TcCompleteSig
+ | TcPartialSig TcPartialSig
- , sig_ctxt :: UserTypeCtxt -- In the case of type-class default methods,
- -- the Name in the FunSigCtxt is not the same
- -- as the TcId; the former is 'op', while the
- -- latter is '$dmop' or some such
+data TcCompleteSig -- A complete signature with no wildcards,
+ -- so the complete polymorphic type is known.
+ = CSig { sig_bndr :: TcId -- The polymorphic Id with that type
- , sig_loc :: SrcSpan -- Location of the type signature
- }
+ , sig_ctxt :: UserTypeCtxt -- In the case of type-class default methods,
+ -- the Name in the FunSigCtxt is not the same
+ -- as the TcId; the former is 'op', while the
+ -- latter is '$dmop' or some such
+
+ , sig_loc :: SrcSpan -- Location of the type signature
+ }
- | PartialSig -- A partial type signature (i.e. includes one or more
+data TcPartialSig -- A partial type signature (i.e. includes one or more
-- wildcards). In this case it doesn't make sense to give
-- the polymorphic Id, because we are going to /infer/ its
-- type, so we can't make the polymorphic Id ab-initio
- { psig_name :: Name -- Name of the function; used when report wildcards
- , psig_hs_ty :: LHsSigWcType GhcRn -- The original partial signature in
- -- HsSyn form
- , sig_ctxt :: UserTypeCtxt
- , sig_loc :: SrcSpan -- Location of the type signature
- }
+ = PSig { psig_name :: Name -- Name of the function; used when report wildcards
+ , psig_hs_ty :: LHsSigWcType GhcRn -- The original partial signature in
+ -- HsSyn form
+ , psig_ctxt :: UserTypeCtxt
+ , psig_loc :: SrcSpan -- Location of the type signature
+ }
+data TcPatSynSig
+ = PatSig {
+ patsig_name :: Name,
+ patsig_implicit_bndrs :: [InvisTVBinder], -- Implicitly-bound kind vars (Inferred) and
+ -- implicitly-bound type vars (Specified)
+ -- See Note [The pattern-synonym signature splitting rule] in GHC.Tc.TyCl.PatSyn
+ patsig_univ_bndrs :: [InvisTVBinder], -- Bound by explicit user forall
+ patsig_req :: TcThetaType,
+ patsig_ex_bndrs :: [InvisTVBinder], -- Bound by explicit user forall
+ patsig_prov :: TcThetaType,
+ patsig_body_ty :: TcSigmaType
+ }
{- Note [Complete and partial type signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -146,7 +161,7 @@ sig_extra_cts is Nothing.
-}
data TcIdSigInst
- = TISI { sig_inst_sig :: TcIdSigInfo
+ = TISI { sig_inst_sig :: TcIdSig
, sig_inst_skols :: [(Name, InvisTVBinder)]
-- Instantiated type and kind variables, TyVarTvs
@@ -187,7 +202,7 @@ data TcIdSigInst
Note that "sig_inst_tau" might actually be a polymorphic type,
if the original function had a signature like
forall a. Eq a => forall b. Ord b => ....
-But that's ok: tcMatchesFun (called by tcRhs) can deal with that
+But that's ok: tcFunBindMatches (called by tcRhs) can deal with that
It happens, too! See Note [Polymorphic methods] in GHC.Tc.TyCl.Class.
Note [Quantified variables in partial type signatures]
@@ -231,51 +246,59 @@ Here we get
sig_inst_wcs = [ _22::k ]
-}
-data TcPatSynInfo
- = TPSI {
- patsig_name :: Name,
- patsig_implicit_bndrs :: [InvisTVBinder], -- Implicitly-bound kind vars (Inferred) and
- -- implicitly-bound type vars (Specified)
- -- See Note [The pattern-synonym signature splitting rule] in GHC.Tc.TyCl.PatSyn
- patsig_univ_bndrs :: [InvisTVBinder], -- Bound by explicit user forall
- patsig_req :: TcThetaType,
- patsig_ex_bndrs :: [InvisTVBinder], -- Bound by explicit user forall
- patsig_prov :: TcThetaType,
- patsig_body_ty :: TcSigmaType
- }
-
instance Outputable TcSigInfo where
- ppr (TcIdSig idsi) = ppr idsi
- ppr (TcPatSynSig tpsi) = text "TcPatSynInfo" <+> ppr tpsi
+ ppr (TcIdSig sig) = ppr sig
+ ppr (TcPatSynSig sig) = ppr sig
-instance Outputable TcIdSigInfo where
- ppr (CompleteSig { sig_bndr = bndr })
- = ppr bndr <+> dcolon <+> ppr (idType bndr)
- ppr (PartialSig { psig_name = name, psig_hs_ty = hs_ty })
- = text "[partial signature]" <+> ppr name <+> dcolon <+> ppr hs_ty
+instance Outputable TcIdSig where
+ ppr (TcCompleteSig sig) = ppr sig
+ ppr (TcPartialSig sig) = ppr sig
-instance Outputable TcIdSigInst where
- ppr (TISI { sig_inst_sig = sig, sig_inst_skols = skols
- , sig_inst_theta = theta, sig_inst_tau = tau })
- = hang (ppr sig) 2 (vcat [ ppr skols, ppr theta <+> darrow <+> ppr tau ])
+instance Outputable TcCompleteSig where
+ ppr (CSig { sig_bndr = bndr })
+ = ppr bndr <+> dcolon <+> ppr (idType bndr)
+
+instance Outputable TcPartialSig where
+ ppr (PSig { psig_name = name, psig_hs_ty = hs_ty })
+ = text "[partial signature]" <+> ppr name <+> dcolon <+> ppr hs_ty
-instance Outputable TcPatSynInfo where
- ppr (TPSI{ patsig_name = name}) = ppr name
+instance Outputable TcPatSynSig where
+ ppr (PatSig { patsig_name = name}) = ppr name
+
+instance Outputable TcIdSigInst where
+ ppr (TISI { sig_inst_sig = sig, sig_inst_skols = skols
+ , sig_inst_theta = theta, sig_inst_tau = tau })
+ = hang (ppr sig) 2 (vcat [ ppr skols, ppr theta <+> darrow <+> ppr tau ])
isPartialSig :: TcIdSigInst -> Bool
-isPartialSig (TISI { sig_inst_sig = PartialSig {} }) = True
-isPartialSig _ = False
+isPartialSig (TISI { sig_inst_sig = TcPartialSig {} }) = True
+isPartialSig _ = False
-- | No signature or a partial signature
hasCompleteSig :: TcSigFun -> Name -> Bool
hasCompleteSig sig_fn name
= case sig_fn name of
- Just (TcIdSig (CompleteSig {})) -> True
- _ -> False
+ Just (TcIdSig (TcCompleteSig {})) -> True
+ _ -> False
----------------------------
--- TcTyThing
----------------------------
+tcSigInfoName :: TcSigInfo -> Name
+tcSigInfoName (TcIdSig (TcCompleteSig sig)) = idName (sig_bndr sig)
+tcSigInfoName (TcIdSig (TcPartialSig sig)) = psig_name sig
+tcSigInfoName (TcPatSynSig sig) = patsig_name sig
+
+tcIdSigLoc :: TcIdSig -> SrcSpan
+tcIdSigLoc (TcCompleteSig sig) = sig_loc sig
+tcIdSigLoc (TcPartialSig sig) = psig_loc sig
+
+completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId
+completeSigPolyId_maybe (TcIdSig (TcCompleteSig sig)) = Just (sig_bndr sig)
+completeSigPolyId_maybe _ = Nothing
+
+{- *********************************************************************
+* *
+ TcTyThing
+* *
+********************************************************************* -}
-- | A typecheckable thing available in a local context. Could be
-- 'AGlobal' 'TyThing', but also lexically scoped variables, etc.
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index 246cfe5fba12..a5639af6fd19 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -284,7 +284,7 @@ data SkolemInfoAnon
| 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 GhcTc)
+ HsMatchContextRn
-- e.g. data T = forall a. Eq a => MkT a
-- f (MkT x) = ...
-- The pattern MkT x will allocate an existential type
@@ -1142,7 +1142,7 @@ data FixedRuntimeRepContext
| FRRArrow !FRRArrowContext
-- | A representation-polymorphic check arising from a call
- -- to 'matchExpectedFunTys' or 'matchActualFunTySigma'.
+ -- to 'matchExpectedFunTys' or 'matchActualFunTy'.
--
-- See 'ExpectedFunTyOrigin' for more details.
| FRRExpectedFunTy
@@ -1367,7 +1367,7 @@ instance Outputable FRRArrowContext where
********************************************************************* -}
-- | In what context are we calling 'matchExpectedFunTys'
--- or 'matchActualFunTySigma'?
+-- or 'matchActualFunTy'?
--
-- Used for two things:
--
diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs
index 89140294d147..08f54b5051e4 100644
--- a/compiler/GHC/Tc/Utils/Unify.hs
+++ b/compiler/GHC/Tc/Utils/Unify.hs
@@ -34,7 +34,7 @@ module GHC.Tc.Utils.Unify (
matchExpectedAppTy,
matchExpectedFunTys,
matchExpectedFunKind,
- matchActualFunTySigma, matchActualFunTysRho,
+ matchActualFunTy, matchActualFunTys,
checkTyEqRhs, recurseIntoTyConApp,
PuResult(..), failCheckWith, okCheckRefl, mapCheck,
@@ -95,7 +95,7 @@ import qualified Data.Semigroup as S ( (<>) )
* *
********************************************************************* -}
--- | 'matchActualFunTySigma' looks for just one function arrow,
+-- | 'matchActualFunTy' looks for just one function arrow,
-- returning an uninstantiated sigma-type.
--
-- Invariant: the returned argument type has a syntactically fixed
@@ -103,7 +103,7 @@ import qualified Data.Semigroup as S ( (<>) )
-- in GHC.Tc.Utils.Concrete.
--
-- See Note [Return arguments with a fixed RuntimeRep].
-matchActualFunTySigma
+matchActualFunTy
:: ExpectedFunTyOrigin
-- ^ See Note [Herald for matchExpectedFunTys]
-> Maybe TypedThing
@@ -123,11 +123,11 @@ matchActualFunTySigma
--
-- See Note [matchActualFunTy error handling] for the first three arguments
--- If (wrap, arg_ty, res_ty) = matchActualFunTySigma ... fun_ty
+-- If (wrap, arg_ty, res_ty) = matchActualFunTy ... fun_ty
-- then wrap :: fun_ty ~> (arg_ty -> res_ty)
-- and NB: res_ty is an (uninstantiated) SigmaType
-matchActualFunTySigma herald mb_thing err_info fun_ty
+matchActualFunTy herald mb_thing err_info fun_ty
= assertPpr (isRhoTy fun_ty) (ppr fun_ty) $
go fun_ty
where
@@ -187,8 +187,8 @@ matchActualFunTySigma herald mb_thing err_info fun_ty
(n_val_args_in_call, arg_tys_so_far) = err_info
{- Note [matchActualFunTy error handling]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-matchActualFunTySigma is made much more complicated by the
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+matchActualFunTy is made much more complicated by the
desire to produce good error messages. Consider the application
f @Int x y
In GHC.Tc.Gen.Expr.tcArgs we deal with visible type arguments,
@@ -215,17 +215,17 @@ Ugh!
-- INVARIANT: the returned argument types all have a syntactically fixed RuntimeRep
-- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.
-- See Note [Return arguments with a fixed RuntimeRep].
-matchActualFunTysRho :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpectedFunTys]
- -> CtOrigin
- -> Maybe TypedThing -- ^ the thing with type TcSigmaType
- -> Arity
- -> TcSigmaType
- -> TcM (HsWrapper, [Scaled TcSigmaTypeFRR], TcRhoType)
--- If matchActualFunTysRho n ty = (wrap, [t1,..,tn], res_ty)
+matchActualFunTys :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpectedFunTys]
+ -> CtOrigin
+ -> Maybe TypedThing -- ^ the thing with type TcSigmaType
+ -> Arity
+ -> TcSigmaType
+ -> TcM (HsWrapper, [Scaled TcSigmaTypeFRR], TcRhoType)
+-- If matchActualFunTys n ty = (wrap, [t1,..,tn], res_ty)
-- then wrap : ty ~> (t1 -> ... -> tn -> res_ty)
-- and res_ty is a RhoType
-- NB: the returned type is top-instantiated; it's a RhoType
-matchActualFunTysRho herald ct_orig mb_thing n_val_args_wanted fun_ty
+matchActualFunTys herald ct_orig mb_thing n_val_args_wanted fun_ty
= go n_val_args_wanted [] fun_ty
where
go n so_far fun_ty
@@ -237,13 +237,13 @@ matchActualFunTysRho herald ct_orig mb_thing n_val_args_wanted fun_ty
go 0 _ fun_ty = return (idHsWrapper, [], fun_ty)
go n so_far fun_ty
- = do { (wrap_fun1, arg_ty1, res_ty1) <- matchActualFunTySigma
+ = do { (wrap_fun1, arg_ty1, res_ty1) <- matchActualFunTy
herald mb_thing
(n_val_args_wanted, so_far)
fun_ty
; (wrap_res, arg_tys, res_ty) <- go (n-1) (arg_ty1:so_far) res_ty1
; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty
- -- NB: arg_ty1 comes from matchActualFunTySigma, so it has
+ -- NB: arg_ty1 comes from matchActualFunTy, so it has
-- a syntactically fixed RuntimeRep as needed to call mkWpFun.
; return (wrap_fun2 <.> wrap_fun1, arg_ty1:arg_tys, res_ty) }
@@ -314,8 +314,8 @@ Note [Return arguments with a fixed RuntimeRep]
The functions
- matchExpectedFunTys,
- - matchActualFunTySigma,
- - matchActualFunTysRho,
+ - matchActualFunTy,
+ - matchActualFunTys,
peel off argument types, as explained in Note [matchExpectedFunTys].
It's important that these functions return argument types that have
@@ -343,7 +343,7 @@ Example:
The body of `f` is a lambda abstraction, so we must be able to split off
one argument type from its type. This is handled by `matchExpectedFunTys`
- (see 'GHC.Tc.Gen.Match.tcMatchLambda'). We end up with desugared Core that
+ (see 'GHC.Tc.Gen.Match.tcLambdaMatches'). We end up with desugared Core that
looks like this:
f :: forall (a :: TYPE (F Int)). Dual (a |> (TYPE F[0]))
@@ -371,7 +371,7 @@ Example:
-- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.
-- See Note [Return arguments with a fixed RuntimeRep].
matchExpectedFunTys :: forall a.
- ExpectedFunTyOrigin -- See Note [Herald for matchExpectedFunTys]
+ ExpectedFunTyOrigin -- See Note [Herald for matchExpectedFunTys]
-> UserTypeCtxt
-> Arity
-> ExpRhoType -- Skolemised
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 8da99ee7d9bd..1936b5bb17f8 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -1004,8 +1004,7 @@ cvtLocalDecs declDescr ds
((_:_), (_:_)) ->
failWith ImplicitParamsWithOtherBinds
-cvtClause :: HsMatchContext GhcPs
- -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
+cvtClause :: HsMatchContextPs -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
cvtClause ctxt (Clause ps body wheres)
= do { ps' <- cvtPats ps
; let pps = map (parenthesizePat appPrec) ps'
@@ -1328,8 +1327,7 @@ cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss
; rec_stmt <- wrapParLA (mkRecStmt noAnn) ss'
; returnLA rec_stmt }
-cvtMatch :: HsMatchContext GhcPs
- -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
+cvtMatch :: HsMatchContextPs -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
cvtMatch ctxt (TH.Match p body decs)
= do { p' <- cvtPat p
; let lp = case p' of
diff --git a/compiler/GHC/Types/Var.hs b/compiler/GHC/Types/Var.hs
index 7adcc6e26c42..e14d83962ed9 100644
--- a/compiler/GHC/Types/Var.hs
+++ b/compiler/GHC/Types/Var.hs
@@ -723,8 +723,8 @@ data VarBndr var argf = Bndr var argf
--
-- A 'TyVarBinder' is a binder with only TyVar
type ForAllTyBinder = VarBndr TyCoVar ForAllTyFlag
-type InvisTyBinder = VarBndr TyCoVar Specificity
-type ReqTyBinder = VarBndr TyCoVar ()
+type InvisTyBinder = VarBndr TyCoVar Specificity
+type ReqTyBinder = VarBndr TyCoVar ()
type TyVarBinder = VarBndr TyVar ForAllTyFlag
type InvisTVBinder = VarBndr TyVar Specificity
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index 5c732a180155..f77d2a283a3e 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -308,9 +308,9 @@ data HsExpr p
| HsLam (XLam p)
HsLamVariant -- ^ Tells whether this is for lambda, \case, or \cases
(MatchGroup p (LHsExpr p))
- -- ^ LamSingle: one match
+ -- ^ LamSingle: one match of arity >= 1
-- LamCase: many arity-1 matches
- -- LamCases: many matches of uniform arity
+ -- LamCases: many matches of uniform arity >= 1
--
-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',
-- 'GHC.Parser.Annotation.AnnRarrow',
@@ -977,10 +977,9 @@ type LMatch id body = XRec id (Match id body)
-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
data Match p body
= Match {
- m_ext :: XCMatch p body,
- m_ctxt :: HsMatchContext p,
- -- See Note [m_ctxt in Match]
- m_pats :: [LPat p], -- The patterns
+ m_ext :: XCMatch p body,
+ m_ctxt :: HsMatchContext (LIdP (NoGhcTc p)), -- See Note [m_ctxt in Match]
+ m_pats :: [LPat p], -- The patterns
m_grhss :: (GRHSs p body)
}
| XMatch !(XXMatch p body)
@@ -988,7 +987,6 @@ data Match p body
{-
Note [m_ctxt in Match]
~~~~~~~~~~~~~~~~~~~~~~
-
A Match can occur in a number of contexts, such as a FunBind, HsCase, HsLam and
so on.
@@ -1017,9 +1015,6 @@ annotations
(&&& ) [] [] = []
xs &&& [] = xs
( &&& ) [] ys = ys
-
-
-
-}
@@ -1533,14 +1528,13 @@ data ArithSeqInfo id
--
-- Context of a pattern match. This is more subtle than it would seem. See
-- Note [FunBind vs PatBind].
-data HsMatchContext p
+data HsMatchContext fn
= FunRhs
-- ^ A pattern matching on an argument of a
-- function binding
- { mc_fun :: LIdP (NoGhcTc p) -- ^ function binder of @f@
- -- See Note [mc_fun field of FunRhs]
- -- See #20415 for a long discussion about
- -- this field and why it uses NoGhcTc.
+ { mc_fun :: fn -- ^ function binder of @f@
+ -- See Note [mc_fun field of FunRhs]
+ -- See #20415 for a long discussion about this field
, mc_fixity :: LexicalFixity -- ^ fixing of @f@
, mc_strictness :: SrcStrictness -- ^ was @f@ banged?
-- See Note [FunBind vs PatBind]
@@ -1559,42 +1553,51 @@ data HsMatchContext p
-- tell matchWrapper what sort of
-- runtime error message to generate]
- | StmtCtxt (HsStmtContext p) -- ^Pattern of a do-stmt, list comprehension,
- -- pattern guard, etc
+ | StmtCtxt (HsStmtContext fn) -- ^Pattern of a do-stmt, list comprehension,
+ -- pattern guard, etc
| ThPatSplice -- ^A Template Haskell pattern splice
| ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |]
| PatSyn -- ^A pattern synonym declaration
| LazyPatCtx -- ^An irrefutable pattern
-{-
-Note [mc_fun field of FunRhs]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The mc_fun field of FunRhs has type `LIdP (NoGhcTc p)`, which means it will be
-a `RdrName` in pass `GhcPs`, a `Name` in `GhcRn`, and (importantly) still a
-`Name` in `GhcTc` -- not an `Id`. See Note [NoGhcTc] in GHC.Hs.Extension.
-
-Why a `Name` in the typechecker phase? Because:
-* A `Name` is all we need, as it turns out.
-* Using an `Id` involves knot-tying in the monad, which led to #22695.
+{- Note [mc_fun field of FunRhs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+HsMatchContext is parameterised over `fn`, the function binder stored in `FunRhs`.
+This makes pretty printing easy.
+
+In the use of `HsMatchContext` in `Match`, it is parameterised thus:
+ data Match p body = Match { m_ctxt :: HsMatchContext (LIdP (NoGhcTc p)), ... }
+So in a Match, the mc_fun field `FunRhs` will be a `RdrName` in pass `GhcPs`, a `Name`
+in `GhcRn`, and (importantly) still a `Name` in `GhcTc` -- not an `Id`.
+See Note [NoGhcTc] in GHC.Hs.Extension.
+
+* Why a `Name` in the typechecker phase? Because:
+ * A `Name` is all we need, as it turns out.
+ * Using an `Id` involves knot-tying in the monad, which led to #22695.
+
+* Why a /located/ name? Because we want to record the location of the Id
+ on the LHS of /this/ match. See Note [m_ctxt in Match]. Example:
+ (&&&) [] [] = []
+ xs &&& [] = xs
+ The two occurrences of `&&&` have different locations.
+
+* Why parameterise `HsMatchContext` over `fn` rather than over the pass `p`?
+ Because during typechecking (specifically GHC.Tc.Gen.Match.tcMatch) we need to convert
+ HsMatchContext (LIdP (NoGhcTc GhcRn)) --> HsMatchContext (LIdP (NoGhcTc GhcTc))
+ With this parameterisation it's easy; if it was parametersed over `p` we'd need
+ a recursive traversal of the HsMatchContext.
See #20415 for a long discussion.
-
-}
-isPatSynCtxt :: HsMatchContext p -> Bool
-isPatSynCtxt ctxt =
- case ctxt of
- PatSyn -> True
- _ -> False
-
-- | Haskell Statement Context.
-data HsStmtContext p
- = HsDoStmt HsDoFlavour -- ^ Context for HsDo (do-notation and comprehensions)
- | PatGuard (HsMatchContext p) -- ^ Pattern guard for specified thing
- | ParStmtCtxt (HsStmtContext p) -- ^ A branch of a parallel stmt
- | TransStmtCtxt (HsStmtContext p) -- ^ A branch of a transform stmt
- | ArrowExpr -- ^ do-notation in an arrow-command context
+data HsStmtContext fn
+ = HsDoStmt HsDoFlavour -- ^ Context for HsDo (do-notation and comprehensions)
+ | PatGuard (HsMatchContext fn) -- ^ Pattern guard for specified thing
+ | ParStmtCtxt (HsStmtContext fn) -- ^ A branch of a parallel stmt
+ | TransStmtCtxt (HsStmtContext fn) -- ^ A branch of a transform stmt
+ | ArrowExpr -- ^ do-notation in an arrow-command context
-- | Haskell arrow match context.
data HsArrowMatchContext
@@ -1610,13 +1613,19 @@ data HsDoFlavour
| MonadComp
deriving (Eq, Data)
-qualifiedDoModuleName_maybe :: HsStmtContext p -> Maybe ModuleName
+qualifiedDoModuleName_maybe :: HsStmtContext fn -> Maybe ModuleName
qualifiedDoModuleName_maybe ctxt = case ctxt of
HsDoStmt (DoExpr m) -> m
HsDoStmt (MDoExpr m) -> m
_ -> Nothing
-isComprehensionContext :: HsStmtContext id -> Bool
+isPatSynCtxt :: HsMatchContext fn -> Bool
+isPatSynCtxt ctxt =
+ case ctxt of
+ PatSyn -> True
+ _ -> False
+
+isComprehensionContext :: HsStmtContext fn -> Bool
-- Uses comprehension syntax [ e | quals ]
isComprehensionContext (ParStmtCtxt c) = isComprehensionContext c
isComprehensionContext (TransStmtCtxt c) = isComprehensionContext c
@@ -1632,7 +1641,7 @@ isDoComprehensionContext ListComp = True
isDoComprehensionContext MonadComp = True
-- | Is this a monadic context?
-isMonadStmtContext :: HsStmtContext id -> Bool
+isMonadStmtContext :: HsStmtContext fn -> Bool
isMonadStmtContext (ParStmtCtxt ctxt) = isMonadStmtContext ctxt
isMonadStmtContext (TransStmtCtxt ctxt) = isMonadStmtContext ctxt
isMonadStmtContext (HsDoStmt flavour) = isMonadDoStmtContext flavour
@@ -1646,7 +1655,7 @@ isMonadDoStmtContext DoExpr{} = True
isMonadDoStmtContext MDoExpr{} = True
isMonadDoStmtContext GhciStmtCtxt = True
-isMonadCompContext :: HsStmtContext id -> Bool
+isMonadCompContext :: HsStmtContext fn -> Bool
isMonadCompContext (HsDoStmt flavour) = isMonadDoCompContext flavour
isMonadCompContext (ParStmtCtxt _) = False
isMonadCompContext (TransStmtCtxt _) = False
--
GitLab