{-# LANGUAGE FlexibleContexts #-}

-- | A variant of 'Functor' for 'Hyper.Type.HyperType's
module Hyper.Class.Functor
    ( HFunctor (..)
    , hmapped1
    , hiso
    ) where

import Control.Lens (AnIso', Iso', Setter, cloneIso, iso, sets, _Wrapped)
import GHC.Generics
import GHC.Generics.Lens (generic1)
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 = forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> *) (a :: k1) (b :: k2).
(Generic1 f, Generic1 g) =>
Iso (f a) (g b) (Rep1 f a) (Rep1 g b)
generic1 forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall (h :: HyperType) (p :: HyperType) (q :: HyperType).
HFunctor h =>
(forall (n :: HyperType). HWitness h n -> (p # n) -> q # n)
-> (h # p) -> h # q
hmap (forall (n :: HyperType). HWitness h n -> (p # n) -> q # n
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (h1 :: HyperType) (n1 :: HyperType) (h2 :: HyperType)
       (n2 :: HyperType).
Iso
  (HWitness h1 n1)
  (HWitness h2 n2)
  (HWitnessType h1 n1)
  (HWitnessType h2 n2)
_HWitness forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. a -> a
id))

instance HFunctor (Const a) where
    {-# INLINE hmap #-}
    hmap :: forall (p :: HyperType) (q :: HyperType).
(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
_ = forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. a -> a
id

instance (HFunctor a, HFunctor b) => HFunctor (a :*: b) where
    {-# INLINE hmap #-}
    hmap :: forall (p :: HyperType) (q :: HyperType).
(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 (h :: HyperType) (p :: HyperType) (q :: HyperType).
HFunctor h =>
(forall (n :: HyperType). HWitness h n -> (p # n) -> q # n)
-> (h # p) -> h # q
hmap (forall (n :: HyperType). HWitness (a :*: b) n -> (p # n) -> q # n
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: HyperType) (n :: HyperType).
HWitnessType h n -> HWitness h n
HWitness forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1) a ('AHyperType p)
x
            forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g 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 (forall (n :: HyperType). HWitness (a :*: b) n -> (p # n) -> q # n
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: HyperType) (n :: HyperType).
HWitnessType h n -> HWitness h n
HWitness forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (p :: HyperType) (q :: HyperType).
(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) = forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (forall (h :: HyperType) (p :: HyperType) (q :: HyperType).
HFunctor h =>
(forall (n :: HyperType). HWitness h n -> (p # n) -> q # n)
-> (h # p) -> h # q
hmap (forall (n :: HyperType). HWitness (a :+: b) n -> (p # n) -> q # n
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: HyperType) (n :: HyperType).
HWitnessType h n -> HWitness h n
HWitness forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (forall (h :: HyperType) (p :: HyperType) (q :: HyperType).
HFunctor h =>
(forall (n :: HyperType). HWitness h n -> (p # n) -> q # n)
-> (h # p) -> h # q
hmap (forall (n :: HyperType). HWitness (a :+: b) n -> (p # n) -> q # n
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: HyperType) (n :: HyperType).
HWitnessType h n -> HWitness h n
HWitness forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (h :: HyperType) (n :: HyperType) (p :: HyperType)
       (q :: HyperType).
(HFunctor h, HNodesConstraint h ((~) n)) =>
Setter (h # p) (h # q) (p # n) (q # n)
hmapped1 = 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 (h :: HyperType) (p :: HyperType) (q :: HyperType).
HFunctor h =>
(forall (n :: HyperType). HWitness h n -> (p # n) -> q # n)
-> (h # p) -> h # q
hmap (forall {k} (t :: k). Proxy t
Proxy @((~) 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
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 (h :: HyperType) (p :: HyperType) (q :: HyperType).
HFunctor h =>
(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 = forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (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 -> (forall s a. s -> Getting a s a -> a
^. forall s t a b. AnIso s t a b -> Iso s t a b
cloneIso (forall (n :: HyperType). HWitness h n -> AnIso' (p # n) (q # n)
f HWitness h n
w)))) (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 -> (forall s t a b. AnIso s t a b -> Iso s t a b
cloneIso (forall (n :: HyperType). HWitness h n -> AnIso' (p # n) (q # n)
f HWitness h n
w) forall t b. AReview t b -> b -> t
#)))