module Snap.Snaplet.Internal.LensT where
import Control.Applicative (Alternative (..),
Applicative (..))
import Control.Category ((.))
import Control.Lens (ALens', cloneLens, storing, (^#))
import Control.Monad (MonadPlus (..))
import Control.Monad.Base (MonadBase (..))
import Control.Monad.Reader (MonadReader (..))
import Control.Monad.State.Class (MonadState (..))
import Control.Monad.Trans (MonadIO (..), MonadTrans (..))
import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
MonadTransControl (..),
defaultLiftBaseWith,
defaultLiftWith, defaultRestoreM,
defaultRestoreT)
import Prelude (Functor (..), Monad (..), const,
($), ($!))
import Snap.Core (MonadSnap (..))
import Snap.Snaplet.Internal.RST (RST (..), runRST, withRST)
newtype LensT b v s m a = LensT (RST (ALens' b v) s m a)
deriving ( Monad
, MonadTrans
, Functor
, Applicative
, MonadIO
, MonadPlus
, Alternative
, MonadReader (ALens' b v))
instance Monad m => MonadState v (LensT b v b m) where
get = lGet
put = lPut
instance MonadBase bs m => MonadBase bs (LensT b v s m) where
liftBase = lift . liftBase
instance MonadBaseControl bs m => MonadBaseControl bs (LensT b v s m) where
type StM (LensT b v s m) a = ComposeSt (LensT b v s) m a
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
instance MonadTransControl (LensT b v s) where
type StT (LensT b v s) a = StT (RST (ALens' b v) s) a
liftWith = defaultLiftWith LensT (\(LensT rst) -> rst)
restoreT = defaultRestoreT LensT
instance MonadSnap m => MonadSnap (LensT b v s m) where
liftSnap m = LensT $ liftSnap m
getBase :: Monad m => LensT b v s m s
getBase = LensT get
putBase :: Monad m => s -> LensT b v s m ()
putBase = LensT . put
lGet :: Monad m => LensT b v b m v
lGet = LensT $ do
!l <- ask
!b <- get
return $! b ^# l
lPut :: Monad m => v -> LensT b v b m ()
lPut v = LensT $ do
!l <- ask
!b <- get
put $! storing l v b
runLensT :: Monad m => LensT b v s m a -> ALens' b v -> s -> m (a, s)
runLensT (LensT m) l = runRST m l
withLensT :: Monad m
=> (ALens' b' v' -> ALens' b v)
-> LensT b v s m a
-> LensT b' v' s m a
withLensT f (LensT m) = LensT $ withRST f m
withTop :: Monad m
=> ALens' b v'
-> LensT b v' s m a
-> LensT b v s m a
withTop subLens = withLensT (const subLens)
with :: Monad m => ALens' v v' -> LensT b v' s m a -> LensT b v s m a
with subLens = withLensT (\l -> cloneLens l . subLens)