diff options
| author | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2020-09-28 01:38:55 +0200 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-10-05 13:59:33 -0400 |
| commit | 802b5e6fdd6dfc58396a9dca1903dc5a1d6634ca (patch) | |
| tree | 4d55590d9c88a456b2f4c9365e5e501b8db91367 | |
| parent | bc5de347bccd7a2691a9e4b927ab80acb7e15991 (diff) | |
| download | haskell-802b5e6fdd6dfc58396a9dca1903dc5a1d6634ca.tar.gz | |
Fix linear types in TH splices (#18465)
| -rw-r--r-- | compiler/GHC/Tc/Gen/Splice.hs | 5 | ||||
| -rw-r--r-- | testsuite/tests/linear/should_fail/LinearTHFail.hs | 11 | ||||
| -rw-r--r-- | testsuite/tests/linear/should_fail/LinearTHFail.stderr | 13 | ||||
| -rw-r--r-- | testsuite/tests/linear/should_fail/all.T | 1 |
4 files changed, 29 insertions, 1 deletions
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index 5871eb99ea..54e736fda5 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -192,6 +192,8 @@ tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty -- Throw away the typechecked expression but return its type. -- We'll typecheck it again when we splice it in somewhere ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var wrapper)) $ + tcScalingUsage Many $ + -- Scale by Many, TH lifting is currently nonlinear (#18465) tcInferRhoNC expr -- NC for no context; tcBracket does that ; let rep = getRuntimeRep expr_ty @@ -289,7 +291,8 @@ tcPendingSplice m_var (PendingRnSplice flavour splice_name expr) = do { meta_ty <- tcMetaTy meta_ty_name -- Expected type of splice, e.g. m Exp ; let expected_type = mkAppTy m_var meta_ty - ; expr' <- tcCheckPolyExpr expr expected_type + ; expr' <- tcScalingUsage Many $ tcCheckPolyExpr expr expected_type + -- Scale by Many, TH lifting is currently nonlinear (#18465) ; return (PendingTcSplice splice_name expr') } where meta_ty_name = case flavour of diff --git a/testsuite/tests/linear/should_fail/LinearTHFail.hs b/testsuite/tests/linear/should_fail/LinearTHFail.hs new file mode 100644 index 0000000000..42878e5dad --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearTHFail.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskellQuotes, LinearTypes #-} + +module LinearTHFail where -- #18465 + +import Language.Haskell.TH + +f :: Q Exp %1 -> Q Exp +f x = [| Just $x |] + +g :: Code Q a %1 -> Code Q (Maybe a) +g x = [|| Just $$x ||] diff --git a/testsuite/tests/linear/should_fail/LinearTHFail.stderr b/testsuite/tests/linear/should_fail/LinearTHFail.stderr new file mode 100644 index 0000000000..58537e811e --- /dev/null +++ b/testsuite/tests/linear/should_fail/LinearTHFail.stderr @@ -0,0 +1,13 @@ + +LinearTHFail.hs:8:3: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘x’ + • In an equation for ‘f’: + f x + = [| Just $x |] + pending(rn) [<splice, x>] + +LinearTHFail.hs:11:3: error: + • Couldn't match type ‘'Many’ with ‘'One’ + arising from multiplicity of ‘x’ + • In an equation for ‘g’: g x = [|| Just $$x ||] diff --git a/testsuite/tests/linear/should_fail/all.T b/testsuite/tests/linear/should_fail/all.T index 272e9e2a35..5fa6fdb18f 100644 --- a/testsuite/tests/linear/should_fail/all.T +++ b/testsuite/tests/linear/should_fail/all.T @@ -30,3 +30,4 @@ test('LinearSequenceExpr', normal, compile_fail, ['']) test('LinearIf', normal, compile_fail, ['']) test('LinearPatternGuardWildcard', normal, compile_fail, ['']) test('LinearFFI', normal, compile_fail, ['']) +test('LinearTHFail', normal, compile_fail, ['']) |