-- | A variant of 'Traversable' for 'Hyper.Type.HyperType's

{-# LANGUAGE FlexibleContexts #-}

module Hyper.Class.Traversable
    ( HTraversable(..)
    , ContainedH(..), _ContainedH
    , htraverse, htraverse1
    ) where

import Control.Lens (iso)
import GHC.Generics
import GHC.Generics.Lens (_M1, _Rec1)
import Hyper.Class.Foldable (HFoldable)
import Hyper.Class.Functor (HFunctor(..), hmapped1)
import Hyper.Class.Nodes (HNodes(..), HWitness)
import Hyper.Type (AHyperType, type (#))

import Hyper.Internal.Prelude

-- | A 'Hyper.Type.HyperType' containing a tree inside an action.
--
-- Used to express 'hsequence'.
newtype ContainedH f p (h :: AHyperType) = MkContainedH { ContainedH f p h -> f (p h)
runContainedH :: f (p h) }

-- | An 'Iso' for the 'ContainedH' @newtype@
{-# INLINE _ContainedH #-}
_ContainedH ::
    Iso (ContainedH f0 p0 # k0)
        (ContainedH f1 p1 # k1)
        (f0 (p0 # k0))
        (f1 (p1 # k1))
_ContainedH :: p (f0 (p0 # k0)) (f (f1 (p1 # k1)))
-> p (ContainedH f0 p0 # k0) (f (ContainedH f1 p1 # k1))
_ContainedH = ((ContainedH f0 p0 # k0) -> f0 (p0 # k0))
-> (f1 (p1 # k1) -> ContainedH f1 p1 # k1)
-> Iso
     (ContainedH f0 p0 # k0)
     (ContainedH f1 p1 # k1)
     (f0 (p0 # k0))
     (f1 (p1 # k1))
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (ContainedH f0 p0 # k0) -> f0 (p0 # k0)
forall (f :: * -> *) (p :: AHyperType -> *) (h :: AHyperType).
ContainedH f p h -> f (p h)
runContainedH f1 (p1 # k1) -> ContainedH f1 p1 # k1
forall (f :: * -> *) (p :: AHyperType -> *) (h :: AHyperType).
f (p h) -> ContainedH f p h
MkContainedH

-- | A variant of 'Traversable' for 'Hyper.Type.HyperType's
class (HFunctor h, HFoldable h) => HTraversable h where
    -- | 'HTraversable' variant of 'sequenceA'
    hsequence ::
        Applicative f =>
        h # ContainedH f p ->
        f (h # p)
    {-# INLINE hsequence #-}
    default hsequence ::
        (Generic1 h, HTraversable (Rep1 h), Applicative f) =>
        h # ContainedH f p ->
        f (h # p)
    hsequence = ((Rep1 h # p) -> h # p) -> f (Rep1 h # p) -> f (h # p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Rep1 h # p) -> h # p
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 (f (Rep1 h # p) -> f (h # p))
-> ((h # ContainedH f p) -> f (Rep1 h # p))
-> (h # ContainedH f p)
-> f (h # p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rep1 h # ContainedH f p) -> f (Rep1 h # p)
forall (h :: AHyperType -> *) (f :: * -> *) (p :: AHyperType -> *).
(HTraversable h, Applicative f) =>
(h # ContainedH f p) -> f (h # p)
hsequence ((Rep1 h # ContainedH f p) -> f (Rep1 h # p))
-> ((h # ContainedH f p) -> Rep1 h # ContainedH f p)
-> (h # ContainedH f p)
-> f (Rep1 h # p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (h # ContainedH f p) -> Rep1 h # ContainedH f p
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1

instance HTraversable (Const a) where
    {-# INLINE hsequence #-}
    hsequence :: (Const a # ContainedH f p) -> f (Const a # p)
hsequence (Const a
x) = (Const a # p) -> f (Const a # p)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Const a # p
forall k a (b :: k). a -> Const a b
Const a
x)

instance (HTraversable a, HTraversable b) => HTraversable (a :*: b) where
    {-# INLINE hsequence #-}
    hsequence :: ((a :*: b) # ContainedH f p) -> f ((a :*: b) # p)
hsequence (a ('AHyperType (ContainedH f p))
x :*: b ('AHyperType (ContainedH f p))
y) = a ('AHyperType p) -> b ('AHyperType p) -> (a :*: b) # p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (a ('AHyperType p) -> b ('AHyperType p) -> (a :*: b) # p)
-> f (a ('AHyperType p)) -> f (b ('AHyperType p) -> (a :*: b) # p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a ('AHyperType (ContainedH f p)) -> f (a ('AHyperType p))
forall (h :: AHyperType -> *) (f :: * -> *) (p :: AHyperType -> *).
(HTraversable h, Applicative f) =>
(h # ContainedH f p) -> f (h # p)
hsequence a ('AHyperType (ContainedH f p))
x f (b ('AHyperType p) -> (a :*: b) # p)
-> f (b ('AHyperType p)) -> f ((a :*: b) # p)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> b ('AHyperType (ContainedH f p)) -> f (b ('AHyperType p))
forall (h :: AHyperType -> *) (f :: * -> *) (p :: AHyperType -> *).
(HTraversable h, Applicative f) =>
(h # ContainedH f p) -> f (h # p)
hsequence b ('AHyperType (ContainedH f p))
y

instance (HTraversable a, HTraversable b) => HTraversable (a :+: b) where
    {-# INLINE hsequence #-}
    hsequence :: ((a :+: b) # ContainedH f p) -> f ((a :+: b) # p)
hsequence (L1 a ('AHyperType (ContainedH f p))
x) = a ('AHyperType (ContainedH f p)) -> f (a # p)
forall (h :: AHyperType -> *) (f :: * -> *) (p :: AHyperType -> *).
(HTraversable h, Applicative f) =>
(h # ContainedH f p) -> f (h # p)
hsequence a ('AHyperType (ContainedH f p))
x f (a # p) -> ((a # p) -> (a :+: b) # p) -> f ((a :+: b) # p)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (a # p) -> (a :+: b) # p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1
    hsequence (R1 b ('AHyperType (ContainedH f p))
x) = b ('AHyperType (ContainedH f p)) -> f (b # p)
forall (h :: AHyperType -> *) (f :: * -> *) (p :: AHyperType -> *).
(HTraversable h, Applicative f) =>
(h # ContainedH f p) -> f (h # p)
hsequence b ('AHyperType (ContainedH f p))
x f (b # p) -> ((b # p) -> (a :+: b) # p) -> f ((a :+: b) # p)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (b # p) -> (a :+: b) # p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1

instance HTraversable h => HTraversable (M1 i m h) where
    {-# INLINE hsequence #-}
    hsequence :: (M1 i m h # ContainedH f p) -> f (M1 i m h # p)
hsequence = (h ('AHyperType (ContainedH f p)) -> f (h ('AHyperType p)))
-> (M1 i m h # ContainedH f p) -> f (M1 i m h # p)
forall k1 k2 i (c :: Meta) (f :: k1 -> *) (p :: k1) j (d :: Meta)
       (g :: k2 -> *) (q :: k2).
Iso (M1 i c f p) (M1 j d g q) (f p) (g q)
_M1 h ('AHyperType (ContainedH f p)) -> f (h ('AHyperType p))
forall (h :: AHyperType -> *) (f :: * -> *) (p :: AHyperType -> *).
(HTraversable h, Applicative f) =>
(h # ContainedH f p) -> f (h # p)
hsequence

instance HTraversable h => HTraversable (Rec1 h) where
    {-# INLINE hsequence #-}
    hsequence :: (Rec1 h # ContainedH f p) -> f (Rec1 h # p)
hsequence = (h ('AHyperType (ContainedH f p)) -> f (h ('AHyperType p)))
-> (Rec1 h # ContainedH f p) -> f (Rec1 h # p)
forall k1 k2 (f :: k1 -> *) (p :: k1) (g :: k2 -> *) (q :: k2).
Iso (Rec1 f p) (Rec1 g q) (f p) (g q)
_Rec1 h ('AHyperType (ContainedH f p)) -> f (h ('AHyperType p))
forall (h :: AHyperType -> *) (f :: * -> *) (p :: AHyperType -> *).
(HTraversable h, Applicative f) =>
(h # ContainedH f p) -> f (h # p)
hsequence

-- | 'HTraversable' variant of 'traverse'
{-# INLINE htraverse #-}
htraverse ::
    (Applicative f, HTraversable h) =>
    (forall n. HWitness h n -> p # n -> f (q # n)) ->
    h # p ->
    f (h # q)
htraverse :: (forall (n :: AHyperType -> *).
 HWitness h n -> (p # n) -> f (q # n))
-> (h # p) -> f (h # q)
htraverse forall (n :: AHyperType -> *). HWitness h n -> (p # n) -> f (q # n)
f = (h # ContainedH f q) -> f (h # q)
forall (h :: AHyperType -> *) (f :: * -> *) (p :: AHyperType -> *).
(HTraversable h, Applicative f) =>
(h # ContainedH f p) -> f (h # p)
hsequence ((h # ContainedH f q) -> f (h # q))
-> ((h # p) -> h # ContainedH f q) -> (h # p) -> f (h # q)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (n :: AHyperType -> *).
 HWitness h n -> (p # n) -> ContainedH f q # n)
-> (h # p) -> h # ContainedH f q
forall (h :: AHyperType -> *) (p :: AHyperType -> *)
       (q :: AHyperType -> *).
HFunctor h =>
(forall (n :: AHyperType -> *). HWitness h n -> (p # n) -> q # n)
-> (h # p) -> h # q
hmap ((f (q ('AHyperType n)) -> ContainedH f q ('AHyperType n))
-> ((p # n) -> f (q ('AHyperType n)))
-> (p # n)
-> ContainedH f q ('AHyperType n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f (q ('AHyperType n)) -> ContainedH f q ('AHyperType n)
forall (f :: * -> *) (p :: AHyperType -> *) (h :: AHyperType).
f (p h) -> ContainedH f p h
MkContainedH (((p # n) -> f (q ('AHyperType n)))
 -> (p # n) -> ContainedH f q ('AHyperType n))
-> (HWitness h n -> (p # n) -> f (q ('AHyperType n)))
-> HWitness h n
-> (p # n)
-> ContainedH f q ('AHyperType n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HWitness h n -> (p # n) -> f (q ('AHyperType n))
forall (n :: AHyperType -> *). HWitness h n -> (p # n) -> f (q # n)
f)

-- | 'HTraversable' variant of 'traverse' for 'Hyper.Type.HyperType's with a single node type.
--
-- It is a valid 'Traversal' as it avoids using @RankNTypes@.
{-# INLINE htraverse1 #-}
htraverse1 ::
    (HTraversable h, HNodesConstraint h ((~) n)) =>
    Traversal (h # p) (h # q) (p # n) (q # n)
htraverse1 :: Traversal (h # p) (h # q) (p # n) (q # n)
htraverse1 (p # n) -> f (q # n)
f = (h # ContainedH f q) -> f (h # q)
forall (h :: AHyperType -> *) (f :: * -> *) (p :: AHyperType -> *).
(HTraversable h, Applicative f) =>
(h # ContainedH f p) -> f (h # p)
hsequence ((h # ContainedH f q) -> f (h # q))
-> ((h # p) -> h # ContainedH f q) -> (h # p) -> f (h # q)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((p # n) -> Identity (ContainedH f q # n))
-> (h # p) -> Identity (h # ContainedH f q)
forall (h :: AHyperType -> *) (n :: AHyperType -> *)
       (p :: AHyperType -> *) (q :: AHyperType -> *).
(HFunctor h, HNodesConstraint h ((~) n)) =>
Setter (h # p) (h # q) (p # n) (q # n)
hmapped1 (((p # n) -> Identity (ContainedH f q # n))
 -> (h # p) -> Identity (h # ContainedH f q))
-> ((p # n) -> ContainedH f q # n) -> (h # p) -> h # ContainedH f q
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ f (q # n) -> ContainedH f q # n
forall (f :: * -> *) (p :: AHyperType -> *) (h :: AHyperType).
f (p h) -> ContainedH f p h
MkContainedH (f (q # n) -> ContainedH f q # n)
-> ((p # n) -> f (q # n)) -> (p # n) -> ContainedH f q # n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (p # n) -> f (q # n)
f)