Reader3.hs

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

module Data.Reader.Reader3(
  Reader3T(..)
, Reader3
) where

import Control.Applicative
    ( Applicative(pure), liftA2 )
import Control.Category ( Category(..) )
import Control.Lens
    ( iso, over, _Wrapped, Rewrapped, Wrapped(..) )
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.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

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))