diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,22 @@ +0.4 +=== + +* Add _haddock_ documentation with 100% coverage. +* Rewrite README tutorial. +* [#37](https://github.com/serokell/universum/issues/37): + Add generalized version of `readEither`. +* [#38](https://github.com/serokell/universum/issues/38): + Add `evaluateNF`, `evaluateNF_`, `evaluateWHNF`, `evaluateWHNF_`. +* [#39](https://github.com/serokell/universum/issues/39): + Add lifted versions of `IORef` functions. +* Remove `foreach` +* Reexport `(&&&)` from `Control.Arrow`. +* Add lifted version of `readTVarIO`. +* `interact` and `getContents` work with _Lazy Text_. +* Reexport `MaybeT`, `maybeToExceptT`, `exceptToMaybeT`. + 0.3 -===== +=== * [#28](https://github.com/serokell/universum/issues/28): Remove `putByteString` and `putLByteString`. diff --git a/src/Applicative.hs b/src/Applicative.hs --- a/src/Applicative.hs +++ b/src/Applicative.hs @@ -1,12 +1,20 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE Safe #-} +-- | Convenient utils to work with 'Applicative'. There were more functions in this module +-- (see ) +-- but only convenient ans most used are left. + module Applicative ( pass ) where import Control.Applicative (Applicative (pure)) +-- | Shorter alias for @pure ()@. +-- +-- >>> pass :: Maybe () +-- Just () pass :: Applicative f => f () pass = pure () diff --git a/src/Base.hs b/src/Base.hs --- a/src/Base.hs +++ b/src/Base.hs @@ -1,56 +1,57 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE Unsafe #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE Unsafe #-} +-- | Reexports from @GHC.*@ modules of +-- package. + module Base - ( module X + ( module GHC.Base + , module GHC.Enum + , module GHC.Err + , module GHC.Exts + , module GHC.Float + , module GHC.Num + , module GHC.Real + , module GHC.Show + , module GHC.TypeLits + , module GHC.Types + +#if ( __GLASGOW_HASKELL__ >= 800 ) + , module GHC.OverloadedLabels + , module GHC.ExecutionStack + , module GHC.Stack +#endif + , ($!) ) where --- Glorious Glasgow Haskell Compiler -#if defined(__GLASGOW_HASKELL__) && ( __GLASGOW_HASKELL__ >= 600 ) - -- Base GHC types -import GHC.Base as X (String, asTypeOf, maxInt, minInt, ord, seq, - (++)) -import GHC.Enum as X (Bounded (..), Enum (..), boundedEnumFrom, - boundedEnumFromThen) -import GHC.Err as X (error, undefined) -import GHC.Exts as X (Constraint, FunPtr, Ptr) -import GHC.Float as X (Double (..), Float (..), Floating (..), - showFloat, showSignedFloat) -import GHC.Num as X (Integer, Num (..), subtract) -import GHC.Real as X hiding ((%)) -import GHC.Show as X (Show (..)) -import System.IO as X (print, putStr, putStrLn) - -import GHC.Types as X (Bool, Char, IO, Int, Ordering, Word) +import GHC.Base (String, asTypeOf, maxInt, minInt, ord, seq, (++)) +import GHC.Enum (Bounded (..), Enum (..), boundedEnumFrom, + boundedEnumFromThen) +import GHC.Err (error, undefined) +import GHC.Exts (Constraint, FunPtr, Ptr) +import GHC.Float (Double (..), Float (..), Floating (..), showFloat, + showSignedFloat) +import GHC.Num (Integer, Num (..), subtract) +import GHC.Real hiding ((%)) +import GHC.Show (Show (..)) +import GHC.TypeLits (CmpNat, KnownNat, KnownSymbol, Nat, SomeNat (..), + SomeSymbol (..), Symbol, natVal, someNatVal, + someSymbolVal, symbolVal) +import GHC.Types (Bool, Char, Coercible, IO, Int, Ordering, Word) -#if ( __GLASGOW_HASKELL__ >= 710 ) -import GHC.Types as X (Coercible) -#endif - -#if ( __GLASGOW_HASKELL__ >= 710 ) -import GHC.StaticPtr as X (StaticPtr) -#endif - #if ( __GLASGOW_HASKELL__ >= 800 ) -import GHC.OverloadedLabels as X (IsLabel (..)) - -import GHC.ExecutionStack as X (Location (..), SrcLoc (..), getStackTrace, - showStackTrace) +import GHC.OverloadedLabels (IsLabel (..)) -import GHC.Stack as X (CallStack, HasCallStack, callStack, - currentCallStack, getCallStack, - prettyCallStack, prettySrcLoc, - withFrozenCallStack) +import GHC.ExecutionStack (Location (..), SrcLoc (..), getStackTrace, + showStackTrace) -#if ( __GLASGOW_HASKELL__ >= 710 ) -import GHC.TypeLits as X (CmpNat, KnownNat, KnownSymbol, Nat, - SomeNat (..), SomeSymbol (..), Symbol, natVal, - someNatVal, someSymbolVal, symbolVal) +import GHC.Stack (CallStack, HasCallStack, callStack, + currentCallStack, getCallStack, prettyCallStack, + prettySrcLoc, withFrozenCallStack) #endif -- Pending GHC 8.2 we'll expose these. @@ -68,12 +69,15 @@ ) -} -#endif +-- | Stricter version of 'Data.Function.$' operator. -- Default Prelude defines this at the toplevel module, so we do as well. -infixr 0 $! - +-- +-- >>> const 3 $ undefined +-- 3 +-- >>> const 3 $! undefined +-- CallStack (from HasCallStack): +-- error, called at libraries/base/GHC/Err.hs:79:14 in base:GHC.Err ($!) :: (a -> b) -> a -> b -f $! x = let !vx = x in f vx - -#endif +f $! x = let !vx = x in f vx +infixr 0 $! diff --git a/src/Bifunctor.hs b/src/Bifunctor.hs deleted file mode 100644 --- a/src/Bifunctor.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE Safe #-} - -module Bifunctor - ( Bifunctor (..) - ) where - -import Control.Applicative (Const (..)) -import Data.Either (Either (..)) -import Data.Function (id, (.)) - -class Bifunctor p where - {-# MINIMAL bimap | first, second #-} - - bimap :: (a -> b) -> (c -> d) -> p a c -> p b d - bimap f g = first f . second g - - first :: (a -> b) -> p a c -> p b c - first f = bimap f id - - second :: (b -> c) -> p a b -> p a c - second = bimap id - -instance Bifunctor (,) where - bimap f g ~(a, b) = (f a, g b) - -instance Bifunctor Either where - bimap f _ (Left a) = Left (f a) - bimap _ g (Right b) = Right (g b) - -instance Bifunctor Const where - bimap f _ (Const a) = Const (f a) diff --git a/src/Bool.hs b/src/Bool.hs --- a/src/Bool.hs +++ b/src/Bool.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE Safe #-} +-- | Convenient commonly used and very helpful functions to work with 'Bool'. + module Bool ( whenM , unlessM @@ -12,17 +13,43 @@ import Data.Bool (Bool) import Data.Function (flip) +-- | Reversed version of @if-then-else@. +-- +-- >>> bool 5 10 True +-- 10 +-- >>> bool 5 10 False +-- 5 bool :: a -> a -> Bool -> a bool f t p = if p then t else f +-- | Monadic version of 'when'. +-- +-- >>> whenM (pure False) $ putText "No text :(" +-- >>> whenM (pure True) $ putText "Yes text :)" +-- Yes text :) +-- >>> whenM (Just True) (pure ()) +-- Just () +-- >>> whenM (Just False) (pure ()) +-- Just () +-- >>> whenM Nothing (pure ()) +-- Nothing whenM :: Monad m => m Bool -> m () -> m () -whenM p m = - p >>= flip when m +whenM p m = p >>= flip when m +{-# INLINE whenM #-} +-- | Monadic version of 'unless'. +-- +-- >>> unlessM (pure False) $ putText "No text :(" +-- No text :( +-- >>> unlessM (pure True) $ putText "Yes text :)" unlessM :: Monad m => m Bool -> m () -> m () -unlessM p m = - p >>= flip unless m +unlessM p m = p >>= flip unless m +{-# INLINE unlessM #-} +-- | Monadic version of @if-then-else@. +-- +-- >>> ifM (pure True) (putText "True text") (putText "False text") +-- True text ifM :: Monad m => m Bool -> m a -> m a -> m a ifM p x y = p >>= \b -> if b then x else y diff --git a/src/Concurrent.hs b/src/Concurrent.hs deleted file mode 100644 --- a/src/Concurrent.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE Safe #-} - --- | Concurrency useful and common functions. -module Concurrent - ( -- * MVar - MVar - , newEmptyMVar - , newMVar - , putMVar - , readMVar - , swapMVar - , takeMVar - , tryPutMVar - , tryReadMVar - , tryTakeMVar - - -- * STM - , STM - , TVar - , atomically - , newTVarIO - , STM.modifyTVar' - , STM.newTVar - , STM.readTVar - , STM.writeTVar - ) where - - -import qualified Control.Concurrent.MVar as CCM (newEmptyMVar, newMVar, putMVar, - readMVar, swapMVar, takeMVar, - tryPutMVar, tryReadMVar, tryTakeMVar) -import qualified Control.Concurrent.STM.TVar as STM (modifyTVar', newTVar, newTVarIO, - readTVar, writeTVar) -import qualified Control.Monad.STM as STM (atomically) - -import Control.Concurrent.MVar (MVar) -import Control.Concurrent.STM.TVar (TVar) -import Control.Monad.STM (STM) -import Control.Monad.Trans (MonadIO, liftIO) -import Data.Bool (Bool) -import Data.Function (($), (.)) -import Data.Maybe (Maybe) - ----------------------------------------------------------------------------- --- Lifted Control.Concurrent.MVar ----------------------------------------------------------------------------- - --- | Lifted to 'MonadIO' version of 'CCM.newEmptyMVar'. -newEmptyMVar :: MonadIO m => m (MVar a) -newEmptyMVar = liftIO CCM.newEmptyMVar -{-# INLINABLE newEmptyMVar #-} - --- | Lifted to 'MonadIO' version of 'CCM.newMVar'. -newMVar :: MonadIO m => a -> m (MVar a) -newMVar = liftIO . CCM.newMVar -{-# INLINABLE newMVar #-} - --- | Lifted to 'MonadIO' version of 'CCM.putMVar'. -putMVar :: MonadIO m => MVar a -> a -> m () -putMVar m a = liftIO $ CCM.putMVar m a -{-# INLINABLE putMVar #-} - --- | Lifted to 'MonadIO' version of 'CCM.readMVar'. -readMVar :: MonadIO m => MVar a -> m a -readMVar = liftIO . CCM.readMVar -{-# INLINABLE readMVar #-} - --- | Lifted to 'MonadIO' version of 'CCM.swapMVar'. -swapMVar :: MonadIO m => MVar a -> a -> m a -swapMVar m v = liftIO $ CCM.swapMVar m v -{-# INLINABLE swapMVar #-} - --- | Lifted to 'MonadIO' version of 'CCM.takeMVar'. -takeMVar :: MonadIO m => MVar a -> m a -takeMVar = liftIO . CCM.takeMVar -{-# INLINABLE takeMVar #-} - --- | Lifted to 'MonadIO' version of 'CCM.tryPutMVar'. -tryPutMVar :: MonadIO m => MVar a -> a -> m Bool -tryPutMVar m v = liftIO $ CCM.tryPutMVar m v -{-# INLINABLE tryPutMVar #-} - --- | Lifted to 'MonadIO' version of 'CCM.tryReadMVar'. -tryReadMVar :: MonadIO m => MVar a -> m (Maybe a) -tryReadMVar = liftIO . CCM.tryReadMVar -{-# INLINABLE tryReadMVar #-} - --- | Lifted to 'MonadIO' version of 'CCM.tryTakeMVar'. -tryTakeMVar :: MonadIO m => MVar a -> m (Maybe a) -tryTakeMVar = liftIO . CCM.tryTakeMVar -{-# INLINABLE tryTakeMVar #-} - ----------------------------------------------------------------------------- --- Lifted STM ----------------------------------------------------------------------------- - --- | Lifted to 'MonadIO' version of 'STM.atomically'. -atomically :: MonadIO m => STM a -> m a -atomically = liftIO . STM.atomically -{-# INLINABLE atomically #-} - --- | Lifted to 'MonadIO' version of 'STM.newTVarIO'. -newTVarIO :: MonadIO m => a -> m (TVar a) -newTVarIO = liftIO . STM.newTVarIO -{-# INLINABLE newTVarIO #-} diff --git a/src/Containers.hs b/src/Containers.hs --- a/src/Containers.hs +++ b/src/Containers.hs @@ -3,7 +3,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} @@ -11,6 +10,13 @@ {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} +-- | Reimagined approach for 'Foldable' type hierarchy. Forbids usages +-- of 'length' function and similar over 'Maybe' and other potentially unsafe +-- data types. It was proposed to use @-XTypeApplication@ for such cases. +-- But this approach is not robust enough because programmers are human and can +-- easily forget to do this. For discussion see this topic: +-- + module Containers ( -- * Foldable-like classes and methods @@ -80,6 +86,9 @@ -- Containers (e.g. tuples aren't containers) ---------------------------------------------------------------------------- +-- | Type of element for some container. Implemented as a type family because +-- some containers are monomorphic over element type (like 'T.Text', 'IS.IntSet', etc.) +-- so we can't implement nice interface using old higher-kinded types approach. type family Element t type instance Element (f a) = a @@ -89,10 +98,28 @@ type instance Element BSL.ByteString = Word8 type instance Element IS.IntSet = Int +-- | Type class for container. Fully compatible with 'Foldable'. +-- Contains very small and safe subset of 'Foldable' functions. class Container t where + -- | Convert container to list of elements. + -- + -- >>> toList (Just True) + -- [True] + -- >>> toList @Text "aba" + -- "aba" + -- >>> :t toList @Text "aba" + -- toList @Text "aba" :: [Char] toList :: t -> [Element t] + + -- | Checks whether container is empty. + -- + -- >>> null @Text "" + -- True + -- >>> null @Text "aba" + -- False null :: t -> Bool +-- | This instance makes 'Container' compatible and overlappable by 'Foldable'. instance {-# OVERLAPPABLE #-} Foldable f => Container (f a) where toList = F.toList {-# INLINE toList #-} @@ -371,44 +398,69 @@ -- Derivative functions ---------------------------------------------------------------------------- +-- | Stricter version of 'Prelude.sum'. +-- +-- >>> sum [1..10] +-- 55 +-- >>> sum (Just 3) +-- :43:1: error: +-- • Do not use 'Foldable' methods on Maybe +-- • In the expression: sum (Just 3) +-- In an equation for ‘it’: it = sum (Just 3) sum :: (NontrivialContainer t, Num (Element t)) => t -> Element t sum = foldl' (+) 0 +-- | Stricter version of 'Prelude.product'. +-- +-- >>> product [1..10] +-- 3628800 +-- >>> product (Right 3) +-- :45:1: error: +-- • Do not use 'Foldable' methods on Either +-- • In the expression: product (Right 3) +-- In an equation for ‘it’: it = product (Right 3) product :: (NontrivialContainer t, Num (Element t)) => t -> Element t product = foldl' (*) 1 +-- | Constrained to 'NonTrivialContainer' version of 'Data.Foldable.traverse_'. traverse_ :: (NontrivialContainer t, Applicative f) => (Element t -> f b) -> t -> f () traverse_ f = foldr ((*>) . f) pass +-- | Constrained to 'NonTrivialContainer' version of 'Data.Foldable.for_'. for_ :: (NontrivialContainer t, Applicative f) => t -> (Element t -> f b) -> f () for_ = flip traverse_ {-# INLINE for_ #-} +-- | Constrained to 'NonTrivialContainer' version of 'Data.Foldable.mapM_'. mapM_ :: (NontrivialContainer t, Monad m) => (Element t -> m b) -> t -> m () mapM_ f= foldr ((>>) . f) pass +-- | Constrained to 'NonTrivialContainer' version of 'Data.Foldable.forM_'. forM_ :: (NontrivialContainer t, Monad m) => t -> (Element t -> m b) -> m () forM_ = flip mapM_ {-# INLINE forM_ #-} +-- | Constrained to 'NonTrivialContainer' version of 'Data.Foldable.sequenceA_'. sequenceA_ :: (NontrivialContainer t, Applicative f, Element t ~ f a) => t -> f () sequenceA_ = foldr (*>) pass +-- | Constrained to 'NonTrivialContainer' version of 'Data.Foldable.sequence_'. sequence_ :: (NontrivialContainer t, Monad m, Element t ~ m a) => t -> m () sequence_ = foldr (>>) pass +-- | Constrained to 'NonTrivialContainer' version of 'Data.Foldable.asum'. asum :: (NontrivialContainer t, Alternative f, Element t ~ f a) => t -> f a @@ -470,6 +522,16 @@ -- One ---------------------------------------------------------------------------- +-- | Type class for types that can be created from one element. @singleton@ +-- is lone name for this function. Also constructions of different type differ: +-- @:[]@ for lists, two arguments for Maps. Also some data types are monomorphic. +-- +-- >>> one True :: [Bool] +-- [True] +-- >>> one 'a' :: Text +-- "a" +-- >>> one (3, "hello") :: HashMap Int String +-- fromList [(3,"hello")] class One x where type OneItem x -- | Create a list, map, 'Text', etc from a single element. diff --git a/src/Conv.hs b/src/Conv.hs --- a/src/Conv.hs +++ b/src/Conv.hs @@ -3,6 +3,8 @@ {-# LANGUAGE Safe #-} {-# LANGUAGE TypeSynonymInstances #-} +-- | Type classes for convertion between different string representations. + module Conv ( ConvertUtf8 (..) , ToString (..) @@ -25,9 +27,28 @@ import Data.String (String) import Functor ((<$>)) +-- | Type class for conversion to utf8 representation of text. class ConvertUtf8 a b where + -- | Encode as utf8 string (usually 'B.ByteString'). + -- + -- >>> encodeUtf8 @Text @ByteString "патак" + -- "\208\191\208\176\209\130\208\176\208\186" encodeUtf8 :: a -> b + + -- | Decode from utf8 string. + -- + -- >>> decodeUtf8 @Text @ByteString "\208\191\208\176\209\130\208\176\208\186" + -- "\1087\1072\1090\1072\1082" + -- >>> putStrLn $ decodeUtf8 @Text @ByteString "\208\191\208\176\209\130\208\176\208\186" + -- патак decodeUtf8 :: b -> a + + -- | Decode as utf8 string but returning execption if byte sequence is malformed. + -- + -- >>> decodeUtf8 @Text @ByteString "\208\208\176\209\130\208\176\208\186" + -- "\65533\65533\1090\1072\1082" + -- >>> decodeUtf8Strict @Text @ByteString "\208\208\176\209\130\208\176\208\186" + -- Left Cannot decode byte '\xd0': Data.Text.Internal.Encoding.decodeUtf8: Invalid UTF-8 stream decodeUtf8Strict :: b -> Either T.UnicodeException a instance ConvertUtf8 String B.ByteString where @@ -60,6 +81,7 @@ decodeUtf8 = LT.decodeUtf8With T.lenientDecode decodeUtf8Strict = LT.decodeUtf8' +-- | Type class for converting other strings to 'T.Text'. class ToText a where toText :: a -> T.Text @@ -72,6 +94,7 @@ instance ToText LT.Text where toText = LT.toStrict +-- | Type class for converting other strings to 'LT.Text'. class ToLText a where toLText :: a -> LT.Text @@ -84,6 +107,7 @@ instance ToLText LT.Text where toLText = id +-- | Type class for converting other strings to 'String'. class ToString a where toString :: a -> String diff --git a/src/Debug.hs b/src/Debug.hs --- a/src/Debug.hs +++ b/src/Debug.hs @@ -1,8 +1,11 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE Trustworthy #-} +-- | Functions for debugging. If you left these functions in your code +-- then warning is generated to remind you about left usages. Also some +-- functions (and data types) are convenient for prototyping. + module Debug ( undefined , error @@ -24,43 +27,52 @@ import qualified Base as P import qualified Prelude as P -import Show (Print, putStrLn) +import Print (Print, putStrLn) import Applicative (pass) +-- | Generalized over string version of 'Debug.Trace.trace' that leaves warnings. {-# WARNING trace "'trace' remains in code" #-} trace :: Print b => b -> a -> a trace string expr = unsafePerformIO (do putStrLn string return expr) +-- | 'P.error' that takes 'Text' as an argument. error :: Text -> a error s = P.error (unpack s) +-- | Version of 'Debug.Trace.traceShow' that leaves warning. {-# WARNING traceShow "'traceShow' remains in code" #-} traceShow :: P.Show a => a -> b -> b traceShow a b = trace (P.show a) b +-- | Version of 'Debug.Trace.traceShow' that leaves warning. {-# WARNING traceShowId "'traceShowId' remains in code" #-} traceShowId :: P.Show a => a -> a traceShowId a = trace (P.show a) a +-- | Version of 'Debug.Trace.traceShowM' that leaves warning. {-# WARNING traceShowM "'traceShowM' remains in code" #-} traceShowM :: (P.Show a, Monad m) => a -> m () traceShowM a = trace (P.show a) pass +-- | Version of 'Debug.Trace.traceM' that leaves warning and takes 'Text'. {-# WARNING traceM "'traceM' remains in code" #-} traceM :: (Monad m) => Text -> m () traceM s = trace (unpack s) pass +-- | Version of 'Debug.Trace.traceId' that leaves warning and takes 'Text'. {-# WARNING traceId "'traceId' remains in code" #-} traceId :: Text -> Text traceId s = trace s s +-- | Similar to 'undefined' but data type. {-# WARNING Undefined "'Undefined' type remains in code" #-} data Undefined = Undefined deriving (P.Eq, P.Ord, P.Show, P.Read, P.Enum, P.Bounded, Data, Typeable, Generic) +-- | 'P.undefined' that leaves warning in code on every usage. {-# WARNING undefined "'undefined' function remains in code (or use 'error')" #-} undefined :: a undefined = P.undefined diff --git a/src/Exceptions.hs b/src/Exceptions.hs --- a/src/Exceptions.hs +++ b/src/Exceptions.hs @@ -2,6 +2,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Safe #-} +-- | Some functions to work with exceptions over 'MonadError'. + module Exceptions ( Exception , SomeException (..) @@ -14,6 +16,8 @@ import Data.Maybe (Maybe, maybe) -- To suppress redundant applicative constraint warning on GHC 8.0 +-- | Throws error for 'Maybe' if 'Data.Maybe.Nothing' is given. +-- Operates over 'MonadError'. #if ( __GLASGOW_HASKELL__ >= 800 ) note :: (MonadError e m) => e -> Maybe a -> m a note err = maybe (throwError err) pure diff --git a/src/Functor.hs b/src/Functor.hs --- a/src/Functor.hs +++ b/src/Functor.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} +-- | Convenient functions to work with 'Functor'. + module Functor ( Functor (..) , void @@ -13,6 +14,10 @@ import Data.Function ((.)) import Data.Functor (Functor (..), void, ($>), (<$>)) -infixl 4 <<$>> +-- | Alias for @fmap . fmap@. Convenient to work with two nested 'Functor's. +-- +-- >>> negate <<$>> Just [1,2,3] +-- Just [-1,-2,-3] (<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) (<<$>>) = fmap . fmap +infixl 4 <<$>> diff --git a/src/Lifted.hs b/src/Lifted.hs --- a/src/Lifted.hs +++ b/src/Lifted.hs @@ -1,117 +1,25 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE Safe #-} +-- | Lifted versions of base functions. + module Lifted - ( -- * Text - appendFile - , getContents - , getLine - , interact - , readFile - , writeFile - -- * IO - , getArgs - , openFile - , exitWith - , exitFailure - , exitSuccess - , die - -- * ST + ( module Lifted.Concurrent + , module Lifted.Env + , module Lifted.File + , module Lifted.IORef + , stToIO ) where -#if ( __GLASGOW_HASKELL__ >= 710 ) -import Control.Monad.ST (RealWorld, ST) -#else -import Control.Monad.ST.Safe (RealWorld, ST) -#endif -import Control.Monad.Trans (MonadIO, liftIO) -import Data.String (String) -import Data.Text (Text) -import Prelude (FilePath, (>>)) -import System.Exit (ExitCode) -import System.IO (Handle, IOMode, stderr) -import qualified System.IO (hPutStrLn) - --- Text -import qualified Data.Text.IO as XIO --- IO -import qualified System.Environment as XIO -import qualified System.Exit as XIO -import qualified System.IO as XIO (openFile) --- ST -#if ( __GLASGOW_HASKELL__ >= 710 ) -import qualified Control.Monad.ST as XIO -#else -import qualified Control.Monad.ST.Safe as XIO -#endif - ----------------------------------------------------------------------------- --- Text ----------------------------------------------------------------------------- - -appendFile :: MonadIO m => FilePath -> Text -> m () -appendFile a b = liftIO (XIO.appendFile a b) -{-# INLINABLE appendFile #-} - -getContents :: MonadIO m => m Text -getContents = liftIO XIO.getContents -{-# INLINABLE getContents #-} - -getLine :: MonadIO m => m Text -getLine = liftIO XIO.getLine -{-# INLINABLE getLine #-} - -interact :: MonadIO m => (Text -> Text) -> m () -interact a = liftIO (XIO.interact a) -{-# INLINABLE interact #-} - -readFile :: MonadIO m => FilePath -> m Text -readFile a = liftIO (XIO.readFile a) -{-# INLINABLE readFile #-} - -writeFile :: MonadIO m => FilePath -> Text -> m () -writeFile a b = liftIO (XIO.writeFile a b) -{-# INLINABLE writeFile #-} - ----------------------------------------------------------------------------- --- IO ----------------------------------------------------------------------------- - -getArgs :: MonadIO m => m [String] -getArgs = liftIO (XIO.getArgs) -{-# INLINABLE getArgs #-} - -openFile :: MonadIO m => FilePath -> IOMode -> m Handle -openFile a b = liftIO (XIO.openFile a b) -{-# INLINABLE openFile #-} - --- 'withFile' can't be lifted into 'MonadIO', as it uses 'bracket' - -exitWith :: MonadIO m => ExitCode -> m a -exitWith a = liftIO (XIO.exitWith a) -{-# INLINABLE exitWith #-} - -exitFailure :: MonadIO m => m a -exitFailure = liftIO XIO.exitFailure -{-# INLINABLE exitFailure #-} - -exitSuccess :: MonadIO m => m a -exitSuccess = liftIO XIO.exitSuccess -{-# INLINABLE exitSuccess #-} - --- 'die' is available since base-4.8, but it's more convenient to --- redefine it instead of using CPP -die :: MonadIO m => String -> m () -die err = liftIO (System.IO.hPutStrLn stderr err) >> exitFailure -{-# INLINABLE die #-} +import Lifted.Concurrent +import Lifted.Env +import Lifted.File +import Lifted.IORef ----------------------------------------------------------------------------- --- ST ----------------------------------------------------------------------------- +import qualified Control.Monad.ST as XIO +import Control.Monad.Trans (MonadIO, liftIO) -stToIO :: MonadIO m => ST RealWorld a -> m a +-- | Lifted version of 'XIO.stToIO'. +stToIO :: MonadIO m => XIO.ST XIO.RealWorld a -> m a stToIO a = liftIO (XIO.stToIO a) -{-# INLINABLE stToIO #-} +{-# INLINE stToIO #-} diff --git a/src/Lifted/Concurrent.hs b/src/Lifted/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/Lifted/Concurrent.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE Safe #-} + +-- | Concurrency useful and common functions. + +module Lifted.Concurrent + ( -- * MVar + MVar + , newEmptyMVar + , newMVar + , putMVar + , readMVar + , swapMVar + , takeMVar + , tryPutMVar + , tryReadMVar + , tryTakeMVar + + -- * STM + , STM + , TVar + , atomically + , newTVarIO + , readTVarIO + , STM.modifyTVar' + , STM.newTVar + , STM.readTVar + , STM.writeTVar + ) where + + +import qualified Control.Concurrent.MVar as CCM (newEmptyMVar, newMVar, putMVar, + readMVar, swapMVar, takeMVar, + tryPutMVar, tryReadMVar, tryTakeMVar) +import qualified Control.Concurrent.STM.TVar as STM (modifyTVar', newTVar, newTVarIO, + readTVar, readTVarIO, writeTVar) +import qualified Control.Monad.STM as STM (atomically) + +import Control.Concurrent.MVar (MVar) +import Control.Concurrent.STM.TVar (TVar) +import Control.Monad.STM (STM) +import Control.Monad.Trans (MonadIO, liftIO) +import Data.Bool (Bool) +import Data.Function (($), (.)) +import Data.Maybe (Maybe) + +---------------------------------------------------------------------------- +-- Lifted Control.Concurrent.MVar +---------------------------------------------------------------------------- + +-- | Lifted to 'MonadIO' version of 'CCM.newEmptyMVar'. +newEmptyMVar :: MonadIO m => m (MVar a) +newEmptyMVar = liftIO CCM.newEmptyMVar +{-# INLINE newEmptyMVar #-} + +-- | Lifted to 'MonadIO' version of 'CCM.newMVar'. +newMVar :: MonadIO m => a -> m (MVar a) +newMVar = liftIO . CCM.newMVar +{-# INLINE newMVar #-} + +-- | Lifted to 'MonadIO' version of 'CCM.putMVar'. +putMVar :: MonadIO m => MVar a -> a -> m () +putMVar m a = liftIO $ CCM.putMVar m a +{-# INLINE putMVar #-} + +-- | Lifted to 'MonadIO' version of 'CCM.readMVar'. +readMVar :: MonadIO m => MVar a -> m a +readMVar = liftIO . CCM.readMVar +{-# INLINE readMVar #-} + +-- | Lifted to 'MonadIO' version of 'CCM.swapMVar'. +swapMVar :: MonadIO m => MVar a -> a -> m a +swapMVar m v = liftIO $ CCM.swapMVar m v +{-# INLINE swapMVar #-} + +-- | Lifted to 'MonadIO' version of 'CCM.takeMVar'. +takeMVar :: MonadIO m => MVar a -> m a +takeMVar = liftIO . CCM.takeMVar +{-# INLINE takeMVar #-} + +-- | Lifted to 'MonadIO' version of 'CCM.tryPutMVar'. +tryPutMVar :: MonadIO m => MVar a -> a -> m Bool +tryPutMVar m v = liftIO $ CCM.tryPutMVar m v +{-# INLINE tryPutMVar #-} + +-- | Lifted to 'MonadIO' version of 'CCM.tryReadMVar'. +tryReadMVar :: MonadIO m => MVar a -> m (Maybe a) +tryReadMVar = liftIO . CCM.tryReadMVar +{-# INLINE tryReadMVar #-} + +-- | Lifted to 'MonadIO' version of 'CCM.tryTakeMVar'. +tryTakeMVar :: MonadIO m => MVar a -> m (Maybe a) +tryTakeMVar = liftIO . CCM.tryTakeMVar +{-# INLINE tryTakeMVar #-} + +---------------------------------------------------------------------------- +-- Lifted STM +---------------------------------------------------------------------------- + +-- | Lifted to 'MonadIO' version of 'STM.atomically'. +atomically :: MonadIO m => STM a -> m a +atomically = liftIO . STM.atomically +{-# INLINE atomically #-} + +-- | Lifted to 'MonadIO' version of 'STM.newTVarIO'. +newTVarIO :: MonadIO m => a -> m (TVar a) +newTVarIO = liftIO . STM.newTVarIO +{-# INLINE newTVarIO #-} + +-- | Lifted to 'MonadIO' version of 'STM.readTVarIO'. +readTVarIO :: MonadIO m => TVar a -> m a +readTVarIO = liftIO . STM.readTVarIO +{-# INLINE readTVarIO #-} diff --git a/src/Lifted/Env.hs b/src/Lifted/Env.hs new file mode 100644 --- /dev/null +++ b/src/Lifted/Env.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE Safe #-} + +-- | Lifted versions of functions that work with environment. + +module Lifted.Env + ( getArgs + , exitWith + , exitFailure + , exitSuccess + , die + ) where + +import Control.Monad.Trans (MonadIO, liftIO) +import Data.String (String) +import Prelude ((>>)) +import qualified System.Environment as XIO +import System.Exit (ExitCode) +import qualified System.Exit as XIO +import System.IO (stderr) +import qualified System.IO (hPutStrLn) + +-- | Lifted version of 'System.Environment.getArgs'. +getArgs :: MonadIO m => m [String] +getArgs = liftIO (XIO.getArgs) +{-# INLINE getArgs #-} + +-- | Lifted version of 'System.Exit.exitWith'. +exitWith :: MonadIO m => ExitCode -> m a +exitWith a = liftIO (XIO.exitWith a) +{-# INLINE exitWith #-} + +-- | Lifted version of 'System.Exit.exitFailure'. +exitFailure :: MonadIO m => m a +exitFailure = liftIO XIO.exitFailure +{-# INLINE exitFailure #-} + +-- | Lifted version of 'System.Exit.exitSuccess'. +exitSuccess :: MonadIO m => m a +exitSuccess = liftIO XIO.exitSuccess +{-# INLINE exitSuccess #-} + +-- | Lifted version of 'System.Exit.die'. +-- 'XIO.die' is available since base-4.8, but it's more convenient to +-- redefine it instead of using CPP. +die :: MonadIO m => String -> m () +die err = liftIO (System.IO.hPutStrLn stderr err) >> exitFailure +{-# INLINE die #-} diff --git a/src/Lifted/File.hs b/src/Lifted/File.hs new file mode 100644 --- /dev/null +++ b/src/Lifted/File.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} + +-- | Lifted versions of functions working with files and common IO. +-- All functions are specialized to 'Data.Text.Text'. + +module Lifted.File + ( appendFile + , getContents + , getLine + , interact + , openFile + , readFile + , writeFile + ) where + +import Control.Monad.Trans (MonadIO, liftIO) +import Data.Text (Text) +import qualified Data.Text.IO as XIO +import qualified Data.Text.Lazy as L (Text) +import qualified Data.Text.Lazy.IO as LIO (getContents, interact) +import Prelude (FilePath) +import System.IO (Handle, IOMode) +import qualified System.IO as XIO (openFile) + +---------------------------------------------------------------------------- +-- Text +---------------------------------------------------------------------------- + +-- | Lifted version of 'Data.Text.appendFile'. +appendFile :: MonadIO m => FilePath -> Text -> m () +appendFile a b = liftIO (XIO.appendFile a b) +{-# INLINE appendFile #-} + +-- | Lifted version of 'Data.Text.getContents'. +getContents :: MonadIO m => m L.Text +getContents = liftIO LIO.getContents +{-# INLINE getContents #-} + +-- | Lifted version of 'Data.Text.getLine'. +getLine :: MonadIO m => m Text +getLine = liftIO XIO.getLine +{-# INLINE getLine #-} + +-- | Lifted version of 'Data.Text.interact'. +interact :: MonadIO m => (L.Text -> L.Text) -> m () +interact a = liftIO (LIO.interact a) +{-# INLINE interact #-} + +-- | Lifted version of 'Data.Text.readFile'. +readFile :: MonadIO m => FilePath -> m Text +readFile a = liftIO (XIO.readFile a) +{-# INLINE readFile #-} + +-- | Lifted version of 'Data.Text.writeFile'. +writeFile :: MonadIO m => FilePath -> Text -> m () +writeFile a b = liftIO (XIO.writeFile a b) +{-# INLINE writeFile #-} + +-- | Lifted version of 'System.IO.openFile'. +openFile :: MonadIO m => FilePath -> IOMode -> m Handle +openFile a b = liftIO (XIO.openFile a b) +{-# INLINE openFile #-} + +-- 'withFile' can't be lifted into 'MonadIO', as it uses 'bracket' diff --git a/src/Lifted/IORef.hs b/src/Lifted/IORef.hs new file mode 100644 --- /dev/null +++ b/src/Lifted/IORef.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE Safe #-} + +-- | Lifted reexports from 'Data.IORef' module. + +module Lifted.IORef + ( IORef + , atomicModifyIORef + , atomicModifyIORef' + , atomicWriteIORef + , modifyIORef + , modifyIORef' + , newIORef + , readIORef + , writeIORef + ) where + +import qualified Data.IORef as Ref (atomicModifyIORef, atomicModifyIORef', + atomicWriteIORef, modifyIORef, modifyIORef', + newIORef, readIORef, writeIORef) + +import Control.Monad.Trans (MonadIO, liftIO) +import Data.Function (($), (.)) +import Data.IORef (IORef) + +-- | Lifted version of 'Ref.newIORef'. +newIORef :: MonadIO m => a -> m (IORef a) +newIORef = liftIO . Ref.newIORef +{-# INLINE newIORef #-} + +-- | Lifted version of 'Ref.readIORef'. +readIORef :: MonadIO m => IORef a -> m a +readIORef = liftIO . Ref.readIORef +{-# INLINE readIORef #-} + +-- | Lifted version of 'Ref.writeIORef'. +writeIORef :: MonadIO m => IORef a -> a -> m () +writeIORef ref what = liftIO $ Ref.writeIORef ref what +{-# INLINE writeIORef #-} + +-- | Lifted version of 'Ref.modifyIORef'. +modifyIORef :: MonadIO m => IORef a -> (a -> a) -> m () +modifyIORef ref how = liftIO $ Ref.modifyIORef ref how +{-# INLINE modifyIORef #-} + +-- | Lifted version of 'Ref.modifyIORef''. +modifyIORef' :: MonadIO m => IORef a -> (a -> a) -> m () +modifyIORef' ref how = liftIO $ Ref.modifyIORef' ref how +{-# INLINE modifyIORef' #-} + +-- | Lifted version of 'Ref.atomicModifyIORef'. +atomicModifyIORef :: MonadIO m => IORef a -> (a -> (a, b)) -> m b +atomicModifyIORef ref how = liftIO $ Ref.atomicModifyIORef ref how +{-# INLINE atomicModifyIORef #-} + +-- | Lifted version of 'Ref.atomicModifyIORef''. +atomicModifyIORef' :: MonadIO m => IORef a -> (a -> (a, b)) -> m b +atomicModifyIORef' ref how = liftIO $ Ref.atomicModifyIORef' ref how +{-# INLINE atomicModifyIORef' #-} + +-- | Lifted version of 'Ref.atomicWriteIORef'. +atomicWriteIORef :: MonadIO m => IORef a -> a -> m () +atomicWriteIORef ref what = liftIO $ Ref.atomicWriteIORef ref what +{-# INLINE atomicWriteIORef #-} diff --git a/src/List.hs b/src/List.hs --- a/src/List.hs +++ b/src/List.hs @@ -1,9 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} +-- | Utility functions to work with lists. + module List ( list , ordNub + , sortBy , sortOn , unzip , unzip3 @@ -15,10 +18,9 @@ , zip3 ) where -import Data.Function ((.)) import Data.Functor (fmap) -import Data.List (sortBy, unzip, unzip3, zip, zip3) -import Data.Ord (Ord, comparing) +import Data.List (sortBy, sortOn, unzip, unzip3, zip, zip3) +import Data.Ord (Ord) import qualified Data.Set as Set #if ( __GLASGOW_HASKELL__ >= 800 ) @@ -29,11 +31,7 @@ import Applicative (pass) #endif - -sortOn :: (Ord o) => (a -> o) -> [a] -> [a] -sortOn = sortBy . comparing - --- O(n * log n) +-- | Like 'Prelude.nub' but runs in @O(n * log n)@ time and requires 'Ord'. ordNub :: (Ord a) => [a] -> [a] ordNub l = go Set.empty l where @@ -43,17 +41,26 @@ then go s xs else x : go (Set.insert x s) xs +-- | Returns default list if given list is empty. +-- Otherwise applies given function to every element. +-- +-- >>> list [True] even [] +-- [True] +-- >>> list [True] even [1..5] +-- [False,True,False,True,False] list :: [b] -> (a -> b) -> [a] -> [b] list def f xs = case xs of - [] -> def - _ -> fmap f xs + [] -> def + _ -> fmap f xs #if ( __GLASGOW_HASKELL__ >= 800 ) +-- | Performs given action over 'NonEmpty' list if given list is non empty. whenNotNull :: Applicative f => [a] -> (NonEmpty a -> f ()) -> f () whenNotNull [] _ = pass whenNotNull (x:xs) f = f (x :| xs) {-# INLINE whenNotNull #-} +-- | Monadic version of 'whenNotNull'. whenNotNullM :: Monad m => m [a] -> (NonEmpty a -> m ()) -> m () whenNotNullM ml f = ml >>= \l -> whenNotNull l f {-# INLINE whenNotNullM #-} diff --git a/src/Monad.hs b/src/Monad.hs --- a/src/Monad.hs +++ b/src/Monad.hs @@ -1,19 +1,21 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +-- | Reexporting useful monadic stuff. + module Monad - ( module Export + ( module Monad.Maybe + , module Monad.Either + , module Monad.Trans - , Monad ((>>=), return) + , Monad ((>>=), (>>), return) , MonadFail (fail) , MonadPlus (..) , (=<<) , (>=>) , (<=<) - , (>>) , forever , join @@ -49,9 +51,9 @@ , (<$!>) ) where -import Monad.Either as Export -import Monad.Maybe as Export -import Monad.Trans as Export +import Monad.Either +import Monad.Maybe +import Monad.Trans import Base (IO, seq) import Control.Applicative (Applicative (pure)) @@ -77,10 +79,13 @@ import Containers (Element, NontrivialContainer, toList) --- old specialized to list version --- concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] -- | Lifting bind into a monad. Generalized version of @concatMap@ --- that works with a monadic predicate. +-- that works with a monadic predicate. Old and simpler specialized to list +-- version had next type: +-- +-- @ +-- concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] +-- @ concatMapM :: (Applicative q, Monad m, Traversable m) => (a -> q (m b)) -> m a @@ -97,6 +102,7 @@ concatForM = flip concatMapM {-# INLINE concatForM #-} +-- | Stricter version of 'Data.Functor.<$>'. (<$!>) :: Monad m => (a -> b) -> m a -> m b f <$!> m = do x <- m @@ -104,6 +110,20 @@ z `seq` return z {-# INLINE (<$!>) #-} +-- | Monadic and constrained to 'NonTrivialContainer' version of 'Prelude.and'. +-- +-- >>> andM [Just True, Just False] +-- Just False +-- >>> andM [Just True] +-- Just True +-- >>> andM [Just True, Just False, Nothing] +-- Just False +-- >>> andM [Just True, Nothing] +-- Nothing +-- >>> andM [putStrLn "1" >> pure True, putStrLn "2" >> pure False, putStrLn "3" >> undefined] +-- 1 +-- 2 +-- False andM :: (NontrivialContainer f, Element f ~ m Bool, Monad m) => f -> m Bool andM = go . toList where @@ -112,6 +132,14 @@ q <- p if q then go ps else pure False +-- | Monadic and constrained to 'NonTrivialContainer' version of 'Prelude.or'. +-- +-- >>> orM [Just True, Just False] +-- Just True +-- >>> orM [Just True, Nothing] +-- Just True +-- >>> orM [Nothing, Just True] +-- Nothing orM :: (NontrivialContainer f, Element f ~ m Bool, Monad m) => f -> m Bool orM = go . toList where @@ -120,6 +148,14 @@ q <- p if q then pure True else go ps +-- | Monadic and constrained to 'NonTrivialContainer' version of 'Prelude.all'. +-- +-- >>> allM (readMaybe >=> pure . even) ["6", "10"] +-- Just True +-- >>> allM (readMaybe >=> pure . even) ["5", "aba"] +-- Just False +-- >>> allM (readMaybe >=> pure . even) ["aba", "10"] +-- Nothing allM :: (NontrivialContainer f, Monad m) => (Element f -> m Bool) -> f -> m Bool allM p = go . toList where @@ -128,6 +164,14 @@ q <- p x if q then go xs else pure False +-- | Monadic and constrained to 'NonTrivialContainer' version of 'Prelude.any'. +-- +-- >>> anyM (readMaybe >=> pure . even) ["5", "10"] +-- Just True +-- >>> anyM (readMaybe >=> pure . even) ["10", "aba"] +-- Just True +-- >>> anyM (readMaybe >=> pure . even) ["aba", "10"] +-- Nothing anyM :: (NontrivialContainer f, Monad m) => (Element f -> m Bool) -> f -> m Bool anyM p = go . toList where @@ -141,9 +185,10 @@ {-# SPECIALIZE anyM :: (a -> IO Bool) -> [a] -> IO Bool #-} {-# SPECIALIZE allM :: (a -> IO Bool) -> [a] -> IO Bool #-} --- Copied from 'fail' by Herbert Valerio Riedel (the library is under BSD3) #if __GLASGOW_HASKELL__ < 800 +-- | Class for 'Monad's that can 'fail'. +-- Copied from 'fail' by Herbert Valerio Riedel (the library is under BSD3). class Monad m => MonadFail m where fail :: String -> m a diff --git a/src/Monad/Either.hs b/src/Monad/Either.hs --- a/src/Monad/Either.hs +++ b/src/Monad/Either.hs @@ -23,32 +23,60 @@ import Applicative (pass) +-- | Maps left part of 'Either' to 'Maybe'. +-- +-- >>> leftToMaybe (Left True) +-- Just True +-- >>> leftToMaybe (Right "aba") +-- Nothing leftToMaybe :: Either l r -> Maybe l leftToMaybe = either Just (const Nothing) +-- | Maps right part of 'Either' to 'Maybe'. +-- +-- >>> rightToMaybe (Left True) +-- Nothing +-- >>> leftToMaybe (Right "aba") +-- Just "aba" rightToMaybe :: Either l r -> Maybe r rightToMaybe = either (const Nothing) Just +-- | Maps 'Maybe' to 'Either' wrapping default value into 'Left'. +-- +-- >>> maybeToRight True (Just "aba") +-- Right "aba" +-- >>> maybeToRight True Nothing +-- Left True maybeToRight :: l -> Maybe r -> Either l r maybeToRight l = maybe (Left l) Right +-- | Maps 'Maybe' to 'Either' wrapping default value into 'Right'. +-- +-- >>> maybeToLeft True (Just "aba") +-- Left "aba" +-- >>> maybeToRight True Nothing +-- Right True maybeToLeft :: r -> Maybe l -> Either l r maybeToLeft r = maybe (Right r) Left +-- | Applies given action to 'Either' content if 'Left' is given. whenLeft :: Applicative f => Either l r -> (l -> f ()) -> f () whenLeft (Left l) f = f l whenLeft (Right _) _ = pass {-# INLINE whenLeft #-} +-- | Monadic version of 'whenLeft'. whenLeftM :: Monad m => m (Either l r) -> (l -> m ()) -> m () whenLeftM me f = me >>= \e -> whenLeft e f {-# INLINE whenLeftM #-} +-- | Applies given action to 'Either' content if 'Right' is given. whenRight :: Applicative f => Either l r -> (r -> f ()) -> f () whenRight (Left _) _ = pass whenRight (Right r) f = f r {-# INLINE whenRight #-} +-- | Monadic version of 'whenRight'. whenRightM :: Monad m => m (Either l r) -> (r -> m ()) -> m () whenRightM me f = me >>= \e -> whenRight e f {-# INLINE whenRightM #-} diff --git a/src/Monad/Maybe.hs b/src/Monad/Maybe.hs --- a/src/Monad/Maybe.hs +++ b/src/Monad/Maybe.hs @@ -17,29 +17,48 @@ import Applicative (pass) +-- | Specialized version of 'for_' for 'Maybe'. It's used for code readability. +-- Also helps to avoid space leaks: +-- . whenJust :: Applicative f => Maybe a -> (a -> f ()) -> f () whenJust (Just x) f = f x whenJust Nothing _ = pass {-# INLINE whenJust #-} +-- | Monadic version of 'whenJust'. whenJustM :: Monad m => m (Maybe a) -> (a -> m ()) -> m () whenJustM mm f = mm >>= \m -> whenJust m f {-# INLINE whenJustM #-} +-- | Performs default 'Applicative' action if 'Nothing' is given. +-- Otherwise returns content of 'Just' pured to 'Applicative'. +-- +-- >>> whenNothing Nothing [True, False] +-- [True,False] +-- >>> whenNothing (Just True) [True, False] +-- [True] whenNothing :: Applicative f => Maybe a -> f a -> f a whenNothing (Just x) _ = pure x whenNothing Nothing m = m {-# INLINE whenNothing #-} +-- | Performs default 'Applicative' action if 'Nothing' is given. +-- Do nothing for 'Just'. Convenient for discarding 'Just' content. +-- +-- >>> whenNothing_ Nothing $ putText "Nothing!" +-- Nothing! +-- >>> whenNothing_ (Just True) $ putText "Nothing!" whenNothing_ :: Applicative f => Maybe a -> f () -> f () whenNothing_ Nothing m = m whenNothing_ _ _ = pass {-# INLINE whenNothing_ #-} +-- | Monadic version of 'whenNothing'. whenNothingM :: Monad m => m (Maybe a) -> m a -> m a whenNothingM mm action = mm >>= \m -> whenNothing m action {-# INLINE whenNothingM #-} +-- | Monadic version of 'whenNothingM_'. whenNothingM_ :: Monad m => m (Maybe a) -> m () -> m () whenNothingM_ mm action = mm >>= \m -> whenNothing_ m action {-# INLINE whenNothingM_ #-} diff --git a/src/Monad/Trans.hs b/src/Monad/Trans.hs --- a/src/Monad/Trans.hs +++ b/src/Monad/Trans.hs @@ -3,11 +3,19 @@ -- | Monad transformers utilities. module Monad.Trans - ( module X + ( -- * Reexports from @Control.Monad.*@ + module Control.Monad.Catch + , module Control.Monad.Except + , module Control.Monad.Reader + , module Control.Monad.State + , module Control.Monad.Trans + , module Control.Monad.Trans.Maybe + -- * Convenient functions to work with 'Reader' monad , usingReader , usingReaderT + -- * Convenient functions to work with 'State' monad , evaluatingState , evaluatingStateT , executingState @@ -17,49 +25,60 @@ ) where -- Monad transformers -import Control.Monad.Catch as X (MonadCatch (catch), MonadMask (..), +import Control.Monad.Catch (MonadCatch (catch), MonadMask (..), MonadThrow (throwM), bracket, bracket_, catchAll, finally) -import Control.Monad.Except as X (ExceptT (..), runExceptT) -import Control.Monad.State as X (MonadState, State, StateT (..), evalState, +import Control.Monad.Except (ExceptT (..), runExceptT) +import Control.Monad.Reader (MonadReader, Reader, ReaderT (..), ask, asks, + local, reader, runReader) +import Control.Monad.State (MonadState, State, StateT (..), evalState, evalStateT, execState, execStateT, gets, modify, runState, state, withState) - -import Control.Monad.Reader as X (MonadReader, Reader, ReaderT (..), ask, asks, - local, reader, runReader) - -import Control.Monad.Trans as X (MonadIO, lift, liftIO) +import Control.Monad.Trans (MonadIO, lift, liftIO) +import Control.Monad.Trans.Maybe (MaybeT (..), exceptToMaybeT, maybeToExceptT) -import Prelude (Functor, flip, fst, snd, (<$>)) +import Prelude (Functor, flip, fst, snd, (<$>)) +-- | Shorter and more readable alias for @flip runReaderT@. usingReaderT :: r -> ReaderT r m a -> m a usingReaderT = flip runReaderT {-# INLINE usingReaderT #-} +-- | Shorter and more readable alias for @flip runReader@. usingReader :: r -> Reader r a -> a usingReader = flip runReader {-# INLINE usingReader #-} +-- | Shorter and more readable alias for @flip runStateT@. usingStateT :: s -> StateT s m a -> m (a, s) usingStateT = flip runStateT {-# INLINE usingStateT #-} +-- | Shorter and more readable alias for @flip runState@. usingState :: s -> State s a -> (a, s) usingState = flip runState {-# INLINE usingState #-} +-- | Alias for @flip evalStateT@. It's not shorter but sometimes +-- more readable. Done by analogy with @using*@ functions family. evaluatingStateT :: Functor f => s -> StateT s f a -> f a evaluatingStateT s st = fst <$> usingStateT s st {-# INLINE evaluatingStateT #-} +-- | Alias for @flip evalState@. It's not shorter but sometimes +-- more readable. Done by analogy with @using*@ functions family. evaluatingState :: s -> State s a -> a evaluatingState s st = fst (usingState s st) {-# INLINE evaluatingState #-} +-- | Alias for @flip execStateT@. It's not shorter but sometimes +-- more readable. Done by analogy with @using*@ functions family. executingStateT :: Functor f => s -> StateT s f a -> f s executingStateT s st = snd <$> usingStateT s st {-# INLINE executingStateT #-} +-- | Alias for @flip execState@. It's not shorter but sometimes +-- more readable. Done by analogy with @using*@ functions family. executingState :: s -> State s a -> s executingState s st = snd (usingState s st) {-# INLINE executingState #-} diff --git a/src/Print.hs b/src/Print.hs new file mode 100644 --- /dev/null +++ b/src/Print.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Trustworthy #-} + +-- | Generalization of 'Prelude.putStr' and 'Prelude.putStrLn' functions. + +module Print + ( Print (..) + , putText + , putLText + ) where + +import qualified Base +import Data.Function ((.)) +import qualified Prelude as Prelude + +import Control.Monad.IO.Class (MonadIO, liftIO) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as BL + +import qualified Data.Text as T +import qualified Data.Text.IO as T + +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.IO as TL + + +-- | Polymorfic over string and lifted to 'MonadIO' printing functions. +class Print a where + putStr :: MonadIO m => a -> m () + putStrLn :: MonadIO m => a -> m () + +instance Print T.Text where + putStr = liftIO . T.putStr + putStrLn = liftIO . T.putStrLn + +instance Print TL.Text where + putStr = liftIO . TL.putStr + putStrLn = liftIO . TL.putStrLn + +instance Print BS.ByteString where + putStr = liftIO . BS.putStr + putStrLn = liftIO . BS.putStrLn + +instance Print BL.ByteString where + putStr = liftIO . BL.putStr + putStrLn = liftIO . BL.putStrLn + +instance Print [Base.Char] where + putStr = liftIO . Prelude.putStr + putStrLn = liftIO . Prelude.putStrLn + +-- | Specialized to 'T.Text' version of 'putStrLn' or forcing type inference. +putText :: MonadIO m => T.Text -> m () +putText = putStrLn +{-# SPECIALIZE putText :: T.Text -> Base.IO () #-} + +-- | Specialized to 'TL.Text' version of 'putStrLn' or forcing type inference. +putLText :: MonadIO m => TL.Text -> m () +putLText = putStrLn +{-# SPECIALIZE putLText :: TL.Text -> Base.IO () #-} diff --git a/src/Show.hs b/src/Show.hs deleted file mode 100644 --- a/src/Show.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE ExtendedDefaultRules #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeSynonymInstances #-} - -module Show - ( Print (..) - , putText - , putLText - ) where - -import qualified Base -import Data.Function ((.)) - -import Control.Monad.IO.Class (MonadIO, liftIO) -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as BL - -import qualified Data.Text as T -import qualified Data.Text.IO as T - -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.IO as TL - - -class Print a where - putStr :: MonadIO m => a -> m () - putStrLn :: MonadIO m => a -> m () - -instance Print T.Text where - putStr = liftIO . T.putStr - putStrLn = liftIO . T.putStrLn - -instance Print TL.Text where - putStr = liftIO . TL.putStr - putStrLn = liftIO . TL.putStrLn - -instance Print BS.ByteString where - putStr = liftIO . BS.putStr - putStrLn = liftIO . BS.putStrLn - -instance Print BL.ByteString where - putStr = liftIO . BL.putStr - putStrLn = liftIO . BL.putStrLn - -instance Print [Base.Char] where - putStr = liftIO . Base.putStr - putStrLn = liftIO . Base.putStrLn - --- For forcing type inference -putText :: MonadIO m => T.Text -> m () -putText = putStrLn -{-# SPECIALIZE putText :: T.Text -> Base.IO () #-} - -putLText :: MonadIO m => TL.Text -> m () -putLText = putStrLn -{-# SPECIALIZE putLText :: TL.Text -> Base.IO () #-} diff --git a/src/TypeOps.hs b/src/TypeOps.hs --- a/src/TypeOps.hs +++ b/src/TypeOps.hs @@ -8,6 +8,14 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +#if __GLASGOW_HASKELL__ <= 710 +{-# LANGUAGE Trustworthy #-} +#else +{-# LANGUAGE Safe #-} +#endif + +-- | Type operators for writing convenient type signatures. + module TypeOps ( type Each , type ($) @@ -26,7 +34,7 @@ -- @ -- f :: Each [Show, Read] [a, b] => a -> b -> String -- = --- f :: (Show a, Show b, Read a, Show b) => a -> b -> String +-- f :: (Show a, Show b, Read a, Read b) => a -> b -> String -- @ -- -- To specify list with single constraint / variable, don't forget to prefix diff --git a/src/Universum.hs b/src/Universum.hs --- a/src/Universum.hs +++ b/src/Universum.hs @@ -1,29 +1,41 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE Trustworthy #-} +-- | Main module that reexports all functionality allowed to use +-- without importing any other modules. Just add next lines to your +-- module to replace default ugly 'Prelude' with better one. +-- +-- @ +-- {-# LANGUAGE NoImplicitPrelude #-} +-- +-- import Universum +-- @ + module Universum ( -- * Reexports from base and from modules in this repo - module X + module X -- Should I expand this to all modules to remove haddock warnings? , module Base -- * Useful classes , Buildable -- * Useful standard unclassifed functions + , evaluateNF + , evaluateNF_ + , evaluateWHNF + , evaluateWHNF_ + , guarded , identity , map - , uncons - , unsnoc , pretty , prettyL , print - , foreach - , guarded + , readEither , show + , uncons + , unsnoc -- * Convenient type aliases , LText @@ -32,7 +44,6 @@ import Applicative as X import Bool as X -import Concurrent as X import Containers as X import Conv as X import Debug as X @@ -41,12 +52,12 @@ import Lifted as X import List as X import Monad as X -import Show as X +import Print as X import TypeOps as X -import Base as Base hiding (error, print, putStr, putStrLn, - show, showFloat, showList, showSigned, - showSignedFloat, showsPrec, undefined) +import Base as Base hiding (error, show, showFloat, + showList, showSigned, showSignedFloat, + showsPrec, undefined) import qualified Base as PBase import Data.String as X (IsString (..)) @@ -57,10 +68,12 @@ initSafe, lastDef, lastMay, tailDef, tailMay, tailSafe) --- Applicatives +-- Applicatives and Bifunctors and Arrows import Control.Applicative as X (Alternative (..), Applicative (..), Const (..), ZipList (..), liftA, liftA2, liftA3, optional, (<**>)) +import Control.Arrow as X ((&&&)) +import Data.Bifunctor as X (Bifunctor (..)) -- Base typeclasses import Data.Eq as X (Eq (..)) @@ -84,12 +97,6 @@ import Data.Monoid as X #endif -#if (__GLASGOW_HASKELL__ >= 710) -import Data.Bifunctor as X (Bifunctor (..)) -#else -import Bifunctor as X (Bifunctor (..)) -#endif - -- Deepseq import Control.DeepSeq as X (NFData (..), deepseq, force, ($!!)) @@ -157,7 +164,7 @@ import Data.Text.Encoding as X (decodeUtf8', decodeUtf8With) import Data.Text.Encoding.Error as X (OnDecodeError, OnError, UnicodeException, lenientDecode, strictDecode) -import Text.Read as X (Read, readEither, readMaybe, reads) +import Text.Read as X (Read, readMaybe, reads) -- IO import System.IO as X (FilePath, Handle, IOMode (..), stderr, @@ -169,20 +176,39 @@ (^?), _1, _2, _3, _4, _5) import Lens.Micro.Mtl as X (preuse, preview, use, view) --- Type synonyms for lazy types +-- For internal usage only +import qualified Control.Exception.Base (evaluate) +import qualified Prelude (print) +import qualified Text.Read (readEither) + +-- | Type synonym for 'Data.Text.Lazy.Text'. type LText = Data.Text.Lazy.Text + +-- | Type synonym for 'Data.ByteString.Lazy.ByteString'. type LByteString = Data.ByteString.Lazy.ByteString +-- | Renamed version of 'Prelude.id'. identity :: a -> a identity x = x +-- | 'Prelude.map' generalized to 'Functor'. map :: Functor f => (a -> b) -> f a -> f b map = fmap +-- | Destructuring list into its head and tail if possible. This function is total. +-- +-- >>> uncons [] +-- Nothing +-- >>> uncons [1..5] +-- Just (1,[2,3,4,5]) +-- >>> uncons (5 : [1..5]) >>= \(f, l) -> pure $ f == length l +-- Just True uncons :: [a] -> Maybe (a, [a]) uncons [] = Nothing uncons (x:xs) = Just (x, xs) +-- | Similar to 'uncons' but destructuring list into its last element and +-- everything before it. unsnoc :: [x] -> Maybe ([x],x) unsnoc = foldr go Nothing where @@ -190,15 +216,32 @@ Nothing -> ([], x) Just (xs, e) -> (x:xs, e)) +-- | Lifted version of 'Prelude.print'. print :: (X.MonadIO m, PBase.Show a) => a -> m () -print = liftIO . PBase.print +print = liftIO . Prelude.print -foreach :: Functor f => f a -> (a -> b) -> f b -foreach = flip fmap +-- | Polymorhpic version of 'Text.Read.readEither'. +-- +-- >>> readEither @Text @Int "123" +-- Right 123 +-- >>> readEither @Text @Int "aa" +-- Left "Prelude.read: no parse" +readEither :: (ToString a, Read b) => a -> Either Text b +readEither = X.first toText . Text.Read.readEither . X.toString +-- | Version of 'Prelude.guard' that takes verification function. +-- Can be used in some similar way: +-- @ +-- safeSum :: Int -> Int -> Maybe Int +-- safeSum a b = do +-- verifiedA <- guarded (>0) a +-- verifiedB <- guarded (>0) b +-- pure $ verifiedA + verifiedB +-- @ guarded :: (Alternative f) => (a -> Bool) -> a -> f a guarded p x = X.bool empty (pure x) (p x) +-- | Generalized version of 'Prelude.show'. show :: (Show a, IsString b) => a -> b show x = X.fromString (PBase.show x) {-# SPECIALIZE show :: Show a => a -> Text #-} @@ -211,5 +254,23 @@ pretty :: Buildable a => a -> Text pretty = X.toStrict . prettyL +-- | Similar to 'pretty' but for 'LText'. prettyL :: Buildable a => a -> LText prettyL = toLazyText . build + +-- | Lifted alias for 'Control.Exception.Base.evaluate' with clearer name. +evaluateWHNF :: MonadIO m => a -> m a +evaluateWHNF = liftIO . Control.Exception.Base.evaluate + +-- | Like 'evaluateWNHF' but discards value. +evaluateWHNF_ :: MonadIO m => a -> m () +evaluateWHNF_ what = (`seq` ()) <$!> evaluateWHNF what + +-- | Alias for @evaluateWHNF . force@ with clearer name. +evaluateNF :: (X.NFData a, MonadIO m) => a -> m a +evaluateNF = evaluateWHNF . force + +-- | Alias for @evaluateWHNF . rnf@. Similar to 'evaluateNF' +-- but discards resulting value. +evaluateNF_ :: (X.NFData a, MonadIO m) => a -> m () +evaluateNF_ = evaluateWHNF . rnf diff --git a/src/Unsafe.hs b/src/Unsafe.hs --- a/src/Unsafe.hs +++ b/src/Unsafe.hs @@ -1,6 +1,9 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE Unsafe #-} +{-# LANGUAGE Unsafe #-} +-- | Unsafe functions to work with lists and 'Maybe'. +-- Sometimes unavoidable but better don't use them. This module +-- is not even included in default prelude exports. + module Unsafe ( unsafeHead , unsafeTail @@ -8,31 +11,32 @@ , unsafeLast , unsafeFromJust , unsafeIndex - , unsafeThrow ) where -import Base (Int) -import qualified Control.Exception as Exc -import qualified Data.List as List -import qualified Data.Maybe as Maybe +import Base (Int) +import qualified Data.List as List +import qualified Data.Maybe as Maybe +-- | Cautionary alias for 'List.head'. unsafeHead :: [a] -> a unsafeHead = List.head +-- | Cautionary alias for 'List.tail'. unsafeTail :: [a] -> [a] unsafeTail = List.tail +-- | Cautionary alias for 'List.init'. unsafeInit :: [a] -> [a] unsafeInit = List.init +-- | Cautionary alias for 'List.last'. unsafeLast :: [a] -> a unsafeLast = List.last -unsafeFromJust :: Maybe.Maybe a -> a -unsafeFromJust = Maybe.fromJust - +-- | Cautionary alias for 'List.!!'. unsafeIndex :: [a] -> Int -> a unsafeIndex = (List.!!) -unsafeThrow :: Exc.Exception e => e -> a -unsafeThrow = Exc.throw +-- | Cautionary alias for 'Maybe.fromJust'. +unsafeFromJust :: Maybe.Maybe a -> a +unsafeFromJust = Maybe.fromJust diff --git a/universum.cabal b/universum.cabal --- a/universum.cabal +++ b/universum.cabal @@ -1,5 +1,5 @@ name: universum -version: 0.3 +version: 0.4 synopsis: Custom prelude used in Serokell description: Custom prelude used in Serokell homepage: https://github.com/serokell/universum @@ -28,19 +28,22 @@ Applicative Base - Bifunctor Bool - Concurrent Containers Conv Debug Exceptions Functor - Lifted List - Show + Print TypeOps Unsafe + + Lifted + Lifted.Concurrent + Lifted.Env + Lifted.File + Lifted.IORef Monad Monad.Either