    {-# LANGUAGE BangPatterns               #-}
    {-# LANGUAGE FlexibleInstances          #-}
    {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    {-# LANGUAGE MultiParamTypeClasses      #-}
    {-# LANGUAGE TypeFamilies               #-}
    {-# LANGUAGE UndecidableInstances       #-}

    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
         {-# INLINE liftBaseWith #-}
         {-# INLINE restoreM #-}

    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
        {-# INLINE liftWith #-}
        {-# INLINE restoreT #-}

    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
    {-# INLINE getBase #-}

    ------------------------------------------------------------------------------
    putBase :: Monad m => s -> LensT b v s m ()
    putBase = LensT . put
    {-# INLINE putBase #-}

    ------------------------------------------------------------------------------
    lGet :: Monad m => LensT b v b m v
    lGet = LensT $ do
               !l <- ask
               !b <- get
               return $! b ^# l
    {-# INLINE lGet #-}

    ------------------------------------------------------------------------------
    lPut :: Monad m => v -> LensT b v b m ()
    lPut v = LensT $ do
                 !l <- ask
                 !b <- get
                 put $! storing l v b
    {-# INLINE lPut #-}

    ------------------------------------------------------------------------------
    runLensT :: Monad m => LensT b v s m a -> ALens' b v -> s -> m (a, s)
    runLensT (LensT m) l = runRST m l
    {-# INLINE runLensT #-}

    ------------------------------------------------------------------------------
    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
    {-# INLINE withLensT #-}

    ------------------------------------------------------------------------------
    withTop :: Monad m
            => ALens' b v'
            -> LensT b v' s m a
            -> LensT b v  s m a
    withTop subLens = withLensT (const subLens)
    {-# INLINE withTop #-}

    ------------------------------------------------------------------------------
    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)