Disallow nonlinear fields in Template Haskell (#18378)wip/T20183

11 files changed, 54 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]
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 8f8ddaf1e8..44b33a217b 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -2545,6 +2545,10 @@ data DecidedStrictness = DecidedLazy
 --   @
 --
 --   In @MkBar@, 'ForallC' will quantify @a@, @b@, and @c@.
+--
+-- Multiplicity annotations for data types are currently not supported
+-- in Template Haskell (i.e. all fields represented by Template Haskell
+-- will be linear).
 data Con = NormalC Name [BangType]       -- ^ @C Int a@
          | RecC Name [VarBangType]       -- ^ @C { v :: Int, w :: a }@
          | InfixC BangType Name BangType -- ^ @Int :+ a@
diff --git a/testsuite/tests/linear/should_compile/LinearTH4.hs b/testsuite/tests/linear/should_compile/LinearTH4.hs
new file mode 100644
index 0000000000..3061e77ce6
--- /dev/null
+++ b/testsuite/tests/linear/should_compile/LinearTH4.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LinearTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
+module LinearTH4 where
+
+$([d| data T where { MkT :: Int %1 -> T } |])
diff --git a/testsuite/tests/linear/should_compile/all.T b/testsuite/tests/linear/should_compile/all.T
index 77cd913b81..b9d4215793 100644
--- a/testsuite/tests/linear/should_compile/all.T
+++ b/testsuite/tests/linear/should_compile/all.T
@@ -33,6 +33,7 @@ test('LinearLetRec', expect_broken(18694), compile, ['-O -dlinear-core-lint'])
 test('LinearTH1', normal, compile, [''])
 test('LinearTH2', normal, compile, [''])
 test('LinearTH3', normal, compile, [''])
+test('LinearTH4', normal, compile, [''])
 test('LinearHole', normal, compile, [''])
 test('T18731', normal, compile, [''])
 test('T19400', unless(compiler_debugged(), skip), compile, [''])
diff --git a/testsuite/tests/linear/should_fail/LinearTHFail2.hs b/testsuite/tests/linear/should_fail/LinearTHFail2.hs
new file mode 100644
index 0000000000..f5613be0c4
--- /dev/null
+++ b/testsuite/tests/linear/should_fail/LinearTHFail2.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LinearTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module LinearTHFail2 where
+
+$([d| data T where { MkT :: Int -> T } |])
diff --git a/testsuite/tests/linear/should_fail/LinearTHFail2.stderr b/testsuite/tests/linear/should_fail/LinearTHFail2.stderr
new file mode 100644
index 0000000000..cbc3ce4b35
--- /dev/null
+++ b/testsuite/tests/linear/should_fail/LinearTHFail2.stderr
@@ -0,0 +1,3 @@
+
+LinearTHFail2.hs:7:3: error:
+    Non-linear fields in data constructors not (yet) handled by Template Haskell
diff --git a/testsuite/tests/linear/should_fail/LinearTHFail3.hs b/testsuite/tests/linear/should_fail/LinearTHFail3.hs
new file mode 100644
index 0000000000..eef6c02b83
--- /dev/null
+++ b/testsuite/tests/linear/should_fail/LinearTHFail3.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LinearTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module LinearTHFail3 where
+
+$([d| data T where { MkT :: Int %m -> T } |])
diff --git a/testsuite/tests/linear/should_fail/LinearTHFail3.stderr b/testsuite/tests/linear/should_fail/LinearTHFail3.stderr
new file mode 100644
index 0000000000..a61e401810
--- /dev/null
+++ b/testsuite/tests/linear/should_fail/LinearTHFail3.stderr
@@ -0,0 +1,3 @@
+
+LinearTHFail3.hs:7:3: error:
+    Non-linear fields in data constructors not (yet) handled by Template Haskell
diff --git a/testsuite/tests/linear/should_fail/all.T b/testsuite/tests/linear/should_fail/all.T
index a831011cef..92b82a2037 100644
--- a/testsuite/tests/linear/should_fail/all.T
+++ b/testsuite/tests/linear/should_fail/all.T
@@ -32,6 +32,8 @@ test('LinearIf', normal, compile_fail, [''])
 test('LinearPatternGuardWildcard', normal, compile_fail, [''])
 test('LinearFFI', normal, compile_fail, [''])
 test('LinearTHFail', normal, compile_fail, [''])
+test('LinearTHFail2', normal, compile_fail, [''])
+test('LinearTHFail3', normal, compile_fail, [''])
 test('T18888', normal, compile_fail, [''])
 test('T18888_datakinds', normal, compile_fail, [''])
 test('T19120', normal, compile_fail, [''])