diff options
author | Eric Seidel <gridaphobe@gmail.com> | 2015-09-02 10:22:01 +0200 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2015-09-02 13:21:43 +0200 |
commit | 6740d70d95cb81cea3859ff847afc61ec439db4f (patch) | |
tree | 08199080ae5e55aafa1ff05cffd929039d3345bf /libraries | |
parent | ad26c54b86a868567d324d5de6fd0b4c2ed28022 (diff) | |
download | haskell-6740d70d95cb81cea3859ff847afc61ec439db4f.tar.gz |
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
Diffstat (limited to 'libraries')
m--------- | libraries/Cabal | 0 | ||||
m--------- | libraries/array | 0 | ||||
-rw-r--r-- | libraries/base/Control/Exception.hs | 3 | ||||
-rw-r--r-- | libraries/base/Control/Exception/Base.hs | 3 | ||||
-rw-r--r-- | libraries/base/GHC/Err.hs | 10 | ||||
-rw-r--r-- | libraries/base/GHC/Exception.hs | 57 | ||||
-rw-r--r-- | libraries/base/GHC/Exception.hs-boot | 5 | ||||
-rw-r--r-- | libraries/base/GHC/IO/Exception.hs | 10 | ||||
-rw-r--r-- | libraries/base/GHC/SrcLoc.hs | 40 | ||||
-rw-r--r-- | libraries/base/GHC/Stack.hsc | 62 | ||||
-rw-r--r-- | libraries/base/base.cabal | 1 | ||||
-rw-r--r-- | libraries/base/tests/assert.stderr | 4 | ||||
-rw-r--r-- | libraries/ghc-prim/GHC/Types.hs | 51 |
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] |