Added HasCallStack constraint for trace functions (#55)

* added HasCallStack constraint for trace functions, for issue #39

* unpack string on 7.6

protolude.cabal

@@ -50,6 +50,8 @@ library
     Functor
     Semiring
     Bifunctor
+    CallStack
+    Error
     Panic
 
   default-extensions:

src/Base.hs

@@ -32,10 +32,6 @@ import GHC.Float as X (
   , showFloat
   , showSignedFloat
   )
-import GHC.Err as X (
-    undefined
-  , error
-  )
 import GHC.Show as X (
     Show(..)
   )

src/CallStack.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE ConstraintKinds #-}
+
+module CallStack
+( HasCallStack
+) where
+
+#if MIN_VERSION_base(4,9,0)
+import GHC.Stack (HasCallStack)
+#elif MIN_VERSION_base(4,8,1)
+import qualified GHC.Stack
+type HasCallStack = (?callStack :: GHC.Stack.CallStack)
+#else
+import GHC.Exts (Constraint)
+type HasCallStack = (() :: Constraint)
+#endif

src/Debug.hs

@@ -3,7 +3,6 @@
 
 module Debug (
   undefined,
-  error,
   trace,
   traceM,
   traceId,
@@ -18,6 +17,7 @@ import Data.Text (Text, unpack)
 import Control.Monad (Monad, return)
 
 import qualified Base as P
+import Error (error)
 import Show (Print, putStrLn)
 
 import System.IO.Unsafe (unsafePerformIO)
@@ -34,10 +34,6 @@ traceIO string expr = do
     putStrLn string
     return expr
 
-{-# WARNING error "'error' remains in code" #-}
-error :: Text -> a
-error s = P.error (unpack s)
-
 {-# WARNING traceShow "'traceShow' remains in code" #-}
 traceShow :: P.Show a => a -> b -> b
 traceShow a b = trace (P.show a) b
@@ -59,7 +55,7 @@ traceId :: Text -> Text
 traceId s = trace s s
 
 notImplemented :: a
-notImplemented = P.error "Not implemented"
+notImplemented = error "Not implemented"
 
 undefined :: a
-undefined = P.undefined
+undefined = error "Prelude.undefined"

src/Error.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE ExistentialQuantification #-}
+
+#if MIN_VERSION_base(4,9,0)
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+#endif
+
+module Error
+( error
+) where
+
+import GHC.Prim
+import Data.Text (Text, unpack)
+
+#if MIN_VERSION_base(4,9,0)
+-- Full stack trace.
+
+import GHC.Types (RuntimeRep)
+import CallStack (HasCallStack)
+import GHC.Exception (errorCallWithCallStackException)
+
+error :: forall (r :: RuntimeRep) . forall (a :: TYPE r) . HasCallStack => Text -> a
+error s = raise# (errorCallWithCallStackException (unpack s) ?callstack)
+
+#elif MIN_VERSION_base(4,7,0)
+-- Basic Call Stack with callsite.
+
+import GHC.Exception (errorCallException)
+
+error :: Text -> a
+error s = raise# (errorCallException (unpack s))
+
+#else
+
+-- No exception tracing.
+import GHC.Types
+import GHC.Exception
+
+error :: Text -> a
+error s = throw (ErrorCall (unpack s))
+
+#endif

src/Panic.hs

@@ -1,5 +1,10 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DeriveDataTypeable #-}
+#if MIN_VERSION_base(4,9,0)
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+#endif
 
 module Panic (
   FatalError(..),
@@ -9,6 +14,7 @@ module Panic (
 import Base (Show)
 import Data.Text (Text)
 import Data.Typeable (Typeable)
+import CallStack (HasCallStack)
 import Control.Exception as X
 
 -- | Uncatchable exceptions thrown and never caught.
@@ -17,5 +23,5 @@ data FatalError = FatalError { fatalErrorMessage :: Text }
 
 instance Exception FatalError
 
-panic :: Text -> a
+panic :: HasCallStack => Text -> a
 panic a = throw (FatalError a)

src/Protolude.hs

@@ -49,8 +49,6 @@ import Base as Base hiding (
     putStr           -- Overriden by Show.putStr
   , putStrLn         -- Overriden by Show.putStrLn
   , print            -- Overriden by Protolude.print
-  , error            -- Overriden by Debug.error
-  , undefined        -- Overriden by Debug.undefined
   , show             -- Overriden by Protolude.show
   , showFloat        -- Custom Show instances deprecated.
   , showList         -- Custom Show instances deprecated.