trying to see how haskell-lens can help; pointers welcome

ReadV.hs

{-# LANGUAGE
    FlexibleInstances
    , GeneralizedNewtypeDeriving
    , NoImplicitPrelude
    , OverloadedStrings
    , RankNTypes
#-}


module C12E.Validation.ReadV where
{-
    ( ReadV
    , ReadVT
    , checkReadVT
    , hoistReadVT
    , makeReadV
    , makeReadVT
    , passReadV
    , passReadVT
    , runReadVT
    ) where
-}


import Protolude hiding ((.), from)

import Control.Arrow (Kleisli(Kleisli), runKleisli)
import Control.Category (Category, (.), id)
import Control.Lens.Iso (Iso, from, iso)
import Control.Lens.Operators ((^.), (%~))
import Control.Lens.Type (Simple)
import Control.Lens.Getter (view)
import Control.Lens.Setter (over, mapped)
import Control.Lens.Wrapped
import Control.Monad.Except (ExceptT(ExceptT))
import Control.Monad.Reader
    (ReaderT(ReaderT), mapReaderT, withReaderT, runReaderT)
import Data.Functor.Compose (Compose(Compose), getCompose)
import Data.Functor.Identity (Identity)
import Data.Profunctor (Profunctor, Strong, first', lmap, rmap)

import C12E.Validation (Validation(Failure, Success), _Validation, _Either)


newtype ReadVT e m r a =
    ReadVT { unReadVT :: ReaderT r (Compose m (Validation e)) a }
    deriving (Functor, Applicative)

type ReadET e m r a = ReaderT r (ExceptT e m) a
type ReadKT e m r a = Kleisli (ExceptT e m) r a
type ReadV e r a = ReadVT e Identity r a


instance Monad m => Semigroup (ReadVT e m a a) where
  (<>) = (.)

instance Monad m => Monoid (ReadVT e m a a) where
  mempty = id
  mappend = (.)

instance Monad m => Category (ReadVT e m) where
    id = ReadVT . ReaderT $ Compose . pure . Success
    ra . rb = over readVTtoKT ((view readVTtoKT ra) .) rb

instance Functor m => Profunctor (ReadVT e m) where
    rmap = over (readVTtoET . mapped)
    lmap f = ReadVT . withReaderT f . unReadVT

instance Functor m => Strong (ReadVT e m) where
    first' rvt =
        ReadVT . ReaderT $ \(r, c) -> map (\a -> (a, c)) $ runReadVT' r rvt


makeReadVT :: (r -> m (Validation e a)) -> ReadVT e m r a
makeReadVT = ReadVT . ReaderT . map Compose

makeReadV :: Applicative m => (r -> (Validation e a)) -> ReadVT e m r a
makeReadV = makeReadVT . (map pure)

passReadVT :: (Applicative m, Semigroup e) => (r -> m a) -> ReadVT e m r a
passReadVT = makeReadVT . (map $ sequenceA . pure)

passReadV :: (Applicative m, Semigroup e) => (r -> a) -> ReadVT e m r a
passReadV = makeReadV . (map $ pure)

runReadVT :: ReadVT e m r a -> r -> m (Validation e a)
runReadVT rvt r = getCompose $ runReadVT' r rvt

checkReadVT
    :: (Applicative m, Semigroup e, Monoid e)
    => (r -> Maybe e)
    -> ReadVT e m r r
checkReadVT f =
    makeReadV $ \r -> maybe (pure r) (Failure . mappend mempty) (f r)

hoistReadVT :: (forall x. m x -> n x) -> ReadVT e m r a -> ReadVT e n r a
hoistReadVT f =
    ReadVT . ReaderT. map (Compose . f . getCompose) . runReaderT . unReadVT


runReadVT' :: r -> ReadVT e m r a -> Compose m (Validation e) a
runReadVT' r = flip runReaderT r . unReadVT

readVTtoET
    :: (Functor m, Functor m')
    => Iso (ReadVT e m r a) (ReadVT e' m' r' a')
           (ReadET e m r a) (ReadET e' m' r' a')
readVTtoET = iso toET fromET
    where
    toET = mapReaderT (ExceptT . map (view _Either) . getCompose) . unReadVT
    fromET = ReadVT . mapReaderT (Compose . map (view _Validation) . runExceptT)

readVTtoKT
    :: (Functor m, Functor m')
    => Iso (ReadVT e m r a) (ReadVT e' m' r' a')
           (ReadKT e m r a) (ReadKT e' m' r' a')
readVTtoKT = readVTtoET . iso toKT fromKT
    where
    toKT = Kleisli . runReaderT
    fromKT = ReaderT . runKleisli