Applicative van Laarhoven lenses

multilens.hs

{-# LANGUAGE RankNTypes #-}

import Control.Applicative
import Data.Functor.Identity

type MultiLens a b = forall f. Applicative f => (b -> f b) -> a -> f a

get :: MultiLens a b -> a -> [b]
get l = getConst . l (Const . pure)

modify :: MultiLens a b -> (b -> b) -> a -> a
modify l f = runIdentity . l (Identity . f)

set :: MultiLens a b -> b -> a -> a
set l = modify l . const


interactive :: Show b => MultiLens a b -> (b -> b) -> a -> IO a
interactive l f = l $ \b -> do
  putStr $ "Change " ++ show b ++ "? (y/n)"
  c <- getChar
  putStrLn ""
  if c == 'y' then return (f b) else return b


list :: MultiLens [a] a
list _ [] = pure []
list f (x:xs) = (:) <$> f x <*> list f xs