Search code examples
haskelllenseshaskell-optics

Is there a van Laarhoven optic based on the Monad typeclass?


As I understand it, each van Laarhoven optic type can be defined by a constraint on a type constructor:

type Lens      s t a b = forall f. Functor f     => (a -> f b) -> s -> f t
type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t
-- etc.

If we choose Monad as the constraint, does it form some kind of "optic" in a meaningful way?

type Something s t a b = forall f. Monad f => (a -> f b) -> s -> f t

My intuition is that the Monad constraint might be too restrictive to get any value out of a structure like this: since the Const functor is not a Monad, we can't do the trick of specializing f to Const in order to derive a view-like function. Still, we can do some things with this Something type; it's just not clear to me if we can do anything particularly useful with it.

The reason I'm curious is because the type of a van Laarhoven optic is suspiciously similar to the type of a function that modifies a "mutable reference" type like IORef. For example, we can easily implement

modifyIORefM :: MonadIO m => IORef a -> (a -> m a) -> () -> m ()

which, when partially-applied to an IORef, has the shape

type SomethingIO s t a b = forall f. MonadIO f => (a -> f b) -> s -> f t

where a = b and s = t = (). I'm not sure whether this is a meaningful or meaningless coincidence.


Solution

  • Practically speaking, such an optic is a slightly inconvenient Traversal.

    That's because, practically speaking, we use a Traversal:

    type Traversal s t a b = forall f. (Applicative f) => (a -> f b) -> (s -> f t)
    

    for two things. Getting a list of as from an s, which we can do with the Const functor:

    toListOf :: Traversal s t a b -> s -> [a]
    toListOf t = getConst . t (Const . (:[]))
    

    and replacing the as with bs to turn the s into a t. One method is to use the State functor, and ignoring issues with matching the counts of as and bs, we have:

    setListOf :: Traversal s t a b -> [b] -> s -> t
    setListOf t bs s = evalState (t (\a -> state (\(b:bs) -> (b, bs))) s) bs
    

    If we instead have an optic using a Monad constraint:

    type TraversalM s t a b = forall f. (Monad f) => (a -> f b) -> (s -> f t)
    

    we can still perform these two operations. Since State is a monad, the setListOf operation can use the same implementation:

    setListOfM :: Traversal s t a b -> [b] -> s -> t
    setListOfM t bs s = evalState (t (\a -> state (\(b:bs) -> (b, bs))) s) bs
    

    For toListOf, there's no Monad instance for Const [a], but we can use a Writer monad to extract the a values, as long as we have a dummy b value to make the type checker happy:

    toListOfM :: TraversalM s t a b -> b -> s -> [a]
    toListOfM t dummy_b s = execWriter (t (\a -> tell [a] >> pure dummy_b) s)
    

    or, since Haskell has bottom:

    toListOfM' :: TraversalM s t a b -> s -> [a]
    toListOfM' t s = execWriter (t (\a -> tell [a] >> pure undefined) s)
    

    Self-contained code:

    import Data.Functor.Const
    import Control.Monad.State
    import Control.Monad.Writer
    
    type Traversal s t a b = forall f. (Applicative f) => (a -> f b) -> (s -> f t)
    
    toListOf :: Traversal s t a b -> s -> [a]
    toListOf t = getConst . t (Const . (:[]))
    
    setListOf :: Traversal s t a b -> [b] -> s -> t
    setListOf t bs s = evalState (t (\a -> state (\(b:bs) -> (b, bs))) s) bs
    
    type TraversalM s t a b = forall f. (Monad f) => (a -> f b) -> (s -> f t)
    
    toListOfM :: TraversalM s t a b -> b -> s -> [a]
    toListOfM t dummy_b s = execWriter (t (\a -> tell [a] >> pure dummy_b) s)
    
    toListOfM' :: TraversalM s t a b -> s -> [a]
    toListOfM' t s = execWriter (t (\a -> tell [a] >> pure undefined) s)
    
    setListOfM :: TraversalM s t a b -> [b] -> s -> t
    setListOfM t bs s = evalState (t (\a -> state (\(b:bs) -> (b, bs))) s) bs
    
    listItems :: Traversal [a] [b] a b
    listItems = traverse
    
    listItemsM :: TraversalM [a] [b] a b
    listItemsM = mapM
    
    main = do
      -- as a getter
      print $ toListOf listItems [1,2,3]
      print $ toListOfM listItemsM 99 [1,2,3]  -- dummy value
      print $ toListOfM' listItemsM [1,2,3]    -- use undefined
      -- as a setter
      print $ setListOf listItems [4,5,6] [1,2,3]
      print $ setListOfM listItemsM [4,5,6] [1,2,3]