module Data.BEncode.Parser
( BParser
, runParser
, token
, dict
, list
, optional
, bstring
, bbytestring
, bint
, setInput
, (<|>)
) where
import Data.BEncode
import qualified Data.Map as Map
import qualified Data.ByteString.Char8 as BS
import Control.Monad
data BParser a
= BParser (BEncode -> Reply a)
runB :: BParser a -> BEncode -> Reply a
runB (BParser b) = b
data Reply a
= Ok a BEncode
| Error String
instance Monad BParser where
(BParser p) >>= f = BParser $ \b -> case p b of
Ok a b' -> runB (f a) b'
Error str -> Error str
return val = BParser $ Ok val
fail str = BParser $ \_ -> Error str
(<|>) :: BParser a -> BParser a -> BParser a
(BParser b1) <|> (BParser b2)
= BParser $ \b -> case b1 b of
Ok a b' -> Ok a b'
_ -> b2 b
runParser :: BParser a -> BEncode -> Either String a
runParser parser b = case runB parser b of
Ok a _ -> Right a
Error str -> Left str
token :: BParser BEncode
token = BParser $ \b -> Ok b b
dict :: String -> BParser BEncode
dict name = BParser $ \b -> case b of
BDict bmap | Just code <- Map.lookup name bmap
-> Ok code b
BDict _ -> Error $ "Name not found in dictionary: " ++ name
_ -> Error $ "Not a dictionary: " ++ name
list :: String -> BParser a -> BParser [a]
list name p
= dict name >>= \lst ->
BParser $ \b -> case lst of
BList bs -> foldr cat (Ok [] b) (map (runB p) bs)
_ -> Error $ "Not a list: " ++ name
where cat (Ok v _) (Ok vs b) = Ok (v:vs) b
cat (Ok _ _) (Error str) = Error str
cat (Error str) _ = Error str
optional :: BParser a -> BParser (Maybe a)
optional p = liftM Just p <|> return Nothing
bstring :: BParser BEncode -> BParser String
bstring p = do b <- p
case b of
BString str -> return (BS.unpack str)
_ -> fail $ "Expected BString, found: " ++ show b
bbytestring :: BParser BEncode -> BParser BS.ByteString
bbytestring p = do b <- p
case b of
BString str -> return str
_ -> fail $ "Expected BString, found: " ++ show b
bint :: BParser BEncode -> BParser Int
bint p = do b <- p
case b of
BInt int -> return int
_ -> fail $ "Expected BInt, found: " ++ show b
setInput :: BEncode -> BParser ()
setInput b = BParser $ \_ -> Ok () b