module Containers
(
Element
, Container(..)
, NontrivialContainer(..)
, sum
, product
, mapM_
, forM_
, traverse_
, for_
, sequenceA_
, sequence_
, asum
, One(..)
) where
import Control.Applicative (Alternative (..))
import Control.Monad.Identity (Identity)
import Data.Coerce (Coercible, coerce)
import Data.Foldable (Foldable)
import qualified Data.Foldable as F
import Data.Hashable (Hashable)
import Data.Maybe (fromMaybe)
import Data.Monoid (All (..), Any (..), First (..))
import Data.Word (Word8)
import Prelude hiding (Foldable (..), all, any, mapM_, sequence_)
#if __GLASGOW_HASKELL__ >= 800
import GHC.Err (errorWithoutStackTrace)
import GHC.TypeLits (ErrorMessage (..), TypeError)
#endif
#if ( __GLASGOW_HASKELL__ >= 800 )
import qualified Data.List.NonEmpty as NE
#endif
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)
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
class Container t where
toList :: t -> [Element t]
null :: t -> Bool
instance Foldable f => Container (f a) where
toList = F.toList
null = F.null
instance Container T.Text where
toList = T.unpack
null = T.null
instance Container TL.Text where
toList = TL.unpack
null = TL.null
instance Container BS.ByteString where
toList = BS.unpack
null = BS.null
instance Container BSL.ByteString where
toList = BSL.unpack
null = BSL.null
instance Container IS.IntSet where
toList = IS.toList
null = IS.null
class Container t => NontrivialContainer t where
foldMap :: Monoid m => (Element t -> m) -> t -> m
foldMap f = foldr (mappend . f) mempty
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
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
instance Foldable f => NontrivialContainer (f a) where
foldMap = F.foldMap
fold = F.fold
foldr = F.foldr
foldr' = F.foldr'
foldl = F.foldl
foldl' = F.foldl'
foldr1 = F.foldr1
foldl1 = F.foldl1
length = F.length
elem = F.elem
maximum = F.maximum
minimum = F.minimum
all = F.all
any = F.any
and = F.and
or = F.or
find = F.find
instance NontrivialContainer T.Text where
foldr = T.foldr
foldl = T.foldl
foldl' = T.foldl'
foldr1 = T.foldr1
foldl1 = T.foldl1
length = T.length
elem c = T.isInfixOf (T.singleton c)
maximum = T.maximum
minimum = T.minimum
all = T.all
any = T.any
find = T.find
head = fmap fst . T.uncons
instance NontrivialContainer TL.Text where
foldr = TL.foldr
foldl = TL.foldl
foldl' = TL.foldl'
foldr1 = TL.foldr1
foldl1 = TL.foldl1
length = fromIntegral . TL.length
elem c s = TL.isInfixOf (TL.singleton c) s
maximum = TL.maximum
minimum = TL.minimum
all = TL.all
any = TL.any
find = TL.find
head = fmap fst . TL.uncons
instance NontrivialContainer BS.ByteString where
foldr = BS.foldr
foldl = BS.foldl
foldl' = BS.foldl'
foldr1 = BS.foldr1
foldl1 = BS.foldl1
length = BS.length
elem = BS.elem
maximum = BS.maximum
minimum = BS.minimum
all = BS.all
any = BS.any
find = BS.find
head = fmap fst . BS.uncons
instance NontrivialContainer BSL.ByteString where
foldr = BSL.foldr
foldl = BSL.foldl
foldl' = BSL.foldl'
foldr1 = BSL.foldr1
foldl1 = BSL.foldl1
length = fromIntegral . BSL.length
elem = BSL.elem
maximum = BSL.maximum
minimum = BSL.minimum
all = BSL.all
any = BSL.any
find = BSL.find
head = fmap fst . BSL.uncons
instance NontrivialContainer IS.IntSet where
foldr = IS.foldr
foldl = IS.foldl
foldl' = IS.foldl'
length = IS.size
elem = IS.member
maximum = IS.findMax
minimum = IS.findMin
head = fmap fst . IS.minView
sum :: (NontrivialContainer t, Num (Element t)) => t -> Element t
sum = foldl' (+) 0
product :: (NontrivialContainer t, Num (Element t)) => t -> Element t
product = foldl' (*) 1
traverse_
:: (NontrivialContainer t, Applicative f)
=> (Element t -> f b) -> t -> f ()
traverse_ f = foldr ((*>) . f) pass
for_
:: (NontrivialContainer t, Applicative f)
=> t -> (Element t -> f b) -> f ()
for_ = flip traverse_
mapM_
:: (NontrivialContainer t, Monad m)
=> (Element t -> m b) -> t -> m ()
mapM_ f= foldr ((>>) . f) pass
forM_
:: (NontrivialContainer t, Monad m)
=> t -> (Element t -> m b) -> m ()
forM_ = flip mapM_
sequenceA_
:: (NontrivialContainer t, Applicative f, Element t ~ f a)
=> t -> f ()
sequenceA_ = foldr (*>) pass
sequence_
:: (NontrivialContainer t, Monad m, Element t ~ m a)
=> t -> m ()
sequence_ = foldr (>>) pass
asum
:: (NontrivialContainer t, Alternative f, Element t ~ f a)
=> t -> f a
asum = foldr (<|>) empty
#define DISALLOW_CONTAINER_8(t, 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 :$$: \
Text "NB. If you tried to use 'for_' on Maybe or Either, use 'whenJust' or 'whenRight' instead" ) => \
NontrivialContainer (t) where { \
foldr = undefined; \
foldl = undefined; \
foldl' = undefined; \
length = undefined; \
elem = undefined; \
maximum = undefined; \
minimum = undefined; } \
#define DISALLOW_CONTAINER_7(t) \
instance ForbiddenFoldable (t) => Container (t) where { \
toList = undefined; \
null = undefined; } \
#define DISALLOW_NONTRIVIAL_CONTAINER_7(t) \
instance ForbiddenFoldable (t) => NontrivialContainer (t) where { \
foldr = undefined; \
foldl = undefined; \
foldl' = undefined; \
length = undefined; \
elem = undefined; \
maximum = undefined; \
minimum = undefined; } \
#if __GLASGOW_HASKELL__ >= 800
DISALLOW_CONTAINER_8((a, b),"tuples")
DISALLOW_NONTRIVIAL_CONTAINER_8((a, b),"tuples")
DISALLOW_NONTRIVIAL_CONTAINER_8(Maybe a,"Maybe")
DISALLOW_NONTRIVIAL_CONTAINER_8(Identity a,"Identity")
DISALLOW_NONTRIVIAL_CONTAINER_8(Either a b,"Either")
#else
class ForbiddenFoldable a
DISALLOW_CONTAINER_7((a, b))
DISALLOW_NONTRIVIAL_CONTAINER_7((a, b))
DISALLOW_NONTRIVIAL_CONTAINER_7(Maybe a)
DISALLOW_NONTRIVIAL_CONTAINER_7(Identity a)
DISALLOW_NONTRIVIAL_CONTAINER_7(Either a b)
#endif
class One x where
type OneItem x
one :: OneItem x -> x
instance One [a] where
type OneItem [a] = a
one = (:[])
#if ( __GLASGOW_HASKELL__ >= 800 )
instance One (NE.NonEmpty a) where
type OneItem (NE.NonEmpty a) = a
one = (NE.:|[])
#endif
instance One (SEQ.Seq a) where
type OneItem (SEQ.Seq a) = a
one = (SEQ.empty SEQ.|>)
instance One T.Text where
type OneItem T.Text = Char
one = T.singleton
instance One TL.Text where
type OneItem TL.Text = Char
one = TL.singleton
instance One BS.ByteString where
type OneItem BS.ByteString = Word8
one = BS.singleton
instance One BSL.ByteString where
type OneItem BSL.ByteString = Word8
one = BSL.singleton
instance One (M.Map k v) where
type OneItem (M.Map k v) = (k, v)
one = uncurry M.singleton
instance Hashable k => One (HM.HashMap k v) where
type OneItem (HM.HashMap k v) = (k, v)
one = uncurry HM.singleton
instance One (IM.IntMap v) where
type OneItem (IM.IntMap v) = (Int, v)
one = uncurry IM.singleton
instance One (S.Set v) where
type OneItem (S.Set v) = v
one = S.singleton
instance Hashable v => One (HS.HashSet v) where
type OneItem (HS.HashSet v) = v
one = HS.singleton
instance One IS.IntSet where
type OneItem IS.IntSet = Int
one = IS.singleton
instance One (V.Vector a) where
type OneItem (V.Vector a) = a
one = V.singleton
instance VU.Unbox a => One (VU.Vector a) where
type OneItem (VU.Vector a) = a
one = VU.singleton
instance VP.Prim a => One (VP.Vector a) where
type OneItem (VP.Vector a) = a
one = VP.singleton
instance VS.Storable a => One (VS.Vector a) where
type OneItem (VS.Vector a) = a
one = VS.singleton
(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c)
(#.) _f = coerce