Reader1.hs

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

module Data.Reader.Reader1(
  Reader1T(..)
, Reader1
, Reader1Lens
, reader1
, reader1Lens
, reader1'
, star1
, kleisli1
, liftReader1
, pureReader1
, homReader1
) where

import Control.Applicative
    ( Applicative((<*>), pure), Alternative((<|>), empty) )
import Control.Arrow ( Kleisli )
import Control.Category ( Category(..) )
import Control.Lens
    ( LensLike, view, iso, over, _Wrapped, Iso, Rewrapped, Wrapped(..) )
import Control.Monad
    ( Monad(return, (>>=)), 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.Cont.Class ( MonadCont(..) )
import Control.Monad.IO.Class ( MonadIO(..) )
import Control.Monad.Morph
    ( MFunctor(..), MMonad(..) )
import Control.Monad.Trans.Class ( MonadTrans(..) )
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 ( Star )
import Data.Reader.Reader
    ( pureReader,
      homReader,
      reader,
      readerLens,
      star,
      kleisli,
      reader',
      liftReader )
import Data.Semigroup ( Semigroup((<>)) )

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

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

type Reader1 a b =
  Reader1T a Identity b

reader1 ::
  Iso
    (Reader1 a b)
    (Reader1 a' b')
    (a -> b)
    (a' -> b')
reader1 =
  reader

type Reader1Lens f s t a b =
  Reader1T a f b
  -> Reader1T s f t

reader1Lens ::
  Iso
    (LensLike f s t a b)
    (LensLike f' s' t' a' b')
    (Reader1Lens f s t a b)
    (Reader1Lens f' s' t' a' b')
reader1Lens =
  readerLens

reader1' ::
  Iso
    (Reader.ReaderT a f b)
    (Reader.ReaderT a' f' b')
    (Reader1T a f b)
    (Reader1T a' f' b')
reader1' =
  reader'

star1 ::
  Iso
    (Star f a b)
    (Star f' a' b')
    (Reader1T a f b)
    (Reader1T a' f' b')
star1 =
  star

kleisli1 ::
  Iso
    (Kleisli f a b)
    (Kleisli f' a' b')
    (Reader1T a f b)
    (Reader1T a' f' b')
kleisli1 =
  kleisli

liftReader1 ::
  Iso
    (Reader1T a f b)
    (Reader1T a' f' b')
    (Reader1 a (f b))
    (Reader1 a' (f' b'))
liftReader1 =
  liftReader

pureReader1 ::
  Applicative f =>
  Reader1 a b
  -> Reader1T a f b
pureReader1 =
  pureReader

homReader1 ::
  (forall x. f x -> g x)
  -> Reader1T a f b
  -> Reader1T a g b
homReader1 =
  homReader

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

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

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

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

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

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

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

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

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

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

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

instance MonadTrans (Reader1T a) where
  lift =
    Reader1T . pure

instance MFunctor (Reader1T a) where
  hoist f =
    over _Wrapped (f .)

instance MMonad (Reader1T a) where
  embed f =
    over _Wrapped (\g a -> view _Wrapped (f (g a)) a)

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

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

instance MonadState a f => MonadState a (Reader1T a f) where
  get =
    lift get
  put =
    lift . put
  state =
    lift . state

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

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

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

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

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

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