Use IP based CallStack in error and undefined

This patch modifies `error`, `undefined`, and `assertError` to use
implicit call-stacks to provide better error messages to users.

There are a few knock-on effects:

- `GHC.Classes.IP` is now wired-in so it can be used in the wired-in
  types for `error` and `undefined`.

- `TysPrim.tyVarList` has been replaced with a new function
  `TysPrim.mkTemplateTyVars`. `tyVarList` made it easy to introduce
  subtle bugs when you need tyvars of different kinds. The naive

  ```
  tv1 = head $ tyVarList kind1
  tv2 = head $ tyVarList kind2
  ```

  would result in `tv1` and `tv2` sharing a `Unique`, thus substitutions
  would be applied incorrectly, treating `tv1` and `tv2` as the same
  tyvar. `mkTemplateTyVars` avoids this pitfall by taking a list of kinds
  and producing a single tyvar of each kind.

- The types `GHC.SrcLoc.SrcLoc` and `GHC.Stack.CallStack` now live in
  ghc-prim.

- The type `GHC.Exception.ErrorCall` has a new constructor
  `ErrorCallWithLocation` that takes two `String`s instead of one, the
  2nd one being arbitrary metadata about the error (but usually the
  call-stack). A bi-directional pattern synonym `ErrorCall` continues to
  provide the old API.

Updates Cabal, array, and haddock submodules.

Reviewers: nh2, goldfire, simonpj, hvr, rwbarton, austin, bgamari

Reviewed By: simonpj

Subscribers: rwbarton, rodlogic, goldfire, maoe, simonmar, carter,
liyang, bgamari, thomie

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

GHC Trac Issues: #5273

13 files changed, 126 insertions, 120 deletions

diff --git a/libraries/Cabal b/libraries/Cabal
-Subproject f47732a50d4bd103c5660c2fbcd77cbce8c521b
+Subproject ad1136358d10d68f3d94fa2fe0f11a25331bdf1
diff --git a/libraries/array b/libraries/array
-Subproject 68323b26865ec86a53237ca8974e82bf406a971
+Subproject 2f5b772f4475d70a68c6f9d10390ac9812afdb7
diff --git a/libraries/base/Control/Exception.hs b/libraries/base/Control/Exception.hs
index 9c388f4450..1383972c7a 100644
--- a/libraries/base/Control/Exception.hs
+++ b/libraries/base/Control/Exception.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE NoImplicitPrelude, ExistentialQuantification #-}
+{-# LANGUAGE NoImplicitPrelude, ExistentialQuantification, PatternSynonyms #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -56,6 +56,7 @@ module Control.Exception (
         RecSelError(..),
         RecUpdError(..),
         ErrorCall(..),
+        pattern ErrorCall,
         TypeError(..),
 
         -- * Throwing exceptions
diff --git a/libraries/base/Control/Exception/Base.hs b/libraries/base/Control/Exception/Base.hs
index ece5c69dd5..ba2502f379 100644
--- a/libraries/base/Control/Exception/Base.hs
+++ b/libraries/base/Control/Exception/Base.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE NoImplicitPrelude, MagicHash #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE StandaloneDeriving #-}
 
 -----------------------------------------------------------------------------
@@ -38,7 +39,7 @@ module Control.Exception.Base (
         RecConError(..),
         RecSelError(..),
         RecUpdError(..),
-        ErrorCall(..),
+        ErrorCall(..), pattern ErrorCall,
         TypeError(..), -- #10284, custom error type for deferred type errors
 
         -- * Throwing exceptions
diff --git a/libraries/base/GHC/Err.hs b/libraries/base/GHC/Err.hs
index 9bd71327d9..8cdb10709d 100644
--- a/libraries/base/GHC/Err.hs
+++ b/libraries/base/GHC/Err.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE NoImplicitPrelude, MagicHash #-}
+{-# LANGUAGE NoImplicitPrelude, MagicHash, ImplicitParams #-}
 {-# OPTIONS_HADDOCK hide #-}
 
 -----------------------------------------------------------------------------
@@ -28,17 +28,17 @@ import GHC.Prim
 import GHC.Integer ()   -- Make sure Integer is compiled first
                         -- because GHC depends on it in a wired-in way
                         -- so the build system doesn't see the dependency
-import {-# SOURCE #-} GHC.Exception( errorCallException )
+import {-# SOURCE #-} GHC.Exception( errorCallWithCallStackException )
 
 -- | 'error' stops execution and displays an error message.
-error :: [Char] -> a
-error s = raise# (errorCallException s)
+error :: (?callStack :: CallStack) => [Char] -> a
+error s = raise# (errorCallWithCallStackException s ?callStack)
 
 -- | A special case of 'error'.
 -- It is expected that compilers will recognize this and insert error
 -- messages which are more appropriate to the context in which 'undefined'
 -- appears.
-undefined :: a
+undefined :: (?callStack :: CallStack) => a
 undefined =  error "Prelude.undefined"
 
 -- | Used for compiler-generated error message;
diff --git a/libraries/base/GHC/Exception.hs b/libraries/base/GHC/Exception.hs
index b82ae114e6..3fbae05c9a 100644
--- a/libraries/base/GHC/Exception.hs
+++ b/libraries/base/GHC/Exception.hs
@@ -2,6 +2,8 @@
 {-# LANGUAGE NoImplicitPrelude
            , ExistentialQuantification
            , MagicHash
+           , RecordWildCards
+           , PatternSynonyms
   #-}
 {-# OPTIONS_HADDOCK hide #-}
 
@@ -22,9 +24,12 @@
 module GHC.Exception
        ( Exception(..)    -- Class
        , throw
-       , SomeException(..), ErrorCall(..), ArithException(..)
+       , SomeException(..), ErrorCall(..), pattern ErrorCall, ArithException(..)
        , divZeroException, overflowException, ratioZeroDenomException
-       , errorCallException
+       , errorCallException, errorCallWithCallStackException
+       , showCallStack, popCallStack, showSrcLoc
+         -- re-export CallStack and SrcLoc from GHC.Types
+       , CallStack(..), SrcLoc(..)
        ) where
 
 import Data.Maybe
@@ -158,17 +163,61 @@ throw e = raise# (toException e)
 
 -- |This is thrown when the user calls 'error'. The @String@ is the
 -- argument given to 'error'.
-newtype ErrorCall = ErrorCall String
+data ErrorCall = ErrorCallWithLocation String String
     deriving (Eq, Ord)
 
+pattern ErrorCall err <- ErrorCallWithLocation err _ where
+  ErrorCall err = ErrorCallWithLocation err ""
+
 instance Exception ErrorCall
 
 instance Show ErrorCall where
-    showsPrec _ (ErrorCall err) = showString err
+  showsPrec _ (ErrorCallWithLocation err "") = showString err
+  showsPrec _ (ErrorCallWithLocation err loc) = showString (err ++ '\n' : loc)
 
 errorCallException :: String -> SomeException
 errorCallException s = toException (ErrorCall s)
 
+errorCallWithCallStackException :: String -> CallStack -> SomeException
+errorCallWithCallStackException s stk
+  = toException (ErrorCallWithLocation s (showCallStack (popCallStack stk)))
+
+
+-- | Pretty print 'SrcLoc'
+--
+-- @since 4.8.2.0
+showSrcLoc :: SrcLoc -> String
+showSrcLoc SrcLoc {..}
+  = foldr (++) ""
+      [ srcLocFile, ":"
+      , show srcLocStartLine, ":"
+      , show srcLocStartCol, " in "
+      , srcLocPackage, ":", srcLocModule
+      ]
+
+-- | Pretty print 'CallStack'
+--
+-- @since 4.8.2.0
+showCallStack :: CallStack -> String
+showCallStack (CallStack stk@(_:_))
+  = unlines ("CallStack:" : map (indent . showCallSite) stk)
+  where
+  -- Data.OldList isn't available yet, so we repeat the definition here
+  unlines [] = []
+  unlines [l] = l
+  unlines (l:ls) = l ++ '\n' : unlines ls
+  indent l = "  " ++ l
+  showCallSite (f, loc) = f ++ ", called at " ++ showSrcLoc loc
+showCallStack _ = error "CallStack cannot be empty!"
+
+
+-- | Remove the most recent callsite from the 'CallStack'
+--
+-- @since 4.8.2.0
+popCallStack :: CallStack -> CallStack
+popCallStack (CallStack (_:rest)) = CallStack rest
+popCallStack _ = error "CallStack cannot be empty!"
+
 -- |Arithmetic exceptions.
 data ArithException
   = Overflow
diff --git a/libraries/base/GHC/Exception.hs-boot b/libraries/base/GHC/Exception.hs-boot
index aa19897363..594f2665e8 100644
--- a/libraries/base/GHC/Exception.hs-boot
+++ b/libraries/base/GHC/Exception.hs-boot
@@ -25,10 +25,13 @@ to get a visibly-bottom value.
 -}
 
 module GHC.Exception ( SomeException, errorCallException,
+                       errorCallWithCallStackException,
                        divZeroException, overflowException, ratioZeroDenomException
     ) where
-import GHC.Types( Char )
+import GHC.Types( Char, CallStack )
 
 data SomeException
 divZeroException, overflowException, ratioZeroDenomException  :: SomeException
+
 errorCallException :: [Char] -> SomeException
+errorCallWithCallStackException :: [Char] -> CallStack -> SomeException
diff --git a/libraries/base/GHC/IO/Exception.hs b/libraries/base/GHC/IO/Exception.hs
index 482027b742..e723ebdf33 100644
--- a/libraries/base/GHC/IO/Exception.hs
+++ b/libraries/base/GHC/IO/Exception.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE DeriveGeneric, NoImplicitPrelude, MagicHash,
-             ExistentialQuantification #-}
+             ExistentialQuantification, ImplicitParams #-}
 {-# OPTIONS_GHC -funbox-strict-fields #-}
 {-# OPTIONS_HADDOCK hide #-}
 
@@ -352,10 +352,12 @@ instance Show IOException where
 -- Note the use of "lazy". This means that
 --     assert False (throw e)
 -- will throw the assertion failure rather than e. See trac #5561.
-assertError :: Addr# -> Bool -> a -> a
-assertError str predicate v
+assertError :: (?callStack :: CallStack) => Bool -> a -> a
+assertError predicate v
   | predicate = lazy v
-  | otherwise = throw (AssertionFailed (untangle str "Assertion failed"))
+  | otherwise = throw (AssertionFailed
+                        ("Assertion failed\n"
+                         ++ showCallStack (popCallStack ?callStack)))
 
 unsupportedOperation :: IOError
 unsupportedOperation =
diff --git a/libraries/base/GHC/SrcLoc.hs b/libraries/base/GHC/SrcLoc.hs
deleted file mode 100644
index 23a109bd8f..0000000000
--- a/libraries/base/GHC/SrcLoc.hs
+++ /dev/null
@@ -1,40 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-
--- | @since 4.8.2.0
-module GHC.SrcLoc
-  ( SrcLoc
-  , srcLocPackage
-  , srcLocModule
-  , srcLocFile
-  , srcLocStartLine
-  , srcLocStartCol
-  , srcLocEndLine
-  , srcLocEndCol
-
-  -- * Pretty printing
-  , showSrcLoc
-  ) where
-
--- | A single location in the source code.
---
--- @since 4.8.2.0
-data SrcLoc = SrcLoc
-  { srcLocPackage   :: String
-  , srcLocModule    :: String
-  , srcLocFile      :: String
-  , srcLocStartLine :: Int
-  , srcLocStartCol  :: Int
-  , srcLocEndLine   :: Int
-  , srcLocEndCol    :: Int
-  } deriving (Show, Eq)
-
--- | Pretty print 'SrcLoc'
---
--- @since 4.8.2.0
-showSrcLoc :: SrcLoc -> String
-showSrcLoc SrcLoc {..}
-  = concat [ srcLocFile, ":"
-           , show srcLocStartLine, ":"
-           , show srcLocStartCol, " in "
-           , srcLocPackage, ":", srcLocModule
-           ]
diff --git a/libraries/base/GHC/Stack.hsc b/libraries/base/GHC/Stack.hsc
index 40fba7dcc8..a2283ff656 100644
--- a/libraries/base/GHC/Stack.hsc
+++ b/libraries/base/GHC/Stack.hsc
@@ -18,18 +18,10 @@
 {-# LANGUAGE UnboxedTuples, MagicHash, NoImplicitPrelude #-}
 module GHC.Stack (
     -- * Call stacks
-    -- ** Simulated by the RTS
     currentCallStack,
     whoCreated,
     errorWithStackTrace,
 
-    -- ** Explicitly created via implicit-parameters
-    --
-    -- @since 4.8.2.0
-    CallStack,
-    getCallStack,
-    showCallStack,
-
     -- * Internals
     CostCentreStack,
     CostCentre,
@@ -44,8 +36,6 @@ module GHC.Stack (
     renderStack
   ) where
 
-import Data.List ( unlines )
-
 import Foreign
 import Foreign.C
 
@@ -56,8 +46,6 @@ import GHC.Foreign as GHC
 import GHC.IO.Encoding
 import GHC.Exception
 import GHC.List ( concatMap, null, reverse )
-import GHC.Show
-import GHC.SrcLoc
 
 #define PROFILING
 #include "Rts.h"
@@ -139,52 +127,4 @@ errorWithStackTrace x = unsafeDupablePerformIO $ do
    stack <- ccsToStrings =<< getCurrentCCS x
    if null stack
       then throwIO (ErrorCall x)
-      else throwIO (ErrorCall (x ++ '\n' : renderStack stack))
-
-
-----------------------------------------------------------------------
--- Explicit call-stacks built via ImplicitParams
-----------------------------------------------------------------------
-
--- | @CallStack@s are an alternate method of obtaining the call stack at a given
--- point in the program.
---
--- When an implicit-parameter of type @CallStack@ occurs in a program, GHC will
--- solve it with the current location. If another @CallStack@ implicit-parameter
--- is in-scope (e.g. as a function argument), the new location will be appended
--- to the one in-scope, creating an explicit call-stack. For example,
---
--- @
--- myerror :: (?loc :: CallStack) => String -> a
--- myerror msg = error (msg ++ "\n" ++ showCallStack ?loc)
--- @
--- ghci> myerror "die"
--- *** Exception: die
--- ?loc, called at MyError.hs:7:51 in main:MyError
---   myerror, called at <interactive>:2:1 in interactive:Ghci1
---
--- @CallStack@s do not interact with the RTS and do not require compilation with
--- @-prof@. On the other hand, as they are built up explicitly using
--- implicit-parameters, they will generally not contain as much information as
--- the simulated call-stacks maintained by the RTS.
---
--- The @CallStack@ type is abstract, but it can be converted into a
--- @[(String, SrcLoc)]@ via 'getCallStack'. The @String@ is the name of function
--- that was called, the 'SrcLoc' is the call-site. The list is ordered with the
--- most recently called function at the head.
---
--- @since 4.8.2.0
-data CallStack = CallStack { getCallStack :: [(String, SrcLoc)] }
-  -- See Note [Overview of implicit CallStacks]
-  deriving (Show, Eq)
-
--- | Pretty print 'CallStack'
---
--- @since 4.8.2.0
-showCallStack :: CallStack -> String
-showCallStack (CallStack (root:rest))
-  = unlines (showCallSite root : map (indent . showCallSite) rest)
-  where
-  indent l = "  " ++ l
-  showCallSite (f, loc) = f ++ ", called at " ++ showSrcLoc loc
-showCallStack _ = error "CallStack cannot be empty!"
+      else throwIO (ErrorCallWithLocation x (renderStack stack))
diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
index 21a8ae7bcb..33734a00c7 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/base.cabal
@@ -248,7 +248,6 @@ Library
         GHC.StaticPtr
         GHC.STRef
         GHC.Show
-        GHC.SrcLoc
         GHC.Stable
         GHC.Stack
         GHC.Stats
diff --git a/libraries/base/tests/assert.stderr b/libraries/base/tests/assert.stderr
index 8d99aa0a64..7183f1e763 100644
--- a/libraries/base/tests/assert.stderr
+++ b/libraries/base/tests/assert.stderr
@@ -1,2 +1,4 @@
-assert: assert.hs:9:11-16: Assertion failed
+assert: Assertion failed
+CallStack:
+  assert, called at assert.hs:9:11 in main:Main
 
diff --git a/libraries/ghc-prim/GHC/Types.hs b/libraries/ghc-prim/GHC/Types.hs
index 7bc746f256..6dcd5f1a7f 100644
--- a/libraries/ghc-prim/GHC/Types.hs
+++ b/libraries/ghc-prim/GHC/Types.hs
@@ -30,10 +30,11 @@ module GHC.Types (
         SPEC(..),
         Nat, Symbol,
         Coercible,
+        SrcLoc(..), CallStack(..)
     ) where
 
 import GHC.Prim
-
+import GHC.Tuple ()
 
 infixr 5 :
 
@@ -308,3 +309,51 @@ you're reading this in 2023 then things went wrong). See #8326.
 -- Libraries can specify this by using 'SPEC' data type to inform which
 -- loops should be aggressively specialized.
 data SPEC = SPEC | SPEC2
+
+-- | A single location in the source code.
+--
+-- @since 4.8.2.0
+data SrcLoc = SrcLoc
+  { srcLocPackage   :: [Char]
+  , srcLocModule    :: [Char]
+  , srcLocFile      :: [Char]
+  , srcLocStartLine :: Int
+  , srcLocStartCol  :: Int
+  , srcLocEndLine   :: Int
+  , srcLocEndCol    :: Int
+  }
+
+----------------------------------------------------------------------
+-- Explicit call-stacks built via ImplicitParams
+----------------------------------------------------------------------
+
+-- | @CallStack@s are an alternate method of obtaining the call stack at a given
+-- point in the program.
+--
+-- When an implicit-parameter of type @CallStack@ occurs in a program, GHC will
+-- solve it with the current location. If another @CallStack@ implicit-parameter
+-- is in-scope (e.g. as a function argument), the new location will be appended
+-- to the one in-scope, creating an explicit call-stack. For example,
+--
+-- @
+-- myerror :: (?loc :: CallStack) => String -> a
+-- myerror msg = error (msg ++ "\n" ++ showCallStack ?loc)
+-- @
+-- ghci> myerror "die"
+-- *** Exception: die
+-- CallStack:
+--   ?loc, called at MyError.hs:7:51 in main:MyError
+--   myerror, called at <interactive>:2:1 in interactive:Ghci1
+--
+-- @CallStack@s do not interact with the RTS and do not require compilation with
+-- @-prof@. On the other hand, as they are built up explicitly using
+-- implicit-parameters, they will generally not contain as much information as
+-- the simulated call-stacks maintained by the RTS.
+--
+-- A @CallStack@ is a @[(String, SrcLoc)]@. The @String@ is the name of
+-- function that was called, the 'SrcLoc' is the call-site. The list is
+-- ordered with the most recently called function at the head.
+--
+-- @since 4.8.2.0
+data CallStack = CallStack { getCallStack :: [([Char], SrcLoc)] }
+  -- See Note [Overview of implicit CallStacks]