{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Snap.Snaplet.Internal.Lensed where
import Control.Applicative (Alternative (..),
Applicative (..), (<$>))
import Control.Category ((.))
import Control.Lens (ALens', cloneLens, storing, (^#))
import Control.Monad (MonadPlus (..), liftM)
import Control.Monad.Base (MonadBase (..))
import qualified Control.Monad.Fail as Fail
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,
defaultRestoreM)
import Control.Monad.Trans.State (StateT(..))
import Prelude (Functor (..), Monad (..), ($))
import Snap.Core (MonadSnap (..))
newtype Lensed b v m a = Lensed
{ forall b v (m :: * -> *) a.
Lensed b v m a -> ALens' b v -> v -> b -> m (a, v, b)
unlensed :: ALens' b v -> v -> b -> m (a, v, b) }
instance Functor m => Functor (Lensed b v m) where
fmap :: forall a b. (a -> b) -> Lensed b v m a -> Lensed b v m b
fmap a -> b
f (Lensed ALens' b v -> v -> b -> m (a, v, b)
g) = forall b v (m :: * -> *) a.
(ALens' b v -> v -> b -> m (a, v, b)) -> Lensed b v m a
Lensed forall a b. (a -> b) -> a -> b
$ \ALens' b v
l v
v b
s ->
(\(a
a,v
v',b
s') -> (a -> b
f a
a, v
v', b
s')) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ALens' b v -> v -> b -> m (a, v, b)
g ALens' b v
l v
v b
s
instance (Functor m, Monad m) => Applicative (Lensed b v m) where
pure :: forall a. a -> Lensed b v m a
pure a
a = forall b v (m :: * -> *) a.
(ALens' b v -> v -> b -> m (a, v, b)) -> Lensed b v m a
Lensed forall a b. (a -> b) -> a -> b
$ \ALens' b v
_ v
v b
s -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, v
v, b
s)
Lensed ALens' b v -> v -> b -> m (a -> b, v, b)
mf <*> :: forall a b.
Lensed b v m (a -> b) -> Lensed b v m a -> Lensed b v m b
<*> Lensed ALens' b v -> v -> b -> m (a, v, b)
ma = forall b v (m :: * -> *) a.
(ALens' b v -> v -> b -> m (a, v, b)) -> Lensed b v m a
Lensed forall a b. (a -> b) -> a -> b
$ \ALens' b v
l v
v b
s -> do
(a -> b
f, v
v', b
s') <- ALens' b v -> v -> b -> m (a -> b, v, b)
mf ALens' b v
l v
v b
s
(\(a
a,v
v'',b
s'') -> (a -> b
f a
a, v
v'', b
s'')) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ALens' b v -> v -> b -> m (a, v, b)
ma ALens' b v
l v
v' b
s'
instance Fail.MonadFail m => Fail.MonadFail (Lensed b v m) where
fail :: forall a. String -> Lensed b v m a
fail String
s = forall b v (m :: * -> *) a.
(ALens' b v -> v -> b -> m (a, v, b)) -> Lensed b v m a
Lensed forall a b. (a -> b) -> a -> b
$ \ALens' b v
_ v
_ b
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
s
instance Monad m => Monad (Lensed b v m) where
return :: forall a. a -> Lensed b v m a
return a
a = forall b v (m :: * -> *) a.
(ALens' b v -> v -> b -> m (a, v, b)) -> Lensed b v m a
Lensed forall a b. (a -> b) -> a -> b
$ \ALens' b v
_ v
v b
s -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, v
v, b
s)
Lensed ALens' b v -> v -> b -> m (a, v, b)
g >>= :: forall a b.
Lensed b v m a -> (a -> Lensed b v m b) -> Lensed b v m b
>>= a -> Lensed b v m b
k = forall b v (m :: * -> *) a.
(ALens' b v -> v -> b -> m (a, v, b)) -> Lensed b v m a
Lensed forall a b. (a -> b) -> a -> b
$ \ALens' b v
l v
v b
s -> do
(a
a, v
v', b
s') <- ALens' b v -> v -> b -> m (a, v, b)
g ALens' b v
l v
v b
s
forall b v (m :: * -> *) a.
Lensed b v m a -> ALens' b v -> v -> b -> m (a, v, b)
unlensed (a -> Lensed b v m b
k a
a) ALens' b v
l v
v' b
s'
instance Monad m => MonadState v (Lensed b v m) where
get :: Lensed b v m v
get = forall b v (m :: * -> *) a.
(ALens' b v -> v -> b -> m (a, v, b)) -> Lensed b v m a
Lensed forall a b. (a -> b) -> a -> b
$ \ALens' b v
_ v
v b
s -> forall (m :: * -> *) a. Monad m => a -> m a
return (v
v, v
v, b
s)
put :: v -> Lensed b v m ()
put v
v' = forall b v (m :: * -> *) a.
(ALens' b v -> v -> b -> m (a, v, b)) -> Lensed b v m a
Lensed forall a b. (a -> b) -> a -> b
$ \ALens' b v
_ v
_ b
s -> forall (m :: * -> *) a. Monad m => a -> m a
return ((), v
v', b
s)
instance Monad m => MonadReader (ALens' b v) (Lensed b v m) where
ask :: Lensed b v m (ALens' b v)
ask = forall b v (m :: * -> *) a.
(ALens' b v -> v -> b -> m (a, v, b)) -> Lensed b v m a
Lensed forall a b. (a -> b) -> a -> b
$ \ALens' b v
l v
v b
s -> forall (m :: * -> *) a. Monad m => a -> m a
return (ALens' b v
l, v
v, b
s)
local :: forall a.
(ALens' b v -> ALens' b v) -> Lensed b v m a -> Lensed b v m a
local = forall (m :: * -> *) b v v' a.
Monad m =>
(ALens' b v -> ALens' b v') -> Lensed b v' m a -> Lensed b v m a
lensedLocal
lensedLocal :: Monad m => (ALens' b v -> ALens' b v') -> Lensed b v' m a -> Lensed b v m a
lensedLocal :: forall (m :: * -> *) b v v' a.
Monad m =>
(ALens' b v -> ALens' b v') -> Lensed b v' m a -> Lensed b v m a
lensedLocal ALens' b v -> ALens' b v'
f Lensed b v' m a
g = do
ALens' b v
l <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) b v' a v.
Monad m =>
ALens' b v' -> Lensed b v' m a -> Lensed b v m a
withTop (ALens' b v -> ALens' b v'
f ALens' b v
l) Lensed b v' m a
g
instance MonadTrans (Lensed b v) where
lift :: forall (m :: * -> *) a. Monad m => m a -> Lensed b v m a
lift m a
m = forall b v (m :: * -> *) a.
(ALens' b v -> v -> b -> m (a, v, b)) -> Lensed b v m a
Lensed forall a b. (a -> b) -> a -> b
$ \ALens' b v
_ v
v b
b -> do
a
res <- m a
m
forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, v
v, b
b)
instance MonadIO m => MonadIO (Lensed b v m) where
liftIO :: forall a. IO a -> Lensed b v m a
liftIO = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
instance MonadPlus m => MonadPlus (Lensed b v m) where
mzero :: forall a. Lensed b v m a
mzero = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *) a. MonadPlus m => m a
mzero
Lensed b v m a
m mplus :: forall a. Lensed b v m a -> Lensed b v m a -> Lensed b v m a
`mplus` Lensed b v m a
n = forall b v (m :: * -> *) a.
(ALens' b v -> v -> b -> m (a, v, b)) -> Lensed b v m a
Lensed forall a b. (a -> b) -> a -> b
$ \ALens' b v
l v
v b
b ->
forall b v (m :: * -> *) a.
Lensed b v m a -> ALens' b v -> v -> b -> m (a, v, b)
unlensed Lensed b v m a
m ALens' b v
l v
v b
b forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall b v (m :: * -> *) a.
Lensed b v m a -> ALens' b v -> v -> b -> m (a, v, b)
unlensed Lensed b v m a
n ALens' b v
l v
v b
b
instance (Monad m, Alternative m) => Alternative (Lensed b v m) where
empty :: forall a. Lensed b v m a
empty = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (f :: * -> *) a. Alternative f => f a
empty
Lensed ALens' b v -> v -> b -> m (a, v, b)
m <|> :: forall a. Lensed b v m a -> Lensed b v m a -> Lensed b v m a
<|> Lensed ALens' b v -> v -> b -> m (a, v, b)
n = forall b v (m :: * -> *) a.
(ALens' b v -> v -> b -> m (a, v, b)) -> Lensed b v m a
Lensed forall a b. (a -> b) -> a -> b
$ \ALens' b v
l v
v b
b -> ALens' b v -> v -> b -> m (a, v, b)
m ALens' b v
l v
v b
b forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ALens' b v -> v -> b -> m (a, v, b)
n ALens' b v
l v
v b
b
instance MonadSnap m => MonadSnap (Lensed b v m) where
liftSnap :: forall a. Snap a -> Lensed b v m a
liftSnap = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap
instance MonadBase base m => MonadBase base (Lensed b v m) where
liftBase :: forall α. base α -> Lensed b v m α
liftBase = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase
instance MonadBaseControl base m => MonadBaseControl base (Lensed b v m) where
type StM (Lensed b v m) a = ComposeSt (Lensed b v) m a
liftBaseWith :: forall a.
(RunInBase (Lensed b v m) base -> base a) -> Lensed b v m a
liftBaseWith = forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) a.
(MonadTransControl t, MonadBaseControl b m) =>
(RunInBaseDefault t m b -> b a) -> t m a
defaultLiftBaseWith
restoreM :: forall a. StM (Lensed b v m) a -> Lensed b v m a
restoreM = forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) a.
(MonadTransControl t, MonadBaseControl b m) =>
ComposeSt t m a -> t m a
defaultRestoreM
{-# INLINE liftBaseWith #-}
{-# INLINE restoreM #-}
instance MonadTransControl (Lensed b v) where
type StT (Lensed b v) a = (a, v, b)
liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run (Lensed b v) -> m a) -> Lensed b v m a
liftWith Run (Lensed b v) -> m a
f = forall b v (m :: * -> *) a.
(ALens' b v -> v -> b -> m (a, v, b)) -> Lensed b v m a
Lensed forall a b. (a -> b) -> a -> b
$ \ALens' b v
l v
v b
b -> do
a
res <- Run (Lensed b v) -> m a
f forall a b. (a -> b) -> a -> b
$ \(Lensed ALens' b v -> v -> b -> n (b, v, b)
g) -> ALens' b v -> v -> b -> n (b, v, b)
g ALens' b v
l v
v b
b
forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, v
v, b
b)
restoreT :: forall (m :: * -> *) a.
Monad m =>
m (StT (Lensed b v) a) -> Lensed b v m a
restoreT m (StT (Lensed b v) a)
k = forall b v (m :: * -> *) a.
(ALens' b v -> v -> b -> m (a, v, b)) -> Lensed b v m a
Lensed forall a b. (a -> b) -> a -> b
$ \ALens' b v
_ v
_ b
_ -> m (StT (Lensed b v) a)
k
{-# INLINE liftWith #-}
{-# INLINE restoreT #-}
globally :: Monad m => StateT b m a -> Lensed b v m a
globally :: forall (m :: * -> *) b a v.
Monad m =>
StateT b m a -> Lensed b v m a
globally (StateT b -> m (a, b)
f) = forall b v (m :: * -> *) a.
(ALens' b v -> v -> b -> m (a, v, b)) -> Lensed b v m a
Lensed forall a b. (a -> b) -> a -> b
$ \ALens' b v
l v
v b
s ->
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\(a
a, b
s') -> (a
a, b
s' forall s t a b. s -> ALens s t a b -> a
^# ALens' b v
l, b
s')) forall a b. (a -> b) -> a -> b
$ b -> m (a, b)
f (forall s t a b. ALens s t a b -> b -> s -> t
storing ALens' b v
l v
v b
s)
lensedAsState :: Monad m => Lensed b v m a -> ALens' b v -> StateT b m a
lensedAsState :: forall (m :: * -> *) b v a.
Monad m =>
Lensed b v m a -> ALens' b v -> StateT b m a
lensedAsState (Lensed ALens' b v -> v -> b -> m (a, v, b)
f) ALens' b v
l = forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT forall a b. (a -> b) -> a -> b
$ \b
s -> do
(a
a, v
v', b
s') <- ALens' b v -> v -> b -> m (a, v, b)
f ALens' b v
l (b
s forall s t a b. s -> ALens s t a b -> a
^# ALens' b v
l) b
s
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, forall s t a b. ALens s t a b -> b -> s -> t
storing ALens' b v
l v
v' b
s')
getBase :: Monad m => Lensed b v m b
getBase :: forall (m :: * -> *) b v. Monad m => Lensed b v m b
getBase = forall b v (m :: * -> *) a.
(ALens' b v -> v -> b -> m (a, v, b)) -> Lensed b v m a
Lensed forall a b. (a -> b) -> a -> b
$ \ALens' b v
_ v
v b
b -> forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, v
v, b
b)
withTop :: Monad m => ALens' b v' -> Lensed b v' m a -> Lensed b v m a
withTop :: forall (m :: * -> *) b v' a v.
Monad m =>
ALens' b v' -> Lensed b v' m a -> Lensed b v m a
withTop ALens' b v'
l Lensed b v' m a
m = forall (m :: * -> *) b a v.
Monad m =>
StateT b m a -> Lensed b v m a
globally forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b v a.
Monad m =>
Lensed b v m a -> ALens' b v -> StateT b m a
lensedAsState Lensed b v' m a
m ALens' b v'
l
with :: Monad m => ALens' v v' -> Lensed b v' m a -> Lensed b v m a
with :: forall (m :: * -> *) v v' b a.
Monad m =>
ALens' v v' -> Lensed b v' m a -> Lensed b v m a
with ALens' v v'
l Lensed b v' m a
g = do
ALens b b v v
l' <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) b v' a v.
Monad m =>
ALens' b v' -> Lensed b v' m a -> Lensed b v m a
withTop (forall s t a b. ALens s t a b -> Lens s t a b
cloneLens ALens b b v v
l' forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ALens' v v'
l) Lensed b v' m a
g
embed :: Monad m => ALens' v v' -> Lensed v v' m a -> Lensed b v m a
embed :: forall (m :: * -> *) v v' a b.
Monad m =>
ALens' v v' -> Lensed v v' m a -> Lensed b v m a
embed ALens' v v'
l Lensed v v' m a
m = forall (m :: * -> *) v a b.
Monad m =>
StateT v m a -> Lensed b v m a
locally forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b v a.
Monad m =>
Lensed b v m a -> ALens' b v -> StateT b m a
lensedAsState Lensed v v' m a
m ALens' v v'
l
locally :: Monad m => StateT v m a -> Lensed b v m a
locally :: forall (m :: * -> *) v a b.
Monad m =>
StateT v m a -> Lensed b v m a
locally (StateT v -> m (a, v)
f) = forall b v (m :: * -> *) a.
(ALens' b v -> v -> b -> m (a, v, b)) -> Lensed b v m a
Lensed forall a b. (a -> b) -> a -> b
$ \ALens' b v
_ v
v b
s ->
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\(a
a, v
v') -> (a
a, v
v', b
s)) forall a b. (a -> b) -> a -> b
$ v -> m (a, v)
f v
v
runLensed :: Monad m
=> Lensed t1 b m t
-> ALens' t1 b
-> t1
-> m (t, t1)
runLensed :: forall (m :: * -> *) t1 b t.
Monad m =>
Lensed t1 b m t -> ALens' t1 b -> t1 -> m (t, t1)
runLensed (Lensed ALens' t1 b -> b -> t1 -> m (t, b, t1)
f) ALens' t1 b
l t1
s = do
(t
a, b
v', t1
s') <- ALens' t1 b -> b -> t1 -> m (t, b, t1)
f ALens' t1 b
l (t1
s forall s t a b. s -> ALens s t a b -> a
^# ALens' t1 b
l) t1
s
forall (m :: * -> *) a. Monad m => a -> m a
return (t
a, forall s t a b. ALens s t a b -> b -> s -> t
storing ALens' t1 b
l b
v' t1
s')