[Git][ghc/ghc][wip/T24359] More progress
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Tue Feb 13 00:28:47 UTC 2024
Simon Peyton Jones pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC
Commits:
cac643df by Simon Peyton Jones at 2024-02-13T00:26:17+00:00
More progress
- - - - -
29 changed files:
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Stats.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/HsType.hs
- − compiler/GHC/Tc/Gen/Rule.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Types/Constraint.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Validity.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/Language/Haskell/Syntax/Binds.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- compiler/Language/Haskell/Syntax/Extension.hs
Changes:
=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -32,8 +32,9 @@ import GHC.Prelude
import Language.Haskell.Syntax.Extension
import Language.Haskell.Syntax.Binds
+import Language.Haskell.Syntax.Expr( LHsExpr )
-import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprFunBind, pprPatBind )
+import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprLExpr, pprFunBind, pprPatBind )
import {-# SOURCE #-} GHC.Hs.Pat (pprLPat )
import GHC.Types.Tickish
@@ -750,20 +751,17 @@ data TcSpecPrags
= IsDefaultMethod -- ^ Super-specialised: a default method should
-- be macro-expanded at every call site
| SpecPrags [LTcSpecPrag]
- deriving Data
-- | Located Type checker Specification Pragmas
type LTcSpecPrag = Located TcSpecPrag
-- | Type checker Specification Pragma
data TcSpecPrag
- = SpecPrag
- Id
- HsWrapper
- InlinePragma
- -- ^ The Id to be specialised, a wrapper that specialises the
- -- polymorphic function, and inlining spec for the specialised function
- deriving Data
+ = SpecPrag Id HsWrapper InlinePragma
+ -- ^ The Id to be specialised, a wrapper that specialises the
+ -- polymorphic function, and inlining spec for the specialised function
+
+ | SpecPragE (RuleBndrs GhcTc) (LHsExpr GhcTc) InlinePragma
noSpecPrags :: TcSpecPrags
noSpecPrags = SpecPrags []
@@ -795,9 +793,9 @@ ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_src = src, inl_inline = spec }
NoUserInlinePrag -> "{-# " ++ extractSpecPragName src
_ -> "{-# " ++ extractSpecPragName src ++ "_INLINE"
-ppr_sig (SpecSigE _ spec_e inl@(InlinePragma { inl_src = src, inl_inline = spec }))
+ppr_sig (SpecSigE _ bndrs spec_e inl@(InlinePragma { inl_src = src, inl_inline = spec }))
= pragSrcBrackets (inlinePragmaSource inl) pragmaSrc $
- pp_inl <+> ppr spec_e
+ pp_inl <+> hang (ppr bndrs) 2 (pprLExpr spec_e)
where
-- SPECIALISE or SPECIALISE_INLINE
pragmaSrc = case spec of
@@ -848,7 +846,7 @@ hsSigDoc (ClassOpSig _ is_deflt _ _)
| is_deflt = text "default type signature"
| otherwise = text "class method signature"
hsSigDoc (SpecSig _ _ _ inl) = (inlinePragmaName . inl_inline $ inl) <+> text "pragma"
-hsSigDoc (SpecSigE _ _ inl) = (inlinePragmaName . inl_inline $ inl) <+> text "pragma"
+hsSigDoc (SpecSigE _ _ _ inl) = (inlinePragmaName . inl_inline $ inl) <+> text "pragma"
hsSigDoc (InlineSig _ _ prag) = (inlinePragmaName . inl_inline $ prag) <+> text "pragma"
-- Using the 'inlinePragmaName' function ensures that the pragma name for any
-- one of the INLINE/INLINABLE/NOINLINE pragmas are printed after being extracted
@@ -906,11 +904,38 @@ pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps)
instance Outputable TcSpecPrag where
ppr (SpecPrag var _ inl)
= text (extractSpecPragName $ inl_src inl) <+> pprSpec var (text "<type>") inl
+ ppr (SpecPragE bndrs spec_e inl)
+ = text (extractSpecPragName $ inl_src inl)
+ <+> hang (ppr bndrs) 2 (pprLExpr spec_e)
pprMinimalSig :: (OutputableBndr name)
=> LBooleanFormula (GenLocated l name) -> SDoc
pprMinimalSig (L _ bf) = ppr (fmap unLoc bf)
+
+{- *********************************************************************
+* *
+ RuleBndrs
+* *
+********************************************************************* -}
+
+type instance XCRuleBndr (GhcPass _) = EpAnn [AddEpAnn]
+type instance XRuleBndrSig (GhcPass _) = EpAnn [AddEpAnn]
+type instance XXRuleBndr (GhcPass _) = DataConCantHappen
+
+instance (OutputableBndrId p) => Outputable (RuleBndrs (GhcPass p)) where
+ ppr (RuleBndrs { rb_tyvs = tyvs, rb_tmvs = tmvs })
+ = pp_forall_ty tyvs <+> pp_forall_tm tyvs
+ where
+ pp_forall_ty Nothing = empty
+ pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot
+ pp_forall_tm Nothing | null tmvs = empty
+ pp_forall_tm _ = forAllLit <+> fsep (map ppr tmvs) <> dot
+
+instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where
+ ppr (RuleBndr _ name) = ppr name
+ ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty)
+
{-
************************************************************************
* *
@@ -922,6 +947,7 @@ pprMinimalSig (L _ bf) = ppr (fmap unLoc bf)
type instance Anno (HsBindLR (GhcPass idL) (GhcPass idR)) = SrcSpanAnnA
type instance Anno (IPBind (GhcPass p)) = SrcSpanAnnA
type instance Anno (Sig (GhcPass p)) = SrcSpanAnnA
+type instance Anno (RuleBndr (GhcPass p)) = EpAnn NoEpAnns
-- For CompleteMatchSig
type instance Anno [LocatedN RdrName] = SrcSpan
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -1223,10 +1223,6 @@ instance NoAnn HsRuleAnn where
flattenRuleDecls :: [LRuleDecls (GhcPass p)] -> [LRuleDecl (GhcPass p)]
flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls
-type instance XCRuleBndr (GhcPass _) = EpAnn [AddEpAnn]
-type instance XRuleBndrSig (GhcPass _) = EpAnn [AddEpAnn]
-type instance XXRuleBndr (GhcPass _) = DataConCantHappen
-
instance (OutputableBndrId p) => Outputable (RuleDecls (GhcPass p)) where
ppr (HsRules { rds_ext = ext
, rds_rules = rules })
@@ -1241,28 +1237,18 @@ instance (OutputableBndrId p) => Outputable (RuleDecl (GhcPass p)) where
ppr (HsRule { rd_ext = ext
, rd_name = name
, rd_act = act
- , rd_tyvs = tys
- , rd_tmvs = tms
+ , rd_bndrs = bndrs
, rd_lhs = lhs
, rd_rhs = rhs })
= sep [pprFullRuleName st name <+> ppr act,
- nest 4 (pp_forall_ty tys <+> pp_forall_tm tys
- <+> pprExpr (unLoc lhs)),
+ nest 4 (ppr bndrs <+> pprExpr (unLoc lhs)),
nest 6 (equals <+> pprExpr (unLoc rhs)) ]
where
- pp_forall_ty Nothing = empty
- pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot
- pp_forall_tm Nothing | null tms = empty
- pp_forall_tm _ = forAllLit <+> fsep (map ppr tms) <> dot
st = case ghcPass @p of
GhcPs | (_, st) <- ext -> st
GhcRn | (_, st) <- ext -> st
GhcTc | (_, st) <- ext -> st
-instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where
- ppr (RuleBndr _ name) = ppr name
- ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty)
-
pprFullRuleName :: SourceText -> GenLocated a (RuleName) -> SDoc
pprFullRuleName st (L _ n) = pprWithSourceText st (doubleQuotes $ ftext n)
@@ -1415,7 +1401,6 @@ type instance Anno (ForeignDecl (GhcPass p)) = SrcSpanAnnA
type instance Anno (RuleDecls (GhcPass p)) = SrcSpanAnnA
type instance Anno (RuleDecl (GhcPass p)) = SrcSpanAnnA
type instance Anno (SourceText, RuleName) = EpAnn NoEpAnns
-type instance Anno (RuleBndr (GhcPass p)) = EpAnn NoEpAnns
type instance Anno (WarnDecls (GhcPass p)) = SrcSpanAnnA
type instance Anno (WarnDecl (GhcPass p)) = SrcSpanAnnA
type instance Anno (AnnDecl (GhcPass p)) = SrcSpanAnnA
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -259,6 +259,13 @@ deriving instance Data (RuleBndr GhcPs)
deriving instance Data (RuleBndr GhcRn)
deriving instance Data (RuleBndr GhcTc)
+deriving instance Data (RuleBndrs GhcPs)
+deriving instance Data (RuleBndrs GhcRn)
+deriving instance Data (RuleBndrs GhcTc)
+
+deriving instance Data TcSpecPrags
+deriving instance Data TcSpecPrag
+
-- deriving instance (DataId p) => Data (WarnDecls p)
deriving instance Data (WarnDecls GhcPs)
deriving instance Data (WarnDecls GhcRn)
=====================================
compiler/GHC/Hs/Stats.hs
=====================================
@@ -116,7 +116,7 @@ ppSourceStats short (L _ (HsModule{ hsmodExports = exports, hsmodImports = impor
sig_info (FixSig {}) = (1,0,0,0,0)
sig_info (TypeSig {}) = (0,1,0,0,0)
sig_info (SpecSig {}) = (0,0,1,0,0)
- sig_info (SpecESig {}) = (0,0,1,0,0)
+ sig_info (SpecSigE {}) = (0,0,1,0,0)
sig_info (InlineSig {}) = (0,0,0,1,0)
sig_info (ClassOpSig {}) = (0,0,0,0,1)
sig_info _ = (0,0,0,0,0)
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -445,7 +445,7 @@ Reason
dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)
dsRule (L loc (HsRule { rd_name = name
, rd_act = rule_act
- , rd_tmvs = vars
+ , rd_bndrs = RuleBndrs { rb_tmvs = vars }
, rd_lhs = lhs
, rd_rhs = rhs }))
= putSrcSpanDs (locA loc) $
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -800,7 +800,7 @@ dsSpecs :: CoreExpr -- Its rhs
-> TcSpecPrags
-> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids
, [CoreRule] ) -- Rules for the Global Ids
--- See Note [Handling SPECIALISE pragmas] in GHC.Tc.Gen.Bind
+-- See Note [Handling SPECIALISE pragmas] in GHC.Tc.Gen.Sig
dsSpecs _ IsDefaultMethod = return (nilOL, [])
dsSpecs poly_rhs (SpecPrags sps)
= do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps
@@ -820,48 +820,57 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
-- Moreover, classops don't (currently) have an inl_sat arity set
-- (it would be Just 0) and that in turn makes makeCorePair bleat
- | no_act_spec && isNeverActive rule_act
- = putSrcSpanDs loc $
- do { diagnosticDs (DsUselessSpecialiseForNoInlineFunction poly_id)
- ; return Nothing } -- Function is NOINLINE, and the specialisation inherits that
- -- See Note [Activation pragmas for SPECIALISE]
-
- | otherwise
- = putSrcSpanDs loc $
- do { uniq <- newUnique
- ; let poly_name = idName poly_id
- spec_occ = mkSpecOcc (getOccName poly_name)
- spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)
- (spec_bndrs, spec_app) = collectHsWrapBinders spec_co
+ | (spec_bndrs, spec_app) <- collectHsWrapBinders spec_co
-- spec_co looks like
-- \spec_bndrs. [] spec_args
-- perhaps with the body of the lambda wrapped in some WpLets
-- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2
+ = putSrcSpanDs loc $
+ dsHsWrapper spec_app $ \core_app ->
+ finishSpecPrag mb_poly_rhs spec_bndrs (core_app (Var poly_id)) spec_inl
- ; dsHsWrapper spec_app $ \core_app -> do
- { let ds_lhs = core_app (Var poly_id)
- spec_ty = mkLamTypes spec_bndrs (exprType ds_lhs)
- ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id
- -- , text "spec_co:" <+> ppr spec_co
- -- , text "ds_rhs:" <+> ppr ds_lhs ]) $
- dflags <- getDynFlags
- ; case decomposeRuleLhs dflags spec_bndrs ds_lhs (mkVarSet spec_bndrs) of {
- Left msg -> do { diagnosticDs msg; return Nothing } ;
- Right (rule_bndrs, _fn, rule_lhs_args) -> do
+dsSpec mb_poly_rhs (L loc (SpecPragE bndrs spec_e spec_inl))
+ | RuleBndrs { rb_tmvs = tm_bndrs } <- bndrs
+ = putSrcSpanDs loc $
+ do { core_spec_e <- dsLExpr spec_e
+ ; let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- tm_bndrs]
+
+ ; finishSpecPrag mb_poly_rhs bndrs' core_spec_e spec_inl }
+
+finishSpecPrag :: Maybe CoreExpr -> [Var] -> CoreExpr -> InlinePragma
+ -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
+finishSpecPrag mb_poly_rhs bndrs rule_lhs spec_inl
+ = do { dflags <- getDynFlags
+ ; case decomposeRuleLhs dflags bndrs rule_lhs (mkVarSet bndrs) of {
+ Left msg -> do { diagnosticDs msg; return Nothing } ;
+ Right (rule_bndrs, poly_id, rule_lhs_args) ->
+
+ do { this_mod <- getModule
+ ; uniq <- newUnique
+ ; let poly_name = idName poly_id
+ spec_occ = mkSpecOcc (getOccName poly_name)
+ spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)
+ spec_ty = mkLamTypes rule_bndrs (exprType rule_lhs)
+ fn_unf = realIdUnfolding poly_id
+ poly_rhs = specFunBody poly_id mb_poly_rhs
+ id_inl = idInlinePragma poly_id
+ inl_prag = specFunInlinePrag mb_poly_rhs poly_id id_inl spec_inl
+ rule_act = specRuleActivation id_inl spec_inl
- { this_mod <- getModule
- ; let fn_unf = realIdUnfolding poly_id
simpl_opts = initSimpleOpts dflags
- spec_unf = specUnfolding simpl_opts spec_bndrs core_app rule_lhs_args fn_unf
- spec_id = mkLocalId spec_name ManyTy spec_ty -- Specialised binding is toplevel, hence Many.
+ spec_unf = specUnfolding simpl_opts rule_bndrs mk_app rule_lhs_args fn_unf
+ spec_id = mkLocalId spec_name ManyTy spec_ty
+ -- Specialised binding is toplevel, hence Many.
`setInlinePragma` inl_prag
`setIdUnfolding` spec_unf
rule = mkSpecRule dflags this_mod False rule_act (text "USPEC")
poly_id rule_bndrs rule_lhs_args
- (mkVarApps (Var spec_id) spec_bndrs)
- spec_rhs = mkLams spec_bndrs (core_app poly_rhs)
+ (mkVarApps (Var spec_id) rule_bndrs)
+
+ mk_app e = mkApps e rule_lhs_args
+ spec_rhs = mkLams rule_bndrs (mkApps poly_rhs rule_lhs_args)
; dsWarnOrphanRule rule
@@ -869,42 +878,49 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
-- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because
-- makeCorePair overwrites the unfolding, which we have
-- just created using specUnfolding
- } } } }
+ } } }
where
- is_local_id = isJust mb_poly_rhs
- poly_rhs | Just rhs <- mb_poly_rhs
- = rhs -- Local Id; this is its rhs
- | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
- = unfolding -- Imported Id; this is its unfolding
- -- Use realIdUnfolding so we get the unfolding
- -- even when it is a loop breaker.
- -- We want to specialise recursive functions!
- | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
- -- The type checker has checked that it *has* an unfolding
-
- id_inl = idInlinePragma poly_id
- -- See Note [Activation pragmas for SPECIALISE]
- inl_prag | not (isDefaultInlinePragma spec_inl) = spec_inl
- | not is_local_id -- See Note [Specialising imported functions]
- -- in OccurAnal
- , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
- | otherwise = id_inl
+specFunBody :: Id -> Maybe CoreExpr -> CoreExpr
+specFunBody _ (Just rhs)
+ = rhs -- Local Id; this is its rhs
+specFunBody poly_id Nothing
+ | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
+ = unfolding -- Imported Id; this is its unfolding
+ -- Use realIdUnfolding so we get the unfolding
+ -- even when it is a loop breaker.
+ -- We want to specialise recursive functions!
+ | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
+ -- The type checker has checked that it *has* an unfolding
+
+specFunInlinePrag :: Maybe CoreExpr -> Id -> InlinePragma
+ -> InlinePragma -> InlinePragma
+-- See Note [Activation pragmas for SPECIALISE]
+specFunInlinePrag mb_poly_rhs poly_id id_inl spec_inl
+ | not (isDefaultInlinePragma spec_inl) = spec_inl
+ | not is_local_id -- See Note [Specialising imported functions]
+ -- in OccurAnal
+ , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
+ | otherwise = id_inl
-- Get the INLINE pragma from SPECIALISE declaration, or,
-- failing that, from the original Id
+ where
+ is_local_id = isJust mb_poly_rhs
- spec_prag_act = inlinePragmaActivation spec_inl
-
+specRuleActivation :: InlinePragma -> InlinePragma -> Activation
+specRuleActivation id_inl spec_inl
+ | no_act_spec = inl_prag_act -- Inherit
+ | otherwise = spec_prag_act -- Specified by user
+ where
-- See Note [Activation pragmas for SPECIALISE]
-- no_act_spec is True if the user didn't write an explicit
-- phase specification in the SPECIALISE pragma
+ inl_prag_act = inlinePragmaActivation id_inl
+ spec_prag_act = inlinePragmaActivation spec_inl
no_act_spec = case inlinePragmaSpec spec_inl of
NoInline _ -> isNeverActive spec_prag_act
Opaque _ -> isNeverActive spec_prag_act
_ -> isAlwaysActive spec_prag_act
- rule_act | no_act_spec = inlinePragmaActivation id_inl -- Inherit
- | otherwise = spec_prag_act -- Specified by user
-
dsWarnOrphanRule :: CoreRule -> DsM ()
dsWarnOrphanRule rule
@@ -1009,14 +1025,15 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs rhs_fvs
-- ]) $
Left (DsRuleBindersNotBound unbound orig_bndrs orig_lhs lhs2)
| otherwise ->
- -- pprTrace "decomposeRuleLhs 2" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs
- -- , text "orig_lhs:" <+> ppr orig_lhs
- -- , text "lhs1:" <+> ppr lhs1
- -- , text "extra_bndrs:" <+> ppr extra_bndrs
- -- , text "fn_id:" <+> ppr fn_id
- -- , text "args:" <+> ppr args
- -- , text "args fvs:" <+> ppr (exprsFreeVarsList args)
- -- ]) $
+ pprTrace "decomposeRuleLhs 2" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs
+ , text "orig_lhs:" <+> ppr orig_lhs
+ , text "lhs1:" <+> ppr lhs1
+ , text "trimmed_bndrs:" <+> ppr trimmed_bndrs
+ , text "extra_bndrs:" <+> ppr extra_bndrs
+ , text "fn_id:" <+> ppr fn_id
+ , text "args:" <+> ppr args
+ , text "args fvs:" <+> ppr (exprsFreeVarsList args)
+ ]) $
Right (trimmed_bndrs ++ extra_bndrs, fn_id, args)
where -- See Note [Variables unbound on the LHS]
@@ -1180,9 +1197,9 @@ drop_dicts drops dictionary bindings on the LHS where possible.
quantify over it. That makes 'd' free in the LHS, but that is later
picked up by extra_dict_bndrs (see Note [Unused spec binders]).
- NB 1: We can only drop the binding if the RHS doesn't bind
- one of the orig_bndrs, which we assume occur on RHS.
- Example
+ NB 1: We can only drop the binding if the RHS of the binding doesn't
+ mention one of the orig_bndrs, which we assume occur on RHS of
+ the rule. Example
f :: (Eq a) => b -> a -> a
{-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-}
Here we want to end up with
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -802,8 +802,7 @@ repDefD (L loc (DefaultDecl _ tys)) = do { tys1 <- repLTys tys
repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repRuleD (L loc (HsRule { rd_name = n
, rd_act = act
- , rd_tyvs = m_ty_bndrs
- , rd_tmvs = tm_bndrs
+ , rd_bndrs = RuleBndrs { rb_tyvs = m_ty_bndrs, rb_tmvs = tm_bndrs }
, rd_lhs = lhs
, rd_rhs = rhs }))
= do { let ty_bndrs = fromMaybe [] m_ty_bndrs
@@ -995,8 +994,10 @@ rep_sig (L loc (FixSig _ fix_sig)) = rep_fix_d (locA loc) fix_sig
rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec (locA loc)
rep_sig (L loc (SpecSig _ nm tys ispec))
= concatMapM (\t -> rep_specialise nm t ispec (locA loc)) tys
-rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty (locA loc)
-rep_sig (L _ (MinimalSig {})) = notHandled ThMinimalPragmas
+rep_sig (L _ sig@(SpecSigE {}))
+ = pprPanic "No TH for SPECIALISE yet" (ppr sig)
+rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty (locA loc)
+rep_sig (L _ (MinimalSig {})) = notHandled ThMinimalPragmas
rep_sig (L loc (SCCFunSig _ nm str)) = rep_sccFun nm str (locA loc)
rep_sig (L loc (CompleteMatchSig _ cls mty))
= rep_complete_sig cls mty (locA loc)
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1790,6 +1790,10 @@ instance HiePass p => ToHie (SigContext (LocatedA (Sig (GhcPass p)))) where
[ toHie $ (C Use) name
, toHie $ map (TS (ResolvedScopes [])) typs
]
+ SpecSigE _ bndrs spec_e _ ->
+ [ toHieRuleBndrs (locA sp) (mkScope spec_e) bndrs
+ , toHie spec_e
+ ]
SpecInstSig _ typ ->
[ toHie $ TS (ResolvedScopes []) typ
]
@@ -2125,18 +2129,25 @@ instance ToHie (LocatedA (RuleDecls GhcRn)) where
]
instance ToHie (LocatedA (RuleDecl GhcRn)) where
- toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM
+ toHie (L span r@(HsRule { rd_name = rname, rd_bndrs = bndrs
+ , rd_lhs = exprA, rd_rhs = exprB }))
+ = concatM
[ makeNodeA r span
, locOnly $ getLocA rname
- , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
- , toHie $ map (RS $ mkScope (locA span)) bndrs
+ , toHieRuleBndrs (locA span) scope bndrs
, toHie exprA
, toHie exprB
]
- where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc
- bndrs_sc = maybe NoScope mkScope (listToMaybe bndrs)
- exprA_sc = mkScope exprA
- exprB_sc = mkScope exprB
+ where
+ scope = mkScope exprA `combineScopes` mkScope exprB
+
+toHieRuleBndrs :: SrcSpan -> Scope -> RuleBndrs GhcRn -> HieM [HieAST Type]
+toHieRuleBndrs span body_sc (RuleBndrs { rb_tyvs = tybndrs, rb_tmvs = bndrs })
+ = concatM [ toHie $ fmap (tvScopes (ResolvedScopes []) full_sc) tybndrs
+ , toHie $ map (RS $ mkScope (locA span)) bndrs ]
+ where
+ full_sc = bndrs_sc `combineScopes` body_sc
+ bndrs_sc = maybe NoScope mkScope (listToMaybe bndrs)
instance ToHie (RScoped (LocatedAn NoEpAnns (RuleBndr GhcRn))) where
toHie (RS sc (L span bndr)) = concatM $ makeNodeA bndr span : case bndr of
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1866,11 +1866,12 @@ rule :: { LRuleDecl GhcPs }
{%runPV (unECP $4) >>= \ $4 ->
runPV (unECP $6) >>= \ $6 ->
acsA (\cs -> (sLL $1 $> $ HsRule
- { rd_ext = (EpAnn (glEE $1 $>) ((fstOf3 $3) (mj AnnEqual $5 : (fst $2))) cs, getSTRINGs $1)
+ { rd_ext = ( EpAnn (glEE $1 $>) ((fst $3) (mj AnnEqual $5 : (fst $2))) cs
+ , getSTRINGs $1 )
, rd_name = L (noAnnSrcSpan $ gl $1) (getSTRING $1)
- , rd_act = (snd $2) `orElse` AlwaysActive
- , rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3
- , rd_lhs = $4, rd_rhs = $6 })) }
+ , rd_act = snd $2 `orElse` AlwaysActive
+ , rd_bndrs = snd $3
+ , rd_lhs = $4, rd_rhs = $6 })) }
-- Rules can be specified to be NeverActive, unlike inline/specialize pragmas
rule_activation :: { ([AddEpAnn],Maybe Activation) }
@@ -1905,19 +1906,23 @@ rule_explicit_activation :: { ([AddEpAnn]
{ ($2++[mos $1,mcs $3]
,NeverActive) }
-rule_foralls :: { ([AddEpAnn] -> HsRuleAnn, Maybe [LHsTyVarBndr () GhcPs], [LRuleBndr GhcPs]) }
- : 'forall' rule_vars '.' 'forall' rule_vars '.' {% let tyvs = mkRuleTyVarBndrs $2
- in hintExplicitForall $1
- >> checkRuleTyVarBndrNames (mkRuleTyVarBndrs $2)
- >> return (\anns -> HsRuleAnn
- (Just (mu AnnForall $1,mj AnnDot $3))
- (Just (mu AnnForall $4,mj AnnDot $6))
- anns,
- Just (mkRuleTyVarBndrs $2), mkRuleBndrs $5) }
- | 'forall' rule_vars '.' { (\anns -> HsRuleAnn Nothing (Just (mu AnnForall $1,mj AnnDot $3)) anns,
- Nothing, mkRuleBndrs $2) }
+rule_foralls :: { ([AddEpAnn] -> HsRuleAnn, RuleBndrs GhcPs) }
+ : 'forall' rule_vars '.' 'forall' rule_vars '.'
+ {% hintExplicitForall $1
+ >> checkRuleTyVarBndrNames $2
+ >> return ( \anns -> HsRuleAnn
+ (Just (mu AnnForall $1,mj AnnDot $3))
+ (Just (mu AnnForall $4,mj AnnDot $6))
+ anns
+ , mkRuleBndrs (Just $2) $5 ) }
+
+ | 'forall' rule_vars '.'
+ { ( \anns -> HsRuleAnn Nothing (Just (mu AnnForall $1,mj AnnDot $3)) anns
+ , mkRuleBndrs Nothing $2 ) }
+
-- See Note [%shift: rule_foralls -> {- empty -}]
- | {- empty -} %shift { (\anns -> HsRuleAnn Nothing Nothing anns, Nothing, []) }
+ | {- empty -} %shift
+ { (\anns -> HsRuleAnn Nothing Nothing anns, mkRuleBndrs Nothing []) }
rule_vars :: { [LRuleTyTmVar] }
: rule_var rule_vars { $1 : $2 }
@@ -2662,7 +2667,21 @@ sigdecl :: { LHsDecl GhcPs }
{% acsA (\cs ->
let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)
(NoUserInlinePrag, FunLike) (snd $2)
- in sLL $1 $> $ SigD noExtField (SpecSig (EpAnn (glEE $1 $>) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) cs) $3 (fromOL $5) inl_prag)) }
+ in sLL $1 $> $ SigD noExtField $
+ SpecSig (EpAnn (glEE $1 $>) (mo $1:mu AnnDcolon $4:mc $6:fst $2) cs)
+ $3 (fromOL $5)
+ inl_prag) }
+
+ | '{-# SPECIALISE' activation rule_foralls exp '#-}'
+ {% runPV (unECP $4) >>= \ $4 ->
+ acsA (\cs ->
+ let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)
+ (NoUserInlinePrag, FunLike)
+ (snd $2)
+ in sLL $1 $> $ SigD noExtField $
+ SpecSigE (EpAnn (glEE $1 $>) (mo $1:mc $5:fst $2) cs)
+ (snd $3) $4
+ inl_prag) }
| '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
{% acsA (\cs -> sLL $1 $> $ SigD noExtField (SpecSig (EpAnn (glEE $1 $>) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) cs) $3 (fromOL $5)
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -62,7 +62,7 @@ module GHC.Parser.PostProcess (
checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
checkValSigLhs,
LRuleTyTmVar, RuleTyTmVar(..),
- mkRuleBndrs, mkRuleTyVarBndrs,
+ mkRuleBndrs,
checkRuleTyVarBndrNames,
checkRecordSyntax,
checkEmptyGADTs,
@@ -1002,32 +1002,35 @@ type LRuleTyTmVar = LocatedAn NoEpAnns RuleTyTmVar
data RuleTyTmVar = RuleTyTmVar (EpAnn [AddEpAnn]) (LocatedN RdrName) (Maybe (LHsType GhcPs))
-- ^ Essentially a wrapper for a @RuleBndr GhcPs@
--- turns RuleTyTmVars into RuleBnrs - this is straightforward
-mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
-mkRuleBndrs = fmap (fmap cvt_one)
- where cvt_one (RuleTyTmVar ann v Nothing) = RuleBndr ann v
- cvt_one (RuleTyTmVar ann v (Just sig)) =
- RuleBndrSig ann v (mkHsPatSigType noAnn sig)
-
--- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting
-mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs]
-mkRuleTyVarBndrs = fmap cvt_one
- where cvt_one (L l (RuleTyTmVar ann v Nothing))
+mkRuleBndrs :: Maybe [LRuleTyTmVar] -> [LRuleTyTmVar] -> RuleBndrs GhcPs
+mkRuleBndrs tvbs tmbs
+ = RuleBndrs { rb_tyvs = fmap (fmap cvt_tv) tvbs
+ , rb_tmvs = fmap (fmap cvt_tm) tmbs }
+ where
+ -- cvt_tm turns RuleTyTmVars into RuleBnrs - this is straightforward
+ cvt_tm (RuleTyTmVar ann v Nothing) = RuleBndr ann v
+ cvt_tm (RuleTyTmVar ann v (Just sig)) = RuleBndrSig ann v (mkHsPatSigType noAnn sig)
+
+ -- cvt_ty turns RuleTyTmVars into HsTyVarBndrs - this is more interesting
+ cvt_tv (L l (RuleTyTmVar ann v Nothing))
= L (l2l l) (UserTyVar ann () (fmap tm_to_ty v))
- cvt_one (L l (RuleTyTmVar ann v (Just sig)))
+ cvt_tv (L l (RuleTyTmVar ann v (Just sig)))
= L (l2l l) (KindedTyVar ann () (fmap tm_to_ty v) sig)
+
-- takes something in namespace 'varName' to something in namespace 'tvName'
- tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ)
- tm_to_ty _ = panic "mkRuleTyVarBndrs"
+ tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ)
+ tm_to_ty _ = panic "mkRuleTyVarBndrs"
+checkRuleTyVarBndrNames :: [LRuleTyTmVar] -> P ()
-- See Note [Parsing explicit foralls in Rules] in Parser.y
-checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P ()
-checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)
- where check (L loc (Unqual occ)) =
- when (occNameFS occ `elem` [fsLit "family",fsLit "role"])
- (addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
- (PsErrParseErrorOnInput occ))
- check _ = panic "checkRuleTyVarBndrNames"
+checkRuleTyVarBndrNames bndrs
+ = sequence_ [ check lname | L _ (RuleTyTmVar _ lname _) <- bndrs ]
+ where
+ check (L loc (Unqual occ)) =
+ when (occNameFS occ `elem` [fsLit "family",fsLit "role"]) $
+ addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
+ PsErrParseErrorOnInput occ
+ check _ = panic "checkRuleTyVarBndrNames"
checkRecordSyntax :: (MonadP m, Outputable a) => LocatedA a -> m (LocatedA a)
checkRecordSyntax lr@(L loc r)
=====================================
compiler/GHC/Rename/Bind.hs
=====================================
@@ -21,7 +21,7 @@ module GHC.Rename.Bind (
rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
-- Other bindings
- rnMethodBinds, renameSigs,
+ rnMethodBinds, renameSigs, bindRuleBndrs,
rnMatchGroup, rnGRHSs, rnGRHS, rnSrcFixityDecl,
makeMiniFixityEnv, MiniFixityEnv,
HsSigCtxt(..),
@@ -42,14 +42,10 @@ import GHC.Rename.Pat
import GHC.Rename.Names
import GHC.Rename.Env
import GHC.Rename.Fixity
-import GHC.Rename.Utils ( mapFvRn
- , checkDupRdrNames
- , warnUnusedLocalBinds
- , checkUnusedRecordWildcard
- , checkDupAndShadowedNames, bindLocalNamesFV
- , addNoNestedForallsContextsErr, checkInferredVars )
+import GHC.Rename.Utils
import GHC.Driver.DynFlags
import GHC.Unit.Module
+
import GHC.Types.Error
import GHC.Types.FieldLabel
import GHC.Types.Name
@@ -58,16 +54,19 @@ import GHC.Types.Name.Set
import GHC.Types.Name.Reader ( RdrName, rdrNameOcc )
import GHC.Types.SourceFile
import GHC.Types.SrcLoc as SrcLoc
-import GHC.Data.List.SetOps ( findDupsEq )
import GHC.Types.Basic ( RecFlag(..), TypeOrKind(..) )
-import GHC.Data.Graph.Directed ( SCC(..) )
-import GHC.Data.Bag
+import GHC.Types.Unique.Set
+
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
-import GHC.Types.Unique.Set
+
+import GHC.Data.List.SetOps ( findDupsEq )
+import GHC.Data.Graph.Directed ( SCC(..) )
+import GHC.Data.Bag
import GHC.Data.Maybe ( orElse )
import GHC.Data.OrdList
+
import qualified GHC.LanguageExtensions as LangExt
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
@@ -1091,11 +1090,12 @@ renameSig ctxt sig@(SpecSig _ v tys inl)
= do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt TypeLevel ty
; return ( new_ty:tys, fvs_ty `plusFV` fvs) }
-renameSig ctxt sig@(SpecSigE _ bndrs spec_e inl)
- = bindrRuleBndrs bndrs $ \_ bndrs' ->
- do { (spec_e', fvs) <- rnLExpr spec_e
- ; fn <- checkSpecSig spec_e'
- ; return (SpecSigE fn bndrs' spec_e' inl, fvs) }
+renameSig _ctxt (SpecSigE _ bndrs spec_e inl)
+ = do { fn_rdr <- checkSpecESigShape spec_e
+ ; fn_name <- lookupOccRn fn_rdr -- Checks that the head isn't forall-bound
+ ; bindRuleBndrs (SpecECtx fn_rdr) bndrs $ \_ bndrs' ->
+ do { (spec_e', fvs) <- rnLExpr spec_e
+ ; return (SpecSigE fn_name bndrs' spec_e' inl, fvs) } }
renameSig ctxt sig@(InlineSig _ v s)
= do { new_v <- lookupSigOccRnN ctxt sig v
@@ -1130,25 +1130,26 @@ renameSig _ctxt sig@(CompleteMatchSig (_, s) (L l bf) mty)
this_mod <- fmap tcg_mod getGblEnv
unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $
-- Why 'any'? See Note [Orphan COMPLETE pragmas]
- addErrCtxt (text "In" <+> ppr sig) $ failWithTc TcRnOrphanCompletePragma
+ addErrCtxt (text "In" <+> ppr sig) $
+ failWithTc TcRnOrphanCompletePragma
return (CompleteMatchSig (noAnn, s) (L l new_bf) new_mty, emptyFVs)
-checkSpecSig :: LHsExpr GhcRn -> RnM Name
+checkSpecESigShape :: LHsExpr GhcPs -> RnM RdrName
-- Checks the shape of a SPECIALISE
-- That it looks like (f a1 .. an [ :: ty ])
-checkSpecSig spec_e = go_l spec_e
+checkSpecESigShape spec_e = go_l spec_e
where
go_l (L _ e) = go e
- go (ExprWithSig _ fn _) = go_l fn
- go (HsApp _ fn _) = go_l fn
- go (HsAppType _ fn _) = go_l fn
- go (HsVar fn) = return fn
- go (HsPar e) = go_l e
- go _ = do { addErr (TcRnSpecSigShape spec_e)
- ; return (mkUnboundName (mkVarOccFS (fsLit "SPECIALISE-lhs"))) })
+ go :: HsExpr GhcPs -> RnM RdrName
+ go (ExprWithTySig _ fn _) = go_l fn
+ go (HsApp _ fn _) = go_l fn
+ go (HsAppType _ fn _) = go_l fn
+ go (HsVar _ (L _ fn)) = return fn
+ go (HsPar _ e) = go_l e
+ go _ = failWithTc (TcRnSpecSigShape spec_e)
{-
Note [Orphan COMPLETE pragmas]
@@ -1260,18 +1261,17 @@ checkDupMinimalSigs sigs
sig1 : sig2 : otherSigs -> dupMinimalSigErr sig1 sig2 otherSigs
_ -> return ()
-bindRuleBndrs :: RuleName -> RuleBndrs GhcPs
+bindRuleBndrs :: HsDocContext -> RuleBndrs GhcPs
-> ([Name] -> RuleBndrs GhcRn -> RnM (a,FreeVars))
-> RnM (a,FreeVars)
-bindRuleBndrs rule_name (RuleBndrs { rb_tyvs = tyvs, rb_tmvs = tmvs }) thing_inside
+bindRuleBndrs doc (RuleBndrs { rb_tyvs = tyvs, rb_tmvs = tmvs }) thing_inside
= do { let rdr_names_w_loc = map (get_var . unLoc) tmvs
- doc = RuleCtx rule_name
; checkDupRdrNames rdr_names_w_loc
; checkShadowedRdrNames rdr_names_w_loc
; names <- newLocalBndrsRn rdr_names_w_loc
; bindRuleTyVars doc tyvs $ \ tyvs' ->
bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' ->
- thing_inside (RuleBndrs { rb_tyvs = tyvs', rb_tmvs = tmvs' }) }
+ thing_inside names (RuleBndrs { rb_tyvs = tyvs', rb_tmvs = tmvs' }) }
where
get_var :: RuleBndr GhcPs -> LocatedN RdrName
get_var (RuleBndrSig _ v _) = v
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -820,6 +820,7 @@ wildCardsAllowed env
ExprWithTySigCtx {} -> True
PatCtx {} -> True
RuleCtx {} -> True
+ SpecECtx {} -> True
FamPatCtx {} -> True -- Not named wildcards though
GHCiCtx {} -> True
HsTypeCtx {} -> True
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -25,13 +25,12 @@ import GHC.Hs
import GHC.Types.FieldLabel
import GHC.Types.Name.Reader
import GHC.Rename.HsType
-import GHC.Rename.Bind( bindRuleBndrs )
+import GHC.Rename.Bind
import GHC.Rename.Doc
import GHC.Rename.Env
import GHC.Rename.Utils ( mapFvRn, bindLocalNames
, checkDupRdrNames, bindLocalNamesFV
- , checkShadowedRdrNames, warnUnusedTypePatterns
- , newLocalBndrsRn
+ , warnUnusedTypePatterns
, noNestedForallsContextsErr
, addNoNestedForallsContextsErr, checkInferredVars )
import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) )
@@ -41,7 +40,6 @@ import GHC.Tc.Gen.Annotation ( annCtxt )
import GHC.Tc.Utils.Monad
import GHC.Tc.Types.Origin ( TypedThing(..) )
-import GHC.Types.ForeignCall ( CCallTarget(..) )
import GHC.Unit
import GHC.Unit.Module.Warnings
import GHC.Builtin.Names( applicativeClassName, pureAName, thenAName
@@ -49,22 +47,26 @@ import GHC.Builtin.Names( applicativeClassName, pureAName, thenAName
, semigroupClassName, sappendName
, monoidClassName, mappendName
)
+
+import GHC.Types.ForeignCall ( CCallTarget(..) )
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
-import GHC.Utils.Outputable
-import GHC.Data.Bag
-import GHC.Types.Basic ( TypeOrKind(..) )
-import GHC.Data.FastString
+import GHC.Types.Basic ( TypeOrKind(..), RuleName )
import GHC.Types.SrcLoc as SrcLoc
import GHC.Driver.DynFlags
import GHC.Utils.Misc ( lengthExceeds, partitionWith )
import GHC.Utils.Panic
import GHC.Driver.Env ( HscEnv(..), hsc_home_unit)
+import GHC.Types.Unique.Set
+
+import GHC.Utils.Outputable
+
+import GHC.Data.FastString
+import GHC.Data.Bag
import GHC.Data.List.SetOps ( findDupsEq, removeDupsOn, equivClasses )
import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..)
, stronglyConnCompFromEdgedVerticesUniq )
-import GHC.Types.Unique.Set
import GHC.Data.OrdList
import qualified GHC.LanguageExtensions as LangExt
import GHC.Core.DataCon ( isSrcStrict )
@@ -1149,23 +1151,23 @@ rnHsRuleDecls (HsRules { rds_ext = (_, src)
, rds_rules = rn_rules }, fvs) }
rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
-rnHsRuleDecl (HsRule { rd_ext = (_, st)
- , rd_name = L _ rule_name
- , rd_act = act
- , rd_bndr = bndrs
- , rd_lhs = lhs
- , rd_rhs = rhs })
- = bindRuleBndrs rule_name bndrs $ \tm_names bndrs' ->
+rnHsRuleDecl (HsRule { rd_ext = (_, st)
+ , rd_name = lrule_name@(L _ rule_name)
+ , rd_act = act
+ , rd_bndrs = bndrs
+ , rd_lhs = lhs
+ , rd_rhs = rhs })
+ = bindRuleBndrs (RuleCtx rule_name) bndrs $ \tm_names bndrs' ->
do { (lhs', fv_lhs') <- rnLExpr lhs
; (rhs', fv_rhs') <- rnLExpr rhs
; checkValidRule rule_name tm_names lhs' fv_lhs'
- ; return (HsRule { rd_ext = (HsRuleRn fv_lhs' fv_rhs', st)
- , rd_name = rule_name
- , rd_act = act
- , rd_tyvs = tyvs'
- , rd_tmvs = tmvs'
- , rd_lhs = lhs'
- , rd_rhs = rhs' }, fv_lhs' `plusFV` fv_rhs') } }
+ ; return (HsRule { rd_ext = (HsRuleRn fv_lhs' fv_rhs', st)
+ , rd_name = lrule_name
+ , rd_act = act
+ , rd_bndrs = bndrs'
+ , rd_lhs = lhs'
+ , rd_rhs = rhs' }
+ , fv_lhs' `plusFV` fv_rhs') }
{-
Note [Rule LHS validity checking]
@@ -1183,7 +1185,7 @@ lambdas. So it seems simpler not to check at all, and that is why
check_e is commented out.
-}
-checkValidRule :: FastString -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM ()
+checkValidRule :: RuleName -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM ()
checkValidRule rule_name ids lhs' fv_lhs'
= do { -- Check for the form of the LHS
case (validRuleLhs ids lhs') of
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1295,10 +1295,12 @@ instance Diagnostic TcRnMessage where
PatSynBind {} -> text "Pattern synonyms"
-- Associated pattern synonyms are not implemented yet
_ -> pprPanic "rnMethodBind" (ppr bind)
+
TcRnOrphanCompletePragma -> mkSimpleDecorated $
text "Orphan COMPLETE pragmas not supported" $$
text "A COMPLETE pragma must mention at least one data constructor" $$
text "or pattern synonym defined in the same module."
+
TcRnEmptyCase ctxt -> mkSimpleDecorated message
where
pp_ctxt = case ctxt of
@@ -1340,6 +1342,9 @@ instance Diagnostic TcRnMessage where
, text "Combine alternative minimal complete definitions with `|'" ]
where
sigs = sig1 : sig2 : otherSigs
+ TcRnSpecSigShape spec_e -> mkSimpleDecorated $
+ hang (text "Illegal form of SPECIALISE pragma")
+ 2 (ppr spec_e)
TcRnUnexpectedStandaloneDerivingDecl -> mkSimpleDecorated $
text "Illegal standalone deriving declaration"
TcRnUnusedVariableInRuleDecl name var -> mkSimpleDecorated $
@@ -2278,6 +2283,8 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnOrphanCompletePragma{}
-> ErrorWithoutFlag
+ TcRnSpecSigShape{}
+ -> ErrorWithoutFlag
TcRnEmptyCase{}
-> ErrorWithoutFlag
TcRnNonStdGuards{}
@@ -2925,6 +2932,8 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnOrphanCompletePragma{}
-> noHints
+ TcRnSpecSigShape{}
+ -> noHints
TcRnEmptyCase ctxt -> case ctxt of
LamAlt LamCases -> noHints -- cases syntax doesn't support empty case.
ArrowMatchCtxt (ArrowLamAlt LamCases) -> noHints
@@ -5282,6 +5291,7 @@ pprHsDocContext SpecInstSigCtx = text "a SPECIALISE instance pragma"
pprHsDocContext DefaultDeclCtx = text "a `default' declaration"
pprHsDocContext DerivDeclCtx = text "a deriving declaration"
pprHsDocContext (RuleCtx name) = text "the rewrite rule" <+> doubleQuotes (ftext name)
+pprHsDocContext (SpecECtx name) = text "the SPECIALISE pragma for" <+> quotes (ppr name)
pprHsDocContext (TyDataCtx tycon) = text "the data type declaration for" <+> quotes (ppr tycon)
pprHsDocContext (FamPatCtx tycon) = text "a type pattern of family instance for" <+> quotes (ppr tycon)
pprHsDocContext (TySynCtx name) = text "the declaration for type synonym" <+> quotes (ppr name)
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -3094,6 +3094,14 @@ data TcRnMessage where
-}
TcRnDuplicateMinimalSig :: LSig GhcPs -> LSig GhcPs -> [LSig GhcPs] -> TcRnMessage
+ {-| TcRnSpecSigShape is an error that occurs when the user writes a SPECIALISE
+ pragma that isn't just a function application.
+
+ Example:
+ {-# SPECIALISE let x=True in x #-}
+ -}
+ TcRnSpecSigShape :: LHsExpr GhcPs -> TcRnMessage
+
{-| 'TcRnIllegalInvisTyVarBndr' is an error that occurs
when invisible type variable binders in type declarations
are used without enabling the @TypeAbstractions@ extension.
@@ -5786,6 +5794,7 @@ data HsDocContext
| ForeignDeclCtx (LocatedN RdrName)
| DerivDeclCtx
| RuleCtx FastString
+ | SpecECtx RdrName
| TyDataCtx (LocatedN RdrName)
| TySynCtx (LocatedN RdrName)
| TyFamilyCtx (LocatedN RdrName)
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -69,7 +69,7 @@ module GHC.Tc.Gen.HsType (
tcMult,
-- Pattern type signatures
- tcHsPatSigType, tcHsTyPat,
+ tcHsPatSigType, tcHsTyPat, tcRuleBndrSig,
HoleMode(..),
-- Error messages
@@ -4257,8 +4257,26 @@ tcHsPatSigType ctxt hole_mode
(HsPS { hsps_ext = HsPSRn { hsps_nwcs = sig_wcs, hsps_imp_tvs = sig_ns }
, hsps_body = hs_ty })
ctxt_kind
- = tc_type_in_pat ctxt hole_mode hs_ty sig_wcs sig_ns ctxt_kind
-
+ = tc_type_in_pat ctxt Nothing hole_mode hs_ty sig_wcs sig_ns ctxt_kind
+
+tcRuleBndrSig :: Name
+ -> SkolemInfo
+ -> HsPatSigType GhcRn -- The type signature
+ -> TcM ( [(Name, TcTyVar)] -- Wildcards
+ , [(Name, TcTyVar)] -- The new bit of type environment, binding
+ -- the scoped type variables
+ , TcType) -- The type
+-- Used for type-checking type signatures in
+-- RULE forall bndrs e.g. forall (x::Int). f x = x
+-- See Note [Pattern signature binders and scoping] in GHC.Hs.Type
+--
+-- This may emit constraints
+-- See Note [Recipe for checking a signature]
+tcRuleBndrSig name skol_info
+ (HsPS { hsps_ext = HsPSRn { hsps_nwcs = sig_wcs, hsps_imp_tvs = sig_ns }
+ , hsps_body = hs_ty })
+ = tc_type_in_pat (RuleBndrTypeCtxt name) (Just skol_info)
+ HM_Sig hs_ty sig_wcs sig_ns OpenKind
-- Typecheck type patterns, in data constructor patterns, e.g
-- f (MkT @a @(Maybe b) ...) = ...
@@ -4281,7 +4299,7 @@ tcHsTyPat hs_pat@(HsTP{hstp_ext = hstp_rn, hstp_body = hs_ty}) expected_kind
where
all_ns = imp_ns ++ exp_ns
HsTPRn{hstp_nwcs = wcs, hstp_imp_tvs = imp_ns, hstp_exp_tvs = exp_ns} = hstp_rn
- tc_unif_in_pat = tc_type_in_pat TypeAppCtxt HM_TyAppPat
+ tc_unif_in_pat = tc_type_in_pat TypeAppCtxt Nothing HM_TyAppPat
-- `tc_bndr_in_pat` is used in type patterns to handle the binders case.
-- See Note [Type patterns: binders and unifiers]
@@ -4335,6 +4353,7 @@ tc_bndr_in_pat bndr wcs imp_ns expected_kind = do
--
-- * In patterns `tc_type_in_pat` is used to check pattern signatures.
tc_type_in_pat :: UserTypeCtxt
+ -> Maybe SkolemInfo -- Just sk for RULE and SPECIALISE pragmas only
-> HoleMode -- HM_Sig when in a SigPat, HM_TyAppPat when in a ConPat checking type applications.
-> LHsType GhcRn -- The type in pattern
-> [Name] -- All named wildcards in type
@@ -4344,9 +4363,10 @@ tc_type_in_pat :: UserTypeCtxt
, [(Name, TcTyVar)] -- The new bit of type environment, binding
-- the scoped type variables
, TcType) -- The type
-tc_type_in_pat ctxt hole_mode hs_ty wcs ns ctxt_kind
+tc_type_in_pat ctxt mb_skol hole_mode hs_ty wcs ns ctxt_kind
= addSigCtxt ctxt hs_ty $
- do { tkv_prs <- mapM new_implicit_tv ns
+ do { tkvs <- mapM new_implicit_tv ns
+ ; let tkv_prs = ns `zip` tkvs
; mode <- mkHoleMode TypeLevel hole_mode
; (wcs, ty)
<- addTypeCtxt hs_ty $
@@ -4376,14 +4396,11 @@ tc_type_in_pat ctxt hole_mode hs_ty wcs ns ctxt_kind
where
new_implicit_tv name
= do { kind <- newMetaKindVar
- ; tv <- case ctxt of
- RuleSigCtxt rname _ -> do
- skol_info <- mkSkolemInfo (RuleSkol rname)
- newSkolemTyVar skol_info name kind
- _ -> newPatTyVar name kind
- -- See Note [Typechecking pattern signature binders]
- -- NB: tv's Name may be fresh (in the case of newPatTyVar)
- ; return (name, tv) }
+ ; case mb_skol of
+ Just skol_info -> newSkolemTyVar skol_info name kind
+ Nothing -> newPatTyVar name kind }
+ -- See Note [Typechecking pattern signature binders]
+ -- NB: tv's Name may be fresh (in the case of newPatTyVar)
-- See Note [Type patterns: binders and unifiers]
tyPatToBndr :: HsTyPat GhcRn -> Maybe (HsTyVarBndr () GhcRn)
=====================================
compiler/GHC/Tc/Gen/Rule.hs deleted
=====================================
@@ -1,48 +0,0 @@
-{-# LANGUAGE TypeFamilies #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The AQUA Project, Glasgow University, 1993-1998
-
--}
-
--- | Typechecking rewrite rules
-module GHC.Tc.Gen.Rule (
- tcRules,
- tcRuleBndrs,
- mkTcRuleBndrs
- ) where
-
-import GHC.Prelude
-
-import GHC.Hs
-import GHC.Tc.Types
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Solver
-import GHC.Tc.Solver.Monad ( runTcS )
-import GHC.Tc.Types.Constraint
-import GHC.Tc.Types.Origin
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Gen.HsType
-import GHC.Tc.Gen.Sig( tcRuleBndrs )
-import GHC.Tc.Gen.Expr
-import GHC.Tc.Utils.Env
-import GHC.Tc.Utils.Unify( buildImplicationFor )
-import GHC.Tc.Zonk.TcType
-
-import GHC.Core.Type
-import GHC.Core.Coercion( mkCoVarCo )
-import GHC.Core.TyCon( isTypeFamilyTyCon )
-import GHC.Core.Predicate
-
-import GHC.Types.Id
-import GHC.Types.Var( EvVar, tyVarName )
-import GHC.Types.Var.Set
-import GHC.Types.Basic ( RuleName, NonStandardDefaultingStrategy(..) )
-import GHC.Types.SrcLoc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Data.FastString
-import GHC.Data.Bag
-
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -35,28 +35,36 @@ import GHC.Driver.Backend
import GHC.Hs
+import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcInferRho, tcCheckMonoExpr )
+
import GHC.Tc.Errors.Types ( FixedRuntimeRepProvenance(..), TcRnMessage(..) )
import GHC.Tc.Gen.HsType
-import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities )
import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.TcMType ( checkTypeHasFixedRuntimeRep )
import GHC.Tc.Zonk.Type
-import GHC.Tc.Types
import GHC.Tc.Types.Origin
+import GHC.Tc.Solver
+import GHC.Tc.Solver.Monad ( runTcS )
import GHC.Tc.Utils.TcType
+import GHC.Tc.Utils.TcMType
import GHC.Tc.Validity ( checkValidType )
-import GHC.Tc.Utils.Unify( tcTopSkolemise, unifyType )
+import GHC.Tc.Utils.Unify( tcTopSkolemise, unifyType, buildImplicationFor )
import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs )
-import GHC.Tc.Utils.Env( tcLookupId )
+import GHC.Tc.Utils.Env
import GHC.Tc.Types.Evidence( HsWrapper, (<.>) )
+import GHC.Tc.Types.Constraint
+import GHC.Tc.Zonk.TcType
import GHC.Core( hasSomeUnfolding )
-import GHC.Core.Type ( mkTyVarBinders )
+import GHC.Core.Type
import GHC.Core.Multiplicity
+import GHC.Core.Predicate
+import GHC.Core.Coercion( mkCoVarCo )
import GHC.Core.TyCo.Rep( mkNakedFunTy )
+import GHC.Core.TyCon( isTypeFamilyTyCon )
-import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars, invisArgTypeLike )
-import GHC.Types.Id ( Id, idName, idType, setInlinePragma
+import GHC.Types.Var
+import GHC.Types.Var.Set
+import GHC.Types.Id ( idName, idType, setInlinePragma
, mkLocalId, realIdUnfolding )
import GHC.Types.Basic
import GHC.Types.Name
@@ -70,6 +78,7 @@ import GHC.Utils.Misc as Utils ( singleton )
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Data.Bag
import GHC.Data.Maybe( orElse, whenIsJust )
import Data.Maybe( mapMaybe )
@@ -593,7 +602,7 @@ mkPragEnv sigs binds
get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn)
get_sig sig@(L _ (SpecSig _ (L _ nm) _ _)) = Just (nm, add_arity nm sig)
- get_sig sig@(L _ (SpecSigE nm _ _)) = Just (nm, add_arity nm sig)
+ get_sig sig@(L _ (SpecSigE nm _ _ _)) = Just (nm, add_arity nm sig)
get_sig sig@(L _ (InlineSig _ (L _ nm) _)) = Just (nm, add_arity nm sig)
get_sig sig@(L _ (SCCFunSig _ (L _ nm) _)) = Just (nm, sig)
get_sig _ = Nothing
@@ -610,7 +619,7 @@ mkPragEnv sigs binds
addInlinePragArity :: Arity -> LSig GhcRn -> LSig GhcRn
addInlinePragArity ar (L l (InlineSig x nm inl)) = L l (InlineSig x nm (add_inl_arity ar inl))
addInlinePragArity ar (L l (SpecSig x nm ty inl)) = L l (SpecSig x nm ty (add_inl_arity ar inl))
-addInlinePragArity ar (L l (SpecSigE x e inl)) = L l (SpecSigE x e (add_inl_arity ar inl))
+addInlinePragArity ar (L l (SpecSigE n x e inl)) = L l (SpecSigE n x e (add_inl_arity ar inl))
addInlinePragArity _ sig = sig
add_inl_arity :: Arity -> InlinePragma -> InlinePragma
@@ -677,7 +686,7 @@ should add the arity later for all binders. But it works fine like this.
* *
************************************************************************
-Note [Handling SPECIALISE pragmas]
+Note [Handling SPoECIALISE pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The basic idea is this:
@@ -826,6 +835,7 @@ tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl)
; wrap <- tcSpecWrapper (FunSigCtxt name (lhsSigTypeContextSpan hs_ty)) poly_ty spec_ty
; return (SpecPrag poly_id wrap inl) }
+-- SPECIALISE expressions
-- Example: f :: forall a. Ord a => a -> Bool -> blah
-- {-# SPECIALISE forall x. f (x::Int) True #-}
-- We typecheck, and generate (SpecPragE [x] (f @Int dOrdInt x True))
@@ -834,29 +844,52 @@ tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl)
-- RULE forall d x. f @Int d x True = $sf x
-- The thing in the SpecPragE is very very like the LHS of a RULE
-tcSpecPrag poly_id prag@(SpecSigE nm bndrs spec_e inl)
- = do { (tc_lvl, wanted, (id_bndrs, spec_e', rho))
+tcSpecPrag _poly_id (SpecSigE nm bndrs spec_e inl)
+ = do { skol_info <- mkSkolemInfo (SpecESkol nm)
+ ; (tc_lvl, wanted, (id_bndrs, spec_e', rho))
<- pushLevelAndCaptureConstraints $
- do { (tv_bndrs, id_bndrs) <- tcRuleBndrs rule_name bndrs
+ do { (tv_bndrs, id_bndrs) <- tcRuleBndrs skol_info bndrs
; tcExtendNameTyVarEnv [(tyVarName tv, tv) | tv <- tv_bndrs] $
tcExtendIdEnv id_bndrs $
do { (spec_e', rho) <- tcInferRho spec_e
; return (id_bndrs, spec_e', rho) } }
- ; _ <- setTcLevel tc_lvl $ runTcS $ solveWanteds wanteds
- ; wanted <- liftZonkM $ zonkWC wanted
+ -- Solve unfication constraints
+ ; _ <- setTcLevel tc_lvl $ runTcS $ solveWanteds wanted
+
+ -- Apply the unifications
+ ; wanted <- liftZonkM (zonkWC wanted)
+ ; seed_tys <- liftZonkM (mapM zonkTcType (rho : map idType id_bndrs)
; let (quant_cts, residual_wanted) = getRuleQuantCts wanted
- ; quant_evs <- mapM mk_quant_ev (bagToList quant_cts)
- ; let tpl_ids = quant_evs ++ id_bndrs
- ; forall_tkvs <- candidateQTyVarsOfTypes (rho : map idType tpl_ids)
- ; skol_info <- mkSkolemInfo (RuleSkol nm)
- ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars forall_tkvs
+ quant_preds = map ctPred quant_cts
+ grown_tcvs = growThetaTyVars quant_preds (tyCoVarsOfTypes seed_tys)
+
+ ; dvs <- candidateQTyVarsOfTypes (quant_preds ++ seed_tys)
+ ; let weeded_dvs = weedOutCandidates (`dVarSetIntersectVarSet` grown_tcvs) dvs
+ ; skol_info <- mkSkolemInfo (SpecESkol nm)
+ ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars weeded_dvs
+
+ ; let (bound_cts, free_cts) = partition is_bound quant_cts
+ is_bound ct = any (`elemVarSet` tyCoVarsOfCt ct) qtkvs)
+
+
+ ; free_evs <- mapM mk_quant_ev free_cts
+ ; bound_evs <- mapM mk_quant_ev bound_cts
+ ; let quant_evs = free_evs ++ bound_evs
+
; (implic, ev_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs
quant_evs residual_wanted
- ; emitImplication implic
- ; return (SpecPragE (mkTcRuleBndrs bndrs (qtkvs ++ tpl_ids)
- spec_e' inl)) }
+ ; emitImplications implic
+ ; emitSimples (listToBag free_cts)
+
+ ; let bndrs' = mkTcRuleBndrs bndrs (qtkvs ++ bound_evs ++ id_bnrs)
+ full_e' = mkHsDictLet ev_binds spec_e'
+ ; traceTc "tcSpecPrag:SpecSigE" $
+ vcat [ text "bndrs:" <+> ppr bndrs'
+ , text "full_e:" <+> ppr full_e'
+ , text "inl:" <+> ppr inl ]
+ ; return [SpecPragE bndrs' free_evs full_e' inl] }
tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag)
@@ -1016,7 +1049,7 @@ tcRule (HsRule { rd_ext = ext
; skol_info <- mkSkolemInfo (RuleSkol name)
-- Note [Typechecking rules]
; (tc_lvl, stuff) <- pushTcLevelM $
- generateRuleConstraints name bndrs lhs rhs
+ generateRuleConstraints skol_info bndrs lhs rhs
; let (id_bndrs, lhs', lhs_wanted
, rhs', rhs_wanted, rule_ty) = stuff
@@ -1044,11 +1077,10 @@ tcRule (HsRule { rd_ext = ext
; let tpl_ids = lhs_evs ++ id_bndrs
-- See Note [Re-quantify type variables in rules]
- ; forall_tkvs <- candidateQTyVarsOfTypes (rule_ty : map idType tpl_ids)
+ ; dvs <- candidateQTyVarsOfTypes (rule_ty : map idType tpl_ids)
; let weed_out = (`dVarSetMinusVarSet` dont_default)
- quant_cands = forall_tkvs { dv_kvs = weed_out (dv_kvs forall_tkvs)
- , dv_tvs = weed_out (dv_tvs forall_tkvs) }
- ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars quant_cands
+ weeded_dvs = weedOutCandidates weed_out dvs
+ ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars weeded_dvs
; traceTc "tcRule" (vcat [ pprFullRuleName (snd ext) rname
, text "forall_tkvs:" <+> ppr forall_tkvs
, text "quant_cands:" <+> ppr quant_cands
@@ -1056,7 +1088,7 @@ tcRule (HsRule { rd_ext = ext
, text "residual_lhs_wanted:" <+> ppr residual_lhs_wanted
, text "qtkvs:" <+> ppr qtkvs
, text "rule_ty:" <+> ppr rule_ty
- , text "ty_bndrs:" <+> ppr ty_bndrs
+ , text "bndrs:" <+> ppr bndrs
, text "qtkvs ++ tpl_ids:" <+> ppr (qtkvs ++ tpl_ids)
, text "tpl_id info:" <+>
vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ]
@@ -1072,28 +1104,28 @@ tcRule (HsRule { rd_ext = ext
; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs
lhs_evs rhs_wanted
; emitImplications (lhs_implic `unionBags` rhs_implic)
- ; return $ HsRule { rd_ext = ext
- , rd_name = rname
- , rd_act = act
- , rd_bnrs = mkTcRuleBndrs bndrs (qtkvs ++ tpl_ids)
- , rd_lhs = mkHsDictLet lhs_binds lhs'
- , rd_rhs = mkHsDictLet rhs_binds rhs' } }
-
-mkTcRuleBndrs :: RuleBndrs GhcRn -> [Var] -> RuleBndrs GHCTc
+ ; return $ HsRule { rd_ext = ext
+ , rd_name = rname
+ , rd_act = act
+ , rd_bndrs = mkTcRuleBndrs bndrs (qtkvs ++ tpl_ids)
+ , rd_lhs = mkHsDictLet lhs_binds lhs'
+ , rd_rhs = mkHsDictLet rhs_binds rhs' } }
+
+mkTcRuleBndrs :: RuleBndrs GhcRn -> [Var] -> RuleBndrs GhcTc
mkTcRuleBndrs (RuleBndrs { rb_tyvs = tyvs }) vars
= RuleBndrs { rb_tyvs = tyvs -- preserved for ppr-ing
, rb_tmvs = map (noLocA . RuleBndr noAnn . noLocA) vars }
-generateRuleConstraints :: FastString
+generateRuleConstraints :: SkolemInfo
-> RuleBndrs GhcRn
-> LHsExpr GhcRn -> LHsExpr GhcRn
-> TcM ( [TcId]
, LHsExpr GhcTc, WantedConstraints
, LHsExpr GhcTc, WantedConstraints
, TcType )
-generateRuleConstraints rule_namebndrs lhs rhs
+generateRuleConstraints skol_info bndrs lhs rhs
= do { ((tv_bndrs, id_bndrs), bndr_wanted) <- captureConstraints $
- tcRuleBndrs rule_name bndrs
+ tcRuleBndrs skol_info bndrs
-- bndr_wanted constraints can include wildcard hole
-- constraints, which we should not forget about.
-- It may mention the skolem type variables bound by
@@ -1114,40 +1146,38 @@ ruleCtxt name = text "When checking the rewrite rule" <+>
-- See Note [TcLevel in type checking rules]
-tcRuleBndrs :: RuleName -> RuleBndrs GhcRn
+tcRuleBndrs :: SkolemInfo -> RuleBndrs GhcRn
-> TcM ([TcTyVar], [Id])
-tcRuleBndrs rule_name (RuleBndrs { rb_tyvs = mb_tv_bndrs, rb_tmvs = tmvs })) xs
+tcRuleBndrs skol_info (RuleBndrs { rb_tyvs = mb_tv_bndrs, rb_tmvs = tmvs })
| Just tv_bndrs <- mb_tv_bndrs
- = do { skol_info <- mkSkolemInfo (RuleSkol rule_name)
- ; (tybndrs1,(tys2,tms)) <- bindExplicitTKBndrs_Skol skol_info tv_bndrs $
- tcRuleTmBndrs rule_name tmvs
+ = do { (tybndrs1,(tys2,tms)) <- bindExplicitTKBndrs_Skol skol_info tv_bndrs $
+ tcRuleTmBndrs skol_info tmvs
; let tys1 = binderVars tybndrs1
; return (tys1 ++ tys2, tms) }
| otherwise
- = tcRuleTmBndrs rule_name xs
+ = tcRuleTmBndrs skol_info tmvs
-- See Note [TcLevel in type checking rules]
-tcRuleTmBndrs :: FastString -> [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id])
+tcRuleTmBndrs :: SkolemInfo -> [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id])
tcRuleTmBndrs _ [] = return ([],[])
-tcRuleTmBndrs rule_name (L _ (RuleBndr _ (L _ name)) : rule_bndrs)
+tcRuleTmBndrs skol_info (L _ (RuleBndr _ (L _ name)) : rule_bndrs)
= do { ty <- newOpenFlexiTyVarTy
- ; (tyvars, tmvars) <- tcRuleTmBndrs rule_name rule_bndrs
+ ; (tyvars, tmvars) <- tcRuleTmBndrs skol_info rule_bndrs
; return (tyvars, mkLocalId name ManyTy ty : tmvars) }
-tcRuleTmBndrs rule_name (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs)
+tcRuleTmBndrs skol_info (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs)
-- e.g x :: a->a
-- The tyvar 'a' is brought into scope first, just as if you'd written
-- a::*, x :: a->a
-- If there's an explicit forall, the renamer would have already reported an
-- error for each out-of-scope type variable used
- = do { let ctxt = RuleSigCtxt rule_name name
- ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt HM_Sig rn_ty OpenKind
+ = do { (_ , tvs, id_ty) <- tcRuleBndrSig name skol_info rn_ty
; let id = mkLocalId name ManyTy id_ty
- -- See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType
+ -- See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType
-- The type variables scope over subsequent bindings; yuk
; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $
- tcRuleTmBndrs rule_name rule_bndrs
+ tcRuleTmBndrs skol_info rule_bndrs
; return (map snd tvs ++ tyvars, id : tmvars) }
{-
@@ -1220,7 +1250,7 @@ revert to SimplCheck when going under an implication.
* Step 2: Zonk the ORIGINAL (unsimplified) LHS constraints, to take
advantage of those unifications
-* Setp 3: Partition the LHS constraints into the ones we will
+* Step 3: Partition the LHS constraints into the ones we will
quantify over, and the others.
See Note [RULE quantification over equalities]
@@ -1330,10 +1360,10 @@ simplifyRule name tc_lvl lhs_wanted rhs_wanted
-- Note [The SimplifyRule Plan] step 2
; lhs_wanted <- liftZonkM $ zonkWC lhs_wanted
- ; let (quant_cts, residual_lhs_wanted) = getRuleQuantCts lhs_wanted
-- Note [The SimplifyRule Plan] step 3
- ; quant_evs <- mapM mk_quant_ev (bagToList quant_cts)
+ ; let (quant_cts, residual_lhs_wanted) = getRuleQuantCts lhs_wanted
+ ; quant_evs <- mapM mk_quant_ev quant_cts
; traceTc "simplifyRule" $
vcat [ text "LHS of rule" <+> doubleQuotes (ftext name)
@@ -1358,7 +1388,7 @@ mk_quant_ev ct
mk_quant_ev ct = pprPanic "mk_quant_ev" (ppr ct)
-getRuleQuantCts :: WantedConstraints -> (Cts, WantedConstraints)
+getRuleQuantCts :: WantedConstraints -> ([Ct], WantedConstraints)
-- Extract all the constraints we can quantify over,
-- also returning the depleted WantedConstraints
--
@@ -1377,8 +1407,10 @@ getRuleQuantCts :: WantedConstraints -> (Cts, WantedConstraints)
-- Not hard, but tiresome.
getRuleQuantCts wc
- = float_wc emptyVarSet wc
+ = (bagToList quant_cts, residual}
where
+ !(quant_cts, residual) = float_wc emptyVarSet wc
+
float_wc :: TcTyCoVarSet -> WantedConstraints -> (Cts, WantedConstraints)
float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics, wc_errors = errs })
= ( simple_yes `andCts` implic_yes
=====================================
compiler/GHC/Tc/Solver.hs
=====================================
@@ -2011,10 +2011,8 @@ decideQuantifiedTyVars skol_info name_taus psigs candidates
-- Keep the psig_tys first, so that candidateQTyVarsOfTypes produces
-- them in that order, so that the final qtvs quantifies in the same
-- order as the partial signatures do (#13524)
- ; dv at DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} <- candidateQTyVarsOfTypes $
- psig_tys ++ candidates ++ tau_tys
- ; let pick = (`dVarSetIntersectVarSet` grown_tcvs)
- dvs_plus = dv { dv_kvs = pick cand_kvs, dv_tvs = pick cand_tvs }
+ ; dvs <- candidateQTyVarsOfTypes (psig_tys ++ candidates ++ tau_tys)
+ ; let dvs_plus = weedOutCandidates (`dVarSetIntersectVarSet` grown_tcvs) dvs
; traceTc "decideQuantifiedTyVars" (vcat
[ text "tau_tys =" <+> ppr tau_tys
=====================================
compiler/GHC/Tc/Types/Constraint.hs
=====================================
@@ -1835,6 +1835,7 @@ checkSkolInfoAnon sk1 sk2 = go sk1 sk2
go FamInstSkol FamInstSkol = True
go BracketSkol BracketSkol = True
go (RuleSkol n1) (RuleSkol n2) = n1==n2
+ go (SpecESkol n1) (SpecESkol n2) = n1==n2
go (PatSkol c1 _) (PatSkol c2 _) = getName c1 == getName c2
-- Too tedious to compare the HsMatchContexts
go (InferSkol ids1) (InferSkol ids2) = equalLength ids1 ids2 &&
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -128,8 +128,6 @@ data UserTypeCtxt
| PatSigCtxt -- Type sig in pattern
-- eg f (x::t) = ...
-- or (x::t, y) = e
- | RuleSigCtxt FastString Name -- LHS of a RULE forall
- -- RULE "foo" forall (x :: a -> a). f (Just x) = ...
| ForSigCtxt Name -- Foreign import or export signature
| DefaultDeclCtxt -- Types in a default declaration
| InstDeclCtxt Bool -- An instance declaration
@@ -152,6 +150,9 @@ data UserTypeCtxt
-- data <S> => T a = MkT a
| DerivClauseCtxt -- A 'deriving' clause
| TyVarBndrKindCtxt Name -- The kind of a type variable being bound
+ | RuleBndrTypeCtxt Name -- The type of a term variable being bound in a RULE
+ -- or SPECIALISE pragma
+ -- RULE "foo" forall (x :: a -> a). f (Just x) = ...
| DataKindCtxt Name -- The kind of a data/newtype (instance)
| TySynKindCtxt Name -- The kind of the RHS of a type synonym
| TyFamResKindCtxt Name -- The result kind of a type family
@@ -189,11 +190,10 @@ redundantConstraintsSpan _ = noSrcSpan
pprUserTypeCtxt :: UserTypeCtxt -> SDoc
-pprUserTypeCtxt (FunSigCtxt n _) = text "the type signature for" <+> quotes (ppr n)
-pprUserTypeCtxt (InfSigCtxt n) = text "the inferred type for" <+> quotes (ppr n)
-pprUserTypeCtxt (RuleSigCtxt _ n) = text "the type signature for" <+> quotes (ppr n)
-pprUserTypeCtxt (ExprSigCtxt _) = text "an expression type signature"
-pprUserTypeCtxt KindSigCtxt = text "a kind signature"
+pprUserTypeCtxt (FunSigCtxt n _) = text "the type signature for" <+> quotes (ppr n)
+pprUserTypeCtxt (InfSigCtxt n) = text "the inferred type for" <+> quotes (ppr n)
+pprUserTypeCtxt (ExprSigCtxt _) = text "an expression type signature"
+pprUserTypeCtxt KindSigCtxt = text "a kind signature"
pprUserTypeCtxt (StandaloneKindSigCtxt n) = text "a standalone kind signature for" <+> quotes (ppr n)
pprUserTypeCtxt TypeAppCtxt = text "a type argument"
pprUserTypeCtxt (ConArgCtxt c) = text "the type of the constructor" <+> quotes (ppr c)
@@ -212,6 +212,7 @@ pprUserTypeCtxt (DataTyCtxt tc) = text "the context of the data type declarati
pprUserTypeCtxt (PatSynCtxt n) = text "the signature for pattern synonym" <+> quotes (ppr n)
pprUserTypeCtxt (DerivClauseCtxt) = text "a `deriving' clause"
pprUserTypeCtxt (TyVarBndrKindCtxt n) = text "the kind annotation on the type variable" <+> quotes (ppr n)
+pprUserTypeCtxt (RuleBndrTypeCtxt n) = text "the type signature for" <+> quotes (ppr n)
pprUserTypeCtxt (DataKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n)
pprUserTypeCtxt (TySynKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n)
pprUserTypeCtxt (TyFamResKindCtxt n) = text "the result kind for" <+> quotes (ppr n)
@@ -293,6 +294,7 @@ data SkolemInfoAnon
| IPSkol [HsIPName] -- Binding site of an implicit parameter
| RuleSkol RuleName -- The LHS of a RULE
+ | SpecESkol Name -- A SPECIALISE pragma
| InferSkol [(Name,TcType)]
-- We have inferred a type for these (mutually recursive)
@@ -364,6 +366,7 @@ pprSkolInfo (InstSkol (IsQC {}) sz) = vcat [ text "a quantified context"
pprSkolInfo FamInstSkol = text "a family instance declaration"
pprSkolInfo BracketSkol = text "a Template Haskell bracket"
pprSkolInfo (RuleSkol name) = text "the RULE" <+> pprRuleName name
+pprSkolInfo (SpecESkol name) = text "a SPECIALISE pragma for" <+> quotes (ppr name)
pprSkolInfo (PatSkol cl mc) = sep [ pprPatSkolInfo cl
, text "in" <+> pprMatchContext mc ]
pprSkolInfo (InferSkol ids) = hang (text "the inferred type" <> plural ids <+> text "of")
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -84,7 +84,7 @@ module GHC.Tc.Utils.TcMType (
candidateQTyVarsOfType, candidateQTyVarsOfKind,
candidateQTyVarsOfTypes, candidateQTyVarsOfKinds,
- candidateQTyVarsWithBinders,
+ candidateQTyVarsWithBinders, weedOutCandidates,
CandidatesQTvs(..), delCandidates,
candidateKindVars, partitionCandidates,
@@ -1335,6 +1335,10 @@ instance Outputable CandidatesQTvs where
, text "dv_tvs =" <+> ppr tvs
, text "dv_cvs =" <+> ppr cvs ])
+weedOutCandidates :: (DTyVarSet -> DTyVarSet) -> CandidateQTVs -> CandidateQTVs
+weedOutCandidate weed_out dv@(DV { dv_kvs = kvs; dv_tvs = tvs })
+ = dv { dv_kvs = weed_out kvs, dv_tvs = weed_out tvs }
+
isEmptyCandidates :: CandidatesQTvs -> Bool
isEmptyCandidates (DV { dv_kvs = kvs, dv_tvs = tvs })
= isEmptyDVarSet kvs && isEmptyDVarSet tvs
=====================================
compiler/GHC/Tc/Validity.hs
=====================================
@@ -391,7 +391,6 @@ checkValidType ctxt ty
= case ctxt of
DefaultDeclCtxt-> MustBeMonoType
PatSigCtxt -> rank0
- RuleSigCtxt {} -> rank1
TySynCtxt _ -> rank0
ExprSigCtxt {} -> rank1
@@ -415,10 +414,11 @@ checkValidType ctxt ty
SpecInstCtxt -> rank1
GhciCtxt {} -> ArbitraryRank
- TyVarBndrKindCtxt _ -> rank0
- DataKindCtxt _ -> rank1
- TySynKindCtxt _ -> rank1
- TyFamResKindCtxt _ -> rank1
+ TyVarBndrKindCtxt {} -> rank0
+ RuleBndrTypeCtxt{} -> rank1
+ DataKindCtxt _ -> rank1
+ TySynKindCtxt _ -> rank1
+ TyFamResKindCtxt _ -> rank1
_ -> panic "checkValidType"
-- Can't happen; not used for *user* sigs
@@ -552,7 +552,7 @@ typeOrKindCtxt (ExprSigCtxt {}) = OnlyTypeCtxt
typeOrKindCtxt (TypeAppCtxt {}) = OnlyTypeCtxt
typeOrKindCtxt (PatSynCtxt {}) = OnlyTypeCtxt
typeOrKindCtxt (PatSigCtxt {}) = OnlyTypeCtxt
-typeOrKindCtxt (RuleSigCtxt {}) = OnlyTypeCtxt
+typeOrKindCtxt (RuleBndrTypeCtxt {})= OnlyTypeCtxt
typeOrKindCtxt (ForSigCtxt {}) = OnlyTypeCtxt
typeOrKindCtxt (DefaultDeclCtxt {}) = OnlyTypeCtxt
typeOrKindCtxt (InstDeclCtxt {}) = OnlyTypeCtxt
@@ -1474,7 +1474,7 @@ okIPCtxt (StandaloneKindSigCtxt {}) = False
okIPCtxt (ClassSCCtxt {}) = False
okIPCtxt (InstDeclCtxt {}) = False
okIPCtxt (SpecInstCtxt {}) = False
-okIPCtxt (RuleSigCtxt {}) = False
+okIPCtxt (RuleBndrTypeCtxt {}) = False
okIPCtxt DefaultDeclCtxt = False
okIPCtxt DerivClauseCtxt = False
okIPCtxt (TyVarBndrKindCtxt {}) = False
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -852,9 +852,13 @@ zonkLTcSpecPrags ps
= mapM zonk_prag ps
where
zonk_prag (L loc (SpecPrag id co_fn inl))
- = do { co_fn' <- don'tBind $ zonkCoFn co_fn
- ; id' <- zonkIdOcc id
- ; return (L loc (SpecPrag id' co_fn' inl)) }
+ = do { co_fn' <- don'tBind $ zonkCoFn co_fn
+ ; id' <- zonkIdOcc id
+ ; return (L loc (SpecPrag id' co_fn' inl)) }
+ zonk_prag (L loc (SpecPragE bndrs spec_e inl))
+ = zonkRuleBndrs bndrs $ \ bndrs' ->
+ do { spec_e' <- zonkLExpr spec_e
+ ; return (L loc (SpecPragE bndrs' spec_e' inl)) }
{-
************************************************************************
@@ -1653,16 +1657,22 @@ zonkRules :: [LRuleDecl GhcTc] -> ZonkTcM [LRuleDecl GhcTc]
zonkRules rs = mapM (wrapLocZonkMA zonkRule) rs
zonkRule :: RuleDecl GhcTc -> ZonkTcM (RuleDecl GhcTc)
-zonkRule rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-}
+zonkRule rule@(HsRule { rd_bndrs = bndrs
, rd_lhs = lhs
, rd_rhs = rhs })
- = runZonkBndrT (traverse zonk_tm_bndr tm_bndrs) $ \ new_tm_bndrs ->
+ = zonkRuleBndrs bndrs $ \ new_bndrs ->
do { -- See Note [Zonking the LHS of a RULE]
; new_lhs <- setZonkType SkolemiseFlexi $ zonkLExpr lhs
; new_rhs <- zonkLExpr rhs
- ; return $ rule { rd_tmvs = new_tm_bndrs
+ ; return $ rule { rd_bndrs = new_bndrs
, rd_lhs = new_lhs
, rd_rhs = new_rhs } }
+
+
+zonkRuleBndrs :: RuleBndrs GhcTc -> (RuleBndrs GhcTc -> ZonkTcM a) -> ZonkTcM a
+zonkRuleBndrs (RuleBndrs { rb_tyvs = tyvs, rb_tmvs = tmvs }) thing_inside
+ = runZonkBndrT (traverse zonk_tm_bndr tmvs) $ \ new_tmvs ->
+ thing_inside (RuleBndrs { rb_tyvs = tyvs, rb_tmvs = new_tmvs })
where
zonk_tm_bndr :: LRuleBndr GhcTc -> ZonkBndrTcM (LRuleBndr GhcTc)
zonk_tm_bndr (L l (RuleBndr x (L loc v)))
@@ -1672,11 +1682,9 @@ zonkRule rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-}
zonk_it v
| isId v = zonkIdBndrX v
- | otherwise = assert (isImmutableTyVar v)
+ | otherwise = assert (isImmutableTyVar v) $
zonkTyBndrX v
- -- DV: used to be "return v", but that is plain
- -- wrong because we may need to go inside the kind
- -- of v and zonk there!
+ -- We may need to go inside the kind of v and zonk there!
{-
************************************************************************
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -914,8 +914,7 @@ cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)
HsRule { rd_ext = (noAnn, quotedSourceText nm)
, rd_name = rd_name'
, rd_act = act
- , rd_tyvs = ty_bndrs'
- , rd_tmvs = tm_bndrs'
+ , rd_bndrs = RuleBndrs { rb_tyvs = ty_bndrs', rb_tmvs = tm_bndrs' }
, rd_lhs = lhs'
, rd_rhs = rhs' }
; returnJustLA $ Hs.RuleD noExtField
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -519,6 +519,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnMisplacedSigDecl" = 87866
GhcDiagnosticCode "TcRnUnexpectedDefaultSig" = 40700
GhcDiagnosticCode "TcRnDuplicateMinimalSig" = 85346
+ GhcDiagnosticCode "TcRnSpecSigShape" = 93944
GhcDiagnosticCode "TcRnLoopySuperclassSolve" = Outdated 36038
GhcDiagnosticCode "TcRnUnexpectedStandaloneDerivingDecl" = 95159
GhcDiagnosticCode "TcRnUnusedVariableInRuleDecl" = 65669
=====================================
compiler/Language/Haskell/Syntax/Binds.hs
=====================================
@@ -551,6 +551,37 @@ isCompleteMatchSig :: forall p. UnXRec p => LSig p -> Bool
isCompleteMatchSig (unXRec @p -> CompleteMatchSig {} ) = True
isCompleteMatchSig _ = False
+{- *********************************************************************
+* *
+ Rule binders
+* *
+********************************************************************* -}
+
+data RuleBndrs pass = RuleBndrs
+ { rb_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc pass)]
+ -- ^ Forall'd type vars
+ , rb_tmvs :: [LRuleBndr pass]
+ -- ^ Forall'd term vars, before typechecking;
+ -- after typechecking this includes all forall'd vars
+ }
+
+-- | Located Rule Binder
+type LRuleBndr pass = XRec pass (RuleBndr pass)
+
+-- | Rule Binder
+data RuleBndr pass
+ = RuleBndr (XCRuleBndr pass) (LIdP pass)
+ | RuleBndrSig (XRuleBndrSig pass) (LIdP pass) (HsPatSigType pass)
+ | XRuleBndr !(XXRuleBndr pass)
+ -- ^
+ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',
+ -- 'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnClose'
+
+ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
+
+collectRuleBndrSigTys :: [RuleBndr pass] -> [HsPatSigType pass]
+collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs]
+
{-
************************************************************************
* *
=====================================
compiler/Language/Haskell/Syntax/Decls.hs
=====================================
@@ -1649,30 +1649,6 @@ data RuleDecl pass
-- 'GHC.Parser.Annotation.AnnEqual',
| XRuleDecl !(XXRuleDecl pass)
-data RuleBndrs pass = RuleBndrs
- { rb_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc pass)]
- -- ^ Forall'd type vars
- , rb_tmvs :: [LRuleBndr pass]
- -- ^ Forall'd term vars, before typechecking;
- -- after typechecking this includes all forall'd vars
- }
-
--- | Located Rule Binder
-type LRuleBndr pass = XRec pass (RuleBndr pass)
-
--- | Rule Binder
-data RuleBndr pass
- = RuleBndr (XCRuleBndr pass) (LIdP pass)
- | RuleBndrSig (XRuleBndrSig pass) (LIdP pass) (HsPatSigType pass)
- | XRuleBndr !(XXRuleBndr pass)
- -- ^
- -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',
- -- 'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnClose'
-
- -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
-
-collectRuleBndrSigTys :: [RuleBndr pass] -> [HsPatSigType pass]
-collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs]
{-
************************************************************************
=====================================
compiler/Language/Haskell/Syntax/Extension.hs
=====================================
@@ -211,6 +211,7 @@ type family XIdSig x
type family XFixSig x
type family XInlineSig x
type family XSpecSig x
+type family XSpecSigE x
type family XSpecInstSig x
type family XMinimalSig x
type family XSCCFunSig x
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cac643df7fb8fe5321be02780bef32f40e98f2e8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cac643df7fb8fe5321be02780bef32f40e98f2e8
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240212/84712d38/attachment-0001.html>
More information about the ghc-commits
mailing list