It's not an April's Fool day anymore, but don't take this seriously anyway. Tongue in cheek literate Haskell post on lenses (if interested in more serious ones, see Compiling Lenses, and Affine Traversal ).
A quote by metafunctor
Haskell is so advanced that a inordinate amount of literature is devoted to what in any standard language would be simple getters setters and loops.For loops are too much for me, but getters and setters we can do (in Haskell).
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
module MutatedLens where
import Control.Monad.ST
import Control.Lens
import Data.STRef
readSTRef
and writeSTRef
types are just right so we can pass them into lens
stref :: Lens (STRef s a) (ST s ()) (ST s a) a
stref = lens readSTRef writeSTRef
Unfortunately the type of view
is too restrictive, so we have to define a polymorphic version:
type GettingP r s t a b = (a -> Const r b) -> s -> Const r t
viewP :: GettingP a s t a b -> s -> a
viewP f s = getConst (f Const s)
Seems to work:
λ> :t viewP stref
viewP stref :: STRef s a -> ST s a
Let's define an imperative record, with mutable fields:
data ImpRecord s = ImpRecord
{ _intField :: STRef s Int
, _boolField :: STRef s Bool
}
and a "lens" into the first field:
intField :: Lens (ImpRecord s) (ST s ()) (STRef s Int) (ST s ())
intField = lens _intField (\_ -> id)
Now we can read and write through intField
and stref
. First we create a record, then read its field; after that we mutate the field and read it again:
program :: ST s (Int, Int)
program = do
iRef <- newSTRef 1
bRef <- newSTRef True
let mrecord = ImpRecord iRef bRef
i1 <- viewP (intField . stref) mrecord
set (intField . stref) 2 mrecord
i2 <- viewP (intField . stref) mrecord
pure (i1, i2)
If we run the program, it works:
λ> print (runST program)
(1,2)
The problem with this approach, is that we cannot drill through STRef s (STRef s) ...
.
Normal lens are in (->)
, but we can work in Kleisli (ST s)
too. So if we change all normal arrows to Kleisli (ST s)
(yet unwrapped), we can define STLens
:
type STLens z s t a b = forall f. MonadTransFunctor f =>
(ST z a -> f (ST z) b) -> s -> f (ST z) t
class MonadTransFunctor t where
tfmap :: Monad m => (a -> m b) -> t m a -> t m b
semibind :: Monad m => m a -> (a -> t m b) -> t m b
stlens :: (s -> ST z a) -> (s -> b -> ST z t) -> STLens z s t a b
stlens getter setter f s = tfmap (setter s) (f (getter s))
They compose:
infixr 8 `o`
o :: STLens z s t a b -> STLens z a b u v -> STLens z s t u v
o stab abuv f s = stab (\sta -> semibind sta $ \a -> abuv f a) s
and we can redefine stref'
:
stref' :: STLens z (STRef z a) (STRef z a) a a
stref' = stlens readSTRef (\s b -> writeSTRef s b >> pure s)
The following definitions for stview
and stover
are very similar to lens
counterparts.
newtype ConstT r (m :: * -> *) a = ConstT { getConstT :: m r }
instance MonadTransFunctor (ConstT r) where
tfmap f (ConstT r) = ConstT r
semibind m k = ConstT $ m >>= getConstT . k
type STGetting r z s a =
(ST z a -> ConstT r (ST z) a) -> s -> ConstT r (ST z) s
stview :: STGetting a z s a -> s -> ST z a
stview l s = getConstT (l ConstT s)
newtype IdentityT m a = IdentityT { runIdentityT :: m a }
type STSetter z s t a b =
(ST z a -> IdentityT (ST z) b) -> s -> IdentityT (ST z) t
instance MonadTransFunctor IdentityT where
tfmap f (IdentityT x) = IdentityT (x >>= f)
semibind m k = IdentityT (m >>= runIdentityT . k)
stover :: STSetter z s t a b -> (a -> ST z b) -> s -> ST z t
stover l f s = runIdentityT (l (\a -> IdentityT (a >>= f)) s)
stset :: STSetter z s t a b -> s -> b -> ST z t
stset l s b = stover l (\_ -> pure b) s
And we can now drill through multiple STRef
!
program2 :: ST s (Int, Int)
program2 = do
ref1 <- newSTRef 42
ref2 <- newSTRef ref1
i1 <- stview (stref' `o` stref') ref2
_ <- stset (stref' `o` stref') ref2 99
i2 <- stview (stref' `o` stref') ref2
pure (i1, i2)
λ> print (runST program2)
(42,99)
So, yet another example that Haskell is good imperative language. And we can have controlled effects in imperative language, you just need expressive enough language. :)
You can run this file with
stack --resolver=nightly-2017-03-01 ghci --ghci-options='-pgmL markdown-unlit'
λ> :l mutated-lenses.lhs
fetch the source from https://gist.github.com/phadej/a74f0d14749a352b9b3430c10bf35706