Reader3.hs

{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}

module Data.Reader.Reader3(
  Reader3T(..)
, Reader3
, Reader3Lens
, reader3
, reader3Lens
, reader3'
, star3
, kleisli3
, homReader3
) where
import Data.Type.Equality
import Control.Applicative
    ( Applicative(pure), liftA2 )
import Control.Arrow
    ( Kleisli(Kleisli) )
import Control.Category ( Category(..) )
import Control.Lens
    ( LensLike, view, iso, review, over, _Wrapped, Iso, Rewrapped, Wrapped(..) )
import qualified Control.Monad.Reader as Reader(ReaderT(ReaderT))
import Data.Either ( either )
import Data.Functor.Apply ( Apply(liftF2) )
import Data.Functor.Contravariant ( Contravariant(contramap) )
import Data.Functor.Contravariant.Divisible
    ( Decidable(..), Divisible(..) )
import Data.Functor.Identity ( Identity(..) )
import Data.Monoid(Monoid(mempty, mappend))
import Data.Profunctor
    ( Star(Star) )
import Data.Semigroup ( Semigroup((<>)) )
import Data.Void ( absurd )

newtype Reader3T f b a =
  Reader3T (a -> f b)

instance Reader3T f b a ~ x =>
  Rewrapped (Reader3T f' b' a') x
instance Wrapped (Reader3T f b a) where
  type Unwrapped (Reader3T f b a) =
    a
    -> f b
  _Wrapped' =
    iso (\(Reader3T x) -> x) Reader3T

type Reader3 a b =
  Reader3T Identity b a

reader3 ::
  Iso
    (Reader3 a b)
    (Reader3 a' b')
    (a -> b)
    (a' -> b')
reader3 =
  iso
    (\r -> runIdentity . view _Wrapped r)
    (\f -> review _Wrapped (Identity . f))

reader3' ::
  Iso
    (Reader.ReaderT a f b)
    (Reader.ReaderT a' f' b')
    (Reader3T f b a)
    (Reader3T f' b' a')
reader3' =
  iso
    (\(Reader.ReaderT k) -> Reader3T k)
    (\(Reader3T k) -> Reader.ReaderT k)

type Reader3Lens f s t a b =
  Reader3T f b a
  -> Reader3T f t s

reader3Lens ::
  Iso
    (LensLike f s t a b)
    (LensLike f' s' t' a' b')
    (Reader3Lens f s t a b)
    (Reader3Lens f' s' t' a' b')
reader3Lens =
  iso
    (\k f -> Reader3T (k (view _Wrapped f)))
    (\k f -> view _Wrapped (k (Reader3T f)))

star3 ::
  Iso
    (Star f a b)
    (Star f' a' b')
    (Reader3T f b a)
    (Reader3T f' b' a')
star3 =
  iso
    (\(Star k) -> Reader3T k)
    (\(Reader3T k) -> Star k)

kleisli3 ::
  Iso
    (Kleisli f a b)
    (Kleisli f' a' b')
    (Reader3T f b a)
    (Reader3T f' b' a')
kleisli3 =
  iso
    (\(Kleisli k) -> Reader3T k)
    (\(Reader3T k) -> Kleisli k)

homReader3 ::
  (forall x. f x -> g x)
  -> Reader3T f b a
  -> Reader3T g b a
homReader3 f =
  over _Wrapped (f .)

instance Contravariant (Reader3T f b) where
  contramap f =
    over _Wrapped (. f)

instance (Monoid b, Applicative f) => Divisible (Reader3T f b) where
  conquer =
    Reader3T (pure (pure mempty))
  divide k (Reader3T f) (Reader3T g) =
    Reader3T (\a -> let (b, c) = k a in liftA2 mappend (f b) (g c))

instance (Monoid b, Applicative f) => Decidable (Reader3T f b) where
  lose f =
    Reader3T (absurd . f)
  choose k (Reader3T f) (Reader3T g) =
    Reader3T (either f g . k)

instance (Semigroup b, Apply f) => Semigroup (Reader3T f b a) where
  Reader3T x <> Reader3T y =
    Reader3T (\a -> liftF2 (<>) (x a) (y a))

instance (Monoid b, Apply f, Applicative f) => Monoid (Reader3T f b a) where
  mempty =
    Reader3T (pure (pure mempty))