Lensed.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Snap.Snaplet.Internal.Lensed where

import Control.Applicative
import Control.Monad
import Control.Monad.Trans
import Data.Lens.Strict
import Control.Monad.CatchIO
import Control.Monad.Reader.Class
import Control.Monad.State.Class
import Control.Monad.State.Strict
import Control.Category
import Prelude hiding (catch, id, (.))
import Snap.Core


------------------------------------------------------------------------------
newtype Lensed b v m a = Lensed
    { unlensed :: Lens b v -> v -> b -> m (a, v, b) }


------------------------------------------------------------------------------
instance Functor m => Functor (Lensed b v m) where
    fmap f (Lensed g) = Lensed $ \l v s ->
        (\(a,v',s') -> (f a, v', s')) <$> g l v s


------------------------------------------------------------------------------
instance (Functor m, Monad m) => Applicative (Lensed b v m) where
    pure a = Lensed $ \_ v s -> return (a, v, s)
    Lensed mf <*> Lensed ma = Lensed $ \l v s -> do
        (f, v', s') <- mf l v s
        (\(a,v'',s'') -> (f a, v'', s'')) <$> ma l v' s'


------------------------------------------------------------------------------
instance Monad m => Monad (Lensed b v m) where
    return a = Lensed $ \_ v s -> return (a, v, s)
    Lensed g >>= k = Lensed $ \l v s -> do
        (a, v', s') <- g l v s
        unlensed (k a) l v' s'


------------------------------------------------------------------------------
instance Monad m => MonadState v (Lensed b v m) where
    get = Lensed $ \_ v s -> return (v, v, s)
    put v' = Lensed $ \_ _ s -> return ((), v', s)


------------------------------------------------------------------------------
instance Monad m => MonadReader (Lens b v) (Lensed b v m) where
    ask = Lensed $ \l v s -> return (l, v, s)
    local f g = do
        l' <- asks f
        withTop l' g


------------------------------------------------------------------------------
instance MonadTrans (Lensed b v) where
    lift m = Lensed $ \_ v b -> do
                 res <- m
                 return (res, v, b)


------------------------------------------------------------------------------
instance MonadIO m => MonadIO (Lensed b v m) where
  liftIO = lift . liftIO


------------------------------------------------------------------------------
instance MonadCatchIO m => MonadCatchIO (Lensed b v m) where
    catch (Lensed m) f = Lensed $ \l v b -> m l v b `catch` handler l v b
      where
        handler l v b e = let (Lensed h) = f e
                          in h l v b

    block (Lensed m)   = Lensed $ \l v b -> block (m l v b)
    unblock (Lensed m) = Lensed $ \l v b -> unblock (m l v b)


------------------------------------------------------------------------------
instance MonadPlus m => MonadPlus (Lensed b v m) where
    mzero = lift mzero
    m `mplus` n = Lensed $ \l v b ->
                  unlensed m l v b `mplus` unlensed n l v b


------------------------------------------------------------------------------
instance (Monad m, Alternative m) => Alternative (Lensed b v m) where
    empty = lift empty
    (Lensed m) <|> (Lensed n) = Lensed $ \l v b -> m l v b <|> n l v b


------------------------------------------------------------------------------
instance MonadSnap m => MonadSnap (Lensed b v m) where
    liftSnap = lift . liftSnap


------------------------------------------------------------------------------
getBase :: Monad m => Lensed b v m b
getBase = Lensed $ \_ v b -> return (b, v, b)


------------------------------------------------------------------------------
withTop :: Monad m => Lens b v' -> Lensed b v' m a -> Lensed b v m a
withTop l m = globally $ lensedAsState m l


------------------------------------------------------------------------------
with :: Monad m => Lens v v' -> Lensed b v' m a -> Lensed b v m a
with l g = do
    l' <- asks (l .)
    withTop l' g


------------------------------------------------------------------------------
embed :: Monad m => Lens v v' -> Lensed v v' m a -> Lensed b v m a
embed l m = locally $ lensedAsState m l


------------------------------------------------------------------------------
globally :: Monad m => StateT b m a -> Lensed b v m a
globally (StateT f) = Lensed $ \l v s ->
                      liftM (\(a, s') -> (a, l ^$ s', s')) $ f (l ^= v $ s)


------------------------------------------------------------------------------
locally :: Monad m => StateT v m a -> Lensed b v m a
locally (StateT f) = Lensed $ \_ v s ->
                     liftM (\(a, v') -> (a, v', s)) $ f v


------------------------------------------------------------------------------
lensedAsState :: Monad m => Lensed b v m a -> Lens b v -> StateT b m a
lensedAsState (Lensed f) l = StateT $ \s -> do
    (a, v', s') <- f l (l ^$ s) s
    return (a, l ^= v' $ s')


------------------------------------------------------------------------------
runLensed :: Monad m
          => Lensed t1 b m t
          -> Lens t1 b
          -> t1
          -> m (t, t1)
runLensed (Lensed f) l s = do
    (a, v', s') <- f l (l ^$ s) s
    return (a, l ^= v' $ s')