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

{-# LANGUAGE FlexibleContexts #-}

module Hyper.Class.Foldable
    ( HFoldable(..)
    , hfolded1
    , htraverse_, htraverse1_
    ) where

import Control.Lens (Fold, folding)
import GHC.Generics
import Hyper.Class.Nodes (HNodes(..), HWitness(..), _HWitness, (#>))
import Hyper.Type (type (#))

import Hyper.Internal.Prelude

-- | A variant of 'Foldable' for 'Hyper.Type.HyperType's
class HNodes h => HFoldable h where
    -- | 'HFoldable' variant of 'foldMap'
    --
    -- Gets a function from @h@'s nodes (trees along witnesses that they are nodes of @h@)
    -- into a monoid and concats its results for all nodes.
    hfoldMap ::
        Monoid a =>
        (forall n. HWitness h n -> p # n -> a) ->
        h # p ->
        a
    {-# INLINE hfoldMap #-}
    default hfoldMap ::
        ( Generic1 h, HFoldable (Rep1 h), HWitnessType h ~ HWitnessType (Rep1 h)
        , Monoid a
        ) =>
        (forall n. HWitness h n -> p # n -> a) ->
        h # p ->
        a
    hfoldMap forall (n :: HyperType). HWitness h n -> (p # n) -> a
f = (forall (n :: HyperType). HWitness (Rep1 h) n -> (p # n) -> a)
-> (Rep1 h # p) -> a
forall (h :: HyperType) a (p :: HyperType).
(HFoldable h, Monoid a) =>
(forall (n :: HyperType). HWitness h n -> (p # n) -> a)
-> (h # p) -> a
hfoldMap (HWitness h n -> (p # n) -> a
forall (n :: HyperType). HWitness h n -> (p # n) -> a
f (HWitness h n -> (p # n) -> a)
-> (HWitness (Rep1 h) n -> HWitness h n)
-> HWitness (Rep1 h) n
-> (p # n)
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((HWitnessType (Rep1 h) n -> Identity (HWitnessType (Rep1 h) n))
-> HWitness (Rep1 h) n -> Identity (HWitness h n)
forall (h1 :: HyperType) (n1 :: HyperType) (h :: HyperType)
       (n :: HyperType).
Iso
  (HWitness h1 n1)
  (HWitness h n)
  (HWitnessType h1 n1)
  (HWitnessType h n)
_HWitness ((HWitnessType (Rep1 h) n -> Identity (HWitnessType (Rep1 h) n))
 -> HWitness (Rep1 h) n -> Identity (HWitness h n))
-> (HWitnessType (Rep1 h) n -> HWitnessType (Rep1 h) n)
-> HWitness (Rep1 h) n
-> HWitness h n
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ HWitnessType (Rep1 h) n -> HWitnessType (Rep1 h) n
forall a. a -> a
id)) ((Rep1 h # p) -> a) -> ((h # p) -> Rep1 h # p) -> (h # p) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (h # p) -> Rep1 h # p
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1

instance HFoldable (Const a) where
    {-# INLINE hfoldMap #-}
    hfoldMap :: (forall (n :: HyperType). HWitness (Const a) n -> (p # n) -> a)
-> (Const a # p) -> a
hfoldMap forall (n :: HyperType). HWitness (Const a) n -> (p # n) -> a
_ Const a # p
_ = a
forall a. Monoid a => a
mempty

instance (HFoldable a, HFoldable b) => HFoldable (a :*: b) where
    {-# INLINE hfoldMap #-}
    hfoldMap :: (forall (n :: HyperType). HWitness (a :*: b) n -> (p # n) -> a)
-> ((a :*: b) # p) -> a
hfoldMap forall (n :: HyperType). HWitness (a :*: b) n -> (p # n) -> a
f (a ('AHyperType p)
x :*: b ('AHyperType p)
y) =
        (forall (n :: HyperType). HWitness a n -> (p # n) -> a)
-> a ('AHyperType p) -> a
forall (h :: HyperType) a (p :: HyperType).
(HFoldable h, Monoid a) =>
(forall (n :: HyperType). HWitness h n -> (p # n) -> a)
-> (h # p) -> a
hfoldMap (HWitness (a :*: b) n -> (p # n) -> a
forall (n :: HyperType). HWitness (a :*: b) n -> (p # n) -> a
f (HWitness (a :*: b) n -> (p # n) -> a)
-> (HWitness a n -> HWitness (a :*: b) n)
-> HWitness a n
-> (p # n)
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:+:) (HWitness a) (HWitness b) n -> HWitness (a :*: b) n
forall (h :: HyperType) (n :: HyperType).
HWitnessType h n -> HWitness h n
HWitness ((:+:) (HWitness a) (HWitness b) n -> HWitness (a :*: b) n)
-> (HWitness a n -> (:+:) (HWitness a) (HWitness b) n)
-> HWitness a n
-> HWitness (a :*: b) n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HWitness a n -> (:+:) (HWitness a) (HWitness b) n
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1) a ('AHyperType p)
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<>
        (forall (n :: HyperType). HWitness b n -> (p # n) -> a)
-> b ('AHyperType p) -> a
forall (h :: HyperType) a (p :: HyperType).
(HFoldable h, Monoid a) =>
(forall (n :: HyperType). HWitness h n -> (p # n) -> a)
-> (h # p) -> a
hfoldMap (HWitness (a :*: b) n -> (p # n) -> a
forall (n :: HyperType). HWitness (a :*: b) n -> (p # n) -> a
f (HWitness (a :*: b) n -> (p # n) -> a)
-> (HWitness b n -> HWitness (a :*: b) n)
-> HWitness b n
-> (p # n)
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:+:) (HWitness a) (HWitness b) n -> HWitness (a :*: b) n
forall (h :: HyperType) (n :: HyperType).
HWitnessType h n -> HWitness h n
HWitness ((:+:) (HWitness a) (HWitness b) n -> HWitness (a :*: b) n)
-> (HWitness b n -> (:+:) (HWitness a) (HWitness b) n)
-> HWitness b n
-> HWitness (a :*: b) n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HWitness b n -> (:+:) (HWitness a) (HWitness b) n
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1) b ('AHyperType p)
y

instance (HFoldable a, HFoldable b) => HFoldable (a :+: b) where
    {-# INLINE hfoldMap #-}
    hfoldMap :: (forall (n :: HyperType). HWitness (a :+: b) n -> (p # n) -> a)
-> ((a :+: b) # p) -> a
hfoldMap forall (n :: HyperType). HWitness (a :+: b) n -> (p # n) -> a
f (L1 a ('AHyperType p)
x) = (forall (n :: HyperType). HWitness a n -> (p # n) -> a)
-> a ('AHyperType p) -> a
forall (h :: HyperType) a (p :: HyperType).
(HFoldable h, Monoid a) =>
(forall (n :: HyperType). HWitness h n -> (p # n) -> a)
-> (h # p) -> a
hfoldMap (HWitness (a :+: b) n -> (p # n) -> a
forall (n :: HyperType). HWitness (a :+: b) n -> (p # n) -> a
f (HWitness (a :+: b) n -> (p # n) -> a)
-> (HWitness a n -> HWitness (a :+: b) n)
-> HWitness a n
-> (p # n)
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:+:) (HWitness a) (HWitness b) n -> HWitness (a :+: b) n
forall (h :: HyperType) (n :: HyperType).
HWitnessType h n -> HWitness h n
HWitness ((:+:) (HWitness a) (HWitness b) n -> HWitness (a :+: b) n)
-> (HWitness a n -> (:+:) (HWitness a) (HWitness b) n)
-> HWitness a n
-> HWitness (a :+: b) n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HWitness a n -> (:+:) (HWitness a) (HWitness b) n
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1) a ('AHyperType p)
x
    hfoldMap forall (n :: HyperType). HWitness (a :+: b) n -> (p # n) -> a
f (R1 b ('AHyperType p)
x) = (forall (n :: HyperType). HWitness b n -> (p # n) -> a)
-> b ('AHyperType p) -> a
forall (h :: HyperType) a (p :: HyperType).
(HFoldable h, Monoid a) =>
(forall (n :: HyperType). HWitness h n -> (p # n) -> a)
-> (h # p) -> a
hfoldMap (HWitness (a :+: b) n -> (p # n) -> a
forall (n :: HyperType). HWitness (a :+: b) n -> (p # n) -> a
f (HWitness (a :+: b) n -> (p # n) -> a)
-> (HWitness b n -> HWitness (a :+: b) n)
-> HWitness b n
-> (p # n)
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:+:) (HWitness a) (HWitness b) n -> HWitness (a :+: b) n
forall (h :: HyperType) (n :: HyperType).
HWitnessType h n -> HWitness h n
HWitness ((:+:) (HWitness a) (HWitness b) n -> HWitness (a :+: b) n)
-> (HWitness b n -> (:+:) (HWitness a) (HWitness b) n)
-> HWitness b n
-> HWitness (a :+: b) n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HWitness b n -> (:+:) (HWitness a) (HWitness b) n
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1) b ('AHyperType p)
x

deriving newtype instance HFoldable h => HFoldable (M1 i m h)
deriving newtype instance HFoldable h => HFoldable (Rec1 h)

-- | 'HFoldable' variant for 'Control.Lens.folded' for 'Hyper.Type.HyperType's with a single node type.
--
-- Avoids using @RankNTypes@ and thus can be composed with other optics.
{-# INLINE hfolded1 #-}
hfolded1 ::
    forall h n p.
    ( HFoldable h
    , HNodesConstraint h ((~) n)
    ) =>
    Fold (h # p) (p # n)
hfolded1 :: Fold (h # p) (p # n)
hfolded1 =
    ((h # p) -> [p # n]) -> Fold (h # p) (p # n)
forall (f :: * -> *) s a. Foldable f => (s -> f a) -> Fold s a
folding ((forall (n :: HyperType). HWitness h n -> (p # n) -> [p # n])
-> (h # p) -> [p # n]
forall (h :: HyperType) a (p :: HyperType).
(HFoldable h, Monoid a) =>
(forall (n :: HyperType). HWitness h n -> (p # n) -> a)
-> (h # p) -> a
hfoldMap @_ @[p # n] (Proxy ((~) n)
forall k (t :: k). Proxy t
Proxy @((~) n) Proxy ((~) n)
-> ((n ~ n) => (p # n) -> [p # n])
-> HWitness h n
-> (p # n)
-> [p # n]
forall (h :: HyperType) (c :: HyperType -> Constraint)
       (n :: HyperType) r.
(HNodes h, HNodesConstraint h c) =>
Proxy c -> (c n => r) -> HWitness h n -> r
#> (n ~ n) => (p # n) -> [p # n]
forall (f :: * -> *) a. Applicative f => a -> f a
pure))

-- | 'HFoldable' variant of 'Data.Foldable.traverse_'
--
-- Applise a given action on all subtrees
-- (represented as trees along witnesses that they are nodes of @h@)
{-# INLINE htraverse_ #-}
htraverse_ ::
    (Applicative f, HFoldable h) =>
    (forall c. HWitness h c -> m # c -> f ()) ->
    h # m ->
    f ()
htraverse_ :: (forall (c :: HyperType). HWitness h c -> (m # c) -> f ())
-> (h # m) -> f ()
htraverse_ forall (c :: HyperType). HWitness h c -> (m # c) -> f ()
f = [f ()] -> f ()
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Applicative f) =>
t (f a) -> f ()
sequenceA_ ([f ()] -> f ()) -> ((h # m) -> [f ()]) -> (h # m) -> f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (n :: HyperType). HWitness h n -> (m # n) -> [f ()])
-> (h # m) -> [f ()]
forall (h :: HyperType) a (p :: HyperType).
(HFoldable h, Monoid a) =>
(forall (n :: HyperType). HWitness h n -> (p # n) -> a)
-> (h # p) -> a
hfoldMap ((f () -> [f ()]) -> ((m # n) -> f ()) -> (m # n) -> [f ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (f () -> [f ()] -> [f ()]
forall a. a -> [a] -> [a]
:[]) (((m # n) -> f ()) -> (m # n) -> [f ()])
-> (HWitness h n -> (m # n) -> f ())
-> HWitness h n
-> (m # n)
-> [f ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HWitness h n -> (m # n) -> f ()
forall (c :: HyperType). HWitness h c -> (m # c) -> f ()
f)

-- | 'HFoldable' variant of 'Data.Foldable.traverse_' for 'Hyper.Type.HyperType's with a single node type (avoids using @RankNTypes@)
{-# INLINE htraverse1_ #-}
htraverse1_ ::
    forall f h n p.
    ( Applicative f, HFoldable h
    , HNodesConstraint h ((~) n)
    ) =>
    (p # n -> f ()) ->
    h # p ->
    f ()
htraverse1_ :: ((p # n) -> f ()) -> (h # p) -> f ()
htraverse1_ (p # n) -> f ()
f = (forall (c :: HyperType). HWitness h c -> (p # c) -> f ())
-> (h # p) -> f ()
forall (f :: * -> *) (h :: HyperType) (m :: HyperType).
(Applicative f, HFoldable h) =>
(forall (c :: HyperType). HWitness h c -> (m # c) -> f ())
-> (h # m) -> f ()
htraverse_ (Proxy ((~) n)
forall k (t :: k). Proxy t
Proxy @((~) n) Proxy ((~) n)
-> ((n ~ c) => (p # c) -> f ()) -> HWitness h c -> (p # c) -> f ()
forall (h :: HyperType) (c :: HyperType -> Constraint)
       (n :: HyperType) r.
(HNodes h, HNodesConstraint h c) =>
Proxy c -> (c n => r) -> HWitness h n -> r
#> (p # n) -> f ()
(n ~ c) => (p # c) -> f ()
f)