template-haskell: Add support for default declarations

Fixes #19373

5 files changed, 17 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