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

data ListT m a = ListT {
  ListT m a -> m [a]
runListT :: m [a]
}

instance (Monad m) => Functor (ListT m) where
  fmap :: (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]
xs <- m [a]
mxs
    [b] -> m [b]
forall (m :: * -> *) a. Monad m => a -> m a
return ([b] -> m [b]) -> [b] -> m [b]
forall a b. (a -> b) -> a -> b
$ (a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map a -> b
f [a]
xs

instance (Monad m) => Applicative (ListT m) where
  pure :: 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 (m :: * -> *) a. Monad m => a -> m a
return [a
x])
  (ListT m [a -> b]
mf) <*> :: 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 (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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return [a
x])
  (ListT m [a]
mxs) >>= :: 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)
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 (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 :: ListT m a
empty                       = m [a] -> ListT m a
forall (m :: * -> *) a. m [a] -> ListT m a
ListT ([a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [])
  (ListT m [a]
mxs) <|> :: 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 (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs
      then m [a]
mxs
      else m [a]
mys

instance MonadTrans ListT where
  lift :: 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 (m :: * -> *) a. Monad m => a -> m a
return [a
x]