diff options
-rw-r--r-- | compiler/GHC/HsToCore/Errors/Ppr.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Errors/Types.hs | 1 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Quote.hs | 19 | ||||
-rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Syntax.hs | 4 | ||||
-rw-r--r-- | testsuite/tests/linear/should_compile/LinearTH4.hs | 6 | ||||
-rw-r--r-- | testsuite/tests/linear/should_compile/all.T | 1 | ||||
-rw-r--r-- | testsuite/tests/linear/should_fail/LinearTHFail2.hs | 7 | ||||
-rw-r--r-- | testsuite/tests/linear/should_fail/LinearTHFail2.stderr | 3 | ||||
-rw-r--r-- | testsuite/tests/linear/should_fail/LinearTHFail3.hs | 7 | ||||
-rw-r--r-- | testsuite/tests/linear/should_fail/LinearTHFail3.stderr | 3 | ||||
-rw-r--r-- | testsuite/tests/linear/should_fail/all.T | 2 |
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, ['']) |