From 95dc6dc070deac733d4a4a63a93e606a2e772a67 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Sat, 21 Jan 2017 19:29:49 +0000 Subject: Template Haskell support for COMPLETE pragmas Reviewers: RyanGlScott, austin, goldfire, bgamari Subscribers: thomie Differential Revision: https://phabricator.haskell.org/D2997 GHC Trac Issues: #13098 --- compiler/deSugar/DsMeta.hs | 21 +++++- compiler/hsSyn/Convert.hs | 5 ++ compiler/prelude/THNames.hs | 85 +++++++++++----------- .../template-haskell/Language/Haskell/TH/Lib.hs | 5 +- .../template-haskell/Language/Haskell/TH/Ppr.hs | 3 + .../template-haskell/Language/Haskell/TH/Syntax.hs | 2 + libraries/template-haskell/changelog.md | 2 + testsuite/tests/th/T13098.hs | 9 +++ testsuite/tests/th/all.T | 1 + 9 files changed, 90 insertions(+), 43 deletions(-) create mode 100644 testsuite/tests/th/T13098.hs diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 049c226a0b..1ec70c7bdc 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -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) diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 3e0bf126cf..a1ea110cf6 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -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 diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs index fbda099d46..e051082c34 100644 --- a/compiler/prelude/THNames.hs +++ b/compiler/prelude/THNames.hs @@ -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 diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index 0aa76204b1..a3cbc8efb5 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -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 = diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index 803eaef2dc..00ffbd0042 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -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 diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index 92e48adb2a..b63d692a11 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -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 diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md index adf9365ed0..50f1709b83 100644 --- a/libraries/template-haskell/changelog.md +++ b/libraries/template-haskell/changelog.md @@ -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) diff --git a/testsuite/tests/th/T13098.hs b/testsuite/tests/th/T13098.hs new file mode 100644 index 0000000000..77e23f3d11 --- /dev/null +++ b/testsuite/tests/th/T13098.hs @@ -0,0 +1,9 @@ +{-# 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 ] ) diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 917f3157a7..d378412f94 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -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']) -- cgit v1.2.1