Compose.hs

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

-- | Compose two 'HyperType's.
--
-- Inspired by [hyperfunctions' @Category@ instance](http://hackage.haskell.org/package/hyperfunctions-0/docs/Control-Monad-Hyper.html).
module Hyper.Combinator.Compose
    ( HCompose (..)
    , _HCompose
    , W_HCompose (..)
    , HComposeConstraint1
    , decompose
    , decompose'
    , hcomposed
    ) where

import Control.Lens (Iso', Optic, Profunctor, iso)
import Data.Constraint (withDict)
import Hyper.Class.Apply (HApply (..))
import Hyper.Class.Foldable (HFoldable (..))
import Hyper.Class.Functor (HFunctor (..), hiso)
import Hyper.Class.Nodes (HNodes (..), HWitness (..), (#>))
import Hyper.Class.Pointed (HPointed (..))
import Hyper.Class.Recursive (RNodes (..), RTraversable, Recursively (..))
import Hyper.Class.Traversable (ContainedH (..), HTraversable (..), htraverse)
import Hyper.Class.ZipMatch (ZipMatch (..))
import Hyper.Type (GetHyperType, HyperType, type (#))
import Hyper.Type.Pure (Pure, _Pure)
import Text.PrettyPrint.HughesPJClass (Pretty (..))

import Hyper.Internal.Prelude

-- | Compose two 'HyperType's as an external and internal layer
newtype HCompose a b h = HCompose {getHCompose :: a # HCompose b (GetHyperType h)}
    deriving stock (Generic)

makeCommonInstances [''HCompose]

instance Pretty (a # HCompose b (GetHyperType h)) => Pretty (HCompose a b h) where
    pPrintPrec level prec (HCompose x) = pPrintPrec level prec x

-- | An 'Control.Lens.Iso' for the 'HCompose' @newtype@
{-# INLINE _HCompose #-}
_HCompose ::
    Iso
        (HCompose a0 b0 # h0)
        (HCompose a1 b1 # h1)
        (a0 # HCompose b0 h0)
        (a1 # HCompose b1 h1)
_HCompose = iso getHCompose HCompose

{-# ANN module "HLint: ignore Use camelCase" #-}
data W_HCompose a b n where
    W_HCompose :: HWitness a a0 -> HWitness b b0 -> W_HCompose a b (HCompose a0 b0)

instance (HNodes a, HNodes b) => HNodes (HCompose a b) where
    type HNodesConstraint (HCompose a b) c = HNodesConstraint a (HComposeConstraint0 c b)
    type HWitnessType (HCompose a b) = W_HCompose a b
    {-# INLINE hLiftConstraint #-}
    hLiftConstraint (HWitness (W_HCompose w0 w1)) p r =
        hLiftConstraint w0 (p0 p) $
            hLiftConstraint w1 (p1 p w0) (withDict (d0 p w0 w1) r)
                \\ hComposeConstraint0 p (Proxy @b) w0
        where
            p0 :: Proxy c -> Proxy (HComposeConstraint0 c b)
            p0 _ = Proxy
            p1 :: proxy0 c -> proxy1 a0 -> Proxy (HComposeConstraint1 c a0)
            p1 _ _ = Proxy
            d0 ::
                HComposeConstraint1 c a0 b0 =>
                Proxy c ->
                HWitness a a0 ->
                HWitness b b0 ->
                Dict (c (HCompose a0 b0))
            d0 _ _ _ = hComposeConstraint1

class HComposeConstraint0 (c :: HyperType -> Constraint) (b :: HyperType) (h0 :: HyperType) where
    hComposeConstraint0 ::
        proxy0 c ->
        proxy1 b ->
        proxy2 h0 ->
        Dict (HNodesConstraint b (HComposeConstraint1 c h0))

instance HNodesConstraint b (HComposeConstraint1 c h0) => HComposeConstraint0 c b h0 where
    {-# INLINE hComposeConstraint0 #-}
    hComposeConstraint0 _ _ _ = Dict

class HComposeConstraint1 (c :: HyperType -> Constraint) (h0 :: HyperType) (h1 :: HyperType) where
    hComposeConstraint1 :: Dict (c (HCompose h0 h1))

instance c (HCompose h0 h1) => HComposeConstraint1 c h0 h1 where
    {-# INLINE hComposeConstraint1 #-}
    hComposeConstraint1 = Dict

instance
    (HPointed a, HPointed b) =>
    HPointed (HCompose a b)
    where
    {-# INLINE hpure #-}
    hpure x =
        _HCompose
            # hpure
                ( \wa ->
                    _HCompose # hpure (\wb -> _HCompose # x (HWitness (W_HCompose wa wb)))
                )

instance (HFunctor a, HFunctor b) => HFunctor (HCompose a b) where
    {-# INLINE hmap #-}
    hmap f =
        _HCompose
            %~ hmap
                ( \w0 ->
                    _HCompose %~ hmap (\w1 -> _HCompose %~ f (HWitness (W_HCompose w0 w1)))
                )

instance (HApply a, HApply b) => HApply (HCompose a b) where
    {-# INLINE hzip #-}
    hzip (HCompose a0) =
        _HCompose
            %~ hmap
                ( \_ (HCompose b0 :*: HCompose b1) ->
                    _HCompose
                        # hmap
                            ( \_ (HCompose i0 :*: HCompose i1) ->
                                _HCompose # (i0 :*: i1)
                            )
                            (hzip b0 b1)
                )
            . hzip a0

instance (HFoldable a, HFoldable b) => HFoldable (HCompose a b) where
    {-# INLINE hfoldMap #-}
    hfoldMap f =
        hfoldMap
            ( \w0 ->
                hfoldMap (\w1 -> f (HWitness (W_HCompose w0 w1)) . (^. _HCompose)) . (^. _HCompose)
            )
            . (^. _HCompose)

instance (HTraversable a, HTraversable b) => HTraversable (HCompose a b) where
    {-# INLINE hsequence #-}
    hsequence =
        _HCompose
            ( hsequence
                . hmap (const (MkContainedH . _HCompose (htraverse (const (_HCompose runContainedH)))))
            )

instance
    (ZipMatch h0, ZipMatch h1, HTraversable h0, HFunctor h1) =>
    ZipMatch (HCompose h0 h1)
    where
    {-# INLINE zipMatch #-}
    zipMatch (HCompose x) (HCompose y) =
        zipMatch x y
            >>= htraverse
                ( \_ (HCompose cx :*: HCompose cy) ->
                    zipMatch cx cy
                        <&> (_HCompose #) . hmap (\_ (HCompose bx :*: HCompose by) -> bx :*: by & HCompose)
                )
            <&> (_HCompose #)

instance
    ( HNodes a
    , HNodes b
    , HNodesConstraint a (HComposeConstraint0 RNodes b)
    ) =>
    RNodes (HCompose a b)

instance
    ( HNodes h0
    , HNodes h1
    , c (HCompose h0 h1)
    , HNodesConstraint h0 (HComposeConstraint0 RNodes h1)
    , HNodesConstraint h0 (HComposeConstraint0 (Recursively c) h1)
    ) =>
    Recursively c (HCompose h0 h1)

instance
    ( HTraversable a
    , HTraversable b
    , HNodesConstraint a (HComposeConstraint0 RNodes b)
    , HNodesConstraint a (HComposeConstraint0 (Recursively HFunctor) b)
    , HNodesConstraint a (HComposeConstraint0 (Recursively HFoldable) b)
    , HNodesConstraint a (HComposeConstraint0 RTraversable b)
    ) =>
    RTraversable (HCompose a b)

hcomposed ::
    (Profunctor p, Functor f) =>
    Optic
        p
        f
        (a0 # HCompose b0 c0)
        (a1 # HCompose b1 c1)
        (HCompose a2 b2 # c2)
        (HCompose a3 b3 # c3) ->
    Optic
        p
        f
        (HCompose a0 b0 # c0)
        (HCompose a1 b1 # c1)
        (a2 # HCompose b2 c2)
        (a3 # HCompose b3 c3)
hcomposed f = _HCompose . f . _HCompose

-- | Inject Pure between two hypertypes.
decompose ::
    forall a0 b0 a1 b1.
    (Recursively HFunctor a0, Recursively HFunctor b0, Recursively HFunctor a1, Recursively HFunctor b1) =>
    Iso (Pure # HCompose a0 b0) (Pure # HCompose a1 b1) (a0 # b0) (a1 # b1)
decompose = iso (^. decompose') (decompose' #)

decompose' ::
    forall a b.
    (Recursively HFunctor a, Recursively HFunctor b) =>
    Iso' (Pure # HCompose a b) (a # b)
decompose' =
    _Pure
        . _HCompose
        . hiso
            ( Proxy @(Recursively HFunctor) #>
                _HCompose
                    . hiso (Proxy @(Recursively HFunctor) #> _HCompose . decompose')
                    \\ recursively (Proxy @(HFunctor b))
            )
        \\ recursively (Proxy @(HFunctor a))