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

4 files changed, 63 insertions, 2 deletions

diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index 8507c0d7ff..442d287ed8 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -975,7 +975,7 @@ tcPatSynPat :: PatEnv -> Located Name -> PatSyn
             -> Scaled ExpSigmaType         -- Type of the pattern
             -> HsConPatDetails GhcRn -> TcM a
             -> TcM (Pat GhcTc, a)
-tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside
+tcPatSynPat penv (L con_span con_name) pat_syn pat_ty arg_pats thing_inside
   = do  { let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, ty) = patSynSig pat_syn
 
         ; (subst, univ_tvs') <- newMetaTyVars univ_tvs
@@ -1010,7 +1010,9 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside
                             LamPat mc -> PatSkol (PatSynCon pat_syn) mc
                             LetPat {} -> UnkSkol -- Doesn't matter
 
-        ; req_wrap <- instCall PatOrigin (mkTyVarTys univ_tvs') req_theta'
+        ; req_wrap <- instCall (OccurrenceOf con_name) (mkTyVarTys univ_tvs') req_theta'
+                      -- Origin (OccurrenceOf con_name):
+                      -- see Note [Call-stack tracing of pattern synonyms]
         ; traceTc "instCall" (ppr req_wrap)
 
         ; traceTc "checkConstraints {" Outputable.empty
@@ -1032,6 +1034,29 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside
         ; pat_ty <- readExpType (scaledThing pat_ty)
         ; return (mkHsWrapPat (wrap <.> mult_wrap) res_pat pat_ty, res) }
 
+{- Note [Call-stack tracing of pattern synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   f :: HasCallStack => blah
+
+   pattern Annotated :: HasCallStack => (CallStack, a) -> a
+   pattern Annotated x <- (f -> x)
+
+When we pattern-match against `Annotated` we will call `f`, and must
+pass a call-stack.  We may want `Annotated` itself to propagate the call
+stack, so we give it a HasCallStack constraint too.  But then we expect
+to see `Annotated` in the call stack.
+
+This is achieve easily, but a bit trickily.  When we instantiate
+Annotated's "required" constraints, in tcPatSynPat, give them a
+CtOrigin of (OccurrenceOf "Annotated"). That way the special magic
+in GHC.Tc.Solver.Canonical.canClassNC which deals with CallStack
+constraints will kick in: that logic only fires on constraints
+whose Origin is (OccurrenceOf f).
+
+See also Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
+and Note [Solving CallStack constraints] in GHC.Tc.Solver.Monad
+-}
 ----------------------------
 -- | Convenient wrapper for calling a matchExpectedXXX function
 matchExpectedPatTy :: (TcRhoType -> TcM (TcCoercionN, a))
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, [''])