Template Haskell support for COMPLETE pragmas

Reviewers: RyanGlScott, austin, goldfire, bgamari

Subscribers: thomie

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

GHC Trac Issues: #13098

9 files changed, 90 insertions, 43 deletions

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'])