From 46220a1a4a3d05480a20dbaa62c631f8b2557185 Mon Sep 17 00:00:00 2001 From: Stephen Diehl Date: Wed, 31 May 2017 10:13:08 +0100 Subject: [PATCH 1/4] Added HasCallStack constraint for trace functions (#55) * added HasCallStack constraint for trace functions, for issue #39 * unpack string on 7.6 --- protolude.cabal | 2 ++ src/Base.hs | 4 ---- src/CallStack.hs | 18 ++++++++++++++++++ src/Debug.hs | 10 +++------- src/Error.hs | 45 +++++++++++++++++++++++++++++++++++++++++++++ src/Panic.hs | 8 +++++++- src/Protolude.hs | 2 -- 7 files changed, 75 insertions(+), 14 deletions(-) create mode 100644 src/CallStack.hs create mode 100644 src/Error.hs 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. From d30d6a39abab0b078de7b8b52e6837400bfd5fbf Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Wed, 14 Jun 2017 07:33:23 +0200 Subject: [PATCH 2/4] add (<&>), fixes issue #53 (#56) --- docs/Functor.md | 1 + src/Protolude.hs | 9 ++++++++- 2 files changed, 9 insertions(+), 1 deletion(-) 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/src/Protolude.hs b/src/Protolude.hs index 20ac9aba8..3d2cc1a8f 100644 --- a/src/Protolude.hs +++ b/src/Protolude.hs @@ -16,7 +16,7 @@ module Protolude ( print, throwIO, throwTo, - foreach, + foreach, (<&>), show, pass, guarded, @@ -570,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 () From d7bc98214233d368875a59f8f68823684d00bdd6 Mon Sep 17 00:00:00 2001 From: Moritz Kiefer Date: Wed, 5 Jul 2017 08:02:57 +0200 Subject: [PATCH 3/4] Bump base upper bound for GHC 8.2 --- .travis.yml | 1 + protolude.cabal | 5 +++-- 2 files changed, 4 insertions(+), 2 deletions(-) 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/protolude.cabal b/protolude.cabal index 8e5d45489..d134f07ff 100644 --- a/protolude.cabal +++ b/protolude.cabal @@ -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: @@ -65,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, From 5717b9a42c23bbf92f534ab2ed5d2f9e552b0f7d Mon Sep 17 00:00:00 2001 From: Stephen Diehl Date: Wed, 5 Jul 2017 14:42:30 +0100 Subject: [PATCH 4/4] description and synopsis lines for latest cabal --- protolude.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/protolude.cabal b/protolude.cabal index d134f07ff..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