module Control.Monad.Record
( maybeAbort
, maybeAbortM
, lensGS
, MLens(..)
, (:-->)(..)
, getM
, setM
, modM
, getMAbort
, setMAbort
, modMAbort
, askM
, liftState
, liftSubState
, liftSubMaybeState
, (<:)
, (=:)
, ($:)
, (<::)
, (=::)
, ($::)
, (<<:)
, (<=:)
, (<$:)
, (<<::)
, (<->)
, (<:<)
, (>$<)
, (>$>)
, (>$$>)
, module Data.Label
, module Data.Label.Poly
, module Data.Label.Point
) where
import Prelude hiding ((.), id)
import Control.Category
import Control.Monad.Abort
import Control.Monad.Reader
import Control.Monad.State.Strict hiding (get, modify)
import qualified Control.Monad.State.Strict as S (modify)
import Control.Monad.Trans.Maybe
import Data.Label
import Data.Label.Poly (Lens)
import Data.Label.Point (Total)
maybeAbort :: (Monad m) => r -> Maybe a -> AbortT r m a
maybeAbort _ (Just x) = return x
maybeAbort r (Nothing) = abort r
maybeAbortM :: (MonadTrans t, Monad m, MonadAbort (t m)) => AbortResultType (t m) -> MaybeT m a -> t m a
maybeAbortM r m = do
x <- lift . runMaybeT $ m
case x of
(Just a) -> return a
(Nothing) -> abort r
lensGS :: (f -> a) -> (a -> f -> f) -> f :-> a
lensGS getter setter = lens getter (\modifier f -> setter (modifier (getter f)) f)
class MLens l a f where
type MLensA l a f
type MLensF l a f
toLens :: l f a -> (MLensF l a f) :-> Maybe (MLensA l a f)
instance MLens (Lens Total) (Maybe i -> Maybe i) (Maybe o -> Maybe o) where
type MLensA (Lens Total) (Maybe i -> Maybe i) (Maybe o -> Maybe o) = i
type MLensF (Lens Total) (Maybe i -> Maybe i) (Maybe o -> Maybe o) = Maybe o
toLens = id
instance MLens (:-->) a f where
type MLensA (:-->) a f = a
type MLensF (:-->) a f = f
toLens = unMaybeLens
newtype f :--> a = MaybeLens {unMaybeLens :: f :-> Maybe a}
instance Category (:-->) where
id = MaybeLens $ lensGS Just (\a f -> maybe f id a)
MaybeLens a . MaybeLens b = MaybeLens $ lensGS getter setter
where getter f = get a =<< get b f
setter = modify b . fmap . set a
getM :: (MonadState m) => (StateType m :-> a) -> m a
getM = gets . get
setM :: (MonadState m) => (StateType m :-> a) -> a -> m ()
setM l = S.modify . set l
modM :: (MonadState m) => (StateType m :-> a) -> (a -> a) -> m ()
modM l = S.modify . modify l
getMAbort :: (MonadState m, MLens l b f, MLensF l b f ~ StateType m) => r -> l f b -> (MLensA l b f :-> a) -> AbortT r m a
getMAbort r b l = liftM (get l) $ maybeAbort r =<< gets (get $ toLens b)
setMAbort :: (MonadState m, MLens l b f, MLensF l b f ~ StateType m) => l f b -> (MLensA l b f :-> a) -> a -> m ()
setMAbort b l x = S.modify . modify (toLens b) . fmap $ set l x
modMAbort :: (MonadState m, MLens l b f, MLensF l b f ~ StateType m) => l f b -> (MLensA l b f :-> a) -> (a -> a) -> m ()
modMAbort b l f = S.modify . modify (toLens b) . fmap $ modify l f
askM :: (MonadReader m) => (EnvType m :-> a) -> m a
askM = asks . get
liftState :: (MonadState m) => (StateType m :-> s) -> StateT s m a -> m a
liftState l n = do
(a, s) <- runStateT n =<< (l <::)
l =:: s
return a
liftSubState :: (Monad m, MonadTrans t, MonadState (t m)) => (StateType (t m) :-> s) -> StateT s m a -> t m a
liftSubState l m = do
s <- getM l
(a, s') <- lift . runStateT m $ s
setM l s'
return a
liftSubMaybeState :: (Monad m, MonadTrans t, MonadState (t m), MLens l b f, MLensF l b f ~ StateType (t m)) => l f b -> StateT (MLensA l b f) m a -> MaybeT (t m) a
liftSubMaybeState l m = MaybeT $ do
sw <- getM l'
case sw of
(Just s) -> do
(a, s') <- lift . runStateT m $ s
setM l' $ Just s'
return $ Just a
(Nothing) -> do
return Nothing
where l' = toLens l
infixr 8 <::
(<:) :: (f :-> a) -> f -> a
(<:) = get
infixr 5 =::
(=:) :: (f :-> a) -> a -> f -> f
(=:) = set
infixr 8 $::
($:) :: (f :-> a) -> (a -> a) -> f -> f
($:) = modify
infixr 8 <:
(<::) :: (MonadState m) => (StateType m :-> a) -> m a
(<::) = getM
infixr 5 =:
(=::) :: (MonadState m) => (StateType m :-> a) -> a -> m ()
(=::) = setM
infixr 8 $:
($::) :: (MonadState m) => (StateType m :-> a) -> (a -> a) -> m ()
($::) = modM
infixr 8 <<:
(<<:) :: (MonadState m, MLens l b f, MLensF l b f ~ StateType m) => r -> l f b -> (MLensA l b f :-> a) -> AbortT r m a
(<<:) = getMAbort
infixr 5 <=:
(<=:) :: (MonadState m, MLens l b f, MLensF l b f ~ StateType m) => l f b -> (MLensA l b f :-> a) -> a -> m ()
(<=:) = setMAbort
infixr 8 <$:
(<$:) :: (MonadState m, MLens l b f, MLensF l b f ~ StateType m) => l f b -> (MLensA l b f :-> a) -> (a -> a) -> m ()
(<$:) = modMAbort
infixr 8 <<::
(<<::) :: (MonadState m, MLens l b f, MLensF l b f ~ StateType m) => l f b -> (MLensA l b f :-> a) -> AbortT () m a
(<<::) = getMAbort ()
infixr 5 <->
(<->) :: (MLens l a f, MLens l' a' f', MLensA l a f ~ MLensF l' a' f') => l' f' a' -> l f a -> MLensF l a f :--> MLensA l' a' f'
a <-> b = (MaybeLens . toLens $ a) . (MaybeLens . toLens $ b)
infixr 5 <:<
(<:<) :: (MonadReader m) => (EnvType m :-> a) -> m a
(<:<) = askM
infixr 4 >$<
(>$<) :: (MonadState m) => (StateType m :-> s) -> StateT s m a -> m a
(>$<) = liftState
infixr 5 >$>
(>$>) :: (Monad m) => (s :-> s') -> StateT s' m a -> StateT s m a
(>$>) = liftSubState
infixr 4 >$$>
(>$$>) :: (Monad m, MonadTrans t, MonadState (t m), MLens l b f, MLensF l b f ~ StateType (t m)) => l f b -> StateT (MLensA l b f) m a -> MaybeT (t m) a
(>$$>) = liftSubMaybeState