{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

{- |
Module      : Network.MPD.Applicative.Internal
Copyright   : (c) Simon Hengel 2012
License     : MIT

Maintainer  : joachifm@fastmail.fm
Stability   : stable
Portability : unportable

Applicative MPD command interface.

This allows us to combine commands into command lists, as in

> (,,) <$> currentSong <*> stats <*> status

where the requests are automatically combined into a command list and
the result of each command passed to the consumer.
-}

module Network.MPD.Applicative.Internal
    ( Parser(..)
    , liftParser
    , getResponse
    , emptyResponse
    , unexpected
    , Command(..)
    , runCommand
    ) where

import           Control.Monad
import           Data.ByteString.Char8 (ByteString)

import           Network.MPD.Core hiding (getResponse)
import qualified Network.MPD.Core as Core
import           Control.Monad.Except
import qualified Control.Monad.Fail as Fail

-- | A line-oriented parser that returns a value along with any remaining input.
newtype Parser a
    = Parser { forall a.
Parser a -> [ByteString] -> Either String (a, [ByteString])
runParser :: [ByteString] -> Either String (a, [ByteString]) }
      deriving (forall a b. (a -> b) -> Parser a -> Parser b)
-> (forall a b. a -> Parser b -> Parser a) -> Functor Parser
forall a b. a -> Parser b -> Parser a
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Parser a -> Parser b
fmap :: forall a b. (a -> b) -> Parser a -> Parser b
$c<$ :: forall a b. a -> Parser b -> Parser a
<$ :: forall a b. a -> Parser b -> Parser a
Functor

instance Monad Parser where
    return :: forall a. a -> Parser a
return a
a  = ([ByteString] -> Either String (a, [ByteString])) -> Parser a
forall a.
([ByteString] -> Either String (a, [ByteString])) -> Parser a
Parser (([ByteString] -> Either String (a, [ByteString])) -> Parser a)
-> ([ByteString] -> Either String (a, [ByteString])) -> Parser a
forall a b. (a -> b) -> a -> b
$ \[ByteString]
input -> (a, [ByteString]) -> Either String (a, [ByteString])
forall a b. b -> Either a b
Right (a
a, [ByteString]
input)
    Parser a
p1 >>= :: forall a b. Parser a -> (a -> Parser b) -> Parser b
>>= a -> Parser b
p2 = ([ByteString] -> Either String (b, [ByteString])) -> Parser b
forall a.
([ByteString] -> Either String (a, [ByteString])) -> Parser a
Parser (([ByteString] -> Either String (b, [ByteString])) -> Parser b)
-> ([ByteString] -> Either String (b, [ByteString])) -> Parser b
forall a b. (a -> b) -> a -> b
$ \[ByteString]
input -> Parser a -> [ByteString] -> Either String (a, [ByteString])
forall a.
Parser a -> [ByteString] -> Either String (a, [ByteString])
runParser Parser a
p1 [ByteString]
input Either String (a, [ByteString])
-> ((a, [ByteString]) -> Either String (b, [ByteString]))
-> Either String (b, [ByteString])
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (a -> [ByteString] -> Either String (b, [ByteString]))
-> (a, [ByteString]) -> Either String (b, [ByteString])
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Parser b -> [ByteString] -> Either String (b, [ByteString])
forall a.
Parser a -> [ByteString] -> Either String (a, [ByteString])
runParser (Parser b -> [ByteString] -> Either String (b, [ByteString]))
-> (a -> Parser b)
-> a
-> [ByteString]
-> Either String (b, [ByteString])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Parser b
p2)

instance Fail.MonadFail Parser where
    fail :: forall a. String -> Parser a
fail = String -> Parser a
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
Prelude.fail

instance Applicative Parser where
    pure :: forall a. a -> Parser a
pure  = a -> Parser a
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: forall a b. Parser (a -> b) -> Parser a -> Parser b
(<*>) = Parser (a -> b) -> Parser a -> Parser b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

-- | Convert a regular parser.
liftParser :: ([ByteString] -> Either String a) -> Parser a
liftParser :: forall a. ([ByteString] -> Either String a) -> Parser a
liftParser [ByteString] -> Either String a
p = ([ByteString] -> Either String (a, [ByteString])) -> Parser a
forall a.
([ByteString] -> Either String (a, [ByteString])) -> Parser a
Parser (([ByteString] -> Either String (a, [ByteString])) -> Parser a)
-> ([ByteString] -> Either String (a, [ByteString])) -> Parser a
forall a b. (a -> b) -> a -> b
$ \[ByteString]
input -> case (ByteString -> Bool)
-> [ByteString] -> ([ByteString], [ByteString])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"list_OK") [ByteString]
input of
    ([ByteString]
xs, [ByteString]
ys) -> (a -> (a, [ByteString]))
-> Either String a -> Either String (a, [ByteString])
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, Int -> [ByteString] -> [ByteString]
forall a. Int -> [a] -> [a]
drop Int
1 [ByteString]
ys) ([ByteString] -> Either String a
p [ByteString]
xs)

-- | Return everything until the next "list_OK".
getResponse :: Parser [ByteString]
getResponse :: Parser [ByteString]
getResponse = ([ByteString] -> Either String ([ByteString], [ByteString]))
-> Parser [ByteString]
forall a.
([ByteString] -> Either String (a, [ByteString])) -> Parser a
Parser (([ByteString] -> Either String ([ByteString], [ByteString]))
 -> Parser [ByteString])
-> ([ByteString] -> Either String ([ByteString], [ByteString]))
-> Parser [ByteString]
forall a b. (a -> b) -> a -> b
$ \[ByteString]
input -> case (ByteString -> Bool)
-> [ByteString] -> ([ByteString], [ByteString])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"list_OK") [ByteString]
input of
    ([ByteString]
xs, [ByteString]
ys) -> ([ByteString], [ByteString])
-> Either String ([ByteString], [ByteString])
forall a b. b -> Either a b
Right ([ByteString]
xs, Int -> [ByteString] -> [ByteString]
forall a. Int -> [a] -> [a]
drop Int
1 [ByteString]
ys)

-- | For commands returning an empty response.
emptyResponse :: Parser ()
emptyResponse :: Parser ()
emptyResponse = do
    [ByteString]
r <- Parser [ByteString]
getResponse
    Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ByteString] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
r) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$
        [ByteString] -> Parser ()
forall a. [ByteString] -> Parser a
unexpected [ByteString]
r

-- | Fail with unexpected response.
unexpected :: [ByteString] -> Parser a
unexpected :: forall a. [ByteString] -> Parser a
unexpected = String -> Parser a
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser a)
-> ([ByteString] -> String) -> [ByteString] -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"unexpected Response: " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> ([ByteString] -> String) -> [ByteString] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> String
forall a. Show a => a -> String
show

-- | A compound command, comprising a parser for the responses and a
-- combined request of an arbitrary number of commands.
data Command a = Command {
     forall a. Command a -> Parser a
commandParser  :: Parser a
   , forall a. Command a -> [String]
commandRequest :: [String]
   } deriving (forall a b. (a -> b) -> Command a -> Command b)
-> (forall a b. a -> Command b -> Command a) -> Functor Command
forall a b. a -> Command b -> Command a
forall a b. (a -> b) -> Command a -> Command b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Command a -> Command b
fmap :: forall a b. (a -> b) -> Command a -> Command b
$c<$ :: forall a b. a -> Command b -> Command a
<$ :: forall a b. a -> Command b -> Command a
Functor

instance Applicative Command where
    pure :: forall a. a -> Command a
pure a
a = Parser a -> [String] -> Command a
forall a. Parser a -> [String] -> Command a
Command (a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a) []
    (Command Parser (a -> b)
p1 [String]
c1) <*> :: forall a b. Command (a -> b) -> Command a -> Command b
<*> (Command Parser a
p2 [String]
c2) = Parser b -> [String] -> Command b
forall a. Parser a -> [String] -> Command a
Command (Parser (a -> b)
p1 Parser (a -> b) -> Parser a -> Parser b
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a
p2) ([String]
c1 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
c2)

-- | Execute a 'Command'.
runCommand :: MonadMPD m => Command a -> m a
runCommand :: forall (m :: * -> *) a. MonadMPD m => Command a -> m a
runCommand (Command Parser a
p [String]
c) = do
    [ByteString]
r <- String -> m [ByteString]
forall (m :: * -> *). MonadMPD m => String -> m [ByteString]
Core.getResponse String
command
    case Parser a -> [ByteString] -> Either String (a, [ByteString])
forall a.
Parser a -> [ByteString] -> Either String (a, [ByteString])
runParser Parser a
p [ByteString]
r of
        Left String
err      -> MPDError -> m a
forall a. MPDError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> MPDError
Unexpected String
err)
        Right (a
a, []) -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
        Right (a
_, [ByteString]
xs) -> MPDError -> m a
forall a. MPDError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> MPDError
Unexpected (String -> MPDError) -> String -> MPDError
forall a b. (a -> b) -> a -> b
$ String
"superfluous input: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [ByteString] -> String
forall a. Show a => a -> String
show [ByteString]
xs)
    where
        command :: String
command = case [String]
c of
            [String
x] -> String
x
            [String]
xs  -> [String] -> String
unlines (String
"command_list_ok_begin" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
xs)
                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"command_list_end"