Effectful composible lens

MLens.hs

import Control.Monad ((>=>))
import Data.Map (Map)
import qualified Data.Map as M
import GHC.Generics (Generic)
import Optics

data MLens m s a = MLens
  { mview :: s -> m a
  , mset  :: a -> s -> m s
  }


mover :: Monad m => MLens m s a -> (a -> m a) -> s -> m s
mover lens k s = do
  a <- mview lens s
  a' <- k a
  mset lens a' s

(>%>) :: Monad m => MLens m s u -> MLens m u a -> MLens m s a
lsu >%> lua = MLens
  { mview = mview lsu >=> mview lua
  , mset = \a s -> do
      u <- mview lsu s
      u' <- mset lua a u
      mset lsu u' s
  }

fromPrism :: (Is k An_AffineFold, Is k A_Setter) =>
  e -> Optic' k NoIx s a -> MLens (Either e) s a
fromPrism e p = MLens
  { mview = \s -> case preview p s of
                Nothing -> Left e
                Just a  -> Right a
  , mset = \a s -> case preview p s of
                Nothing -> Left e
                Just _  -> Right $ set p a s
  }

data Tree
  = Leaf
  | Branch (Map String Tree)
  deriving (Generic, Show)

data Err
  = NotLeaf
  | NotBranch
  | NoChild String
  deriving (Show)

leaf :: MLens (Either Err) Tree ()
leaf = fromPrism NotLeaf #_Leaf

branch :: MLens (Either Err) Tree (Map String Tree)
branch = fromPrism NotBranch #_Branch

subtree :: String -> MLens (Either Err) Tree Tree
subtree name = branch >%> fromPrism (NoChild name) (ix name)

tree :: Tree
tree = Branch (M.fromList [("a", Leaf), ("b", Branch mempty)])

{-
>>> mview (subtree "a") tree
Right Leaf

>>> mview (subtree "a" >%> leaf) tree
Right ()

>>> mview (subtree "b" >%> leaf) tree
Left NotLeaf

>>> mview (subtree "b" >%> branch) tree
Right (fromList [])

>>> mset (subtree "b" >%> branch) (M.fromList [("x", Leaf)]) tree
Right (Branch (fromList [("a",Leaf),("b",Branch (fromList [("x",Leaf)]))]))

>>> mset (subtree "a" >%> branch) (M.fromList [("x", Leaf)]) tree
Left NotBranch
-}