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

{-# LANGUAGE FlexibleContexts #-}

module Hyper.Class.Functor
    ( HFunctor(..)
    , hmapped1
    , hiso
    ) where

import Control.Lens (Setter, Iso', AnIso', sets, iso, cloneIso)
import GHC.Generics
import Hyper.Class.Nodes (HNodes(..), HWitness(..), _HWitness, (#>))
import Hyper.Type (type (#))

import Hyper.Internal.Prelude

-- | A variant of 'Functor' for 'HyperType's
class HNodes h => HFunctor h where
    -- | 'HFunctor' variant of 'fmap'
    --
    -- Applied a given mapping for @h@'s nodes (trees along witnesses that they are nodes of @h@)
    -- to result with a new tree, potentially with a different nest type.
    hmap ::
        (forall n. HWitness h n -> p # n -> q # n) ->
        h # p ->
        h # q
    {-# INLINE hmap #-}
    default hmap ::
        (Generic1 h, HFunctor (Rep1 h), HWitnessType h ~ HWitnessType (Rep1 h)) =>
        (forall n. HWitness h n -> p # n -> q # n) ->
        h # p ->
        h # q
    hmap forall (n :: HyperType). HWitness h n -> (p # n) -> q # n
f = Rep1 h ('AHyperType q) -> h # q
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 (Rep1 h ('AHyperType q) -> h # q)
-> ((h # p) -> Rep1 h ('AHyperType q)) -> (h # p) -> h # q
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (n :: HyperType). HWitness (Rep1 h) n -> (p # n) -> q # n)
-> (Rep1 h # p) -> Rep1 h ('AHyperType q)
forall (h :: HyperType) (p :: HyperType) (q :: HyperType).
HFunctor h =>
(forall (n :: HyperType). HWitness h n -> (p # n) -> q # n)
-> (h # p) -> h # q
hmap (HWitness h n -> (p # n) -> q # n
forall (n :: HyperType). HWitness h n -> (p # n) -> q # n
f (HWitness h n -> (p # n) -> q # n)
-> (HWitness (Rep1 h) n -> HWitness h n)
-> HWitness (Rep1 h) n
-> (p # n)
-> q # n
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) -> Rep1 h ('AHyperType q))
-> ((h # p) -> Rep1 h # p) -> (h # p) -> Rep1 h ('AHyperType q)
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 HFunctor (Const a) where
    {-# INLINE hmap #-}
    hmap :: (forall (n :: HyperType). HWitness (Const a) n -> (p # n) -> q # n)
-> (Const a # p) -> Const a # q
hmap forall (n :: HyperType). HWitness (Const a) n -> (p # n) -> q # n
_ (Const a
x) = a -> Const a # q
forall k a (b :: k). a -> Const a b
Const a
x

instance (HFunctor a, HFunctor b) => HFunctor (a :*: b) where
    {-# INLINE hmap #-}
    hmap :: (forall (n :: HyperType). HWitness (a :*: b) n -> (p # n) -> q # n)
-> ((a :*: b) # p) -> (a :*: b) # q
hmap forall (n :: HyperType). HWitness (a :*: b) n -> (p # n) -> q # n
f (a ('AHyperType p)
x :*: b ('AHyperType p)
y) =
        (forall (n :: HyperType). HWitness a n -> (p # n) -> q # n)
-> a ('AHyperType p) -> a # q
forall (h :: HyperType) (p :: HyperType) (q :: HyperType).
HFunctor h =>
(forall (n :: HyperType). HWitness h n -> (p # n) -> q # n)
-> (h # p) -> h # q
hmap (HWitness (a :*: b) n -> (p # n) -> q # n
forall (n :: HyperType). HWitness (a :*: b) n -> (p # n) -> q # n
f (HWitness (a :*: b) n -> (p # n) -> q # n)
-> (HWitness a n -> HWitness (a :*: b) n)
-> HWitness a n
-> (p # n)
-> q # n
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 # q) -> b ('AHyperType q) -> (a :*: b) # q
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*:
        (forall (n :: HyperType). HWitness b n -> (p # n) -> q # n)
-> b ('AHyperType p) -> b ('AHyperType q)
forall (h :: HyperType) (p :: HyperType) (q :: HyperType).
HFunctor h =>
(forall (n :: HyperType). HWitness h n -> (p # n) -> q # n)
-> (h # p) -> h # q
hmap (HWitness (a :*: b) n -> (p # n) -> q # n
forall (n :: HyperType). HWitness (a :*: b) n -> (p # n) -> q # n
f (HWitness (a :*: b) n -> (p # n) -> q # n)
-> (HWitness b n -> HWitness (a :*: b) n)
-> HWitness b n
-> (p # n)
-> q # n
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 (HFunctor a, HFunctor b) => HFunctor (a :+: b) where
    {-# INLINE hmap #-}
    hmap :: (forall (n :: HyperType). HWitness (a :+: b) n -> (p # n) -> q # n)
-> ((a :+: b) # p) -> (a :+: b) # q
hmap forall (n :: HyperType). HWitness (a :+: b) n -> (p # n) -> q # n
f (L1 a ('AHyperType p)
x) = a ('AHyperType q) -> (a :+: b) # q
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 ((forall (n :: HyperType). HWitness a n -> (p # n) -> q # n)
-> a ('AHyperType p) -> a ('AHyperType q)
forall (h :: HyperType) (p :: HyperType) (q :: HyperType).
HFunctor h =>
(forall (n :: HyperType). HWitness h n -> (p # n) -> q # n)
-> (h # p) -> h # q
hmap (HWitness (a :+: b) n -> (p # n) -> q # n
forall (n :: HyperType). HWitness (a :+: b) n -> (p # n) -> q # n
f (HWitness (a :+: b) n -> (p # n) -> q # n)
-> (HWitness a n -> HWitness (a :+: b) n)
-> HWitness a n
-> (p # n)
-> q # n
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)
    hmap forall (n :: HyperType). HWitness (a :+: b) n -> (p # n) -> q # n
f (R1 b ('AHyperType p)
x) = b ('AHyperType q) -> (a :+: b) # q
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 ((forall (n :: HyperType). HWitness b n -> (p # n) -> q # n)
-> b ('AHyperType p) -> b ('AHyperType q)
forall (h :: HyperType) (p :: HyperType) (q :: HyperType).
HFunctor h =>
(forall (n :: HyperType). HWitness h n -> (p # n) -> q # n)
-> (h # p) -> h # q
hmap (HWitness (a :+: b) n -> (p # n) -> q # n
forall (n :: HyperType). HWitness (a :+: b) n -> (p # n) -> q # n
f (HWitness (a :+: b) n -> (p # n) -> q # n)
-> (HWitness b n -> HWitness (a :+: b) n)
-> HWitness b n
-> (p # n)
-> q # n
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 HFunctor h => HFunctor (M1 i m h)
deriving newtype instance HFunctor h => HFunctor (Rec1 h)

-- | 'HFunctor' variant of 'Control.Lens.mapped' for 'Hyper.Type.HyperType's with a single node type.
--
-- Avoids using @RankNTypes@ and thus can be composed with other optics.
{-# INLINE hmapped1 #-}
hmapped1 ::
    forall h n p q.
    (HFunctor h, HNodesConstraint h ((~) n)) =>
    Setter (h # p) (h # q) (p # n) (q # n)
hmapped1 :: Setter (h # p) (h # q) (p # n) (q # n)
hmapped1 = (((p # n) -> q # n) -> (h # p) -> h # q)
-> Optical (->) (->) f (h # p) (h # q) (p # n) (q # n)
forall (p :: * -> * -> *) (q :: * -> * -> *) (f :: * -> *) a b s t.
(Profunctor p, Profunctor q, Settable f) =>
(p a b -> q s t) -> Optical p q f s t a b
sets (\(p # n) -> q # n
f -> (forall (n :: HyperType). HWitness h n -> (p # n) -> q # n)
-> (h # p) -> h # q
forall (h :: HyperType) (p :: HyperType) (q :: HyperType).
HFunctor h =>
(forall (n :: HyperType). HWitness h n -> (p # n) -> q # n)
-> (h # p) -> h # q
hmap (Proxy ((~) n)
forall k (t :: k). Proxy t
Proxy @((~) n) Proxy ((~) n)
-> ((n ~ n) => (p # n) -> q # n)
-> HWitness h n
-> (p # n)
-> q # n
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) -> q # n
(n ~ n) => (p # n) -> q # n
f))

-- | Define 'Iso's for 'HFunctor's
--
-- TODO: Is there an equivalent for this in lens that we can name this after?
hiso ::
    HFunctor h =>
    (forall n. HWitness h n -> AnIso' (p # n) (q # n)) ->
    Iso' (h # p) (h # q)
hiso :: (forall (n :: HyperType). HWitness h n -> AnIso' (p # n) (q # n))
-> Iso' (h # p) (h # q)
hiso forall (n :: HyperType). HWitness h n -> AnIso' (p # n) (q # n)
f = ((h # p) -> h # q) -> ((h # q) -> h # p) -> Iso' (h # p) (h # q)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso ((forall (n :: HyperType). HWitness h n -> (p # n) -> q # n)
-> (h # p) -> h # q
forall (h :: HyperType) (p :: HyperType) (q :: HyperType).
HFunctor h =>
(forall (n :: HyperType). HWitness h n -> (p # n) -> q # n)
-> (h # p) -> h # q
hmap (\HWitness h n
w -> ((p # n) -> Getting (q # n) (p # n) (q # n) -> q # n
forall s a. s -> Getting a s a -> a
^. AnIso (p # n) (p # n) (q # n) (q # n)
-> Iso (p # n) (p # n) (q # n) (q # n)
forall s t a b. AnIso s t a b -> Iso s t a b
cloneIso (HWitness h n -> AnIso (p # n) (p # n) (q # n) (q # n)
forall (n :: HyperType). HWitness h n -> AnIso' (p # n) (q # n)
f HWitness h n
w)))) ((forall (n :: HyperType). HWitness h n -> (q # n) -> p # n)
-> (h # q) -> h # p
forall (h :: HyperType) (p :: HyperType) (q :: HyperType).
HFunctor h =>
(forall (n :: HyperType). HWitness h n -> (p # n) -> q # n)
-> (h # p) -> h # q
hmap (\HWitness h n
w -> (AnIso (p # n) (p # n) (q # n) (q # n)
-> Iso (p # n) (p # n) (q # n) (q # n)
forall s t a b. AnIso s t a b -> Iso s t a b
cloneIso (HWitness h n -> AnIso (p # n) (p # n) (q # n) (q # n)
forall (n :: HyperType). HWitness h n -> AnIso' (p # n) (q # n)
f HWitness h n
w) (Tagged (q # n) (Identity (q # n))
 -> Tagged (p # n) (Identity (p # n)))
-> (q # n) -> p # n
forall t b. AReview t b -> b -> t
#)))