universum 0.3 → 0.4
raw patch · 27 files changed
+860/−444 lines, 27 files
Files
- CHANGES.md +18/−1
- src/Applicative.hs +8/−0
- src/Base.hs +52/−48
- src/Bifunctor.hs +0/−32
- src/Bool.hs +33/−6
- src/Concurrent.hs +0/−106
- src/Containers.hs +63/−1
- src/Conv.hs +24/−0
- src/Debug.hs +14/−2
- src/Exceptions.hs +4/−0
- src/Functor.hs +9/−4
- src/Lifted.hs +17/−109
- src/Lifted/Concurrent.hs +112/−0
- src/Lifted/Env.hs +47/−0
- src/Lifted/File.hs +65/−0
- src/Lifted/IORef.hs +63/−0
- src/List.hs +17/−10
- src/Monad.hs +59/−14
- src/Monad/Either.hs +28/−0
- src/Monad/Maybe.hs +19/−0
- src/Monad/Trans.hs +29/−10
- src/Print.hs +61/−0
- src/Show.hs +0/−59
- src/TypeOps.hs +9/−1
- src/Universum.hs +85/−24
- src/Unsafe.hs +16/−12
- universum.cabal +8/−5
CHANGES.md view
@@ -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`.
src/Applicative.hs view
@@ -1,12 +1,20 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE Safe #-} +-- | Convenient utils to work with 'Applicative'. There were more functions in this module+-- (see <https://www.stackage.org/haddock/lts-8.9/protolude-0.1.10/Applicative.html protolude version>)+-- 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 ()
src/Base.hs view
@@ -1,56 +1,57 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ExplicitNamespaces #-}-{-# LANGUAGE Unsafe #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE Unsafe #-} +-- | Reexports from @GHC.*@ modules of <https://www.stackage.org/lts-8.9/package/base-4.9.1.0 base>+-- 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 $!
− src/Bifunctor.hs
@@ -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)
src/Bool.hs view
@@ -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
− src/Concurrent.hs
@@ -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 #-}
src/Containers.hs view
@@ -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:+-- <https://www.reddit.com/r/haskell/comments/60r9hu/proposal_suggest_explicit_type_application_for/ Suggest explicit type application for Foldable length and friends>+ 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)+-- <interactive>: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)+-- <interactive>: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.
src/Conv.hs view
@@ -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
src/Debug.hs view
@@ -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
src/Exceptions.hs view
@@ -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
src/Functor.hs view
@@ -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 <<$>>
src/Lifted.hs view
@@ -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 #-}
+ src/Lifted/Concurrent.hs view
@@ -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 #-}
+ src/Lifted/Env.hs view
@@ -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 #-}
+ src/Lifted/File.hs view
@@ -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'
+ src/Lifted/IORef.hs view
@@ -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 #-}
src/List.hs view
@@ -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 #-}
src/Monad.hs view
@@ -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
src/Monad/Either.hs view
@@ -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 #-}
src/Monad/Maybe.hs view
@@ -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:+-- <http://www.snoyman.com/blog/2017/01/foldable-mapm-maybe-and-recursive-functions Foldable.mapM_ space leak>. 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_ #-}
src/Monad/Trans.hs view
@@ -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 #-}
+ src/Print.hs view
@@ -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 () #-}
− src/Show.hs
@@ -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 () #-}
src/TypeOps.hs view
@@ -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
src/Universum.hs view
@@ -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
src/Unsafe.hs view
@@ -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
universum.cabal view
@@ -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