module Container.Class
(
Element
, ToList(..)
, Container(..)
, NontrivialContainer
, WrappedList (..)
, 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 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)
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 ToList t where
toList :: t -> [Element t]
null :: t -> Bool
null = List.null . toList
instance Foldable f => ToList (f a) where
toList = F.toList
null = F.null
instance ToList T.Text where
toList = T.unpack
null = T.null
instance ToList TL.Text where
toList = TL.unpack
null = TL.null
instance ToList BS.ByteString where
toList = BS.unpack
null = BS.null
instance ToList BSL.ByteString where
toList = BSL.unpack
null = BSL.null
instance ToList IS.IntSet where
toList = IS.toList
null = IS.null
class ToList t => Container 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
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
type NontrivialContainer t = Container t
instance Foldable f => Container (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
notElem = F.notElem
maximum = F.maximum
minimum = F.minimum
all = F.all
any = F.any
and = F.and
or = F.or
find = F.find
instance Container 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 Container 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 Container BS.ByteString where
foldr = BS.foldr
foldl = BS.foldl
foldl' = BS.foldl'
foldr1 = BS.foldr1
foldl1 = BS.foldl1
length = BS.length
elem = BS.elem
notElem = BS.notElem
maximum = BS.maximum
minimum = BS.minimum
all = BS.all
any = BS.any
find = BS.find
head = fmap fst . BS.uncons
instance Container 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
notElem = BSL.notElem
maximum = BSL.maximum
minimum = BSL.minimum
all = BSL.all
any = BSL.any
find = BSL.find
head = fmap fst . BSL.uncons
instance Container 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
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
null (WrappedList l) = null l
instance ToList (f a) => Container (WrappedList f a) where
foldMap f = foldMap f . toList
fold = fold . toList
foldr f z = foldr f z . toList
foldr' f z = foldr' f z . toList
foldl f z = foldl f z . toList
foldl' f z = foldl' f z . toList
foldr1 f = foldr1 f . toList
foldl1 f = foldl1 f . toList
length = length . toList
elem x = elem x . toList
notElem x = notElem x . toList
maximum = maximum . toList
minimum = minimum . toList
all p = all p . toList
any p = any p . toList
and = and . toList
or = or . toList
find p = find p . toList
head = head . toList
sum :: (Container t, Num (Element t)) => t -> Element t
sum = foldl' (+) 0
product :: (Container t, Num (Element t)) => t -> Element t
product = foldl' (*) 1
traverse_
:: (Container t, Applicative f)
=> (Element t -> f b) -> t -> f ()
traverse_ f = foldr ((*>) . f) pass
for_
:: (Container t, Applicative f)
=> t -> (Element t -> f b) -> f ()
for_ = flip traverse_
mapM_
:: (Container t, Monad m)
=> (Element t -> m b) -> t -> m ()
mapM_ f= foldr ((>>) . f) pass
forM_
:: (Container t, Monad m)
=> t -> (Element t -> m b) -> m ()
forM_ = flip mapM_
sequenceA_
:: (Container t, Applicative f, Element t ~ f a)
=> t -> f ()
sequenceA_ = foldr (*>) pass
sequence_
:: (Container t, Monad m, Element t ~ m a)
=> t -> m ()
sequence_ = foldr (>>) pass
asum
:: (Container t, Alternative f, Element t ~ f a)
=> t -> f a
asum = foldr (<|>) empty
#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
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