{-# 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')