{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  BParser
-- Copyright   :  (c) 2005 Lemmih <lemmih@gmail.com>
-- License     :  BSD3
-- Maintainer  :  lemmih@gmail.com
-- Stability   :  stable
-- Portability :  portable
--
-- A parsec style parser for BEncoded data
-----------------------------------------------------------------------------
module Data.BEncode.Parser {-#
    DEPRECATED "Use \"Data.BEncode.Reader\" instead" #-}
    ( BParser
    , runParser
    , token
    , dict
    , list
    , optional
    , bstring
    , bbytestring
    , bint
    , setInput
    , (<|>)
    ) where


import           Control.Applicative        hiding (optional)
import           Control.Monad
import           Data.BEncode
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Map                   as Map

#if MIN_VERSION_base(4,13,0)
import qualified Control.Monad.Fail as Fail
#endif

data BParser a
    = BParser (BEncode -> Reply a)

instance Alternative BParser where
    <|> :: BParser a -> BParser a -> BParser a
(<|>) = BParser a -> BParser a -> BParser a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
    empty :: BParser a
empty = BParser a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance MonadPlus BParser where
    mzero :: BParser a
mzero = (BEncode -> Reply a) -> BParser a
forall a. (BEncode -> Reply a) -> BParser a
BParser ((BEncode -> Reply a) -> BParser a)
-> (BEncode -> Reply a) -> BParser a
forall a b. (a -> b) -> a -> b
$ \_ -> String -> Reply a
forall a. String -> Reply a
Error "mzero"
    mplus :: BParser a -> BParser a -> BParser a
mplus (BParser a :: BEncode -> Reply a
a) (BParser b :: BEncode -> Reply a
b) = (BEncode -> Reply a) -> BParser a
forall a. (BEncode -> Reply a) -> BParser a
BParser ((BEncode -> Reply a) -> BParser a)
-> (BEncode -> Reply a) -> BParser a
forall a b. (a -> b) -> a -> b
$ \st :: BEncode
st -> case BEncode -> Reply a
a BEncode
st of
                                                       Error _err :: String
_err -> BEncode -> Reply a
b BEncode
st
                                                       ok :: Reply a
ok         -> Reply a
ok


runB :: BParser a -> BEncode -> Reply a
runB :: BParser a -> BEncode -> Reply a
runB (BParser b :: BEncode -> Reply a
b) = BEncode -> Reply a
b

data Reply a
    = Ok a BEncode
    | Error String

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

instance Monad BParser where
    (BParser p :: BEncode -> Reply a
p) >>= :: BParser a -> (a -> BParser b) -> BParser b
>>= f :: a -> BParser b
f = (BEncode -> Reply b) -> BParser b
forall a. (BEncode -> Reply a) -> BParser a
BParser ((BEncode -> Reply b) -> BParser b)
-> (BEncode -> Reply b) -> BParser b
forall a b. (a -> b) -> a -> b
$ \b :: BEncode
b -> case BEncode -> Reply a
p BEncode
b of
                                          Ok a :: a
a b' :: BEncode
b' -> BParser b -> BEncode -> Reply b
forall a. BParser a -> BEncode -> Reply a
runB (a -> BParser b
f a
a) BEncode
b'
                                          Error str :: String
str -> String -> Reply b
forall a. String -> Reply a
Error String
str
    return :: a -> BParser a
return val :: a
val = (BEncode -> Reply a) -> BParser a
forall a. (BEncode -> Reply a) -> BParser a
BParser ((BEncode -> Reply a) -> BParser a)
-> (BEncode -> Reply a) -> BParser a
forall a b. (a -> b) -> a -> b
$ a -> BEncode -> Reply a
forall a. a -> BEncode -> Reply a
Ok a
val
#if MIN_VERSION_base(4,13,0)
instance Fail.MonadFail BParser where
#endif
    fail :: String -> BParser a
fail str :: String
str = (BEncode -> Reply a) -> BParser a
forall a. (BEncode -> Reply a) -> BParser a
BParser ((BEncode -> Reply a) -> BParser a)
-> (BEncode -> Reply a) -> BParser a
forall a b. (a -> b) -> a -> b
$ \_ -> String -> Reply a
forall a. String -> Reply a
Error String
str

instance Functor BParser where
    fmap :: (a -> b) -> BParser a -> BParser b
fmap = (a -> b) -> BParser a -> BParser b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM


runParser :: BParser a -> BEncode -> Either String a
runParser :: BParser a -> BEncode -> Either String a
runParser parser :: BParser a
parser b :: BEncode
b = case BParser a -> BEncode -> Reply a
forall a. BParser a -> BEncode -> Reply a
runB BParser a
parser BEncode
b of
                       Ok a :: a
a _ -> a -> Either String a
forall a b. b -> Either a b
Right a
a
                       Error str :: String
str -> String -> Either String a
forall a b. a -> Either a b
Left String
str

token :: BParser BEncode
token :: BParser BEncode
token = (BEncode -> Reply BEncode) -> BParser BEncode
forall a. (BEncode -> Reply a) -> BParser a
BParser ((BEncode -> Reply BEncode) -> BParser BEncode)
-> (BEncode -> Reply BEncode) -> BParser BEncode
forall a b. (a -> b) -> a -> b
$ \b :: BEncode
b -> BEncode -> BEncode -> Reply BEncode
forall a. a -> BEncode -> Reply a
Ok BEncode
b BEncode
b

dict :: String -> BParser BEncode
dict :: String -> BParser BEncode
dict name :: String
name = (BEncode -> Reply BEncode) -> BParser BEncode
forall a. (BEncode -> Reply a) -> BParser a
BParser ((BEncode -> Reply BEncode) -> BParser BEncode)
-> (BEncode -> Reply BEncode) -> BParser BEncode
forall a b. (a -> b) -> a -> b
$ \b :: BEncode
b -> case BEncode
b of
                              BDict bmap :: Map String BEncode
bmap | Just code :: BEncode
code <- String -> Map String BEncode -> Maybe BEncode
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
name Map String BEncode
bmap
                                   -> BEncode -> BEncode -> Reply BEncode
forall a. a -> BEncode -> Reply a
Ok BEncode
code BEncode
b
                              BDict _ -> String -> Reply BEncode
forall a. String -> Reply a
Error (String -> Reply BEncode) -> String -> Reply BEncode
forall a b. (a -> b) -> a -> b
$ "Name not found in dictionary: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
                              _ -> String -> Reply BEncode
forall a. String -> Reply a
Error (String -> Reply BEncode) -> String -> Reply BEncode
forall a b. (a -> b) -> a -> b
$ "Not a dictionary: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name

list :: String -> BParser a -> BParser [a]
list :: String -> BParser a -> BParser [a]
list name :: String
name p :: BParser a
p
    = String -> BParser BEncode
dict String
name BParser BEncode -> (BEncode -> BParser [a]) -> BParser [a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \lst :: BEncode
lst ->
      (BEncode -> Reply [a]) -> BParser [a]
forall a. (BEncode -> Reply a) -> BParser a
BParser ((BEncode -> Reply [a]) -> BParser [a])
-> (BEncode -> Reply [a]) -> BParser [a]
forall a b. (a -> b) -> a -> b
$ \b :: BEncode
b -> case BEncode
lst of
                      BList bs :: [BEncode]
bs -> (BEncode -> Reply [a] -> Reply [a])
-> Reply [a] -> [BEncode] -> Reply [a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Reply a -> Reply [a] -> Reply [a]
forall a. Reply a -> Reply [a] -> Reply [a]
cat (Reply a -> Reply [a] -> Reply [a])
-> (BEncode -> Reply a) -> BEncode -> Reply [a] -> Reply [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BParser a -> BEncode -> Reply a
forall a. BParser a -> BEncode -> Reply a
runB BParser a
p) ([a] -> BEncode -> Reply [a]
forall a. a -> BEncode -> Reply a
Ok [] BEncode
b) [BEncode]
bs
                      _ -> String -> Reply [a]
forall a. String -> Reply a
Error (String -> Reply [a]) -> String -> Reply [a]
forall a b. (a -> b) -> a -> b
$ "Not a list: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
    where cat :: Reply a -> Reply [a] -> Reply [a]
cat (Ok v :: a
v _) (Ok vs :: [a]
vs b :: BEncode
b) = [a] -> BEncode -> Reply [a]
forall a. a -> BEncode -> Reply a
Ok (a
va -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
vs) BEncode
b
          cat (Ok _ _) (Error str :: String
str) = String -> Reply [a]
forall a. String -> Reply a
Error String
str
          cat (Error str :: String
str) _ = String -> Reply [a]
forall a. String -> Reply a
Error String
str

optional :: BParser a -> BParser (Maybe a)
optional :: BParser a -> BParser (Maybe a)
optional p :: BParser a
p = (a -> Maybe a) -> BParser a -> BParser (Maybe a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Maybe a
forall a. a -> Maybe a
Just BParser a
p BParser (Maybe a) -> BParser (Maybe a) -> BParser (Maybe a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe a -> BParser (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

bstring :: BParser BEncode -> BParser String
bstring :: BParser BEncode -> BParser String
bstring p :: BParser BEncode
p = do BEncode
b <- BParser BEncode
p
               case BEncode
b of
                 BString str :: ByteString
str -> String -> BParser String
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> String
L.unpack ByteString
str)
                 _ -> String -> BParser String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> BParser String) -> String -> BParser String
forall a b. (a -> b) -> a -> b
$ "Expected BString, found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ BEncode -> String
forall a. Show a => a -> String
show BEncode
b

bbytestring :: BParser BEncode -> BParser L.ByteString
bbytestring :: BParser BEncode -> BParser ByteString
bbytestring p :: BParser BEncode
p = do BEncode
b <- BParser BEncode
p
                   case BEncode
b of
                     BString str :: ByteString
str -> ByteString -> BParser ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
str
                     _ -> String -> BParser ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> BParser ByteString) -> String -> BParser ByteString
forall a b. (a -> b) -> a -> b
$ "Expected BString, found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ BEncode -> String
forall a. Show a => a -> String
show BEncode
b

bint :: BParser BEncode -> BParser Integer
bint :: BParser BEncode -> BParser Integer
bint p :: BParser BEncode
p = do BEncode
b <- BParser BEncode
p
            case BEncode
b of
              BInt int :: Integer
int -> Integer -> BParser Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
int
              _ -> String -> BParser Integer
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> BParser Integer) -> String -> BParser Integer
forall a b. (a -> b) -> a -> b
$ "Expected BInt, found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ BEncode -> String
forall a. Show a => a -> String
show BEncode
b

setInput :: BEncode -> BParser ()
setInput :: BEncode -> BParser ()
setInput b :: BEncode
b = (BEncode -> Reply ()) -> BParser ()
forall a. (BEncode -> Reply a) -> BParser a
BParser ((BEncode -> Reply ()) -> BParser ())
-> (BEncode -> Reply ()) -> BParser ()
forall a b. (a -> b) -> a -> b
$ \_ -> () -> BEncode -> Reply ()
forall a. a -> BEncode -> Reply a
Ok () BEncode
b