diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2016-08-17 14:35:19 +0100 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2016-08-17 14:38:52 +0100 |
commit | f352e5cd7bb629fe0ca3b913bfbe7bee43d62f3a (patch) | |
tree | 8de467c54198b69cff4e77968365380de75766fc | |
parent | efc0372a157eadeee58bbada77c64d53590e04af (diff) | |
download | haskell-f352e5cd7bb629fe0ca3b913bfbe7bee43d62f3a.tar.gz |
Keep the bindings local during defaultCallStacks
defaultCallStacks generates evidence bindings for call stacks,
but wasn't setting the binding site correctly. As a result
they were simply discarded in the case of pattern synonyms,
giving rise to Trac #12489.
The fix is easy; and I added an ASSERT to catch the error earlier.
-rw-r--r-- | compiler/typecheck/TcPatSyn.hs | 4 | ||||
-rw-r--r-- | compiler/typecheck/TcSMonad.hs | 6 | ||||
-rw-r--r-- | compiler/typecheck/TcSimplify.hs | 9 | ||||
-rw-r--r-- | testsuite/tests/patsyn/should_compile/T12489.hs | 5 | ||||
-rw-r--r-- | testsuite/tests/patsyn/should_compile/all.T | 1 |
5 files changed, 20 insertions, 5 deletions
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 171c1adf55..81a202909f 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -176,8 +176,10 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details -- Solve the constraints now, because we are about to make a PatSyn, -- which should not contain unification variables and the like (Trac #10997) + ; empty_binds <- simplifyTop (mkImplicWC implics) + -- Since all the inputs are implications the returned bindings will be empty - ; _ <- simplifyTop (mkImplicWC implics) + ; MASSERT2( isEmptyBag empty_binds, ppr empty_binds ) -- ToDo: in the bidirectional case, check that the ex_tvs' are all distinct -- Otherwise we may get a type error when typechecking the builder, diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index 4c854c204d..29837a9d69 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -16,7 +16,7 @@ module TcSMonad ( TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds, failTcS, warnTcS, addErrTcS, runTcSEqualities, - nestTcS, nestImplicTcS, + nestTcS, nestImplicTcS, setEvBindsTcS, runTcPluginTcS, addUsedGREs, deferTcSForAllEq, @@ -2487,6 +2487,10 @@ checkForCyclicBinds ev_binds -- Note [Deterministic SCC] in Digraph. #endif +setEvBindsTcS :: Maybe EvBindsVar -> TcS a -> TcS a +setEvBindsTcS m_ref (TcS thing_inside) + = TcS $ \ env -> thing_inside (env { tcs_ev_binds = m_ref }) + nestImplicTcS :: Maybe EvBindsVar -> TyCoVarSet -- bound in this implication -> TcLevel -> TcS a -> TcS (a, TyCoVarSet) -- also returns any vars used when filling diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs index a2e306df3b..6ebf9f1f85 100644 --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -170,9 +170,12 @@ defaultCallStacks wanteds handle_simples simples = catBagMaybes <$> mapBagM defaultCallStack simples - handle_implic implic = do - wanteds <- defaultCallStacks (ic_wanted implic) - return (implic { ic_wanted = wanteds }) + handle_implic implic + = do { wanteds <- setEvBindsTcS (ic_binds implic) $ + -- defaultCallStack sets a binding, so + -- we must set the correct binding group + defaultCallStacks (ic_wanted implic) + ; return (implic { ic_wanted = wanteds }) } defaultCallStack ct | Just _ <- isCallStackPred (ctPred ct) diff --git a/testsuite/tests/patsyn/should_compile/T12489.hs b/testsuite/tests/patsyn/should_compile/T12489.hs new file mode 100644 index 0000000000..205799b608 --- /dev/null +++ b/testsuite/tests/patsyn/should_compile/T12489.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} + +module T12489 where +pattern P :: a -> b +pattern P a <- (undefined -> a) diff --git a/testsuite/tests/patsyn/should_compile/all.T b/testsuite/tests/patsyn/should_compile/all.T index 78320c7713..7551eb91dd 100644 --- a/testsuite/tests/patsyn/should_compile/all.T +++ b/testsuite/tests/patsyn/should_compile/all.T @@ -58,3 +58,4 @@ test('T12094', normal, compile, ['']) test('T11977', normal, compile, ['']) test('T12108', normal, compile, ['']) test('T12484', normal, compile, ['']) +test('T12489', normal, compile, ['']) |