-- | Defines a version of the ListT monad transformer, used in the REST search

module Language.REST.Internal.ListT where

import           Control.Applicative
import           Control.Monad.Trans

newtype ListT m a = ListT {
  forall (m :: * -> *) a. ListT m a -> m [a]
runListT :: m [a]
}

instance (Monad m) => Functor (ListT m) where
  fmap :: forall a b. (a -> b) -> ListT m a -> ListT m b
fmap a -> b
f (ListT m [a]
mxs) = m [b] -> ListT m b
forall (m :: * -> *) a. m [a] -> ListT m a
ListT (m [b] -> ListT m b) -> m [b] -> ListT m b
forall a b. (a -> b) -> a -> b
$ do
    (a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map a -> b
f ([a] -> [b]) -> m [a] -> m [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [a]
mxs

instance (Monad m) => Applicative (ListT m) where
  pure :: forall a. a -> ListT m a
pure a
x                    = m [a] -> ListT m a
forall (m :: * -> *) a. m [a] -> ListT m a
ListT ([a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [a
x])
  (ListT m [a -> b]
mf) <*> :: forall a b. ListT m (a -> b) -> ListT m a -> ListT m b
<*> (ListT m [a]
mx) = m [b] -> ListT m b
forall (m :: * -> *) a. m [a] -> ListT m a
ListT (m [b] -> ListT m b) -> m [b] -> ListT m b
forall a b. (a -> b) -> a -> b
$ do
    [a -> b]
fs <- m [a -> b]
mf
    [a]
xs <- m [a]
mx
    [b] -> m [b]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([b] -> m [b]) -> [b] -> m [b]
forall a b. (a -> b) -> a -> b
$ do
      a -> b
f <- [a -> b]
fs
      (a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map a -> b
f [a]
xs

instance (Monad m) => Monad (ListT m) where
  return :: forall a. a -> ListT m a
return a
x         = m [a] -> ListT m a
forall (m :: * -> *) a. m [a] -> ListT m a
ListT ([a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [a
x])
  (ListT m [a]
mxs) >>= :: forall a b. ListT m a -> (a -> ListT m b) -> ListT m b
>>= a -> ListT m b
f = m [b] -> ListT m b
forall (m :: * -> *) a. m [a] -> ListT m a
ListT (m [b] -> ListT m b) -> m [b] -> ListT m b
forall a b. (a -> b) -> a -> b
$ do
    [a]
xs <- m [a]
mxs
    [[b]]
res <- (a -> m [b]) -> [a] -> m [[b]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ListT m b -> m [b]
forall (m :: * -> *) a. ListT m a -> m [a]
runListT (ListT m b -> m [b]) -> (a -> ListT m b) -> a -> m [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ListT m b
f) [a]
xs
    [b] -> m [b]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([b] -> m [b]) -> [b] -> m [b]
forall a b. (a -> b) -> a -> b
$ [[b]] -> [b]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[b]]
res

instance (Monad m) => Alternative (ListT m) where
  empty :: forall a. ListT m a
empty                       = m [a] -> ListT m a
forall (m :: * -> *) a. m [a] -> ListT m a
ListT ([a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [])
  (ListT m [a]
mxs) <|> :: forall a. ListT m a -> ListT m a -> ListT m a
<|> (ListT m [a]
mys) = m [a] -> ListT m a
forall (m :: * -> *) a. m [a] -> ListT m a
ListT (m [a] -> ListT m a) -> m [a] -> ListT m a
forall a b. (a -> b) -> a -> b
$ do
    [a]
xs <- m [a]
mxs
    if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs
      then m [a]
mxs
      else m [a]
mys

instance MonadTrans ListT where
  lift :: forall (m :: * -> *) a. Monad m => m a -> ListT m a
lift m a
mx = m [a] -> ListT m a
forall (m :: * -> *) a. m [a] -> ListT m a
ListT (m [a] -> ListT m a) -> m [a] -> ListT m a
forall a b. (a -> b) -> a -> b
$ do
    a
x <- m a
mx
    [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [a
x]