module Data.Record.Label
(
Point (Point)
, (:->) (Lens)
, lens
, getL, setL, modL
, fmapL
, (:<->:) (..)
, Iso (..)
, lmap
, for
, getM, setM, modM, (=:)
, askM, localM
, module Data.Record.Label.TH
)
where
import Prelude hiding ((.), id)
import Control.Applicative
import Control.Category
import Control.Monad.State
import Control.Monad.Reader
import Data.Record.Label.TH
data Point f i o = Point
{ _get :: f -> o
, _set :: i -> f -> f
}
_mod :: Point f i o -> (o -> i) -> f -> f
_mod l f a = _set l (f (_get l a)) a
newtype (f :-> a) = Lens { unLens :: Point f a a }
lens :: (f -> a) -> (a -> f -> f) -> f :-> a
lens g s = Lens (Point g s)
getL :: (f :-> a) -> f -> a
getL = _get . unLens
setL :: (f :-> a) -> a -> f -> f
setL = _set . unLens
modL :: (f :-> a) -> (a -> a) -> f -> f
modL = _mod . unLens
instance Category (:->) where
id = lens id const
Lens a . Lens b = lens (_get a . _get b) (_mod b . _set a)
instance Functor (Point f i) where
fmap f x = Point (f . _get x) (_set x)
instance Applicative (Point f i) where
pure a = Point (const a) (const id)
a <*> b = Point (_get a <*> _get b) (\r -> _set b r . _set a r)
fmapL :: Applicative f => (a :-> b) -> f a :-> f b
fmapL l = lens (fmap (getL l)) (\x f -> setL l <$> x <*> f)
class Iso f where
(%) :: a :<->: b -> f a -> f b
infixr 7 :<->:
data a :<->: b = (:<->:) { fw :: a -> b, bw :: b -> a }
instance Category (:<->:) where
id = id :<->: id
(a :<->: b) . (c :<->: d) = a . c :<->: d . b
infixr 8 %
instance Iso ((:->) i) where
l % Lens a = lens (fw l . _get a) (_set a . bw l)
instance Iso ((:<->:) i) where
(%) = (.)
lmap :: Functor f => (a :<->: b) -> f a :<->: f b
lmap l = let a :<->: b = l in fmap a :<->: fmap b
dimap :: (o' -> o) -> (i -> i') -> Point f i' o' -> Point f i o
dimap f g l = Point (f . _get l) (_set l . g)
for :: (i -> o) -> (f :-> o) -> Point f i o
for a b = dimap id a (unLens b)
getM :: MonadState s m => s :-> b -> m b
getM = gets . getL
setM :: MonadState s m => s :-> b -> b -> m ()
setM l = modify . setL l
infixr 7 =:
(=:) :: MonadState s m => s :-> b -> b -> m ()
(=:) = setM
modM :: MonadState s m => s :-> b -> (b -> b) -> m ()
modM l = modify . modL l
askM :: MonadReader r m => (r :-> b) -> m b
askM = asks . getL
localM :: MonadReader r m => (r :-> b) -> (b -> b) -> m a -> m a
localM l f = local (modL l f)