{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}

module Hyper.Combinator.Ann
    ( Ann (..)
    , hAnn
    , hVal
    , Annotated
    , annotation
    , annValue
    ) where

import Control.Lens (Lens, Lens', from, _Wrapped)
import Hyper.Class.Foldable (HFoldable (..))
import Hyper.Class.Functor (HFunctor (..))
import Hyper.Class.Nodes
import Hyper.Class.Traversable
import Hyper.Combinator.Flip
import Hyper.Recurse
import Hyper.TH.Traversable (makeHTraversableApplyAndBases)
import Hyper.Type (type (#), type (:#))

import Hyper.Internal.Prelude

data Ann a h = Ann
    { forall (a :: AHyperType -> *) (h :: AHyperType). Ann a h -> a h
_hAnn :: a h
    , forall (a :: AHyperType -> *) (h :: AHyperType).
Ann a h -> h :# Ann a
_hVal :: h :# Ann a
    }
    deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (a :: AHyperType -> *) (h :: AHyperType) x.
Rep (Ann a h) x -> Ann a h
forall (a :: AHyperType -> *) (h :: AHyperType) x.
Ann a h -> Rep (Ann a h) x
$cto :: forall (a :: AHyperType -> *) (h :: AHyperType) x.
Rep (Ann a h) x -> Ann a h
$cfrom :: forall (a :: AHyperType -> *) (h :: AHyperType) x.
Ann a h -> Rep (Ann a h) x
Generic)
makeLenses ''Ann

makeHTraversableApplyAndBases ''Ann
makeCommonInstances [''Ann]

instance RNodes h => HNodes (HFlip Ann h) where
    type HNodesConstraint (HFlip Ann h) c = (Recursive c, c h)
    type HWitnessType (HFlip Ann h) = HRecWitness h
    hLiftConstraint :: forall (c :: (AHyperType -> *) -> Constraint)
       (n :: AHyperType -> *) r.
HNodesConstraint (HFlip Ann h) c =>
HWitness (HFlip Ann h) n -> Proxy c -> (c n => r) -> r
hLiftConstraint (HWitness HWitnessType (HFlip Ann h) n
HRecWitness h n
HRecSelf) = \Proxy c
_ c n => r
x -> c n => r
x
    hLiftConstraint (HWitness (HRecSub HWitness h c
w0 HRecWitness c n
w1)) = forall (a :: AHyperType -> *)
       (c :: (AHyperType -> *) -> Constraint) (b :: AHyperType -> *)
       (n :: AHyperType -> *) r.
(RNodes a, HNodesConstraint (HFlip Ann a) c) =>
HWitness a b -> HRecWitness b n -> Proxy c -> (c n => r) -> r
hLiftConstraintH HWitness h c
w0 HRecWitness c n
w1

-- TODO: Dedup this and similar code in Hyper.Unify.Generalize
hLiftConstraintH ::
    forall a c b n r.
    (RNodes a, HNodesConstraint (HFlip Ann a) c) =>
    HWitness a b ->
    HRecWitness b n ->
    Proxy c ->
    (c n => r) ->
    r
hLiftConstraintH :: forall (a :: AHyperType -> *)
       (c :: (AHyperType -> *) -> Constraint) (b :: AHyperType -> *)
       (n :: AHyperType -> *) r.
(RNodes a, HNodesConstraint (HFlip Ann a) c) =>
HWitness a b -> HRecWitness b n -> Proxy c -> (c n => r) -> r
hLiftConstraintH HWitness a b
c HRecWitness b n
n Proxy c
p c n => r
f =
    forall (h :: AHyperType -> *)
       (c :: (AHyperType -> *) -> Constraint) (n :: AHyperType -> *) r.
(HNodes h, HNodesConstraint h c) =>
HWitness h n -> Proxy c -> (c n => r) -> r
hLiftConstraint
        HWitness a b
c
        (forall {k} (t :: k). Proxy t
Proxy @RNodes)
        ( forall (h :: AHyperType -> *)
       (c :: (AHyperType -> *) -> Constraint) (n :: AHyperType -> *) r.
(HNodes h, HNodesConstraint h c) =>
HWitness h n -> Proxy c -> (c n => r) -> r
hLiftConstraint
            HWitness a b
c
            Proxy c
p
            (forall (h :: AHyperType -> *)
       (c :: (AHyperType -> *) -> Constraint) (n :: AHyperType -> *) r.
(HNodes h, HNodesConstraint h c) =>
HWitness h n -> Proxy c -> (c n => r) -> r
hLiftConstraint (forall (h :: AHyperType -> *) (n :: AHyperType -> *).
HWitnessType h n -> HWitness h n
HWitness @(HFlip Ann _) HRecWitness b n
n) Proxy c
p c n => r
f)
            forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ forall (c :: (AHyperType -> *) -> Constraint)
       (h :: AHyperType -> *) (proxy :: Constraint -> *).
(Recursive c, HNodes h, c h) =>
proxy (c h) -> Dict (HNodesConstraint h c)
recurse (forall {k} (t :: k). Proxy t
Proxy @(c a))
        )
        forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ forall (c :: (AHyperType -> *) -> Constraint)
       (h :: AHyperType -> *) (proxy :: Constraint -> *).
(Recursive c, HNodes h, c h) =>
proxy (c h) -> Dict (HNodesConstraint h c)
recurse (forall {k} (t :: k). Proxy t
Proxy @(RNodes a))

instance RNodes a => RNodes (Ann a) where
    {-# INLINE recursiveHNodes #-}
    recursiveHNodes :: RecMethod RNodes (Ann a)
recursiveHNodes Proxy (Ann a)
_ = forall (a :: Constraint). a => Dict a
Dict forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ forall (h :: AHyperType -> *). RNodes h => RecMethod RNodes h
recursiveHNodes (forall {k} (t :: k). Proxy t
Proxy @a)

instance (c (Ann a), Recursively c a) => Recursively c (Ann a) where
    {-# INLINE recursively #-}
    recursively :: forall (proxy :: Constraint -> *).
proxy (c (Ann a))
-> Dict (c (Ann a), HNodesConstraint (Ann a) (Recursively c))
recursively proxy (c (Ann a))
_ = forall (a :: Constraint). a => Dict a
Dict forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ forall (c :: (AHyperType -> *) -> Constraint)
       (h :: AHyperType -> *) (proxy :: Constraint -> *).
Recursively c h =>
proxy (c h) -> Dict (c h, HNodesConstraint h (Recursively c))
recursively (forall {k} (t :: k). Proxy t
Proxy @(c a))

instance RTraversable a => RTraversable (Ann a) where
    {-# INLINE recursiveHTraversable #-}
    recursiveHTraversable :: RecMethod RTraversable (Ann a)
recursiveHTraversable Proxy (Ann a)
_ = forall (a :: Constraint). a => Dict a
Dict forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ forall (h :: AHyperType -> *).
RTraversable h =>
RecMethod RTraversable h
recursiveHTraversable (forall {k} (t :: k). Proxy t
Proxy @a)

instance Recursively HFunctor h => HFunctor (HFlip Ann h) where
    {-# INLINE hmap #-}
    hmap :: forall (p :: AHyperType -> *) (q :: AHyperType -> *).
(forall (n :: AHyperType -> *).
 HWitness (HFlip Ann h) n -> (p # n) -> q # n)
-> (HFlip Ann h # p) -> HFlip Ann h # q
hmap forall (n :: AHyperType -> *).
HWitness (HFlip Ann h) n -> (p # n) -> q # n
f =
        forall (f0 :: (AHyperType -> *) -> AHyperType -> *)
       (x0 :: AHyperType -> *) (k0 :: AHyperType -> *)
       (f1 :: (AHyperType -> *) -> AHyperType -> *)
       (x1 :: AHyperType -> *) (k1 :: AHyperType -> *).
Iso (HFlip f0 x0 # k0) (HFlip f1 x1 # k1) (f0 k0 # x0) (f1 k1 # x1)
_HFlip
            forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \(Ann p ('AHyperType h)
a 'AHyperType h :# Ann p
b) ->
                forall (a :: AHyperType -> *) (h :: AHyperType).
a h -> (h :# Ann a) -> Ann a h
Ann
                    (forall (n :: AHyperType -> *).
HWitness (HFlip Ann h) n -> (p # n) -> q # n
f (forall (h :: AHyperType -> *) (n :: AHyperType -> *).
HWitnessType h n -> HWitness h n
HWitness forall (h :: AHyperType -> *). HRecWitness h h
HRecSelf) p ('AHyperType h)
a)
                    ( forall (h :: AHyperType -> *) (p :: AHyperType -> *)
       (q :: AHyperType -> *).
HFunctor h =>
(forall (n :: AHyperType -> *). HWitness h n -> (p # n) -> q # n)
-> (h # p) -> h # q
hmap
                        ( forall {k} (t :: k). Proxy t
Proxy @(Recursively HFunctor) forall (h :: AHyperType -> *)
       (c :: (AHyperType -> *) -> Constraint) (n :: AHyperType -> *) r.
(HNodes h, HNodesConstraint h c) =>
Proxy c -> (c n => HWitness h n -> r) -> HWitness h n -> r
#*#
                            \HWitness h n
w -> forall s t a b. AnIso s t a b -> Iso b a t s
from forall (f0 :: (AHyperType -> *) -> AHyperType -> *)
       (x0 :: AHyperType -> *) (k0 :: AHyperType -> *)
       (f1 :: (AHyperType -> *) -> AHyperType -> *)
       (x1 :: AHyperType -> *) (k1 :: AHyperType -> *).
Iso (HFlip f0 x0 # k0) (HFlip f1 x1 # k1) (f0 k0 # x0) (f1 k1 # x1)
_HFlip forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall (h :: AHyperType -> *) (p :: AHyperType -> *)
       (q :: AHyperType -> *).
HFunctor h =>
(forall (n :: AHyperType -> *). HWitness h n -> (p # n) -> q # n)
-> (h # p) -> h # q
hmap (forall (n :: AHyperType -> *).
HWitness (HFlip Ann h) n -> (p # n) -> q # n
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: AHyperType -> *) (n :: AHyperType -> *).
HWitnessType h n -> HWitness h n
HWitness forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: AHyperType -> *) (c :: AHyperType -> *)
       (n :: AHyperType -> *).
HWitness h c -> HRecWitness c n -> HRecWitness h n
HRecSub HWitness h n
w forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. s -> Getting a s a -> a
^. forall (h1 :: AHyperType -> *) (n1 :: AHyperType -> *)
       (h2 :: AHyperType -> *) (n2 :: AHyperType -> *).
Iso
  (HWitness h1 n1)
  (HWitness h2 n2)
  (HWitnessType h1 n1)
  (HWitnessType h2 n2)
_HWitness))
                        )
                        'AHyperType h :# Ann p
b
                        forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ forall (c :: (AHyperType -> *) -> Constraint)
       (h :: AHyperType -> *) (proxy :: Constraint -> *).
Recursively c h =>
proxy (c h) -> Dict (c h, HNodesConstraint h (Recursively c))
recursively (forall {k} (t :: k). Proxy t
Proxy @(HFunctor h))
                    )

instance Recursively HFoldable h => HFoldable (HFlip Ann h) where
    {-# INLINE hfoldMap #-}
    hfoldMap :: forall a (p :: AHyperType -> *).
Monoid a =>
(forall (n :: AHyperType -> *).
 HWitness (HFlip Ann h) n -> (p # n) -> a)
-> (HFlip Ann h # p) -> a
hfoldMap forall (n :: AHyperType -> *).
HWitness (HFlip Ann h) n -> (p # n) -> a
f (MkHFlip (Ann GetHyperType ('AHyperType p) ('AHyperType h)
a 'AHyperType h :# Ann (GetHyperType ('AHyperType p))
b)) =
        forall (n :: AHyperType -> *).
HWitness (HFlip Ann h) n -> (p # n) -> a
f (forall (h :: AHyperType -> *) (n :: AHyperType -> *).
HWitnessType h n -> HWitness h n
HWitness forall (h :: AHyperType -> *). HRecWitness h h
HRecSelf) GetHyperType ('AHyperType p) ('AHyperType h)
a
            forall a. Semigroup a => a -> a -> a
<> forall (h :: AHyperType -> *) a (p :: AHyperType -> *).
(HFoldable h, Monoid a) =>
(forall (n :: AHyperType -> *). HWitness h n -> (p # n) -> a)
-> (h # p) -> a
hfoldMap
                ( forall {k} (t :: k). Proxy t
Proxy @(Recursively HFoldable) forall (h :: AHyperType -> *)
       (c :: (AHyperType -> *) -> Constraint) (n :: AHyperType -> *) r.
(HNodes h, HNodesConstraint h c) =>
Proxy c -> (c n => HWitness h n -> r) -> HWitness h n -> r
#*#
                    \HWitness h n
w -> forall (h :: AHyperType -> *) a (p :: AHyperType -> *).
(HFoldable h, Monoid a) =>
(forall (n :: AHyperType -> *). HWitness h n -> (p # n) -> a)
-> (h # p) -> a
hfoldMap (forall (n :: AHyperType -> *).
HWitness (HFlip Ann h) n -> (p # n) -> a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: AHyperType -> *) (n :: AHyperType -> *).
HWitnessType h n -> HWitness h n
HWitness forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: AHyperType -> *) (c :: AHyperType -> *)
       (n :: AHyperType -> *).
HWitness h c -> HRecWitness c n -> HRecWitness h n
HRecSub HWitness h n
w forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. s -> Getting a s a -> a
^. forall (h1 :: AHyperType -> *) (n1 :: AHyperType -> *)
       (h2 :: AHyperType -> *) (n2 :: AHyperType -> *).
Iso
  (HWitness h1 n1)
  (HWitness h2 n2)
  (HWitnessType h1 n1)
  (HWitnessType h2 n2)
_HWitness)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: (AHyperType -> *) -> AHyperType -> *)
       (x :: AHyperType -> *) (h :: AHyperType).
(f (GetHyperType h) # x) -> HFlip f x h
MkHFlip
                )
                'AHyperType h :# Ann (GetHyperType ('AHyperType p))
b
            forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ forall (c :: (AHyperType -> *) -> Constraint)
       (h :: AHyperType -> *) (proxy :: Constraint -> *).
Recursively c h =>
proxy (c h) -> Dict (c h, HNodesConstraint h (Recursively c))
recursively (forall {k} (t :: k). Proxy t
Proxy @(HFoldable h))

instance RTraversable h => HTraversable (HFlip Ann h) where
    {-# INLINE hsequence #-}
    hsequence :: forall (f :: * -> *) (p :: AHyperType -> *).
Applicative f =>
(HFlip Ann h # ContainedH f p) -> f (HFlip Ann h # p)
hsequence =
        forall (f0 :: (AHyperType -> *) -> AHyperType -> *)
       (x0 :: AHyperType -> *) (k0 :: AHyperType -> *)
       (f1 :: (AHyperType -> *) -> AHyperType -> *)
       (x1 :: AHyperType -> *) (k1 :: AHyperType -> *).
Iso (HFlip f0 x0 # k0) (HFlip f1 x1 # k1) (f0 k0 # x0) (f1 k1 # x1)
_HFlip
            ( \(Ann ContainedH f p ('AHyperType h)
a 'AHyperType h :# Ann (ContainedH f p)
b) ->
                forall (a :: AHyperType -> *) (h :: AHyperType).
a h -> (h :# Ann a) -> Ann a h
Ann
                    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) (p :: AHyperType -> *) (h :: AHyperType).
ContainedH f p h -> f (p h)
runContainedH ContainedH f p ('AHyperType h)
a
                    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) (h :: AHyperType -> *) (p :: AHyperType -> *)
       (q :: AHyperType -> *).
(Applicative f, HTraversable h) =>
(forall (n :: AHyperType -> *).
 HWitness h n -> (p # n) -> f (q # n))
-> (h # p) -> f (h # q)
htraverse (forall {k} (t :: k). Proxy t
Proxy @RTraversable forall (h :: AHyperType -> *)
       (c :: (AHyperType -> *) -> Constraint) (n :: AHyperType -> *) r.
(HNodes h, HNodesConstraint h c) =>
Proxy c -> (c n => r) -> HWitness h n -> r
#> forall s t a b. AnIso s t a b -> Iso b a t s
from forall (f0 :: (AHyperType -> *) -> AHyperType -> *)
       (x0 :: AHyperType -> *) (k0 :: AHyperType -> *)
       (f1 :: (AHyperType -> *) -> AHyperType -> *)
       (x1 :: AHyperType -> *) (k1 :: AHyperType -> *).
Iso (HFlip f0 x0 # k0) (HFlip f1 x1 # k1) (f0 k0 # x0) (f1 k1 # x1)
_HFlip forall (h :: AHyperType -> *) (f :: * -> *) (p :: AHyperType -> *).
(HTraversable h, Applicative f) =>
(h # ContainedH f p) -> f (h # p)
hsequence) 'AHyperType h :# Ann (ContainedH f p)
b
                    forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ forall (c :: (AHyperType -> *) -> Constraint)
       (h :: AHyperType -> *) (proxy :: Constraint -> *).
(Recursive c, HNodes h, c h) =>
proxy (c h) -> Dict (HNodesConstraint h c)
recurse (forall {k} (t :: k). Proxy t
Proxy @(RTraversable h))
            )

type Annotated a = Ann (Const a)

annotation :: Lens' (Annotated a # h) a
annotation :: forall a (h :: AHyperType -> *). Lens' (Annotated a # h) a
annotation = forall (a :: AHyperType -> *) (h :: AHyperType).
Lens' (Ann a h) (a h)
hAnn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped

-- | Polymorphic lens to an @Annotated@ value
annValue :: Lens (Annotated a # h0) (Annotated a # h1) (h0 # Annotated a) (h1 # Annotated a)
annValue :: forall a (h0 :: AHyperType -> *) (h1 :: AHyperType -> *).
Lens
  (Annotated a # h0)
  (Annotated a # h1)
  (h0 # Annotated a)
  (h1 # Annotated a)
annValue (h0 # Annotated a) -> f (h1 # Annotated a)
f (Ann (Const a
a) 'AHyperType h0 :# Annotated a
b) = (h0 # Annotated a) -> f (h1 # Annotated a)
f 'AHyperType h0 :# Annotated a
b forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (a :: AHyperType -> *) (h :: AHyperType).
a h -> (h :# Ann a) -> Ann a h
Ann (forall {k} a (b :: k). a -> Const a b
Const a
a)