[Git][ghc/ghc][wip/T24359] fix TH tests
sheaf (@sheaf)
gitlab at gitlab.haskell.org
Fri Nov 29 13:40:50 UTC 2024
sheaf pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC
Commits:
a0f0e094 by sheaf at 2024-11-29T14:40:40+01:00
fix TH tests
- - - - -
4 changed files:
- compiler/GHC/Builtin/Names/TH.hs
- compiler/GHC/HsToCore/Quote.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
- libraries/template-haskell/Language/Haskell/TH/Lib.hs
Changes:
=====================================
compiler/GHC/Builtin/Names/TH.hs
=====================================
@@ -75,7 +75,9 @@ templateHaskellNames = [
funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName,
classDName, instanceWithOverlapDName,
standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName,
- pragInlDName, pragOpaqueDName, pragSpecDName, pragSpecEDName, pragSpecInstDName,
+ pragInlDName, pragOpaqueDName,
+ pragSpecDName, pragSpecInlDName, pragSpecEDName, pragSpecInlEDName,
+ pragSpecInstDName,
pragRuleDName, pragCompleteDName, pragAnnDName, pragSCCFunDName, pragSCCFunNamedDName,
defaultSigDName, defaultDName,
dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
@@ -386,7 +388,8 @@ recSName = libFun (fsLit "recS") recSIdKey
-- data Dec = ...
funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName, classDName,
instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName,
- pragSpecDName, pragSpecEDName, pragSpecInstDName, pragRuleDName,
+ pragSpecDName, pragSpecInlDName, pragSpecEDName, pragSpecInlEDName,
+ pragSpecInstDName, pragRuleDName,
pragAnnDName, pragSCCFunDName, pragSCCFunNamedDName,
standaloneDerivWithStrategyDName, defaultSigDName, defaultDName,
dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,
@@ -410,7 +413,9 @@ forImpDName = libFun (fsLit "forImpD")
pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey
pragOpaqueDName = libFun (fsLit "pragOpaqueD") pragOpaqueDIdKey
pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey
+pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
pragSpecEDName = libFun (fsLit "pragSpecED") pragSpecEDIdKey
+pragSpecInlEDName = libFun (fsLit "pragSpecInlED") pragSpecInlEDIdKey
pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey
pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey
pragCompleteDName = libFun (fsLit "pragCompleteD") pragCompleteDIdKey
@@ -955,14 +960,15 @@ recSIdKey = mkPreludeMiscIdUnique 316
-- data Dec = ...
funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
instanceWithOverlapDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey,
- pragInlDIdKey, pragSpecDIdKey, pragSpecEDIdKey, pragSpecInstDIdKey,
+ pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey,
pragRuleDIdKey, pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey,
openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey,
newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,
infixLWithSpecDIdKey, infixRWithSpecDIdKey, infixNWithSpecDIdKey,
roleAnnotDIdKey, patSynDIdKey, patSynSigDIdKey, pragCompleteDIdKey,
implicitParamBindDIdKey, kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey,
- typeDataDIdKey, pragSCCFunDKey, pragSCCFunNamedDKey :: Unique
+ typeDataDIdKey, pragSCCFunDKey, pragSCCFunNamedDKey,
+ pragSpecEDIdKey, pragSpecInlEDIdKey :: Unique
funDIdKey = mkPreludeMiscIdUnique 320
valDIdKey = mkPreludeMiscIdUnique 321
dataDIdKey = mkPreludeMiscIdUnique 322
@@ -975,7 +981,7 @@ sigDIdKey = mkPreludeMiscIdUnique 328
forImpDIdKey = mkPreludeMiscIdUnique 329
pragInlDIdKey = mkPreludeMiscIdUnique 330
pragSpecDIdKey = mkPreludeMiscIdUnique 331
-pragSpecEDIdKey = mkPreludeMiscIdUnique 332
+pragSpecInlDIdKey = mkPreludeMiscIdUnique 332
pragSpecInstDIdKey = mkPreludeMiscIdUnique 333
pragRuleDIdKey = mkPreludeMiscIdUnique 334
pragAnnDIdKey = mkPreludeMiscIdUnique 335
@@ -1001,6 +1007,8 @@ pragOpaqueDIdKey = mkPreludeMiscIdUnique 354
typeDataDIdKey = mkPreludeMiscIdUnique 355
pragSCCFunDKey = mkPreludeMiscIdUnique 356
pragSCCFunNamedDKey = mkPreludeMiscIdUnique 357
+pragSpecEDIdKey = mkPreludeMiscIdUnique 358
+pragSpecInlEDIdKey = mkPreludeMiscIdUnique 359
-- type Cxt = ...
cxtIdKey :: Unique
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1002,7 +1002,7 @@ 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 (SpecSigE _nm bndrs expr ispec))
- = fmap ( \ d -> [(locA loc, d)]) $
+ = fmap (\ d -> [(locA loc, d)]) $
rep_specialiseE bndrs expr ispec
rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty (locA loc)
rep_sig (L _ (MinimalSig {})) = notHandled ThMinimalPragmas
@@ -1106,15 +1106,14 @@ rep_inline nm ispec loc
; return [(loc, pragma)]
}
-rep_inline_phases :: InlinePragma -> MetaM (Core (Maybe TH.Inline), Core TH.Phases)
+rep_inline_phases :: InlinePragma -> MetaM (Maybe (Core TH.Inline), Core TH.Phases)
rep_inline_phases (InlinePragma { inl_act = act, inl_inline = inl })
= do { phases <- repPhases act
; inl <- if noUserInlineSpec inl
-- SPECIALISE
- then dataCon nothingDataConName
+ then return Nothing
-- SPECIALISE INLINE
- else do { MkC inl1 <- repInline inl
- ; dataCon' justDataConName [inl1] }
+ else Just <$> repInline inl
; return (inl, phases) }
rep_specialise :: LocatedN Name -> LHsSigType GhcRn -> InlinePragma
@@ -2777,18 +2776,26 @@ repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
repPragOpaque :: Core TH.Name -> MetaM (Core (M TH.Dec))
repPragOpaque (MkC nm) = rep2 pragOpaqueDName [nm]
-repPragSpec :: Core TH.Name -> Core (M TH.Type) -> Core (Maybe (TH.Inline))
+repPragSpec :: Core TH.Name -> Core (M TH.Type) -> Maybe (Core (TH.Inline))
-> Core TH.Phases
-> MetaM (Core (M TH.Dec))
-repPragSpec (MkC nm) (MkC ty) (MkC inline) (MkC phases)
- = rep2 pragSpecDName [nm, ty, inline, phases]
+repPragSpec (MkC nm) (MkC ty) mb_inl (MkC phases)
+ = case mb_inl of
+ Nothing ->
+ rep2 pragSpecDName [nm, ty, phases]
+ Just (MkC inl) ->
+ rep2 pragSpecInlDName [nm, ty, inl, phases]
repPragSpecE :: Core (Maybe [M (TH.TyVarBndr ())]) -> Core [(M TH.RuleBndr)]
-> Core (M TH.Exp)
- -> Core (Maybe (TH.Inline)) -> Core TH.Phases
+ -> Maybe (Core TH.Inline) -> Core TH.Phases
-> MetaM (Core (M TH.Dec))
-repPragSpecE (MkC ty_bndrs) (MkC tm_bndrs) (MkC expr) (MkC inline) (MkC phases)
- = rep2 pragSpecEDName [ty_bndrs, tm_bndrs, expr, inline, phases]
+repPragSpecE (MkC ty_bndrs) (MkC tm_bndrs) (MkC expr) mb_inl (MkC phases)
+ = case mb_inl of
+ Nothing ->
+ rep2 pragSpecEDName [ty_bndrs, tm_bndrs, expr, phases]
+ Just (MkC inl) ->
+ rep2 pragSpecInlEDName [ty_bndrs, tm_bndrs, expr, inl, phases]
repPragSpecInst :: Core (M TH.Type) -> MetaM (Core (M TH.Dec))
repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
=====================================
@@ -565,6 +565,31 @@ pragSpecInlD n ty inline phases
ty1 <- ty
pure $ PragmaD $ SpecialiseP n ty1 (Just inline) phases
+pragSpecED :: Quote m
+ => Maybe [m (TyVarBndr ())] -> [m RuleBndr]
+ -> m Exp
+ -> Phases
+ -> m Dec
+pragSpecED ty_bndrs tm_bndrs expr phases
+ = do
+ ty_bndrs1 <- traverse sequenceA ty_bndrs
+ tm_bndrs1 <- sequenceA tm_bndrs
+ expr1 <- expr
+ pure $ PragmaD $ SpecialiseEP ty_bndrs1 tm_bndrs1 expr1 Nothing phases
+
+pragSpecInlED :: Quote m
+ => Maybe [m (TyVarBndr ())] -> [m RuleBndr]
+ -> m Exp
+ -> Inline
+ -> Phases
+ -> m Dec
+pragSpecInlED ty_bndrs tm_bndrs expr inl phases
+ = do
+ ty_bndrs1 <- traverse sequenceA ty_bndrs
+ tm_bndrs1 <- sequenceA tm_bndrs
+ expr1 <- expr
+ pure $ PragmaD $ SpecialiseEP ty_bndrs1 tm_bndrs1 expr1 (Just inl) phases
+
pragSpecInstD :: Quote m => m Type -> m Dec
pragSpecInstD ty
= do
=====================================
libraries/template-haskell/Language/Haskell/TH/Lib.hs
=====================================
@@ -122,7 +122,9 @@ module Language.Haskell.TH.Lib (
-- **** Pragmas
ruleVar, typedRuleVar,
valueAnnotation, typeAnnotation, moduleAnnotation,
- pragInlD, pragSpecD, pragSpecInlD, pragSpecInstD, pragRuleD, pragAnnD,
+ pragInlD, pragSpecD, pragSpecInlD,
+ pragSpecED, pragSpecInlED,
+ pragSpecInstD, pragRuleD, pragAnnD,
pragLineD, pragCompleteD,
-- **** Pattern Synonyms
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a0f0e094bf6bec16489b9205195547e9209468fb
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a0f0e094bf6bec16489b9205195547e9209468fb
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/20241129/c507ae00/attachment-0001.html>
More information about the ghc-commits
mailing list