-- 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 'Traversable' over arity-1 type constructors.

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

module Data.Ten.Traversable
         ( Traversable10(..), traverse10, sequenceA10, fsequenceA10
         ) where

import Data.Coerce (coerce)
import Data.Functor.Identity (Identity(..))
import Data.Kind (Type)
import GHC.Generics
         ( Generic1(..)
         , (:.:)(..), (:*:)(..), (:+:)(..)
         , M1(..), Rec1(..), U1(..), V1, K1(..)
         )

import Data.Wrapped (Wrapped1(..))

import Data.Ten.Ap (Ap10(..))
import Data.Ten.Foldable (Foldable10)
import Data.Ten.Functor (Functor10)

(.:) :: (q -> r) -> (a -> b -> q) -> a -> b -> r
.: :: (q -> r) -> (a -> b -> q) -> a -> b -> r
(.:) = ((b -> q) -> b -> r) -> (a -> b -> q) -> a -> b -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (((b -> q) -> b -> r) -> (a -> b -> q) -> a -> b -> r)
-> ((q -> r) -> (b -> q) -> b -> r)
-> (q -> r)
-> (a -> b -> q)
-> a
-> b
-> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (q -> r) -> (b -> q) -> b -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)

-- | Analog of 'Traversable' over arity-1 type constructors.
--
-- This is defined in terms of 'mapTraverse10' for two reasons:
--
-- * First, it makes it possible to use with GeneralizedNewtypeDeriving and
--   DerivingVia.  See
--   https://ryanglscott.github.io/2018/06/22/quantifiedconstraints-and-the-trouble-with-traversable/
--   for more details.
-- * Second, it uses fewer 'fmap's in some cases: when you need to re-apply a
--   constructor tag like 'L1' or 'R1' after calling 'traverse10' on the
--   payload, this would normally be an additional 'fmap', but with
--   'mapTraverse10' it can be fused into the underlying recursive call.  Less
--   crucially, the same trick applies when traversing multiple fields and
--   combining them back into a product type: the first call can use
--   'mapTraverse10' to pre-apply the function, and use '<*>' rather than
--   'Control.Applicative.liftA2' (which is often defined as an 'fmap' followed
--   by a '<*>').
class (Functor10 t, Foldable10 t)
   => Traversable10 (t :: (k -> Type) -> Type) where
  -- | 'traverse10' with a built-in 'fmap' on the final result.
  mapTraverse10
    :: forall f m n r
     . Applicative f
    => (t n -> r)
    -> (forall a. m a -> f (n a))
    -> t m -> f r

-- | Analog of 'traverse' for functors over arity-1 type constructors.
--
-- Given a parametric function that takes the wrapped type @m a@ to @n a@ in an
-- 'Applicative' @f@, visit all contained @m _@s to convert from @t m@ to @t n@.
--
-- @m@ and @n@ here play the role of @a@ and @b@ in the normal 'traverse' type;
-- that is, instead of traversing to change a @Type@, we're traversing to change
-- a type constructor of kind @k -> Type@:
--
-- @
--     traverse
--       :: (Traversable t, Applicative f)
--       => (          a   -> f  b   ) -> t a -> f (t b)
--     traverse10
--       :: (Traversable10 t, Applicative f)
--       => (forall x. m x -> f (n x)) -> t m -> f (t n)
-- @
traverse10
  :: forall t f m n
   . (Traversable10 t, Applicative f)
  => (forall a. m a -> f (n a))
  -> t m -> f (t n)
traverse10 :: (forall (a :: k). m a -> f (n a)) -> t m -> f (t n)
traverse10 = (t n -> t n) -> (forall (a :: k). m a -> f (n a)) -> t m -> f (t n)
forall k (t :: (k -> *) -> *) (f :: * -> *) (m :: k -> *)
       (n :: k -> *) r.
(Traversable10 t, Applicative f) =>
(t n -> r) -> (forall (a :: k). m a -> f (n a)) -> t m -> f r
mapTraverse10 t n -> t n
forall a. a -> a
id

instance (Generic1 f, Traversable10 (Rep1 f))
      => Traversable10 (Wrapped1 Generic1 f) where
  mapTraverse10 :: (Wrapped1 Generic1 f n -> r)
-> (forall (a :: k). m a -> f (n a))
-> Wrapped1 Generic1 f m
-> f r
mapTraverse10 Wrapped1 Generic1 f n -> r
r forall (a :: k). m a -> f (n a)
f = (Rep1 f n -> r)
-> (forall (a :: k). m a -> f (n a)) -> Rep1 f m -> f r
forall k (t :: (k -> *) -> *) (f :: * -> *) (m :: k -> *)
       (n :: k -> *) r.
(Traversable10 t, Applicative f) =>
(t n -> r) -> (forall (a :: k). m a -> f (n a)) -> t m -> f r
mapTraverse10 (Wrapped1 Generic1 f n -> r
r (Wrapped1 Generic1 f n -> r)
-> (Rep1 f n -> Wrapped1 Generic1 f n) -> Rep1 f n -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f n -> Wrapped1 Generic1 f n
forall k (c :: (k -> *) -> Constraint) (f :: k -> *) (a :: k).
f a -> Wrapped1 c f a
Wrapped1 (f n -> Wrapped1 Generic1 f n)
-> (Rep1 f n -> f n) -> Rep1 f n -> Wrapped1 Generic1 f n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep1 f n -> f n
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1) forall (a :: k). m a -> f (n a)
f (Rep1 f m -> f r)
-> (Wrapped1 Generic1 f m -> Rep1 f m)
-> Wrapped1 Generic1 f m
-> f r
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 Traversable10 (Ap10 a) where
  mapTraverse10 :: (Ap10 a n -> r)
-> (forall (a :: k). m a -> f (n a)) -> Ap10 a m -> f r
mapTraverse10 Ap10 a n -> r
r forall (a :: k). m a -> f (n a)
f (Ap10 m a
x) = Ap10 a n -> r
r (Ap10 a n -> r) -> (n a -> Ap10 a n) -> n a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n a -> Ap10 a n
forall k (a :: k) (f :: k -> *). f a -> Ap10 a f
Ap10 (n a -> r) -> f (n a) -> f r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a -> f (n a)
forall (a :: k). m a -> f (n a)
f m a
x

instance Traversable10 (K1 i a) where
  mapTraverse10 :: (K1 i a n -> r)
-> (forall (a :: k). m a -> f (n a)) -> K1 i a m -> f r
mapTraverse10 K1 i a n -> r
r forall (a :: k). m a -> f (n a)
_ K1 i a m
k = r -> f r
forall (f :: * -> *) a. Applicative f => a -> f a
pure (K1 i a n -> r
r (K1 i a n -> r) -> K1 i a n -> r
forall a b. (a -> b) -> a -> b
$ K1 i a m -> K1 i a n
coerce K1 i a m
k)

instance Traversable10 V1 where
  mapTraverse10 :: (V1 n -> r) -> (forall (a :: k). m a -> f (n a)) -> V1 m -> f r
mapTraverse10 V1 n -> r
_ forall (a :: k). m a -> f (n a)
_ V1 m
x = case V1 m
x of {}

instance Traversable10 U1 where
  mapTraverse10 :: (U1 n -> r) -> (forall (a :: k). m a -> f (n a)) -> U1 m -> f r
mapTraverse10 U1 n -> r
r forall (a :: k). m a -> f (n a)
_ U1 m
U1 = r -> f r
forall (f :: * -> *) a. Applicative f => a -> f a
pure (U1 n -> r
r U1 n
forall k (p :: k). U1 p
U1)

instance Traversable10 f => Traversable10 (Rec1 f) where
  mapTraverse10 :: (Rec1 f n -> r)
-> (forall (a :: k). m a -> f (n a)) -> Rec1 f m -> f r
mapTraverse10 Rec1 f n -> r
r forall (a :: k). m a -> f (n a)
f (Rec1 f m
x) = (f n -> r) -> (forall (a :: k). m a -> f (n a)) -> f m -> f r
forall k (t :: (k -> *) -> *) (f :: * -> *) (m :: k -> *)
       (n :: k -> *) r.
(Traversable10 t, Applicative f) =>
(t n -> r) -> (forall (a :: k). m a -> f (n a)) -> t m -> f r
mapTraverse10 (Rec1 f n -> r
r (Rec1 f n -> r) -> (f n -> Rec1 f n) -> f n -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f n -> Rec1 f n
forall k (f :: k -> *) (p :: k). f p -> Rec1 f p
Rec1) forall (a :: k). m a -> f (n a)
f f m
x

instance Traversable10 f => Traversable10 (M1 i c f) where
  mapTraverse10 :: (M1 i c f n -> r)
-> (forall (a :: k). m a -> f (n a)) -> M1 i c f m -> f r
mapTraverse10 M1 i c f n -> r
r forall (a :: k). m a -> f (n a)
f (M1 f m
x) = (f n -> r) -> (forall (a :: k). m a -> f (n a)) -> f m -> f r
forall k (t :: (k -> *) -> *) (f :: * -> *) (m :: k -> *)
       (n :: k -> *) r.
(Traversable10 t, Applicative f) =>
(t n -> r) -> (forall (a :: k). m a -> f (n a)) -> t m -> f r
mapTraverse10 (M1 i c f n -> r
r (M1 i c f n -> r) -> (f n -> M1 i c f n) -> f n -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f n -> M1 i c f n
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1) forall (a :: k). m a -> f (n a)
f f m
x

instance (Traversable10 f, Traversable10 g) => Traversable10 (f :+: g) where
  mapTraverse10 :: ((:+:) f g n -> r)
-> (forall (a :: k). m a -> f (n a)) -> (:+:) f g m -> f r
mapTraverse10 (:+:) f g n -> r
r forall (a :: k). m a -> f (n a)
f (L1 f m
x) = (f n -> r) -> (forall (a :: k). m a -> f (n a)) -> f m -> f r
forall k (t :: (k -> *) -> *) (f :: * -> *) (m :: k -> *)
       (n :: k -> *) r.
(Traversable10 t, Applicative f) =>
(t n -> r) -> (forall (a :: k). m a -> f (n a)) -> t m -> f r
mapTraverse10 ((:+:) f g n -> r
r ((:+:) f g n -> r) -> (f n -> (:+:) f g n) -> f n -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f n -> (:+:) f g n
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1) forall (a :: k). m a -> f (n a)
f f m
x
  mapTraverse10 (:+:) f g n -> r
r forall (a :: k). m a -> f (n a)
f (R1 g m
x) = (g n -> r) -> (forall (a :: k). m a -> f (n a)) -> g m -> f r
forall k (t :: (k -> *) -> *) (f :: * -> *) (m :: k -> *)
       (n :: k -> *) r.
(Traversable10 t, Applicative f) =>
(t n -> r) -> (forall (a :: k). m a -> f (n a)) -> t m -> f r
mapTraverse10 ((:+:) f g n -> r
r ((:+:) f g n -> r) -> (g n -> (:+:) f g n) -> g n -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g n -> (:+:) f g n
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1) forall (a :: k). m a -> f (n a)
f g m
x

instance (Traversable10 f, Traversable10 g) => Traversable10 (f :*: g) where
  mapTraverse10 :: ((:*:) f g n -> r)
-> (forall (a :: k). m a -> f (n a)) -> (:*:) f g m -> f r
mapTraverse10 (:*:) f g n -> r
r forall (a :: k). m a -> f (n a)
f (f m
x :*: g m
y) =
    (f n -> g n -> r)
-> (forall (a :: k). m a -> f (n a)) -> f m -> f (g n -> r)
forall k (t :: (k -> *) -> *) (f :: * -> *) (m :: k -> *)
       (n :: k -> *) r.
(Traversable10 t, Applicative f) =>
(t n -> r) -> (forall (a :: k). m a -> f (n a)) -> t m -> f r
mapTraverse10 ((:*:) f g n -> r
r ((:*:) f g n -> r)
-> (f n -> g n -> (:*:) f g n) -> f n -> g n -> r
forall q r a b. (q -> r) -> (a -> b -> q) -> a -> b -> r
.: f n -> g n -> (:*:) f g n
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:)) forall (a :: k). m a -> f (n a)
f f m
x f (g n -> r) -> f (g n) -> f r
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (a :: k). m a -> f (n a)) -> g m -> f (g n)
forall k (t :: (k -> *) -> *) (f :: * -> *) (m :: k -> *)
       (n :: k -> *).
(Traversable10 t, Applicative f) =>
(forall (a :: k). m a -> f (n a)) -> t m -> f (t n)
traverse10 forall (a :: k). m a -> f (n a)
f g m
y

instance (Traversable f, Traversable10 g) => Traversable10 (f :.: g) where
  mapTraverse10 :: ((:.:) f g n -> r)
-> (forall (a :: k). m a -> f (n a)) -> (:.:) f g m -> f r
mapTraverse10 (:.:) f g n -> r
r forall (a :: k). m a -> f (n a)
f (Comp1 f (g m)
x) = (:.:) f g n -> r
r ((:.:) f g n -> r) -> (f (g n) -> (:.:) f g n) -> f (g n) -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (g n) -> (:.:) f g n
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 (f (g n) -> r) -> f (f (g n)) -> f r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (g m -> f (g n)) -> f (g m) -> f (f (g n))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((forall (a :: k). m a -> f (n a)) -> g m -> f (g n)
forall k (t :: (k -> *) -> *) (f :: * -> *) (m :: k -> *)
       (n :: k -> *).
(Traversable10 t, Applicative f) =>
(forall (a :: k). m a -> f (n a)) -> t m -> f (t n)
traverse10 forall (a :: k). m a -> f (n a)
f) f (g m)
x

-- | 'sequenceA' for 'Traversable10'.
--
-- This variant expects just the plain @m@ actions at each field, and wraps the
-- results in @Identity.
sequenceA10
  :: (Applicative m, Traversable10 f)
  => f m -> m (f Identity)
sequenceA10 :: f m -> m (f Identity)
sequenceA10 = (forall a. m a -> m (Identity a)) -> f m -> m (f Identity)
forall k (t :: (k -> *) -> *) (f :: * -> *) (m :: k -> *)
       (n :: k -> *).
(Traversable10 t, Applicative f) =>
(forall (a :: k). m a -> f (n a)) -> t m -> f (t n)
traverse10 ((a -> Identity a) -> m a -> m (Identity a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Identity a
forall a. a -> Identity a
Identity)

-- | 'sequenceA' for 'Traversable10'.
--
-- This variant expects the composition of the 'Applicative' being sequenced
-- with some inner type constructor at each field.
fsequenceA10
  :: (Applicative m, Traversable10 f)
  => f (m :.: n) -> m (f n)
fsequenceA10 :: f (m :.: n) -> m (f n)
fsequenceA10 = (forall (a :: k). (:.:) m n a -> m (n a)) -> f (m :.: n) -> m (f n)
forall k (t :: (k -> *) -> *) (f :: * -> *) (m :: k -> *)
       (n :: k -> *).
(Traversable10 t, Applicative f) =>
(forall (a :: k). m a -> f (n a)) -> t m -> f (t n)
traverse10 forall (a :: k). (:.:) m n a -> m (n a)
coerce