[commit: ghc] ghc-8.0: Default non-canonical CallStack constraints (38dc961)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/38dc961bf8459577b8a57d5e04a90b470c79fe0c/ghc

>---------------------------------------------------------------

commit 38dc961bf8459577b8a57d5e04a90b470c79fe0c
Author: Eric Seidel <gridaphobe at gmail.com>
Date:   Fri Jan 22 12:45:53 2016 +0100

    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
    
    (cherry picked from commit 835a2a24a605f8e458f57c71aa67e9983593b5e4)


>---------------------------------------------------------------

38dc961bf8459577b8a57d5e04a90b470c79fe0c
 compiler/typecheck/TcInteract.hs                          |  2 +-
 compiler/typecheck/TcRnTypes.hs                           | 10 +++++-----
 compiler/typecheck/TcSimplify.hs                          |  7 ++++---
 testsuite/tests/typecheck/should_compile/T11462.hs        |  6 ++++++
 testsuite/tests/typecheck/should_compile/T11462_Plugin.hs | 14 ++++++++++++++
 testsuite/tests/typecheck/should_compile/all.T            |  7 +++++++
 6 files changed, 37 insertions(+), 9 deletions(-)

diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index cc2148f..d326966 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 8bfc8c7..9edc6a7 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 81ea3aa..47d4009 100644
--- a/compiler/typecheck/TcSimplify.hs
+++ b/compiler/typecheck/TcSimplify.hs
@@ -181,9 +181,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
diff --git a/testsuite/tests/typecheck/should_compile/T11462.hs b/testsuite/tests/typecheck/should_compile/T11462.hs
new file mode 100644
index 0000000..a9d7815
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T11462.hs
@@ -0,0 +1,6 @@
+{-# OPTIONS_GHC -fplugin=T11462_Plugin #-}
+
+module T11462 where
+
+impossible :: a
+impossible = undefined
diff --git a/testsuite/tests/typecheck/should_compile/T11462_Plugin.hs b/testsuite/tests/typecheck/should_compile/T11462_Plugin.hs
new file mode 100644
index 0000000..5d98395
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T11462_Plugin.hs
@@ -0,0 +1,14 @@
+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 ()
+  }
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 46ab53b..90f42bf 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/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'])