base: Move prettyCallStack to GHC.Stack

3 files changed, 47 insertions, 31 deletions

diff --git a/libraries/base/GHC/Exception.hs b/libraries/base/GHC/Exception.hs
index 66982b0043..332825bfca 100644
--- a/libraries/base/GHC/Exception.hs
+++ b/libraries/base/GHC/Exception.hs
@@ -2,7 +2,6 @@
 {-# LANGUAGE NoImplicitPrelude
            , ExistentialQuantification
            , MagicHash
-           , RecordWildCards
            , PatternSynonyms
   #-}
 {-# LANGUAGE DataKinds, PolyKinds #-}
@@ -28,7 +27,8 @@ module GHC.Exception
        , ErrorCall(..,ErrorCall)
        , errorCallException
        , errorCallWithCallStackException
-         -- re-export CallStack and SrcLoc from GHC.Types
+
+         -- * Re-exports from GHC.Types
        , CallStack, fromCallSiteList, getCallStack, prettyCallStack
        , prettyCallStackLines, showCCSStack
        , SrcLoc(..), prettySrcLoc
@@ -40,6 +40,7 @@ import GHC.Stack.Types
 import GHC.OldList
 import GHC.IO.Unsafe
 import {-# SOURCE #-} GHC.Stack.CCS
+import {-# SOURCE #-} GHC.Stack (prettyCallStackLines, prettyCallStack, prettySrcLoc)
 import GHC.Exception.Type
 
 -- | Throw an exception.  Exceptions may be thrown from purely
@@ -89,31 +90,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 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/base/GHC/Stack.hs b/libraries/base/GHC/Stack.hs
index 007db83b42..35c4fb68b0 100644
--- a/libraries/base/GHC/Stack.hs
+++ b/libraries/base/GHC/Stack.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE ImplicitParams #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE Trustworthy #-}
 
@@ -27,8 +28,9 @@ module GHC.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,12 +50,14 @@ module GHC.Stack (
     renderStack
   ) where
 
+import GHC.Show
 import GHC.Stack.CCS
 import GHC.Stack.Types
 import GHC.IO
 import GHC.Base
 import GHC.List
 import GHC.Exception
+import Data.OldList (intercalate)
 
 -- | Like the function 'error', but appends a stack trace to the error
 -- message if one is available.
@@ -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/base/GHC/Stack.hs-boot b/libraries/base/GHC/Stack.hs-boot
new file mode 100644
index 0000000000..6cb999e190
--- /dev/null
+++ b/libraries/base/GHC/Stack.hs-boot
@@ -0,0 +1,10 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module GHC.Stack where
+
+import GHC.Base
+import GHC.Stack.Types (CallStack, SrcLoc)
+
+prettyCallStackLines :: CallStack -> [String]
+prettyCallStack :: CallStack -> String
+prettySrcLoc :: SrcLoc -> String