diff options
| -rw-r--r-- | compiler/GHC/Tc/Gen/Pat.hs | 29 | ||||
| -rw-r--r-- | testsuite/tests/deSugar/should_run/T19289.hs | 31 | ||||
| -rw-r--r-- | testsuite/tests/deSugar/should_run/T19289.stdout | 4 | ||||
| -rw-r--r-- | testsuite/tests/deSugar/should_run/all.T | 1 |
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, ['']) |