diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,11 @@ +0.4.2 +===== + +* [#25](https://github.com/serokell/universum/issues/25): + Add vararg functions composition operator (...). +* Rewrite `concatMapM` & `concatForM` so that they allow traversed + and returned-by-function container types differ. + 0.4.1 ===== diff --git a/src/Containers.hs b/src/Containers.hs --- a/src/Containers.hs +++ b/src/Containers.hs @@ -4,8 +4,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} @@ -46,10 +46,9 @@ import qualified Data.Foldable as F import Data.Hashable (Hashable) import Data.Maybe (fromMaybe) -import Data.Monoid (All(..), Any(..), First(..)) +import Data.Monoid (All (..), Any (..), First (..)) import Data.Word (Word8) -import Prelude hiding (all, any, Foldable (..), mapM_, - sequence_) +import Prelude hiding (Foldable (..), all, any, mapM_, sequence_) #if __GLASGOW_HASKELL__ >= 800 import GHC.Err (errorWithoutStackTrace) @@ -68,17 +67,17 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS 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.Unboxed as VU import qualified Data.Vector.Primitive as VP import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU import Applicative (pass) @@ -472,13 +471,17 @@ ---------------------------------------------------------------------------- #define DISALLOW_CONTAINER_8(t, z) \ - instance TypeError (Text "Do not use 'Foldable' methods on " :<>: Text z) => \ + instance TypeError \ + (Text "Do not use 'Foldable' methods on " :<>: Text z :$$: \ + Text "NB. If you tried to use 'for_' on Maybe or Either, use 'whenJust' or 'whenRight' instead" ) => \ Container (t) where { \ toList = undefined; \ null = undefined; } \ #define DISALLOW_NONTRIVIAL_CONTAINER_8(t, z) \ - instance TypeError (Text "Do not use 'Foldable' methods on " :<>: Text z) => \ + instance TypeError \ + (Text "Do not use 'Foldable' methods on " :<>: Text z :$$: \ + Text "NB. If you tried to use 'for_' on Maybe or Either, use 'whenJust' or 'whenRight' instead" ) => \ NontrivialContainer (t) where { \ foldr = undefined; \ foldl = undefined; \ diff --git a/src/Monad.hs b/src/Monad.hs --- a/src/Monad.hs +++ b/src/Monad.hs @@ -60,7 +60,7 @@ import Data.Function ((.)) import Data.Functor (fmap) import Data.Traversable (Traversable (traverse)) -import Prelude (Bool (..), flip) +import Prelude (Bool (..), Monoid, flip) #if __GLASGOW_HASKELL__ >= 710 import Control.Monad hiding (fail, (<$!>)) @@ -77,7 +77,8 @@ import Text.ParserCombinators.ReadPrec (ReadPrec) #endif -import Containers (Element, NontrivialContainer, toList) +import Containers (Element, NontrivialContainer, fold, + toList) -- | Lifting bind into a monad. Generalized version of @concatMap@ -- that works with a monadic predicate. Old and simpler specialized to list @@ -86,19 +87,40 @@ -- @ -- concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] -- @ -concatMapM :: (Applicative q, Monad m, Traversable m) - => (a -> q (m b)) - -> m a - -> q (m b) -concatMapM f = fmap join . traverse f +-- +-- 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 + , NontrivialContainer (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 q, Monad m, Traversable m) - => m a - -> (a -> q (m b)) - -> q (m b) +concatForM + :: ( Applicative f + , Monoid m + , NontrivialContainer (l m) + , Traversable l + ) + => l a -> (a -> f m) -> f m concatForM = flip concatMapM {-# INLINE concatForM #-} diff --git a/src/Universum.hs b/src/Universum.hs --- a/src/Universum.hs +++ b/src/Universum.hs @@ -54,6 +54,7 @@ import Monad as X import Print as X import TypeOps as X +import VarArg as X import Base as Base hiding (error, show, showFloat, showList, showSigned, showSignedFloat, diff --git a/src/VarArg.hs b/src/VarArg.hs new file mode 100644 --- /dev/null +++ b/src/VarArg.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module VarArg + ( (...) + ) 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 +class Composition a b c | a b -> c where + (...) :: a -> b -> c + +instance (a ~ c, r ~ b) => + Composition (a -> b) c r where + f ... g = f g + {-# INLINE (...) #-} + +instance (Composition (a -> b) d r1, r ~ (c -> r1)) => + Composition (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,5 +1,5 @@ name: universum -version: 0.4.1 +version: 0.4.2 synopsis: Custom prelude used in Serokell description: Custom prelude used in Serokell homepage: https://github.com/serokell/universum @@ -38,6 +38,7 @@ Print TypeOps Unsafe + VarArg Lifted Lifted.Concurrent