Don't panic on 'no skolem info' and add failing testswip/no-skolem-panic

11 files changed, 117 insertions, 3 deletions

diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index c26dce5161..766b88408d 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -74,6 +74,7 @@ import GHC.Utils.FV ( fvVarList, unionFV )
 
 import GHC.Data.Bag
 import GHC.Data.FastString
+import GHC.Utils.Trace (pprTraceUserWarning)
 import GHC.Data.List.SetOps ( equivClasses )
 import GHC.Data.Maybe
 import qualified GHC.Data.Strict as Strict
@@ -2944,8 +2945,11 @@ pprSkols ctxt tvs
   = vcat (map pp_one (getSkolemInfo (cec_encl ctxt) tvs))
   where
     pp_one (UnkSkol, tvs)
-      = hang (pprQuotedList tvs)
-           2 (is_or_are tvs "an" "unknown")
+      = vcat [ hang (pprQuotedList tvs)
+                 2 (is_or_are tvs "a" "(rigid, skolem)")
+             , nest 2 (text "of unknown origin")
+             , nest 2 (text "bound at" <+> ppr (foldr1 combineSrcSpans (map getSrcSpan tvs)))
+             ]
     pp_one (RuntimeUnkSkol, tvs)
       = hang (pprQuotedList tvs)
            2 (is_or_are tvs "an" "unknown runtime")
@@ -2979,7 +2983,13 @@ getSkolemInfo _ []
 
 getSkolemInfo [] tvs
   | all isRuntimeUnkSkol tvs = [(RuntimeUnkSkol, tvs)]        -- #14628
-  | otherwise = pprPanic "No skolem info:" (ppr tvs)
+  | otherwise = -- See https://gitlab.haskell.org/ghc/ghc/-/issues?label_name[]=No%20skolem%20info
+      pprTraceUserWarning msg [(UnkSkol,tvs)]
+  where
+    msg = text "No skolem info - we could not find the origin of the following variables" <+> ppr tvs
+       $$ text "This should not happen, please report it as a bug following the instructions at:"
+       $$ text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug"
+
 
 getSkolemInfo (implic:implics) tvs
   | null tvs_here =                            getSkolemInfo implics tvs
diff --git a/compiler/GHC/Utils/Trace.hs b/compiler/GHC/Utils/Trace.hs
index ac29cd6fd8..5da6e6e5d9 100644
--- a/compiler/GHC/Utils/Trace.hs
+++ b/compiler/GHC/Utils/Trace.hs
@@ -7,6 +7,7 @@ module GHC.Utils.Trace
   , pprSTrace
   , pprTraceException
   , warnPprTrace
+  , pprTraceUserWarning
   , trace
   )
 where
@@ -71,6 +72,15 @@ warnPprTrace True   msg x
                     (msg $$ withFrozenCallStack traceCallStackDoc )
                     x
 
+-- | For when we want to show the user a non-fatal WARNING so that they can
+-- report a GHC bug, but don't want to panic.
+pprTraceUserWarning :: HasCallStack => SDoc -> a -> a
+pprTraceUserWarning msg x
+  | unsafeHasNoDebugOutput = x
+  | otherwise = pprDebugAndThen defaultSDocContext trace (text "WARNING:")
+                    (msg $$ withFrozenCallStack traceCallStackDoc )
+                    x
+
 traceCallStackDoc :: HasCallStack => SDoc
 traceCallStackDoc =
     hang (text "Call stack:")
diff --git a/testsuite/tests/ado/T16135.hs b/testsuite/tests/ado/T16135.hs
new file mode 100644
index 0000000000..ff8cc8588e
--- /dev/null
+++ b/testsuite/tests/ado/T16135.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE ExistentialQuantification, ApplicativeDo #-}
+
+module Bug where
+
+data T f = forall a. MkT (f a)
+
+runf :: forall f. Functor f => IO (T f)
+runf = do
+    return ()
+    MkT fa <- runf
+    return $ MkT fa
diff --git a/testsuite/tests/ado/all.T b/testsuite/tests/ado/all.T
index 8c07539965..86e18998b0 100644
--- a/testsuite/tests/ado/all.T
+++ b/testsuite/tests/ado/all.T
@@ -18,3 +18,4 @@ test('T14163', normal, compile_and_run, [''])
 test('T15344', normal, compile_and_run, [''])
 test('T16628', normal, compile_fail, [''])
 test('T17835', normal, compile, [''])
+test('T16135', when(compiler_debugged(),expect_broken(16135)), compile, [''])
diff --git a/testsuite/tests/typecheck/no_skolem_info/Makefile b/testsuite/tests/typecheck/no_skolem_info/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/typecheck/no_skolem_info/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/typecheck/no_skolem_info/T10946_sk.hs b/testsuite/tests/typecheck/no_skolem_info/T10946_sk.hs
new file mode 100644
index 0000000000..c63dd7e30d
--- /dev/null
+++ b/testsuite/tests/typecheck/no_skolem_info/T10946_sk.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Bug where
+
+m :: a -> a
+m x = $$([||_||])
diff --git a/testsuite/tests/typecheck/no_skolem_info/T19482.hs b/testsuite/tests/typecheck/no_skolem_info/T19482.hs
new file mode 100644
index 0000000000..175887bd59
--- /dev/null
+++ b/testsuite/tests/typecheck/no_skolem_info/T19482.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+
+module Bug where
+
+instance BugClass ((s : sx) :: [r]) where
+    bugList = testF @r @s
+
+class BugClass k where
+    bugList :: ()
+
+testF :: forall a (b :: [a]). ()
+testF = ()
diff --git a/testsuite/tests/typecheck/no_skolem_info/T19752.hs b/testsuite/tests/typecheck/no_skolem_info/T19752.hs
new file mode 100644
index 0000000000..3fd3a68318
--- /dev/null
+++ b/testsuite/tests/typecheck/no_skolem_info/T19752.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Bug where
+
+type family F a
+
+g :: forall a. a
+g = f
+  where
+    f :: (F b ~ a) => a
+    f = undefined
diff --git a/testsuite/tests/typecheck/no_skolem_info/T19760.hs b/testsuite/tests/typecheck/no_skolem_info/T19760.hs
new file mode 100644
index 0000000000..eb3ac674cc
--- /dev/null
+++ b/testsuite/tests/typecheck/no_skolem_info/T19760.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Bug where
+
+import Data.Kind
+
+f :: forall a (p :: Maybe a -> Type) (m :: Maybe a). p m
+f = go
+  where
+    go :: forall a' (m' :: Maybe a'). p m'
+    go = undefined
diff --git a/testsuite/tests/typecheck/no_skolem_info/T20063.hs b/testsuite/tests/typecheck/no_skolem_info/T20063.hs
new file mode 100644
index 0000000000..f49d5a9ec4
--- /dev/null
+++ b/testsuite/tests/typecheck/no_skolem_info/T20063.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE DataKinds                #-}
+{-# LANGUAGE GADTs                    #-}
+{-# LANGUAGE PolyKinds                #-}
+{-# LANGUAGE RankNTypes               #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TypeApplications         #-}
+{-# LANGUAGE TypeFamilies             #-}
+{-# LANGUAGE TypeOperators            #-}
+
+module Bug where
+
+data Context where
+  Extend :: forall k. Context -> Context
+
+type (:*&) :: Context -> forall k -> Context
+type ctx :*& k = Extend @k ctx
+
+data Idx ctx where
+  T :: Idx ctx -> Idx (ctx :*& l)
+
+data Rn ctx1 ctx2 where
+  U :: Rn ctx1 ctx2 -> Rn (ctx1 :*& l) (ctx2 :*& l)
+
+rnRename :: Rn ctx1 ctx2 -> Idx ctx3 -> Idx ctx4
+rnRename (U _ ) _ = T _
+rnRename _      T = undefined
diff --git a/testsuite/tests/typecheck/no_skolem_info/all.T b/testsuite/tests/typecheck/no_skolem_info/all.T
new file mode 100644
index 0000000000..80b4db6a1b
--- /dev/null
+++ b/testsuite/tests/typecheck/no_skolem_info/all.T
@@ -0,0 +1,5 @@
+test('T19752', [expect_broken(19752), grep_errmsg('of unknown origin')], compile_fail, [''])
+test('T20063', [expect_broken(20063), grep_errmsg('of unknown origin')], compile_fail, [''])
+test('T19760', [expect_broken(19760), grep_errmsg('of unknown origin')], compile_fail, [''])
+test('T19482', [expect_broken(19482), grep_errmsg('of unknown origin')], compile_fail, [''])
+test('T10946_sk', [expect_broken(10946), grep_errmsg('of unknown origin')], compile_fail, [''])