Reader2.hs

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

module Data.Reader.Reader2(
  Reader2T(..)
, Reader2
, Reader2Lens
, reader2
, reader2Lens
, reader2'
, star2
, kleisli2
, liftReader2
, pureReader2
, homReader2
) where

import Control.Applicative
    ( Applicative((<*>), pure), Alternative((<|>), empty) )
import Control.Arrow
    ( ArrowZero(..),
      ArrowPlus(..),
      Arrow(first, second, arr),
      (>>>),
      ArrowApply(..),
      ArrowChoice(..),
      ArrowLoop(..),
      Kleisli )
import Control.Category ( Category(..) )
import Control.Lens
    ( LensLike, view, iso, over, _Wrapped, Iso, Rewrapped, Wrapped(..) )
import Control.Monad
    ( Monad(return, (>>=)), sequence, MonadPlus(..), (>=>) )
import qualified Control.Monad.Reader as Reader( ReaderT )
import Control.Monad.Reader.Class ( MonadReader )
import qualified Control.Monad.Reader.Class as Reader ( MonadReader(..) )
import Control.Monad.State.Class ( MonadState(..) )
import Control.Monad.Writer.Class ( MonadWriter(..) )
import Control.Monad.Error.Class ( MonadError(..) )
import Control.Monad.Fix ( MonadFix(..) )
import Control.Monad.Cont.Class ( MonadCont(..) )
import Control.Monad.IO.Class ( MonadIO(..) )
import Data.Distributive ( Distributive(distribute, collect) )
import Data.Either ( Either(Right, Left), either )
import Data.Functor ( Functor(fmap) )
import Data.Functor.Alt ( Alt((<!>)) )
import Data.Functor.Apply ( Apply((<.>), liftF2) )
import Data.Functor.Bind ( Bind((>>-)), (->-) )
import Data.Functor.Contravariant ( Contravariant(contramap) )
import Data.Functor.Contravariant.Divisible
    ( Decidable(..), Divisible(..) )
import Data.Functor.Identity ( Identity(..) )
import Data.Functor.Plus ( Plus(..) )
import Data.Monoid(Monoid(mempty))
import Data.Profunctor
    ( Choice(..),
      Profunctor(dimap),
      Star,
      Closed(..),
      Costrong(unfirst),
      Strong(..),
      Mapping(..),
      Cochoice(unright) )
import Data.Profunctor.Traversing ( Traversing(..) )
import Data.Reader.Reader
    ( pureReader,
      homReader,
      reader,
      readerLens,
      star,
      kleisli,
      reader',
      liftReader )
import Data.Semigroup ( Semigroup((<>)) )
import Data.Semigroupoid ( Semigroupoid(..) )
import Data.Traversable ( Traversable(traverse) )
import Data.Tuple ( fst, snd, uncurry )

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

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

type Reader2 a b =
  Reader2T Identity a b

reader2 ::
  Iso
    (Reader2 a b)
    (Reader2 a' b')
    (a -> b)
    (a' -> b')
reader2 =
  reader

reader2' ::
  Iso
    (Reader.ReaderT a f b)
    (Reader.ReaderT a' f' b')
    (Reader2T f a b)
    (Reader2T f' a' b')
reader2' =
  reader'

type Reader2Lens f s t a b =
  Reader2T f a b
  -> Reader2T f s t

reader2Lens ::
  Iso
    (LensLike f s t a b)
    (LensLike f' s' t' a' b')
    (Reader2Lens f s t a b)
    (Reader2Lens f' s' t' a' b')
reader2Lens =
  readerLens

star2 ::
  Iso
    (Star f a b)
    (Star f' a' b')
    (Reader2T f a b)
    (Reader2T f' a' b')
star2 =
  star

kleisli2 ::
  Iso
    (Kleisli f a b)
    (Kleisli f' a' b')
    (Reader2T f a b)
    (Reader2T f' a' b')
kleisli2 =
  kleisli

liftReader2 ::
  Iso
    (Reader2T f a b)
    (Reader2T f' a' b')
    (Reader2 a (f b))
    (Reader2 a' (f' b'))
liftReader2 =
  liftReader

pureReader2 ::
  Applicative f =>
  Reader2 a b
  -> Reader2T f a b
pureReader2 =
  pureReader

homReader2 ::
  (forall x. f x -> g x)
  -> Reader2T f a b
  -> Reader2T g a b
homReader2 =
  homReader

instance Functor f => Functor (Reader2T f a) where
  fmap f (Reader2T g) =
    Reader2T (fmap (fmap f) g)

instance Apply f => Apply (Reader2T f a) where
  Reader2T f <.> Reader2T a =
    Reader2T (\x -> f x <.> a x)

instance Applicative f => Applicative (Reader2T f a) where
  pure =
    Reader2T . pure . pure
  Reader2T f <*> Reader2T a =
    Reader2T (\x -> f x <*> a x)

instance Bind f => Bind (Reader2T f a) where
  Reader2T a >>- f =
    Reader2T (\x -> a x >>- \l -> view _Wrapped (f l) x)

instance Monad f => Monad (Reader2T f a) where
  return =
    pure
  Reader2T a >>= f =
    Reader2T (\x -> a x >>= \l -> view _Wrapped (f l) x)

instance Alt f => Alt (Reader2T f a) where
  Reader2T x <!> Reader2T y =
    Reader2T (\a -> x a <!> y a)

instance Alternative f => Alternative (Reader2T f a) where
  Reader2T x <|> Reader2T y =
    Reader2T (\a -> x a <|> y a)
  empty =
    Reader2T (pure empty)

instance (Alt f, Alternative f) => Plus (Reader2T f a) where
  zero =
    empty

instance MonadPlus f => MonadPlus (Reader2T f a) where
  mzero =
    empty
  mplus =
    (<|>)

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

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

instance Monad f => MonadReader a (Reader2T f a) where
  ask =
    Reader2T pure
  local f =
    over _Wrapped (. f)
  reader f =
    Reader2T (pure . f)

instance MonadWriter a f => MonadWriter a (Reader2T f a) where
  writer =
    Reader2T . pure . writer
  tell =
    Reader2T . pure . tell
  listen =
    over _Wrapped (listen .)
  pass =
    over _Wrapped (pass .)

instance MonadState a f => MonadState a (Reader2T f a) where
  get =
    (Reader2T . pure) get
  put =
    Reader2T . pure . put
  state =
    Reader2T . pure . state

instance MonadError a f => MonadError a (Reader2T f a) where
  throwError =
    Reader2T . pure . throwError
  catchError m h =
    Reader2T (\r -> catchError (view _Wrapped m r) (\e -> view _Wrapped (h e) r))

instance MonadCont f => MonadCont (Reader2T f a) where
  callCC f =
    Reader2T (\r -> callCC (\ c -> view _Wrapped (f (Reader2T . pure . c)) r))

instance MonadIO f => MonadIO (Reader2T f a) where
  liftIO =
    Reader2T . pure . liftIO

instance Functor f => Profunctor (Reader2T f) where
  dimap f g =
    over _Wrapped (\k -> fmap g . k . f)

instance Functor f => Strong (Reader2T f) where
  first' =
    over _Wrapped (\k (a, c) -> fmap (, c) (k a))
  second' =
    over _Wrapped (\k (c, a) -> fmap (c ,) (k a))

instance Applicative f => Choice (Reader2T f) where
  left' =
    over _Wrapped (\k -> either (fmap Left . k) (pure . Right))
  right' =
    over _Wrapped (\k -> either (pure . Left) (fmap Right . k))

instance Applicative f => Traversing (Reader2T f) where
  traverse' =
    over _Wrapped traverse
  wander =
    over _Wrapped

instance Distributive f => Closed (Reader2T f) where
  closed =
    over _Wrapped (\k x -> distribute (k . x))

instance (Applicative f, Distributive f) => Mapping (Reader2T f) where
  map' =
    over _Wrapped collect
  roam f =
    over _Wrapped (\k s -> fmap (`f` s) (distribute k))

instance MonadFix f => Costrong (Reader2T f) where
  unfirst =
    over _Wrapped (\f a -> fmap fst (mfix (\y -> f (a, snd y))))

instance Traversable f => Cochoice (Reader2T f) where
  unright =
    over _Wrapped (\f ->
      let go = either (go . Left) id . sequence . f
      in  go . Right)

instance Bind f => Semigroupoid (Reader2T f) where
  o (Reader2T f) (Reader2T g) =
    Reader2T (g ->- f)

instance Monad f => Category (Reader2T f) where
  Reader2T f . Reader2T g =
    Reader2T (g >=> f)
  id =
    Reader2T pure

instance Monad f => Arrow (Reader2T f) where
  arr f =
    Reader2T (pure . f)
  first =
    over _Wrapped (\f (b, d) -> fmap (, d) (f b))
  second =
    over _Wrapped (\f (d, b) -> fmap (d ,) (f b))

instance MonadFix f => ArrowLoop (Reader2T f) where
  loop =
    unfirst

instance Monad f => ArrowApply (Reader2T f) where
  app =
    Reader2T (uncurry (view _Wrapped))

instance Monad f => ArrowChoice (Reader2T f) where
  left f =
    f +++ arr id
  right f =
    arr id +++ f
  f +++ g =
    (f >>> arr Left) ||| (g >>> arr Right)
  Reader2T f ||| Reader2T g =
    Reader2T (either f g)

instance MonadPlus f => ArrowZero (Reader2T f) where
    zeroArrow = Reader2T (pure mzero)

instance MonadPlus f => ArrowPlus (Reader2T f) where
    Reader2T f <+> Reader2T g = Reader2T (\x -> f x `mplus` g x)

instance Contravariant f => Contravariant (Reader2T f a) where
  contramap f =
    over _Wrapped (fmap (contramap f))

instance Divisible f => Divisible (Reader2T f a) where
  divide k (Reader2T f) (Reader2T g) =
    Reader2T (liftF2 (divide k) f g)
  conquer =
    Reader2T (pure conquer)

instance Decidable f => Decidable (Reader2T f a) where
  lose =
    Reader2T . pure . lose
  choose k (Reader2T f) (Reader2T g) =
    Reader2T (liftF2 (choose k) f g)