module Data.Record.Label
(
Getter
, Setter
, Modifier
, Point
, (:->) (Label)
, label
, get, set, mod
, (:<->:) (..)
, (<->)
, Iso (..)
, for
, getM, setM, modM, (=:)
, module Data.Record.Label.TH
)
where
import Prelude hiding ((.), id, mod)
import Control.Applicative
import Control.Category
import Control.Monad.State hiding (get)
import Data.Record.Label.TH
type Getter f o = f -> o
type Setter f i = i -> f -> f
type Modifier f i o = (o -> i) -> f -> f
data Point f i o = Point
{ _get :: Getter f o
, _set :: Setter f i
}
_mod :: Point f i o -> (o -> i) -> f -> f
_mod l f a = _set l (f (_get l a)) a
newtype (f :-> a) = Label { unLabel :: Point f a a }
label :: Getter f a -> Setter f a -> f :-> a
label g s = Label (Point g s)
get :: (f :-> a) -> f -> a
get = _get . unLabel
set :: (f :-> a) -> a -> f -> f
set = _set . unLabel
mod :: (f :-> a) -> (a -> a) -> f -> f
mod = _mod . unLabel
instance Category (:->) where
id = Label (Point id const)
(Label a) . (Label b) = Label (Point (_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 (\f -> _get a f (_get b f)) (\r -> _set b r . _set a r)
class Iso f where
iso :: a :<->: b -> f a -> f b
iso (Lens a b) = osi (b <-> a)
osi :: a :<->: b -> f b -> f a
osi (Lens a b) = iso (b <-> a)
data a :<->: b = Lens { fw :: a -> b, bw :: b -> a }
infixr 7 <->
(<->) :: (a -> b) -> (b -> a) -> a :<->: b
a <-> b = Lens a b
instance Category (:<->:) where
id = Lens id id
(Lens a b) . (Lens c d) = Lens (a . c) (d . b)
instance Iso ((:->) i) where
iso l (Label a) = Label (Point (fw l . _get a) (_set a . bw l))
instance Iso ((:<->:) i) where
iso = (.)
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 (unLabel b)
getM :: MonadState s m => s :-> b -> m b
getM = gets . get
setM :: MonadState s m => s :-> b -> b -> m ()
setM l = modify . set l
infixr 7 =:
(=:) :: MonadState s m => s :-> b -> b -> m ()
(=:) = setM
modM :: MonadState s m => s :-> b -> (b -> b) -> m ()
modM l = modify . mod l