-- Copyright 2018-2021 Google LLC
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.

-- | Provides an analog of 'Foldable' over arity-1 type constructors.

{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Data.Ten.Foldable
         ( Foldable10(..)
         , fold10, foldr10, foldl10, traverse10_, sequenceA10_, fsequenceA10_
         ) where

import Data.Functor (void)
import Data.Functor.Const (Const(..))
import Data.Kind (Type)
import Data.Monoid (Dual(..), Endo(..))
import GHC.Generics
         ( Generic1(..)
         , (:.:)(..), (:*:)(..), (:+:)(..)
         , M1(..), Rec1(..), U1(..), V1, K1(..)
         )

import Data.Wrapped (Wrapped1(..))

import Data.Ten.Ap (Ap10(..))

-- | 'Foldable' over arity-1 type constructors.
--
-- Whereas 'Foldable' folds @a :: Type@ values to a monoid, 'Foldable10' folds
-- @(m :: k -> Type) a@ values to a monoid, parametrically in @a@.  That is,
-- the type parameter of 'Foldable' has arity 0, and the type parameter of
-- 'Foldable10' has arity 1.
class Foldable10 (t :: (k -> Type) -> Type) where
  -- | Map each @m a@ element parametrically to @w@ and 'mconcat' the results.
  foldMap10 :: Monoid w => (forall a. m a -> w) -> t m -> w

instance (Generic1 f, Foldable10 (Rep1 f))
      => Foldable10 (Wrapped1 Generic1 f) where
  foldMap10 :: (forall (a :: k). m a -> w) -> Wrapped1 Generic1 f m -> w
foldMap10 forall (a :: k). m a -> w
f = (forall (a :: k). m a -> w) -> Rep1 f m -> w
forall k (t :: (k -> *) -> *) w (m :: k -> *).
(Foldable10 t, Monoid w) =>
(forall (a :: k). m a -> w) -> t m -> w
foldMap10 forall (a :: k). m a -> w
f (Rep1 f m -> w)
-> (Wrapped1 Generic1 f m -> Rep1 f m)
-> Wrapped1 Generic1 f m
-> w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f m -> Rep1 f m
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 (f m -> Rep1 f m)
-> (Wrapped1 Generic1 f m -> f m)
-> Wrapped1 Generic1 f m
-> Rep1 f m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Wrapped1 Generic1 f m -> f m
forall k (c :: (k -> *) -> Constraint) (f :: k -> *) (a :: k).
Wrapped1 c f a -> f a
unWrapped1

instance Foldable10 (Ap10 a) where
  foldMap10 :: (forall (a :: k). m a -> w) -> Ap10 a m -> w
foldMap10 forall (a :: k). m a -> w
f (Ap10 m a
x) = m a -> w
forall (a :: k). m a -> w
f m a
x

instance Foldable10 (K1 i a) where
  foldMap10 :: (forall (a :: k). m a -> w) -> K1 i a m -> w
foldMap10 forall (a :: k). m a -> w
_ (K1 a
_) = w
forall a. Monoid a => a
mempty

instance Foldable10 V1 where
  foldMap10 :: (forall (a :: k). m a -> w) -> V1 m -> w
foldMap10 forall (a :: k). m a -> w
_ V1 m
x = case V1 m
x of {}

instance Foldable10 U1 where
  foldMap10 :: (forall (a :: k). m a -> w) -> U1 m -> w
foldMap10 forall (a :: k). m a -> w
_ U1 m
U1 = w
forall a. Monoid a => a
mempty

deriving instance Foldable10 f => Foldable10 (Rec1 f)
deriving instance Foldable10 f => Foldable10 (M1 i c f)

instance (Foldable10 f, Foldable10 g) => Foldable10 (f :+: g) where
  foldMap10 :: (forall (a :: k). m a -> w) -> (:+:) f g m -> w
foldMap10 forall (a :: k). m a -> w
f (L1 f m
x) = (forall (a :: k). m a -> w) -> f m -> w
forall k (t :: (k -> *) -> *) w (m :: k -> *).
(Foldable10 t, Monoid w) =>
(forall (a :: k). m a -> w) -> t m -> w
foldMap10 forall (a :: k). m a -> w
f f m
x
  foldMap10 forall (a :: k). m a -> w
f (R1 g m
x) = (forall (a :: k). m a -> w) -> g m -> w
forall k (t :: (k -> *) -> *) w (m :: k -> *).
(Foldable10 t, Monoid w) =>
(forall (a :: k). m a -> w) -> t m -> w
foldMap10 forall (a :: k). m a -> w
f g m
x

instance (Foldable10 f, Foldable10 g) => Foldable10 (f :*: g) where
  foldMap10 :: (forall (a :: k). m a -> w) -> (:*:) f g m -> w
foldMap10 forall (a :: k). m a -> w
f (f m
l :*: g m
r) = (forall (a :: k). m a -> w) -> f m -> w
forall k (t :: (k -> *) -> *) w (m :: k -> *).
(Foldable10 t, Monoid w) =>
(forall (a :: k). m a -> w) -> t m -> w
foldMap10 forall (a :: k). m a -> w
f f m
l w -> w -> w
forall a. Semigroup a => a -> a -> a
<> (forall (a :: k). m a -> w) -> g m -> w
forall k (t :: (k -> *) -> *) w (m :: k -> *).
(Foldable10 t, Monoid w) =>
(forall (a :: k). m a -> w) -> t m -> w
foldMap10 forall (a :: k). m a -> w
f g m
r

instance (Foldable f, Foldable10 g) => Foldable10 (f :.: g) where
  foldMap10 :: (forall (a :: k). m a -> w) -> (:.:) f g m -> w
foldMap10 forall (a :: k). m a -> w
f (Comp1 f (g m)
x) = (g m -> w) -> f (g m) -> w
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((forall (a :: k). m a -> w) -> g m -> w
forall k (t :: (k -> *) -> *) w (m :: k -> *).
(Foldable10 t, Monoid w) =>
(forall (a :: k). m a -> w) -> t m -> w
foldMap10 forall (a :: k). m a -> w
f) f (g m)
x

-- | Given a structure over @'Const' m@, return the ('<>') of all elements.
fold10 :: (Foldable10 t, Monoid m) => t (Const m) -> m
fold10 :: t (Const m) -> m
fold10 = (forall (a :: k). Const m a -> m) -> t (Const m) -> m
forall k (t :: (k -> *) -> *) w (m :: k -> *).
(Foldable10 t, Monoid w) =>
(forall (a :: k). m a -> w) -> t m -> w
foldMap10 forall (a :: k). Const m a -> m
forall a k (b :: k). Const a b -> a
getConst

-- | Right-associative fold over a 'Foldable10'.
foldr10 :: Foldable10 t => (forall a. m a -> b -> b) -> b -> t m -> b
foldr10 :: (forall (a :: k). m a -> b -> b) -> b -> t m -> b
foldr10 forall (a :: k). m a -> b -> b
f b
z = (Endo b -> b -> b) -> b -> Endo b -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip Endo b -> b -> b
forall a. Endo a -> a -> a
appEndo b
z (Endo b -> b) -> (t m -> Endo b) -> t m -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (a :: k). m a -> Endo b) -> t m -> Endo b
forall k (t :: (k -> *) -> *) w (m :: k -> *).
(Foldable10 t, Monoid w) =>
(forall (a :: k). m a -> w) -> t m -> w
foldMap10 ((b -> b) -> Endo b
forall a. (a -> a) -> Endo a
Endo ((b -> b) -> Endo b) -> (m a -> b -> b) -> m a -> Endo b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> b -> b
forall (a :: k). m a -> b -> b
f)

-- | Left-associative fold over a 'Foldable10'.
foldl10 :: Foldable10 t => (forall a. b -> m a -> b) -> b -> t m -> b
foldl10 :: (forall (a :: k). b -> m a -> b) -> b -> t m -> b
foldl10 forall (a :: k). b -> m a -> b
f b
z = (Endo b -> b -> b) -> b -> Endo b -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip Endo b -> b -> b
forall a. Endo a -> a -> a
appEndo b
z (Endo b -> b) -> (t m -> Endo b) -> t m -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dual (Endo b) -> Endo b
forall a. Dual a -> a
getDual (Dual (Endo b) -> Endo b)
-> (t m -> Dual (Endo b)) -> t m -> Endo b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (a :: k). m a -> Dual (Endo b)) -> t m -> Dual (Endo b)
forall k (t :: (k -> *) -> *) w (m :: k -> *).
(Foldable10 t, Monoid w) =>
(forall (a :: k). m a -> w) -> t m -> w
foldMap10 (Endo b -> Dual (Endo b)
forall a. a -> Dual a
Dual (Endo b -> Dual (Endo b))
-> (m a -> Endo b) -> m a -> Dual (Endo b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> b) -> Endo b
forall a. (a -> a) -> Endo a
Endo ((b -> b) -> Endo b) -> (m a -> b -> b) -> m a -> Endo b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> m a -> b) -> m a -> b -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> m a -> b
forall (a :: k). b -> m a -> b
f)

-- | Sequence actions given by a function left-to-right in a 'Foldable10'.
--
-- This form discards the final result; see 'Data.Ten.Traversable.traverse10'
-- for a version that keeps it.
traverse10_
  :: (Applicative f, Foldable10 t) => (forall a. m a -> f ()) -> t m -> f ()
traverse10_ :: (forall (a :: k). m a -> f ()) -> t m -> f ()
traverse10_ forall (a :: k). m a -> f ()
f = (forall (a :: k). f () -> m a -> f ()) -> f () -> t m -> f ()
forall k (t :: (k -> *) -> *) b (m :: k -> *).
Foldable10 t =>
(forall (a :: k). b -> m a -> b) -> b -> t m -> b
foldl10 (\f ()
a m a
x -> f ()
a f () -> f () -> f ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* m a -> f ()
forall (a :: k). m a -> f ()
f m a
x) (() -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | Sequence actions in a 'Foldable10' left-to-right, discarding the result.
--
-- This variant expects the composition of the 'Applicative' being sequenced
-- with some inner type constructor at each field.
--
-- See 'Data.Ten.Traversable.fsequenceA10_' for a version that keeps the result.
fsequenceA10_ :: (Applicative m, Foldable10 f) => f (m :.: n) -> m ()
fsequenceA10_ :: f (m :.: n) -> m ()
fsequenceA10_ = (forall (a :: k). (:.:) m n a -> m ()) -> f (m :.: n) -> m ()
forall k (f :: * -> *) (t :: (k -> *) -> *) (m :: k -> *).
(Applicative f, Foldable10 t) =>
(forall (a :: k). m a -> f ()) -> t m -> f ()
traverse10_ (m (n a) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (n a) -> m ())
-> ((:.:) m n a -> m (n a)) -> (:.:) m n a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:.:) m n a -> m (n a)
forall k2 (f :: k2 -> *) k1 (g :: k1 -> k2) (p :: k1).
(:.:) f g p -> f (g p)
unComp1)

-- | Sequence actions in a 'Foldable10' left-to-right, discarding the result.
--
-- This variant expects just the plain @m@ actions with no inner type
-- constructor.
sequenceA10_ :: (Applicative m, Foldable10 f) => f m -> m ()
sequenceA10_ :: f m -> m ()
sequenceA10_ = (forall a. m a -> m ()) -> f m -> m ()
forall k (f :: * -> *) (t :: (k -> *) -> *) (m :: k -> *).
(Applicative f, Foldable10 t) =>
(forall (a :: k). m a -> f ()) -> t m -> f ()
traverse10_ forall a. m a -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void