diff --git a/protolude.cabal b/protolude.cabal index 2d38447b3..8e5d45489 100644 --- a/protolude.cabal +++ b/protolude.cabal @@ -50,6 +50,8 @@ library Functor Semiring Bifunctor + CallStack + Error Panic default-extensions: diff --git a/src/Base.hs b/src/Base.hs index d9a5420e7..4eb78145f 100644 --- a/src/Base.hs +++ b/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(..) ) diff --git a/src/CallStack.hs b/src/CallStack.hs new file mode 100644 index 000000000..8f875b72d --- /dev/null +++ b/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 diff --git a/src/Debug.hs b/src/Debug.hs index 5e62b884d..36adcbfbe 100644 --- a/src/Debug.hs +++ b/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" diff --git a/src/Error.hs b/src/Error.hs new file mode 100644 index 000000000..fd497e0ea --- /dev/null +++ b/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 diff --git a/src/Panic.hs b/src/Panic.hs index 6055bc6dc..508ddc7f0 100644 --- a/src/Panic.hs +++ b/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) diff --git a/src/Protolude.hs b/src/Protolude.hs index 5bfb5003a..20ac9aba8 100644 --- a/src/Protolude.hs +++ b/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.