Make pattern synonyms play with CallStack

This small patch makes pattern synonyms play nicely with CallStack
constraints, using logic explained in GHC.Tc.Gen.Pat
Note [Call-stack tracing of pattern synonyms]

Fixes #19289

3 files changed, 36 insertions, 0 deletions

diff --git a/testsuite/tests/deSugar/should_run/T19289.hs b/testsuite/tests/deSugar/should_run/T19289.hs
new file mode 100644
index 0000000000..92f512cddc
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/T19289.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Main where
+
+import           GHC.Stack
+
+-- | Some useless pattern synonym that groups a value with the call stack using
+-- view patterns. In the real code base where I'm using this this pattern
+-- synonym generates part of an abstract syntax tree instead.
+pattern Annotated :: HasCallStack => (CallStack, a) -> a
+pattern Annotated x <- (addCallStack -> x)
+  where
+    Annotated (_, x) = x
+
+-- | Used in 'SomeSynonym' to pair a value with the current call stack, since
+-- you cannot add the 'HasCallStack' constraint to a lambda (in the real use
+-- case we would be calling a function that does something with the call stack
+-- here).
+addCallStack :: HasCallStack => a -> (CallStack, a)
+addCallStack x = (callStack, x)
+
+someAnnotatedValue :: (CallStack, Int)
+someAnnotatedValue = let Annotated annotated = 10 in annotated
+
+
+main :: IO ()
+main = do
+    let (stack, _) = someAnnotatedValue
+    putStrLn "No lines from within 'someAnnotatedValue' (i.e. line 24) will show up here:"
+    putStrLn $ prettyCallStack stack
diff --git a/testsuite/tests/deSugar/should_run/T19289.stdout b/testsuite/tests/deSugar/should_run/T19289.stdout
new file mode 100644
index 0000000000..3244cc3f47
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/T19289.stdout
@@ -0,0 +1,4 @@
+No lines from within 'someAnnotatedValue' (i.e. line 24) will show up here:
+CallStack (from HasCallStack):
+  addCallStack, called at T19289.hs:12:25 in main:Main
+  Annotated, called at T19289.hs:24:26 in main:Main
diff --git a/testsuite/tests/deSugar/should_run/all.T b/testsuite/tests/deSugar/should_run/all.T
index 406cb24863..9d43f94b40 100644
--- a/testsuite/tests/deSugar/should_run/all.T
+++ b/testsuite/tests/deSugar/should_run/all.T
@@ -70,3 +70,4 @@ test('T18172', [], ghci_script, ['T18172.script'])
 
 test('DsDoExprFailMsg', exit_code(1), compile_and_run, [''])
 test('DsMonadCompFailMsg', exit_code(1), compile_and_run, [''])
+test('T19289', normal, compile_and_run, [''])