Disallow nonlinear fields in Template Haskell (#18378)

3 files changed, 21 insertions, 1 deletions

diff --git a/compiler/GHC/HsToCore/Errors/Ppr.hs b/compiler/GHC/HsToCore/Errors/Ppr.hs
index c8bda5562b..c5f3aca1ec 100644
--- a/compiler/GHC/HsToCore/Errors/Ppr.hs
+++ b/compiler/GHC/HsToCore/Errors/Ppr.hs
@@ -165,6 +165,8 @@ instance Diagnostic DsMessage where
                     text "Pragma for declaration of" <+> ppr decl
              ThSplicesWithinDeclBrackets
                -> mkMsg "Splices within declaration brackets" empty
+             ThNonLinearDataCon
+               -> mkMsg "Non-linear fields in data constructors" empty
          where
            mkMsg what doc =
              mkSimpleDecorated $
diff --git a/compiler/GHC/HsToCore/Errors/Types.hs b/compiler/GHC/HsToCore/Errors/Types.hs
index 9a98e764e2..1747ae7914 100644
--- a/compiler/GHC/HsToCore/Errors/Types.hs
+++ b/compiler/GHC/HsToCore/Errors/Types.hs
@@ -192,6 +192,7 @@ data ThRejectionReason
   | ThHaddockDocumentation
   | ThWarningAndDeprecationPragmas [LIdP GhcRn]
   | ThSplicesWithinDeclBrackets
+  | ThNonLinearDataCon
 
 data NegLiteralExtEnabled
   = YesUsingNegLiterals
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index f68a561957..ebda80c142 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -2664,6 +2664,7 @@ repH98DataCon con details
              arg_tys <- repPrefixConArgs ps
              rep2 normalCName [unC con', unC arg_tys]
            InfixCon st1 st2 -> do
+             verifyLinearConstructors [st1, st2]
              arg1 <- repBangTy (hsScaledThing st1)
              arg2 <- repBangTy (hsScaledThing st2)
              rep2 infixCName [unC arg1, unC con', unC arg2]
@@ -2688,10 +2689,26 @@ repGadtDataCons cons details res_ty
              rep2 recGadtCName [unC (nonEmptyCoreList cons'), unC arg_vtys,
                                 unC res_ty']
 
+-- TH currently only supports linear constructors.
+-- We also accept the (->) arrow when -XLinearTypes is off, because this
+-- denotes a linear field.
+-- This check is not performed in repRecConArgs, since the GADT record
+-- syntax currently does not have a way to mark fields as nonlinear.
+verifyLinearConstructors :: [HsScaled GhcRn (LHsType GhcRn)] -> MetaM ()
+verifyLinearConstructors ps = do
+  linear <- lift $ xoptM LangExt.LinearTypes
+  let allGood = all (\st -> case hsMult st of
+                              HsUnrestrictedArrow _ -> not linear
+                              HsLinearArrow _       -> True
+                              _                     -> False) ps
+  unless allGood $ notHandled ThNonLinearDataCon
+
 -- Desugar the arguments in a data constructor declared with prefix syntax.
 repPrefixConArgs :: [HsScaled GhcRn (LHsType GhcRn)]
                  -> MetaM (Core [M TH.BangType])
-repPrefixConArgs ps = repListM bangTypeTyConName repBangTy (map hsScaledThing ps)
+repPrefixConArgs ps = do
+  verifyLinearConstructors ps
+  repListM bangTypeTyConName repBangTy (map hsScaledThing ps)
 
 -- Desugar the arguments in a data constructor declared with record syntax.
 repRecConArgs :: LocatedL [LConDeclField GhcRn]