MLens.hs

type MLens m s t a b = forall f. Traversable f => (a -> Compose m f b) -> s -> Compose m f t

mlens :: Monad m => (s -> m a) -> (s -> b -> m t) -> MLens m s t a b
mlens get set h s = Compose $ get s >>= getCompose . h >>= traverse (set s)

type MGetting m r s a = (a -> Compose m (Const r) a) -> s -> Compose m (Const r) s

mview :: Applicative m => MGetting m a s a -> s -> m a
mview l s = fmap getConst . getCompose $ l (\a -> Compose (pure (Const a))) s

type MSetter m s t a b = (a -> Compose m Identity b) -> s -> Compose m Identity t

mover :: Functor m => MSetter m s t a b -> (a -> m b) -> s -> m t
mover l f s = fmap runIdentity . getCompose $ l (Compose . fmap Identity . f) s

mset :: Applicative m => MSetter m s t a b -> b -> s -> m t
mset l b = mover l (const $ pure b)

ref :: MonadIO m => MLens m (IORef a) (IORef a) a a
ref = mlens (liftIO . readIORef) (\i x -> liftIO (writeIORef i x) >> pure i)