Commit 95dc6dc0 authored by Matthew Pickering's avatar Matthew Pickering

Template Haskell support for COMPLETE pragmas

Reviewers: RyanGlScott, austin, goldfire, bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2997

GHC Trac Issues: #13098
parent 1a3f1eeb
......@@ -737,7 +737,8 @@ rep_sig (L loc (SpecSig nm tys ispec))
rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty loc
rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty
rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty
rep_sig (L _ (CompleteMatchSig {})) = notHandled "CompleteMatchSig" empty
rep_sig (L loc (CompleteMatchSig _st cls mty)) = rep_complete_sig cls mty loc
rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> Located Name
-> DsM (SrcSpan, Core TH.DecQ)
......@@ -832,6 +833,21 @@ repPhases (ActiveAfter _ i) = do { MkC arg <- coreIntLit i
; dataCon' fromPhaseDataConName [arg] }
repPhases _ = dataCon allPhasesDataConName
rep_complete_sig :: Located [Located Name]
-> Maybe (Located Name)
-> SrcSpan
-> DsM [(SrcSpan, Core TH.DecQ)]
rep_complete_sig (L _ cls) mty loc
= do { mty' <- rep_maybe_name mty
; cls' <- repList nameTyConName lookupLOcc cls
; sig <- repPragComplete cls' mty'
; return [(loc, sig)] }
where
rep_maybe_name Nothing = coreNothing nameTyConName
rep_maybe_name (Just n) = do
cn <- lookupLOcc n
coreJust nameTyConName cn
-------------------------------------------------------
-- Types
-------------------------------------------------------
......@@ -2101,6 +2117,9 @@ repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)
repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ)
repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> DsM (Core TH.DecQ)
repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty]
repPragRule :: Core String -> Core [TH.RuleBndrQ] -> Core TH.ExpQ
-> Core TH.ExpQ -> Core TH.Phases -> DsM (Core TH.DecQ)
repPragRule (MkC nm) (MkC bndrs) (MkC lhs) (MkC rhs) (MkC phases)
......
......@@ -709,6 +709,11 @@ cvtPragmaD (LineP line file)
= do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1))
; return Nothing
}
cvtPragmaD (CompleteP cls mty)
= do { cls' <- noLoc <$> mapM cNameL cls
; mty' <- traverse tconNameL mty
; returnJustL $ Hs.SigD
$ CompleteMatchSig NoSourceText cls' mty' }
dfltActivation :: TH.Inline -> Activation
dfltActivation TH.NoInline = NeverActive
......
......@@ -342,7 +342,8 @@ funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName,
dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,
openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName,
infixNDName, roleAnnotDName, patSynDName, patSynSigDName :: Name
infixNDName, roleAnnotDName, patSynDName, patSynSigDName,
pragCompleteDName :: Name
funDName = libFun (fsLit "funD") funDIdKey
valDName = libFun (fsLit "valD") valDIdKey
dataDName = libFun (fsLit "dataD") dataDIdKey
......@@ -361,6 +362,7 @@ pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey
pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey
pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey
pragCompleteDName = libFun (fsLit "pragCompleteD") pragCompleteDIdKey
pragAnnDName = libFun (fsLit "pragAnnD") pragAnnDIdKey
dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey
newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
......@@ -859,7 +861,7 @@ funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey,
newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,
infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,
patSynSigDIdKey :: Unique
patSynSigDIdKey, pragCompleteDIdKey :: Unique
funDIdKey = mkPreludeMiscIdUnique 320
valDIdKey = mkPreludeMiscIdUnique 321
dataDIdKey = mkPreludeMiscIdUnique 322
......@@ -890,79 +892,80 @@ standaloneDerivWithStrategyDIdKey = mkPreludeMiscIdUnique 346
defaultSigDIdKey = mkPreludeMiscIdUnique 347
patSynDIdKey = mkPreludeMiscIdUnique 348
patSynSigDIdKey = mkPreludeMiscIdUnique 349
pragCompleteDIdKey = mkPreludeMiscIdUnique 350
-- type Cxt = ...
cxtIdKey :: Unique
cxtIdKey = mkPreludeMiscIdUnique 350
cxtIdKey = mkPreludeMiscIdUnique 351
-- data SourceUnpackedness = ...
noSourceUnpackednessKey, sourceNoUnpackKey, sourceUnpackKey :: Unique
noSourceUnpackednessKey = mkPreludeMiscIdUnique 351
sourceNoUnpackKey = mkPreludeMiscIdUnique 352
sourceUnpackKey = mkPreludeMiscIdUnique 353
noSourceUnpackednessKey = mkPreludeMiscIdUnique 352
sourceNoUnpackKey = mkPreludeMiscIdUnique 353
sourceUnpackKey = mkPreludeMiscIdUnique 354
-- data SourceStrictness = ...
noSourceStrictnessKey, sourceLazyKey, sourceStrictKey :: Unique
noSourceStrictnessKey = mkPreludeMiscIdUnique 354
sourceLazyKey = mkPreludeMiscIdUnique 355
sourceStrictKey = mkPreludeMiscIdUnique 356
noSourceStrictnessKey = mkPreludeMiscIdUnique 355
sourceLazyKey = mkPreludeMiscIdUnique 356
sourceStrictKey = mkPreludeMiscIdUnique 357
-- data Con = ...
normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey, gadtCIdKey,
recGadtCIdKey :: Unique
normalCIdKey = mkPreludeMiscIdUnique 357
recCIdKey = mkPreludeMiscIdUnique 358
infixCIdKey = mkPreludeMiscIdUnique 359
forallCIdKey = mkPreludeMiscIdUnique 360
gadtCIdKey = mkPreludeMiscIdUnique 361
recGadtCIdKey = mkPreludeMiscIdUnique 362
normalCIdKey = mkPreludeMiscIdUnique 358
recCIdKey = mkPreludeMiscIdUnique 359
infixCIdKey = mkPreludeMiscIdUnique 360
forallCIdKey = mkPreludeMiscIdUnique 361
gadtCIdKey = mkPreludeMiscIdUnique 362
recGadtCIdKey = mkPreludeMiscIdUnique 363
-- data Bang = ...
bangIdKey :: Unique
bangIdKey = mkPreludeMiscIdUnique 363
bangIdKey = mkPreludeMiscIdUnique 364
-- type BangType = ...
bangTKey :: Unique
bangTKey = mkPreludeMiscIdUnique 364
bangTKey = mkPreludeMiscIdUnique 365
-- type VarBangType = ...
varBangTKey :: Unique
varBangTKey = mkPreludeMiscIdUnique 365
varBangTKey = mkPreludeMiscIdUnique 366
-- data PatSynDir = ...
unidirPatSynIdKey, implBidirPatSynIdKey, explBidirPatSynIdKey :: Unique
unidirPatSynIdKey = mkPreludeMiscIdUnique 366
implBidirPatSynIdKey = mkPreludeMiscIdUnique 367
explBidirPatSynIdKey = mkPreludeMiscIdUnique 368
unidirPatSynIdKey = mkPreludeMiscIdUnique 367
implBidirPatSynIdKey = mkPreludeMiscIdUnique 368
explBidirPatSynIdKey = mkPreludeMiscIdUnique 369
-- data PatSynArgs = ...
prefixPatSynIdKey, infixPatSynIdKey, recordPatSynIdKey :: Unique
prefixPatSynIdKey = mkPreludeMiscIdUnique 369
infixPatSynIdKey = mkPreludeMiscIdUnique 370
recordPatSynIdKey = mkPreludeMiscIdUnique 371
prefixPatSynIdKey = mkPreludeMiscIdUnique 370
infixPatSynIdKey = mkPreludeMiscIdUnique 371
recordPatSynIdKey = mkPreludeMiscIdUnique 372
-- data Type = ...
forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey,
unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, sigTIdKey,
equalityTIdKey, litTIdKey, promotedTIdKey, promotedTupleTIdKey,
promotedNilTIdKey, promotedConsTIdKey, wildCardTIdKey :: Unique
forallTIdKey = mkPreludeMiscIdUnique 380
varTIdKey = mkPreludeMiscIdUnique 381
conTIdKey = mkPreludeMiscIdUnique 382
tupleTIdKey = mkPreludeMiscIdUnique 383
unboxedTupleTIdKey = mkPreludeMiscIdUnique 384
unboxedSumTIdKey = mkPreludeMiscIdUnique 385
arrowTIdKey = mkPreludeMiscIdUnique 386
listTIdKey = mkPreludeMiscIdUnique 387
appTIdKey = mkPreludeMiscIdUnique 388
sigTIdKey = mkPreludeMiscIdUnique 389
equalityTIdKey = mkPreludeMiscIdUnique 390
litTIdKey = mkPreludeMiscIdUnique 391
promotedTIdKey = mkPreludeMiscIdUnique 392
promotedTupleTIdKey = mkPreludeMiscIdUnique 393
promotedNilTIdKey = mkPreludeMiscIdUnique 394
promotedConsTIdKey = mkPreludeMiscIdUnique 395
wildCardTIdKey = mkPreludeMiscIdUnique 396
forallTIdKey = mkPreludeMiscIdUnique 381
varTIdKey = mkPreludeMiscIdUnique 382
conTIdKey = mkPreludeMiscIdUnique 383
tupleTIdKey = mkPreludeMiscIdUnique 384
unboxedTupleTIdKey = mkPreludeMiscIdUnique 385
unboxedSumTIdKey = mkPreludeMiscIdUnique 386
arrowTIdKey = mkPreludeMiscIdUnique 387
listTIdKey = mkPreludeMiscIdUnique 388
appTIdKey = mkPreludeMiscIdUnique 389
sigTIdKey = mkPreludeMiscIdUnique 390
equalityTIdKey = mkPreludeMiscIdUnique 391
litTIdKey = mkPreludeMiscIdUnique 392
promotedTIdKey = mkPreludeMiscIdUnique 393
promotedTupleTIdKey = mkPreludeMiscIdUnique 394
promotedNilTIdKey = mkPreludeMiscIdUnique 395
promotedConsTIdKey = mkPreludeMiscIdUnique 396
wildCardTIdKey = mkPreludeMiscIdUnique 397
-- data TyLit = ...
numTyLitIdKey, strTyLitIdKey :: Unique
......
......@@ -100,7 +100,7 @@ module Language.Haskell.TH.Lib (
ruleVar, typedRuleVar,
valueAnnotation, typeAnnotation, moduleAnnotation,
pragInlD, pragSpecD, pragSpecInlD, pragSpecInstD, pragRuleD, pragAnnD,
pragLineD,
pragLineD, pragCompleteD,
-- **** Pattern Synonyms
patSynD, patSynSigD, unidir, implBidir, explBidir, prefixPatSyn,
......@@ -557,6 +557,9 @@ pragAnnD target expr
pragLineD :: Int -> String -> DecQ
pragLineD line file = return $ PragmaD $ LineP line file
pragCompleteD :: [Name] -> Maybe Name -> DecQ
pragCompleteD cls mty = return $ PragmaD $ CompleteP cls mty
dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> [ConQ] -> [DerivClauseQ]
-> DecQ
dataInstD ctxt tc tys ksig cons derivs =
......
......@@ -527,6 +527,9 @@ instance Ppr Pragma where
target1 (ValueAnnotation v) = ppr v
ppr (LineP line file)
= text "{-# LINE" <+> int line <+> text (show file) <+> text "#-}"
ppr (CompleteP cls mty)
= text "{-# COMPLETE" <+> (fsep $ punctuate comma $ map ppr cls)
<+> maybe empty (\ty -> dcolon <+> ppr ty) mty
------------------------------
instance Ppr Inline where
......
......@@ -1764,6 +1764,8 @@ data Pragma = InlineP Name Inline RuleMatch Phases
| RuleP String [RuleBndr] Exp Exp Phases
| AnnP AnnTarget Exp
| LineP Int String
| CompleteP [Name] (Maybe Name)
-- ^ @{ {\-\# COMPLETE C_1, ..., C_i [ :: T ] \#-} }@
deriving( Show, Eq, Ord, Data, Generic )
data Inline = NoInline
......
......@@ -16,6 +16,8 @@
* Add support for attaching deriving strategies to `deriving` statements
(#10598)
* Add support for `COMPLETE` pragmas. (#13098)
* `unboxedTupleTypeName` and `unboxedTupleDataName` now work for unboxed
0-tuples and 1-tuples (#12977)
......
{-# LANGUAGE TemplateHaskell #-}
module T13098 where
import Language.Haskell.TH
$( sequence [ dataD (cxt []) (mkName "T") [PlainTV (mkName "a")]
Nothing [normalC (mkName "T") []] []
, pragCompleteD [mkName "T"] Nothing ] )
......@@ -369,3 +369,4 @@ test('T12977', normal, compile, ['-v0'])
test('T12993', normal, multimod_compile, ['T12993.hs', '-v0'])
test('T13018', normal, compile, ['-v0'])
test('T13123', normal, compile, ['-v0'])
test('T13098', normal, compile, ['-v0'])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment