template-haskell: Add support for default declarations

Fixes #19373

13 files changed, 49 insertions, 9 deletions

diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs
index 07a8583662..ceba3042d7 100644
--- a/compiler/GHC/Builtin/Names/TH.hs
+++ b/compiler/GHC/Builtin/Names/TH.hs
@@ -72,7 +72,7 @@ templateHaskellNames = [
     classDName, instanceWithOverlapDName,
     standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName,
     pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
-    pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName,
+    pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName, defaultDName,
     dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
     dataInstDName, newtypeInstDName, tySynInstDName,
     infixLDName, infixRDName, infixNDName,
@@ -353,7 +353,7 @@ recSName    = libFun (fsLit "recS")    recSIdKey
 funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
     instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName,
     pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName,
-    pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName,
+    pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName, defaultDName,
     dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,
     openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName,
     infixNDName, roleAnnotDName, patSynDName, patSynSigDName,
@@ -368,6 +368,7 @@ instanceWithOverlapDName         = libFun (fsLit "instanceWithOverlapD")
 standaloneDerivWithStrategyDName = libFun (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey
 sigDName                         = libFun (fsLit "sigD")                         sigDIdKey
 kiSigDName                       = libFun (fsLit "kiSigD")                       kiSigDIdKey
+defaultDName                     = libFun (fsLit "defaultD")                     defaultDIdKey
 defaultSigDName                  = libFun (fsLit "defaultSigD")                  defaultSigDIdKey
 forImpDName                      = libFun (fsLit "forImpD")                      forImpDIdKey
 pragInlDName                     = libFun (fsLit "pragInlD")                     pragInlDIdKey
@@ -878,7 +879,7 @@ funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
     newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,
     infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,
     patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey,
-    kiSigDIdKey :: Unique
+    kiSigDIdKey, defaultDIdKey :: Unique
 funDIdKey                         = mkPreludeMiscIdUnique 320
 valDIdKey                         = mkPreludeMiscIdUnique 321
 dataDIdKey                        = mkPreludeMiscIdUnique 322
@@ -912,6 +913,7 @@ patSynSigDIdKey                   = mkPreludeMiscIdUnique 349
 pragCompleteDIdKey                = mkPreludeMiscIdUnique 350
 implicitParamBindDIdKey           = mkPreludeMiscIdUnique 351
 kiSigDIdKey                       = mkPreludeMiscIdUnique 352
+defaultDIdKey                     = mkPreludeMiscIdUnique 353
 
 -- type Cxt = ...
 cxtIdKey :: Unique
diff --git a/compiler/GHC/HsToCore/Errors/Ppr.hs b/compiler/GHC/HsToCore/Errors/Ppr.hs
index 6c65b14e20..c8bda5562b 100644
--- a/compiler/GHC/HsToCore/Errors/Ppr.hs
+++ b/compiler/GHC/HsToCore/Errors/Ppr.hs
@@ -163,8 +163,6 @@ instance Diagnostic DsMessage where
              ThWarningAndDeprecationPragmas decl
                -> mkMsg "WARNING and DEPRECATION pragmas" $
                     text "Pragma for declaration of" <+> ppr decl
-             ThDefaultDeclarations decl
-               -> mkMsg "Default declarations" (ppr decl)
              ThSplicesWithinDeclBrackets
                -> mkMsg "Splices within declaration brackets" empty
          where
diff --git a/compiler/GHC/HsToCore/Errors/Types.hs b/compiler/GHC/HsToCore/Errors/Types.hs
index 950d4aa42a..9a98e764e2 100644
--- a/compiler/GHC/HsToCore/Errors/Types.hs
+++ b/compiler/GHC/HsToCore/Errors/Types.hs
@@ -191,7 +191,6 @@ data ThRejectionReason
   | ThNegativeOverloadedPatterns !(Pat GhcRn)
   | ThHaddockDocumentation
   | ThWarningAndDeprecationPragmas [LIdP GhcRn]
-  | ThDefaultDeclarations !(DefaultDecl GhcRn)
   | ThSplicesWithinDeclBrackets
 
 data NegLiteralExtEnabled
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 71e5ac9655..f68a561957 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -305,7 +305,7 @@ repTopDs group@(HsGroup { hs_valds   = valds
                      ; inst_ds  <- mapM repInstD instds
                      ; deriv_ds <- mapM repStandaloneDerivD derivds
                      ; fix_ds   <- mapM repLFixD fixds
-                     ; _        <- mapM no_default_decl defds
+                     ; def_ds   <- mapM repDefD defds
                      ; for_ds   <- mapM repForD fords
                      ; _        <- mapM no_warn (concatMap (wd_warnings . unLoc)
                                                            warnds)
@@ -319,6 +319,7 @@ repTopDs group@(HsGroup { hs_valds   = valds
                                 val_ds ++ catMaybes tycl_ds ++ role_ds
                                        ++ kisig_ds
                                        ++ (concat fix_ds)
+                                       ++ def_ds
                                        ++ inst_ds ++ rule_ds ++ for_ds
                                        ++ ann_ds ++ deriv_ds) }) ;
 
@@ -332,8 +333,6 @@ repTopDs group@(HsGroup { hs_valds   = valds
   where
     no_splice (L loc _)
       = notHandledL (locA loc) ThSplicesWithinDeclBrackets
-    no_default_decl (L loc decl)
-      = notHandledL (locA loc) (ThDefaultDeclarations decl)
     no_warn :: LWarnDecl GhcRn -> MetaM a
     no_warn (L loc (Warning _ thing _))
       = notHandledL (locA loc) (ThWarningAndDeprecationPragmas thing)
@@ -798,6 +797,12 @@ rep_fix_d loc (FixitySig _ names (Fixity _ prec dir))
                    ; return (loc,dec) }
        ; mapM do_one names }
 
+repDefD :: LDefaultDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
+repDefD (L loc (DefaultDecl _ tys)) = do { tys1 <- repLTys tys
+                                         ; MkC tys2 <- coreListM typeTyConName tys1
+                                         ; dec <- rep2 defaultDName [tys2]
+                                         ; return (locA loc, dec)}
+
 repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
 repRuleD (L loc (HsRule { rd_name = n
                         , rd_act = act
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index e452841f7a..8d3df10185 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -226,6 +226,10 @@ cvtDec (TH.InfixD fx nm)
        ; returnJustLA (Hs.SigD noExtField (FixSig noAnn
                                       (FixitySig noExtField [nm'] (cvtFixity fx)))) }
 
+cvtDec (TH.DefaultD tys)
+  = do  { tys' <- traverse cvtType tys
+        ; returnJustLA (Hs.DefD noExtField $ DefaultDecl noAnn tys') }
+
 cvtDec (PragmaD prag)
   = cvtPragmaD prag
 
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index de90df2bfd..f57861024c 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -103,6 +103,9 @@ module Language.Haskell.TH.Lib (
     -- **** Fixity
     infixLD, infixRD, infixND,
 
+    -- **** Default declaration
+    defaultD,
+
     -- **** Foreign Function Interface (FFI)
     cCall, stdCall, cApi, prim, javaScript,
     unsafe, safe, interruptible, forImpD,
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
index 472a4f8557..d921a60e6b 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
@@ -468,6 +468,9 @@ infixRD prec nm = pure (InfixD (Fixity prec InfixR) nm)
 infixND :: Quote m => Int -> Name -> m Dec
 infixND prec nm = pure (InfixD (Fixity prec InfixN) nm)
 
+defaultD :: Quote m => [m Type] -> m Dec
+defaultD tys = DefaultD <$> sequenceA tys
+
 pragInlD :: Quote m => Name -> Inline -> RuleMatch -> Phases -> m Dec
 pragInlD name inline rm phases
   = pure $ PragmaD $ InlineP name inline rm phases
@@ -1030,6 +1033,7 @@ withDecDoc doc dec = do
     doc_loc (StandaloneDerivD _ _ _) = Nothing
     doc_loc (DefaultSigD _ _)        = Nothing
     doc_loc (ImplicitParamBindD _ _) = Nothing
+    doc_loc (DefaultD _)             = Nothing
 
 -- | Variant of 'withDecDoc' that applies the same documentation to
 -- multiple declarations. Useful for documenting quoted declarations.
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 47585b9f9d..6fcf48010d 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -361,6 +361,8 @@ ppr_dec _ (SigD f t)    = pprPrefixOcc f <+> dcolon <+> ppr t
 ppr_dec _ (KiSigD f k)  = text "type" <+> pprPrefixOcc f <+> dcolon <+> ppr k
 ppr_dec _ (ForeignD f)  = ppr f
 ppr_dec _ (InfixD fx n) = pprFixity n fx
+ppr_dec _ (DefaultD tys) =
+        text "default" <+> parens (sep $ punctuate comma $ map ppr tys)
 ppr_dec _ (PragmaD p)   = ppr p
 ppr_dec isTop (DataFamilyD tc tvs kind)
   = text "data" <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> maybeKind
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 5e0c75151e..8f8ddaf1e8 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -2289,6 +2289,7 @@ data Dec
                                   --{ foreign export ... }@
 
   | InfixD Fixity Name            -- ^ @{ infix 3 foo }@
+  | DefaultD [Type]               -- ^ @{ default (Integer, Double) }@
 
   -- | pragmas
   | PragmaD Pragma                -- ^ @{ {\-\# INLINE [1] foo \#-\} }@
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index 39d1c04c3f..d5581297f2 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -1,5 +1,9 @@
 # Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell)
 
+## 2.19.0.0
+
+  * Add `DefaultD` constructor to support Haskell `default` declarations.
+
 ## 2.18.0.0
   * The types of `ConP` and `conP` have been changed to allow for an additional list
     of type applications preceding the argument patterns.
diff --git a/testsuite/tests/th/T19373.hs b/testsuite/tests/th/T19373.hs
new file mode 100644
index 0000000000..0e29f71544
--- /dev/null
+++ b/testsuite/tests/th/T19373.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+
+import Data.Monoid (Sum)
+import Language.Haskell.TH
+
+dec :: DecsQ
+dec = [d| default (Int, Double)
+        |]
+
+$([d| default (Integer, Sum Integer)
+        |])
+
+main = runQ dec >>= putStrLn . pprint
+       >> print (4 <> 8)
diff --git a/testsuite/tests/th/T19373.stdout b/testsuite/tests/th/T19373.stdout
new file mode 100644
index 0000000000..4dbafb7ef2
--- /dev/null
+++ b/testsuite/tests/th/T19373.stdout
@@ -0,0 +1,2 @@
+default (GHC.Types.Int, GHC.Types.Double)
+Sum {getSum = 12}
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 90ca816cd8..a19ad09ec9 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -524,6 +524,7 @@ test('T18612', normal, compile, [''])
 test('T18740c', normal, compile_fail, [''])
 test('T18740d', normal, compile_fail, [''])
 test('T19363', normal, compile_and_run, [''])
+test('T19373', normal, compile_and_run, [''])
 test('T19377', normal, compile, [''])
 test('T17804', normal, compile, [''])
 test('T19470', only_ways(['ghci']), ghci_script, ['T19470.script'])