Commit 835a2a24 authored by Eric Seidel's avatar Eric Seidel Committed by Ben Gamari
Browse files

Default non-canonical CallStack constraints

Test Plan: `make test TEST=T11462`

Reviewers: austin, bgamari, simonpj

Reviewed By: simonpj

Subscribers: thomie

Projects: #ghc

Differential Revision: https://phabricator.haskell.org/D1804

GHC Trac Issues: #11462
parent adb721bd
......@@ -680,7 +680,7 @@ interactIrred _ wi = pprPanic "interactIrred" (ppr wi)
interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct)
interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys })
| isWanted ev_w
, Just ip_name <- isCallStackCt workItem
, Just ip_name <- isCallStackDict cls tys
, OccurrenceOf func <- ctLocOrigin (ctEvLoc ev_w)
-- If we're given a CallStack constraint that arose from a function
-- call, we need to push the current call-site onto the stack instead
......
......@@ -69,7 +69,7 @@ module TcRnTypes(
isCDictCan_Maybe, isCFunEqCan_maybe,
isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt,
isGivenCt, isHoleCt, isOutOfScopeCt, isExprHoleCt, isTypeHoleCt,
isUserTypeErrorCt, isCallStackCt, getUserTypeErrorMsg,
isUserTypeErrorCt, isCallStackDict, getUserTypeErrorMsg,
ctEvidence, ctLoc, setCtLoc, ctPred, ctFlavour, ctEqRel, ctOrigin,
mkTcEqPredLikeEv,
mkNonCanonical, mkNonCanonicalCt,
......@@ -1756,18 +1756,18 @@ isUserTypeErrorCt ct = case getUserTypeErrorMsg ct of
Just _ -> True
_ -> False
-- | Is the constraint for an Implicit CallStack
-- | Are we looking at an Implicit CallStack
-- (i.e. @IP "name" CallStack@)?
--
-- If so, returns @Just "name"@.
isCallStackCt :: Ct -> Maybe FastString
isCallStackCt CDictCan { cc_class = cls, cc_tyargs = tys }
isCallStackDict :: Class -> [Type] -> Maybe FastString
isCallStackDict cls tys
| cls `hasKey` ipClassKey
, [ip_name_ty, ty] <- tys
, Just (tc, _) <- splitTyConApp_maybe ty
, tc `hasKey` callStackTyConKey
= isStrLitTy ip_name_ty
isCallStackCt _
isCallStackDict _ _
= Nothing
instance Outputable Ct where
......
......@@ -173,9 +173,10 @@ defaultCallStacks wanteds
wanteds <- defaultCallStacks (ic_wanted implic)
return (implic { ic_wanted = wanteds })
defaultCallStack ct@(CDictCan { cc_ev = ev_w })
| Just _ <- isCallStackCt ct
= do { solveCallStack ev_w EvCsEmpty
defaultCallStack ct
| Just (cls, tys) <- getClassPredTys_maybe (ctPred ct)
, Just _ <- isCallStackDict cls tys
= do { solveCallStack (cc_ev ct) EvCsEmpty
; return Nothing }
defaultCallStack ct
......
{-# OPTIONS_GHC -fplugin=T11462_Plugin #-}
module T11462 where
impossible :: a
impossible = undefined
module T11462_Plugin(plugin) where
import TcRnMonad ( TcPlugin(..), TcPluginResult(..) )
import Plugins ( defaultPlugin, Plugin(..), CommandLineOption )
plugin :: Plugin
plugin = defaultPlugin { tcPlugin = Just . thePlugin }
thePlugin :: [CommandLineOption] -> TcPlugin
thePlugin opts = TcPlugin
{ tcPluginInit = return ()
, tcPluginSolve = \_ _ _ _ -> return $ TcPluginOk [] []
, tcPluginStop = \_ -> return ()
}
......@@ -489,3 +489,10 @@ test('T10592', normal, compile, [''])
test('T11305', normal, compile, [''])
test('T11254', normal, compile, [''])
test('T11379', normal, compile, [''])
test('T11462',
[extra_clean(['T11462_Plugin.hi', 'T11462_Plugin.o']),
unless(have_dynamic(), expect_broken(10301))],
multi_compile,
['', [('T11462_Plugin.hs', '-package ghc'),
('T11462.hs', '')],
'-dynamic'])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment