{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Safe #-}
#elif __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2011-2015 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  portable
--
----------------------------------------------------------------------------
module Data.Semigroup.Foldable
  ( Foldable1(..)
  , intercalate1
  , intercalateMap1
  , traverse1_
  , for1_
  , sequenceA1_
  , foldMapDefault1
  , asum1
  , foldrM1
  , foldlM1
  ) where

import Data.Foldable
import Data.Functor.Alt (Alt(..))
import Data.Functor.Apply
import Data.List.NonEmpty (NonEmpty(..))
import Data.Traversable.Instances ()
import Data.Semigroup hiding (Product, Sum)
import Data.Semigroup.Foldable.Class
import Prelude hiding (foldr)

-- $setup
-- >>> import Data.List.NonEmpty
-- >>> import Data.Monoid (Monoid (..))

newtype JoinWith a = JoinWith {JoinWith a -> a -> a
joinee :: (a -> a)}

instance Semigroup a => Semigroup (JoinWith a) where
  JoinWith a -> a
a <> :: JoinWith a -> JoinWith a -> JoinWith a
<> JoinWith a -> a
b = (a -> a) -> JoinWith a
forall a. (a -> a) -> JoinWith a
JoinWith ((a -> a) -> JoinWith a) -> (a -> a) -> JoinWith a
forall a b. (a -> b) -> a -> b
$ \a
j -> a -> a
a a
j a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
j a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a -> a
b a
j

-- | Insert an @m@ between each pair of @t m@.  Equivalent to
-- 'intercalateMap1' with 'id' as the second argument.
--
-- >>> intercalate1 ", " $ "hello" :| ["how", "are", "you"]
-- "hello, how, are, you"
--
-- >>> intercalate1 ", " $ "hello" :| []
-- "hello"
--
-- >>> intercalate1 mempty $ "I" :| ["Am", "Fine", "You?"]
-- "IAmFineYou?"
intercalate1 :: (Foldable1 t, Semigroup m) => m -> t m -> m
intercalate1 :: m -> t m -> m
intercalate1 = (m -> (m -> m) -> t m -> m) -> (m -> m) -> m -> t m -> m
forall a b c. (a -> b -> c) -> b -> a -> c
flip m -> (m -> m) -> t m -> m
forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
m -> (a -> m) -> t a -> m
intercalateMap1 m -> m
forall a. a -> a
id
{-# INLINE intercalate1 #-}

-- | Insert @m@ between each pair of @m@ derived from @a@.
--
-- >>> intercalateMap1 " " show $ True :| [False, True]
-- "True False True"
--
-- >>> intercalateMap1 " " show $ True :| []
-- "True"
intercalateMap1 :: (Foldable1 t, Semigroup m) => m -> (a -> m) -> t a -> m
intercalateMap1 :: m -> (a -> m) -> t a -> m
intercalateMap1 m
j a -> m
f = (JoinWith m -> m -> m) -> m -> JoinWith m -> m
forall a b c. (a -> b -> c) -> b -> a -> c
flip JoinWith m -> m -> m
forall a. JoinWith a -> a -> a
joinee m
j (JoinWith m -> m) -> (t a -> JoinWith m) -> t a -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> JoinWith m) -> t a -> JoinWith m
forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
(a -> m) -> t a -> m
foldMap1 ((m -> m) -> JoinWith m
forall a. (a -> a) -> JoinWith a
JoinWith ((m -> m) -> JoinWith m) -> (a -> m -> m) -> a -> JoinWith m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m -> m -> m
forall a b. a -> b -> a
const (m -> m -> m) -> (a -> m) -> a -> m -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m
f)
{-# INLINE intercalateMap1 #-}

newtype Act f a = Act { Act f a -> f a
getAct :: f a }

instance Apply f => Semigroup (Act f a) where
  Act f a
a <> :: Act f a -> Act f a -> Act f a
<> Act f a
b = f a -> Act f a
forall (f :: * -> *) a. f a -> Act f a
Act (f a
a f a -> f a -> f a
forall (f :: * -> *) a b. Apply f => f a -> f b -> f b
.> f a
b)

instance Functor f => Functor (Act f) where
  fmap :: (a -> b) -> Act f a -> Act f b
fmap a -> b
f (Act f a
a) = f b -> Act f b
forall (f :: * -> *) a. f a -> Act f a
Act (a -> b
f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
a)
  a
b <$ :: a -> Act f b -> Act f a
<$ Act f b
a = f a -> Act f a
forall (f :: * -> *) a. f a -> Act f a
Act (a
b a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f b
a)

traverse1_ :: (Foldable1 t, Apply f) => (a -> f b) -> t a -> f ()
traverse1_ :: (a -> f b) -> t a -> f ()
traverse1_ a -> f b
f t a
t = () () -> f b -> f ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Act f b -> f b
forall (f :: * -> *) a. Act f a -> f a
getAct ((a -> Act f b) -> t a -> Act f b
forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
(a -> m) -> t a -> m
foldMap1 (f b -> Act f b
forall (f :: * -> *) a. f a -> Act f a
Act (f b -> Act f b) -> (a -> f b) -> a -> Act f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f) t a
t)
{-# INLINE traverse1_ #-}

for1_ :: (Foldable1 t, Apply f) => t a -> (a -> f b) -> f ()
for1_ :: t a -> (a -> f b) -> f ()
for1_ = ((a -> f b) -> t a -> f ()) -> t a -> (a -> f b) -> f ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> f b) -> t a -> f ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable1 t, Apply f) =>
(a -> f b) -> t a -> f ()
traverse1_
{-# INLINE for1_ #-}

sequenceA1_ :: (Foldable1 t, Apply f) => t (f a) -> f ()
sequenceA1_ :: t (f a) -> f ()
sequenceA1_ t (f a)
t = () () -> f a -> f ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Act f a -> f a
forall (f :: * -> *) a. Act f a -> f a
getAct ((f a -> Act f a) -> t (f a) -> Act f a
forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
(a -> m) -> t a -> m
foldMap1 f a -> Act f a
forall (f :: * -> *) a. f a -> Act f a
Act t (f a)
t)
{-# INLINE sequenceA1_ #-}

-- | Usable default for foldMap, but only if you define foldMap1 yourself
foldMapDefault1 :: (Foldable1 t, Monoid m) => (a -> m) -> t a -> m
foldMapDefault1 :: (a -> m) -> t a -> m
foldMapDefault1 a -> m
f = WrappedMonoid m -> m
forall m. WrappedMonoid m -> m
unwrapMonoid (WrappedMonoid m -> m) -> (t a -> WrappedMonoid m) -> t a -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> WrappedMonoid m) -> t a -> WrappedMonoid m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (m -> WrappedMonoid m
forall m. m -> WrappedMonoid m
WrapMonoid (m -> WrappedMonoid m) -> (a -> m) -> a -> WrappedMonoid m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m
f)
{-# INLINE foldMapDefault1 #-}

-- toStream :: Foldable1 t => t a -> Stream a
-- concat1 :: Foldable1 t => t (Stream a) -> Stream a
-- concatMap1 :: Foldable1 t => (a -> Stream b) -> t a -> Stream b

newtype Alt_ f a = Alt_ { Alt_ f a -> f a
getAlt_ :: f a }

instance Alt f => Semigroup (Alt_ f a) where
  Alt_ f a
a <> :: Alt_ f a -> Alt_ f a -> Alt_ f a
<> Alt_ f a
b = f a -> Alt_ f a
forall (f :: * -> *) a. f a -> Alt_ f a
Alt_ (f a
a f a -> f a -> f a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> f a
b)

asum1 :: (Foldable1 t, Alt m) => t (m a) -> m a
asum1 :: t (m a) -> m a
asum1 = Alt_ m a -> m a
forall (f :: * -> *) a. Alt_ f a -> f a
getAlt_ (Alt_ m a -> m a) -> (t (m a) -> Alt_ m a) -> t (m a) -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m a -> Alt_ m a) -> t (m a) -> Alt_ m a
forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
(a -> m) -> t a -> m
foldMap1 m a -> Alt_ m a
forall (f :: * -> *) a. f a -> Alt_ f a
Alt_
{-# INLINE asum1 #-}

-- | Monadic fold over the elements of a non-empty structure,
-- associating to the right, i.e. from right to left.
--
-- > let g = (=<<) . f
-- > in foldrM1 f (x1 :| [x2, ..., xn]) == x1 `g` (x2 `g` ... (xn-1 `f` xn)...)
--
foldrM1 :: (Foldable1 t, Monad m) => (a -> a -> m a) -> t a -> m a
foldrM1 :: (a -> a -> m a) -> t a -> m a
foldrM1 a -> a -> m a
f = NonEmpty a -> m a
go (NonEmpty a -> m a) -> (t a -> NonEmpty a) -> t a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t a -> NonEmpty a
forall (t :: * -> *) a. Foldable1 t => t a -> NonEmpty a
toNonEmpty
  where
    g :: a -> m a -> m a
g = (a -> m a) -> m a -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
(=<<) ((a -> m a) -> m a -> m a) -> (a -> a -> m a) -> a -> m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> m a
f
    
    go :: NonEmpty a -> m a
go (a
e:|[a]
es) =
      case [a]
es of
        []   -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
e
        a
x:[a]
xs -> a
e a -> m a -> m a
`g` (NonEmpty a -> m a
go (a
xa -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:|[a]
xs))

-- | Monadic fold over the elements of a non-empty structure,
-- associating to the left, i.e. from left to right.
--
-- > let g = flip $ (=<<) . f
-- > in foldlM1 f (x1 :| [x2, ..., xn]) == (...((x1 `f` x2) `g` x2) `g`...) `g` xn
--
foldlM1 :: (Foldable1 t, Monad m) => (a -> a -> m a) -> t a -> m a
foldlM1 :: (a -> a -> m a) -> t a -> m a
foldlM1 a -> a -> m a
f t a
t = (a -> a -> m a) -> a -> [a] -> m a
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM a -> a -> m a
f a
x [a]
xs
  where
    a
x:|[a]
xs = t a -> NonEmpty a
forall (t :: * -> *) a. Foldable1 t => t a -> NonEmpty a
toNonEmpty t a
t