You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
100 lines
2.9 KiB
100 lines
2.9 KiB
{-# 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 Internal
|
|
( Parser(..)
|
|
, liftParser
|
|
, getResponse
|
|
, emptyResponse
|
|
, unexpected
|
|
, Command(..)
|
|
, runCommand
|
|
) where
|
|
|
|
import Control.Applicative
|
|
import Control.Monad
|
|
import Data.ByteString.Char8 (ByteString)
|
|
|
|
import Network.MPD.Core hiding (getResponse)
|
|
import qualified Network.MPD.Core as Core
|
|
import Control.Monad.Error
|
|
|
|
-- | A line-oriented parser that returns a value along with any remaining input.
|
|
newtype Parser a
|
|
= Parser { runParser :: [ByteString] -> Either String (a, [ByteString]) }
|
|
deriving Functor
|
|
|
|
instance Monad Parser where
|
|
fail = Parser . const . Left
|
|
return a = Parser $ \input -> Right (a, input)
|
|
p1 >>= p2 = Parser $ \input -> runParser p1 input >>= uncurry (runParser . p2)
|
|
|
|
instance Applicative Parser where
|
|
pure = return
|
|
(<*>) = ap
|
|
|
|
-- | Convert a regular parser.
|
|
liftParser :: ([ByteString] -> Either String a) -> Parser a
|
|
liftParser p = Parser $ \input -> case break (== "list_OK") input of
|
|
(xs, ys) -> fmap (, drop 1 ys) (p xs)
|
|
|
|
-- | Return everything until the next "list_OK".
|
|
getResponse :: Parser [ByteString]
|
|
getResponse = Parser $ \input -> case break (== "list_OK") input of
|
|
(xs, ys) -> Right (xs, drop 1 ys)
|
|
|
|
-- | For commands returning an empty response.
|
|
emptyResponse :: Parser ()
|
|
emptyResponse = do
|
|
r <- getResponse
|
|
unless (null r) $
|
|
unexpected r
|
|
|
|
-- | Fail with unexpected response.
|
|
unexpected :: [ByteString] -> Parser a
|
|
unexpected = fail . ("unexpected Response: " ++) . show
|
|
|
|
-- | A compound command, comprising a parser for the responses and a
|
|
-- combined request of an arbitrary number of commands.
|
|
data Command a = Command {
|
|
commandParser :: Parser a
|
|
, commandRequest :: [String]
|
|
} deriving Functor
|
|
|
|
instance Applicative Command where
|
|
pure a = Command (pure a) []
|
|
(Command p1 c1) <*> (Command p2 c2) = Command (p1 <*> p2) (c1 ++ c2)
|
|
|
|
-- | Execute a 'Command'.
|
|
runCommand :: MonadMPD m => Command a -> m a
|
|
runCommand (Command p c) = do
|
|
r <- Core.getResponse command
|
|
case runParser p r of
|
|
Left err -> throwError (Unexpected err)
|
|
Right (a, []) -> return a
|
|
Right (_, xs) -> throwError (Unexpected $ "superfluous input: " ++ show xs)
|
|
where
|
|
command = case c of
|
|
[x] -> x
|
|
xs -> unlines ("command_list_ok_begin" : xs)
|
|
++ "command_list_end"
|
|
|