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

compiler/typecheck/TcInteract.hs

@@ -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

compiler/typecheck/TcRnTypes.hs

@@ -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

compiler/typecheck/TcSimplify.hs

@@ -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

testsuite/tests/typecheck/should_compile/T11462.hs

+{-# OPTIONS_GHC -fplugin=T11462_Plugin #-}
+
+module T11462 where
+
+impossible :: a
+impossible = undefined

testsuite/tests/typecheck/should_compile/T11462_Plugin.hs

+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 ()
+  }

testsuite/tests/typecheck/should_compile/all.T

@@ -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'])