Monadic lens in Van Laarhoven representation

LensM.hs

{-# LANGUAGE RankNTypes #-}

module LensM where

import Control.Applicative (Const(..))
import Data.Functor.Identity (Identity(..))
import Data.Functor.Contravariant (Contravariant)
import Data.Functor.Compose

class Functor f => MfaAms f where
  mfaAms :: forall m a s. Monad m => m (f a) -> (a -> m s) -> m (f s)

instance MfaAms (Const a) where
  mfaAms mfa _ = Const . getConst <$> mfa

instance MfaAms Identity where
  mfaAms mfa ams = Identity <$> (mfa >>= (ams . runIdentity))

type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
type LensM m s t a b = forall f. MfaAms f => (a -> Compose m f b) -> s -> Compose m f t

over :: Lens s t a b -> (a -> b) -> s -> t
over l g s = runIdentity $ l (Identity . g) s

overM :: Monad m => LensM m s t a b -> (a -> m b) -> s -> m t
overM l g s = runIdentity <$> getCompose (l (Compose . fmap Identity . g) s)

view :: Lens s t a b -> s -> a
view l s = getConst $ l Const s

viewM :: Monad m => LensM m s t a b -> s -> m a
viewM l s = getConst <$> getCompose (l (Compose . pure . Const) s)

lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
lens getter setter f s = setter s <$> f (getter s)

lensM :: Monad m => (s -> m a) -> (s -> b -> m t) -> LensM m s t a b
lensM getter setter f s = Compose $ (getter s >>= getCompose . f) `mfaAms` setter s

set :: Lens s t a b -> b -> s -> t
set l b = over l (const b)

-- Lens is more general, then LensM:  
liftLens :: Monad m => Lens s t a b -> LensM m s t a b
liftLens l = l