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

3 files changed, 10 insertions, 9 deletions

diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index 1853cb322f..86cc8b3ee9 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/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
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 60abfca12e..07037c706f 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/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
diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
index 9ea3d915fd..499b53a7da 100644
--- a/compiler/typecheck/TcSimplify.hs
+++ b/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