diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2016, Stephen Diehl +Copyright (c) 2016-2017, Stephen Diehl Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to diff --git a/protolude.cabal b/protolude.cabal --- a/protolude.cabal +++ b/protolude.cabal @@ -1,13 +1,13 @@ name: protolude -version: 0.1.10 -synopsis: A sensible set of defaults for writing custom Preludes. +version: 0.2 +synopsis: A small prelude. description: A sensible set of defaults for writing custom Preludes. homepage: https://github.com/sdiehl/protolude license: MIT license-file: LICENSE author: Stephen Diehl maintainer: stephen.m.diehl@gmail.com -copyright: 2016 Stephen Diehl +copyright: 2016-2017 Stephen Diehl category: Prelude build-type: Simple cabal-version: >=1.10 @@ -21,7 +21,9 @@ GHC == 7.8.4, GHC == 7.10.1, GHC == 7.10.2, - GHC == 7.10.3 + GHC == 7.10.3, + GHC == 8.0.1, + GHC == 8.2.1 Bug-Reports: https://github.com/sdiehl/protolude/issues description: @@ -34,6 +36,9 @@ exposed-modules: Protolude Unsafe + + other-modules: + Exceptions Base Applicative Bool @@ -46,11 +51,10 @@ Functor Semiring Bifunctor - Exceptions + CallStack + Error Panic - other-modules: - default-extensions: NoImplicitPrelude OverloadedStrings @@ -62,17 +66,26 @@ -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, - safe >= 0.3 && <0.4, - async >= 2.1 && <2.2, + async >= 2.0 && <2.2, deepseq >= 1.3 && <1.5, containers >= 0.5 && <0.6, - mtl >= 2.1 && <2.3, - transformers >= 0.4 && <0.6, + hashable >= 1.2 && <1.3, + transformers >= 0.2 && <0.6, text >= 1.2 && <1.3, stm >= 2.4 && <2.5, - bytestring >= 0.10 && <0.11 + bytestring >= 0.10 && <0.11, + mtl >= 2.1 && <2.3, + mtl-compat >= 0.2 && <0.3 + + if impl(ghc >= 7.8.0) + build-depends: + safe >= 0.3 && <0.3.16 + else + build-depends: + safe >= 0.3 && <0.3.10 hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Base.hs b/src/Base.hs --- a/src/Base.hs +++ b/src/Base.hs @@ -1,8 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Unsafe #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ExplicitNamespaces #-} module Base ( module X, @@ -13,13 +13,25 @@ #if defined(__GLASGOW_HASKELL__) && ( __GLASGOW_HASKELL__ >= 600 ) -- Base GHC types -import GHC.Num as X -import GHC.Enum as X +import GHC.Num as X ( + Num(..) + , Integer + , subtract + ) +import GHC.Enum as X ( + Bounded(..) + , Enum(..) + , boundedEnumFrom + , boundedEnumFromThen + ) import GHC.Real as X -import GHC.Float as X -import GHC.Err as X ( - undefined - , error +import GHC.Float as X ( + Float(..) + , Double(..) + , Floating (..) + , RealFloat(..) + , showFloat + , showSignedFloat ) import GHC.Show as X ( Show(..) @@ -36,7 +48,10 @@ , ord , maxInt , minInt + , until ) + +-- Exported for lifting into new functions. import System.IO as X ( print , putStr @@ -55,6 +70,10 @@ #endif ) +#if ( __GLASGOW_HASKELL__ >= 710 ) +import GHC.StaticPtr as X (StaticPtr) +#endif + #if ( __GLASGOW_HASKELL__ >= 800 ) import GHC.OverloadedLabels as X ( IsLabel(..) @@ -69,26 +88,47 @@ import GHC.Stack as X ( CallStack - , HasCallStack + , type HasCallStack , callStack , prettySrcLoc , currentCallStack , getCallStack , prettyCallStack + , withFrozenCallStack ) +#if ( __GLASGOW_HASKELL__ >= 710 ) +import GHC.TypeLits as X ( + Symbol + , SomeSymbol(..) + , Nat + , SomeNat(..) + , CmpNat + , KnownSymbol + , KnownNat + , natVal + , someNatVal + , symbolVal + , someSymbolVal + ) +#endif + +-- Pending GHC 8.2 we'll expose these. + {- import GHC.Records as X ( HasField(..) ) --} import Data.Kind as X ( type (*) , type Type ) +-} + #endif +-- Default Prelude defines this at the toplevel module, so we do as well. infixr 0 $! ($!) :: (a -> b) -> a -> b diff --git a/src/Bool.hs b/src/Bool.hs --- a/src/Bool.hs +++ b/src/Bool.hs @@ -7,11 +7,16 @@ , ifM , guardM , bool +, (&&^) +, (||^) +, (<&&>) +, (<||>) ) where -import Data.Bool (Bool) +import Data.Bool (Bool(..), (&&), (||)) import Data.Function (flip) -import Control.Monad (Monad, MonadPlus, when, unless, guard, (>>=), (=<<)) +import Control.Applicative(Applicative, liftA2) +import Control.Monad (Monad, MonadPlus, return, when, unless, guard, (>>=), (=<<)) bool :: a -> a -> Bool -> a bool f t p = if p then t else f @@ -29,3 +34,31 @@ guardM :: MonadPlus m => m Bool -> m () guardM f = guard =<< f + +-- | The '||' operator lifted to a monad. If the first +-- argument evaluates to 'True' the second argument will not +-- be evaluated. +infixr 2 ||^ -- same as (||) +(||^) :: Monad m => m Bool -> m Bool -> m Bool +(||^) a b = ifM a (return True) b + +infixr 2 <||> +-- | '||' lifted to an Applicative. +-- Unlike '||^' the operator is __not__ short-circuiting. +(<||>) :: Applicative a => a Bool -> a Bool -> a Bool +(<||>) = liftA2 (||) +{-# INLINE (<||>) #-} + +-- | The '&&' operator lifted to a monad. If the first +-- argument evaluates to 'False' the second argument will not +-- be evaluated. +infixr 3 &&^ -- same as (&&) +(&&^) :: Monad m => m Bool -> m Bool -> m Bool +(&&^) a b = ifM a b (return False) + +infixr 3 <&&> +-- | '&&' lifted to an Applicative. +-- Unlike '&&^' the operator is __not__ short-circuiting. +(<&&>) :: Applicative a => a Bool -> a Bool -> a Bool +(<&&>) = liftA2 (&&) +{-# INLINE (<&&>) #-} diff --git a/src/CallStack.hs b/src/CallStack.hs new file mode 100644 --- /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 --- a/src/Debug.hs +++ b/src/Debug.hs @@ -3,7 +3,6 @@ module Debug ( undefined, - error, trace, traceM, traceId, @@ -18,26 +17,24 @@ import Control.Monad (Monad, return) import qualified Base as P -import Show (Print, putStrLn) +import Error (error) +import Show (Print, hPutStrLn) +import System.IO(stderr) import System.IO.Unsafe (unsafePerformIO) {-# WARNING trace "'trace' remains in code" #-} trace :: Print b => b -> a -> a trace string expr = unsafePerformIO (do - putStrLn string + hPutStrLn stderr string return expr) {-# WARNING traceIO "'traceIO' remains in code" #-} traceIO :: Print b => b -> a -> P.IO a traceIO string expr = do - putStrLn string + hPutStrLn stderr 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 @@ -54,12 +51,12 @@ traceM :: (Monad m) => Text -> m () traceM s = trace (unpack s) (return ()) -{-# WARNING traceId "'traceM' remains in code" #-} +{-# WARNING traceId "'traceId' remains in code" #-} 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/Either.hs b/src/Either.hs --- a/src/Either.hs +++ b/src/Either.hs @@ -6,6 +6,7 @@ , maybeToRight , leftToMaybe , rightToMaybe +, maybeEmpty , maybeToEither ) where @@ -26,5 +27,9 @@ maybeToLeft :: r -> Maybe l -> Either l r maybeToLeft r = maybe (Right r) Left -maybeToEither :: Monoid b => (a -> b) -> Maybe a -> b -maybeToEither = maybe mempty +maybeEmpty :: Monoid b => (a -> b) -> Maybe a -> b +maybeEmpty = maybe mempty + +maybeToEither :: e -> Maybe a -> Either e a +maybeToEither e Nothing = Left e +maybeToEither _ (Just a) = Right a diff --git a/src/Error.hs b/src/Error.hs new file mode 100644 --- /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/Exceptions.hs b/src/Exceptions.hs --- a/src/Exceptions.hs +++ b/src/Exceptions.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -21,8 +22,14 @@ hush (Left _) = empty hush (Right x) = pure x +-- To suppress redundenet applicative constraint warning on GHC 8.0 +#if ( __GLASGOW_HASKELL__ >= 800 ) +note :: (MonadError e m) => e -> Maybe a -> m a +note err = maybe (throwError err) pure +#else note :: (MonadError e m, Applicative m) => e -> Maybe a -> m a note err = maybe (throwError err) pure +#endif tryIO :: MonadIO m => IO a -> ExceptT IOException m a tryIO = ExceptT . liftIO . Exception.try diff --git a/src/Functor.hs b/src/Functor.hs --- a/src/Functor.hs +++ b/src/Functor.hs @@ -6,10 +6,13 @@ Functor(..), ($>), (<$>), + (<<$>>), void, ) where -#if (__GLASGOW_HASKELL__ >= 710) +import Data.Function ((.)) + +#if MIN_VERSION_base(4,7,0) import Data.Functor ( Functor(..) , ($>) @@ -23,16 +26,17 @@ ) import Data.Function (flip) -import Data.Function ((.)) infixl 4 $> ($>) :: Functor f => f a -> b -> f b ($>) = flip (<$) -(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) -(<<$>>) = fmap . fmap - void :: Functor f => f a -> f () void x = () <$ x #endif + +infixl 4 <<$>> + +(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) +(<<$>>) = fmap . fmap diff --git a/src/List.hs b/src/List.hs --- a/src/List.hs +++ b/src/List.hs @@ -16,12 +16,12 @@ import Data.Foldable (Foldable, foldr, foldl') import Data.Function ((.)) import Data.Functor (fmap) -import Control.Monad (return) +import Control.Applicative (pure) import qualified Data.Set as Set import GHC.Num (Num, (+), (*)) head :: (Foldable f) => f a -> Maybe a -head = foldr (\x _ -> return x) Nothing +head = foldr (\x _ -> pure x) Nothing sortOn :: (Ord o) => (a -> o) -> [a] -> [a] sortOn = sortBy . comparing diff --git a/src/Monad.hs b/src/Monad.hs --- a/src/Monad.hs +++ b/src/Monad.hs @@ -42,12 +42,7 @@ import Base (seq) import Data.List (concat) - -#if (__GLASGOW_HASKELL__ >= 710) -import Control.Monad hiding ((<$!>)) -#else import Control.Monad -#endif concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] concatMapM f xs = liftM concat (mapM f xs) @@ -64,9 +59,11 @@ z `seq` return z {-# INLINE liftM2' #-} +#if !MIN_VERSION_base(4,8,0) (<$!>) :: Monad m => (a -> b) -> m a -> m b f <$!> m = do x <- m let z = f x z `seq` return z {-# INLINE (<$!>) #-} +#endif diff --git a/src/Panic.hs b/src/Panic.hs --- 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,13 +14,14 @@ 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. -data FatalError = FatalError { msg :: Text } +data FatalError = FatalError { fatalErrorMessage :: Text } deriving (Show, Typeable) 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 --- a/src/Protolude.hs +++ b/src/Protolude.hs @@ -10,22 +10,28 @@ module Base, identity, map, - (&), uncons, unsnoc, applyN, print, throwIO, throwTo, - foreach, + foreach, (<&>), show, pass, guarded, guardedA, LText, LByteString, + liftIO1, + liftIO2, +#if !MIN_VERSION_base(4,8,0) + (&), +#endif + die, ) where +-- Protolude module exports. import List as X import Show as X import Bool as X @@ -37,13 +43,12 @@ import Conv as X import Panic as X import Exceptions as X +import Semiring as X 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. @@ -71,6 +76,8 @@ , lastMay , foldr1May , foldl1May + , maximumMay + , minimumMay , atMay , atDef ) @@ -89,8 +96,15 @@ ) -- Base typeclasses -import Data.Eq as X -import Data.Ord as X +import Data.Eq as X ( + Eq(..) + ) +import Data.Ord as X ( + Ord(..) + , Ordering(..) + , Down(..) + , comparing + ) import Data.Traversable as X import Data.Foldable as X hiding ( foldr1 @@ -98,20 +112,35 @@ , product , sum ) -import Semiring as X -import Data.Functor.Identity as X +import Data.Functor.Identity as X ( + Identity(..) + ) -#if ( __GLASGOW_HASKELL__ >= 800 ) -import Data.Monoid as X hiding ((<>)) -import Data.Semigroup as X ( Semigroup(..) ) -#else -import Data.Monoid as X +#if MIN_VERSION_base(4,9,0) +import Data.List.NonEmpty as X ( + NonEmpty(..) + , nonEmpty + ) +import Data.Semigroup as X ( + Semigroup(sconcat, stimes) + , WrappedMonoid + , Option(..) + , option + , diff + , cycle1 + , stimesMonoid + , stimesIdempotent + , stimesIdempotentMonoid + , mtimesDefault + ) #endif -#if (__GLASGOW_HASKELL__ >= 710) -import Data.Bifunctor as X (Bifunctor(..)) -#else +import Data.Monoid as X + +#if !MIN_VERSION_base(4,8,0) import Bifunctor as X (Bifunctor(..)) +#else +import Data.Bifunctor as X (Bifunctor(..)) #endif -- Deepseq @@ -123,7 +152,14 @@ ) -- Data structures -import Data.Tuple as X +import Data.Tuple as X ( + fst + , snd + , curry + , uncurry + , swap + ) + import Data.List as X ( splitAt , break @@ -153,15 +189,29 @@ , tails , zipWith , zip + , unzip + , genericLength + , genericTake + , genericDrop + , genericSplitAt + , genericReplicate ) +-- Hashing +import Data.Hashable as X ( + Hashable + , hash + , hashWithSalt + , hashUsing + ) + import Data.Map as X (Map) import Data.Set as X (Set) import Data.Sequence as X (Seq) import Data.IntMap as X (IntMap) import Data.IntSet as X (IntSet) -#if ( __GLASGOW_HASKELL__ >= 710 ) +#if MIN_VERSION_base(4,7,0) import Data.Proxy as X ( Proxy(..) ) @@ -177,6 +227,7 @@ import Data.Type.Coercion as X ( Coercion(..) , coerceWith + , repr ) import Data.Type.Equality as X ( @@ -188,6 +239,9 @@ , gcastWith ) +#endif + +#if MIN_VERSION_base(4,8,0) import Data.Void as X ( Void , absurd @@ -199,7 +253,7 @@ import Control.Monad.State as X ( MonadState , State - , StateT + , StateT(StateT) , put , get , gets @@ -219,7 +273,7 @@ import Control.Monad.Reader as X ( MonadReader , Reader - , ReaderT + , ReaderT(ReaderT) , ask , asks , local @@ -231,7 +285,7 @@ import Control.Monad.Except as X ( MonadError , Except - , ExceptT + , ExceptT(ExceptT) , throwError , catchError , runExcept @@ -245,14 +299,53 @@ ) -- Base types -import Data.Int as X +import Data.Int as X ( + Int + , Int8 + , Int16 + , Int32 + , Int64 + ) import Data.Bits as X hiding ( unsafeShiftL , unsafeShiftR ) -import Data.Word as X -import Data.Either as X -import Data.Complex as X +import Data.Word as X ( + Word + , Word8 + , Word16 + , Word32 + , Word64 +#if MIN_VERSION_base(4,7,0) + , byteSwap16 + , byteSwap32 + , byteSwap64 +#endif + ) + +import Data.Either as X ( + Either(..) + , either + , lefts + , rights + , partitionEithers +#if MIN_VERSION_base(4,7,0) + , isLeft + , isRight +#endif + ) + +import Data.Complex as X ( + Complex(..) + , realPart + , imagPart + , mkPolar + , cis + , polar + , magnitude + , phase + , conjugate + ) import Data.Char as X (chr) import Data.Bool as X hiding (bool) import Data.Maybe as X hiding (fromJust) @@ -264,11 +357,15 @@ , flip , fix , on +#if MIN_VERSION_base(4,8,0) + , (&) +#endif ) -- Genericss import GHC.Generics as X ( Generic(..) + , Generic1 , Rep , K1(..) , M1(..) @@ -277,14 +374,19 @@ , D1 , C1 , S1 - , (:+:) - , (:*:) + , (:+:)(..) + , (:*:)(..) + , (:.:)(..) , Rec0 , Constructor(..) + , Datatype(..) , Selector(..) , Fixity(..) + , Associativity(..) #if ( __GLASGOW_HASKELL__ >= 800 ) , Meta(..) + , FixityI(..) + , URec #endif ) @@ -317,9 +419,25 @@ , decodeUtf8With ) +import Data.Text.Encoding.Error as X ( + OnDecodeError + , OnError + , UnicodeException + , lenientDecode + , strictDecode + , ignore + , replace + ) + -- IO -import System.Exit as X import System.Environment as X (getArgs) +import qualified System.Exit +import System.Exit as X ( + ExitCode(..) + , exitWith + , exitFailure + , exitSuccess + ) import System.IO as X ( Handle , FilePath @@ -332,7 +450,11 @@ ) -- ST -import Control.Monad.ST as X +import Control.Monad.ST as X ( + ST + , runST + , fixST + ) -- Concurrency and Parallelism import Control.Exception as X hiding ( @@ -340,20 +462,61 @@ , throwIO , throwTo , assert - , displayException , Handler(..) ) import qualified Control.Exception -import Control.Monad.STM as X +import Control.Monad.STM as X ( + STM + , atomically + , always + , alwaysSucceeds + , retry + , orElse + , check + , throwSTM + , catchSTM + ) import Control.Concurrent as X hiding ( throwTo , yield ) -import Control.Concurrent.Async as X +import Control.Concurrent.Async as X ( + Async(..) + , Concurrently(..) + , async + , asyncBound + , asyncOn + , withAsync + , withAsyncBound + , withAsyncOn + , wait + , poll + , waitCatch + , cancel + , cancelWith + , asyncThreadId + , waitAny + , waitAnyCatch + , waitAnyCancel + , waitAnyCatchCancel + , waitEither + , waitEitherCatch + , waitEitherCancel + , waitEitherCatchCancel + , waitEither_ + , waitBoth + , link + , link2 + , race + , race_ + , concurrently + ) +import Foreign.Ptr as X (IntPtr, WordPtr) import Foreign.Storable as X (Storable) +import Foreign.StablePtr as X (StablePtr) -- Read instances hiding unsafe builtins (read) import Text.Read as X ( @@ -367,10 +530,13 @@ type LText = Data.Text.Lazy.Text type LByteString = Data.ByteString.Lazy.ByteString + +#if !MIN_VERSION_base(4,8,0) infixl 1 & (&) :: a -> (a -> b) -> b x & f = f x +#endif identity :: a -> a identity x = x @@ -379,7 +545,7 @@ map = fmap uncons :: [a] -> Maybe (a, [a]) -uncons [] = Nothing +uncons [] = Nothing uncons (x:xs) = Just (x, xs) unsnoc :: [x] -> Maybe ([x],x) @@ -404,6 +570,14 @@ 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 () @@ -413,6 +587,14 @@ guardedA :: (Functor f, Alternative t) => (a -> f Bool) -> a -> f (t a) guardedA p x = X.bool empty (pure x) <$> p x +-- | Lift an 'IO' operation with 1 argument into another monad +liftIO1 :: MonadIO m => (a -> IO b) -> a -> m b +liftIO1 = (.) liftIO + +-- | Lift an 'IO' operation with 2 arguments into another monad +liftIO2 :: MonadIO m => (a -> b -> IO c) -> a -> b -> m c +liftIO2 = ((.).(.)) liftIO + show :: (Show a, StringConv String b) => a -> b show x = toS (PBase.show x) {-# SPECIALIZE show :: Show a => a -> Text #-} @@ -420,3 +602,11 @@ {-# SPECIALIZE show :: Show a => a -> ByteString #-} {-# SPECIALIZE show :: Show a => a -> LByteString #-} {-# SPECIALIZE show :: Show a => a -> String #-} + +#if MIN_VERSION_base(4,8,0) +die :: Text -> IO a +die err = System.Exit.die (toS err) +#else +die :: Text -> IO a +die err = hPutStrLn stderr err >> exitFailure +#endif diff --git a/src/Show.hs b/src/Show.hs --- a/src/Show.hs +++ b/src/Show.hs @@ -9,9 +9,12 @@ Print(..), putText, putLText, + putByteString, + putLByteString, ) where import qualified Base +import qualified System.IO as Base import Data.Function ((.)) import Control.Monad.IO.Class (MonadIO, liftIO) @@ -24,30 +27,36 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.IO as TL +import System.IO (Handle, stdout) + class Print a where + hPutStr :: MonadIO m => Handle -> a -> m () putStr :: MonadIO m => a -> m () + putStr = hPutStr stdout + hPutStrLn :: MonadIO m => Handle -> a -> m () putStrLn :: MonadIO m => a -> m () + putStrLn = hPutStrLn stdout instance Print T.Text where - putStr = liftIO . T.putStr - putStrLn = liftIO . T.putStrLn + hPutStr = \h -> liftIO . T.hPutStr h + hPutStrLn = \h -> liftIO . T.hPutStrLn h instance Print TL.Text where - putStr = liftIO . TL.putStr - putStrLn = liftIO . TL.putStrLn + hPutStr = \h -> liftIO . TL.hPutStr h + hPutStrLn = \h -> liftIO . TL.hPutStrLn h instance Print BS.ByteString where - putStr = liftIO . BS.putStr - putStrLn = liftIO . BS.putStrLn + hPutStr = \h -> liftIO . BS.hPutStr h + hPutStrLn = \h -> liftIO . BS.hPutStrLn h instance Print BL.ByteString where - putStr = liftIO . BL.putStr - putStrLn = liftIO . BL.putStrLn + hPutStr = \h -> liftIO . BL.hPutStr h + hPutStrLn = \h -> liftIO . BL.hPutStrLn h instance Print [Base.Char] where - putStr = liftIO . Base.putStr - putStrLn = liftIO . Base.putStrLn + hPutStr = \h -> liftIO . Base.hPutStr h + hPutStrLn = \h -> liftIO . Base.hPutStrLn h -- For forcing type inference putText :: MonadIO m => T.Text -> m () @@ -57,3 +66,11 @@ putLText :: MonadIO m => TL.Text -> m () putLText = putStrLn {-# SPECIALIZE putLText :: TL.Text -> Base.IO () #-} + +putByteString :: MonadIO m => BS.ByteString -> m () +putByteString = putStrLn +{-# SPECIALIZE putByteString :: BS.ByteString -> Base.IO () #-} + +putLByteString :: MonadIO m => BL.ByteString -> m () +putLByteString = putStrLn +{-# SPECIALIZE putLByteString :: BL.ByteString -> Base.IO () #-}