diff --git a/libraries/ghc-internal/src/GHC/Internal/Exception.hs b/libraries/ghc-internal/src/GHC/Internal/Exception.hs index 023554a981df1d7a008253db14e5cb3e25d57388..0dcafebc7d75e77db7da72b58be00a65e6e50ec1 100644 --- a/libraries/ghc-internal/src/GHC/Internal/Exception.hs +++ b/libraries/ghc-internal/src/GHC/Internal/Exception.hs @@ -2,7 +2,6 @@ {-# LANGUAGE NoImplicitPrelude , ExistentialQuantification , MagicHash - , RecordWildCards , PatternSynonyms #-} {-# LANGUAGE DataKinds, PolyKinds #-} @@ -62,6 +61,7 @@ import GHC.Internal.Stack.Types import GHC.Internal.Data.OldList import GHC.Internal.IO.Unsafe import {-# SOURCE #-} GHC.Internal.Stack.CCS +import {-# SOURCE #-} GHC.Internal.Stack (prettyCallStackLines, prettyCallStack, prettySrcLoc) import GHC.Internal.Exception.Type -- | Throw an exception. Exceptions may be thrown from purely @@ -111,31 +111,3 @@ showCCSStack :: [String] -> [String] showCCSStack [] = [] showCCSStack stk = "CallStack (from -prof):" : map (" " ++) (reverse stk) --- prettySrcLoc and prettyCallStack are defined here to avoid hs-boot --- files. See Note [Definition of CallStack] - --- | Pretty print a 'SrcLoc'. --- --- @since base-4.9.0.0 -prettySrcLoc :: SrcLoc -> String -prettySrcLoc SrcLoc {..} - = foldr (++) "" - [ srcLocFile, ":" - , show srcLocStartLine, ":" - , show srcLocStartCol, " in " - , srcLocPackage, ":", srcLocModule - ] - --- | Pretty print a 'CallStack'. --- --- @since base-4.9.0.0 -prettyCallStack :: CallStack -> String -prettyCallStack = intercalate "\n" . prettyCallStackLines - -prettyCallStackLines :: CallStack -> [String] -prettyCallStackLines cs = case getCallStack cs of - [] -> [] - stk -> "CallStack (from HasCallStack):" - : map ((" " ++) . prettyCallSite) stk - where - prettyCallSite (f, loc) = f ++ ", called at " ++ prettySrcLoc loc diff --git a/libraries/ghc-internal/src/GHC/Internal/Stack.hs b/libraries/ghc-internal/src/GHC/Internal/Stack.hs index 57e8727d52551d0d6e18729bd81384a2970c068a..2a238c5612f8a9e1a51fd9a1c5441ea6165da242 100644 --- a/libraries/ghc-internal/src/GHC/Internal/Stack.hs +++ b/libraries/ghc-internal/src/GHC/Internal/Stack.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Trustworthy #-} @@ -27,8 +28,9 @@ module GHC.Internal.Stack ( -- * HasCallStack call stacks CallStack, HasCallStack, callStack, emptyCallStack, freezeCallStack, - fromCallSiteList, getCallStack, popCallStack, prettyCallStack, + fromCallSiteList, getCallStack, popCallStack, pushCallStack, withFrozenCallStack, + prettyCallStackLines, prettyCallStack, -- * Source locations SrcLoc(..), prettySrcLoc, @@ -48,11 +50,13 @@ module GHC.Internal.Stack ( renderStack ) where +import GHC.Internal.Show import GHC.Internal.Stack.CCS import GHC.Internal.Stack.Types import GHC.Internal.IO import GHC.Internal.Base import GHC.Internal.List +import GHC.Internal.Data.OldList (intercalate) import GHC.Internal.Exception -- | Like the function 'error', but appends a stack trace to the error @@ -104,3 +108,32 @@ withFrozenCallStack do_this = -- withFrozenCallStack's call-site let ?callStack = freezeCallStack (popCallStack callStack) in do_this + +-- prettySrcLoc and prettyCallStack are defined here to avoid hs-boot +-- files. See Note [Definition of CallStack] + +-- | Pretty print a 'SrcLoc'. +-- +-- @since 4.9.0.0 +prettySrcLoc :: SrcLoc -> String +prettySrcLoc SrcLoc {..} + = foldr (++) "" + [ srcLocFile, ":" + , show srcLocStartLine, ":" + , show srcLocStartCol, " in " + , srcLocPackage, ":", srcLocModule + ] + +-- | Pretty print a 'CallStack'. +-- +-- @since 4.9.0.0 +prettyCallStack :: CallStack -> String +prettyCallStack = intercalate "\n" . prettyCallStackLines + +prettyCallStackLines :: CallStack -> [String] +prettyCallStackLines cs = case getCallStack cs of + [] -> [] + stk -> "CallStack (from HasCallStack):" + : map ((" " ++) . prettyCallSite) stk + where + prettyCallSite (f, loc) = f ++ ", called at " ++ prettySrcLoc loc diff --git a/libraries/ghc-internal/src/GHC/Internal/Stack.hs-boot b/libraries/ghc-internal/src/GHC/Internal/Stack.hs-boot new file mode 100644 index 0000000000000000000000000000000000000000..8019482465bd6b4108d0ee9a039ab59efb6d6a64 --- /dev/null +++ b/libraries/ghc-internal/src/GHC/Internal/Stack.hs-boot @@ -0,0 +1,10 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module GHC.Internal.Stack where + +import GHC.Internal.Base +import GHC.Internal.Stack.Types (CallStack, SrcLoc) + +prettyCallStackLines :: CallStack -> [String] +prettyCallStack :: CallStack -> String +prettySrcLoc :: SrcLoc -> String