[Git][ghc/ghc][wip/sgraf-T12457] WIP
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Wed Jun 19 08:37:42 UTC 2024
Sebastian Graf pushed to branch wip/sgraf-T12457 at Glasgow Haskell Compiler / GHC
Commits:
82aea77e by Sebastian Graf at 2024-06-19T10:37:16+02:00
WIP
- - - - -
23 changed files:
- compiler/GHC/Builtin/Names/TH.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Tc/Deriv.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Deriv/Infer.hs
- compiler/GHC/Tc/Deriv/Utils.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Gen/Splice.hs-boot
- compiler/GHC/Tc/Module.hs-boot
- compiler/Language/Haskell/Syntax/Decls.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
Changes:
=====================================
compiler/GHC/Builtin/Names/TH.hs
=====================================
@@ -32,8 +32,7 @@ templateHaskellNames :: [Name]
templateHaskellNames = [
returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName,
mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameG_fldName,
- mkNameLName,
- mkNameSName, mkNameQName,
+ mkNameUName, mkNameLName, mkNameSName, mkNameQName,
mkModNameName,
liftStringName,
unTypeName, unTypeCodeName,
@@ -177,7 +176,11 @@ templateHaskellNames = [
modNameTyConName,
-- Quasiquoting
- quoteDecName, quoteTypeName, quoteExpName, quotePatName]
+ quoteDecName, quoteTypeName, quoteExpName, quotePatName,
+
+ -- DeriveTH
+ deriveTHClassName, deriveTHName
+ ]
thSyn, thLib, qqLib, liftLib :: Module
thSyn = mkTHModule (fsLit "GHC.Internal.TH.Syntax")
@@ -210,6 +213,9 @@ liftClassName = mk_known_key_name clsName liftLib (fsLit "Lift") liftClassKey
quoteClassName :: Name
quoteClassName = thCls (fsLit "Quote") quoteClassKey
+deriveTHClassName :: Name
+deriveTHClassName = mk_known_key_name clsName thLib (fsLit "DeriveTH") deriveTHClassKey
+
qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
matchTyConName, clauseTyConName, funDepTyConName, predTyConName,
@@ -236,7 +242,8 @@ modNameTyConName = thTc (fsLit "ModName") modNameTyConKey
returnQName, bindQName, sequenceQName, newNameName, liftName,
mkNameName, mkNameG_vName, mkNameG_fldName, mkNameG_dName, mkNameG_tcName,
mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeCodeName,
- unsafeCodeCoerceName, liftTypedName, mkModNameName, mkNameQName :: Name
+ unsafeCodeCoerceName, liftTypedName, mkModNameName, mkNameQName,
+ deriveTHName :: Name
returnQName = thFun (fsLit "returnQ") returnQIdKey
bindQName = thFun (fsLit "bindQ") bindQIdKey
sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
@@ -246,6 +253,7 @@ mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey
mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey
mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
mkNameG_fldName= thFun (fsLit "mkNameG_fld") mkNameG_fldIdKey
+mkNameUName = thFun (fsLit "mkNameU") mkNameUIdKey
mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey
mkNameQName = thFun (fsLit "mkNameQ") mkNameQIdKey
mkNameSName = thFun (fsLit "mkNameS") mkNameSIdKey
@@ -256,6 +264,7 @@ unsafeCodeCoerceName = thFun (fsLit "unsafeCodeCoerce") unsafeCodeCoerceIdKey
liftName = liftFun (fsLit "lift") liftIdKey
liftStringName = liftFun (fsLit "liftString") liftStringIdKey
liftTypedName = liftFun (fsLit "liftTyped") liftTypedIdKey
+deriveTHName = libFun (fsLit "deriveTHEntry") deriveTHIdKey
-------------------- TH.Lib -----------------------
@@ -689,6 +698,9 @@ liftClassKey = mkPreludeClassUnique 200
quoteClassKey :: Unique
quoteClassKey = mkPreludeClassUnique 201
+deriveTHClassKey :: Unique
+deriveTHClassKey = mkPreludeClassUnique 202
+
{- *********************************************************************
* *
TyCon keys
@@ -799,8 +811,9 @@ dataNamespaceSpecifierDataConKey = mkPreludeDataConUnique 215
returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
mkNameIdKey, mkNameG_vIdKey, mkNameG_fldIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
- mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeCodeIdKey,
- unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey, mkNameQIdKey :: Unique
+ mkNameUIdKey, mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeCodeIdKey,
+ unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey, mkNameQIdKey,
+ deriveTHIdKey :: Unique
returnQIdKey = mkPreludeMiscIdUnique 200
bindQIdKey = mkPreludeMiscIdUnique 201
sequenceQIdKey = mkPreludeMiscIdUnique 202
@@ -819,6 +832,7 @@ mkModNameIdKey = mkPreludeMiscIdUnique 215
unsafeCodeCoerceIdKey = mkPreludeMiscIdUnique 216
mkNameQIdKey = mkPreludeMiscIdUnique 217
mkNameG_fldIdKey = mkPreludeMiscIdUnique 218
+deriveTHIdKey = mkPreludeMiscIdUnique 219
-- data Lit = ...
@@ -874,6 +888,7 @@ matchIdKey = mkPreludeMiscIdUnique 261
clauseIdKey :: Unique
clauseIdKey = mkPreludeMiscIdUnique 262
+mkNameUIdKey = mkPreludeMiscIdUnique 269
-- data Exp = ...
varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey,
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -647,6 +647,7 @@ derivStrategyName = text . go
go AnyclassStrategy {} = "anyclass"
go NewtypeStrategy {} = "newtype"
go ViaStrategy {} = "via"
+ go THStrategy {} = "template-haskell"
type instance XDctSingle (GhcPass _) = NoExtField
type instance XDctMulti (GhcPass _) = NoExtField
@@ -1063,6 +1064,10 @@ type instance XViaStrategy GhcPs = XViaStrategyPs
type instance XViaStrategy GhcRn = LHsSigType GhcRn
type instance XViaStrategy GhcTc = Type
+type instance XTHStrategy GhcPs = [AddEpAnn]
+type instance XTHStrategy GhcRn = NoExtField
+type instance XTHStrategy GhcTc = NoExtField
+
data XViaStrategyPs = XViaStrategyPs [AddEpAnn] (LHsSigType GhcPs)
instance OutputableBndrId p
@@ -1074,6 +1079,7 @@ instance OutputableBndrId p
GhcPs -> ppr ty
GhcRn -> ppr ty
GhcTc -> ppr ty
+ ppr (THStrategy _) = text "template-haskell"
instance Outputable XViaStrategyPs where
ppr (XViaStrategyPs _ t) = ppr t
@@ -1085,7 +1091,8 @@ foldDerivStrategy :: (p ~ GhcPass pass)
foldDerivStrategy other _ (StockStrategy _) = other
foldDerivStrategy other _ (AnyclassStrategy _) = other
foldDerivStrategy other _ (NewtypeStrategy _) = other
-foldDerivStrategy _ via (ViaStrategy t) = via t
+foldDerivStrategy other _ (THStrategy _) = other
+foldDerivStrategy _ via (ViaStrategy t) = via t
-- | Map over the @via@ type if dealing with 'ViaStrategy'. Otherwise,
-- return the 'DerivStrategy' unchanged.
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -66,7 +66,8 @@ import GHC.Tc.Utils.TcType (TcType, TcTyVar)
import {-# SOURCE #-} GHC.Tc.Types.LclEnv (TcLclEnv)
import GHCi.RemoteTypes ( ForeignRef )
-import qualified GHC.Internal.TH.Syntax as TH (Q)
+import qualified GHC.Internal.TH.Syntax as TH
+import qualified GHC.Internal.TH.Ppr as TH
-- libraries:
import Data.Data hiding (Fixity(..))
@@ -2039,6 +2040,8 @@ ppr_splice herald mn e
Just splice_name -> whenPprDebug (brackets (ppr splice_name)))
<> ppr e
+data THQuote
+ = THTypBr TH.Type
type instance XExpBr GhcPs = NoExtField
type instance XPatBr GhcPs = NoExtField
@@ -2054,7 +2057,7 @@ type instance XDecBrL GhcRn = NoExtField
type instance XDecBrG GhcRn = NoExtField
type instance XTypBr GhcRn = NoExtField
type instance XVarBr GhcRn = NoExtField
-type instance XXQuote GhcRn = DataConCantHappen
+type instance XXQuote GhcRn = THQuote
-- See Note [The life cycle of a TH quotation]
type instance XExpBr GhcTc = DataConCantHappen
@@ -2065,6 +2068,9 @@ type instance XTypBr GhcTc = DataConCantHappen
type instance XVarBr GhcTc = DataConCantHappen
type instance XXQuote GhcTc = NoExtField
+instance Outputable THQuote where
+ ppr (THTypBr ty) = thBrackets (text "TH.Type") (text (TH.pprint ty))
+
instance OutputableBndrId p
=> Outputable (HsQuote (GhcPass p)) where
ppr = pprHsQuote
@@ -2081,6 +2087,7 @@ instance OutputableBndrId p
pprHsQuote (VarBr _ False n)
= text "''" <> pprPrefixOcc (unLoc n)
pprHsQuote (XQuote b) = case ghcPass @p of
+ GhcRn -> ppr b
GhcTc -> pprPanic "pprHsQuote: `HsQuote GhcTc` shouldn't exist" (ppr b)
-- See Note [The life cycle of a TH quotation]
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -405,6 +405,8 @@ deriving instance Data (HsUntypedSplice GhcTc)
deriving instance Data a => Data (HsUntypedSpliceResult a)
+deriving instance Data THQuote
+
-- deriving instance (DataIdLR p p) => Data (HsQuote p)
deriving instance Data (HsQuote GhcPs)
deriving instance Data (HsQuote GhcRn)
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -175,6 +175,7 @@ dsBracket (HsBracketTc { hsb_wrap = mb_wrap, hsb_splices = splices, hsb_quote =
TypBr _ t -> runOverloaded $ do { MkC t1 <- repLTy t ; return t1 }
DecBrG _ gp -> runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 }
DecBrL {} -> panic "dsUntypedBracket: unexpected DecBrL"
+ XQuote (THTypBr t) -> runOverloaded $ do { MkC t1 <- repThTy t ; return t1 }
where
Just wrap = mb_wrap -- Not used in VarBr case
-- In the overloaded case we have to get given a wrapper, it is just
@@ -1184,15 +1185,26 @@ instance RepTV () () where
repKindedTV (MkC nm) () (MkC ki) = rep2 kindedTVName [nm, ki]
instance RepTV Specificity TH.Specificity where
+ tyVarBndrName = tyVarBndrSpecTyConName
+ repPlainTV (MkC nm) spec = do { (MkC spec') <- rep_flag (spec2spec spec)
+ ; rep2 plainInvisTVName [nm, spec'] }
+ repKindedTV (MkC nm) spec (MkC ki) = do { (MkC spec') <- rep_flag (spec2spec spec)
+ ; rep2 kindedInvisTVName [nm, spec', ki] }
+
+instance RepTV TH.Specificity TH.Specificity where
tyVarBndrName = tyVarBndrSpecTyConName
repPlainTV (MkC nm) spec = do { (MkC spec') <- rep_flag spec
; rep2 plainInvisTVName [nm, spec'] }
repKindedTV (MkC nm) spec (MkC ki) = do { (MkC spec') <- rep_flag spec
; rep2 kindedInvisTVName [nm, spec', ki] }
-rep_flag :: Specificity -> MetaM (Core TH.Specificity)
-rep_flag SpecifiedSpec = rep2_nw specifiedSpecName []
-rep_flag InferredSpec = rep2_nw inferredSpecName []
+spec2spec :: Specificity -> TH.Specificity
+spec2spec SpecifiedSpec = TH.SpecifiedSpec
+spec2spec InferredSpec = TH.InferredSpec
+
+rep_flag :: TH.Specificity -> MetaM (Core TH.Specificity)
+rep_flag TH.SpecifiedSpec = rep2_nw specifiedSpecName []
+rep_flag TH.InferredSpec = rep2_nw inferredSpecName []
instance RepTV (HsBndrVis GhcRn) TH.BndrVis where
tyVarBndrName = tyVarBndrVisTyConName
@@ -1497,6 +1509,101 @@ repRole (L _ (Just Representational)) = rep2_nw representationalRName []
repRole (L _ (Just Phantom)) = rep2_nw phantomRName []
repRole (L _ Nothing) = rep2_nw inferRName []
+repThName :: TH.Name -> MetaM (Core (TH.Name))
+repThName (TH.Name (TH.OccName s) flv) = coreString s >>= \nm -> case flv of
+ TH.NameS -> repNameS nm
+ TH.NameQ (TH.ModName mod) -> repNameQ nm =<< coreString mod
+ TH.NameU u -> repNameU nm =<< coreIntegerLit u
+ TH.NameL u -> repNameL nm =<< coreIntegerLit u
+ TH.NameG ns (TH.PkgName pkg) (TH.ModName mod) -> do
+ mod <- coreString mod
+ pkg <- coreString pkg
+ repNameG ns mod pkg nm
+
+-- | Represent a TH type variable binder
+repThTyVarBndr :: RepTV flag flag' => TH.TyVarBndr flag -> MetaM (Core (M (TH.TyVarBndr flag')))
+repThTyVarBndr (TH.PlainTV nm fl) = do { nm <- repThName nm; repPlainTV nm fl }
+repThTyVarBndr (TH.KindedTV nm fl ki) = do { nm <- repThName nm; ki <- repThTy ki; repKindedTV nm fl ki }
+
+repThTyLit :: TH.TyLit -> MetaM (Core (M TH.TyLit))
+repThTyLit (TH.NumTyLit n) = repTnumTyLit =<< coreIntegerLit n
+repThTyLit (TH.StrTyLit s) = repTstrTyLit =<< coreString s
+repThTyLit (TH.CharTyLit c) = repTcharTyLit =<< coreChar c
+
+repTnumTyLit :: Core Integer -> MetaM (Core (M TH.TyLit))
+repTnumTyLit (MkC n) = rep2 numTyLitName [n]
+
+repTstrTyLit :: Core String -> MetaM (Core (M TH.TyLit))
+repTstrTyLit (MkC s) = rep2 strTyLitName [s]
+
+repTcharTyLit :: Core Char -> MetaM (Core (M TH.TyLit))
+repTcharTyLit (MkC c) = rep2 charTyLitName [c]
+
+repThCxt :: TH.Cxt -> MetaM (Core (M TH.Cxt))
+repThCxt cxt = repListM typeTyConName repThTy cxt >>= repCtxt
+
+repThTy :: TH.Type -> MetaM (Core (M TH.Type))
+-- A bit like `lift @TH.Type`, but in `MetaM . Core . M` instead of `Q`
+repThTy (TH.ForallT bndrs cxt ty) = do
+ bndrs <- repListM tyVarBndrSpecTyConName repThTyVarBndr bndrs
+ cxt <- repThCxt cxt
+ ty <- repThTy ty
+ repTForall bndrs cxt ty
+repThTy (TH.ForallVisT bndrs ty) = do
+ bndrs <- repListM tyVarBndrSpecTyConName repThTyVarBndr bndrs
+ ty <- repThTy ty
+ repTForallVis bndrs ty
+repThTy (TH.AppT f a) = do
+ f <- repThTy f
+ a <- repThTy a
+ repTapp f a
+repThTy (TH.AppKindT f k) = do
+ f <- repThTy f
+ k <- repThTy k
+ repTappKind f k
+repThTy (TH.SigT t k) = do
+ t <- repThTy t
+ k <- repThTy k
+ repTSig t k
+repThTy (TH.VarT n) = do
+ n <- repThName n
+ repTvar n
+repThTy (TH.ConT n) = do
+ n <- repThName n
+ repNamedTyCon n
+repThTy (TH.PromotedT n) = do
+ n <- repThName n
+ repPromotedDataCon n
+repThTy (TH.InfixT a n b) = do
+ a <- repThTy a
+ n <- repThName n
+ b <- repThTy b
+ repTInfix a n b
+repThTy (TH.TupleT n) = repTupleTyCon n
+repThTy (TH.UnboxedTupleT n) = repUnboxedTupleTyCon n
+repThTy (TH.UnboxedSumT n) = repUnboxedSumTyCon n
+repThTy TH.ArrowT = repArrowTyCon
+repThTy TH.MulArrowT = repMulArrowTyCon
+repThTy TH.EqualityT = repTequality
+repThTy TH.ListT = repListTyCon
+repThTy (TH.PromotedTupleT n) = repPromotedTupleTyCon n
+repThTy TH.PromotedNilT = repPromotedNilTyCon
+repThTy TH.PromotedConsT = repPromotedConsTyCon
+repThTy TH.StarT = repTStar
+repThTy TH.ConstraintT = repTConstraint
+repThTy TH.WildCardT = repTWildCard
+repThTy (TH.ImplicitParamT s t) = do
+ s <- coreString s
+ t <- repThTy t
+ repTImplicitParam s t
+repThTy (TH.LitT lit) = do
+ lit <- repThTyLit lit
+ repTLit lit
+repThTy TH.ParensT{} = panic "ParensT impossible"
+repThTy TH.PromotedInfixT{} = panic "PromotedInfixT impossible"
+repThTy TH.UInfixT{} = panic "UInfixT impossible"
+repThTy TH.PromotedUInfixT{} = panic "PromotedUInfixT impossible"
+
-----------------------------------------------------------------------------
-- Splices
-----------------------------------------------------------------------------
@@ -3038,6 +3145,20 @@ repNameS (MkC name) = rep2_nw mkNameSName [name]
repNameQ :: Core String -> Core String -> MetaM (Core TH.Name)
repNameQ (MkC mn) (MkC name) = rep2_nw mkNameQName [mn, name]
+repNameU :: Core String -> Core Integer -> MetaM (Core TH.Name)
+repNameU (MkC mn) (MkC uniq) = rep2_nw mkNameUName [mn, uniq]
+
+repNameL :: Core String -> Core Integer -> MetaM (Core TH.Name)
+repNameL (MkC mn) (MkC uniq) = rep2_nw mkNameLName [mn, uniq]
+
+repNameG :: TH.NameSpace -> Core String -> Core String -> Core String -> MetaM (Core TH.Name)
+repNameG TH.DataName (MkC mod) (MkC pkg) (MkC nm) = rep2_nw mkNameG_dName [pkg,mod,nm]
+repNameG TH.VarName (MkC mod) (MkC pkg) (MkC nm) = rep2_nw mkNameG_vName [pkg,mod,nm]
+repNameG TH.TcClsName (MkC mod) (MkC pkg) (MkC nm) = rep2_nw mkNameG_tcName [pkg,mod,nm]
+repNameG (TH.FldName fld) (MkC mod) (MkC pkg) (MkC nm) = do
+ MkC fld <- coreString fld
+ rep2_nw mkNameG_fldName [pkg,mod,nm,fld]
+
--------------- Miscellaneous -------------------
repGensym :: Core String -> MetaM (Core (M TH.Name))
@@ -3131,6 +3252,12 @@ nonEmptyCoreList' xs@(MkC x:|_) = MkC (mkListExpr (exprType x) (toList $ fmap un
coreStringLit :: MonadThings m => FastString -> m (Core String)
coreStringLit s = do { z <- mkStringExprFS s; return (MkC z) }
+coreString :: MonadThings m => String -> m (Core String)
+coreString s = do { z <- mkStringExpr s; return (MkC z) }
+
+coreChar :: MonadThings m => Char -> m (Core Char)
+coreChar c = return (MkC (mkCharExpr c))
+
------------------- Maybe ------------------
repMaybe :: Name -> (a -> MetaM (Core b))
@@ -3187,6 +3314,10 @@ coreIntLit :: Int -> MetaM (Core Int)
coreIntLit i = do platform <- getPlatform
return (MkC (mkIntExprInt platform i))
+coreIntegerLit :: Integer -> MetaM (Core Integer)
+coreIntegerLit i = do platform <- getPlatform
+ return (MkC (mkIntegerExpr platform i))
+
coreVar :: Id -> Core TH.Name -- The Id has type Name
coreVar id = MkC (Var id)
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1699,6 +1699,7 @@ instance ToHie (RScoped (LocatedAn NoEpAnns (DerivStrategy GhcRn))) where
AnyclassStrategy _ -> []
NewtypeStrategy _ -> []
ViaStrategy s -> [ toHie (TS (ResolvedScopes [sc]) s) ]
+ THStrategy _ -> []
instance ToHie (LocatedP OverlapMode) where
toHie (L span _) = locOnly (locA span)
=====================================
compiler/GHC/Parser.y
=====================================
@@ -635,9 +635,10 @@ are the most common patterns, rewritten as regular expressions for clarity:
'using' { L _ ITusing } -- for list transform extension
'pattern' { L _ ITpattern } -- for pattern synonyms
'static' { L _ ITstatic } -- for static pointers extension
- 'stock' { L _ ITstock } -- for DerivingStrategies extension
- 'anyclass' { L _ ITanyclass } -- for DerivingStrategies extension
- 'via' { L _ ITvia } -- for DerivingStrategies extension
+ 'stock' { L _ ITstock } -- for DerivingStrategies extension
+ 'anyclass' { L _ ITanyclass } -- for DerivingStrategies extension
+ 'via' { L _ ITvia } -- for DerivingStrategies extension
+ 'template-haskell' { L _ ITtemplatehaskell } -- for DerivingStrategies extension
'unit' { L _ ITunit }
'signature' { L _ ITsignature }
@@ -1415,6 +1416,7 @@ deriv_strategy_no_via :: { LDerivStrategy GhcPs }
: 'stock' {% amsA' (sL1 $1 (StockStrategy [mj AnnStock $1])) }
| 'anyclass' {% amsA' (sL1 $1 (AnyclassStrategy [mj AnnAnyclass $1])) }
| 'newtype' {% amsA' (sL1 $1 (NewtypeStrategy [mj AnnNewtype $1])) }
+ | 'template-haskell' {% amsA' (sL1 $1 (THStrategy [mj AnnTH $1])) }
deriv_strategy_via :: { LDerivStrategy GhcPs }
: 'via' sigktype {% amsA' (sLL $1 $> (ViaStrategy (XViaStrategyPs [mj AnnVia $1] $2))) }
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -311,6 +311,7 @@ data AnnKeywordId
| AnnValStr -- ^ String value, will need quotes when output
| AnnVbar -- ^ '|'
| AnnVia -- ^ 'via'
+ | AnnTH -- ^ 'template-haskell' (as deriving strategy)
| AnnWhere
| Annlarrowtail -- ^ '-<'
| AnnlarrowtailU -- ^ '-<', unicode variant
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -856,6 +856,7 @@ data Token
| ITstock
| ITanyclass
| ITvia
+ | ITtemplatehaskell
-- Backpack tokens
| ITunit
@@ -1104,6 +1105,7 @@ reservedWordsFM = listToUFM $
( "stock", ITstock, 0 ),
( "anyclass", ITanyclass, 0 ),
( "via", ITvia, 0 ),
+ ( "th", ITtemplatehaskell, 0 ),
( "group", ITgroup, xbit TransformComprehensionsBit),
( "by", ITby, xbit TransformComprehensionsBit),
( "using", ITusing, xbit TransformComprehensionsBit),
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -2176,7 +2176,7 @@ rnLDerivStrategy doc mds thing_inside
let extNeeded :: LangExt.Extension
extNeeded
| ViaStrategy{} <- ds
- = LangExt.DerivingVia
+ = LangExt.DerivingVia -- TODO: TH
| otherwise
= LangExt.DerivingStrategies
@@ -2187,6 +2187,7 @@ rnLDerivStrategy doc mds thing_inside
StockStrategy _ -> boring_case (StockStrategy noExtField)
AnyclassStrategy _ -> boring_case (AnyclassStrategy noExtField)
NewtypeStrategy _ -> boring_case (NewtypeStrategy noExtField)
+ THStrategy _ -> boring_case (THStrategy noExtField)
ViaStrategy (XViaStrategyPs _ via_ty) ->
do checkInferredVars doc via_ty
(via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty
=====================================
compiler/GHC/Rename/Splice.hs
=====================================
@@ -9,6 +9,7 @@ module GHC.Rename.Splice (
rnTypedSplice,
-- Untyped splices
rnSpliceType, rnUntypedSpliceExpr, rnSplicePat, rnSpliceTyPat, rnSpliceDecl,
+ runRnSplice,
-- Brackets
rnTypedBracket, rnUntypedBracket,
@@ -361,6 +362,7 @@ runRnSplice :: UntypedSpliceFlavour
-> TcRn (res, [ForeignRef (TH.Q ())])
runRnSplice flavour run_meta ppr_res splice
= do { hooks <- hsc_hooks <$> getTopEnv
+ ; pprTraceM "run0" empty
; splice' <- case runRnSpliceHook hooks of
Nothing -> return splice
Just h -> h splice
@@ -371,19 +373,26 @@ runRnSplice flavour run_meta ppr_res splice
-- Typecheck the expression
; meta_exp_ty <- tcMetaTy meta_ty_name
+ ; pprTraceM "run01" (ppr meta_exp_ty $$ ppr the_expr)
+ ; blah <- tcTopSpliceExpr Untyped
+ (tcCheckPolyExpr the_expr meta_exp_ty)
+ ; pprTraceM "run02" (ppr meta_exp_ty $$ ppr the_expr $$ ppr blah)
; zonked_q_expr <- zonkTopLExpr =<<
tcTopSpliceExpr Untyped
(tcCheckPolyExpr the_expr meta_exp_ty)
+ ; pprTraceM "run1" empty
-- Run the expression
; mod_finalizers_ref <- newTcRef []
; result <- setStage (RunSplice mod_finalizers_ref) $
run_meta zonked_q_expr
+ ; pprTraceM "run2" empty
; mod_finalizers <- readTcRef mod_finalizers_ref
; traceSplice (SpliceInfo { spliceDescription = what
, spliceIsDecl = is_decl
, spliceSource = Just the_expr
, spliceGenerated = ppr_res result })
+ ; pprTraceM "run3" empty
; return (result, mod_finalizers) }
=====================================
compiler/GHC/Tc/Deriv.hs
=====================================
@@ -39,7 +39,7 @@ import GHC.Unit.Module.Warnings
import GHC.Rename.Bind
import GHC.Rename.Env
-import GHC.Rename.Module ( addTcgDUs )
+import GHC.Rename.Module ( addTcgDUs, findSplice )
import GHC.Rename.Utils
import GHC.Core.Unify( tcUnifyTy )
@@ -71,6 +71,13 @@ import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Data.List (partition, find)
+import {-# SOURCE #-} GHC.Tc.Gen.Splice (reifyType, runMetaD)
+import {-# SOURCE #-} GHC.Tc.Module (rnTopSrcDecls, tcTopSrcDecls)
+import GHC.Types.Basic
+import GHC.ThToHs (convertToHsType)
+import GHC.Builtin.Names.TH (deriveTHName)
+import GHC.Rename.Splice (runRnSplice)
+import GHC.Tc.Solver (captureTopConstraints)
{-
************************************************************************
@@ -266,9 +273,9 @@ pprRepTy fi@(FamInst { fi_tys = lhs })
where rhs = famInstRHS fi
renameDeriv :: [InstInfo GhcPs]
- -> Bag (LHsBind GhcPs, LSig GhcPs)
+ -> (LHsBinds GhcPs, [LSig GhcPs])
-> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-renameDeriv inst_infos bagBinds
+renameDeriv inst_infos (aux_binds, aux_sigs)
= discardWarnings $
-- Discard warnings about unused bindings etc
setXOptM LangExt.EmptyCase $
@@ -289,8 +296,7 @@ renameDeriv inst_infos bagBinds
-- Bring the extra deriving stuff into scope
-- before renaming the instances themselves
; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos))
- ; let (aux_binds, aux_sigs) = unzipBag bagBinds
- aux_val_binds = ValBinds NoAnnSortKey aux_binds (bagToList aux_sigs)
+ ; let aux_val_binds = ValBinds NoAnnSortKey aux_binds aux_sigs
-- Importantly, we use rnLocalValBindsLHS, not rnTopBindsLHS, to rename
-- auxiliary bindings as if they were defined locally.
-- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.
@@ -1208,6 +1214,11 @@ mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat warn = do
derivingThingFailWith NoGeneralizedNewtypeDeriving DerivErrGNDUsedOnData
mkNewTypeEqn True dit
+ Just (THStrategy _) -> do
+ (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args
+ dit <- expectAlgTyConApp cls_tys inst_ty
+ mk_eqn_th cls_tys inst_ty dit
+
Nothing -> mk_eqn_no_strategy
-- @expectNonNullaryClsArgs inst_tys@ checks if @inst_tys@ is non-empty.
@@ -1425,6 +1436,75 @@ mk_eqn_via cls_tys inst_ty via_ty =
, dsm_via_inst_ty = inst_ty
, dsm_via_ty = via_ty }
+mk_eqn_th :: [Type] -- All arguments to the class besides the last
+ -> Type -- The last argument to the class
+ -> DerivInstTys -- Information about the arguments to the class
+ -> DerivM EarlyDerivSpec
+mk_eqn_th cls_tys inst_ty dit = do
+ -- dflags <- getDynFlags
+ -- TODO
+ -- let isDeriveAnyClassEnabled =
+ -- deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags)
+ cls <- asks denv_cls
+ th_ty <- lift $ reifyType (mkTyConApp (dit_tc dit) (dit_tc_args dit))
+ let hs_ty = case convertToHsType (Generated OtherExpansion SkipPmc) noSrcSpan th_ty of
+ Left _ -> Nothing
+ Right hs_ty -> Just hs_ty
+ let br = noLocA $ HsUntypedBracket [] $ XQuote (THTypBr th_ty) :: LHsExpr GhcRn
+ let head = nlHsVar deriveTHName :: LHsExpr GhcRn
+ let tc = classTyCon cls
+ let inst_ty = nlHsTyVar NotPromoted (tyConName tc) :: LHsType GhcRn
+ let app_ty = mkHsAppType head (HsWC [] inst_ty) :: LHsExpr GhcRn
+ let app = nlHsApp app_ty br :: LHsExpr GhcRn
+ let spl = HsUntypedSpliceExpr [] app :: HsUntypedSplice GhcRn
+ let ppr_decls :: [LHsDecl GhcPs] -> SDoc
+ ppr_decls ds = vcat (map ppr ds)
+ pprTraceM "here1" empty
+ (decls, mod_finalizers) <- lift $ checkNoErrs $
+ runRnSplice UntypedDeclSplice runMetaD ppr_decls spl
+ inst_decl <- case decls of
+ [L _ (InstD _ (ClsInstD _ inst_decl))] -> pure inst_decl
+ _ -> panic "not a class inst"
+ --(grp, mb_rest) <- lift $ findSplice decls
+ --case mb_rest of
+ --Just _ -> panic "urgh"
+ --Nothing -> return ()
+ --pprTraceM "here2" empty
+ --(tcg_env, rn_decls) <- lift $ rnTopSrcDecls grp
+ -- Get TH-generated top-level declarations and make sure they don't
+ -- contain any splices since we don't handle that at the moment
+ --
+ -- The plumbing here is a bit odd: see #10853
+ th_topdecls_var <- fmap tcg_th_topdecls (lift getGblEnv)
+ th_ds <- readTcRef th_topdecls_var
+ writeTcRef th_topdecls_var []
+ let (aux_binds, _, _, _, _, _) = partitionBindsAndSigs th_ds -- TODO check rest empty
+ -- Rename TH-generated top-level declarations
+ -- (th_grp, mb_rest) <- lift $ findSplice th_ds
+ -- case mb_rest of
+ -- Just _ -> panic "urgh"
+ -- Nothing -> return ()
+ -- (tcg_env, th_rn_decls) <- lift $ setGblEnv tcg_env $ rnTopSrcDecls th_grp
+ -- let grp = appendGroups rn_decls th_rn_decls
+
+ -- Type check all declarations
+ -- NB: set the env **before** captureTopConstraints so that error messages
+ -- get reported w.r.t. the right GlobalRdrEnv. It is for this reason that
+ -- the captureTopConstraints must go here, not in tcRnSrcDecls.
+-- ((tcg_env, _tcl_env), _lie1) <- lift $
+-- setGblEnv tcg_env $
+-- captureTopConstraints $
+-- tcTopSrcDecls grp
+-- pprTraceM "here3" empty
+
+ -- add_mod_finalizers_now mod_finalizers
+ -- TODO: top-level decls
+ pprTraceM "blah" (ppr hs_ty $$ ppr br $$ ppr inst_decl $$ ppr aux_binds)
+ mk_eqn_from_mechanism (DerivSpecTH
+ { dsm_th_dit = dit
+ , dsm_th_inst_decl = inst_decl
+ , dsm_th_aux_binds = aux_binds})
+
-- Derive an instance without a user-requested deriving strategy. This uses
-- heuristics to determine which deriving strategy to use.
-- See Note [Deriving strategies].
@@ -1921,6 +2001,9 @@ genInstBinds spec@(DS { ds_tvs = tyvars, ds_mechanism = mechanism
DerivSpecVia{dsm_via_ty = via_ty}
-> gen_newtype_or_via via_ty
+ DerivSpecTH{dsm_th_aux_binds = aux_binds}
+ -> pure (emptyBag, [], mapBag DerivTH aux_binds, [])
+
gen_newtype_or_via ty = do
let (binds, sigs) = gen_Newtype_binds loc clas tyvars inst_tys ty
return (binds, sigs, emptyBag, [])
@@ -1958,6 +2041,9 @@ genFamInsts spec@(DS { ds_tvs = tyvars, ds_mechanism = mechanism
-- Try DerivingVia
DerivSpecVia{dsm_via_ty = via_ty}
-> gen_newtype_or_via via_ty
+
+ DerivSpecTH{} -> do
+ pure $ undefined
where
gen_newtype_or_via ty = gen_Newtype_fam_insts loc clas tyvars inst_tys ty
@@ -1990,6 +2076,8 @@ doDerivInstErrorChecks1 mechanism =
-> pure ()
DerivSpecVia{}
-> atf_coerce_based_error_checks
+ DerivSpecTH{}
+ -> pure ()
where
-- When processing a standalone deriving declaration, check that all of the
-- constructors for the data type are in scope. For instance:
=====================================
compiler/GHC/Tc/Deriv/Generate.hs
=====================================
@@ -136,6 +136,8 @@ data AuxBindSpec
-- data type. This is only used on the RHS of the
-- to-be-generated $c binding.
+ | DerivTH (LHsBind GhcPs) -- just the thing; should be System name already (see ThToHs.thRdrName)
+
-- | Retrieve the 'RdrName' of the binding that the supplied 'AuxBindSpec'
-- describes.
auxBindSpecRdrName :: AuxBindSpec -> RdrName
@@ -143,6 +145,7 @@ auxBindSpecRdrName (DerivTag2Con _ tag2con_RDR) = tag2con_RDR
auxBindSpecRdrName (DerivMaxTag _ maxtag_RDR) = maxtag_RDR
auxBindSpecRdrName (DerivDataDataType _ dataT_RDR _) = dataT_RDR
auxBindSpecRdrName (DerivDataConstr _ dataC_RDR _) = dataC_RDR
+auxBindSpecRdrName DerivTH{} = panic "not here; see gen_aux_bind_spec"
{-
************************************************************************
@@ -2203,6 +2206,8 @@ genAuxBindSpecOriginal loc spec
fixity | is_infix = infix_RDR
| otherwise = prefix_RDR
+ gen_bind DerivTH{} = panic "not here; see gen_aux_bind_spec"
+
-- | Generate the code for an auxiliary binding that is a duplicate of another
-- auxiliary binding.
-- See @Note [Auxiliary binders] (Wrinkle: Reducing code duplication)@.
@@ -2231,6 +2236,8 @@ genAuxBindSpecSig loc spec = case spec of
-> mk_sig (nlHsTyVar NotPromoted dataType_RDR)
DerivDataConstr _ _ _
-> mk_sig (nlHsTyVar NotPromoted constr_RDR)
+ DerivTH{}
+ -> panic "not here; see gen_aux_bind_spec"
where
mk_sig = mkHsWildCardBndrs . L (noAnnSrcSpan loc) . mkHsImplicitSigType
@@ -2238,8 +2245,8 @@ genAuxBindSpecSig loc spec = case spec of
-- bindings based on the declarative descriptions in the supplied
-- 'AuxBindSpec's. See @Note [Auxiliary binders]@.
genAuxBinds :: SrcSpan -> Bag AuxBindSpec
- -> Bag (LHsBind GhcPs, LSig GhcPs)
-genAuxBinds loc = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag)
+ -> (LHsBinds GhcPs, [LSig GhcPs])
+genAuxBinds loc = snd . foldr gen_aux_bind_spec (emptyOccEnv, (emptyBag, []))
where
-- Perform a CSE-like pass over the generated auxiliary bindings to avoid
-- code duplication, as described in
@@ -2247,19 +2254,21 @@ genAuxBinds loc = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag)
-- The OccEnv remembers the first occurrence of each sort of auxiliary
-- binding and maps it to the unique RdrName for that binding.
gen_aux_bind_spec :: AuxBindSpec
- -> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
- -> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
+ -> (OccEnv RdrName, (LHsBinds GhcPs, [LSig GhcPs]))
+ -> (OccEnv RdrName, (LHsBinds GhcPs, [LSig GhcPs]))
+ gen_aux_bind_spec (DerivTH bind) (env, (binds, sigs)) = (env, (bind `consBag` binds, sigs)) -- TODO sigs
gen_aux_bind_spec spec (original_rdr_name_env, spec_bag) =
case lookupOccEnv original_rdr_name_env spec_occ of
Nothing
-> ( extendOccEnv original_rdr_name_env spec_occ spec_rdr_name
- , genAuxBindSpecOriginal loc spec `consBag` spec_bag )
+ , genAuxBindSpecOriginal loc spec `cons_bind_sig` spec_bag )
Just original_rdr_name
-> ( original_rdr_name_env
- , genAuxBindSpecDup loc original_rdr_name spec `consBag` spec_bag )
+ , genAuxBindSpecDup loc original_rdr_name spec `cons_bind_sig` spec_bag )
where
spec_rdr_name = auxBindSpecRdrName spec
spec_occ = rdrNameOcc spec_rdr_name
+ cons_bind_sig (bind, sig) (binds, sigs) = (bind `consBag` binds, sig : sigs)
mkParentType :: TyCon -> Type
-- Turn the representation tycon of a family into
=====================================
compiler/GHC/Tc/Deriv/Infer.hs
=====================================
@@ -6,6 +6,7 @@
{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE OverloadedRecordDot #-}
-- | Functions for inferring (and simplifying) the context for derived instances.
module GHC.Tc.Deriv.Infer
@@ -62,6 +63,11 @@ import Data.Function (on)
import Data.Functor.Classes (liftEq)
import Data.List (sortBy)
import Data.Maybe
+import GHC.Types.Id (idName, idType)
+import GHC.Rename.HsType (rnHsSigType)
+import GHC.Tc.Errors.Types (HsDocContext(..))
+import GHC.Tc.Gen.HsType (tcHsClsInstType)
+import GHC.Hs.Decls (ClsInstDecl(..))
----------------------
@@ -96,6 +102,8 @@ inferConstraints mechanism
, mechanism{dsm_stock_dit = dit'} )
DerivSpecAnyClass
-> infer_constraints_simple inferConstraintsAnyclass
+ DerivSpecTH{}
+ -> infer_constraints_simple (inferConstraintsTH mechanism)
DerivSpecNewtype { dsm_newtype_dit =
DerivInstTys{dit_cls_tys = cls_tys}
, dsm_newtype_rep_ty = rep_ty }
@@ -394,6 +402,49 @@ inferConstraintsAnyclass
; pure $ map meth_pred gen_dms }
+-- | Like 'inferConstraintsAnyclass', but used only in the case of @DeriveTH@,
+-- where constraints are gathered based on the type signatures generated for
+-- class methods.
+--
+-- See Note [Gathering and simplifying constraints for DeriveTH]
+-- for an explanation of how these constraints are used to determine the
+-- derived instance context.
+inferConstraintsTH :: DerivSpecMechanism -> DerivM ThetaSpec
+inferConstraintsTH mechanism at DerivSpecTH{dsm_th_inst_decl=inst_decl}
+ = do { DerivEnv { denv_cls = cls
+ , denv_inst_tys = inst_tys } <- ask
+ ; wildcard <- isStandaloneWildcardDeriv
+ ; let ctx = GenericCtx $ text "a derived instance declaration"
+ ; (inst_ty, inst_fvs) <- lift $ rnHsSigType ctx TypeLevel inst_decl.cid_poly_ty
+ ; inst_ty <- lift $ tcHsClsInstType (InstDeclCtxt False {-TODO-}) inst_ty
+ ; let (tyvars, theta, clas, inst_tys2) = tcSplitDFunTy inst_ty -- TODO verify that inst_tys matches (is equal to?) inst_tys2
+-- ; let gen_dms = [ idName sel_id
+-- | (sel_id, _) <- classOpItems cls ]
+ ; pprTraceM "infer" (ppr inst_ty $$ ppr inst_tys $$ ppr inst_tys2 $$ ppr theta)
+ ; let blah pred = SimplePredSpec pred (mkDerivOrigin wildcard) TypeLevel {- TODO -}
+ ; return (map blah theta) }
+
+-- ; let meth_pred :: (Id, Type) -> PredSpec
+-- -- (Id,Type) are the selector Id and the generic default method type
+-- -- NB: the latter is /not/ quantified over the class variables
+-- -- See Note [Gathering and simplifying constraints for DeriveAnyClass]
+-- meth_pred (sel_id, gen_dm_ty)
+-- = let (sel_tvs, _cls_pred, meth_ty) = tcSplitMethodTy (varType sel_id)
+-- meth_ty' = substTyWith sel_tvs inst_tys meth_ty
+-- gen_dm_ty' = substTyWith sel_tvs inst_tys gen_dm_ty in
+-- -- This is the only place where a SubTypePredSpec is
+-- -- constructed instead of a SimplePredSpec. See
+-- -- Note [Gathering and simplifying constraints for DeriveAnyClass]
+-- -- for a more in-depth explanation.
+-- SubTypePredSpec { stps_ty_actual = gen_dm_ty'
+-- , stps_ty_expected = meth_ty'
+-- , stps_origin = mkDerivOrigin wildcard
+-- }
+--
+-- ; pure $ map meth_pred gen_dms }
+inferConstraintsTH _
+ = panic "not called with DerivTH"
+
-- Like 'inferConstraints', but used only for @GeneralizedNewtypeDeriving@ and
-- @DerivingVia at . Since both strategies generate code involving 'coerce', the
-- inferred constraints set up the scaffolding needed to typecheck those uses
=====================================
compiler/GHC/Tc/Deriv/Utils.hs
=====================================
@@ -12,7 +12,7 @@ module GHC.Tc.Deriv.Utils (
DerivM, DerivEnv(..),
DerivSpec(..), pprDerivSpec, setDerivSpecTheta, zonkDerivSpec,
DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock,
- isDerivSpecNewtype, isDerivSpecAnyClass,
+ isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecTH,
isDerivSpecVia, zonkDerivSpecMechanism,
DerivContext(..), OriginativeDerivStatus(..), StockGenFns(..),
isStandaloneDeriv, isStandaloneWildcardDeriv,
@@ -291,15 +291,26 @@ data DerivSpecMechanism
-- ^ The @via@ type
}
+ -- | @DeriveAnyClass@
+ | DerivSpecTH
+ { dsm_th_dit :: DerivInstTys
+ -- ^ Information about the arguments to the class in the derived
+ -- instance, including what type constructor the last argument is
+ -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@.
+ , dsm_th_inst_decl :: ClsInstDecl GhcPs
+ , dsm_th_aux_binds :: LHsBinds GhcPs
+ }
+
-- | Convert a 'DerivSpecMechanism' to its corresponding 'DerivStrategy'.
derivSpecMechanismToStrategy :: DerivSpecMechanism -> DerivStrategy GhcTc
-derivSpecMechanismToStrategy DerivSpecStock{} = StockStrategy noExtField
-derivSpecMechanismToStrategy DerivSpecNewtype{} = NewtypeStrategy noExtField
-derivSpecMechanismToStrategy DerivSpecAnyClass = AnyclassStrategy noExtField
+derivSpecMechanismToStrategy DerivSpecStock{} = StockStrategy noExtField
+derivSpecMechanismToStrategy DerivSpecNewtype{} = NewtypeStrategy noExtField
+derivSpecMechanismToStrategy DerivSpecAnyClass = AnyclassStrategy noExtField
+derivSpecMechanismToStrategy DerivSpecTH{} = THStrategy noExtField
derivSpecMechanismToStrategy (DerivSpecVia{dsm_via_ty = t}) = ViaStrategy t
-isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia
- :: DerivSpecMechanism -> Bool
+isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia,
+ isDerivSpecTH :: DerivSpecMechanism -> Bool
isDerivSpecStock (DerivSpecStock{}) = True
isDerivSpecStock _ = False
@@ -312,6 +323,9 @@ isDerivSpecAnyClass _ = False
isDerivSpecVia (DerivSpecVia{}) = True
isDerivSpecVia _ = False
+isDerivSpecTH (DerivSpecTH{}) = True
+isDerivSpecTH _ = False
+
-- | Zonk the 'TcTyVar's in a 'DerivSpecMechanism' to 'TyVar's.
-- See @Note [What is zonking?]@ in "GHC.Tc.Zonk.Type".
--
@@ -349,6 +363,10 @@ zonkDerivSpecMechanism mechanism =
, dsm_via_inst_ty = inst_ty'
, dsm_via_ty = via_ty'
}
+ DerivSpecTH { dsm_th_dit = dit
+ } -> do
+ dit' <- zonkDerivInstTys dit
+ pure $ mechanism { dsm_th_dit = dit' }
instance Outputable DerivSpecMechanism where
ppr (DerivSpecStock{dsm_stock_dit = dit})
@@ -365,6 +383,9 @@ instance Outputable DerivSpecMechanism where
2 (vcat [ text "dsm_via_cls_tys" <+> ppr cls_tys
, text "dsm_via_inst_ty" <+> ppr inst_ty
, text "dsm_via_ty" <+> ppr via_ty ])
+ ppr (DerivSpecTH{dsm_th_dit = dit})
+ = hang (text "DerivSpecTH")
+ 2 (vcat [ text "dsm_th_dit" <+> ppr dit ])
{-
Note [DerivEnv and DerivSpecMechanism]
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -15,6 +15,7 @@ module GHC.Tc.Gen.Bind
( tcLocalBinds
, tcTopBinds
, tcValBinds
+ , tcTySigs
, tcHsBootSigs
, tcPolyCheck
, chooseInferredQuantifiers
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -676,6 +676,7 @@ tcDerivStrategy mb_lds
tc_deriv_strategy (StockStrategy _) = boring_case (StockStrategy noExtField)
tc_deriv_strategy (AnyclassStrategy _) = boring_case (AnyclassStrategy noExtField)
tc_deriv_strategy (NewtypeStrategy _) = boring_case (NewtypeStrategy noExtField)
+ tc_deriv_strategy (THStrategy _) = boring_case (THStrategy noExtField)
tc_deriv_strategy (ViaStrategy hs_sig)
= do { ty <- tcTopLHsType DerivClauseCtxt hs_sig
-- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv]
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -21,7 +21,7 @@
-- | Template Haskell splices
module GHC.Tc.Gen.Splice(
tcTypedSplice, tcTypedBracket, tcUntypedBracket,
- runAnnotation, getUntypedSpliceBody,
+ reifyType, runAnnotation, getUntypedSpliceBody,
runMetaE, runMetaP, runMetaT, runMetaD, runQuasi,
tcTopSpliceExpr, lookupThName_maybe,
@@ -762,13 +762,14 @@ brackTy b =
return (Just wrapper, final_ty)
in
case b of
- (VarBr {}) -> (Nothing,) <$> tcMetaTy nameTyConName
+ (VarBr {}) -> (Nothing,) <$> tcMetaTy nameTyConName
-- Result type is Var (not Quote-monadic)
- (ExpBr {}) -> mkTy expTyConName -- Result type is m Exp
- (TypBr {}) -> mkTy typeTyConName -- Result type is m Type
- (DecBrG {}) -> mkTy decsTyConName -- Result type is m [Dec]
- (PatBr {}) -> mkTy patTyConName -- Result type is m Pat
- (DecBrL {}) -> panic "tcBrackTy: Unexpected DecBrL"
+ (ExpBr {}) -> mkTy expTyConName -- Result type is m Exp
+ (TypBr {}) -> mkTy typeTyConName -- Result type is m Type
+ (DecBrG {}) -> mkTy decsTyConName -- Result type is m [Dec]
+ (PatBr {}) -> mkTy patTyConName -- Result type is m Pat
+ (DecBrL {}) -> panic "tcBrackTy: Unexpected DecBrL"
+ (XQuote (THTypBr{})) -> mkTy typeTyConName -- Result type is m Type
---------------
-- | Typechecking a pending splice from a untyped bracket
=====================================
compiler/GHC/Tc/Gen/Splice.hs-boot
=====================================
@@ -9,6 +9,7 @@ import GHC.Tc.Types( TcM , SpliceType )
import GHC.Tc.Utils.TcType ( ExpRhoType )
import GHC.Types.Annotations ( Annotation, CoreAnnTarget )
import GHC.Hs.Extension ( GhcRn, GhcPs, GhcTc )
+import qualified GHC.Core.TyCo.Rep as TyCoRep
import GHC.Hs ( HsQuote, HsExpr, LHsExpr, LHsType, LPat, LHsDecl, ThModFinalizers, HsUntypedSpliceResult )
import qualified GHC.Internal.TH.Syntax as TH
@@ -28,6 +29,8 @@ tcUntypedBracket :: HsExpr GhcRn
-> ExpRhoType
-> TcM (HsExpr GhcTc)
+reifyType :: TyCoRep.Type -> TcM TH.Type
+
runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc)
runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation
=====================================
compiler/GHC/Tc/Module.hs-boot
=====================================
@@ -2,6 +2,10 @@ module GHC.Tc.Module where
import GHC.Types.SourceFile(HsBootOrSig)
import GHC.Types.TyThing(TyThing)
-import GHC.Tc.Types (TcM)
+import GHC.Tc.Types (TcM, TcGblEnv, TcLclEnv)
+import GHC.Hs.Extension (GhcPs, GhcRn)
+import GHC.Hs.Decls (HsGroup)
checkBootDeclM :: HsBootOrSig -> TyThing -> TyThing -> TcM ()
+rnTopSrcDecls :: HsGroup GhcPs -> TcM (TcGblEnv, HsGroup GhcRn)
+tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv)
=====================================
compiler/Language/Haskell/Syntax/Decls.hs
=====================================
@@ -1497,6 +1497,8 @@ data DerivStrategy pass
| NewtypeStrategy (XNewtypeStrategy pass) -- ^ @-XGeneralizedNewtypeDeriving@
| ViaStrategy (XViaStrategy pass)
-- ^ @-XDerivingVia@
+ | THStrategy (XTHStrategy pass)
+ -- ^ @-XDerivingTemplateHaskell@
{-
=====================================
compiler/Language/Haskell/Syntax/Extension.hs
=====================================
@@ -340,6 +340,7 @@ type family XStockStrategy x
type family XAnyClassStrategy x
type family XNewtypeStrategy x
type family XViaStrategy x
+type family XTHStrategy x
-- -------------------------------------
-- DefaultDecl type families
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs
=====================================
@@ -1,6 +1,8 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE Trustworthy #-}
@@ -27,13 +29,15 @@ import Control.Applicative(liftA, Applicative(..))
import qualified Data.Kind as Kind (Type)
import Data.Word( Word8 )
import Data.List.NonEmpty ( NonEmpty(..) )
-import GHC.Exts (TYPE)
+import GHC.Exts (TYPE, Constraint)
import Prelude hiding (Applicative(..))
+import Data.Proxy
#else
import GHC.Internal.Base hiding (Type, Module, inline)
import GHC.Internal.Data.Foldable
import GHC.Internal.Data.Functor
import GHC.Internal.Data.Maybe
+import GHC.Internal.Data.Proxy
import GHC.Internal.Data.Traversable (traverse, sequenceA)
import GHC.Internal.Integer
import GHC.Internal.List (zip)
@@ -1252,3 +1256,14 @@ docCons (c, md, arg_docs) = do
| nm <- get_cons_names c'
, (i, Just arg_doc) <- zip [0..] arg_docs
]
+
+class DeriveTH (c :: k) where
+ deriveTH :: Proxy c -> Type -> Q [Dec]
+
+deriveTHEntry :: forall c. DeriveTH c => Q Type -> Q [Dec]
+-- TODO: Use RequiredTypeArguments instead?
+deriveTHEntry head = do
+ head <- head
+ -- Nothing :: Maybe Overlap; will be overwritten by the type-checker with the
+ -- proper overlap pragma
+ deriveTH (Proxy :: Proxy c) head
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/82aea77ed908fe36bed829c9c4a01ea9b30a0181
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/82aea77ed908fe36bed829c9c4a01ea9b30a0181
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/20240619/0c6fd189/attachment-0001.html>
More information about the ghc-commits
mailing list