Mutable references with attached lenses for fmap-like mapping

lensref.hs

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE TemplateHaskell           #-}

module Lib where

import           Control.Lens
import           Data.IORef

atomicModifyIORef_ :: IORef a -> (a -> a) -> IO ()
atomicModifyIORef_ ref f = atomicModifyIORef ref (\a -> (f a, ()))

data RefLens a = forall b . RefLens (IORef b) (Lens' b a)

newRefLens :: a -> IO (RefLens a)
newRefLens a = do
    ref <- newIORef a
    return (RefLens ref id)

readRefLens :: RefLens a -> IO a
readRefLens (RefLens b l) = view l <$> readIORef b

writeRefLens :: RefLens a -> a -> IO ()
writeRefLens (RefLens b l) a = atomicModifyIORef_ b (set l a)

modifyRefLens :: RefLens a -> (a -> (a, b)) -> IO b
modifyRefLens (RefLens b l) f =
    atomicModifyIORef' b $
      \b' -> let (a, ret) = f (b' ^. l) in (set l a b', ret)

modifyRefLens_ :: RefLens a -> (a -> a) -> IO ()
modifyRefLens_ (RefLens b l) f = atomicModifyIORef_ b (over l f)

-- | Similar to
--
--     fmap :: (a -> b) -> f a -> f b
--
lensMap :: Lens' a b -> RefLens a -> RefLens b
lensMap  l' (RefLens ref l) = RefLens ref (l . l')

--------------------------------------------------------------------------------

data Point = Point { _x :: Double, _y :: Double } deriving (Show)
makeLenses ''Point

data State = State
  { _p1 :: Point
  , _p2 :: Point
  , _p3 :: Point
  } deriving (Show)
makeLenses ''State

--------------------------------------------------------------------------------

main :: IO ()
main = do
    ref0 <- newRefLens (State (Point 1 2) (Point 3 4) (Point 5 6))
    readRefLens ref0 >>= print
    let ref1 = lensMap (p1 . x) ref0
    readRefLens ref1 >>= print
    modifyRefLens_ ref1 (+ 100)
    readRefLens ref0 >>= print
    readRefLens ref1 >>= print