diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,10 +1,28 @@ -0.9.2 +1.0.0 ===== -* [#114](https://github.com/serokell/universum/issues/114): - Reexport more functions from `safe-exceptions`. -* [#100](https://github.com/serokell/universum/issues/100): - Add `bug` function = `impureThrow`. +* [#90](https://github.com/serokell/universum/issues/90): + Improve project structure. +* [#89](https://github.com/serokell/universum/issues/89): + Add export of `Universum.Nub` module to `Universum`. +* Add `listToMaybe` to `Universum.Monad.Reexport`. +* [#81](https://github.com/serokell/universum/issues/81): + Make `putText` and `putLText` to be versions of `putStr`. + Add `putTextLn` and `putLTextLn` -- versions of `putStrLn`. +* [#5](https://github.com/serokell/universum/issues/5): + Add safe versions of `head`, `tail`, `init`, `last` functions for `NonEmpty` list. + Old `head` (which returns `Maybe`) is renamed to `safeHead`. + Reexports from `safe` are removed. +* Remove `unsnoc` (this function is very slow and shouldn't be used). +* [#88](https://github.com/serokell/universum/issues/88): + Add `HasCallStack =>` to `error` and `undefined` functions. +* [#58](https://github.com/serokell/universum/issues/58): + Make `Element` type family be associated type family. + Remove `{-# OVERLAPPABLE #-}` instance for `ToList` and `Container`. Add default instances for basic types. + Remove `WrappedList` `newtype` because it's not needed anymore. + Remove `NontrivialContainer` constraint alias. +* [#56](https://github.com/serokell/universum/issues/56): + Make `elem` and `notElem` faster for `Set` and `HashSet` by introducing `ElementConstraint` associated type family. 0.9.1 ===== diff --git a/benchmark/Main.hs b/benchmark/Main.hs --- a/benchmark/Main.hs +++ b/benchmark/Main.hs @@ -1,19 +1,26 @@ {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE ScopedTypeVariables #-} -import Control.DeepSeq (NFData) -import Control.Monad.Identity (Identity (..)) -import Criterion.Main (Benchmark, bench, bgroup, defaultMain, nf) -import Data.Hashable (Hashable) -import Data.List (group, head, nub, sort, zip5) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Text (Text) -import qualified Data.Text as T +module Main where -import Monad (concatMapM) -import Nub (hashNub, ordNub, sortNub, unstableNub) -import VarArg ((...)) +import Control.DeepSeq (NFData) +import Control.Monad.Identity (Identity (..)) +import Criterion.Main (Benchmark, bench, bgroup, defaultMain, nf, whnf) +import Data.Hashable (Hashable) +import Data.List (group, head, nub, sort, zip5) +import Data.Text (Text) +import Universum.Monad (concatMapM) +import Universum.Nub (hashNub, ordNub, sortNub, unstableNub) +import Universum.VarArg ((...)) + +import qualified Data.Foldable as Foldable (elem) +import qualified Data.HashSet as HashSet (fromList) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Set as Set (fromList) +import qualified Data.Text as T +import qualified Universum.Container as Container (elem) + main :: IO () main = defaultMain [ bgroupList listOfSmall "small" @@ -22,6 +29,7 @@ , bgroupList (nStrings 'c') "big str" , bgroupSuperComposition , bgroupConcatMap + , bgroupMember ] bgroupList :: forall a . @@ -146,3 +154,16 @@ concatIdentity :: Int -> Identity [()] concatIdentity n = concatMapM (Identity . pure) $ replicate n () + +-- | Checks that 'member' is implemented efficiently for 'Set' and 'HashSet'. +bgroupMember :: Benchmark +bgroupMember = do + let testList = [1..100000] :: [Int] + let sample = 50000 + let listSet = Set.fromList testList + let listHashSet = HashSet.fromList testList + bgroup "member" [ bench "Set/foldable" $ whnf (Foldable.elem sample) listSet + , bench "Set/elem" $ whnf (Container.elem sample) listSet + , bench "HashSet/Foldable" $ whnf (Foldable.elem sample) listHashSet + , bench "HashSet/elem" $ whnf (Container.elem sample) listHashSet + ] diff --git a/src/Applicative.hs b/src/Applicative.hs deleted file mode 100644 --- a/src/Applicative.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# 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 () - -{- -orAlt :: (Alternative f, Monoid a) => f a -> f a -orAlt f = f <|> pure mempty - -orEmpty :: Alternative f => Bool -> a -> f a -orEmpty b a = if b then pure a else empty - -eitherA :: Alternative f => f a -> f b -> f (Either a b) -eitherA a b = (Left <$> a) <|> (Right <$> b) - -purer :: (Applicative f, Applicative g) => a -> f (g a) -purer = pure . pure - -liftAA2 :: (Applicative f, Applicative g) => (a -> b -> c) -> f (g a) -> f (g b) -> f (g c) -liftAA2 = liftA2 . liftA2 - -(<<*>>) :: (Applicative f, Applicative g) => f (g (a -> b)) -> f (g a) -> f (g b) -(<<*>>) = liftA2 (<*>) --} diff --git a/src/Base.hs b/src/Base.hs deleted file mode 100644 --- a/src/Base.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE Unsafe #-} - --- | Reexports from @GHC.*@ modules of --- package. - -module Base - ( module GHC.Base - , module GHC.Enum - , module GHC.Err - , module GHC.Exts - , module GHC.Float - , module GHC.Num - , module GHC.Real - , module GHC.Show -#if MIN_VERSION_base(4,10,0) - , module GHC.TypeNats -#else - , module GHC.TypeLits -#endif - , module GHC.Types - -#if ( __GLASGOW_HASKELL__ >= 800 ) - , module GHC.OverloadedLabels - , module GHC.ExecutionStack - , module GHC.Stack -#endif - - , ($!) - ) where - --- Base GHC types -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 (..)) -#if MIN_VERSION_base(4,10,0) -import GHC.TypeNats (CmpNat, KnownNat, Nat, SomeNat (..), natVal, - someNatVal) -#else -import GHC.TypeLits (CmpNat, KnownNat, Nat, SomeNat (..), natVal, - someNatVal) -#endif - -import GHC.Types (Bool, Char, Coercible, IO, Int, Ordering, Word) - - -#if ( __GLASGOW_HASKELL__ >= 800 ) -import GHC.ExecutionStack (getStackTrace, showStackTrace) -import GHC.OverloadedLabels (IsLabel (..)) -import GHC.Stack (CallStack, HasCallStack, callStack, - currentCallStack, getCallStack, prettyCallStack, - prettySrcLoc, withFrozenCallStack) -#endif - --- Pending GHC 8.2 we'll expose these. - -{- -import GHC.Records as X ( - HasField(..) - ) - -<<<<<<< HEAD -======= -import Data.Kind as X ( - type (*) - , type Type - ) --} - - --- | Stricter version of 'Data.Function.$' operator. --- Default Prelude defines this at the toplevel module, so we do as well. --- --- >>> 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 -infixr 0 $! diff --git a/src/Bool.hs b/src/Bool.hs deleted file mode 100644 --- a/src/Bool.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE Safe #-} - --- | Convenient commonly used and very helpful functions to work with --- 'Bool' and also with monads. - -module Bool - ( bool - , guard - , guardM - , ifM - , unless - , unlessM - , when - , whenM - ) where - -import Control.Monad (Monad, MonadPlus, guard, unless, when, (>>=)) -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 -{-# 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 -{-# 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 -{-# INLINE ifM #-} - --- | Monadic version of 'guard'. Occasionally useful. --- Here some complex but real-life example: --- @ --- findSomePath :: IO (Maybe FilePath) --- --- somePath :: MaybeT IO FilePath --- somePath = do --- path <- MaybeT findSomePath --- guardM $ liftIO $ doesDirectoryExist path --- return path --- @ -guardM :: MonadPlus m => m Bool -> m () -guardM f = f >>= guard -{-# INLINE guardM #-} diff --git a/src/Container.hs b/src/Container.hs deleted file mode 100644 --- a/src/Container.hs +++ /dev/null @@ -1,9 +0,0 @@ --- | This module exports all container-related stuff. - -module Container - ( module Container.Class - , module Container.Reexport - ) where - -import Container.Class -import Container.Reexport diff --git a/src/Container/Class.hs b/src/Container/Class.hs deleted file mode 100644 --- a/src/Container/Class.hs +++ /dev/null @@ -1,743 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstrainedClassMethods #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# 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 Container.Class - ( - -- * Foldable-like classes and methods - Element - , ToList(..) - , Container(..) - , NontrivialContainer - - , WrappedList (..) - - , sum - , product - - , mapM_ - , forM_ - , traverse_ - , for_ - , sequenceA_ - , sequence_ - , asum - - -- * Others - , One(..) - ) where - -import Control.Applicative (Alternative (..)) -import Control.Monad.Identity (Identity) -import Data.Coerce (Coercible, coerce) -import Data.Foldable (Foldable) -import Data.Hashable (Hashable) -import Data.Maybe (fromMaybe) -import Data.Monoid (All (..), Any (..), First (..)) -import Data.Word (Word8) -import Prelude hiding (Foldable (..), all, and, any, head, mapM_, notElem, or, sequence_) - -#if __GLASGOW_HASKELL__ >= 800 -import GHC.Err (errorWithoutStackTrace) -import GHC.TypeLits (ErrorMessage (..), Symbol, TypeError) -#endif - -#if ( __GLASGOW_HASKELL__ >= 800 ) -import qualified Data.List.NonEmpty as NE -#endif - -import qualified Data.Foldable as F - -import qualified Data.List as List (null) - -import qualified Data.Sequence as SEQ - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL - -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL - -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import qualified Data.Map as M -import qualified Data.Set as S - -import qualified Data.Vector as V -import qualified Data.Vector.Primitive as VP -import qualified Data.Vector.Storable as VS -import qualified Data.Vector.Unboxed as VU - -import Applicative (pass) - ----------------------------------------------------------------------------- --- 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 -type instance Element T.Text = Char -type instance Element TL.Text = Char -type instance Element BS.ByteString = Word8 -type instance Element BSL.ByteString = Word8 -type instance Element IS.IntSet = Int - --- | Type class for data types that can be converted to List. --- Fully compatible with 'Foldable'. --- Contains very small and safe subset of 'Foldable' functions. --- --- You can define 'Tolist' by just defining 'toList' function. --- But the following law should be met: --- --- @'null' ≡ 'List.null' . 'toList'@ --- -class ToList t where - {-# MINIMAL toList #-} - -- | 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 - null = List.null . toList - --- | This instance makes 'ToList' compatible and overlappable by 'Foldable'. -instance {-# OVERLAPPABLE #-} Foldable f => ToList (f a) where - toList = F.toList - {-# INLINE toList #-} - null = F.null - {-# INLINE null #-} - -instance ToList T.Text where - toList = T.unpack - {-# INLINE toList #-} - null = T.null - {-# INLINE null #-} - -instance ToList TL.Text where - toList = TL.unpack - {-# INLINE toList #-} - null = TL.null - {-# INLINE null #-} - -instance ToList BS.ByteString where - toList = BS.unpack - {-# INLINE toList #-} - null = BS.null - {-# INLINE null #-} - -instance ToList BSL.ByteString where - toList = BSL.unpack - {-# INLINE toList #-} - null = BSL.null - {-# INLINE null #-} - -instance ToList IS.IntSet where - toList = IS.toList - {-# INLINE toList #-} - null = IS.null - {-# INLINE null #-} - ----------------------------------------------------------------------------- --- Additional operations that don't make much sense for e.g. Maybe ----------------------------------------------------------------------------- - --- | A class for 'ToList's that aren't trivial like 'Maybe' (e.g. can hold --- more than one value) -class ToList t => Container t where - foldMap :: Monoid m => (Element t -> m) -> t -> m - foldMap f = foldr (mappend . f) mempty - {-# INLINE foldMap #-} - - fold :: Monoid (Element t) => t -> Element t - fold = foldMap id - - foldr :: (Element t -> b -> b) -> b -> t -> b - foldr' :: (Element t -> b -> b) -> b -> t -> b - foldr' f z0 xs = foldl f' id xs z0 - where f' k x z = k $! f x z - foldl :: (b -> Element t -> b) -> b -> t -> b - foldl' :: (b -> Element t -> b) -> b -> t -> b - foldr1 :: (Element t -> Element t -> Element t) -> t -> Element t - foldr1 f xs = -#if __GLASGOW_HASKELL__ >= 800 - fromMaybe (errorWithoutStackTrace "foldr1: empty structure") - (foldr mf Nothing xs) -#else - fromMaybe (error "foldr1: empty structure") - (foldr mf Nothing xs) -#endif - where - mf x m = Just (case m of - Nothing -> x - Just y -> f x y) - foldl1 :: (Element t -> Element t -> Element t) -> t -> Element t - foldl1 f xs = -#if __GLASGOW_HASKELL__ >= 800 - fromMaybe (errorWithoutStackTrace "foldl1: empty structure") - (foldl mf Nothing xs) -#else - fromMaybe (error "foldl1: empty structure") - (foldl mf Nothing xs) -#endif - where - mf m y = Just (case m of - Nothing -> y - Just x -> f x y) - - length :: t -> Int - - elem :: Eq (Element t) => Element t -> t -> Bool - - notElem :: Eq (Element t) => Element t -> t -> Bool - notElem x = not . elem x - - maximum :: Ord (Element t) => t -> Element t - minimum :: Ord (Element t) => t -> Element t - - all :: (Element t -> Bool) -> t -> Bool - all p = getAll #. foldMap (All #. p) - any :: (Element t -> Bool) -> t -> Bool - any p = getAny #. foldMap (Any #. p) - - and :: (Element t ~ Bool) => t -> Bool - and = getAll #. foldMap All - or :: (Element t ~ Bool) => t -> Bool - or = getAny #. foldMap Any - - find :: (Element t -> Bool) -> t -> Maybe (Element t) - find p = getFirst . foldMap (\ x -> First (if p x then Just x else Nothing)) - - head :: t -> Maybe (Element t) - head = foldr (\x _ -> Just x) Nothing - {-# INLINE head #-} - --- | To save backwards compatibility with previous naming. -type NontrivialContainer t = Container t - -instance {-# OVERLAPPABLE #-} Foldable f => Container (f a) where - foldMap = F.foldMap - {-# INLINE foldMap #-} - fold = F.fold - {-# INLINE fold #-} - foldr = F.foldr - {-# INLINE foldr #-} - foldr' = F.foldr' - {-# INLINE foldr' #-} - foldl = F.foldl - {-# INLINE foldl #-} - foldl' = F.foldl' - {-# INLINE foldl' #-} - foldr1 = F.foldr1 - {-# INLINE foldr1 #-} - foldl1 = F.foldl1 - {-# INLINE foldl1 #-} - length = F.length - {-# INLINE length #-} - elem = F.elem - {-# INLINE elem #-} - notElem = F.notElem - {-# INLINE notElem #-} - maximum = F.maximum - {-# INLINE maximum #-} - minimum = F.minimum - {-# INLINE minimum #-} - all = F.all - {-# INLINE all #-} - any = F.any - {-# INLINE any #-} - and = F.and - {-# INLINE and #-} - or = F.or - {-# INLINE or #-} - find = F.find - {-# INLINE find #-} - -instance Container T.Text where - foldr = T.foldr - {-# INLINE foldr #-} - foldl = T.foldl - {-# INLINE foldl #-} - foldl' = T.foldl' - {-# INLINE foldl' #-} - foldr1 = T.foldr1 - {-# INLINE foldr1 #-} - foldl1 = T.foldl1 - {-# INLINE foldl1 #-} - length = T.length - {-# INLINE length #-} - elem c = T.isInfixOf (T.singleton c) -- there are rewrite rules for this - {-# INLINE elem #-} - maximum = T.maximum - {-# INLINE maximum #-} - minimum = T.minimum - {-# INLINE minimum #-} - all = T.all - {-# INLINE all #-} - any = T.any - {-# INLINE any #-} - find = T.find - {-# INLINE find #-} - head = fmap fst . T.uncons - {-# INLINE head #-} - -instance Container TL.Text where - foldr = TL.foldr - {-# INLINE foldr #-} - foldl = TL.foldl - {-# INLINE foldl #-} - foldl' = TL.foldl' - {-# INLINE foldl' #-} - foldr1 = TL.foldr1 - {-# INLINE foldr1 #-} - foldl1 = TL.foldl1 - {-# INLINE foldl1 #-} - length = fromIntegral . TL.length - {-# INLINE length #-} - -- will be okay thanks to rewrite rules - elem c s = TL.isInfixOf (TL.singleton c) s - {-# INLINE elem #-} - maximum = TL.maximum - {-# INLINE maximum #-} - minimum = TL.minimum - {-# INLINE minimum #-} - all = TL.all - {-# INLINE all #-} - any = TL.any - {-# INLINE any #-} - find = TL.find - {-# INLINE find #-} - head = fmap fst . TL.uncons - {-# INLINE head #-} - -instance Container BS.ByteString where - foldr = BS.foldr - {-# INLINE foldr #-} - foldl = BS.foldl - {-# INLINE foldl #-} - foldl' = BS.foldl' - {-# INLINE foldl' #-} - foldr1 = BS.foldr1 - {-# INLINE foldr1 #-} - foldl1 = BS.foldl1 - {-# INLINE foldl1 #-} - length = BS.length - {-# INLINE length #-} - elem = BS.elem - {-# INLINE elem #-} - notElem = BS.notElem - {-# INLINE notElem #-} - maximum = BS.maximum - {-# INLINE maximum #-} - minimum = BS.minimum - {-# INLINE minimum #-} - all = BS.all - {-# INLINE all #-} - any = BS.any - {-# INLINE any #-} - find = BS.find - {-# INLINE find #-} - head = fmap fst . BS.uncons - {-# INLINE head #-} - -instance Container BSL.ByteString where - foldr = BSL.foldr - {-# INLINE foldr #-} - foldl = BSL.foldl - {-# INLINE foldl #-} - foldl' = BSL.foldl' - {-# INLINE foldl' #-} - foldr1 = BSL.foldr1 - {-# INLINE foldr1 #-} - foldl1 = BSL.foldl1 - {-# INLINE foldl1 #-} - length = fromIntegral . BSL.length - {-# INLINE length #-} - elem = BSL.elem - {-# INLINE elem #-} - notElem = BSL.notElem - {-# INLINE notElem #-} - maximum = BSL.maximum - {-# INLINE maximum #-} - minimum = BSL.minimum - {-# INLINE minimum #-} - all = BSL.all - {-# INLINE all #-} - any = BSL.any - {-# INLINE any #-} - find = BSL.find - {-# INLINE find #-} - head = fmap fst . BSL.uncons - {-# INLINE head #-} - -instance Container IS.IntSet where - foldr = IS.foldr - {-# INLINE foldr #-} - foldl = IS.foldl - {-# INLINE foldl #-} - foldl' = IS.foldl' - {-# INLINE foldl' #-} - length = IS.size - {-# INLINE length #-} - elem = IS.member - {-# INLINE elem #-} - maximum = IS.findMax - {-# INLINE maximum #-} - minimum = IS.findMin - {-# INLINE minimum #-} - head = fmap fst . IS.minView - {-# INLINE head #-} - ----------------------------------------------------------------------------- --- Wrapped List ----------------------------------------------------------------------------- --- | This can be useful if you want to use 'Container' methods for your data type --- but you don't want to implement all methods of this type class for that. -newtype WrappedList f a = WrappedList (f a) - -type instance Element (WrappedList f a) = a - -instance ToList (f a) => ToList (WrappedList f a) where - toList (WrappedList l) = toList l - {-# INLINE toList #-} - null (WrappedList l) = null l - {-# INLINE null #-} - -instance ToList (f a) => Container (WrappedList f a) where - foldMap f = foldMap f . toList - {-# INLINE foldMap #-} - fold = fold . toList - {-# INLINE fold #-} - foldr f z = foldr f z . toList - {-# INLINE foldr #-} - foldr' f z = foldr' f z . toList - {-# INLINE foldr' #-} - foldl f z = foldl f z . toList - {-# INLINE foldl #-} - foldl' f z = foldl' f z . toList - {-# INLINE foldl' #-} - foldr1 f = foldr1 f . toList - {-# INLINE foldr1 #-} - foldl1 f = foldl1 f . toList - {-# INLINE foldl1 #-} - length = length . toList - {-# INLINE length #-} - elem x = elem x . toList - {-# INLINE elem #-} - notElem x = notElem x . toList - {-# INLINE notElem #-} - maximum = maximum . toList - {-# INLINE maximum #-} - minimum = minimum . toList - {-# INLINE minimum #-} - all p = all p . toList - {-# INLINE all #-} - any p = any p . toList - {-# INLINE any #-} - and = and . toList - {-# INLINE and #-} - or = or . toList - {-# INLINE or #-} - find p = find p . toList - {-# INLINE find #-} - head = head . toList - {-# INLINE head #-} - - ----------------------------------------------------------------------------- --- 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 :: (Container 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 :: (Container t, Num (Element t)) => t -> Element t -product = foldl' (*) 1 - --- | Constrained to 'Container' version of 'Data.Foldable.traverse_'. -traverse_ - :: (Container t, Applicative f) - => (Element t -> f b) -> t -> f () -traverse_ f = foldr ((*>) . f) pass - --- | Constrained to 'Container' version of 'Data.Foldable.for_'. -for_ - :: (Container t, Applicative f) - => t -> (Element t -> f b) -> f () -for_ = flip traverse_ -{-# INLINE for_ #-} - --- | Constrained to 'Container' version of 'Data.Foldable.mapM_'. -mapM_ - :: (Container t, Monad m) - => (Element t -> m b) -> t -> m () -mapM_ f= foldr ((>>) . f) pass - --- | Constrained to 'Container' version of 'Data.Foldable.forM_'. -forM_ - :: (Container t, Monad m) - => t -> (Element t -> m b) -> m () -forM_ = flip mapM_ -{-# INLINE forM_ #-} - --- | Constrained to 'Container' version of 'Data.Foldable.sequenceA_'. -sequenceA_ - :: (Container t, Applicative f, Element t ~ f a) - => t -> f () -sequenceA_ = foldr (*>) pass - --- | Constrained to 'Container' version of 'Data.Foldable.sequence_'. -sequence_ - :: (Container t, Monad m, Element t ~ m a) - => t -> m () -sequence_ = foldr (>>) pass - --- | Constrained to 'Container' version of 'Data.Foldable.asum'. -asum - :: (Container t, Alternative f, Element t ~ f a) - => t -> f a -asum = foldr (<|>) empty -{-# INLINE asum #-} - ----------------------------------------------------------------------------- --- Disallowed instances ----------------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ >= 800 -type family DisallowInstance (z :: Symbol) :: ErrorMessage where - DisallowInstance z = Text "Do not use 'Foldable' methods on " :<>: Text z - :$$: Text "Suggestions:" - :$$: Text " Instead of" - :$$: Text " for_ :: (Foldable t, Applicative f) => t a -> (a -> f b) -> f ()" - :$$: Text " use" - :$$: Text " whenJust :: Applicative f => Maybe a -> (a -> f ()) -> f ()" - :$$: Text " whenRight :: Applicative f => Either l r -> (r -> f ()) -> f ()" - :$$: Text "" - :$$: Text " Instead of" - :$$: Text " fold :: (Foldable t, Monoid m) => t m -> m" - :$$: Text " use" - :$$: Text " maybeToMonoid :: Monoid m => Maybe m -> m" - :$$: Text "" -#endif - -#define DISALLOW_TO_LIST_8(t, z) \ - instance TypeError (DisallowInstance z) => \ - ToList (t) where { \ - toList = undefined; \ - null = undefined; } \ - -#define DISALLOW_CONTAINER_8(t, z) \ - instance TypeError (DisallowInstance z) => \ - Container (t) where { \ - foldr = undefined; \ - foldl = undefined; \ - foldl' = undefined; \ - length = undefined; \ - elem = undefined; \ - maximum = undefined; \ - minimum = undefined; } \ - -#define DISALLOW_TO_LIST_7(t) \ - instance ForbiddenFoldable (t) => ToList (t) where { \ - toList = undefined; \ - null = undefined; } \ - -#define DISALLOW_CONTAINER_7(t) \ - instance ForbiddenFoldable (t) => Container (t) where { \ - foldr = undefined; \ - foldl = undefined; \ - foldl' = undefined; \ - length = undefined; \ - elem = undefined; \ - maximum = undefined; \ - minimum = undefined; } \ - -#if __GLASGOW_HASKELL__ >= 800 -DISALLOW_TO_LIST_8((a, b),"tuples") -DISALLOW_CONTAINER_8((a, b),"tuples") -DISALLOW_CONTAINER_8(Maybe a,"Maybe") -DISALLOW_CONTAINER_8(Identity a,"Identity") -DISALLOW_CONTAINER_8(Either a b,"Either") -#else -class ForbiddenFoldable a -DISALLOW_TO_LIST_7((a, b)) -DISALLOW_CONTAINER_7((a, b)) -DISALLOW_CONTAINER_7(Maybe a) -DISALLOW_CONTAINER_7(Identity a) -DISALLOW_CONTAINER_7(Either a b) -#endif - ----------------------------------------------------------------------------- --- 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. - one :: OneItem x -> x - --- Lists - -instance One [a] where - type OneItem [a] = a - one = (:[]) - {-# INLINE one #-} - -#if ( __GLASGOW_HASKELL__ >= 800 ) -instance One (NE.NonEmpty a) where - type OneItem (NE.NonEmpty a) = a - one = (NE.:|[]) - {-# INLINE one #-} -#endif - -instance One (SEQ.Seq a) where - type OneItem (SEQ.Seq a) = a - one = (SEQ.empty SEQ.|>) - {-# INLINE one #-} - --- Monomorphic sequences - -instance One T.Text where - type OneItem T.Text = Char - one = T.singleton - {-# INLINE one #-} - -instance One TL.Text where - type OneItem TL.Text = Char - one = TL.singleton - {-# INLINE one #-} - -instance One BS.ByteString where - type OneItem BS.ByteString = Word8 - one = BS.singleton - {-# INLINE one #-} - -instance One BSL.ByteString where - type OneItem BSL.ByteString = Word8 - one = BSL.singleton - {-# INLINE one #-} - --- Maps - -instance One (M.Map k v) where - type OneItem (M.Map k v) = (k, v) - one = uncurry M.singleton - {-# INLINE one #-} - -instance Hashable k => One (HM.HashMap k v) where - type OneItem (HM.HashMap k v) = (k, v) - one = uncurry HM.singleton - {-# INLINE one #-} - -instance One (IM.IntMap v) where - type OneItem (IM.IntMap v) = (Int, v) - one = uncurry IM.singleton - {-# INLINE one #-} - --- Sets - -instance One (S.Set v) where - type OneItem (S.Set v) = v - one = S.singleton - {-# INLINE one #-} - -instance Hashable v => One (HS.HashSet v) where - type OneItem (HS.HashSet v) = v - one = HS.singleton - {-# INLINE one #-} - -instance One IS.IntSet where - type OneItem IS.IntSet = Int - one = IS.singleton - {-# INLINE one #-} - --- Vectors - -instance One (V.Vector a) where - type OneItem (V.Vector a) = a - one = V.singleton - {-# INLINE one #-} - -instance VU.Unbox a => One (VU.Vector a) where - type OneItem (VU.Vector a) = a - one = VU.singleton - {-# INLINE one #-} - -instance VP.Prim a => One (VP.Vector a) where - type OneItem (VP.Vector a) = a - one = VP.singleton - {-# INLINE one #-} - -instance VS.Storable a => One (VS.Vector a) where - type OneItem (VS.Vector a) = a - one = VS.singleton - {-# INLINE one #-} - ----------------------------------------------------------------------------- --- Utils ----------------------------------------------------------------------------- - -(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c) -(#.) _f = coerce -{-# INLINE (#.) #-} diff --git a/src/Container/Reexport.hs b/src/Container/Reexport.hs deleted file mode 100644 --- a/src/Container/Reexport.hs +++ /dev/null @@ -1,23 +0,0 @@ --- | This module reexports all container related stuff from 'Prelude'. - -module Container.Reexport - ( module Data.Hashable - , module Data.HashMap.Strict - , module Data.HashSet - , module Data.IntMap.Strict - , module Data.IntSet - , module Data.Map.Strict - , module Data.Sequence - , module Data.Set - , module Data.Vector - ) where - -import Data.Hashable (Hashable) -import Data.HashMap.Strict (HashMap) -import Data.HashSet (HashSet) -import Data.IntMap.Strict (IntMap) -import Data.IntSet (IntSet) -import Data.Map.Strict (Map) -import Data.Sequence (Seq) -import Data.Set (Set) -import Data.Vector (Vector) diff --git a/src/Debug.hs b/src/Debug.hs deleted file mode 100644 --- a/src/Debug.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# 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 - , trace - , traceM - , traceId - , traceShow - , traceShowId - , traceShowM - , Undefined (..) - ) where - -import Control.Monad (Monad, return) -import Data.Data (Data) -import Data.Text (Text, unpack) -import Data.Typeable (Typeable) -import GHC.Generics (Generic) -import System.IO.Unsafe (unsafePerformIO) - -import qualified Base as P -import qualified Prelude as P -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 deleted file mode 100644 --- a/src/Exceptions.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Safe #-} - --- | Re-exports most useful functionality from 'safe-exceptions'. Also --- provides some functions to work with exceptions over 'MonadError'. - -module Exceptions - ( module Control.Exception.Safe - -#if ( __GLASGOW_HASKELL__ >= 800 ) - , Bug (..) - , bug -#endif - , note - ) where - --- exceptions from safe-exceptions -import Control.Exception.Safe (Exception (..), MonadCatch, MonadMask (..), MonadThrow, - SomeException (..), bracket, bracketOnError, bracket_, catch, - catchAny, displayException, finally, handleAny, mask_, onException, - throwM, try, tryAny) - -import Control.Applicative (Applicative (pure)) -import Control.Monad.Except (MonadError, throwError) -import Data.Maybe (Maybe, maybe) - -#if ( __GLASGOW_HASKELL__ >= 800 ) -import Data.List ((++)) -import GHC.Show (Show) -import GHC.Stack (CallStack, HasCallStack, callStack, prettyCallStack) - -import qualified Control.Exception.Safe as Safe (impureThrow, toException) - --- | Type that represents exceptions used in cases when a particular codepath --- is not meant to be ever executed, but happens to be executed anyway. -data Bug = Bug SomeException CallStack - deriving (Show) - -instance Exception Bug where - displayException (Bug e cStack) = displayException e ++ "\n" - ++ prettyCallStack cStack - --- | Generate a pure value which, when forced, will synchronously --- throw the exception wrapped into 'Bug' data type. -bug :: (HasCallStack, Exception e) => e -> a -bug e = Safe.impureThrow (Bug (Safe.toException e) callStack) -#endif - - --- 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 -#else -note :: (MonadError e m, Applicative m) => e -> Maybe a -> m a -note err = maybe (throwError err) pure -#endif diff --git a/src/Functor.hs b/src/Functor.hs deleted file mode 100644 --- a/src/Functor.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE Safe #-} - --- | Convenient functions to work with 'Functor'. - -module Functor - ( Functor (..) - , void - , ($>) - , (<$>) - , (<<$>>) - ) where - -import Data.Function ((.)) -import Data.Functor (Functor (..), void, ($>), (<$>)) - --- | 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 deleted file mode 100644 --- a/src/Lifted.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE Safe #-} - --- | Lifted versions of base functions. - -module Lifted - ( module Lifted.Concurrent - , module Lifted.Env - , module Lifted.File - , module Lifted.IORef - - , stToIO - ) where - -import Lifted.Concurrent -import Lifted.Env -import Lifted.File -import Lifted.IORef - -import qualified Control.Monad.ST as XIO -import Control.Monad.Trans (MonadIO, liftIO) - --- | Lifted version of 'XIO.stToIO'. -stToIO :: MonadIO m => XIO.ST XIO.RealWorld a -> m a -stToIO a = liftIO (XIO.stToIO a) -{-# INLINE stToIO #-} diff --git a/src/Lifted/Concurrent.hs b/src/Lifted/Concurrent.hs deleted file mode 100644 --- a/src/Lifted/Concurrent.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Lifted/Env.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Lifted/File.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Lifted/IORef.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/List.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE Trustworthy #-} - --- | Utility functions to work with lists. - -module List - ( module Data.List - - , list - , sortWith -#if ( __GLASGOW_HASKELL__ >= 800 ) - , whenNotNull - , whenNotNullM -#endif - ) where - -import Data.List (break, cycle, drop, dropWhile, filter, genericDrop, - genericLength, genericReplicate, genericSplitAt, - genericTake, group, inits, intercalate, intersperse, - isPrefixOf, iterate, permutations, repeat, - replicate, reverse, scanl, scanr, sort, sortBy, - sortBy, sortOn, splitAt, subsequences, tails, take, - takeWhile, transpose, unfoldr, unzip, unzip3, zip, - zip3, zipWith) - -import Data.Functor (fmap) -import GHC.Exts (sortWith) - -#if ( __GLASGOW_HASKELL__ >= 800 ) -import Control.Applicative (Applicative) -import Control.Monad (Monad (..)) -import Data.List.NonEmpty as X (NonEmpty (..)) - -import Applicative (pass) -#endif - --- | 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 - -#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 #-} -#endif diff --git a/src/Monad.hs b/src/Monad.hs deleted file mode 100644 --- a/src/Monad.hs +++ /dev/null @@ -1,227 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} - --- | Reexporting useful monadic stuff. - -module Monad - ( module Monad.Maybe - , module Monad.Either - , module Monad.Trans - - , Monad ((>>=), (>>), return) - , MonadFail (fail) - , MonadPlus (..) - - , (=<<) - , (>=>) - , (<=<) - , forever - - , join - , mfilter - , filterM - , mapAndUnzipM - , zipWithM - , zipWithM_ - , foldM - , foldM_ - , replicateM - , replicateM_ - - , concatMapM - , concatForM - - , allM - , anyM - , andM - , orM - - , liftM - , liftM2 - , liftM3 - , liftM4 - , liftM5 - , ap - - , (<$!>) - ) where - -import Monad.Either -import Monad.Maybe -import Monad.Trans - -import Base (IO, seq) -import Control.Applicative (Applicative (pure)) -import Data.Function ((.)) -import Data.Functor (fmap) -import Data.Traversable (Traversable (traverse)) -import Prelude (Bool (..), Monoid, flip) - -#if __GLASGOW_HASKELL__ >= 710 -import Control.Monad hiding (fail, (<$!>)) -#else -import Control.Monad hiding (fail) -#endif - -#if __GLASGOW_HASKELL__ >= 800 -import Control.Monad.Fail (MonadFail (..)) -#else -import Prelude (Maybe (Nothing), String) -import Text.ParserCombinators.ReadP (ReadP) -import Text.ParserCombinators.ReadPrec (ReadPrec) - -import qualified Prelude as P (fail) -#endif - -import Container (Container, Element, fold, toList) - --- | Lifting bind into a monad. Generalized version of @concatMap@ --- 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] --- @ --- --- Side note: previously it had type --- --- @ --- concatMapM :: (Applicative q, Monad m, Traversable m) --- => (a -> q (m b)) -> m a -> q (m b) --- @ --- --- Such signature didn't allow to use this function when traversed container --- type and type of returned by function-argument differed. --- Now you can use it like e.g. --- --- @ --- concatMapM readFile files >>= putStrLn --- @ -concatMapM - :: ( Applicative f - , Monoid m - , Container (l m) - , Traversable l - ) - => (a -> f m) -> l a -> f m -concatMapM f = fmap fold . traverse f -{-# INLINE concatMapM #-} - --- | Like 'concatMapM', but has its arguments flipped, so can be used --- instead of the common @fmap concat $ forM@ pattern. -concatForM - :: ( Applicative f - , Monoid m - , Container (l m) - , Traversable l - ) - => l a -> (a -> f m) -> f m -concatForM = flip concatMapM -{-# INLINE concatForM #-} - --- | Stricter version of 'Data.Functor.<$>'. -(<$!>) :: Monad m => (a -> b) -> m a -> m b -f <$!> m = do - x <- m - let z = f x - z `seq` return z -{-# INLINE (<$!>) #-} - --- | Monadic and constrained to 'Container' 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 :: (Container f, Element f ~ m Bool, Monad m) => f -> m Bool -andM = go . toList - where - go [] = pure True - go (p:ps) = do - q <- p - if q then go ps else pure False - --- | Monadic and constrained to 'Container' version of 'Prelude.or'. --- --- >>> orM [Just True, Just False] --- Just True --- >>> orM [Just True, Nothing] --- Just True --- >>> orM [Nothing, Just True] --- Nothing -orM :: (Container f, Element f ~ m Bool, Monad m) => f -> m Bool -orM = go . toList - where - go [] = pure False - go (p:ps) = do - q <- p - if q then pure True else go ps - --- | Monadic and constrained to 'Container' 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 :: (Container f, Monad m) => (Element f -> m Bool) -> f -> m Bool -allM p = go . toList - where - go [] = pure True - go (x:xs) = do - q <- p x - if q then go xs else pure False - --- | Monadic and constrained to 'Container' 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 :: (Container f, Monad m) => (Element f -> m Bool) -> f -> m Bool -anyM p = go . toList - where - go [] = pure False - go (x:xs) = do - q <- p x - if q then pure True else go xs - -{-# SPECIALIZE andM :: [IO Bool] -> IO Bool #-} -{-# SPECIALIZE orM :: [IO Bool] -> IO Bool #-} -{-# SPECIALIZE anyM :: (a -> IO Bool) -> [a] -> IO Bool #-} -{-# SPECIALIZE allM :: (a -> IO Bool) -> [a] -> IO Bool #-} - - -#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 - -instance MonadFail Maybe where - fail _ = Nothing - -instance MonadFail [] where - fail _ = [] - -instance MonadFail IO where - fail = P.fail - -instance MonadFail ReadPrec where - fail = P.fail -- = P (\_ -> fail s) - -instance MonadFail ReadP where - fail = P.fail -#endif diff --git a/src/Monad/Either.hs b/src/Monad/Either.hs deleted file mode 100644 --- a/src/Monad/Either.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE Safe #-} - --- | Utilites to work with @Either@ data type. - -module Monad.Either - ( module Data.Either - , fromLeft - , fromRight - , maybeToLeft - , maybeToRight - , leftToMaybe - , rightToMaybe - , whenLeft - , whenLeftM - , whenRight - , whenRightM - ) where - -import Control.Applicative (Applicative) -import Control.Monad (Monad (..)) -import Data.Either (Either (..), either, isLeft, isRight, lefts, - partitionEithers, rights) -import Data.Function (const) -import Data.Maybe (Maybe (..), maybe) - -import Applicative (pass) - - --- | Extracts value from 'Left' or return given default value. --- --- >>> fromLeft 0 (Left 3) --- 3 --- >>> fromLeft 0 (Right 5) --- 0 -fromLeft :: a -> Either a b -> a -fromLeft _ (Left a) = a -fromLeft a (Right _) = a - --- | Extracts value from 'Right' or return given default value. --- --- >>> fromRight 0 (Left 3) --- 0 --- >>> fromRight 0 (Right 5) --- 5 -fromRight :: b -> Either a b -> b -fromRight b (Left _) = b -fromRight _ (Right b) = b - --- | 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 deleted file mode 100644 --- a/src/Monad/Maybe.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE Safe #-} - --- | Utility functions to work with 'Data.Maybe' data type as monad. - -module Monad.Maybe - ( module Data.Maybe - - , maybeToMonoid - , whenJust - , whenJustM - , whenNothing - , whenNothing_ - , whenNothingM - , whenNothingM_ - ) where - -import Data.Maybe (Maybe (..), catMaybes, fromMaybe, isJust, isNothing, - mapMaybe, maybe, maybeToList) - -import Control.Applicative (Applicative, pure) -import Control.Monad (Monad (..)) -import Data.Monoid (Monoid (mempty)) - -import Applicative (pass) - --- | Extracts 'Monoid' value from 'Maybe' returning 'mempty' if 'Nothing'. --- --- >>> maybeToMonoid (Just [1,2,3] :: Maybe [Int]) --- [1,2,3] --- >>> maybeToMonoid (Nothing :: Maybe [Int]) --- [] -maybeToMonoid :: Monoid m => Maybe m -> m -maybeToMonoid = fromMaybe mempty - --- | 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 deleted file mode 100644 --- a/src/Monad/Trans.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE Safe #-} - --- | Monad transformers utilities. - -module Monad.Trans - ( -- * Reexports from @Control.Monad.*@ - module Control.Monad.Except - , module Control.Monad.Reader - , module Control.Monad.State.Strict - , module Control.Monad.Trans - , module Control.Monad.Trans.Identity - , module Control.Monad.Trans.Maybe - - -- * Convenient functions to work with 'Reader' monad - , usingReader - , usingReaderT - - -- * Convenient functions to work with 'State' monad - , evaluatingState - , evaluatingStateT - , executingState - , executingStateT - , usingState - , usingStateT - ) where - --- Monad transformers -import Control.Monad.Except (ExceptT (..), runExceptT) -import Control.Monad.Reader (MonadReader, Reader, ReaderT (..), ask, - asks, local, reader, runReader) -import Control.Monad.State.Strict (MonadState, State, StateT (..), evalState, - evalStateT, execState, execStateT, get, - gets, modify, modify', put, runState, - state, withState) -import Control.Monad.Trans (MonadIO, MonadTrans, lift, liftIO) -import Control.Monad.Trans.Identity (IdentityT (runIdentityT)) -import Control.Monad.Trans.Maybe (MaybeT (..), exceptToMaybeT, - maybeToExceptT) - -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/Nub.hs b/src/Nub.hs deleted file mode 100644 --- a/src/Nub.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-| Functions to remove duplicates from a list. - - = Performance - To check the performance there was done a bunch of benchmarks. - Benchmarks were made on lists of 'Prelude.Int's and 'Data.Text.Text's. - There were two types of list to use: - - * Lists which consist of many different elements - - * Lists which consist of many same elements - - - Here are some recomendations for usage of particular functions based on benchmarking resutls. - - * 'hashNub' is faster than 'ordNub' when there're not so many different values in the list. - - * 'hashNub' is the fastest with 'Data.Text.Text'. - - * 'sortNub' has better performance than 'ordNub' but should be used when sorting is also needed. - - * 'unstableNub' has better performance than 'hashNub' but doesn't save the original order. --} - -module Nub - ( hashNub - , ordNub - , sortNub - , unstableNub - ) where - -import Data.Eq (Eq) -import Data.Hashable (Hashable) -import Data.HashSet as HashSet -import Data.Ord (Ord) -import qualified Data.Set as Set -import Prelude ((.)) - --- | Like 'Prelude.nub' but runs in @O(n * log n)@ time and requires 'Ord'. --- --- >>> ordNub [3, 3, 3, 2, 2, -1, 1] --- [3, 2, -1, 1] -ordNub :: (Ord a) => [a] -> [a] -ordNub = go Set.empty - where - go _ [] = [] - go s (x:xs) = - if x `Set.member` s - then go s xs - else x : go (Set.insert x s) xs - --- | Like 'Prelude.nub' but runs in @O(n * log_16(n))@ time and requires 'Hashable'. --- --- >>> hashNub [3, 3, 3, 2, 2, -1, 1] --- [3, 2, -1, 1] -hashNub :: (Eq a, Hashable a) => [a] -> [a] -hashNub = go HashSet.empty - where - go _ [] = [] - go s (x:xs) = - if x `HashSet.member` s - then go s xs - else x : go (HashSet.insert x s) xs - --- | Like 'ordNub' but also sorts a list. --- --- >>> sortNub [3, 3, 3, 2, 2, -1, 1] --- [-1, 1, 2, 3] -sortNub :: (Ord a) => [a] -> [a] -sortNub = Set.toList . Set.fromList - --- | Like 'hashNub' but has better performance and also doesn't save the order. --- --- >>> unstableNub [3, 3, 3, 2, 2, -1, 1] --- [1, 2, 3, -1] -unstableNub :: (Eq a, Hashable a) => [a] -> [a] -unstableNub = HashSet.toList . HashSet.fromList diff --git a/src/Print.hs b/src/Print.hs deleted file mode 100644 --- a/src/Print.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE Trustworthy #-} - --- | Generalization of 'Prelude.putStr' and 'Prelude.putStrLn' functions. - -module Print - ( Print (..) - , print - , putText - , putLText - ) where - -import Data.Function ((.)) - -import Monad.Trans (MonadIO, liftIO) - -import qualified Base -import qualified Prelude (print, putStr, putStrLn) - -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 - --- | Lifted version of 'Prelude.print'. -print :: forall a m . (MonadIO m, Base.Show a) => a -> m () -print = liftIO . Prelude.print - --- | 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/String.hs b/src/String.hs deleted file mode 100644 --- a/src/String.hs +++ /dev/null @@ -1,196 +0,0 @@ -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} - --- | Type classes for convertion between different string representations. - -module String - ( module Data.String - - -- * Text - , module Text.Read - , module Data.Text - , module Data.Text.Lazy - , module Data.Text.Encoding - , module Data.Text.Encoding.Error - - , module Data.ByteString - - , ConvertUtf8 (..) - , ToString (..) - , ToLText (..) - , ToText (..) - - -- * Buildable class - , Buildable - - -- * Show and read functions - , readEither - , show - , pretty - , prettyL - - -- * Convenient type aliases - , LText - , LByteString - ) where - - --- for reexport -import Data.ByteString (ByteString) -import Data.String (IsString (..)) -import Data.Text (Text, lines, unlines, unwords, words) -import Data.Text.Buildable (Buildable (build)) -import Data.Text.Encoding (decodeUtf8', decodeUtf8With) -import Data.Text.Encoding.Error (OnDecodeError, OnError, UnicodeException, lenientDecode, - strictDecode) -import Data.Text.Lazy (fromStrict, toStrict) -import Text.Read (Read, readMaybe, reads) - --- for internal usage -import Data.Bifunctor (first) -import Data.Either (Either) -import Data.Function (id, (.)) -import Data.String (String) -import Data.Text.Lazy.Builder (toLazyText) - -import Functor ((<$>)) - -import qualified Base as Base (Show (show)) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as LB -import qualified Data.ByteString.Lazy.UTF8 as LBU -import qualified Data.ByteString.UTF8 as BU -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Encoding as LT -import qualified Text.Read (readEither) - --- | Type synonym for 'Data.Text.Lazy.Text'. -type LText = LT.Text - --- | Type synonym for 'Data.ByteString.Lazy.ByteString'. -type LByteString = LB.ByteString - - --- | 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 - encodeUtf8 = BU.fromString - decodeUtf8 = BU.toString - decodeUtf8Strict = (T.unpack <$>) . decodeUtf8Strict - -instance ConvertUtf8 T.Text B.ByteString where - encodeUtf8 = T.encodeUtf8 - decodeUtf8 = T.decodeUtf8With T.lenientDecode - decodeUtf8Strict = T.decodeUtf8' - -instance ConvertUtf8 LT.Text B.ByteString where - encodeUtf8 = LB.toStrict . encodeUtf8 - decodeUtf8 = LT.decodeUtf8With T.lenientDecode . LB.fromStrict - decodeUtf8Strict = decodeUtf8Strict . LB.fromStrict - -instance ConvertUtf8 String LB.ByteString where - encodeUtf8 = LBU.fromString - decodeUtf8 = LBU.toString - decodeUtf8Strict = (T.unpack <$>) . decodeUtf8Strict - -instance ConvertUtf8 T.Text LB.ByteString where - encodeUtf8 = LB.fromStrict . T.encodeUtf8 - decodeUtf8 = T.decodeUtf8With T.lenientDecode . LB.toStrict - decodeUtf8Strict = T.decodeUtf8' . LB.toStrict - -instance ConvertUtf8 LT.Text LB.ByteString where - encodeUtf8 = LT.encodeUtf8 - 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 - -instance ToText String where - toText = T.pack - -instance ToText T.Text where - toText = id - -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 - -instance ToLText String where - toLText = LT.pack - -instance ToLText T.Text where - toLText = LT.fromStrict - -instance ToLText LT.Text where - toLText = id - --- | Type class for converting other strings to 'String'. -class ToString a where - toString :: a -> String - -instance ToString String where - toString = id - -instance ToString T.Text where - toString = T.unpack - -instance ToString LT.Text where - toString = LT.unpack - --- | 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 = first toText . Text.Read.readEither . toString - --- | Generalized version of 'Prelude.show'. -show :: forall b a . (Base.Show a, IsString b) => a -> b -show x = fromString (Base.show x) -{-# SPECIALIZE show :: Base.Show a => a -> Text #-} -{-# SPECIALIZE show :: Base.Show a => a -> LText #-} -{-# SPECIALIZE show :: Base.Show a => a -> ByteString #-} -{-# SPECIALIZE show :: Base.Show a => a -> LByteString #-} -{-# SPECIALIZE show :: Base.Show a => a -> String #-} - --- | Functions to show pretty output for buildable data types. -pretty :: Buildable a => a -> Text -pretty = toStrict . prettyL - --- | Similar to 'pretty' but for 'LText'. -prettyL :: Buildable a => a -> LText -prettyL = toLazyText . build diff --git a/src/TypeOps.hs b/src/TypeOps.hs deleted file mode 100644 --- a/src/TypeOps.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE PolyKinds #-} -{-# 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 With - , type ($) - ) where - -#if __GLASGOW_HASKELL__ <= 710 -import GHC.Prim (Constraint) -#else -import Data.Kind (Constraint) -#endif - -import Control.Type.Operator (type ($), type (<+>)) - --- | Map several constraints over several variables. --- --- @ --- f :: Each [Show, Read] [a, 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 --- it with @\'@: --- --- @ --- f :: Each '[Show] [a, b] => a -> b -> String --- @ -type family Each (c :: [k -> Constraint]) (as :: [k]) where - Each c '[] = (() :: Constraint) - Each c (h ': t) = (c <+> h, Each c t) - --- | Map several constraints over a single variable. --- Note, that @With a b ≡ Each a '[b]@ --- --- @ --- a :: With [Show, Read] a => a -> a --- = --- a :: (Show a, Read a) => a -> a --- @ -type With a b = a <+> b diff --git a/src/Universum.hs b/src/Universum.hs --- a/src/Universum.hs +++ b/src/Universum.hs @@ -1,168 +1,61 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Trustworthy #-} +{-# 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 #-} +-- {-\# LANGUAGE NoImplicitPrelude \#-} -- -- import Universum -- @ module Universum ( -- * Reexports from base and from modules in this repo - module X -- Should I expand this to all modules to remove haddock warnings? - , module Base + module Universum.Applicative + , module Universum.Base + , module Universum.Bool + , module Universum.Container + , module Universum.Debug + , module Universum.DeepSeq + , module Universum.Exception + , module Universum.Function + , module Universum.Functor + , module Universum.Lifted + , module Universum.List + , module Universum.Monad + , module Universum.Monoid + , module Universum.Nub + , module Universum.Print + , module Universum.String + , module Universum.TypeOps + , module Universum.VarArg - -- * Useful standard unclassifed functions - , evaluateNF - , evaluateNF_ - , evaluateWHNF - , evaluateWHNF_ - , identity - , map - , uncons - , unsnoc + -- * Lenses + , module Lens.Micro + , module Lens.Micro.Mtl ) where -import Applicative as X -import Bool as X -import Container as X -import Debug as X -import Exceptions as X -import Functor as X -import Lifted as X -import List as X -import Monad as X -import Print as X -import String as X -import TypeOps as X -import VarArg as X - -import Base as Base hiding (error, show, showFloat, - showList, showSigned, showSignedFloat, - showsPrec, undefined) - --- Maybe'ized version of partial functions -import Safe as X (atDef, atMay, foldl1May, foldr1May, - headDef, headMay, initDef, initMay, - initSafe, lastDef, lastMay, tailDef, - tailMay, tailSafe) - --- 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 (..)) -import Data.Foldable as X (Foldable, concat, concatMap, foldlM, - foldrM, maximumBy, minimumBy) -import Data.Functor.Identity as X (Identity (..)) -import Data.Ord as X (Down (..), Ord (..), Ordering (..), - comparing) -import Data.Traversable as X (Traversable (..), fmapDefault, - foldMapDefault, forM, mapAccumL, - mapAccumR) - -#if ( __GLASGOW_HASKELL__ >= 800 ) -import Data.List.NonEmpty as X (NonEmpty (..), nonEmpty) -import Data.Monoid as X hiding ((<>)) -import Data.Semigroup as X (Option (..), Semigroup (sconcat, stimes, (<>)), - WrappedMonoid, cycle1, mtimesDefault, - stimesIdempotent, stimesIdempotentMonoid, - stimesMonoid) -#else -import Data.Monoid as X hiding ((<>)) -#endif - --- Deepseq -import Control.DeepSeq as X (NFData (..), deepseq, force, ($!!)) - --- Data structures -import Data.Tuple as X (curry, fst, snd, swap, uncurry) - -#if ( __GLASGOW_HASKELL__ >= 710 ) -import Data.Proxy as X (Proxy (..)) -import Data.Typeable as X (Typeable) -import Data.Void as X (Void, absurd, vacuous) -#endif - --- Base types -import Data.Bits as X (xor) -import Data.Bool as X (Bool (..), not, otherwise, (&&), (||)) -import Data.Char as X (chr) -import Data.Int as X (Int, Int16, Int32, Int64, Int8) -import Data.Word as X (Word, Word16, Word32, Word64, Word8, - byteSwap16, byteSwap32, byteSwap64) - -import Data.Function as X (const, fix, flip, on, ($), (.)) - --- Generics -import GHC.Generics as X (Generic) - --- IO -import System.IO as X (FilePath, Handle, IOMode (..), stderr, - stdin, stdout, withFile) +import Universum.Applicative +import Universum.Base +import Universum.Bool +import Universum.Container +import Universum.Debug +import Universum.DeepSeq +import Universum.Exception +import Universum.Function +import Universum.Functor +import Universum.Lifted +import Universum.List +import Universum.Monad +import Universum.Monoid +import Universum.Nub +import Universum.Print +import Universum.String +import Universum.TypeOps +import Universum.VarArg -- Lenses -import Lens.Micro as X (Lens, Lens', Traversal, Traversal', over, - set, (%~), (&), (.~), (<&>), (^.), (^..), - (^?), _1, _2, _3, _4, _5) -import Lens.Micro.Mtl as X (preuse, preview, use, view) - --- For internal usage only -import qualified Control.Exception.Base (evaluate) - --- | 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 - go x mxs = Just (case mxs of - Nothing -> ([], x) - Just (xs, e) -> (x:xs, e)) - --- | 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 +import Lens.Micro (Lens, Lens', Traversal, Traversal', over, set, (%~), (&), (.~), (<&>), (^.), + (^..), (^?), _1, _2, _3, _4, _5) +import Lens.Micro.Mtl (preuse, preview, use, view) diff --git a/src/Universum/Applicative.hs b/src/Universum/Applicative.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Applicative.hs @@ -0,0 +1,40 @@ +{-# 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 Universum.Applicative + ( module Control.Applicative + , pass + ) where + +import Control.Applicative (Alternative (..), Applicative (..), Const (..), ZipList (..), liftA2, + liftA3, optional, (<**>)) + +-- | Shorter alias for @pure ()@. +-- +-- >>> pass :: Maybe () +-- Just () +pass :: Applicative f => f () +pass = pure () + +{- +orAlt :: (Alternative f, Monoid a) => f a -> f a +orAlt f = f <|> pure mempty + +orEmpty :: Alternative f => Bool -> a -> f a +orEmpty b a = if b then pure a else empty + +eitherA :: Alternative f => f a -> f b -> f (Either a b) +eitherA a b = (Left <$> a) <|> (Right <$> b) + +purer :: (Applicative f, Applicative g) => a -> f (g a) +purer = pure . pure + +liftAA2 :: (Applicative f, Applicative g) => (a -> b -> c) -> f (g a) -> f (g b) -> f (g c) +liftAA2 = liftA2 . liftA2 + +(<<*>>) :: (Applicative f, Applicative g) => f (g (a -> b)) -> f (g a) -> f (g b) +(<<*>>) = liftA2 (<*>) +-} diff --git a/src/Universum/Base.hs b/src/Universum/Base.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Base.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE Unsafe #-} + +-- | Reexports from @GHC.*@ modules of +-- package. + +module Universum.Base + ( -- * Base types + module Data.Bits + , module Data.Char + , module Data.Int + , module Data.Word + + -- * Base type classes + , module Data.Eq + , module Data.Foldable + , module Data.Ord + , module Data.Traversable + + -- * System IO + , module System.IO + + -- * Base GHC types +#if ( __GLASGOW_HASKELL__ >= 710 ) + , module Data.Proxy + , module Data.Typeable + , module Data.Void +#endif + , module GHC.Base + , module GHC.Enum + , module GHC.Exts + , module GHC.Float + , module GHC.Generics + , module GHC.Num + , module GHC.Real + , module GHC.Show + +#if MIN_VERSION_base(4,10,0) + , module GHC.TypeNats +#else + , module GHC.TypeLits +#endif + , module GHC.Types + +#if ( __GLASGOW_HASKELL__ >= 800 ) + , module GHC.OverloadedLabels + , module GHC.ExecutionStack + , module GHC.Stack +#endif + + , ($!) + ) where + +-- Base types +import Data.Bits (xor) +import Data.Char (chr) +import Data.Int (Int, Int16, Int32, Int64, Int8) +import Data.Word (Word, Word16, Word32, Word64, Word8, byteSwap16, byteSwap32, byteSwap64) + +-- IO +import System.IO (FilePath, Handle, IOMode (..), stderr, stdin, stdout, withFile) + +-- Base typeclasses +import Data.Eq (Eq (..)) +import Data.Foldable (Foldable, concat, concatMap, foldlM, foldrM, maximumBy, minimumBy) +import Data.Ord (Down (..), Ord (..), Ordering (..), comparing) +import Data.Traversable (Traversable (..), fmapDefault, foldMapDefault, forM, mapAccumL, mapAccumR) + +-- Base GHC types +#if ( __GLASGOW_HASKELL__ >= 710 ) +import Data.Proxy (Proxy (..)) +import Data.Typeable (Typeable) +import Data.Void (Void, absurd, vacuous) +#endif + +import GHC.Base (String, asTypeOf, maxInt, minInt, ord, seq, (++)) +import GHC.Enum (Bounded (..), Enum (..), boundedEnumFrom, boundedEnumFromThen) +import GHC.Exts (Constraint, FunPtr, Ptr) +import GHC.Float (Double (..), Float (..), Floating (..)) +import GHC.Generics (Generic) +import GHC.Num (Integer, Num (..), subtract) +import GHC.Real hiding (showSigned, (%)) +import GHC.Show (Show) +#if MIN_VERSION_base(4,10,0) +import GHC.TypeNats (CmpNat, KnownNat, Nat, SomeNat (..), natVal, someNatVal) +#else +import GHC.TypeLits (CmpNat, KnownNat, Nat, SomeNat (..), natVal, someNatVal) +#endif + +import GHC.Types (Bool, Char, Coercible, IO, Int, Ordering, Word) + + +#if ( __GLASGOW_HASKELL__ >= 800 ) +import GHC.ExecutionStack (getStackTrace, showStackTrace) +import GHC.OverloadedLabels (IsLabel (..)) +import GHC.Stack (CallStack, HasCallStack, callStack, currentCallStack, getCallStack, + prettyCallStack, prettySrcLoc, withFrozenCallStack) +#endif + +-- Pending GHC 8.2 we'll expose these. + +{- +import GHC.Records as X ( + HasField(..) + ) + +<<<<<<< HEAD +======= +import Data.Kind as X ( + type (*) + , type Type + ) +-} + + +-- | Stricter version of 'Data.Function.$' operator. +-- Default Prelude defines this at the toplevel module, so we do as well. +-- +-- >>> 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 +infixr 0 $! diff --git a/src/Universum/Bool.hs b/src/Universum/Bool.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Bool.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE Safe #-} + +-- | Convenient commonly used and very helpful functions to work with +-- 'Bool' and also with monads. + +module Universum.Bool + ( module Universum.Bool.Guard + , module Universum.Bool.Reexport + ) where + +import Universum.Bool.Guard +import Universum.Bool.Reexport diff --git a/src/Universum/Bool/Guard.hs b/src/Universum/Bool/Guard.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Bool/Guard.hs @@ -0,0 +1,57 @@ +module Universum.Bool.Guard + ( guardM + , ifM + , unlessM + , whenM + ) where + +import Universum.Bool.Reexport (Bool, guard, unless, when) +import Universum.Function (flip) +import Universum.Monad (Monad, MonadPlus, (>>=)) + +-- | 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 +{-# 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 +{-# 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 +{-# INLINE ifM #-} + +-- | Monadic version of 'guard'. Occasionally useful. +-- Here some complex but real-life example: +-- @ +-- findSomePath :: IO (Maybe FilePath) +-- +-- somePath :: MaybeT IO FilePath +-- somePath = do +-- path <- MaybeT findSomePath +-- guardM $ liftIO $ doesDirectoryExist path +-- return path +-- @ +guardM :: MonadPlus m => m Bool -> m () +guardM f = f >>= guard +{-# INLINE guardM #-} diff --git a/src/Universum/Bool/Reexport.hs b/src/Universum/Bool/Reexport.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Bool/Reexport.hs @@ -0,0 +1,7 @@ +module Universum.Bool.Reexport + ( module Control.Monad + , module Data.Bool + ) where + +import Control.Monad (guard, unless, when) +import Data.Bool (Bool (..), bool, not, otherwise, (&&), (||)) diff --git a/src/Universum/Container.hs b/src/Universum/Container.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Container.hs @@ -0,0 +1,9 @@ +-- | This module exports all container-related stuff. + +module Universum.Container + ( module Universum.Container.Class + , module Universum.Container.Reexport + ) where + +import Universum.Container.Class +import Universum.Container.Reexport diff --git a/src/Universum/Container/Class.hs b/src/Universum/Container/Class.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Container/Class.hs @@ -0,0 +1,775 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# 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 Universum.Container.Class + ( -- * Foldable-like classes and methods + ToList (..) + , Container (..) + + , sum + , product + + , mapM_ + , forM_ + , traverse_ + , for_ + , sequenceA_ + , sequence_ + , asum + + -- * Others + , One(..) + ) where + +import Data.Coerce (Coercible, coerce) +import Prelude hiding (all, and, any, elem, foldMap, foldl, foldr, mapM_, notElem, or, product, + sequence_, sum) + +import Universum.Applicative (Alternative (..), Const, ZipList, pass) +import Universum.Base (Constraint, Word8) +import Universum.Container.Reexport (HashMap, HashSet, Hashable, IntMap, IntSet, Map, Seq, Set, + Vector) +import Universum.Functor (Identity) +import Universum.Monad.Reexport (fromMaybe) +import Universum.Monoid (All (..), Any (..), Dual, First (..), Last, Product, Sum) + +#if __GLASGOW_HASKELL__ >= 800 +import GHC.Err (errorWithoutStackTrace) +import GHC.TypeLits (ErrorMessage (..), Symbol, TypeError) +#endif + +#if ( __GLASGOW_HASKELL__ >= 800 ) +import qualified Data.List.NonEmpty as NE +import Universum.Monoid (NonEmpty) +#endif + +import qualified Data.Foldable as Foldable + +import qualified Data.List as List (null) + +import qualified Data.Sequence as SEQ + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL + +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HashSet +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import qualified Data.Map as M +import qualified Data.Set as Set + +import qualified Data.Vector as V +import qualified Data.Vector.Primitive as VP +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU + +---------------------------------------------------------------------------- +-- Containers (e.g. tuples aren't containers) +---------------------------------------------------------------------------- + +-- | Default implementation of 'Element' associated type family. +type family ElementDefault (t :: *) :: * where + ElementDefault (f a) = a + +-- | Type class for data types that can be converted to List. +-- Fully compatible with 'Foldable'. +-- Contains very small and safe subset of 'Foldable' functions. +-- +-- You can define 'Tolist' by just defining 'toList' function. +-- But the following law should be met: +-- +-- @'null' ≡ 'List.null' . 'toList'@ +-- +class ToList t where + -- | Type of element for some container. Implemented as an asscociated type family because + -- some containers are monomorphic over element type (like 'T.Text', 'IntSet', etc.) + -- so we can't implement nice interface using old higher-kinded types + -- approach. Implementing this as an associated type family instead of + -- top-level family gives you more control over element types. + type Element t :: * + type Element t = ElementDefault t + + -- | 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] + default toList :: (Foldable f, t ~ f a, Element t ~ a) => t -> [Element t] + toList = Foldable.toList + {-# INLINE toList #-} + + -- | Checks whether container is empty. + -- + -- >>> null @Text "" + -- True + -- >>> null @Text "aba" + -- False + null :: t -> Bool + null = List.null . toList + {-# INLINE null #-} + +---------------------------------------------------------------------------- +-- Instances for monomorphic containers +---------------------------------------------------------------------------- + +instance ToList T.Text where + type Element T.Text = Char + toList = T.unpack + {-# INLINE toList #-} + null = T.null + {-# INLINE null #-} + +instance ToList TL.Text where + type Element TL.Text = Char + toList = TL.unpack + {-# INLINE toList #-} + null = TL.null + {-# INLINE null #-} + +instance ToList BS.ByteString where + type Element BS.ByteString = Word8 + toList = BS.unpack + {-# INLINE toList #-} + null = BS.null + {-# INLINE null #-} + +instance ToList BSL.ByteString where + type Element BSL.ByteString = Word8 + toList = BSL.unpack + {-# INLINE toList #-} + null = BSL.null + {-# INLINE null #-} + +instance ToList IntSet where + type Element IntSet = Int + toList = IS.toList + {-# INLINE toList #-} + null = IS.null + {-# INLINE null #-} + +---------------------------------------------------------------------------- +-- Boilerplate instances (duplicate Foldable) +---------------------------------------------------------------------------- + +-- Basic types +instance ToList [a] +instance ToList (Maybe a) +instance ToList (Either a b) +instance ToList (Identity a) +instance ToList (Const a b) + +#if __GLASGOW_HASKELL__ >= 800 +-- Algebraic types +instance ToList (Dual a) +instance ToList (First a) +instance ToList (Last a) +instance ToList (Product a) +instance ToList (Sum a) +instance ToList (NonEmpty a) +instance ToList (ZipList a) +#endif + +-- Containers +instance ToList (HashMap k v) +instance ToList (HashSet v) +instance ToList (IntMap v) +instance ToList (Map k v) +instance ToList (Set v) +instance ToList (Seq a) +instance ToList (Vector a) + +---------------------------------------------------------------------------- +-- Additional operations that don't make much sense for e.g. Maybe +---------------------------------------------------------------------------- + +-- | A class for 'ToList's that aren't trivial like 'Maybe' (e.g. can hold +-- more than one value) +class ToList t => Container t where + -- | Constraint for elements. This can be used to implement more efficient + -- implementation of some methods. + type ElementConstraint t :: * -> Constraint + type ElementConstraint t = Eq + + foldr :: (Element t -> b -> b) -> b -> t -> b + default foldr :: (Foldable f, t ~ f a, Element t ~ a) => (Element t -> b -> b) -> b -> t -> b + foldr = Foldable.foldr + {-# INLINE foldr #-} + + foldl :: (b -> Element t -> b) -> b -> t -> b + default foldl :: (Foldable f, t ~ f a, Element t ~ a) => (b -> Element t -> b) -> b -> t -> b + foldl = Foldable.foldl + {-# INLINE foldl #-} + + foldl' :: (b -> Element t -> b) -> b -> t -> b + default foldl' :: (Foldable f, t ~ f a, Element t ~ a) => (b -> Element t -> b) -> b -> t -> b + foldl' = Foldable.foldl' + {-# INLINE foldl' #-} + + length :: t -> Int + default length :: (Foldable f, t ~ f a, Element t ~ a) => t -> Int + length = Foldable.length + {-# INLINE length #-} + + elem :: ElementConstraint t (Element t) => Element t -> t -> Bool + default elem :: ( Foldable f + , t ~ f a + , Element t ~ a + , ElementConstraint t ~ Eq + , ElementConstraint t (Element t) + ) => Element t -> t -> Bool + elem = Foldable.elem + {-# INLINE elem #-} + + maximum :: Ord (Element t) => t -> Element t + default maximum :: (Foldable f, t ~ f a, Element t ~ a, Ord (Element t)) => t -> Element t + maximum = Foldable.maximum + {-# INLINE maximum #-} + + minimum :: Ord (Element t) => t -> Element t + default minimum :: (Foldable f, t ~ f a, Element t ~ a, Ord (Element t)) => t -> Element t + minimum = Foldable.minimum + {-# INLINE minimum #-} + + foldMap :: Monoid m => (Element t -> m) -> t -> m + foldMap f = foldr (mappend . f) mempty + {-# INLINE foldMap #-} + + fold :: Monoid (Element t) => t -> Element t + fold = foldMap id + {-# INLINE fold #-} + + foldr' :: (Element t -> b -> b) -> b -> t -> b + foldr' f z0 xs = foldl f' id xs z0 + where f' k x z = k $! f x z + {-# INLINE foldr' #-} + + foldr1 :: (Element t -> Element t -> Element t) -> t -> Element t + foldr1 f xs = +#if __GLASGOW_HASKELL__ >= 800 + fromMaybe (errorWithoutStackTrace "foldr1: empty structure") + (foldr mf Nothing xs) +#else + fromMaybe (error "foldr1: empty structure") + (foldr mf Nothing xs) +#endif + where + mf x m = Just (case m of + Nothing -> x + Just y -> f x y) + {-# INLINE foldr1 #-} + + foldl1 :: (Element t -> Element t -> Element t) -> t -> Element t + foldl1 f xs = +#if __GLASGOW_HASKELL__ >= 800 + fromMaybe (errorWithoutStackTrace "foldl1: empty structure") + (foldl mf Nothing xs) +#else + fromMaybe (error "foldl1: empty structure") + (foldl mf Nothing xs) +#endif + where + mf m y = Just (case m of + Nothing -> y + Just x -> f x y) + {-# INLINE foldl1 #-} + + notElem :: ElementConstraint t (Element t) => Element t -> t -> Bool + notElem x = not . elem x + {-# INLINE notElem #-} + + all :: (Element t -> Bool) -> t -> Bool + all p = getAll #. foldMap (All #. p) + any :: (Element t -> Bool) -> t -> Bool + any p = getAny #. foldMap (Any #. p) + {-# INLINE all #-} + {-# INLINE any #-} + + and :: (Element t ~ Bool) => t -> Bool + and = getAll #. foldMap All + or :: (Element t ~ Bool) => t -> Bool + or = getAny #. foldMap Any + {-# INLINE and #-} + {-# INLINE or #-} + + find :: (Element t -> Bool) -> t -> Maybe (Element t) + find p = getFirst . foldMap (\ x -> First (if p x then Just x else Nothing)) + {-# INLINE find #-} + + safeHead :: t -> Maybe (Element t) + safeHead = foldr (\x _ -> Just x) Nothing + {-# INLINE safeHead #-} + +---------------------------------------------------------------------------- +-- Instances for monomorphic containers +---------------------------------------------------------------------------- + +instance Container T.Text where + foldr = T.foldr + {-# INLINE foldr #-} + foldl = T.foldl + {-# INLINE foldl #-} + foldl' = T.foldl' + {-# INLINE foldl' #-} + foldr1 = T.foldr1 + {-# INLINE foldr1 #-} + foldl1 = T.foldl1 + {-# INLINE foldl1 #-} + length = T.length + {-# INLINE length #-} + elem c = T.isInfixOf (T.singleton c) -- there are rewrite rules for this + {-# INLINE elem #-} + maximum = T.maximum + {-# INLINE maximum #-} + minimum = T.minimum + {-# INLINE minimum #-} + all = T.all + {-# INLINE all #-} + any = T.any + {-# INLINE any #-} + find = T.find + {-# INLINE find #-} + safeHead = fmap fst . T.uncons + {-# INLINE safeHead #-} + +instance Container TL.Text where + foldr = TL.foldr + {-# INLINE foldr #-} + foldl = TL.foldl + {-# INLINE foldl #-} + foldl' = TL.foldl' + {-# INLINE foldl' #-} + foldr1 = TL.foldr1 + {-# INLINE foldr1 #-} + foldl1 = TL.foldl1 + {-# INLINE foldl1 #-} + length = fromIntegral . TL.length + {-# INLINE length #-} + -- will be okay thanks to rewrite rules + elem c s = TL.isInfixOf (TL.singleton c) s + {-# INLINE elem #-} + maximum = TL.maximum + {-# INLINE maximum #-} + minimum = TL.minimum + {-# INLINE minimum #-} + all = TL.all + {-# INLINE all #-} + any = TL.any + {-# INLINE any #-} + find = TL.find + {-# INLINE find #-} + safeHead = fmap fst . TL.uncons + {-# INLINE safeHead #-} + +instance Container BS.ByteString where + foldr = BS.foldr + {-# INLINE foldr #-} + foldl = BS.foldl + {-# INLINE foldl #-} + foldl' = BS.foldl' + {-# INLINE foldl' #-} + foldr1 = BS.foldr1 + {-# INLINE foldr1 #-} + foldl1 = BS.foldl1 + {-# INLINE foldl1 #-} + length = BS.length + {-# INLINE length #-} + elem = BS.elem + {-# INLINE elem #-} + notElem = BS.notElem + {-# INLINE notElem #-} + maximum = BS.maximum + {-# INLINE maximum #-} + minimum = BS.minimum + {-# INLINE minimum #-} + all = BS.all + {-# INLINE all #-} + any = BS.any + {-# INLINE any #-} + find = BS.find + {-# INLINE find #-} + safeHead = fmap fst . BS.uncons + {-# INLINE safeHead #-} + +instance Container BSL.ByteString where + foldr = BSL.foldr + {-# INLINE foldr #-} + foldl = BSL.foldl + {-# INLINE foldl #-} + foldl' = BSL.foldl' + {-# INLINE foldl' #-} + foldr1 = BSL.foldr1 + {-# INLINE foldr1 #-} + foldl1 = BSL.foldl1 + {-# INLINE foldl1 #-} + length = fromIntegral . BSL.length + {-# INLINE length #-} + elem = BSL.elem + {-# INLINE elem #-} + notElem = BSL.notElem + {-# INLINE notElem #-} + maximum = BSL.maximum + {-# INLINE maximum #-} + minimum = BSL.minimum + {-# INLINE minimum #-} + all = BSL.all + {-# INLINE all #-} + any = BSL.any + {-# INLINE any #-} + find = BSL.find + {-# INLINE find #-} + safeHead = fmap fst . BSL.uncons + {-# INLINE safeHead #-} + +instance Container IntSet where + foldr = IS.foldr + {-# INLINE foldr #-} + foldl = IS.foldl + {-# INLINE foldl #-} + foldl' = IS.foldl' + {-# INLINE foldl' #-} + length = IS.size + {-# INLINE length #-} + elem = IS.member + {-# INLINE elem #-} + maximum = IS.findMax + {-# INLINE maximum #-} + minimum = IS.findMin + {-# INLINE minimum #-} + safeHead = fmap fst . IS.minView + {-# INLINE safeHead #-} + +---------------------------------------------------------------------------- +-- Efficient instances +---------------------------------------------------------------------------- + +instance Container (Set v) where + type ElementConstraint (Set v) = Ord + elem = Set.member + {-# INLINE elem #-} + notElem = Set.notMember + {-# INLINE notElem #-} + +class (Eq a, Hashable a) => CanHash a +instance (Eq a, Hashable a) => CanHash a + +instance Container (HashSet v) where + type ElementConstraint (HashSet v) = CanHash + elem = HashSet.member + {-# INLINE elem #-} + +---------------------------------------------------------------------------- +-- Boilerplate instances (duplicate Foldable) +---------------------------------------------------------------------------- + +-- Basic types +instance Container [a] +instance Container (Const a b) + +#if __GLASGOW_HASKELL__ >= 800 +-- Algebraic types +instance Container (Dual a) +instance Container (First a) +instance Container (Last a) +instance Container (Product a) +instance Container (Sum a) +instance Container (NonEmpty a) +instance Container (ZipList a) +#endif + +-- Containers +instance Container (HashMap k v) +instance Container (IntMap v) +instance Container (Map k v) +instance Container (Seq a) +instance Container (Vector a) + +---------------------------------------------------------------------------- +-- 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 :: (Container 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 :: (Container t, Num (Element t)) => t -> Element t +product = foldl' (*) 1 + +-- | Constrained to 'Container' version of 'Data.Foldable.traverse_'. +traverse_ + :: (Container t, Applicative f) + => (Element t -> f b) -> t -> f () +traverse_ f = foldr ((*>) . f) pass + +-- | Constrained to 'Container' version of 'Data.Foldable.for_'. +for_ + :: (Container t, Applicative f) + => t -> (Element t -> f b) -> f () +for_ = flip traverse_ +{-# INLINE for_ #-} + +-- | Constrained to 'Container' version of 'Data.Foldable.mapM_'. +mapM_ + :: (Container t, Monad m) + => (Element t -> m b) -> t -> m () +mapM_ f= foldr ((>>) . f) pass + +-- | Constrained to 'Container' version of 'Data.Foldable.forM_'. +forM_ + :: (Container t, Monad m) + => t -> (Element t -> m b) -> m () +forM_ = flip mapM_ +{-# INLINE forM_ #-} + +-- | Constrained to 'Container' version of 'Data.Foldable.sequenceA_'. +sequenceA_ + :: (Container t, Applicative f, Element t ~ f a) + => t -> f () +sequenceA_ = foldr (*>) pass + +-- | Constrained to 'Container' version of 'Data.Foldable.sequence_'. +sequence_ + :: (Container t, Monad m, Element t ~ m a) + => t -> m () +sequence_ = foldr (>>) pass + +-- | Constrained to 'Container' version of 'Data.Foldable.asum'. +asum + :: (Container t, Alternative f, Element t ~ f a) + => t -> f a +asum = foldr (<|>) empty +{-# INLINE asum #-} + +---------------------------------------------------------------------------- +-- Disallowed instances +---------------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 800 +type family DisallowInstance (z :: Symbol) :: ErrorMessage where + DisallowInstance z = Text "Do not use 'Foldable' methods on " :<>: Text z + :$$: Text "Suggestions:" + :$$: Text " Instead of" + :$$: Text " for_ :: (Foldable t, Applicative f) => t a -> (a -> f b) -> f ()" + :$$: Text " use" + :$$: Text " whenJust :: Applicative f => Maybe a -> (a -> f ()) -> f ()" + :$$: Text " whenRight :: Applicative f => Either l r -> (r -> f ()) -> f ()" + :$$: Text "" + :$$: Text " Instead of" + :$$: Text " fold :: (Foldable t, Monoid m) => t m -> m" + :$$: Text " use" + :$$: Text " maybeToMonoid :: Monoid m => Maybe m -> m" + :$$: Text "" +#endif + +#define DISALLOW_TO_LIST_8(t, z) \ + instance TypeError (DisallowInstance z) => \ + ToList (t) where { \ + toList = undefined; \ + null = undefined; } \ + +#define DISALLOW_CONTAINER_8(t, z) \ + instance TypeError (DisallowInstance z) => \ + Container (t) where { \ + foldr = undefined; \ + foldl = undefined; \ + foldl' = undefined; \ + length = undefined; \ + elem = undefined; \ + maximum = undefined; \ + minimum = undefined; } \ + +#define DISALLOW_TO_LIST_7(t) \ + instance ForbiddenFoldable (t) => ToList (t) where { \ + toList = undefined; \ + null = undefined; } \ + +#define DISALLOW_CONTAINER_7(t) \ + instance ForbiddenFoldable (t) => Container (t) where { \ + foldr = undefined; \ + foldl = undefined; \ + foldl' = undefined; \ + length = undefined; \ + elem = undefined; \ + maximum = undefined; \ + minimum = undefined; } \ + +#if __GLASGOW_HASKELL__ >= 800 +DISALLOW_TO_LIST_8((a, b),"tuples") +DISALLOW_CONTAINER_8((a, b),"tuples") +DISALLOW_CONTAINER_8(Maybe a,"Maybe") +DISALLOW_CONTAINER_8(Identity a,"Identity") +DISALLOW_CONTAINER_8(Either a b,"Either") +#else +class ForbiddenFoldable a +DISALLOW_TO_LIST_7((a, b)) +DISALLOW_CONTAINER_7((a, b)) +DISALLOW_CONTAINER_7(Maybe a) +DISALLOW_CONTAINER_7(Identity a) +DISALLOW_CONTAINER_7(Either a b) +#endif + +---------------------------------------------------------------------------- +-- 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. + one :: OneItem x -> x + +-- Lists + +instance One [a] where + type OneItem [a] = a + one = (:[]) + {-# INLINE one #-} + +#if ( __GLASGOW_HASKELL__ >= 800 ) +instance One (NE.NonEmpty a) where + type OneItem (NE.NonEmpty a) = a + one = (NE.:|[]) + {-# INLINE one #-} +#endif + +instance One (SEQ.Seq a) where + type OneItem (SEQ.Seq a) = a + one = (SEQ.empty SEQ.|>) + {-# INLINE one #-} + +-- Monomorphic sequences + +instance One T.Text where + type OneItem T.Text = Char + one = T.singleton + {-# INLINE one #-} + +instance One TL.Text where + type OneItem TL.Text = Char + one = TL.singleton + {-# INLINE one #-} + +instance One BS.ByteString where + type OneItem BS.ByteString = Word8 + one = BS.singleton + {-# INLINE one #-} + +instance One BSL.ByteString where + type OneItem BSL.ByteString = Word8 + one = BSL.singleton + {-# INLINE one #-} + +-- Maps + +instance One (M.Map k v) where + type OneItem (M.Map k v) = (k, v) + one = uncurry M.singleton + {-# INLINE one #-} + +instance Hashable k => One (HM.HashMap k v) where + type OneItem (HM.HashMap k v) = (k, v) + one = uncurry HM.singleton + {-# INLINE one #-} + +instance One (IM.IntMap v) where + type OneItem (IM.IntMap v) = (Int, v) + one = uncurry IM.singleton + {-# INLINE one #-} + +-- Sets + +instance One (Set v) where + type OneItem (Set v) = v + one = Set.singleton + {-# INLINE one #-} + +instance Hashable v => One (HashSet v) where + type OneItem (HashSet v) = v + one = HashSet.singleton + {-# INLINE one #-} + +instance One IntSet where + type OneItem IntSet = Int + one = IS.singleton + {-# INLINE one #-} + +-- Vectors + +instance One (Vector a) where + type OneItem (Vector a) = a + one = V.singleton + {-# INLINE one #-} + +instance VU.Unbox a => One (VU.Vector a) where + type OneItem (VU.Vector a) = a + one = VU.singleton + {-# INLINE one #-} + +instance VP.Prim a => One (VP.Vector a) where + type OneItem (VP.Vector a) = a + one = VP.singleton + {-# INLINE one #-} + +instance VS.Storable a => One (VS.Vector a) where + type OneItem (VS.Vector a) = a + one = VS.singleton + {-# INLINE one #-} + +---------------------------------------------------------------------------- +-- Utils +---------------------------------------------------------------------------- + +(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c) +(#.) _f = coerce +{-# INLINE (#.) #-} diff --git a/src/Universum/Container/Reexport.hs b/src/Universum/Container/Reexport.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Container/Reexport.hs @@ -0,0 +1,25 @@ +-- | This module reexports all container related stuff from 'Prelude'. + +module Universum.Container.Reexport + ( module Data.Hashable + , module Data.HashMap.Strict + , module Data.HashSet + , module Data.IntMap.Strict + , module Data.IntSet + , module Data.Map.Strict + , module Data.Sequence + , module Data.Set + , module Data.Tuple + , module Data.Vector + ) where + +import Data.Hashable (Hashable) +import Data.HashMap.Strict (HashMap) +import Data.HashSet (HashSet) +import Data.IntMap.Strict (IntMap) +import Data.IntSet (IntSet) +import Data.Map.Strict (Map) +import Data.Sequence (Seq) +import Data.Set (Set) +import Data.Tuple (curry, fst, snd, swap, uncurry) +import Data.Vector (Vector) diff --git a/src/Universum/Debug.hs b/src/Universum/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Debug.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# 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 Universum.Debug + ( Undefined (..) + , error + , trace + , traceM + , traceId + , traceShow + , traceShowId + , traceShowM + , undefined + ) where + +import Control.Monad (Monad, return) +import Data.Data (Data) +import Data.Text (Text, unpack) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import System.IO.Unsafe (unsafePerformIO) + +#if ( __GLASGOW_HASKELL__ >= 800 ) +import GHC.Exts (RuntimeRep, TYPE) + +import Universum.Base (HasCallStack) +#endif + +import Universum.Applicative (pass) +import Universum.Print (Print, putStrLn) + +import qualified Prelude as P + +-- | 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. +#if ( __GLASGOW_HASKELL__ >= 800 ) +error :: forall (r :: RuntimeRep) . forall (a :: TYPE r) . HasCallStack + => Text -> a +#else +error :: Text -> a +#endif +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')" #-} +#if ( __GLASGOW_HASKELL__ >= 800 ) +undefined :: forall (r :: RuntimeRep) . forall (a :: TYPE r) . HasCallStack => a +#else +undefined :: a +#endif +undefined = P.undefined diff --git a/src/Universum/DeepSeq.hs b/src/Universum/DeepSeq.hs new file mode 100644 --- /dev/null +++ b/src/Universum/DeepSeq.hs @@ -0,0 +1,32 @@ +module Universum.DeepSeq + ( module Control.DeepSeq + , evaluateNF + , evaluateNF_ + , evaluateWHNF + , evaluateWHNF_ + ) where + +import Control.DeepSeq (NFData (..), deepseq, force, ($!!)) + +import Universum.Base (seq) +import Universum.Function ((.)) +import Universum.Monad (MonadIO, liftIO, (<$!>)) + +import qualified Control.Exception.Base (evaluate) + +-- | 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 :: (NFData a, MonadIO m) => a -> m a +evaluateNF = evaluateWHNF . force + +-- | Alias for @evaluateWHNF . rnf@. Similar to 'evaluateNF' +-- but discards resulting value. +evaluateNF_ :: (NFData a, MonadIO m) => a -> m () +evaluateNF_ = evaluateWHNF . rnf diff --git a/src/Universum/Exception.hs b/src/Universum/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Exception.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Safe #-} + +-- | Re-exports most useful functionality from 'safe-exceptions'. Also +-- provides some functions to work with exceptions over 'MonadError'. + +module Universum.Exception + ( module Control.Exception.Safe + , note + ) where + +-- exceptions from safe-exceptions +import Control.Exception.Safe (Exception, MonadCatch, MonadMask (..), MonadThrow, + SomeException (..), bracket, bracket_, catch, catchAny, finally, + throwM) + +import Control.Applicative (Applicative (pure)) +import Control.Monad.Except (MonadError, throwError) +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 +#else +note :: (MonadError e m, Applicative m) => e -> Maybe a -> m a +note err = maybe (throwError err) pure +#endif diff --git a/src/Universum/Function.hs b/src/Universum/Function.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Function.hs @@ -0,0 +1,10 @@ +module Universum.Function + ( module Data.Function + , identity + ) where + +import Data.Function (const, fix, flip, on, ($), (.)) + +-- | Renamed version of 'Prelude.id'. +identity :: a -> a +identity x = x diff --git a/src/Universum/Functor.hs b/src/Universum/Functor.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Functor.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE Safe #-} + +-- | Convenient functions to work with 'Functor'. + +module Universum.Functor + ( module Universum.Functor.Fmap + , module Universum.Functor.Reexport + ) where + +import Universum.Functor.Fmap +import Universum.Functor.Reexport diff --git a/src/Universum/Functor/Fmap.hs b/src/Universum/Functor/Fmap.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Functor/Fmap.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE Safe #-} + +module Universum.Functor.Fmap + ( map + , (<<$>>) + ) where + +import Universum.Function ((.)) +import Universum.Functor.Reexport (Functor (..)) + +-- | 'Prelude.map' generalized to 'Functor'. +map :: Functor f => (a -> b) -> f a -> f b +map = fmap + +-- | 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/Universum/Functor/Reexport.hs b/src/Universum/Functor/Reexport.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Functor/Reexport.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Safe #-} + +module Universum.Functor.Reexport + ( module Control.Arrow + , module Data.Bifunctor + , module Data.Functor + , module Data.Functor.Identity + ) where + +import Control.Arrow ((&&&)) +import Data.Bifunctor (Bifunctor (..)) +import Data.Functor (Functor (..), void, ($>), (<$>)) +import Data.Functor.Identity (Identity (..)) diff --git a/src/Universum/Lifted.hs b/src/Universum/Lifted.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Lifted.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE Safe #-} + +-- | Lifted versions of base functions. + +module Universum.Lifted + ( module Universum.Lifted.Concurrent + , module Universum.Lifted.Env + , module Universum.Lifted.File + , module Universum.Lifted.IORef + , module Universum.Lifted.ST + ) where + +import Universum.Lifted.Concurrent +import Universum.Lifted.Env +import Universum.Lifted.File +import Universum.Lifted.IORef +import Universum.Lifted.ST diff --git a/src/Universum/Lifted/Concurrent.hs b/src/Universum/Lifted/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Lifted/Concurrent.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE Safe #-} + +-- | Concurrency useful and common functions. + +module Universum.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 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) + +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) + +---------------------------------------------------------------------------- +-- 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/Universum/Lifted/Env.hs b/src/Universum/Lifted/Env.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Lifted/Env.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE Safe #-} + +-- | Lifted versions of functions that work with environment. + +module Universum.Lifted.Env + ( getArgs + , exitWith + , exitFailure + , exitSuccess + , die + ) where + +import Control.Monad.Trans (MonadIO, liftIO) +import Data.String (String) +import Prelude ((>>)) +import System.Exit (ExitCode) +import System.IO (stderr) + +import qualified System.Environment as XIO +import qualified System.Exit as XIO +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/Universum/Lifted/File.hs b/src/Universum/Lifted/File.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Lifted/File.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} + +-- | Lifted versions of functions working with files and common IO. +-- All functions are specialized to 'Data.Text.Text'. + +module Universum.Lifted.File + ( appendFile + , getContents + , getLine + , interact + , openFile + , readFile + , writeFile + ) where + +import Control.Monad.Trans (MonadIO, liftIO) +import Data.Text (Text) +import Prelude (FilePath) +import System.IO (Handle, IOMode) + +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 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/Universum/Lifted/IORef.hs b/src/Universum/Lifted/IORef.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Lifted/IORef.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE Safe #-} + +-- | Lifted reexports from 'Data.IORef' module. + +module Universum.Lifted.IORef + ( IORef + , atomicModifyIORef + , atomicModifyIORef' + , atomicWriteIORef + , modifyIORef + , modifyIORef' + , newIORef + , readIORef + , writeIORef + ) where + +import Control.Monad.Trans (MonadIO, liftIO) +import Data.Function (($), (.)) +import Data.IORef (IORef) + +import qualified Data.IORef as Ref (atomicModifyIORef, atomicModifyIORef', atomicWriteIORef, + modifyIORef, modifyIORef', newIORef, readIORef, writeIORef) + +-- | 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/Universum/Lifted/ST.hs b/src/Universum/Lifted/ST.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Lifted/ST.hs @@ -0,0 +1,12 @@ +module Universum.Lifted.ST + ( stToIO + ) where + +import Control.Monad.Trans (MonadIO, liftIO) + +import qualified Control.Monad.ST as XIO + +-- | Lifted version of 'XIO.stToIO'. +stToIO :: MonadIO m => XIO.ST XIO.RealWorld a -> m a +stToIO a = liftIO (XIO.stToIO a) +{-# INLINE stToIO #-} diff --git a/src/Universum/List.hs b/src/Universum/List.hs new file mode 100644 --- /dev/null +++ b/src/Universum/List.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE Safe #-} + +-- | Utility functions to work with lists. + +module Universum.List + ( module Universum.List.Reexport + , module Universum.List.Safe + ) where + +import Universum.List.Reexport +import Universum.List.Safe diff --git a/src/Universum/List/Reexport.hs b/src/Universum/List/Reexport.hs new file mode 100644 --- /dev/null +++ b/src/Universum/List/Reexport.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Trustworthy #-} + +module Universum.List.Reexport + ( module Data.List + +#if ( __GLASGOW_HASKELL__ >= 800 ) + , module Data.List.NonEmpty +#endif + + , module GHC.Exts + ) where + +import Data.List (break, cycle, drop, dropWhile, filter, genericDrop, genericLength, + genericReplicate, genericSplitAt, genericTake, group, inits, intercalate, + intersperse, isPrefixOf, iterate, permutations, repeat, replicate, reverse, scanl, + scanr, sort, sortBy, sortOn, splitAt, subsequences, tails, take, takeWhile, + transpose, unfoldr, unzip, unzip3, zip, zip3, zipWith) + +#if ( __GLASGOW_HASKELL__ >= 800 ) +import Data.List.NonEmpty (head, init, last, tail) +#endif + +import GHC.Exts (sortWith) diff --git a/src/Universum/List/Safe.hs b/src/Universum/List/Safe.hs new file mode 100644 --- /dev/null +++ b/src/Universum/List/Safe.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Trustworthy #-} + +module Universum.List.Safe + ( list + , uncons +#if ( __GLASGOW_HASKELL__ >= 800 ) + , whenNotNull + , whenNotNullM +#endif + ) where + +#if ( __GLASGOW_HASKELL__ >= 800 ) +import Universum.Applicative (Applicative, pass) +import Universum.Monad (Monad (..)) +import Universum.Monoid (NonEmpty (..)) +#endif + +import Universum.Functor (fmap) +import Universum.Monad (Maybe (..)) + +-- | 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 + +-- | 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) + +#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 #-} +#endif diff --git a/src/Universum/Monad.hs b/src/Universum/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Monad.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE Trustworthy #-} + +-- | Reexporting useful monadic stuff. + +module Universum.Monad + ( module Universum.Monad.Container + , module Universum.Monad.Either + , module Universum.Monad.Maybe + , module Universum.Monad.Reexport + , module Universum.Monad.Trans + ) where + +import Universum.Monad.Container +import Universum.Monad.Either +import Universum.Monad.Maybe +import Universum.Monad.Reexport +import Universum.Monad.Trans diff --git a/src/Universum/Monad/Container.hs b/src/Universum/Monad/Container.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Monad/Container.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE TypeFamilies #-} + +module Universum.Monad.Container + ( concatMapM + , concatForM + + , allM + , anyM + , andM + , orM + ) where + +import Control.Applicative (Applicative (pure)) +import Data.Function ((.)) +import Data.Traversable (Traversable (traverse)) +import Prelude (Bool (..), Monoid, flip) + +import Universum.Base (IO) +import Universum.Container (Container, Element, fold, toList) +import Universum.Functor (fmap) +import Universum.Monad.Reexport (Monad (..)) + +-- | Lifting bind into a monad. Generalized version of @concatMap@ +-- 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] +-- @ +-- +-- Side note: previously it had type +-- +-- @ +-- concatMapM :: (Applicative q, Monad m, Traversable m) +-- => (a -> q (m b)) -> m a -> q (m b) +-- @ +-- +-- Such signature didn't allow to use this function when traversed container +-- type and type of returned by function-argument differed. +-- Now you can use it like e.g. +-- +-- @ +-- concatMapM readFile files >>= putStrLn +-- @ +concatMapM + :: ( Applicative f + , Monoid m + , Container (l m) + , Element (l m) ~ m + , Traversable l + ) + => (a -> f m) -> l a -> f m +concatMapM f = fmap fold . traverse f +{-# INLINE concatMapM #-} + +-- | Like 'concatMapM', but has its arguments flipped, so can be used +-- instead of the common @fmap concat $ forM@ pattern. +concatForM + :: ( Applicative f + , Monoid m + , Container (l m) + , Element (l m) ~ m + , Traversable l + ) + => l a -> (a -> f m) -> f m +concatForM = flip concatMapM +{-# INLINE concatForM #-} + +-- | Monadic and constrained to 'Container' 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 :: (Container f, Element f ~ m Bool, Monad m) => f -> m Bool +andM = go . toList + where + go [] = pure True + go (p:ps) = do + q <- p + if q then go ps else pure False + +-- | Monadic and constrained to 'Container' version of 'Prelude.or'. +-- +-- >>> orM [Just True, Just False] +-- Just True +-- >>> orM [Just True, Nothing] +-- Just True +-- >>> orM [Nothing, Just True] +-- Nothing +orM :: (Container f, Element f ~ m Bool, Monad m) => f -> m Bool +orM = go . toList + where + go [] = pure False + go (p:ps) = do + q <- p + if q then pure True else go ps + +-- | Monadic and constrained to 'Container' 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 :: (Container f, Monad m) => (Element f -> m Bool) -> f -> m Bool +allM p = go . toList + where + go [] = pure True + go (x:xs) = do + q <- p x + if q then go xs else pure False + +-- | Monadic and constrained to 'Container' 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 :: (Container f, Monad m) => (Element f -> m Bool) -> f -> m Bool +anyM p = go . toList + where + go [] = pure False + go (x:xs) = do + q <- p x + if q then pure True else go xs + +{-# SPECIALIZE andM :: [IO Bool] -> IO Bool #-} +{-# SPECIALIZE orM :: [IO Bool] -> IO Bool #-} +{-# SPECIALIZE anyM :: (a -> IO Bool) -> [a] -> IO Bool #-} +{-# SPECIALIZE allM :: (a -> IO Bool) -> [a] -> IO Bool #-} diff --git a/src/Universum/Monad/Either.hs b/src/Universum/Monad/Either.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Monad/Either.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE Safe #-} + +-- | Utilites to work with @Either@ data type. + +module Universum.Monad.Either + ( fromLeft + , fromRight + , maybeToLeft + , maybeToRight + , leftToMaybe + , rightToMaybe + , whenLeft + , whenLeftM + , whenRight + , whenRightM + ) where + +import Control.Applicative (Applicative) +import Control.Monad (Monad (..)) +import Data.Function (const) +import Data.Maybe (Maybe (..), maybe) + +import Universum.Applicative (pass) +import Universum.Monad.Reexport (Either (..), either) + + +-- | Extracts value from 'Left' or return given default value. +-- +-- >>> fromLeft 0 (Left 3) +-- 3 +-- >>> fromLeft 0 (Right 5) +-- 0 +fromLeft :: a -> Either a b -> a +fromLeft _ (Left a) = a +fromLeft a (Right _) = a + +-- | Extracts value from 'Right' or return given default value. +-- +-- >>> fromRight 0 (Left 3) +-- 0 +-- >>> fromRight 0 (Right 5) +-- 5 +fromRight :: b -> Either a b -> b +fromRight b (Left _) = b +fromRight _ (Right b) = b + +-- | 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/Universum/Monad/Maybe.hs b/src/Universum/Monad/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Monad/Maybe.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE Safe #-} + +-- | Utility functions to work with 'Data.Maybe' data type as monad. + +module Universum.Monad.Maybe + ( whenJust + , whenJustM + , whenNothing + , whenNothing_ + , whenNothingM + , whenNothingM_ + ) where + +import Universum.Applicative (Applicative, pass, pure) +import Universum.Monad.Reexport (Maybe (..), Monad (..)) + +-- | 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/Universum/Monad/Reexport.hs b/src/Universum/Monad/Reexport.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Monad/Reexport.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Trustworthy #-} + +module Universum.Monad.Reexport + ( -- * Reexport transformers + module Control.Monad.Except + , module Control.Monad.Reader + , module Control.Monad.State.Strict + , module Control.Monad.Trans + , module Control.Monad.Trans.Identity + , module Control.Monad.Trans.Maybe + + -- * Reexport Maybe + , module Data.Maybe + + -- * Reexport Either + , module Data.Either + + , Monad ((>>=), (>>), return) + , MonadFail (fail) + , MonadPlus (..) + + , (=<<) + , (>=>) + , (<=<) + , forever + + , join + , mfilter + , filterM + , mapAndUnzipM + , zipWithM + , zipWithM_ + , foldM + , foldM_ + , replicateM + , replicateM_ + + , liftM2 + , liftM3 + , liftM4 + , liftM5 + , ap + + , (<$!>) + ) where + +-- Monad transformers +import Control.Monad.Except (ExceptT (..), runExceptT) +import Control.Monad.Reader (MonadReader, Reader, ReaderT (..), ask, asks, local, reader, runReader) +import Control.Monad.State.Strict (MonadState, State, StateT (..), evalState, evalStateT, execState, + execStateT, get, gets, modify, modify', put, runState, state, + withState) +import Control.Monad.Trans (MonadIO, MonadTrans, lift, liftIO) +import Control.Monad.Trans.Identity (IdentityT (runIdentityT)) +import Control.Monad.Trans.Maybe (MaybeT (..), exceptToMaybeT, maybeToExceptT) + +-- Maybe +import Data.Maybe (Maybe (..), catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, + maybe, maybeToList) + +-- Either +import Data.Either (Either (..), either, isLeft, isRight, lefts, partitionEithers, rights) + +import Control.Monad hiding (fail) + +#if __GLASGOW_HASKELL__ >= 800 +import Control.Monad.Fail (MonadFail (..)) +#else +import Prelude (String) +import Text.ParserCombinators.ReadP (ReadP) +import Text.ParserCombinators.ReadPrec (ReadPrec) + +import Universum.Base (IO) + +import qualified Prelude as P (fail) + +-- | 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 + +instance MonadFail Maybe where + fail _ = Nothing + +instance MonadFail [] where + fail _ = [] + +instance MonadFail IO where + fail = P.fail + +instance MonadFail ReadPrec where + fail = P.fail -- = P (\_ -> fail s) + +instance MonadFail ReadP where + fail = P.fail +#endif diff --git a/src/Universum/Monad/Trans.hs b/src/Universum/Monad/Trans.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Monad/Trans.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE Safe #-} + +-- | Monad transformers utilities. + +module Universum.Monad.Trans + ( -- * Convenient functions to work with 'Reader' monad + usingReader + , usingReaderT + + -- * Convenient functions to work with 'State' monad + , evaluatingState + , evaluatingStateT + , executingState + , executingStateT + , usingState + , usingStateT + ) where + +import Prelude (flip, fst, snd) + +import Universum.Functor (Functor, (<$>)) +import Universum.Monad.Reexport (Reader, ReaderT, State, StateT, runReader, runReaderT, runState, + runStateT) + +-- | 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/Universum/Monoid.hs b/src/Universum/Monoid.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Monoid.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} + +module Universum.Monoid + ( +#if ( __GLASGOW_HASKELL__ >= 800 ) + module Data.List.NonEmpty + , module Data.Monoid + , module Data.Semigroup +#else + module Data.Monoid +#endif + , maybeToMonoid + ) where + +import Data.Monoid (All (..), Alt (..), Any (..), Dual (..), Endo (..), First (..), Last (..), + Monoid (..), Product (..), Sum (..)) + +#if ( __GLASGOW_HASKELL__ >= 800 ) +import Data.List.NonEmpty (NonEmpty (..), nonEmpty) +import Data.Semigroup (Option (..), Semigroup (sconcat, stimes, (<>)), WrappedMonoid, cycle1, + mtimesDefault, stimesIdempotent, stimesIdempotentMonoid, stimesMonoid) +#endif + +import Universum.Monad.Reexport (Maybe, fromMaybe) + +-- | Extracts 'Monoid' value from 'Maybe' returning 'mempty' if 'Nothing'. +-- +-- >>> maybeToMonoid (Just [1,2,3] :: Maybe [Int]) +-- [1,2,3] +-- >>> maybeToMonoid (Nothing :: Maybe [Int]) +-- [] +maybeToMonoid :: Monoid m => Maybe m -> m +maybeToMonoid = fromMaybe mempty diff --git a/src/Universum/Nub.hs b/src/Universum/Nub.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Nub.hs @@ -0,0 +1,77 @@ +{-| Functions to remove duplicates from a list. + + = Performance + To check the performance there was done a bunch of benchmarks. + Benchmarks were made on lists of 'Prelude.Int's and 'Data.Text.Text's. + There were two types of list to use: + + * Lists which consist of many different elements + + * Lists which consist of many same elements + + + Here are some recomendations for usage of particular functions based on benchmarking resutls. + + * 'hashNub' is faster than 'ordNub' when there're not so many different values in the list. + + * 'hashNub' is the fastest with 'Data.Text.Text'. + + * 'sortNub' has better performance than 'ordNub' but should be used when sorting is also needed. + + * 'unstableNub' has better performance than 'hashNub' but doesn't save the original order. +-} + +module Universum.Nub + ( hashNub + , ordNub + , sortNub + , unstableNub + ) where + +import Data.Eq (Eq) +import Data.Hashable (Hashable) +import Data.HashSet as HashSet +import Data.Ord (Ord) +import Prelude ((.)) + +import qualified Data.Set as Set + +-- | Like 'Prelude.nub' but runs in @O(n * log n)@ time and requires 'Ord'. +-- +-- >>> ordNub [3, 3, 3, 2, 2, -1, 1] +-- [3, 2, -1, 1] +ordNub :: (Ord a) => [a] -> [a] +ordNub = go Set.empty + where + go _ [] = [] + go s (x:xs) = + if x `Set.member` s + then go s xs + else x : go (Set.insert x s) xs + +-- | Like 'Prelude.nub' but runs in @O(n * log_16(n))@ time and requires 'Hashable'. +-- +-- >>> hashNub [3, 3, 3, 2, 2, -1, 1] +-- [3, 2, -1, 1] +hashNub :: (Eq a, Hashable a) => [a] -> [a] +hashNub = go HashSet.empty + where + go _ [] = [] + go s (x:xs) = + if x `HashSet.member` s + then go s xs + else x : go (HashSet.insert x s) xs + +-- | Like 'ordNub' but also sorts a list. +-- +-- >>> sortNub [3, 3, 3, 2, 2, -1, 1] +-- [-1, 1, 2, 3] +sortNub :: (Ord a) => [a] -> [a] +sortNub = Set.toList . Set.fromList + +-- | Like 'hashNub' but has better performance and also doesn't save the order. +-- +-- >>> unstableNub [3, 3, 3, 2, 2, -1, 1] +-- [1, 2, 3, -1] +unstableNub :: (Eq a, Hashable a) => [a] -> [a] +unstableNub = HashSet.toList . HashSet.fromList diff --git a/src/Universum/Print.hs b/src/Universum/Print.hs new file mode 100644 --- /dev/null +++ b/src/Universum/Print.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Trustworthy #-} + +-- | Generalization of 'Prelude.putStr' and 'Prelude.putStrLn' functions. + +module Universum.Print + ( Print (..) + , print + , putText + , putTextLn + , putLText + , putLTextLn + ) where + +import Data.Function ((.)) + +import Universum.Monad.Reexport (MonadIO, liftIO) + +import qualified Prelude (print, putStr, putStrLn) + +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 + +import qualified Universum.Base as Base + +-- | 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 + +-- | Lifted version of 'Prelude.print'. +print :: forall a m . (MonadIO m, Base.Show a) => a -> m () +print = liftIO . Prelude.print + +-- | Specialized to 'T.Text' version of 'putStr' or forcing type inference. +putText :: MonadIO m => T.Text -> m () +putText = putStr +{-# SPECIALIZE putText :: T.Text -> Base.IO () #-} + +-- | Specialized to 'T.Text' version of 'putStrLn' or forcing type inference. +putTextLn :: MonadIO m => T.Text -> m () +putTextLn = putStrLn +{-# SPECIALIZE putTextLn :: T.Text -> Base.IO () #-} + +-- | Specialized to 'TL.Text' version of 'putStr' or forcing type inference. +putLText :: MonadIO m => TL.Text -> m () +putLText = putStr +{-# SPECIALIZE putLText :: TL.Text -> Base.IO () #-} + +-- | Specialized to 'TL.Text' version of 'putStrLn' or forcing type inference. +putLTextLn :: MonadIO m => TL.Text -> m () +putLTextLn = putStrLn +{-# SPECIALIZE putLTextLn :: TL.Text -> Base.IO () #-} diff --git a/src/Universum/String.hs b/src/Universum/String.hs new file mode 100644 --- /dev/null +++ b/src/Universum/String.hs @@ -0,0 +1,9 @@ +-- | Type classes for convertion between different string representations. + +module Universum.String + ( module Universum.String.Conversion + , module Universum.String.Reexport + ) where + +import Universum.String.Conversion +import Universum.String.Reexport diff --git a/src/Universum/String/Conversion.hs b/src/Universum/String/Conversion.hs new file mode 100644 --- /dev/null +++ b/src/Universum/String/Conversion.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Universum.String.Conversion + ( -- * Convenient type aliases + LText + , LByteString + + -- * Conversion type classes + , ConvertUtf8 (..) + , ToString (..) + , ToLText (..) + , ToText (..) + + -- * Show and read functions + , readEither + , show + , pretty + , prettyL + ) where + +import Data.Bifunctor (first) +import Data.Either (Either) +import Data.Function (id, (.)) +import Data.String (String) +import Data.Text.Buildable (build) +import Data.Text.Lazy.Builder (toLazyText) + +import Universum.Functor ((<$>)) +import Universum.String.Reexport (Buildable, ByteString, IsString, Read, Text, fromString, toStrict) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Lazy.UTF8 as LBU +import qualified Data.ByteString.UTF8 as BU +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT +import qualified Text.Read (readEither) + +import qualified GHC.Show as Show (Show (show)) + +-- | Type synonym for 'Data.Text.Lazy.Text'. +type LText = LT.Text + +-- | Type synonym for 'Data.ByteString.Lazy.ByteString'. +type LByteString = LB.ByteString + + +-- | 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 + encodeUtf8 = BU.fromString + decodeUtf8 = BU.toString + decodeUtf8Strict = (T.unpack <$>) . decodeUtf8Strict + +instance ConvertUtf8 T.Text B.ByteString where + encodeUtf8 = T.encodeUtf8 + decodeUtf8 = T.decodeUtf8With T.lenientDecode + decodeUtf8Strict = T.decodeUtf8' + +instance ConvertUtf8 LT.Text B.ByteString where + encodeUtf8 = LB.toStrict . encodeUtf8 + decodeUtf8 = LT.decodeUtf8With T.lenientDecode . LB.fromStrict + decodeUtf8Strict = decodeUtf8Strict . LB.fromStrict + +instance ConvertUtf8 String LB.ByteString where + encodeUtf8 = LBU.fromString + decodeUtf8 = LBU.toString + decodeUtf8Strict = (T.unpack <$>) . decodeUtf8Strict + +instance ConvertUtf8 T.Text LB.ByteString where + encodeUtf8 = LB.fromStrict . T.encodeUtf8 + decodeUtf8 = T.decodeUtf8With T.lenientDecode . LB.toStrict + decodeUtf8Strict = T.decodeUtf8' . LB.toStrict + +instance ConvertUtf8 LT.Text LB.ByteString where + encodeUtf8 = LT.encodeUtf8 + 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 + +instance ToText String where + toText = T.pack + +instance ToText T.Text where + toText = id + +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 + +instance ToLText String where + toLText = LT.pack + +instance ToLText T.Text where + toLText = LT.fromStrict + +instance ToLText LT.Text where + toLText = id + +-- | Type class for converting other strings to 'String'. +class ToString a where + toString :: a -> String + +instance ToString String where + toString = id + +instance ToString T.Text where + toString = T.unpack + +instance ToString LT.Text where + toString = LT.unpack + +-- | 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 = first toText . Text.Read.readEither . toString + +-- | Generalized version of 'Prelude.show'. +show :: forall b a . (Show.Show a, IsString b) => a -> b +show x = fromString (Show.show x) +{-# SPECIALIZE show :: Show.Show a => a -> Text #-} +{-# SPECIALIZE show :: Show.Show a => a -> LText #-} +{-# SPECIALIZE show :: Show.Show a => a -> ByteString #-} +{-# SPECIALIZE show :: Show.Show a => a -> LByteString #-} +{-# SPECIALIZE show :: Show.Show a => a -> String #-} + +-- | Functions to show pretty output for buildable data types. +pretty :: Buildable a => a -> Text +pretty = toStrict . prettyL + +-- | Similar to 'pretty' but for 'LText'. +prettyL :: Buildable a => a -> LText +prettyL = toLazyText . build diff --git a/src/Universum/String/Reexport.hs b/src/Universum/String/Reexport.hs new file mode 100644 --- /dev/null +++ b/src/Universum/String/Reexport.hs @@ -0,0 +1,27 @@ +module Universum.String.Reexport + ( -- * String + module Data.String + + -- * Text + , module Data.Text + , module Data.Text.Lazy + , module Data.Text.Encoding + , module Data.Text.Encoding.Error + , module Text.Read + + -- * ByteString + , module Data.ByteString + + -- * Buildable + , module Data.Text.Buildable + ) where + +import Data.ByteString (ByteString) +import Data.String (IsString (..)) +import Data.Text (Text, lines, unlines, unwords, words) +import Data.Text.Buildable (Buildable) +import Data.Text.Encoding (decodeUtf8', decodeUtf8With) +import Data.Text.Encoding.Error (OnDecodeError, OnError, UnicodeException, lenientDecode, + strictDecode) +import Data.Text.Lazy (fromStrict, toStrict) +import Text.Read (Read, readMaybe, reads) diff --git a/src/Universum/TypeOps.hs b/src/Universum/TypeOps.hs new file mode 100644 --- /dev/null +++ b/src/Universum/TypeOps.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +#if __GLASGOW_HASKELL__ <= 710 +{-# LANGUAGE Trustworthy #-} +#else +{-# LANGUAGE Safe #-} +#endif + +-- | Type operators for writing convenient type signatures. + +module Universum.TypeOps + ( type Each + , type With + , type ($) + ) where + +#if __GLASGOW_HASKELL__ <= 710 +import GHC.Prim (Constraint) +#else +import Data.Kind (Constraint) +#endif + +import Control.Type.Operator (type ($), type (<+>)) + +-- | Map several constraints over several variables. +-- +-- @ +-- f :: Each [Show, Read] [a, 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 +-- it with @\'@: +-- +-- @ +-- f :: Each '[Show] [a, b] => a -> b -> String +-- @ +type family Each (c :: [k -> Constraint]) (as :: [k]) where + Each c '[] = (() :: Constraint) + Each c (h ': t) = (c <+> h, Each c t) + +-- | Map several constraints over a single variable. +-- Note, that @With a b ≡ Each a '[b]@ +-- +-- @ +-- a :: With [Show, Read] a => a -> a +-- = +-- a :: (Show a, Read a) => a -> a +-- @ +type With a b = a <+> b diff --git a/src/Universum/VarArg.hs b/src/Universum/VarArg.hs new file mode 100644 --- /dev/null +++ b/src/Universum/VarArg.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Provides operator of variable-arguments function composition. + +module Universum.VarArg + ( SuperComposition(..) + ) where + +class SuperComposition a b c | a b -> c where + -- | Allows to apply function to result of another function with multiple + -- arguments. + -- + -- >>> (show ... (+)) 1 2 + -- "3" + -- >>> show ... 5 + -- "5" + -- >>> (null ... zip5) [1] [2] [3] [] [5] + -- True + -- + -- Inspired by . + -- + -- ==== Performance + -- To check the performance there was done a bunch of benchmarks. Benchmarks were made on + -- examples given above and also on the functions of many arguments. + -- The results are showing that the operator ('...') performs as fast as + -- plain applications of the operator ('Prelude..') on almost all the tests, but ('...') + -- leads to the performance draw-down if @ghc@ fails to inline it. + -- Slow behavior was noticed on functions without type specifications. + -- That's why keep in mind that providing explicit type declarations for functions is very + -- important when using ('...'). + -- Relying on type inference will lead to the situation when all optimizations + -- disappear due to very general inferred type. However, functions without type + -- specification but with applied @INLINE@ pragma are fast again. + -- + (...) :: a -> b -> c + +infixl 8 ... + +instance (a ~ c, r ~ b) => + SuperComposition (a -> b) c r where + f ... g = f g + {-# INLINE (...) #-} + +instance (SuperComposition (a -> b) d r1, r ~ (c -> r1)) => + SuperComposition (a -> b) (c -> d) r where + (f ... g) c = f ... g c + {-# INLINE (...) #-} diff --git a/src/Unsafe.hs b/src/Unsafe.hs deleted file mode 100644 --- a/src/Unsafe.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# 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 - , unsafeInit - , unsafeLast - , unsafeFromJust - , unsafeIndex - ) where - -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 - --- | Cautionary alias for 'List.!!'. -unsafeIndex :: [a] -> Int -> a -unsafeIndex = (List.!!) - --- | Cautionary alias for 'Maybe.fromJust'. -unsafeFromJust :: Maybe.Maybe a -> a -unsafeFromJust = Maybe.fromJust diff --git a/src/VarArg.hs b/src/VarArg.hs deleted file mode 100644 --- a/src/VarArg.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE IncoherentInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - --- | Provides operator of variable-arguments function composition. - -module VarArg - ( SuperComposition(..) - ) where - -class SuperComposition a b c | a b -> c where - -- | Allows to apply function to result of another function with multiple - -- arguments. - -- - -- >>> (show ... (+)) 1 2 - -- "3" - -- >>> show ... 5 - -- "5" - -- >>> (null ... zip5) [1] [2] [3] [] [5] - -- True - -- - -- Inspired by . - -- - -- ==== Performance - -- To check the performance there was done a bunch of benchmarks. Benchmarks were made on - -- examples given above and also on the functions of many arguments. - -- The results are showing that the operator ('...') performs as fast as - -- plain applications of the operator ('Prelude..') on almost all the tests, but ('...') - -- leads to the performance draw-down if @ghc@ fails to inline it. - -- Slow behavior was noticed on functions without type specifications. - -- That's why keep in mind that providing explicit type declarations for functions is very - -- important when using ('...'). - -- Relying on type inference will lead to the situation when all optimizations - -- disappear due to very general inferred type. However, functions without type - -- specification but with applied @INLINE@ pragma are fast again. - -- - (...) :: a -> b -> c - -infixl 8 ... - -instance (a ~ c, r ~ b) => - SuperComposition (a -> b) c r where - f ... g = f g - {-# INLINE (...) #-} - -instance (SuperComposition (a -> b) d r1, r ~ (c -> r1)) => - SuperComposition (a -> b) (c -> d) r where - (f ... g) c = f ... g c - {-# INLINE (...) #-} diff --git a/universum.cabal b/universum.cabal --- a/universum.cabal +++ b/universum.cabal @@ -1,12 +1,12 @@ name: universum -version: 0.9.2 +version: 1.0.0 cabal-version: >=1.10 build-type: Simple license: MIT license-file: LICENSE -copyright: 2016-2016 Stephen Diehl, 2016-2017 Serokell +copyright: 2016 Stephen Diehl, 2016-2017 Serokell maintainer: Serokell -stability: well... +stability: stable homepage: https://github.com/serokell/universum bug-reports: https://github.com/serokell/universum/issues synopsis: Custom prelude used in Serokell @@ -25,43 +25,54 @@ library exposed-modules: Universum - Applicative - Base - Bool - Container - Container.Class - Container.Reexport - Debug - Exceptions - Functor - List - Nub - Print - String - TypeOps - Unsafe - VarArg - Lifted - Lifted.Concurrent - Lifted.Env - Lifted.File - Lifted.IORef - Monad - Monad.Either - Monad.Maybe - Monad.Trans + Universum.Applicative + Universum.Base + Universum.Bool + Universum.Bool.Guard + Universum.Bool.Reexport + Universum.Container + Universum.Container.Class + Universum.Container.Reexport + Universum.Debug + Universum.DeepSeq + Universum.Exception + Universum.Function + Universum.Functor + Universum.Functor.Fmap + Universum.Functor.Reexport + Universum.Lifted + Universum.Lifted.Concurrent + Universum.Lifted.Env + Universum.Lifted.File + Universum.Lifted.IORef + Universum.Lifted.ST + Universum.List + Universum.List.Reexport + Universum.List.Safe + Universum.Monad + Universum.Monad.Container + Universum.Monad.Either + Universum.Monad.Maybe + Universum.Monad.Reexport + Universum.Monad.Trans + Universum.Monoid + Universum.Nub + Universum.Print + Universum.String + Universum.String.Conversion + Universum.String.Reexport + Universum.TypeOps + Universum.VarArg build-depends: - base >=4.9.1.0 && <5, + base >=4.8 && <5, bytestring >=0.10.8.1, containers >=0.5.7.1, deepseq >=1.4.2.0, - exceptions >=0.8.3, ghc-prim >=0.5.0.0, hashable >=1.2.6.1, microlens >=0.4.8.1, microlens-mtl >=0.1.11.0, mtl >=2.2.1, - safe >=0.3.15, safe-exceptions >=0.1.6.0, stm >=2.4.4.1, text >=1.2.2.2,