diff --git a/.travis.yml b/.travis.yml index f04bb57ce..d62b1db2b 100644 --- a/.travis.yml +++ b/.travis.yml @@ -19,6 +19,7 @@ env: - CABALVER=1.22 GHCVER=7.10.2 - CABALVER=1.22 GHCVER=7.10.3 - CABALVER=1.24 GHCVER=8.0.1 + - CABALVER=2.0 GHCVER=8.2.1 # Note: the distinction between `before_install` and `install` is not # important. diff --git a/docs/Functor.md b/docs/Functor.md index 44c441905..40a80c248 100644 --- a/docs/Functor.md +++ b/docs/Functor.md @@ -35,6 +35,7 @@ void :: Functor f => f a -> f () ```haskell foreach :: Functor f => f a -> (a -> b) -> f b +(<&>) :: Functor f => f a -> (a -> b) -> f b ``` diff --git a/protolude.cabal b/protolude.cabal index 2d38447b3..172380b85 100644 --- a/protolude.cabal +++ b/protolude.cabal @@ -1,6 +1,6 @@ name: protolude version: 0.2 -synopsis: A sensible set of defaults for writing custom Preludes. +synopsis: A small prelude. description: A sensible set of defaults for writing custom Preludes. homepage: https://github.com/sdiehl/protolude license: MIT @@ -22,7 +22,8 @@ tested-with: GHC == 7.10.1, GHC == 7.10.2, GHC == 7.10.3, - GHC == 8.0.1 + GHC == 8.0.1, + GHC == 8.2.1 Bug-Reports: https://github.com/sdiehl/protolude/issues description: @@ -50,6 +51,8 @@ library Functor Semiring Bifunctor + CallStack + Error Panic default-extensions: @@ -63,7 +66,7 @@ library -fwarn-implicit-prelude build-depends: - base >= 4.6 && <4.10, + base >= 4.6 && <4.11, array >= 0.4 && <0.6, ghc-prim >= 0.3 && <0.6, async >= 2.0 && <2.2, 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..3d2cc1a8f 100644 --- a/src/Protolude.hs +++ b/src/Protolude.hs @@ -16,7 +16,7 @@ module Protolude ( print, throwIO, throwTo, - foreach, + foreach, (<&>), show, pass, guarded, @@ -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. @@ -572,6 +570,13 @@ throwTo tid e = liftIO (Control.Exception.throwTo tid e) foreach :: Functor f => f a -> (a -> b) -> f b foreach = flip fmap +-- | Infix version of foreach. +-- +-- @<&>@ is to '<$>' what '&' is to '$'. +infixl 4 <&> +(<&>) :: Functor f => f a -> (a -> b) -> f b +(<&>) = foreach + -- | Do nothing returning unit inside applicative. pass :: Applicative f => f () pass = pure ()