Merge branch 'cocreature-ghc-8.2'

.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.

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
 ```
 
 

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,

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

@@ -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 ()