-- |
--   Copyright   :  (c) Sam Truzjan 2013
--   License     :  BSD3
--   Maintainer  :  pxqr.sta@gmail.com
--   Stability   :  stable
--   Portability :  portable
--
--   This module provides convinient and fast way to serialize,
--   deserealize and construct/destructure Bencoded values with
--   optional fields.
--
--   It supports four different types of values:
--
--     * byte strings — represented as 'ByteString';
--
--     * integers     — represented as 'Integer';
--
--     * lists        - represented as ordinary lists;
--
--     * dictionaries — represented as 'BDictMap';
--
--    To serialize any other types we need to make conversion.  To
--    make conversion more convenient there is type class for it:
--    'BEncode'. Any textual strings are considered as UTF8 encoded
--    'Text'.
--
--    The complete Augmented BNF syntax for bencoding format is:
--
--
--    > <BE>    ::= <DICT> | <LIST> | <INT> | <STR>
--    >
--    > <DICT>  ::= "d" 1 * (<STR> <BE>) "e"
--    > <LIST>  ::= "l" 1 * <BE>         "e"
--    > <INT>   ::= "i"     <SNUM>       "e"
--    > <STR>   ::= <NUM> ":" n * <CHAR>; where n equals the <NUM>
--    >
--    > <SNUM>  ::= "-" <NUM> / <NUM>
--    > <NUM>   ::= 1 * <DIGIT>
--    > <CHAR>  ::= %
--    > <DIGIT> ::= "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9"
--
--
--    This module is considered to be imported qualified, for example:
--
--    > import Data.BEncode as BE
--
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE Trustworthy       #-}
{-# LANGUAGE CPP               #-}
{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE TypeOperators          #-}
{-# LANGUAGE DefaultSignatures      #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE ScopedTypeVariables    #-}
#endif

module Data.BEncode
       ( BValue (..)
       , BEncode (..)
       , encode
       , decode

         -- * Helpers
         -- ** Building
       , Assoc
       , (.=!)
       , (.=?)
       , (.:)
       , endDict
       , toDict

         -- ** Extraction
       , Get
       , Result
       , decodingError
       , fromDict
       , lookAhead

       , next
       , req
       , opt
       , field
       , match

       , (<$>!)
       , (<$>?)
       , (<*>!)
       , (<*>?)
       ) where


import Control.Applicative
import Control.Monad
import Control.Monad.State
#if MIN_VERSION_mtl(2, 2, 0)
import Control.Monad.Except
#else
import Control.Monad.Error
#endif
import Data.Int
import Data.List as L
#if __GLASGOW_HASKELL__ < 808
import Data.Semigroup ((<>))
#endif
import Data.Word          (Word8, Word16, Word32, Word64)
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as Lazy
import           Data.Text (Text)
import qualified Data.Text.Encoding as T
import           Data.Typeable
import           Data.Version
import qualified Text.ParserCombinators.ReadP as ReadP

#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (Monoid (mempty))
import Data.Word (Word)
#endif

#if __GLASGOW_HASKELL__ >= 702
import GHC.Generics
#endif

import Data.BEncode.BDict as BD
import Data.BEncode.Internal
import Data.BEncode.Types


-- | Result used in decoding operations.
type Result = Either String

-- | This class is used to define new datatypes that could be easily
-- serialized using bencode format.
--
--   By default 'BEncode' have a generic implementation; suppose
--   the following datatype:
--
-- > data List a = C { _head  :: a
-- >                 , __tail :: List a }
-- >             | N
-- >               deriving Generic
--
--   If we don't need to obey any particular specification or
--   standard, the default instance could be derived automatically
--   from the 'Generic' instance:
--
-- > instance BEncode a => BEncode (List a)
--
--   Example of derived 'toBEncode' result:
--
-- > > toBEncode (C 123 $ C 1 N)
-- > BDict (fromList [("head",BInteger 123),("tail",BList [])])
--
--  Note that prefixed underscore characters are omitted since they
--  are usually used for lens.
--
class BEncode a where
  -- | See an example of implementation here 'Assoc'
  toBEncode   :: a -> BValue

#if __GLASGOW_HASKELL__ >= 702
  default toBEncode
    :: Generic a
    => GBEncodable (Rep a) BValue
    => a -> BValue

  toBEncode = Rep a Any -> BValue
forall (f :: * -> *) e a. GBEncodable f e => f a -> e
gto (Rep a Any -> BValue) -> (a -> Rep a Any) -> a -> BValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from
#endif

  -- | See an example of implementation here 'Get'.
  fromBEncode :: BValue -> Result a

#if __GLASGOW_HASKELL__ >= 702
  default fromBEncode
    :: Generic a
    => GBEncodable (Rep a) BValue
    => BValue -> Result a

  fromBEncode BValue
x = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> a) -> Either String (Rep a Any) -> Result a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BValue -> Either String (Rep a Any)
forall (f :: * -> *) e a. GBEncodable f e => e -> Result (f a)
gfrom BValue
x
#endif

-- | Typically used to throw an decoding error in fromBEncode; when
-- BEncode value to match expected value.
decodingError :: String -> Result a
decodingError :: String -> Result a
decodingError String
s = String -> Result a
forall a b. a -> Either a b
Left (String
"fromBEncode: unable to decode " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
{-# INLINE decodingError #-}

{--------------------------------------------------------------------
  Generics
--------------------------------------------------------------------}

{- NOTE: SELECTORS FOLDING/UNFOLDING
Both List and Map are monoids:

* if fields are named, we fold record to the map;
* otherwise we collect fields using list;

and then unify them using BDict and BList constrs.
-}

#if __GLASGOW_HASKELL__ >= 702

class GBEncodable f e where
  gto   :: f a -> e
  gfrom :: e -> Result (f a)

instance BEncode f
      => GBEncodable (K1 R f) BValue where
  {-# INLINE gto #-}
  gto :: K1 R f a -> BValue
gto = f -> BValue
forall a. BEncode a => a -> BValue
toBEncode (f -> BValue) -> (K1 R f a -> f) -> K1 R f a -> BValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 R f a -> f
forall i c k (p :: k). K1 i c p -> c
unK1

  {-# INLINE gfrom #-}
  gfrom :: BValue -> Result (K1 R f a)
gfrom BValue
x = f -> K1 R f a
forall k i c (p :: k). c -> K1 i c p
K1 (f -> K1 R f a) -> Either String f -> Result (K1 R f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BValue -> Either String f
forall a. BEncode a => BValue -> Result a
fromBEncode BValue
x

instance (Eq e, Monoid e)
      => GBEncodable U1 e where
  {-# INLINE gto #-}
  gto :: U1 a -> e
gto U1 a
U1 = e
forall a. Monoid a => a
mempty

  {-# INLINE gfrom #-}
  gfrom :: e -> Result (U1 a)
gfrom e
x
    | e
x e -> e -> Bool
forall a. Eq a => a -> a -> Bool
== e
forall a. Monoid a => a
mempty = U1 a -> Result (U1 a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 a
forall k (p :: k). U1 p
U1
    |   Bool
otherwise = String -> Result (U1 a)
forall a. String -> Result a
decodingError String
"U1"

instance (GBEncodable a BList, GBEncodable b BList)
      => GBEncodable (a :*: b) BList where
  {-# INLINE gto #-}
  gto :: (:*:) a b a -> BList
gto (a a
a :*: b a
b) = a a -> BList
forall (f :: * -> *) e a. GBEncodable f e => f a -> e
gto a a
a BList -> BList -> BList
forall a. [a] -> [a] -> [a]
++ b a -> BList
forall (f :: * -> *) e a. GBEncodable f e => f a -> e
gto b a
b

  {-# INLINE gfrom #-}
  gfrom :: BList -> Result ((:*:) a b a)
gfrom (BValue
x : BList
xs) = a a -> b a -> (:*:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (a a -> b a -> (:*:) a b a)
-> Either String (a a) -> Either String (b a -> (:*:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BList -> Either String (a a)
forall (f :: * -> *) e a. GBEncodable f e => e -> Result (f a)
gfrom [BValue
x] Either String (b a -> (:*:) a b a)
-> Either String (b a) -> Result ((:*:) a b a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BList -> Either String (b a)
forall (f :: * -> *) e a. GBEncodable f e => e -> Result (f a)
gfrom BList
xs
  gfrom []       = String -> Result ((:*:) a b a)
forall a. String -> Result a
decodingError String
"generic: not enough fields"

instance (GBEncodable a BDict, GBEncodable b BDict)
      => GBEncodable (a :*: b) BDict where
  {-# INLINE gto #-}
  gto :: (:*:) a b a -> BDict
gto (a a
a :*: b a
b) = a a -> BDict
forall (f :: * -> *) e a. GBEncodable f e => f a -> e
gto a a
a BDict -> BDict -> BDict
forall a. Semigroup a => a -> a -> a
<> b a -> BDict
forall (f :: * -> *) e a. GBEncodable f e => f a -> e
gto b a
b

  {-# INLINE gfrom #-}
  -- Just look at this! >.<
  gfrom :: BDict -> Result ((:*:) a b a)
gfrom BDict
dict = a a -> b a -> (:*:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (a a -> b a -> (:*:) a b a)
-> Either String (a a) -> Either String (b a -> (:*:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BDict -> Either String (a a)
forall (f :: * -> *) e a. GBEncodable f e => e -> Result (f a)
gfrom BDict
dict Either String (b a -> (:*:) a b a)
-> Either String (b a) -> Result ((:*:) a b a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BDict -> Either String (b a)
forall (f :: * -> *) e a. GBEncodable f e => e -> Result (f a)
gfrom BDict
dict


instance (GBEncodable a e, GBEncodable b e)
      =>  GBEncodable (a :+: b) e where
  {-# INLINE gto #-}
  gto :: (:+:) a b a -> e
gto (L1 a a
x) = a a -> e
forall (f :: * -> *) e a. GBEncodable f e => f a -> e
gto a a
x
  gto (R1 b a
x) = b a -> e
forall (f :: * -> *) e a. GBEncodable f e => f a -> e
gto b a
x

  {-# INLINE gfrom #-}
  gfrom :: e -> Result ((:+:) a b a)
gfrom e
x = case e -> Result (a a)
forall (f :: * -> *) e a. GBEncodable f e => e -> Result (f a)
gfrom e
x of
    Right a a
lv -> (:+:) a b a -> Result ((:+:) a b a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 a a
lv)
    Left  String
le -> do
      case e -> Result (b a)
forall (f :: * -> *) e a. GBEncodable f e => e -> Result (f a)
gfrom e
x of
        Right b a
rv -> (:+:) a b a -> Result ((:+:) a b a)
forall (m :: * -> *) a. Monad m => a -> m a
return (b a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 b a
rv)
        Left  String
re -> String -> Result ((:+:) a b a)
forall a. String -> Result a
decodingError (String -> Result ((:+:) a b a)) -> String -> Result ((:+:) a b a)
forall a b. (a -> b) -> a -> b
$ String
"generic: both" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
le String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
re

selRename :: String -> String
selRename :: String -> String
selRename = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char
'_'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==)

gfromM1S :: forall c f i p. Selector c
         => GBEncodable f BValue
         => BDict -> Result (M1 i c f p)
gfromM1S :: BDict -> Result (M1 i c f p)
gfromM1S BDict
dict
  | Just BValue
va <- BKey -> BDict -> Maybe BValue
forall a. BKey -> BDictMap a -> Maybe a
BD.lookup (String -> BKey
BC.pack (String -> String
selRename String
name)) BDict
dict = f p -> M1 i c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 i c f p) -> Either String (f p) -> Result (M1 i c f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BValue -> Either String (f p)
forall (f :: * -> *) e a. GBEncodable f e => e -> Result (f a)
gfrom BValue
va
  | Bool
otherwise = String -> Result (M1 i c f p)
forall a. String -> Result a
decodingError (String -> Result (M1 i c f p)) -> String -> Result (M1 i c f p)
forall a b. (a -> b) -> a -> b
$ String
"generic: Selector not found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
name
  where
    name :: String
name = M1 i c f p -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName (String -> M1 i c f p
forall a. HasCallStack => String -> a
error String
"gfromM1S: impossible" :: M1 i c f p)

instance (Selector s, GBEncodable f BValue)
       => GBEncodable (M1 S s f) BDict where
  {-# INLINE gto #-}
  gto :: M1 S s f a -> BDict
gto s :: M1 S s f a
s@(M1 f a
x) = String -> BKey
BC.pack (String -> String
selRename (M1 S s f a -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName M1 S s f a
s)) BKey -> BValue -> BDict
forall a. BKey -> a -> BDictMap a
`BD.singleton` f a -> BValue
forall (f :: * -> *) e a. GBEncodable f e => f a -> e
gto f a
x

  {-# INLINE gfrom #-}
  gfrom :: BDict -> Result (M1 S s f a)
gfrom = BDict -> Result (M1 S s f a)
forall (c :: Meta) (f :: * -> *) i p.
(Selector c, GBEncodable f BValue) =>
BDict -> Result (M1 i c f p)
gfromM1S

-- TODO DList
instance GBEncodable f BValue
      => GBEncodable (M1 S s f) BList where
  {-# INLINE gto #-}
  gto :: M1 S s f a -> BList
gto (M1 f a
x) = [f a -> BValue
forall (f :: * -> *) e a. GBEncodable f e => f a -> e
gto f a
x]

  gfrom :: BList -> Result (M1 S s f a)
gfrom [BValue
x] = f a -> M1 S s f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 S s f a) -> Either String (f a) -> Result (M1 S s f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BValue -> Either String (f a)
forall (f :: * -> *) e a. GBEncodable f e => e -> Result (f a)
gfrom BValue
x
  gfrom BList
_   = String -> Result (M1 S s f a)
forall a. String -> Result a
decodingError String
"generic: empty selector"
  {-# INLINE gfrom #-}

instance (Constructor c, GBEncodable f BDict, GBEncodable f BList)
       => GBEncodable (M1 C c f) BValue where
  {-# INLINE gto #-}
  gto :: M1 C c f a -> BValue
gto con :: M1 C c f a
con@(M1 f a
x)
      | M1 C c f a -> Bool
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Bool
conIsRecord M1 C c f a
con = BDict -> BValue
BDict (f a -> BDict
forall (f :: * -> *) e a. GBEncodable f e => f a -> e
gto f a
x)
      |    Bool
otherwise    = BList -> BValue
BList (f a -> BList
forall (f :: * -> *) e a. GBEncodable f e => f a -> e
gto f a
x)

  {-# INLINE gfrom #-}
  gfrom :: BValue -> Result (M1 C c f a)
gfrom (BDict BDict
a) = f a -> M1 C c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 C c f a) -> Either String (f a) -> Result (M1 C c f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BDict -> Either String (f a)
forall (f :: * -> *) e a. GBEncodable f e => e -> Result (f a)
gfrom BDict
a
  gfrom (BList BList
a) = f a -> M1 C c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 C c f a) -> Either String (f a) -> Result (M1 C c f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BList -> Either String (f a)
forall (f :: * -> *) e a. GBEncodable f e => e -> Result (f a)
gfrom BList
a
  gfrom BValue
_         = String -> Result (M1 C c f a)
forall a. String -> Result a
decodingError String
"generic: Constr"

instance GBEncodable f e
      => GBEncodable (M1 D d f) e where
  {-# INLINE gto #-}
  gto :: M1 D d f a -> e
gto (M1 f a
x) = f a -> e
forall (f :: * -> *) e a. GBEncodable f e => f a -> e
gto f a
x

  {-# INLINE gfrom #-}
  gfrom :: e -> Result (M1 D d f a)
gfrom e
x = f a -> M1 D d f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 D d f a) -> Either String (f a) -> Result (M1 D d f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> e -> Either String (f a)
forall (f :: * -> *) e a. GBEncodable f e => e -> Result (f a)
gfrom e
x

#endif

{--------------------------------------------------------------------
--  Native instances
--------------------------------------------------------------------}

instance BEncode BValue where
  toBEncode :: BValue -> BValue
toBEncode = BValue -> BValue
forall a. a -> a
id
  {-# INLINE toBEncode #-}

  fromBEncode :: BValue -> Result BValue
fromBEncode = BValue -> Result BValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE fromBEncode #-}

instance BEncode BInteger where
  toBEncode :: BInteger -> BValue
toBEncode = BInteger -> BValue
BInteger
  {-# INLINE toBEncode #-}

  fromBEncode :: BValue -> Result BInteger
fromBEncode (BInteger BInteger
i) = BInteger -> Result BInteger
forall (f :: * -> *) a. Applicative f => a -> f a
pure BInteger
i
  fromBEncode BValue
_            = String -> Result BInteger
forall a. String -> Result a
decodingError String
"BInteger"
  {-# INLINE fromBEncode #-}

instance BEncode BString where
  toBEncode :: BKey -> BValue
toBEncode = BKey -> BValue
BString
  {-# INLINE toBEncode #-}

  fromBEncode :: BValue -> Result BKey
fromBEncode (BString BKey
s) = BKey -> Result BKey
forall (f :: * -> *) a. Applicative f => a -> f a
pure BKey
s
  fromBEncode BValue
_           = String -> Result BKey
forall a. String -> Result a
decodingError String
"BString"
  {-# INLINE fromBEncode #-}

{- NOTE: those overlap with instance BEncodable a => BEncodable [a]

instance BEncodable BList where
  toBEncode = BList
  {-# INLINE toBEncode #-}

  fromBEncode (BList xs) = pure xs
  fromBEncode _          = decodingError "BList"
  {-# INLINE fromBEncode #-}

-}

instance BEncode BDict where
  toBEncode :: BDict -> BValue
toBEncode   = BDict -> BValue
BDict
  {-# INLINE toBEncode #-}

  fromBEncode :: BValue -> Result BDict
fromBEncode (BDict BDict
d) = BDict -> Result BDict
forall (f :: * -> *) a. Applicative f => a -> f a
pure BDict
d
  fromBEncode BValue
_         = String -> Result BDict
forall a. String -> Result a
decodingError String
"BDict"
  {-# INLINE fromBEncode #-}

{--------------------------------------------------------------------
--  Integral instances
--------------------------------------------------------------------}

{- NOTE: instance Integral a => BEncodable a
   requires -XUndecidableInstances, so we avoid it
-}

toBEncodeIntegral :: Integral a => a -> BValue
toBEncodeIntegral :: a -> BValue
toBEncodeIntegral = BInteger -> BValue
BInteger (BInteger -> BValue) -> (a -> BInteger) -> a -> BValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> BInteger
forall a b. (Integral a, Num b) => a -> b
fromIntegral
{-# INLINE toBEncodeIntegral #-}

fromBEncodeIntegral :: forall a. Typeable a => Integral a => BValue -> Result a
fromBEncodeIntegral :: BValue -> Result a
fromBEncodeIntegral (BInteger BInteger
i) = a -> Result a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BInteger -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral BInteger
i)
fromBEncodeIntegral BValue
_
  = String -> Result a
forall a. String -> Result a
decodingError (String -> Result a) -> String -> Result a
forall a b. (a -> b) -> a -> b
$ TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (String -> a
forall a. HasCallStack => String -> a
error String
"fromBEncodeIntegral: imposible" :: a)
{-# INLINE fromBEncodeIntegral #-}


instance BEncode Word8 where
  toBEncode :: Word8 -> BValue
toBEncode = Word8 -> BValue
forall a. Integral a => a -> BValue
toBEncodeIntegral
  {-# INLINE toBEncode #-}

  fromBEncode :: BValue -> Result Word8
fromBEncode = BValue -> Result Word8
forall a. (Typeable a, Integral a) => BValue -> Result a
fromBEncodeIntegral
  {-# INLINE fromBEncode #-}

instance BEncode Word16 where
  toBEncode :: Word16 -> BValue
toBEncode = Word16 -> BValue
forall a. Integral a => a -> BValue
toBEncodeIntegral
  {-# INLINE toBEncode #-}

  fromBEncode :: BValue -> Result Word16
fromBEncode = BValue -> Result Word16
forall a. (Typeable a, Integral a) => BValue -> Result a
fromBEncodeIntegral
  {-# INLINE fromBEncode #-}

instance BEncode Word32 where
  toBEncode :: Word32 -> BValue
toBEncode = Word32 -> BValue
forall a. Integral a => a -> BValue
toBEncodeIntegral
  {-# INLINE toBEncode #-}

  fromBEncode :: BValue -> Result Word32
fromBEncode = BValue -> Result Word32
forall a. (Typeable a, Integral a) => BValue -> Result a
fromBEncodeIntegral
  {-# INLINE fromBEncode #-}

instance BEncode Word64 where
  toBEncode :: Word64 -> BValue
toBEncode = Word64 -> BValue
forall a. Integral a => a -> BValue
toBEncodeIntegral
  {-# INLINE toBEncode #-}

  fromBEncode :: BValue -> Result Word64
fromBEncode = BValue -> Result Word64
forall a. (Typeable a, Integral a) => BValue -> Result a
fromBEncodeIntegral
  {-# INLINE fromBEncode #-}

instance BEncode Word where
  toBEncode :: Word -> BValue
toBEncode = Word -> BValue
forall a. Integral a => a -> BValue
toBEncodeIntegral
  {-# INLINE toBEncode #-}

  fromBEncode :: BValue -> Result Word
fromBEncode = BValue -> Result Word
forall a. (Typeable a, Integral a) => BValue -> Result a
fromBEncodeIntegral
  {-# INLINE fromBEncode #-}

instance BEncode Int8 where
  toBEncode :: Int8 -> BValue
toBEncode = Int8 -> BValue
forall a. Integral a => a -> BValue
toBEncodeIntegral
  {-# INLINE toBEncode #-}

  fromBEncode :: BValue -> Result Int8
fromBEncode = BValue -> Result Int8
forall a. (Typeable a, Integral a) => BValue -> Result a
fromBEncodeIntegral
  {-# INLINE fromBEncode #-}

instance BEncode Int16 where
  toBEncode :: Int16 -> BValue
toBEncode = Int16 -> BValue
forall a. Integral a => a -> BValue
toBEncodeIntegral
  {-# INLINE toBEncode #-}

  fromBEncode :: BValue -> Result Int16
fromBEncode = BValue -> Result Int16
forall a. (Typeable a, Integral a) => BValue -> Result a
fromBEncodeIntegral
  {-# INLINE fromBEncode #-}

instance BEncode Int32 where
  toBEncode :: Int32 -> BValue
toBEncode = Int32 -> BValue
forall a. Integral a => a -> BValue
toBEncodeIntegral
  {-# INLINE toBEncode #-}

  fromBEncode :: BValue -> Result Int32
fromBEncode = BValue -> Result Int32
forall a. (Typeable a, Integral a) => BValue -> Result a
fromBEncodeIntegral
  {-# INLINE fromBEncode #-}

instance BEncode Int64 where
  toBEncode :: Int64 -> BValue
toBEncode = Int64 -> BValue
forall a. Integral a => a -> BValue
toBEncodeIntegral
  {-# INLINE toBEncode #-}

  fromBEncode :: BValue -> Result Int64
fromBEncode = BValue -> Result Int64
forall a. (Typeable a, Integral a) => BValue -> Result a
fromBEncodeIntegral
  {-# INLINE fromBEncode #-}

instance BEncode Int where
  toBEncode :: Int -> BValue
toBEncode = Int -> BValue
forall a. Integral a => a -> BValue
toBEncodeIntegral
  {-# INLINE toBEncode #-}

  fromBEncode :: BValue -> Result Int
fromBEncode = BValue -> Result Int
forall a. (Typeable a, Integral a) => BValue -> Result a
fromBEncodeIntegral
  {-# INLINE fromBEncode #-}

{--------------------------------------------------------------------
--  Derived instances
--------------------------------------------------------------------}

instance BEncode Bool where
  toBEncode :: Bool -> BValue
toBEncode = Int -> BValue
forall a. BEncode a => a -> BValue
toBEncode (Int -> BValue) -> (Bool -> Int) -> Bool -> BValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum
  {-# INLINE toBEncode #-}

  fromBEncode :: BValue -> Result Bool
fromBEncode BValue
b = do
    Int
i <- BValue -> Result Int
forall a. BEncode a => BValue -> Result a
fromBEncode BValue
b
    case Int
i :: Int of
      Int
0 -> Bool -> Result Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      Int
1 -> Bool -> Result Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      Int
_ -> String -> Result Bool
forall a. String -> Result a
decodingError String
"Bool"
  {-# INLINE fromBEncode #-}

instance BEncode Text where
  toBEncode :: Text -> BValue
toBEncode = BKey -> BValue
forall a. BEncode a => a -> BValue
toBEncode (BKey -> BValue) -> (Text -> BKey) -> Text -> BValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> BKey
T.encodeUtf8
  {-# INLINE toBEncode #-}

  fromBEncode :: BValue -> Result Text
fromBEncode BValue
b = BKey -> Text
T.decodeUtf8 (BKey -> Text) -> Result BKey -> Result Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BValue -> Result BKey
forall a. BEncode a => BValue -> Result a
fromBEncode BValue
b
  {-# INLINE fromBEncode #-}

instance BEncode a => BEncode [a] where
  {-# SPECIALIZE instance BEncode BList #-}
  toBEncode :: [a] -> BValue
toBEncode = BList -> BValue
BList (BList -> BValue) -> ([a] -> BList) -> [a] -> BValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> BValue) -> [a] -> BList
forall a b. (a -> b) -> [a] -> [b]
L.map a -> BValue
forall a. BEncode a => a -> BValue
toBEncode
  {-# INLINE toBEncode #-}

  fromBEncode :: BValue -> Result [a]
fromBEncode (BList BList
xs) = (BValue -> Either String a) -> BList -> Result [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM BValue -> Either String a
forall a. BEncode a => BValue -> Result a
fromBEncode BList
xs
  fromBEncode BValue
_          = String -> Result [a]
forall a. String -> Result a
decodingError String
"list"
  {-# INLINE fromBEncode #-}

{-
instance BEncode a => BEncode (Map BKey a) where
  {-# SPECIALIZE instance BEncode (Map BKey BValue) #-}
  toBEncode = BDict .  -- BD.map toBEncode
  {-# INLINE toBEncode #-}

  fromBEncode (BDict d) = traverse fromBEncode d
  fromBEncode _         = decodingError "dictionary"
  {-# INLINE fromBEncode #-}

instance (Eq a, BEncode a) => BEncode (Set a) where
  {-# SPECIALIZE instance BEncode (Set BValue)  #-}
  toBEncode = BList . map toBEncode . S.toAscList
  {-# INLINE toBEncode #-}

  fromBEncode (BList xs) = S.fromAscList <$> traverse fromBEncode xs
  fromBEncode _          = decodingError "Data.Set"
  {-# INLINE fromBEncode #-}
-}
instance BEncode Version where
  toBEncode :: Version -> BValue
toBEncode = BKey -> BValue
forall a. BEncode a => a -> BValue
toBEncode (BKey -> BValue) -> (Version -> BKey) -> Version -> BValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> BKey
BC.pack (String -> BKey) -> (Version -> String) -> Version -> BKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> String
showVersion
  {-# INLINE toBEncode #-}

  fromBEncode :: BValue -> Result Version
fromBEncode (BString BKey
bs)
    | [(Version
v, String
_)] <- ReadP Version -> ReadS Version
forall a. ReadP a -> ReadS a
ReadP.readP_to_S ReadP Version
parseVersion (BKey -> String
BC.unpack BKey
bs)
    = Version -> Result Version
forall (m :: * -> *) a. Monad m => a -> m a
return Version
v
  fromBEncode BValue
_ = String -> Result Version
forall a. String -> Result a
decodingError String
"Data.Version"
  {-# INLINE fromBEncode #-}

{--------------------------------------------------------------------
--  Tuple instances
--------------------------------------------------------------------}

instance BEncode () where
  toBEncode :: () -> BValue
toBEncode () = BList -> BValue
BList []
  {-# INLINE toBEncode #-}

  fromBEncode :: BValue -> Result ()
fromBEncode (BList []) = () -> Result ()
forall a b. b -> Either a b
Right ()
  fromBEncode BValue
_          = String -> Result ()
forall a. String -> Result a
decodingError String
"Unable to decode unit value"
  {-# INLINE fromBEncode #-}

instance (BEncode a, BEncode b) => BEncode (a, b) where
  {-# SPECIALIZE instance (BEncode b) => BEncode (BValue, b) #-}
  {-# SPECIALIZE instance (BEncode a) => BEncode (a, BValue) #-}
  {-# SPECIALIZE instance BEncode (BValue, BValue) #-}
  toBEncode :: (a, b) -> BValue
toBEncode (a
a, b
b) = BList -> BValue
BList [a -> BValue
forall a. BEncode a => a -> BValue
toBEncode a
a, b -> BValue
forall a. BEncode a => a -> BValue
toBEncode b
b]
  {-# INLINE toBEncode #-}

  fromBEncode :: BValue -> Result (a, b)
fromBEncode (BList [BValue
a, BValue
b]) = (,) (a -> b -> (a, b))
-> Either String a -> Either String (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BValue -> Either String a
forall a. BEncode a => BValue -> Result a
fromBEncode BValue
a Either String (b -> (a, b)) -> Either String b -> Result (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BValue -> Either String b
forall a. BEncode a => BValue -> Result a
fromBEncode BValue
b
  fromBEncode BValue
_              = String -> Result (a, b)
forall a. String -> Result a
decodingError String
"Unable to decode a pair."
  {-# INLINE fromBEncode #-}

instance (BEncode a, BEncode b, BEncode c) => BEncode (a, b, c) where
  toBEncode :: (a, b, c) -> BValue
toBEncode (a
a, b
b, c
c) = BList -> BValue
BList [a -> BValue
forall a. BEncode a => a -> BValue
toBEncode a
a, b -> BValue
forall a. BEncode a => a -> BValue
toBEncode b
b, c -> BValue
forall a. BEncode a => a -> BValue
toBEncode c
c]
  {-# INLINE toBEncode #-}

  fromBEncode :: BValue -> Result (a, b, c)
fromBEncode (BList [BValue
a, BValue
b, BValue
c]) =
    (,,) (a -> b -> c -> (a, b, c))
-> Either String a -> Either String (b -> c -> (a, b, c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BValue -> Either String a
forall a. BEncode a => BValue -> Result a
fromBEncode BValue
a Either String (b -> c -> (a, b, c))
-> Either String b -> Either String (c -> (a, b, c))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BValue -> Either String b
forall a. BEncode a => BValue -> Result a
fromBEncode BValue
b Either String (c -> (a, b, c))
-> Either String c -> Result (a, b, c)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BValue -> Either String c
forall a. BEncode a => BValue -> Result a
fromBEncode BValue
c
  fromBEncode BValue
_ = String -> Result (a, b, c)
forall a. String -> Result a
decodingError String
"Unable to decode a triple"
  {-# INLINE fromBEncode #-}

instance (BEncode a, BEncode b, BEncode c, BEncode d)
         => BEncode (a, b, c, d) where
  toBEncode :: (a, b, c, d) -> BValue
toBEncode (a
a, b
b, c
c, d
d) = BList -> BValue
BList [ a -> BValue
forall a. BEncode a => a -> BValue
toBEncode a
a, b -> BValue
forall a. BEncode a => a -> BValue
toBEncode b
b
                                 , c -> BValue
forall a. BEncode a => a -> BValue
toBEncode c
c, d -> BValue
forall a. BEncode a => a -> BValue
toBEncode d
d
                                 ]
  {-# INLINE toBEncode #-}

  fromBEncode :: BValue -> Result (a, b, c, d)
fromBEncode (BList [BValue
a, BValue
b, BValue
c, BValue
d]) =
    (,,,) (a -> b -> c -> d -> (a, b, c, d))
-> Either String a -> Either String (b -> c -> d -> (a, b, c, d))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BValue -> Either String a
forall a. BEncode a => BValue -> Result a
fromBEncode BValue
a Either String (b -> c -> d -> (a, b, c, d))
-> Either String b -> Either String (c -> d -> (a, b, c, d))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BValue -> Either String b
forall a. BEncode a => BValue -> Result a
fromBEncode BValue
b
          Either String (c -> d -> (a, b, c, d))
-> Either String c -> Either String (d -> (a, b, c, d))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BValue -> Either String c
forall a. BEncode a => BValue -> Result a
fromBEncode BValue
c Either String (d -> (a, b, c, d))
-> Either String d -> Result (a, b, c, d)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BValue -> Either String d
forall a. BEncode a => BValue -> Result a
fromBEncode BValue
d
  fromBEncode BValue
_ = String -> Result (a, b, c, d)
forall a. String -> Result a
decodingError String
"Unable to decode a tuple4"
  {-# INLINE fromBEncode #-}

instance (BEncode a, BEncode b, BEncode c, BEncode d, BEncode e)
      =>  BEncode (a, b, c, d, e) where
  toBEncode :: (a, b, c, d, e) -> BValue
toBEncode (a
a, b
b, c
c, d
d, e
e) = BList -> BValue
BList [ a -> BValue
forall a. BEncode a => a -> BValue
toBEncode a
a, b -> BValue
forall a. BEncode a => a -> BValue
toBEncode b
b
                                 , c -> BValue
forall a. BEncode a => a -> BValue
toBEncode c
c, d -> BValue
forall a. BEncode a => a -> BValue
toBEncode d
d
                                 , e -> BValue
forall a. BEncode a => a -> BValue
toBEncode e
e
                                 ]
  {-# INLINE toBEncode #-}

  fromBEncode :: BValue -> Result (a, b, c, d, e)
fromBEncode (BList [BValue
a, BValue
b, BValue
c, BValue
d, BValue
e]) =
    (,,,,) (a -> b -> c -> d -> e -> (a, b, c, d, e))
-> Either String a
-> Either String (b -> c -> d -> e -> (a, b, c, d, e))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BValue -> Either String a
forall a. BEncode a => BValue -> Result a
fromBEncode BValue
a Either String (b -> c -> d -> e -> (a, b, c, d, e))
-> Either String b
-> Either String (c -> d -> e -> (a, b, c, d, e))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BValue -> Either String b
forall a. BEncode a => BValue -> Result a
fromBEncode BValue
b
           Either String (c -> d -> e -> (a, b, c, d, e))
-> Either String c -> Either String (d -> e -> (a, b, c, d, e))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BValue -> Either String c
forall a. BEncode a => BValue -> Result a
fromBEncode BValue
c Either String (d -> e -> (a, b, c, d, e))
-> Either String d -> Either String (e -> (a, b, c, d, e))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BValue -> Either String d
forall a. BEncode a => BValue -> Result a
fromBEncode BValue
d Either String (e -> (a, b, c, d, e))
-> Either String e -> Result (a, b, c, d, e)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BValue -> Either String e
forall a. BEncode a => BValue -> Result a
fromBEncode BValue
e
  fromBEncode BValue
_ = String -> Result (a, b, c, d, e)
forall a. String -> Result a
decodingError String
"Unable to decode a tuple5"
  {-# INLINE fromBEncode #-}

{--------------------------------------------------------------------
  Building dictionaries
--------------------------------------------------------------------}

-- | /Assoc/ used to easily build dictionaries with required and
-- optional keys. Suppose we have we following datatype we want to
-- serialize:
--
--  @
--   data FileInfo = FileInfo
--     { fileLength :: Integer
--     , fileMD5sum :: Maybe ByteString
--     , filePath   :: [ByteString]
--     , fileTags   :: Maybe [Text]
--     } deriving (Show, Read, Eq)
--  @
--
-- We need to make @instance 'BEncode' FileInfo@, though we don't want
-- to check the both 'Maybe's manually. The more declarative and
-- convenient way to define the 'toBEncode' method is to use
-- dictionary builders:
--
--  @
--   instance 'BEncode' FileInfo where
--     'toBEncode' FileInfo {..} = 'toDict' $
--          \"length\" '.=!' fileLength
--       '.:' \"md5sum\" '.=?' fileMD5sum
--       '.:' \"path\"   '.=!' filePath
--       '.:' \"tags\"   '.=?' fileTags
--       '.:' 'endDict'
--  @
--
--  NOTE: the list of pairs MUST be sorted lexicographically by keys,
--  like so:
--
--    \"length\" '<' \"md5sum\" '<' \"path\" '<' \"tags\"
--
data Assoc = Some !BKey BValue
           | None

-- | Make required key value pair.
(.=!) :: BEncode a => BKey -> a -> Assoc
(!BKey
k) .=! :: BKey -> a -> Assoc
.=! a
v = BKey -> BValue -> Assoc
Some BKey
k (a -> BValue
forall a. BEncode a => a -> BValue
toBEncode a
v)
{-# INLINE (.=!) #-}

infix 6 .=!

-- | Like the ('.=!') operator but if the value is not present then
-- the key do not appear in resulting bencode dictionary.
--
(.=?) :: BEncode a => BKey -> Maybe a -> Assoc
BKey
_ .=? :: BKey -> Maybe a -> Assoc
.=? Maybe a
Nothing = Assoc
None
BKey
k .=? Just a
v  = BKey -> BValue -> Assoc
Some BKey
k (a -> BValue
forall a. BEncode a => a -> BValue
toBEncode a
v)
{-# INLINE (.=?) #-}

infix 6 .=?

-- | Cons a key\/value pair.
(.:) :: Assoc -> BDict -> BDict
Assoc
None     .: :: Assoc -> BDict -> BDict
.: BDict
d = BDict
d
Some BKey
k BValue
v .: BDict
d = BKey -> BValue -> BDict -> BDict
forall a. BKey -> a -> BDictMap a -> BDictMap a
Cons BKey
k BValue
v BDict
d
{-# INLINE (.:) #-}

infixr 5 .:

-- | Make a bencode value from dictionary description.
toDict :: BDict -> BValue
toDict :: BDict -> BValue
toDict = BDict -> BValue
BDict
{-# INLINE toDict #-}

-- | Used to specify end of dictionary. See 'Assoc'.
endDict :: BDict
endDict :: BDict
endDict = BDict
forall a. BDictMap a
Nil
{-# INLINE endDict #-}

{--------------------------------------------------------------------
--  Dictionary extraction
--------------------------------------------------------------------}

-- | Dictionary extractor are similar to dictionary builders, but play
-- the opposite role: they are used to define 'fromBEncode' method in
-- declarative style. Using the same /FileInfo/ datatype the
-- 'fromBEncode' function instance looks like:
--
--  @
--   instance 'BEncode' FileInfo where
--     'fromBEncode' = 'fromDict' $ do
--       FileInfo '<$>!' \"length\"
--                '<*>?' \"md5sum\"
--                '<*>!' \"path\"
--                '<*>?' \"tags\"
--  @
--
--  The /reqKey/ is used to extract required key — if lookup is failed
--  then whole destructuring fail.
--
--  NOTE: the actions MUST be sorted lexicographically by keys, like so:
--
--  \"length\" '<' \"md5sum\" '<' \"path\" '<' \"tags\"
--
newtype Get a = Get { Get a -> StateT BDict Result a
runGet :: StateT BDict Result a }
  deriving (a -> Get b -> Get a
(a -> b) -> Get a -> Get b
(forall a b. (a -> b) -> Get a -> Get b)
-> (forall a b. a -> Get b -> Get a) -> Functor Get
forall a b. a -> Get b -> Get a
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Get b -> Get a
$c<$ :: forall a b. a -> Get b -> Get a
fmap :: (a -> b) -> Get a -> Get b
$cfmap :: forall a b. (a -> b) -> Get a -> Get b
Functor, Functor Get
a -> Get a
Functor Get
-> (forall a. a -> Get a)
-> (forall a b. Get (a -> b) -> Get a -> Get b)
-> (forall a b c. (a -> b -> c) -> Get a -> Get b -> Get c)
-> (forall a b. Get a -> Get b -> Get b)
-> (forall a b. Get a -> Get b -> Get a)
-> Applicative Get
Get a -> Get b -> Get b
Get a -> Get b -> Get a
Get (a -> b) -> Get a -> Get b
(a -> b -> c) -> Get a -> Get b -> Get c
forall a. a -> Get a
forall a b. Get a -> Get b -> Get a
forall a b. Get a -> Get b -> Get b
forall a b. Get (a -> b) -> Get a -> Get b
forall a b c. (a -> b -> c) -> Get a -> Get b -> Get c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Get a -> Get b -> Get a
$c<* :: forall a b. Get a -> Get b -> Get a
*> :: Get a -> Get b -> Get b
$c*> :: forall a b. Get a -> Get b -> Get b
liftA2 :: (a -> b -> c) -> Get a -> Get b -> Get c
$cliftA2 :: forall a b c. (a -> b -> c) -> Get a -> Get b -> Get c
<*> :: Get (a -> b) -> Get a -> Get b
$c<*> :: forall a b. Get (a -> b) -> Get a -> Get b
pure :: a -> Get a
$cpure :: forall a. a -> Get a
$cp1Applicative :: Functor Get
Applicative, Applicative Get
Get a
Applicative Get
-> (forall a. Get a)
-> (forall a. Get a -> Get a -> Get a)
-> (forall a. Get a -> Get [a])
-> (forall a. Get a -> Get [a])
-> Alternative Get
Get a -> Get a -> Get a
Get a -> Get [a]
Get a -> Get [a]
forall a. Get a
forall a. Get a -> Get [a]
forall a. Get a -> Get a -> Get a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
many :: Get a -> Get [a]
$cmany :: forall a. Get a -> Get [a]
some :: Get a -> Get [a]
$csome :: forall a. Get a -> Get [a]
<|> :: Get a -> Get a -> Get a
$c<|> :: forall a. Get a -> Get a -> Get a
empty :: Get a
$cempty :: forall a. Get a
$cp1Alternative :: Applicative Get
Alternative)

-- | 'fail' is catchable from pure code.
instance Monad Get where
  return :: a -> Get a
return a
a = StateT BDict Result a -> Get a
forall a. StateT BDict Result a -> Get a
Get (a -> StateT BDict Result a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a)
  {-# INLINE return #-}

  Get StateT BDict Result a
m >>= :: Get a -> (a -> Get b) -> Get b
>>= a -> Get b
f = StateT BDict Result b -> Get b
forall a. StateT BDict Result a -> Get a
Get (StateT BDict Result a
m StateT BDict Result a
-> (a -> StateT BDict Result b) -> StateT BDict Result b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Get b -> StateT BDict Result b
forall a. Get a -> StateT BDict Result a
runGet (Get b -> StateT BDict Result b)
-> (a -> Get b) -> a -> StateT BDict Result b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Get b
f)
  {-# INLINE (>>=) #-}

  Get StateT BDict Result a
m >> :: Get a -> Get b -> Get b
>> Get StateT BDict Result b
n = StateT BDict Result b -> Get b
forall a. StateT BDict Result a -> Get a
Get (StateT BDict Result a
m StateT BDict Result a
-> StateT BDict Result b -> StateT BDict Result b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT BDict Result b
n)
  {-# INLINE (>>) #-}

#if __GLASGOW_HASKELL__ < 808
  fail msg = Get (lift (Left msg))
  {-# INLINE fail #-}
#else
instance MonadFail Get where
  fail :: String -> Get a
fail String
msg = StateT BDict Result a -> Get a
forall a. StateT BDict Result a -> Get a
Get (Either String a -> StateT BDict Result a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> Either String a
forall a b. a -> Either a b
Left String
msg))
  {-# INLINE fail #-}
#endif

-- | Run action, but return without consuming and key\/value pair.
-- Fails if the action fails.
lookAhead :: Get a -> Get a
lookAhead :: Get a -> Get a
lookAhead (Get StateT BDict Result a
m) = StateT BDict Result a -> Get a
forall a. StateT BDict Result a -> Get a
Get (StateT BDict Result a -> Get a) -> StateT BDict Result a -> Get a
forall a b. (a -> b) -> a -> b
$ do
  BDict
s <- StateT BDict Result BDict
forall s (m :: * -> *). MonadState s m => m s
get
  a
r <- StateT BDict Result a
m
  BDict -> StateT BDict Result ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put BDict
s
  a -> StateT BDict Result a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r

-- | Get lexicographical successor of the current key\/value pair.
next :: Get BValue
next :: Get BValue
next = StateT BDict Result BValue -> Get BValue
forall a. StateT BDict Result a -> Get a
Get ((BDict -> Result (BValue, BDict)) -> StateT BDict Result BValue
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT BDict -> Result (BValue, BDict)
forall (m :: * -> *) a.
MonadError String m =>
BDictMap a -> m (a, BDictMap a)
go)
  where
    go :: BDictMap a -> m (a, BDictMap a)
go  BDictMap a
Nil          = String -> m (a, BDictMap a)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"no next"
    go (Cons BKey
_ a
v BDictMap a
xs) = (a, BDictMap a) -> m (a, BDictMap a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
v, BDictMap a
xs)

-- | Extract /required/ value from the given key.
req :: BKey -> Get BValue
req :: BKey -> Get BValue
req !BKey
key = StateT BDict Result BValue -> Get BValue
forall a. StateT BDict Result a -> Get a
Get ((BDict -> Result (BValue, BDict)) -> StateT BDict Result BValue
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT BDict -> Result (BValue, BDict)
forall a. BDictMap a -> Either String (a, BDictMap a)
search)
  where
    search :: BDictMap a -> Either String (a, BDictMap a)
search  BDictMap a
Nil          = String -> Either String (a, BDictMap a)
forall a b. a -> Either a b
Left String
msg
    search (Cons BKey
k a
v BDictMap a
xs) =
      case BKey -> BKey -> Ordering
forall a. Ord a => a -> a -> Ordering
compare BKey
k BKey
key of
        Ordering
EQ -> (a, BDictMap a) -> Either String (a, BDictMap a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
v, BDictMap a
xs)
        Ordering
LT -> BDictMap a -> Either String (a, BDictMap a)
search BDictMap a
xs
        Ordering
GT -> String -> Either String (a, BDictMap a)
forall a b. a -> Either a b
Left String
msg

    msg :: String
msg = String
"required field `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ BKey -> String
BC.unpack BKey
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' not found"
{-# INLINE req #-}

-- | Extract optional value from the given key.
opt :: BKey -> Get (Maybe BValue)
opt :: BKey -> Get (Maybe BValue)
opt = Get BValue -> Get (Maybe BValue)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Get BValue -> Get (Maybe BValue))
-> (BKey -> Get BValue) -> BKey -> Get (Maybe BValue)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BKey -> Get BValue
req
{-# INLINE opt #-}

-- | Reconstruct a bencodable value from bencode value.
field :: BEncode a => Get BValue -> Get a
{-# SPECIALIZE field :: Get BValue -> Get BValue #-}
field :: Get BValue -> Get a
field Get BValue
m = StateT BDict Result a -> Get a
forall a. StateT BDict Result a -> Get a
Get (StateT BDict Result a -> Get a) -> StateT BDict Result a -> Get a
forall a b. (a -> b) -> a -> b
$ do
  BValue
v <- Get BValue -> StateT BDict Result BValue
forall a. Get a -> StateT BDict Result a
runGet Get BValue
m
  (String -> StateT BDict Result a)
-> (a -> StateT BDict Result a)
-> Either String a
-> StateT BDict Result a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> StateT BDict Result a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError a -> StateT BDict Result a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String a -> StateT BDict Result a)
-> Either String a -> StateT BDict Result a
forall a b. (a -> b) -> a -> b
$ BValue -> Either String a
forall a. BEncode a => BValue -> Result a
fromBEncode BValue
v

-- | Match key with value.
match :: BKey -> BValue -> Get ()
match :: BKey -> BValue -> Get ()
match BKey
key BValue
expected = do
  BValue
actual <- BKey -> Get BValue
req BKey
key
  if BValue
actual BValue -> BValue -> Bool
forall a. Eq a => a -> a -> Bool
== BValue
expected
    then () -> Get ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    else String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get ()) -> String -> Get ()
forall a b. (a -> b) -> a -> b
$ String
"key match failure(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ BKey -> String
forall a. Show a => a -> String
show BKey
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"): " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                String
"expected = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ BValue -> String
forall a. Show a => a -> String
show BValue
expected String -> String -> String
forall a. [a] -> [a] -> [a]
++
                String
"actual   = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ BValue -> String
forall a. Show a => a -> String
show BValue
actual

-- | Shorthand for: @f '<$>' 'field' ('req' k)@.
(<$>!) :: BEncode a => (a -> b) -> BKey -> Get b
a -> b
f <$>! :: (a -> b) -> BKey -> Get b
<$>! BKey
k = a -> b
f (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get BValue -> Get a
forall a. BEncode a => Get BValue -> Get a
field (BKey -> Get BValue
req BKey
k)
{-# INLINE (<$>!) #-}

infixl 4 <$>!

-- | Shorthand for: @f '<$>' 'optional' ('field' ('req' k))@.
(<$>?) :: BEncode a => (Maybe a -> b) -> BKey -> Get b
Maybe a -> b
f <$>? :: (Maybe a -> b) -> BKey -> Get b
<$>? BKey
k = Maybe a -> b
f (Maybe a -> b) -> Get (Maybe a) -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get a -> Get (Maybe a)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Get BValue -> Get a
forall a. BEncode a => Get BValue -> Get a
field (BKey -> Get BValue
req BKey
k))
{-# INLINE (<$>?) #-}

infixl 4 <$>?

-- | Shorthand for: @f '<*>' 'field' ('req' k)@.
(<*>!) :: BEncode a => Get (a -> b) -> BKey -> Get b
Get (a -> b)
f <*>! :: Get (a -> b) -> BKey -> Get b
<*>! BKey
k = Get (a -> b)
f Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get BValue -> Get a
forall a. BEncode a => Get BValue -> Get a
field (BKey -> Get BValue
req BKey
k)
{-# INLINE (<*>!) #-}

infixl 4 <*>!

-- | Shorthand for: @f '<*>' 'optional' ('field' ('req' k))@.
(<*>?) :: BEncode a => Get (Maybe a -> b) -> BKey -> Get b
Get (Maybe a -> b)
f <*>? :: Get (Maybe a -> b) -> BKey -> Get b
<*>? BKey
k = Get (Maybe a -> b)
f Get (Maybe a -> b) -> Get (Maybe a) -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get a -> Get (Maybe a)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Get BValue -> Get a
forall a. BEncode a => Get BValue -> Get a
field (BKey -> Get BValue
req BKey
k))
{-# INLINE (<*>?) #-}

infixl 4 <*>?

-- | Run a 'Get' monad. See 'Get' for usage.
fromDict :: forall a. Typeable a => Get a -> BValue -> Result a
fromDict :: Get a -> BValue -> Result a
fromDict Get a
m (BDict BDict
d) = StateT BDict Result a -> BDict -> Result a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Get a -> StateT BDict Result a
forall a. Get a -> StateT BDict Result a
runGet Get a
m) BDict
d
fromDict Get a
_  BValue
_        = String -> Result a
forall a. String -> Result a
decodingError (TypeRep -> String
forall a. Show a => a -> String
show (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
inst))
  where
    inst :: a
inst = String -> a
forall a. HasCallStack => String -> a
error String
"fromDict: impossible" :: a

{--------------------------------------------------------------------
  Encoding
--------------------------------------------------------------------}

-- | Decode a value from a strict 'ByteString' using bencode format.
decode :: BEncode a => ByteString -> Result a
decode :: BKey -> Result a
decode = BKey -> Result BValue
parse (BKey -> Result BValue) -> (BValue -> Result a) -> BKey -> Result a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> BValue -> Result a
forall a. BEncode a => BValue -> Result a
fromBEncode

-- | Encode a value using bencode format to a lazy 'ByteString'.
encode :: BEncode a => a -> Lazy.ByteString
encode :: a -> ByteString
encode = BValue -> ByteString
build (BValue -> ByteString) -> (a -> BValue) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> BValue
forall a. BEncode a => a -> BValue
toBEncode