module Data.Record.Field.Combinators
(
idL
, ( # )
, (#$ )
, (<.#>)
, (<#>)
, (<##>)
, (*#)
, (=*)
, (<=:)
, (<=~)
, onField
) where
import Data.Record.Field.Basic
import Data.Record.Label hiding ((=:))
import qualified Control.Category as C
import Control.Applicative
import Control.Monad
import "monads-fd" Control.Monad.State.Class
cantSet :: String -> a
cantSet n = error $ n ++ ": cannot set values."
idL :: a :-> a
idL = C.id
infixl 8 #
( # ) :: (Field a, Field b, Dst a ~ Src b) =>
a -> b -> Src a :-> Dst b
a # b = (field b) C.. (field a)
infixl 8 #$
(#$) :: (Field a) => a -> (Dst a -> b) -> Src a :-> b
ab #$ f = lens getter (cantSet "(#$)")
where getter a = f . getL (field ab) $ a
infixl 7 <.#>
(<.#>) :: (Functor f, Field a) => f (Src a) -> a -> f (Dst a)
f <.#> a = fmap (.# a) f
infixr 9 <#>
(<#>) :: (Applicative f, Field a, Field b, Dst a ~ f (Src b)) =>
a -> b -> Src a :-> f (Dst b)
ab <#> bc = lens getter setter
where getter = (fmap $ getL (field bc)) . getL (field ab)
setter fc = modL (field ab) $
\fb -> flip (setL (field bc)) <$> fb <*> fc
infixr 9 <##>
(<##>) :: (Monad m, Field a, Field b,
Dst a ~ m (Src b), Dst b ~ m c) =>
a -> b -> Src a :-> m c
ab <##> bc = lens getter setter
where getter = getL (field ab) >=> getL (field bc)
setter mc = modL (field ab) $
\mb -> do b <- mb
return $ setL (field bc) mc b
infixl 7 *#
(*#) :: (Field b) => [Src b] -> [b] -> [Dst b]
rs *# as = zipWith (.#) rs as
infixl 8 =*
(=*) :: (Field a) => a -> [Dst a] -> [Src a :-> Src a]
a =* vs = [ a =: v | v <- vs ]
infix 3 <=:
(<=:) :: (MonadState (Src a) m, Field a) =>
a -> Dst a -> m ()
a <=: v = modify (.# a =: v)
infix 3 <=~
(<=~) :: (MonadState (Src a) m, Field a) =>
a -> (Dst a -> Dst a) -> m ()
a <=~ f = modify (.# a =~ f)
infixl 0 `onField`
onField :: (Field a) => (Dst a -> Dst a -> t) -> a -> Src a -> Src a -> t
onField f a r1 r2 = f (r1.#a) (r2.#a)