diff options
author | romes <rodrigo.m.mesquita@gmail.com> | 2023-02-28 15:55:55 +0000 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2023-03-01 04:19:10 -0500 |
commit | 86f240ca956f633c20a61872ec44de9e21266624 (patch) | |
tree | f9a4cbb8d39285d2d758f59f5cc04a8615298e42 | |
parent | cf118e2fac04b79cc7fa63cff0552190c3885bb9 (diff) | |
download | haskell-86f240ca956f633c20a61872ec44de9e21266624.tar.gz |
fix: Consider strictness annotation in rep_bind
Fixes #23036
-rw-r--r-- | compiler/GHC/HsToCore/Quote.hs | 12 | ||||
-rw-r--r-- | testsuite/tests/th/T23036.hs | 16 | ||||
-rw-r--r-- | testsuite/tests/th/T23036.stderr | 18 | ||||
-rw-r--r-- | testsuite/tests/th/all.T | 1 |
4 files changed, 44 insertions, 3 deletions
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 16dc9a8603..8463e9f739 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -1899,12 +1899,18 @@ rep_bind (L loc (FunBind fun_matches = MG { mg_alts = (L _ [L _ (Match { m_pats = [] - , m_grhss = GRHSs _ guards wheres } - )]) } })) + , m_grhss = GRHSs _ guards wheres + -- For a variable declaration I'm pretty + -- sure we always have a FunRhs + , m_ctxt = FunRhs { mc_strictness = strictessAnn } + } )]) } })) = do { (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; fn' <- lookupNBinder fn - ; p <- repPvar fn' + ; p <- repPvar fn' >>= case strictessAnn of + SrcLazy -> repPtilde + SrcStrict -> repPbang + NoSrcStrict -> pure ; ans <- repVal p guardcore wherecore ; ans' <- wrapGenSyms ss ans ; return (locA loc, ans') } diff --git a/testsuite/tests/th/T23036.hs b/testsuite/tests/th/T23036.hs new file mode 100644 index 0000000000..f841ede059 --- /dev/null +++ b/testsuite/tests/th/T23036.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TemplateHaskell #-} +module T23036 where + +import Language.Haskell.TH + +a, b, c :: () +a = $([|let x = undefined in ()|]) +b = $([|let !x = undefined in ()|]) +c = $([|let ~x = undefined in ()|]) + +-- Test strictness annotations are also correctly handled in function and pattern binders +d, e, f:: () +d = $([|let !(x,y) = undefined in ()|]) +e = $([|let (!x,y,~z) = undefined in ()|]) +f = $([|let f !x ~y z = undefined in ()|]) + diff --git a/testsuite/tests/th/T23036.stderr b/testsuite/tests/th/T23036.stderr new file mode 100644 index 0000000000..1082971f77 --- /dev/null +++ b/testsuite/tests/th/T23036.stderr @@ -0,0 +1,18 @@ +T23036.hs:7:6-34: Splicing expression + [| let x = undefined in () |] ======> let x = undefined in () +T23036.hs:8:6-35: Splicing expression + [| let !x = undefined in () |] ======> let !x = undefined in () +T23036.hs:9:6-35: Splicing expression + [| let ~x = undefined in () |] ======> let ~x = undefined in () +T23036.hs:13:6-39: Splicing expression + [| let !(x, y) = undefined in () |] + ======> + let !(x, y) = undefined in () +T23036.hs:14:6-42: Splicing expression + [| let (!x, y, ~z) = undefined in () |] + ======> + let (!x, y, ~z) = undefined in () +T23036.hs:15:6-42: Splicing expression + [| let f !x ~y z = undefined in () |] + ======> + let f !x ~y z = undefined in () diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 2b30e752aa..a4f948bc76 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -559,3 +559,4 @@ test('T22784', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('T22818', normal, compile, ['-v0']) test('T22819', normal, compile, ['-v0']) test('TH_fun_par', normal, compile, ['']) +test('T23036', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) |