diff options
author | Herbert Valerio Riedel <hvr@gnu.org> | 2015-09-27 12:01:41 +0200 |
---|---|---|
committer | Herbert Valerio Riedel <hvr@gnu.org> | 2015-10-02 08:24:43 +0200 |
commit | 03b380428c128b12aef07a9b67341803ef0bea76 (patch) | |
tree | dc6b692bf37369969b06f3ec0ce6c6a8bd8d8870 /libraries/base | |
parent | e3ab25a4d2e159d7c83de7e94252cace2e76d2a1 (diff) | |
download | haskell-03b380428c128b12aef07a9b67341803ef0bea76.tar.gz |
Add Data.Semigroup and Data.List.NonEmpty (re #10365)
This implements phase 1 of the semigroup-as-monoid-superclass
proposal (https://ghc.haskell.org/wiki/Proposal/SemigroupMonoid).
The modules were migrated from the `semigroups-0.17` release mostly
as-is, except for dropping several trivial `{-# INLINE #-}`s,
removing CPP usage, and instances for types & classes provided
outside of `base` (e.g. `containers`, `deepseq`, `hashable`, `tagged`,
`bytestring`, `text`)
Differential Revision: https://phabricator.haskell.org/D1284
Diffstat (limited to 'libraries/base')
-rw-r--r-- | libraries/base/Data/List/NonEmpty.hs | 522 | ||||
-rw-r--r-- | libraries/base/Data/Semigroup.hs | 640 | ||||
-rw-r--r-- | libraries/base/base.cabal | 2 | ||||
-rw-r--r-- | libraries/base/changelog.md | 4 |
4 files changed, 1168 insertions, 0 deletions
diff --git a/libraries/base/Data/List/NonEmpty.hs b/libraries/base/Data/List/NonEmpty.hs new file mode 100644 index 0000000000..6698a0ba58 --- /dev/null +++ b/libraries/base/Data/List/NonEmpty.hs @@ -0,0 +1,522 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Trustworthy #-} -- can't use Safe due to IsList instance +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.List.NonEmpty +-- Copyright : (C) 2011-2015 Edward Kmett, +-- (C) 2010 Tony Morris, Oliver Taylor, Eelis van der Weegen +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- A 'NonEmpty' list is one which always has at least one element, but +-- is otherwise identical to the traditional list type in complexity +-- and in terms of API. You will almost certainly want to import this +-- module @qualified@. +-- +-- @since 4.8.2.0 +---------------------------------------------------------------------------- + +module Data.List.NonEmpty ( + -- * The type of non-empty streams + NonEmpty(..) + + -- * Non-empty stream transformations + , map -- :: (a -> b) -> NonEmpty a -> NonEmpty b + , intersperse -- :: a -> NonEmpty a -> NonEmpty a + , scanl -- :: Foldable f => (b -> a -> b) -> b -> f a -> NonEmpty b + , scanr -- :: Foldable f => (a -> b -> b) -> b -> f a -> NonEmpty b + , scanl1 -- :: (a -> a -> a) -> NonEmpty a -> NonEmpty a + , scanr1 -- :: (a -> a -> a) -> NonEmpty a -> NonEmpty a + , transpose -- :: NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a) + , sortBy -- :: (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a + , sortWith -- :: Ord o => (a -> o) -> NonEmpty a -> NonEmpty a + -- * Basic functions + , length -- :: NonEmpty a -> Int + , head -- :: NonEmpty a -> a + , tail -- :: NonEmpty a -> [a] + , last -- :: NonEmpty a -> a + , init -- :: NonEmpty a -> [a] + , (<|), cons -- :: a -> NonEmpty a -> NonEmpty a + , uncons -- :: NonEmpty a -> (a, Maybe (NonEmpty a)) + , unfoldr -- :: (a -> (b, Maybe a)) -> a -> NonEmpty b + , sort -- :: NonEmpty a -> NonEmpty a + , reverse -- :: NonEmpty a -> NonEmpty a + , inits -- :: Foldable f => f a -> NonEmpty a + , tails -- :: Foldable f => f a -> NonEmpty a + -- * Building streams + , iterate -- :: (a -> a) -> a -> NonEmpty a + , repeat -- :: a -> NonEmpty a + , cycle -- :: NonEmpty a -> NonEmpty a + , unfold -- :: (a -> (b, Maybe a) -> a -> NonEmpty b + , insert -- :: (Foldable f, Ord a) => a -> f a -> NonEmpty a + , some1 -- :: Alternative f => f a -> f (NonEmpty a) + -- * Extracting sublists + , take -- :: Int -> NonEmpty a -> [a] + , drop -- :: Int -> NonEmpty a -> [a] + , splitAt -- :: Int -> NonEmpty a -> ([a], [a]) + , takeWhile -- :: Int -> NonEmpty a -> [a] + , dropWhile -- :: Int -> NonEmpty a -> [a] + , span -- :: Int -> NonEmpty a -> ([a],[a]) + , break -- :: Int -> NonEmpty a -> ([a],[a]) + , filter -- :: (a -> Bool) -> NonEmpty a -> [a] + , partition -- :: (a -> Bool) -> NonEmpty a -> ([a],[a]) + , group -- :: Foldable f => Eq a => f a -> [NonEmpty a] + , groupBy -- :: Foldable f => (a -> a -> Bool) -> f a -> [NonEmpty a] + , groupWith -- :: (Foldable f, Eq b) => (a -> b) -> f a -> [NonEmpty a] + , groupAllWith -- :: (Foldable f, Ord b) => (a -> b) -> f a -> [NonEmpty a] + , group1 -- :: Eq a => NonEmpty a -> NonEmpty (NonEmpty a) + , groupBy1 -- :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty (NonEmpty a) + , groupWith1 -- :: (Foldable f, Eq b) => (a -> b) -> f a -> NonEmpty (NonEmpty a) + , groupAllWith1 -- :: (Foldable f, Ord b) => (a -> b) -> f a -> NonEmpty (NonEmpty a) + -- * Sublist predicates + , isPrefixOf -- :: Foldable f => f a -> NonEmpty a -> Bool + -- * \"Set\" operations + , nub -- :: Eq a => NonEmpty a -> NonEmpty a + , nubBy -- :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty a + -- * Indexing streams + , (!!) -- :: NonEmpty a -> Int -> a + -- * Zipping and unzipping streams + , zip -- :: NonEmpty a -> NonEmpty b -> NonEmpty (a,b) + , zipWith -- :: (a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c + , unzip -- :: NonEmpty (a, b) -> (NonEmpty a, NonEmpty b) + -- * Functions on streams of characters + , words -- :: NonEmpty Char -> NonEmpty String + , unwords -- :: NonEmpty String -> NonEmpty Char + , lines -- :: NonEmpty Char -> NonEmpty String + , unlines -- :: NonEmpty String -> NonEmpty Char + -- * Converting to and from a list + , fromList -- :: [a] -> NonEmpty a + , toList -- :: NonEmpty a -> [a] + , nonEmpty -- :: [a] -> Maybe (NonEmpty a) + , xor -- :: NonEmpty a -> Bool + ) where + + +import Prelude hiding (break, cycle, drop, dropWhile, + filter, foldl, foldr, head, init, iterate, + last, length, lines, map, repeat, reverse, + scanl, scanl1, scanr, scanr1, span, + splitAt, tail, take, takeWhile, unlines, + unwords, unzip, words, zip, zipWith, (!!)) +import qualified Prelude + +import Control.Applicative (Alternative, many) +import Control.Monad (ap) +import Control.Monad.Fix +import Control.Monad.Zip (MonadZip(..)) +import Data.Data (Data) +import Data.Foldable hiding (length, toList) +import qualified Data.Foldable as Foldable +import Data.Function (on) +import qualified Data.List as List +import Data.Ord (comparing) +import qualified GHC.Exts as Exts (IsList(..)) +import GHC.Generics (Generic, Generic1) + +infixr 5 :|, <| + +-- | Non-empty (and non-strict) list type. +-- +-- @since 4.8.2.0 +data NonEmpty a = a :| [a] + deriving ( Eq, Ord, Show, Read, Data, Generic, Generic1 ) + +instance Exts.IsList (NonEmpty a) where + type Item (NonEmpty a) = a + fromList = fromList + toList = toList + +instance MonadFix NonEmpty where + mfix f = case fix (f . head) of + ~(x :| _) -> x :| mfix (tail . f) + +instance MonadZip NonEmpty where + mzip = zip + mzipWith = zipWith + munzip = unzip + +-- | Number of elements in 'NonEmpty' list. +length :: NonEmpty a -> Int +length (_ :| xs) = 1 + Prelude.length xs + +-- | Compute n-ary logic exclusive OR operation on 'NonEmpty' list. +xor :: NonEmpty Bool -> Bool +xor (x :| xs) = foldr xor' x xs + where xor' True y = not y + xor' False y = y + +-- | 'unfold' produces a new stream by repeatedly applying the unfolding +-- function to the seed value to produce an element of type @b@ and a new +-- seed value. When the unfolding function returns 'Nothing' instead of +-- a new seed value, the stream ends. +unfold :: (a -> (b, Maybe a)) -> a -> NonEmpty b +unfold f a = case f a of + (b, Nothing) -> b :| [] + (b, Just c) -> b <| unfold f c + +-- | 'nonEmpty' efficiently turns a normal list into a 'NonEmpty' stream, +-- producing 'Nothing' if the input is empty. +nonEmpty :: [a] -> Maybe (NonEmpty a) +nonEmpty [] = Nothing +nonEmpty (a:as) = Just (a :| as) + +-- | 'uncons' produces the first element of the stream, and a stream of the +-- remaining elements, if any. +uncons :: NonEmpty a -> (a, Maybe (NonEmpty a)) +uncons ~(a :| as) = (a, nonEmpty as) + +-- | The 'unfoldr' function is analogous to "Data.List"'s +-- 'Data.List.unfoldr' operation. +unfoldr :: (a -> (b, Maybe a)) -> a -> NonEmpty b +unfoldr f a = case f a of + (b, mc) -> b :| maybe [] go mc + where + go c = case f c of + (d, me) -> d : maybe [] go me + +instance Functor NonEmpty where + fmap f ~(a :| as) = f a :| fmap f as + b <$ ~(_ :| as) = b :| (b <$ as) + +instance Applicative NonEmpty where + pure a = a :| [] + (<*>) = ap + +instance Monad NonEmpty where + return a = a :| [] + ~(a :| as) >>= f = b :| (bs ++ bs') + where b :| bs = f a + bs' = as >>= toList . f + +instance Traversable NonEmpty where + traverse f ~(a :| as) = (:|) <$> f a <*> traverse f as + +instance Foldable NonEmpty where + foldr f z ~(a :| as) = f a (foldr f z as) + foldl f z ~(a :| as) = foldl f (f z a) as + foldl1 f ~(a :| as) = foldl f a as + foldMap f ~(a :| as) = f a `mappend` foldMap f as + fold ~(m :| ms) = m `mappend` fold ms + +-- | Extract the first element of the stream. +head :: NonEmpty a -> a +head ~(a :| _) = a + +-- | Extract the possibly-empty tail of the stream. +tail :: NonEmpty a -> [a] +tail ~(_ :| as) = as + +-- | Extract the last element of the stream. +last :: NonEmpty a -> a +last ~(a :| as) = List.last (a : as) + +-- | Extract everything except the last element of the stream. +init :: NonEmpty a -> [a] +init ~(a :| as) = List.init (a : as) + +-- | Prepend an element to the stream. +(<|) :: a -> NonEmpty a -> NonEmpty a +a <| ~(b :| bs) = a :| b : bs + +-- | Synonym for '<|'. +cons :: a -> NonEmpty a -> NonEmpty a +cons = (<|) + +-- | Sort a stream. +sort :: Ord a => NonEmpty a -> NonEmpty a +sort = lift List.sort + +-- | Converts a normal list to a 'NonEmpty' stream. +-- +-- Raises an error if given an empty list. +fromList :: [a] -> NonEmpty a +fromList (a:as) = a :| as +fromList [] = error "NonEmpty.fromList: empty list" + +-- | Convert a stream to a normal list efficiently. +toList :: NonEmpty a -> [a] +toList ~(a :| as) = a : as + +-- | Lift list operations to work on a 'NonEmpty' stream. +-- +-- /Beware/: If the provided function returns an empty list, +-- this will raise an error. +lift :: Foldable f => ([a] -> [b]) -> f a -> NonEmpty b +lift f = fromList . f . Foldable.toList + +-- | Map a function over a 'NonEmpty' stream. +map :: (a -> b) -> NonEmpty a -> NonEmpty b +map f ~(a :| as) = f a :| fmap f as + +-- | The 'inits' function takes a stream @xs@ and returns all the +-- finite prefixes of @xs@. +inits :: Foldable f => f a -> NonEmpty [a] +inits = fromList . List.inits . Foldable.toList + +-- | The 'tails' function takes a stream @xs@ and returns all the +-- suffixes of @xs@. +tails :: Foldable f => f a -> NonEmpty [a] +tails = fromList . List.tails . Foldable.toList + +-- | @'insert' x xs@ inserts @x@ into the last position in @xs@ where it +-- is still less than or equal to the next element. In particular, if the +-- list is sorted beforehand, the result will also be sorted. +insert :: (Foldable f, Ord a) => a -> f a -> NonEmpty a +insert a = fromList . List.insert a . Foldable.toList + +-- | @'some1' x@ sequences @x@ one or more times. +some1 :: Alternative f => f a -> f (NonEmpty a) +some1 x = (:|) <$> x <*> many x + +-- | 'scanl' is similar to 'foldl', but returns a stream of successive +-- reduced values from the left: +-- +-- > scanl f z [x1, x2, ...] == z :| [z `f` x1, (z `f` x1) `f` x2, ...] +-- +-- Note that +-- +-- > last (scanl f z xs) == foldl f z xs. +scanl :: Foldable f => (b -> a -> b) -> b -> f a -> NonEmpty b +scanl f z = fromList . List.scanl f z . Foldable.toList + +-- | 'scanr' is the right-to-left dual of 'scanl'. +-- Note that +-- +-- > head (scanr f z xs) == foldr f z xs. +scanr :: Foldable f => (a -> b -> b) -> b -> f a -> NonEmpty b +scanr f z = fromList . List.scanr f z . Foldable.toList + +-- | 'scanl1' is a variant of 'scanl' that has no starting value argument: +-- +-- > scanl1 f [x1, x2, ...] == x1 :| [x1 `f` x2, x1 `f` (x2 `f` x3), ...] +scanl1 :: (a -> a -> a) -> NonEmpty a -> NonEmpty a +scanl1 f ~(a :| as) = fromList (List.scanl f a as) + +-- | 'scanr1' is a variant of 'scanr' that has no starting value argument. +scanr1 :: (a -> a -> a) -> NonEmpty a -> NonEmpty a +scanr1 f ~(a :| as) = fromList (List.scanr1 f (a:as)) + +-- | 'intersperse x xs' alternates elements of the list with copies of @x@. +-- +-- > intersperse 0 (1 :| [2,3]) == 1 :| [0,2,0,3] +intersperse :: a -> NonEmpty a -> NonEmpty a +intersperse a ~(b :| bs) = b :| case bs of + [] -> [] + _ -> a : List.intersperse a bs + +-- | @'iterate' f x@ produces the infinite sequence +-- of repeated applications of @f@ to @x@. +-- +-- > iterate f x = x :| [f x, f (f x), ..] +iterate :: (a -> a) -> a -> NonEmpty a +iterate f a = a :| List.iterate f (f a) + +-- | @'cycle' xs@ returns the infinite repetition of @xs@: +-- +-- > cycle [1,2,3] = 1 :| [2,3,1,2,3,...] +cycle :: NonEmpty a -> NonEmpty a +cycle = fromList . List.cycle . toList + +-- | 'reverse' a finite NonEmpty stream. +reverse :: NonEmpty a -> NonEmpty a +reverse = lift List.reverse + +-- | @'repeat' x@ returns a constant stream, where all elements are +-- equal to @x@. +repeat :: a -> NonEmpty a +repeat a = a :| List.repeat a + +-- | @'take' n xs@ returns the first @n@ elements of @xs@. +take :: Int -> NonEmpty a -> [a] +take n = List.take n . toList + +-- | @'drop' n xs@ drops the first @n@ elements off the front of +-- the sequence @xs@. +drop :: Int -> NonEmpty a -> [a] +drop n = List.drop n . toList + +-- | @'splitAt' n xs@ returns a pair consisting of the prefix of @xs@ +-- of length @n@ and the remaining stream immediately following this prefix. +-- +-- > 'splitAt' n xs == ('take' n xs, 'drop' n xs) +-- > xs == ys ++ zs where (ys, zs) = 'splitAt' n xs +splitAt :: Int -> NonEmpty a -> ([a],[a]) +splitAt n = List.splitAt n . toList + +-- | @'takeWhile' p xs@ returns the longest prefix of the stream +-- @xs@ for which the predicate @p@ holds. +takeWhile :: (a -> Bool) -> NonEmpty a -> [a] +takeWhile p = List.takeWhile p . toList + +-- | @'dropWhile' p xs@ returns the suffix remaining after +-- @'takeWhile' p xs@. +dropWhile :: (a -> Bool) -> NonEmpty a -> [a] +dropWhile p = List.dropWhile p . toList + +-- | @'span' p xs@ returns the longest prefix of @xs@ that satisfies +-- @p@, together with the remainder of the stream. +-- +-- > 'span' p xs == ('takeWhile' p xs, 'dropWhile' p xs) +-- > xs == ys ++ zs where (ys, zs) = 'span' p xs +span :: (a -> Bool) -> NonEmpty a -> ([a], [a]) +span p = List.span p . toList + +-- | The @'break' p@ function is equivalent to @'span' (not . p)@. +break :: (a -> Bool) -> NonEmpty a -> ([a], [a]) +break p = span (not . p) + +-- | @'filter' p xs@ removes any elements from @xs@ that do not satisfy @p@. +filter :: (a -> Bool) -> NonEmpty a -> [a] +filter p = List.filter p . toList + +-- | The 'partition' function takes a predicate @p@ and a stream +-- @xs@, and returns a pair of lists. The first list corresponds to the +-- elements of @xs@ for which @p@ holds; the second corresponds to the +-- elements of @xs@ for which @p@ does not hold. +-- +-- > 'partition' p xs = ('filter' p xs, 'filter' (not . p) xs) +partition :: (a -> Bool) -> NonEmpty a -> ([a], [a]) +partition p = List.partition p . toList + +-- | The 'group' function takes a stream and returns a list of +-- streams such that flattening the resulting list is equal to the +-- argument. Moreover, each stream in the resulting list +-- contains only equal elements. For example, in list notation: +-- +-- > 'group' $ 'cycle' "Mississippi" +-- > = "M" : "i" : "ss" : "i" : "ss" : "i" : "pp" : "i" : "M" : "i" : ... +group :: (Foldable f, Eq a) => f a -> [NonEmpty a] +group = groupBy (==) + +-- | 'groupBy' operates like 'group', but uses the provided equality +-- predicate instead of `==`. +groupBy :: Foldable f => (a -> a -> Bool) -> f a -> [NonEmpty a] +groupBy eq0 = go eq0 . Foldable.toList + where + go _ [] = [] + go eq (x : xs) = (x :| ys) : groupBy eq zs + where (ys, zs) = List.span (eq x) xs + +-- | 'groupWith' operates like 'group', but uses the provided projection when +-- comparing for equality +groupWith :: (Foldable f, Eq b) => (a -> b) -> f a -> [NonEmpty a] +groupWith f = groupBy ((==) `on` f) + +-- | 'groupAllWith' operates like 'groupWith', but sorts the list +-- first so that each equivalence class has, at most, one list in the +-- output +groupAllWith :: (Ord b) => (a -> b) -> [a] -> [NonEmpty a] +groupAllWith f = groupWith f . List.sortBy (compare `on` f) + +-- | 'group1' operates like 'group', but uses the knowledge that its +-- input is non-empty to produce guaranteed non-empty output. +group1 :: Eq a => NonEmpty a -> NonEmpty (NonEmpty a) +group1 = groupBy1 (==) + +-- | 'groupBy1' is to 'group1' as 'groupBy' is to 'group'. +groupBy1 :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty (NonEmpty a) +groupBy1 eq (x :| xs) = (x :| ys) :| groupBy eq zs + where (ys, zs) = List.span (eq x) xs + +-- | 'groupWith1' is to 'group1' as 'groupWith' is to 'group' +groupWith1 :: (Eq b) => (a -> b) -> NonEmpty a -> NonEmpty (NonEmpty a) +groupWith1 f = groupBy1 ((==) `on` f) + +-- | 'groupAllWith1' is to 'groupWith1' as 'groupAllWith' is to 'groupWith' +groupAllWith1 :: (Ord b) => (a -> b) -> NonEmpty a -> NonEmpty (NonEmpty a) +groupAllWith1 f = groupWith1 f . sortWith f + +-- | The 'isPrefix' function returns @True@ if the first argument is +-- a prefix of the second. +isPrefixOf :: Eq a => [a] -> NonEmpty a -> Bool +isPrefixOf [] _ = True +isPrefixOf (y:ys) (x :| xs) = (y == x) && List.isPrefixOf ys xs + +-- | @xs !! n@ returns the element of the stream @xs@ at index +-- @n@. Note that the head of the stream has index 0. +-- +-- /Beware/: a negative or out-of-bounds index will cause an error. +(!!) :: NonEmpty a -> Int -> a +(!!) ~(x :| xs) n + | n == 0 = x + | n > 0 = xs List.!! (n - 1) + | otherwise = error "NonEmpty.!! negative argument" + +-- | The 'zip' function takes two streams and returns a stream of +-- corresponding pairs. +zip :: NonEmpty a -> NonEmpty b -> NonEmpty (a,b) +zip ~(x :| xs) ~(y :| ys) = (x, y) :| List.zip xs ys + +-- | The 'zipWith' function generalizes 'zip'. Rather than tupling +-- the elements, the elements are combined using the function +-- passed as the first argument. +zipWith :: (a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c +zipWith f ~(x :| xs) ~(y :| ys) = f x y :| List.zipWith f xs ys + +-- | The 'unzip' function is the inverse of the 'zip' function. +unzip :: Functor f => f (a,b) -> (f a, f b) +unzip xs = (fst <$> xs, snd <$> xs) + +-- | The 'words' function breaks a stream of characters into a +-- stream of words, which were delimited by white space. +-- +-- /Beware/: if the input contains no words (i.e. is entirely +-- whitespace), this will cause an error. +words :: NonEmpty Char -> NonEmpty String +words = lift List.words + +-- | The 'unwords' function is an inverse operation to 'words'. It +-- joins words with separating spaces. +-- +-- /Beware/: the input @(\"\" :| [])@ will cause an error. +unwords :: NonEmpty String -> NonEmpty Char +unwords = lift List.unwords + +-- | The 'lines' function breaks a stream of characters into a stream +-- of strings at newline characters. The resulting strings do not +-- contain newlines. +lines :: NonEmpty Char -> NonEmpty String +lines = lift List.lines + +-- | The 'unlines' function is an inverse operation to 'lines'. It +-- joins lines, after appending a terminating newline to each. +unlines :: NonEmpty String -> NonEmpty Char +unlines = lift List.unlines + +-- | The 'nub' function removes duplicate elements from a list. In +-- particular, it keeps only the first occurence of each element. +-- (The name 'nub' means \'essence\'.) +-- It is a special case of 'nubBy', which allows the programmer to +-- supply their own inequality test. +nub :: Eq a => NonEmpty a -> NonEmpty a +nub = nubBy (==) + +-- | The 'nubBy' function behaves just like 'nub', except it uses a +-- user-supplied equality predicate instead of the overloaded '==' +-- function. +nubBy :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty a +nubBy eq (a :| as) = a :| List.nubBy eq (List.filter (\b -> not (eq a b)) as) + +-- | 'transpose' for 'NonEmpty', behaves the same as 'Data.List.transpose' +-- The rows/columns need not be the same length, in which case +-- > transpose . transpose /= id +transpose :: NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a) +transpose = fmap fromList + . fromList . List.transpose . Foldable.toList + . fmap Foldable.toList + +-- | 'sortBy' for 'NonEmpty', behaves the same as 'Data.List.sortBy' +sortBy :: (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a +sortBy f = lift (List.sortBy f) + +-- | 'sortWith' for 'NonEmpty', behaves the same as: +-- +-- > sortBy . comparing +sortWith :: Ord o => (a -> o) -> NonEmpty a -> NonEmpty a +sortWith = sortBy . comparing diff --git a/libraries/base/Data/Semigroup.hs b/libraries/base/Data/Semigroup.hs new file mode 100644 index 0000000000..661e513cba --- /dev/null +++ b/libraries/base/Data/Semigroup.hs @@ -0,0 +1,640 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Semigroup +-- Copyright : (C) 2011-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- In mathematics, a semigroup is an algebraic structure consisting of a +-- set together with an associative binary operation. A semigroup +-- generalizes a monoid in that there might not exist an identity +-- element. It also (originally) generalized a group (a monoid with all +-- inverses) to a type where every element did not have to have an inverse, +-- thus the name semigroup. +-- +-- The use of @(\<\>)@ in this module conflicts with an operator with the same +-- name that is being exported by Data.Monoid. However, this package +-- re-exports (most of) the contents of Data.Monoid, so to use semigroups +-- and monoids in the same package just +-- +-- > import Data.Semigroup +-- +-- @since 4.8.2.0 +---------------------------------------------------------------------------- +module Data.Semigroup ( + Semigroup(..) + , stimesMonoid + , stimesIdempotent + , stimesIdempotentMonoid + , mtimesDefault + -- * Semigroups + , Min(..) + , Max(..) + , First(..) + , Last(..) + , WrappedMonoid(..) + -- * Re-exported monoids from Data.Monoid + , Monoid(..) + , Dual(..) + , Endo(..) + , All(..) + , Any(..) + , Sum(..) + , Product(..) + -- * A better monoid for Maybe + , Option(..) + , option + -- * Difference lists of a semigroup + , diff + , cycle1 + -- * ArgMin, ArgMax + , Arg(..) + , ArgMin + , ArgMax + ) where + +import Prelude hiding (foldr1) + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix +import Data.Bifunctor +import Data.Coerce +import Data.Data +import Data.List.NonEmpty +import Data.Monoid (All (..), Any (..), Dual (..), Endo (..), + Product (..), Sum (..)) +import Data.Monoid (Alt (..)) +import qualified Data.Monoid as Monoid +import Data.Proxy +import Data.Void +import GHC.Generics + +infixr 6 <> + +-- | The class of semigroups (types with an associative binary operation). +-- +-- @since 4.8.2.0 +class Semigroup a where + -- | An associative operation. + -- + -- @ + -- (a '<>' b) '<>' c = a '<>' (b '<>' c) + -- @ + -- + -- If @a@ is also a 'Monoid' we further require + -- + -- @ + -- ('<>') = 'mappend' + -- @ + (<>) :: a -> a -> a + + default (<>) :: Monoid a => a -> a -> a + (<>) = mappend + + -- | Reduce a non-empty list with @\<\>@ + -- + -- The default definition should be sufficient, but this can be + -- overridden for efficiency. + -- + sconcat :: NonEmpty a -> a + sconcat (a :| as) = go a as where + go b (c:cs) = b <> go c cs + go b [] = b + + -- | Repeat a value @n@ times. + -- + -- Given that this works on a 'Semigroup' it is allowed to fail if + -- you request 0 or fewer repetitions, and the default definition + -- will do so. + -- + -- By making this a member of the class, idempotent semigroups and monoids can + -- upgrade this to execute in /O(1)/ by picking + -- @stimes = stimesIdempotent@ or @stimes = stimesIdempotentMonoid@ + -- respectively. + stimes :: Integral b => b -> a -> a + stimes y0 x0 + | y0 <= 0 = error "stimes: positive multiplier expected" + | otherwise = f x0 y0 + where + f x y + | even y = f (x <> x) (y `quot` 2) + | y == 1 = x + | otherwise = g (x <> x) (pred y `quot` 2) x + g x y z + | even y = g (x <> x) (y `quot` 2) z + | y == 1 = x <> z + | otherwise = g (x <> x) (pred y `quot` 2) (x <> z) + +-- | A generalization of 'Data.List.cycle' to an arbitrary 'Semigroup'. +-- May fail to terminate for some values in some semigroups. +cycle1 :: Semigroup m => m -> m +cycle1 xs = xs' where xs' = xs <> xs' + +instance Semigroup () where + _ <> _ = () + sconcat _ = () + stimes _ _ = () + +instance Semigroup b => Semigroup (a -> b) where + f <> g = \a -> f a <> g a + stimes n f e = stimes n (f e) + +instance Semigroup [a] where + (<>) = (++) + stimes n x + | n < 0 = error "stimes: [], negative multiplier" + | otherwise = rep n + where + rep 0 = [] + rep i = x ++ rep (i - 1) + +instance Semigroup a => Semigroup (Maybe a) where + Nothing <> b = b + a <> Nothing = a + Just a <> Just b = Just (a <> b) + stimes _ Nothing = Nothing + stimes n (Just a) = case compare n 0 of + LT -> error "stimes: Maybe, negative multiplier" + EQ -> Nothing + GT -> Just (stimes n a) + +instance Semigroup (Either a b) where + Left _ <> b = b + a <> _ = a + stimes = stimesIdempotent + +instance (Semigroup a, Semigroup b) => Semigroup (a, b) where + (a,b) <> (a',b') = (a<>a',b<>b') + stimes n (a,b) = (stimes n a, stimes n b) + +instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (a, b, c) where + (a,b,c) <> (a',b',c') = (a<>a',b<>b',c<>c') + stimes n (a,b,c) = (stimes n a, stimes n b, stimes n c) + +instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d) + => Semigroup (a, b, c, d) where + (a,b,c,d) <> (a',b',c',d') = (a<>a',b<>b',c<>c',d<>d') + stimes n (a,b,c,d) = (stimes n a, stimes n b, stimes n c, stimes n d) + +instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e) + => Semigroup (a, b, c, d, e) where + (a,b,c,d,e) <> (a',b',c',d',e') = (a<>a',b<>b',c<>c',d<>d',e<>e') + stimes n (a,b,c,d,e) = + (stimes n a, stimes n b, stimes n c, stimes n d, stimes n e) + +instance Semigroup Ordering where + LT <> _ = LT + EQ <> y = y + GT <> _ = GT + stimes = stimesIdempotentMonoid + +instance Semigroup a => Semigroup (Dual a) where + Dual a <> Dual b = Dual (b <> a) + stimes n (Dual a) = Dual (stimes n a) + +instance Semigroup (Endo a) where + (<>) = coerce ((.) :: (a -> a) -> (a -> a) -> (a -> a)) + stimes = stimesMonoid + +instance Semigroup All where + (<>) = coerce (&&) + stimes = stimesIdempotentMonoid + +instance Semigroup Any where + (<>) = coerce (||) + stimes = stimesIdempotentMonoid + + +instance Num a => Semigroup (Sum a) where + (<>) = coerce ((+) :: a -> a -> a) + stimes n (Sum a) = Sum (fromIntegral n * a) + +instance Num a => Semigroup (Product a) where + (<>) = coerce ((*) :: a -> a -> a) + stimes n (Product a) = Product (a ^ n) + +-- | This is a valid definition of 'stimes' for a 'Monoid'. +-- +-- Unlike the default definition of 'stimes', it is defined for 0 +-- and so it should be preferred where possible. +stimesMonoid :: (Integral b, Monoid a) => b -> a -> a +stimesMonoid n x0 = case compare n 0 of + LT -> error "stimesMonoid: negative multiplier" + EQ -> mempty + GT -> f x0 n + where + f x y + | even y = f (x `mappend` x) (y `quot` 2) + | y == 1 = x + | otherwise = g (x `mappend` x) (pred y `quot` 2) x + g x y z + | even y = g (x `mappend` x) (y `quot` 2) z + | y == 1 = x `mappend` z + | otherwise = g (x `mappend` x) (pred y `quot` 2) (x `mappend` z) + +-- | This is a valid definition of 'stimes' for an idempotent 'Monoid'. +-- +-- When @mappend x x = x@, this definition should be preferred, because it +-- works in /O(1)/ rather than /O(log n)/ +stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a +stimesIdempotentMonoid n x = case compare n 0 of + LT -> error "stimesIdempotentMonoid: negative multiplier" + EQ -> mempty + GT -> x + +-- | This is a valid definition of 'stimes' for an idempotent 'Semigroup'. +-- +-- When @x <> x = x@, this definition should be preferred, because it +-- works in /O(1)/ rather than /O(log n)/. +stimesIdempotent :: Integral b => b -> a -> a +stimesIdempotent n x + | n <= 0 = error "stimesIdempotent: positive multiplier expected" + | otherwise = x + +instance Semigroup a => Semigroup (Const a b) where + (<>) = coerce ((<>) :: a -> a -> a) + stimes n (Const a) = Const (stimes n a) + +instance Semigroup (Monoid.First a) where + Monoid.First Nothing <> b = b + a <> _ = a + stimes = stimesIdempotentMonoid + +instance Semigroup (Monoid.Last a) where + a <> Monoid.Last Nothing = a + _ <> b = b + stimes = stimesIdempotentMonoid + +instance Alternative f => Semigroup (Alt f a) where + (<>) = coerce ((<|>) :: f a -> f a -> f a) + stimes = stimesMonoid + +instance Semigroup Void where + a <> _ = a + stimes = stimesIdempotent + +instance Semigroup (NonEmpty a) where + (a :| as) <> ~(b :| bs) = a :| (as ++ b : bs) + + +newtype Min a = Min { getMin :: a } + deriving (Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1) + +instance Bounded a => Bounded (Min a) where + minBound = Min minBound + maxBound = Min maxBound + +instance Enum a => Enum (Min a) where + succ (Min a) = Min (succ a) + pred (Min a) = Min (pred a) + toEnum = Min . toEnum + fromEnum = fromEnum . getMin + enumFrom (Min a) = Min <$> enumFrom a + enumFromThen (Min a) (Min b) = Min <$> enumFromThen a b + enumFromTo (Min a) (Min b) = Min <$> enumFromTo a b + enumFromThenTo (Min a) (Min b) (Min c) = Min <$> enumFromThenTo a b c + + +instance Ord a => Semigroup (Min a) where + (<>) = coerce (min :: a -> a -> a) + stimes = stimesIdempotent + +instance (Ord a, Bounded a) => Monoid (Min a) where + mempty = maxBound + mappend = (<>) + +instance Functor Min where + fmap f (Min x) = Min (f x) + +instance Foldable Min where + foldMap f (Min a) = f a + +instance Traversable Min where + traverse f (Min a) = Min <$> f a + +instance Applicative Min where + pure = Min + a <* _ = a + _ *> a = a + Min f <*> Min x = Min (f x) + +instance Monad Min where + return = Min + _ >> a = a + Min a >>= f = f a + +instance MonadFix Min where + mfix f = fix (f . getMin) + +instance Num a => Num (Min a) where + (Min a) + (Min b) = Min (a + b) + (Min a) * (Min b) = Min (a * b) + (Min a) - (Min b) = Min (a - b) + negate (Min a) = Min (negate a) + abs (Min a) = Min (abs a) + signum (Min a) = Min (signum a) + fromInteger = Min . fromInteger + +newtype Max a = Max { getMax :: a } + deriving (Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1) + +instance Bounded a => Bounded (Max a) where + minBound = Max minBound + maxBound = Max maxBound + +instance Enum a => Enum (Max a) where + succ (Max a) = Max (succ a) + pred (Max a) = Max (pred a) + toEnum = Max . toEnum + fromEnum = fromEnum . getMax + enumFrom (Max a) = Max <$> enumFrom a + enumFromThen (Max a) (Max b) = Max <$> enumFromThen a b + enumFromTo (Max a) (Max b) = Max <$> enumFromTo a b + enumFromThenTo (Max a) (Max b) (Max c) = Max <$> enumFromThenTo a b c + +instance Ord a => Semigroup (Max a) where + (<>) = coerce (max :: a -> a -> a) + stimes = stimesIdempotent + +instance (Ord a, Bounded a) => Monoid (Max a) where + mempty = minBound + mappend = (<>) + +instance Functor Max where + fmap f (Max x) = Max (f x) + +instance Foldable Max where + foldMap f (Max a) = f a + +instance Traversable Max where + traverse f (Max a) = Max <$> f a + +instance Applicative Max where + pure = Max + a <* _ = a + _ *> a = a + Max f <*> Max x = Max (f x) + +instance Monad Max where + return = Max + _ >> a = a + Max a >>= f = f a + +instance MonadFix Max where + mfix f = fix (f . getMax) + +instance Num a => Num (Max a) where + (Max a) + (Max b) = Max (a + b) + (Max a) * (Max b) = Max (a * b) + (Max a) - (Max b) = Max (a - b) + negate (Max a) = Max (negate a) + abs (Max a) = Max (abs a) + signum (Max a) = Max (signum a) + fromInteger = Max . fromInteger + +-- | 'Arg' isn't itself a 'Semigroup' in its own right, but it can be +-- placed inside 'Min' and 'Max' to compute an arg min or arg max. +data Arg a b = Arg a b deriving + (Show, Read, Data, Typeable, Generic, Generic1) + +type ArgMin a b = Min (Arg a b) +type ArgMax a b = Max (Arg a b) + +instance Functor (Arg a) where + fmap f (Arg x a) = Arg x (f a) + +instance Foldable (Arg a) where + foldMap f (Arg _ a) = f a + +instance Traversable (Arg a) where + traverse f (Arg x a) = Arg x <$> f a + +instance Eq a => Eq (Arg a b) where + Arg a _ == Arg b _ = a == b + +instance Ord a => Ord (Arg a b) where + Arg a _ `compare` Arg b _ = compare a b + min x@(Arg a _) y@(Arg b _) + | a <= b = x + | otherwise = y + max x@(Arg a _) y@(Arg b _) + | a >= b = x + | otherwise = y + +instance Bifunctor Arg where + bimap f g (Arg a b) = Arg (f a) (g b) + +-- | Use @'Option' ('First' a)@ to get the behavior of +-- 'Data.Monoid.First' from "Data.Monoid". +newtype First a = First { getFirst :: a } deriving + (Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1) + +instance Bounded a => Bounded (First a) where + minBound = First minBound + maxBound = First maxBound + +instance Enum a => Enum (First a) where + succ (First a) = First (succ a) + pred (First a) = First (pred a) + toEnum = First . toEnum + fromEnum = fromEnum . getFirst + enumFrom (First a) = First <$> enumFrom a + enumFromThen (First a) (First b) = First <$> enumFromThen a b + enumFromTo (First a) (First b) = First <$> enumFromTo a b + enumFromThenTo (First a) (First b) (First c) = First <$> enumFromThenTo a b c + +instance Semigroup (First a) where + a <> _ = a + stimes = stimesIdempotent + +instance Functor First where + fmap f (First x) = First (f x) + +instance Foldable First where + foldMap f (First a) = f a + +instance Traversable First where + traverse f (First a) = First <$> f a + +instance Applicative First where + pure x = First x + a <* _ = a + _ *> a = a + First f <*> First x = First (f x) + +instance Monad First where + return = First + _ >> a = a + First a >>= f = f a + +instance MonadFix First where + mfix f = fix (f . getFirst) + +-- | Use @'Option' ('Last' a)@ to get the behavior of +-- 'Data.Monoid.Last' from "Data.Monoid" +newtype Last a = Last { getLast :: a } deriving + (Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1) + +instance Bounded a => Bounded (Last a) where + minBound = Last minBound + maxBound = Last maxBound + +instance Enum a => Enum (Last a) where + succ (Last a) = Last (succ a) + pred (Last a) = Last (pred a) + toEnum = Last . toEnum + fromEnum = fromEnum . getLast + enumFrom (Last a) = Last <$> enumFrom a + enumFromThen (Last a) (Last b) = Last <$> enumFromThen a b + enumFromTo (Last a) (Last b) = Last <$> enumFromTo a b + enumFromThenTo (Last a) (Last b) (Last c) = Last <$> enumFromThenTo a b c + +instance Semigroup (Last a) where + _ <> b = b + stimes = stimesIdempotent + +instance Functor Last where + fmap f (Last x) = Last (f x) + a <$ _ = Last a + +instance Foldable Last where + foldMap f (Last a) = f a + +instance Traversable Last where + traverse f (Last a) = Last <$> f a + +instance Applicative Last where + pure = Last + a <* _ = a + _ *> a = a + Last f <*> Last x = Last (f x) + +instance Monad Last where + return = Last + _ >> a = a + Last a >>= f = f a + +instance MonadFix Last where + mfix f = fix (f . getLast) + +-- | Provide a Semigroup for an arbitrary Monoid. +newtype WrappedMonoid m = WrapMonoid { unwrapMonoid :: m } + deriving (Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1) + +instance Monoid m => Semigroup (WrappedMonoid m) where + (<>) = coerce (mappend :: m -> m -> m) + +instance Monoid m => Monoid (WrappedMonoid m) where + mempty = WrapMonoid mempty + mappend = (<>) + +instance Bounded a => Bounded (WrappedMonoid a) where + minBound = WrapMonoid minBound + maxBound = WrapMonoid maxBound + +instance Enum a => Enum (WrappedMonoid a) where + succ (WrapMonoid a) = WrapMonoid (succ a) + pred (WrapMonoid a) = WrapMonoid (pred a) + toEnum = WrapMonoid . toEnum + fromEnum = fromEnum . unwrapMonoid + enumFrom (WrapMonoid a) = WrapMonoid <$> enumFrom a + enumFromThen (WrapMonoid a) (WrapMonoid b) = WrapMonoid <$> enumFromThen a b + enumFromTo (WrapMonoid a) (WrapMonoid b) = WrapMonoid <$> enumFromTo a b + enumFromThenTo (WrapMonoid a) (WrapMonoid b) (WrapMonoid c) = + WrapMonoid <$> enumFromThenTo a b c + +-- | Repeat a value @n@ times. +-- +-- > mtimesDefault n a = a <> a <> ... <> a -- using <> (n-1) times +-- +-- Implemented using 'stimes' and 'mempty'. +-- +-- This is a suitable definition for an 'mtimes' member of 'Monoid'. +mtimesDefault :: (Integral b, Monoid a) => b -> a -> a +mtimesDefault n x + | n == 0 = mempty + | otherwise = unwrapMonoid (stimes n (WrapMonoid x)) + +-- | 'Option' is effectively 'Maybe' with a better instance of +-- 'Monoid', built off of an underlying 'Semigroup' instead of an +-- underlying 'Monoid'. +-- +-- Ideally, this type would not exist at all and we would just fix the +-- 'Monoid' instance of 'Maybe' +newtype Option a = Option { getOption :: Maybe a } + deriving (Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1) + +instance Functor Option where + fmap f (Option a) = Option (fmap f a) + +instance Applicative Option where + pure a = Option (Just a) + Option a <*> Option b = Option (a <*> b) + +instance Monad Option where + return = pure + + Option (Just a) >>= k = k a + _ >>= _ = Option Nothing + + Option Nothing >> _ = Option Nothing + _ >> b = b + +instance Alternative Option where + empty = Option Nothing + Option Nothing <|> b = b + a <|> _ = a + +instance MonadPlus Option where + mzero = Option Nothing + mplus = (<|>) + +instance MonadFix Option where + mfix f = Option (mfix (getOption . f)) + +instance Foldable Option where + foldMap f (Option (Just m)) = f m + foldMap _ (Option Nothing) = mempty + +instance Traversable Option where + traverse f (Option (Just a)) = Option . Just <$> f a + traverse _ (Option Nothing) = pure (Option Nothing) + +-- | Fold an 'Option' case-wise, just like 'maybe'. +option :: b -> (a -> b) -> Option a -> b +option n j (Option m) = maybe n j m + +instance Semigroup a => Semigroup (Option a) where + (<>) = coerce ((<>) :: Maybe a -> Maybe a -> Maybe a) + + stimes _ (Option Nothing) = Option Nothing + stimes n (Option (Just a)) = case compare n 0 of + LT -> error "stimes: Option, negative multiplier" + EQ -> Option Nothing + GT -> Option (Just (stimes n a)) + +instance Semigroup a => Monoid (Option a) where + mempty = Option Nothing + mappend = (<>) + +-- | This lets you use a difference list of a 'Semigroup' as a 'Monoid'. +diff :: Semigroup m => m -> Endo m +diff = Endo . (<>) + +instance Semigroup (Proxy s) where + _ <> _ = Proxy + sconcat _ = Proxy + stimes _ _ = Proxy diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index 33734a00c7..662f2747d7 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -142,11 +142,13 @@ Library Data.Int Data.Ix Data.List + Data.List.NonEmpty Data.Maybe Data.Monoid Data.Ord Data.Proxy Data.Ratio + Data.Semigroup Data.STRef Data.STRef.Lazy Data.STRef.Strict diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md index 51a1de9d58..b40bfefe91 100644 --- a/libraries/base/changelog.md +++ b/libraries/base/changelog.md @@ -58,6 +58,10 @@ * The `Generic` instance for `Proxy` is now poly-kinded (#10775) + * add `Data.List.NonEmpty` and `Data.Semigroup` (to become + super-class of `Monoid` in the future). These modules were + provided by the `semigroups` package previously. (#10365) + ## 4.8.1.0 *Jul 2015* * Bundled with GHC 7.10.2 |