benc 0.1.0.0 → 0.1.1.0

raw patch · 11 files changed

+1393/−804 lines, 11 filesdep −AttoBencodedep −bencodedep −bencodingdep ~bytestringdep ~containersdep ~textPVP ok

version bump matches the API change (PVP)

Dependencies removed: AttoBencode, bencode, bencoding

Dependency ranges changed: bytestring, containers, text, transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• README.md +18/−14
• benc.cabal +17/−13
• bench/Bench.hs +275/−0
• compare/Bench.hs +0/−413
• src/Data/Bencode/AST.hs +85/−86
• src/Data/Bencode/Decode.hs +406/−97
• src/Data/Bencode/Encode.hs +156/−70
• src/Data/Bencode/Type.hs +2/−3
• src/Data/Bencode/Util.hs +78/−36
• test/Test.hs +346/−72

@@ -1,3 +1,13 @@+### 0.1.1.0 -- 2023-12-05++* New+  * Integer parsing/encoding: `int64`, `int32`, `int16`, `int8`, `word64`,+    `word32`, `word16`, `word8`.+  * List parsing: `index`, `elem`, `list'`.+  * Dictionary parsing: `field'`, `dict'`.+  * `mapMaybe` and `mapOrFail` for `Parser`.+* Performance improvements+ ### 0.1.0.0 -- 2023-11-09  * First version.

@@ -1,5 +1,8 @@ # benc +[![Hackage](https://img.shields.io/hackage/v/benc?logo=haskell&color=blue)](https://hackage.haskell.org/package/benc)+[![Haskell-CI](https://github.com/meooow25/benc/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/meooow25/benc/actions/workflows/haskell-ci.yml)+ Bencode encoding and decoding library  ## Bencode@@ -71,24 +74,24 @@  #### Decoding -| Library     | `crossref`       | `ubuntu`         |-| ----------- | ---------------- | ---------------- |-| benc        | 27.6 ms ± 2.1 ms | 1.46 μs ± 93 ns  |-| bencode     | 218 ms ± 11 ms   | 28.4 μs ± 1.5 μs |-| AttoBencode | 44.8 ms ± 3.8 ms | 2.97 μs ± 171 ns |-| bencoding   | 39.7 ms ± 3.7 ms | 2.38 μs ± 181 ns |+| Library     | `crossref` time  | alloc  | `ubuntu` time    | alloc  |+| ----------- | ---------------- | ------ | ---------------- | ------ |+| benc        | 21.3 ms ± 902 μs | 24 MB  | 1.30 μs ± 90 ns  | 3.6 KB |+| bencode     | 218 ms ± 7.7 ms  | 737 MB | 29.0 μs ± 2.6 μs | 121 KB |+| AttoBencode | 44.6 ms ± 4.0 ms | 129 MB | 3.01 μs ± 102 ns | 17 KB  |+| bencoding   | 39.1 ms ± 2.3 ms | 104 MB | 2.44 μs ± 175 ns | 15 KB  |  <sup>Note: `bencode` parses from a lazy `ByteString` unlike the rest which parse from strict `ByteString`s, and so is expected to be a little slower.</sup>  #### Encoding -| Library     | `crossref`       | `ubuntu`         |-| ----------- | ---------------- | ---------------- |-| benc        | 11.8 ms ± 1.0 ms | 1.91 μs ± 179 ns |-| bencode     | 42.4 ms ± 3.1 ms | 3.19 μs ± 173 ns |-| AttoBencode | 20.2 ms ± 1.1 ms | 10.2 μs ± 387 ns |-| bencoding   | 11.6 ms ± 1.1 ms | 1.79 μs ± 100 ns |+| Library     | `crossref` time  | alloc  | `ubuntu` time    | alloc  |+| ----------- | ---------------- | ------ | ---------------- | ------ |+| benc        | 9.17 ms ± 487 μs | 42 MB  | 1.58 μs ± 101 ns | 11 KB  |+| bencode     | 37.8 ms ± 860 μs | 113 MB | 3.17 μs ± 174 ns | 19 KB  |+| AttoBencode | 19.7 ms ± 1.8 ms | 109 MB | 10.1 μs ± 993 ns | 295 KB |+| bencoding   | 11.9 ms ± 916 μs | 67 MB  | 1.81 μs ± 129 ns | 15 KB  |  <sup>Note: `AttoBencode` encodes to a strict `ByteString` via a lazy `ByteString`, unlike the rest, which only prepare the lazy `ByteString`. As@@ -96,5 +99,6 @@  ## Contributing -Contributions, bug reports, suggestions welcome! Please-[open an issue](https://github.com/meooow25/benc/issues).+Questions, bug reports, documentation improvements, code contributions welcome!+Please [open an issue](https://github.com/meooow25/benc/issues) as the first+step.

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               benc-version:            0.1.0.0+version:            0.1.1.0 synopsis:           Bencode encoding and decoding library description:        Bencode encoding and decoding library. homepage:           https://github.com/meooow25/benc@@ -14,6 +14,15 @@     README.md     CHANGELOG.md +tested-with:+      GHC == 8.10.1+    , GHC == 8.10.7+    , GHC == 9.0.2+    , GHC == 9.2.8+    , GHC == 9.4.8+    , GHC == 9.6.3+    , GHC == 9.8.1+ common warnings     ghc-options: -Wall @@ -31,11 +40,11 @@      build-depends:         base         >= 4.14    && < 5.0-      , bytestring   >= 0.10.12 && < 0.13-      , containers   >= 0.6.5   && < 0.8+      , bytestring   >= 0.10.10 && < 0.13+      , containers   >= 0.6.2.1 && < 0.8       , primitive    >= 0.9.0   && < 0.10-      , text         >= 1.2.4   && < 2.2-      , transformers >= 0.5.6   && < 0.7+      , text         >= 1.2.3.2 && < 2.2+      , transformers >= 0.5.6.2 && < 0.7       , vector       >= 0.13.1  && < 0.14      hs-source-dirs:   src@@ -60,27 +69,22 @@     default-language: Haskell2010     type:             exitcode-stdio-1.0 -benchmark benc-compare+benchmark benc-bench     import:           warnings      build-depends:         base       , benc-      , bencode      == 0.6.1.1-      , AttoBencode  == 0.3.1.0-      , bencoding    == 0.4.5.4+      , deepseq       , tasty       , tasty-bench       , tasty-hunit       , bytestring       , containers-      , deepseq       , text-      , transformers == 0.5.6.2       , vector-      -- bencoding depends on an orphan in the removed Control.Monad.Trans.Error -    hs-source-dirs:   compare+    hs-source-dirs:   bench     main-is:          Bench.hs     default-language: Haskell2010     type:             exitcode-stdio-1.0

@@ -0,0 +1,275 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import Test.Tasty.Bench++import Data.Bits+import Data.Int+import Data.Semigroup+import Data.Word+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Lazy as BL+import qualified Data.Map.Strict as M+import qualified Data.Text as T+import qualified Data.Vector as V++import qualified Data.Bencode.Decode as D+import qualified Data.Bencode.Encode as E++main :: IO ()+main =  defaultMain+  [ bgroup "Decode"+    [ envPure sData   $ bench "string" . whnf decString+    , envPure iData   $ bench "integer" . whnf decInteger+    , envPure lData   $ bench "list" . whnf decList+    , envPure dData   $ bench "dict" . whnf decDict+    , envPure sData   $ bench "text" . whnf decText+    , envPure lsData  $ bench "list string" . whnf decListString+    , envPure liData  $ bench "list int" . whnf decListInt+    , envPure llData  $ bench "list list" . whnf decListList+    , envPure ldData  $ bench "list dict" . whnf decListDict+    , envPure ldData2 $ bench "list fields" . whnf decListFields+    , envPure liData  $ bench "list word16" . whnf decListWord16+    , envPure ldData2 $ bench "list dict'" . whnf decListDict'+    , envPure llData2 $ bench "list index" . whnf decListIndex+    , envPure llData2 $ bench "list list'" . whnf decListList'+    ]+  , bgroup "Encode"+    [ bench "string"      $ whnf encManyString n+    , bench "integer"     $ whnf encManyInteger n+    , bench "list"        $ whnf encManyList n100+    , bench "list fusion" $ whnf encManyListFusion n+    , bench "dict"        $ whnf encManyDict n100+    , bench "text"        $ whnf encManyText n+    , bench "int"         $ whnf encManyInt n+    , bench "field"       $ whnf encManyField n10+    , bench "word16"      $ whnf encManyWord16 n+    ]+  ]+  where+    -- How was the test data and size selected?+    -- Pretty much arbitrarily. Sizes are chosen such that a benchmark+    -- takes <= ~200ms.+    n, n10, n100 :: Int+    !n = 1000000+    !n10 = n `div` 10+    !n100 = n `div` 100++    envPure = env . pure+    toBS = BL.toStrict . BB.toLazyByteString++    sData = BC.pack (show n) <> ":" <> stimes n "x"+    iData = "i1" <> stimes n "1" <> "e"+    lData = "l" <> stimes n "le" <> "e"+    dData = toBS $ "d" <> go n10 <> "e"+      where+        go i | i == 2*n10 = mempty+        go i = "6:" <> BB.intDec i <> "de" <> go (i+1)+    lsData = toBS $ "l" <> stimes n10 s <> "e"+      where+        s = "5:hello5:world13:one two three"+    liData = toBS $ "l" <> go n <> "e"+      where+        go 0 = mempty+        go i = "i" <> BB.intDec (i .&. 0xffff) <> "e" <> go (i-1)+    llData = toBS $ "l" <> stimes n "le" <> "e"+    ldData = toBS $ "l" <> stimes n "de" <> "e"+    ldData2 = toBS $ "l" <> stimes n10 d <> "e"+      where+        d = "d1:0de1:1de1:2de1:3de1:4de1:5de1:6de1:7de1:8de1:9dee"+    silverForMonsters = "lelelelelelelelelele"+    llData2 = toBS $ "l" <> stimes n10 ("l" <> silverForMonsters <> "e") <> "e"+++-- All bench functions below are marked NOINLINE to make it easy to find+-- them by name in the GHC core output.++------------------------------+-- Decode+------------------------------++decString :: B.ByteString -> B.ByteString+decString = runP D.string+{-# NOINLINE decString #-}++decInteger :: B.ByteString -> Integer+decInteger = runP D.integer+{-# NOINLINE decInteger #-}++decList :: B.ByteString -> V.Vector (V.Vector ())+decList = runP (D.list (D.list (pure ())))+{-# NOINLINE decList #-}++decDict :: B.ByteString -> M.Map B.ByteString (M.Map B.ByteString ())+decDict = runP (D.dict (D.dict (pure ())))+{-# NOINLINE decDict #-}++decText :: B.ByteString -> T.Text+decText = runP D.text+{-# NOINLINE decText #-}++decListString :: B.ByteString -> V.Vector B.ByteString+decListString = runP (D.list D.string)+{-# NOINLINE decListString #-}++decListInt :: B.ByteString -> V.Vector Int+decListInt = runP (D.list D.int)+{-# NOINLINE decListInt #-}++decListList :: B.ByteString -> V.Vector (V.Vector ())+decListList = runP (D.list (D.list (pure ())))+{-# NOINLINE decListList #-}++decListDict :: B.ByteString -> V.Vector (M.Map B.ByteString ())+decListDict = runP (D.list (D.dict (pure ())))+{-# NOINLINE decListDict #-}++decListFields :: B.ByteString -> V.Vector ()+decListFields = runP (D.list foo)+  where+    foo = do+      D.field "0" (pure ())+      D.field "1" (pure ())+      D.field "2" (pure ())+      D.field "3" (pure ())+      D.field "4" (pure ())+      D.field "5" (pure ())+      D.field "6" (pure ())+      D.field "7" (pure ())+      D.field "8" (pure ())+      D.field "9" (pure ())+{-# NOINLINE decListFields #-}++decListWord16 :: B.ByteString -> V.Vector Word16+decListWord16 = runP (D.list D.word16)+{-# NOINLINE decListWord16 #-}++decListDict' :: B.ByteString -> V.Vector ()+decListDict' = runP (D.list foo)+  where+    foo = D.dict' $ do+      D.field' "0" (pure ())+      D.field' "1" (pure ())+      D.field' "2" (pure ())+      D.field' "3" (pure ())+      D.field' "4" (pure ())+      D.field' "5" (pure ())+      D.field' "6" (pure ())+      D.field' "7" (pure ())+      D.field' "8" (pure ())+      D.field' "9" (pure ())+{-# NOINLINE decListDict' #-}++decListIndex :: B.ByteString -> V.Vector ()+decListIndex = runP (D.list foo)+  where+    foo = do+      D.index 0 (pure ())+      D.index 1 (pure ())+      D.index 2 (pure ())+      D.index 3 (pure ())+      D.index 4 (pure ())+      D.index 5 (pure ())+      D.index 6 (pure ())+      D.index 7 (pure ())+      D.index 8 (pure ())+      D.index 9 (pure ())+{-# NOINLINE decListIndex #-}++decListList' :: B.ByteString -> V.Vector ()+decListList' = runP (D.list foo)+  where+    foo = D.list' $ do+      D.elem (pure ())+      D.elem (pure ())+      D.elem (pure ())+      D.elem (pure ())+      D.elem (pure ())+      D.elem (pure ())+      D.elem (pure ())+      D.elem (pure ())+      D.elem (pure ())+      D.elem (pure ())+{-# NOINLINE decListList' #-}++runP :: D.Parser a -> B.ByteString -> a+runP p = either error id . D.decode p+{-# INLINE runP #-}++------------------------------+-- Encode+------------------------------++encManyString :: Int -> Int64+encManyString = encMany E.string ("hello","world","one two three")+{-# NOINLINE encManyString #-}++encManyInteger :: Int -> Int64+encManyInteger = encMany E.integer (0,-100000,fromIntegral (maxBound :: Int))+{-# NOINLINE encManyInteger #-}++encManyList :: Int -> Int64+encManyList =+  encMany (E.list (E.list E.value))+          (V.empty, V.replicate 10 V.empty, V.replicate 90 V.empty)+{-# NOINLINE encManyList #-}++encManyListFusion :: Int -> Int64+encManyListFusion = getL . E.toBuilder . E.list E.int . flip V.generate id+{-# NOINLINE encManyListFusion #-}++encManyDict :: Int -> Int64+encManyDict =+  encMany (E.dict (E.dict E.value))+          (M.empty, M.singleton "a" M.empty, m99)+{-# NOINLINE encManyDict #-}++m99 :: M.Map B.ByteString (M.Map B.ByteString a)+m99 = M.fromList [(BC.pack (show i), M.empty) | i <- [1..99 :: Int]]++encManyText :: Int -> Int64+encManyText = encMany E.text ("hello","world","one two three")+{-# NOINLINE encManyText #-}++encManyInt :: Int -> Int64+encManyInt = encMany E.int (0,-100000,maxBound)+{-# NOINLINE encManyInt #-}++data ABC = A | B | C++encManyField :: Int -> Int64+encManyField = encMany foo (A,B,C)+  where+    foo A = e+    foo B = E.dict' $ E.field "foo" id e+    foo C = E.dict' $+         E.field "0" id e+      <> E.field "1" id e+      <> E.field "2" id e+      <> E.field "3" id e+      <> E.field "4" id e+      <> E.field "5" id e+      <> E.field "6" id e+      <> E.field "7" id e+      <> E.field "8" id e+      <> E.field "9" id e+    e = E.dict id M.empty+{-# NOINLINE encManyField #-}++encManyWord16 :: Int -> Int64+encManyWord16 = encMany E.word16 (0,1000,maxBound)+{-# NOINLINE encManyWord16 #-}++encMany :: (a -> E.Encoding) -> (a,a,a) -> Int -> Int64+encMany enc (x0',x1',x2') = getL . go x0' x1' x2'+  where+    go _  _  _  0 = mempty+    go x0 x1 x2 i = E.toBuilder (enc x0) <> go x1 x2 x0 (i-1)+{-# INLINE encMany #-}++getL :: BB.Builder -> Int64+getL = BL.length . BB.toLazyByteString+{-# INLINE getL #-}

@@ -1,413 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE PackageImports #-}-module Main (main) where--import Test.Tasty.Bench-import Test.Tasty.HUnit--import Control.Applicative-import Control.DeepSeq-import Control.Exception-import Data.Maybe-import System.IO-import qualified Data.ByteString as B-import qualified Data.ByteString.Builder as BB-import qualified Data.ByteString.Lazy as BL-import qualified Data.Map.Strict as M-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Vector as V-import GHC.Generics--import qualified Data.AttoBencode as Atto-import qualified "bencode" Data.BEncode as Ben-import qualified Data.BEncode.Reader as Ben-import qualified "bencoding" Data.BEncode as Ing-import qualified Data.Bencode.Decode as D-import qualified Data.Bencode.Encode as E--main :: IO ()-main = do-  defaultMain $-    [ env (withFile testFile ReadMode B.hGetContents) $ \testData ->-      bgroup testName-        [ bgroup "Decode"-          [ bench    "benc"              $ nf decodeBenc testData-          , bench    "bencode"           $ nf decodeBencode testData-          , bench    "AttoBencode"       $ nf decodeAttoBencode testData-          , bench    "bencoding"         $ nf decodeBencoding testData-          , testCase "bencode match"     $ decodeBencode testData @?= decodeBenc testData-          , testCase "AttoBencode match" $ decodeAttoBencode testData @?= decodeBenc testData-          , testCase "bencoding match"   $ decodeBencoding testData @?= decodeBenc testData-          ]-        , env (evaluate (force (decodeBenc testData))) $ \decoded ->-          bgroup "Encode"-            [ bench    "benc"              $ nf encodeBenc decoded-            , bench    "bencode"           $ nf encodeBencode decoded-            , bench    "AttoBencode"       $ nf encodeAttoBencode decoded-            , bench    "bencoding"         $ nf encodeBencoding decoded-            , testCase "bencode match"     $ encodeBencode decoded @?= encodeBenc decoded-            , testCase "AttoBencode match" $ BL.fromStrict (encodeAttoBencode decoded) @?= encodeBenc decoded-            , testCase "bencoding match"   $ encodeBencoding decoded @?= encodeBenc decoded-            ]-        ]-    | (testName, testFile) <- testFiles ]--testFiles :: [(String, FilePath)]-testFiles =-  [ ("crossref", "data/April2023PublicDataFilefromCrossref.torrent")-  , ("ubuntu",   "data/ubuntu-22.04-desktop-amd64.iso.torrent")-  ]---- | This represents a metainfo (.torrent) file.-data MetaInfo = MetaInfo-  { _announce     :: !T.Text-  , _announceList :: !(Maybe (V.Vector (V.Vector T.Text)))-  , _comment      :: !(Maybe T.Text)-  , _createdBy    :: !(Maybe T.Text)-  , _creationDate :: !(Maybe Int)-  , _info         :: !Info-  } deriving (Eq, Show, Generic, NFData)--data Info = Info-  { _singleOrMultiple :: !SingleOrMultiple-  , _name             :: !T.Text-  , _pieceLength      :: !Int-  , _pieces           :: !B.ByteString-  } deriving (Eq, Show, Generic, NFData)--data SingleOrMultiple-  = Single { _length :: !Int }-  | Multiple { _files :: !(V.Vector OneFileInfo) }-  deriving (Eq, Show, Generic, NFData)--data OneFileInfo = OneFileInfo-  { __length :: !Int-  , _path    :: !(V.Vector T.Text)-  } deriving (Eq, Show, Generic, NFData)----------------------------------- benc---------------------------------decodeBenc :: B.ByteString -> MetaInfo-decodeBenc = either error id . D.decode metaInfoP--metaInfoP :: D.Parser MetaInfo-metaInfoP =-  MetaInfo-    <$> D.field "announce" D.text-    <*> optional (D.field "announce-list" (D.list (D.list D.text)))-    <*> optional (D.field "comment" D.text)-    <*> optional (D.field "created by" D.text)-    <*> optional (D.field "creation date" D.int)-    <*> D.field "info" infoP--infoP :: D.Parser Info-infoP =-  Info-    <$> (   Single   <$> D.field "length" D.int-        <|> Multiple <$> D.field "files" (D.list oneFileP))-    <*> D.field "name" D.text-    <*> D.field "piece length" D.int-    <*> D.field "pieces" D.string--oneFileP :: D.Parser OneFileInfo-oneFileP =-  OneFileInfo-    <$> D.field "length" D.int-    <*> D.field "path" (D.list D.text)--encodeBenc :: MetaInfo -> BL.ByteString-encodeBenc = BB.toLazyByteString . E.toBuilder . metaInfoE--metaInfoE :: MetaInfo -> E.Encoding-metaInfoE m = E.dict' $-     E.field "announce" E.text (_announce m)-  <> foldMap (E.field "announce-list" (E.list (E.list E.text)))-             (_announceList m)-  <> foldMap (E.field "comment" E.text) (_comment m)-  <> foldMap (E.field "created by" E.text) (_createdBy m)-  <> foldMap (E.field "creation date" E.int) (_creationDate m)-  <> E.field "info" infoE (_info m)--infoE :: Info -> E.Encoding-infoE i = E.dict' $-     (case _singleOrMultiple i of-        Single l    -> E.field "length" E.int l-        Multiple fs -> E.field "files" (E.list oneFileE) fs)-  <> E.field "name" E.text (_name i)-  <> E.field "piece length" E.int (_pieceLength i)-  <> E.field "pieces" E.string (_pieces i)--oneFileE :: OneFileInfo -> E.Encoding-oneFileE o = E.dict' $-     E.field "length" E.int (__length o)-  <> E.field "path" (E.list E.text) (_path o)----------------------------------- bencode---------------------------------decodeBencode :: B.ByteString -> MetaInfo-decodeBencode =-  either error id .-  Ben.runBReader metaInfoR .-  maybe (error "fail") id .-  Ben.bRead .-  BL.fromStrict--metaInfoR :: Ben.BReader MetaInfo-metaInfoR =-  MetaInfo-    <$> Ben.dict "announce" btext-    <*> optional (-          Ben.dict "announce-list" (-            V.fromList <$> Ben.list (V.fromList <$> Ben.list btext)))-    <*> optional (Ben.dict "comment" btext)-    <*> optional (Ben.dict "created by" btext)-    <*> optional (Ben.dict "creation date" bint)-    <*> Ben.dict "info" infoR--infoR :: Ben.BReader Info-infoR =-  Info-    <$> (   Single <$> Ben.dict "length" bint-        <|> Multiple <$> Ben.dict "files" (V.fromList <$> Ben.list oneFileR))-    <*> Ben.dict "name" btext-    <*> Ben.dict "piece length" bint-    <*> Ben.dict "pieces" (BL.toStrict <$> Ben.bbytestring)--oneFileR :: Ben.BReader OneFileInfo-oneFileR =-  OneFileInfo-    <$> Ben.dict "length" bint-    <*> Ben.dict "path" (V.fromList <$> Ben.list btext)--bint :: Ben.BReader Int-bint = fromIntegral <$> Ben.bint--btext :: Ben.BReader T.Text-btext = T.decodeUtf8 . BL.toStrict <$> Ben.bbytestring--encodeBencode :: MetaInfo -> BL.ByteString-encodeBencode = Ben.bPack . metaInfoW--metaInfoW :: MetaInfo -> Ben.BEncode-metaInfoW m = Ben.BDict $ M.fromList $-     [ ("announce", Ben.BString $ unbtext (_announce m)) ]-  ++ optW "announce-list"-       (Ben.BList . map (Ben.BList . map (Ben.BString . unbtext) . V.toList) . V.toList-          <$> _announceList m)-  ++ optW "comment"       (Ben.BString . unbtext <$> _comment m)-  ++ optW "created by"    (Ben.BString . unbtext <$> _createdBy m)-  ++ optW "creation date" (Ben.BInt . fromIntegral <$> _creationDate m)-  ++ [ ("info", infoW (_info m)) ]--optW :: String -> Maybe Ben.BEncode -> [(String, Ben.BEncode)]-optW k = maybe [] (\x -> [(k,x)])--infoW :: Info -> Ben.BEncode-infoW i = Ben.BDict $ M.fromList $-     (case _singleOrMultiple i of-        Single l    -> [("length", Ben.BInt $ fromIntegral l)]-        Multiple fs -> [("files", Ben.BList $ map oneFileW (V.toList fs))])-  ++ [ ("name"        , Ben.BString $ unbtext (_name i))-     , ("piece length", Ben.BInt $ fromIntegral (_pieceLength i))-     , ("pieces"      , Ben.BString $ BL.fromStrict (_pieces i))-     ]--oneFileW :: OneFileInfo -> Ben.BEncode-oneFileW o = Ben.BDict $ M.fromList-  [ ("length", Ben.BInt $ fromIntegral (__length o))-  , ("path"  , Ben.BList $ map (Ben.BString . unbtext) $ V.toList (_path o))-  ]--unbtext :: T.Text -> BL.ByteString-unbtext = BL.fromStrict . T.encodeUtf8----------------------------------- AttoBencode---------------------------------decodeAttoBencode :: B.ByteString -> MetaInfo-decodeAttoBencode = fromJust . Atto.decode--instance Atto.FromBencode MetaInfo where-  fromBencode (Atto.BDict d) =-    MetaInfo <$> (T.decodeUtf8 <$> d Atto..: "announce")-             <*> Just (-                   V.fromList . map (V.fromList . map T.decodeUtf8)-                     <$> d Atto..: "announce-list")-             <*> Just (T.decodeUtf8 <$> d Atto..: "comment")-             <*> Just (T.decodeUtf8 <$> d Atto..: "created by")-             <*> Just (d Atto..: "creation date")-             <*> d Atto..: "info"-  fromBencode _ = Nothing--instance Atto.FromBencode Info where-  fromBencode (Atto.BDict d) =-    Info <$> (   Single <$> d Atto..: "length"-             <|> Multiple . V.fromList <$> d Atto..: "files")-         <*> (T.decodeUtf8 <$> d Atto..: "name")-         <*> d Atto..: "piece length"-         <*> d Atto..: "pieces"-  fromBencode _ = Nothing--instance Atto.FromBencode OneFileInfo where-  fromBencode (Atto.BDict d) =-    OneFileInfo-      <$> d Atto..: "length"-      <*> (V.fromList . map T.decodeUtf8 <$> d Atto..: "path")-  fromBencode _ = Nothing--encodeAttoBencode :: MetaInfo -> B.ByteString-encodeAttoBencode = Atto.encode--instance Atto.ToBencode MetaInfo where-  toBencode m = Atto.dict $-       [ "announce" Atto..= T.encodeUtf8 (_announce m) ]-    ++ opt "announce-list"-           (map (map T.encodeUtf8 . V.toList) . V.toList <$> _announceList m)-    ++ opt "comment"       (T.encodeUtf8 <$> _comment m)-    ++ opt "created by"    (T.encodeUtf8 <$> _createdBy m)-    ++ opt "creation date" (_creationDate m)-    ++ [ "info" Atto..= _info m ]---- Why is this not already in the library-opt :: Atto.ToBencode a => B.ByteString -> Maybe a -> [(B.ByteString, Atto.BValue)]-opt k = maybe [] (\x -> [k Atto..= x])--instance Atto.ToBencode Info where-  toBencode i = Atto.dict $-       (case _singleOrMultiple i of-          Single l    -> ["length" Atto..= l]-          Multiple fs -> ["files"  Atto..= V.toList fs])-    ++ [ "name"         Atto..= T.encodeUtf8 (_name i)-       , "piece length" Atto..= _pieceLength i-       , "pieces"       Atto..= _pieces i-       ]--instance Atto.ToBencode OneFileInfo where-  toBencode o = Atto.dict-    [ "length" Atto..= __length o-    , "path"   Atto..= map T.encodeUtf8 (V.toList (_path o))-    ]----------------------------------- bencoding---------------------------------decodeBencoding :: B.ByteString -> MetaInfo-decodeBencoding = either error id . Ing.decode--encodeBencoding :: MetaInfo -> BL.ByteString-encodeBencoding = Ing.encode---- You may have noticed that the keys in the records are sorted.--- This is not because I find it neat, but because bencoding forces you to--- hand-sort the order of keys when encoding and decoding! Yikes!--instance Ing.BEncode MetaInfo where-  toBEncode m = Ing.toDict $-           "announce"      Ing..=! _announce m-    Ing..: "announce-list" Ing..=? (map V.toList . V.toList <$> _announceList m)-    Ing..: "comment"       Ing..=? _comment m-    Ing..: "created by"    Ing..=? _createdBy m-    Ing..: "creation date" Ing..=? _creationDate m-    Ing..: "info"          Ing..=! _info m-    Ing..: Ing.endDict-  fromBEncode = Ing.fromDict $-    MetaInfo Ing.<$>! "announce"-             <*> optional-                   (V.fromList . map V.fromList-                      <$> Ing.field (Ing.req "announce-list"))-             Ing.<*>? "comment"-             Ing.<*>? "created by"-             Ing.<*>? "creation date"-             Ing.<*>! "info"--instance Ing.BEncode Info where-  toBEncode i = Ing.toDict $-          (case _singleOrMultiple i of-            Single l    -> "length" Ing..=! l-            Multiple fs -> "files" Ing..=! V.toList fs)-    Ing..: "name"         Ing..=! _name i-    Ing..: "piece length" Ing..=! _pieceLength i-    Ing..: "pieces"       Ing..=! _pieces i-    Ing..: Ing.endDict-  fromBEncode = Ing.fromDict $-    Info <$> (   Single Ing.<$>! "length"-             <|> Multiple . V.fromList Ing.<$>! "files")-         Ing.<*>! "name"-         Ing.<*>! "piece length"-         Ing.<*>! "pieces"--instance Ing.BEncode OneFileInfo where-  toBEncode o = Ing.toDict $-           "length" Ing..=! __length o-    Ing..: "path"   Ing..=! V.toList (_path o)-    Ing..: Ing.endDict-  fromBEncode = Ing.fromDict $-    OneFileInfo Ing.<$>! "length"-                <*> (V.fromList <$> Ing.field (Ing.req "path"))----------------------------------- Results--------------------------------{--$ cabal run benc-compare -- +RTS -T-All-  crossref-    Decode-      benc:              OK-        27.6 ms ± 2.1 ms,  45 MB allocated,  34 MB copied,  38 MB peak memory-      bencode:           OK-        218  ms ±  11 ms, 737 MB allocated,  66 MB copied,  47 MB peak memory-      AttoBencode:       OK-        44.8 ms ± 3.8 ms, 129 MB allocated,  41 MB copied,  47 MB peak memory-      bencoding:         OK-        39.7 ms ± 3.7 ms, 103 MB allocated,  40 MB copied,  47 MB peak memory-      bencode match:     OK-      AttoBencode match: OK-      bencoding match:   OK-    Encode-      benc:              OK-        11.8 ms ± 1.0 ms,  53 MB allocated, 477 KB copied,  62 MB peak memory-      bencode:           OK-        42.4 ms ± 3.1 ms, 113 MB allocated,  41 MB copied,  91 MB peak memory-      AttoBencode:       OK-        20.2 ms ± 1.1 ms, 109 MB allocated, 1.6 MB copied,  91 MB peak memory-      bencoding:         OK-        11.6 ms ± 1.1 ms,  67 MB allocated, 484 KB copied,  91 MB peak memory-      bencode match:     OK-      AttoBencode match: OK-      bencoding match:   OK-  ubuntu-    Decode-      benc:              OK-        1.46 μs ±  93 ns, 6.7 KB allocated,   3 B  copied,  91 MB peak memory-      bencode:           OK-        28.4 μs ± 1.5 μs, 121 KB allocated,  77 B  copied,  91 MB peak memory-      AttoBencode:       OK-        2.97 μs ± 171 ns,  17 KB allocated,   4 B  copied,  91 MB peak memory-      bencoding:         OK-        2.38 μs ± 181 ns,  15 KB allocated,   4 B  copied,  91 MB peak memory-      bencode match:     OK-      AttoBencode match: OK-      bencoding match:   OK-    Encode-      benc:              OK-        1.91 μs ± 179 ns,  12 KB allocated,   2 B  copied,  91 MB peak memory-      bencode:           OK-        3.19 μs ± 173 ns,  19 KB allocated,  13 B  copied,  91 MB peak memory-      AttoBencode:       OK-        10.2 μs ± 387 ns, 295 KB allocated,  26 B  copied,  91 MB peak memory-      bencoding:         OK-        1.79 μs ± 100 ns,  15 KB allocated,   2 B  copied,  91 MB peak memory-      bencode match:     OK-      AttoBencode match: OK-      bencoding match:   OK--}

@@ -1,34 +1,46 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE Strict #-}+{-# OPTIONS_GHC -fspec-constr #-} module Data.Bencode.AST   ( Value(..)   , KeyValue(..)   , parseOnly   ) where +-- ATTENTION: This module is Strict!+--+-- Prefer to add definitions where laziness is desirable in another module+-- instead of here with a ~.+--+-- The core of this module has been inspected (with GHC 9.6.3 -O) to make sure+-- things are optimized and there is no unnecessary boxing to keep time and+-- allocations to a minimum. When modifying this file make sure to check the+-- core.+ import Data.Char (isDigit) import Data.List (intercalate) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import qualified Data.Primitive.Array as A -import Data.Bencode.Util (readKnownNaturalAsInt)+import qualified Data.Bencode.Util as Util  -- | The Bencode AST. data Value-  = String  {-# UNPACK #-} !B.ByteString+  = String  {-# UNPACK #-} B.ByteString   -- ^ Slice of the input @ByteString@.-  | Integer {-# UNPACK #-} !B.ByteString+  | Integer {-# UNPACK #-} B.ByteString   -- ^ Slice of the input @ByteString@, containing a valid integer. Parsing   -- into an integral type is done later if required.-  | List    {-# UNPACK #-} !(A.Array Value)-  | Dict    {-# UNPACK #-} !(A.Array KeyValue)+  | List    {-# UNPACK #-} (A.Array Value)+  | Dict    {-# UNPACK #-} (A.Array KeyValue)   deriving (Eq, Show)  -- | A Bencode dict's key-value pair. data KeyValue = KeyValue-  {-# UNPACK #-} !B.ByteString-- ^ Slice of the input @ByteString@.-  !Value+  {-# UNPACK #-} B.ByteString-- ^ Slice of the input @ByteString@.+  Value   deriving (Eq, Show)  newtype Pos = Pos { unPos :: Int } deriving (Show, Num)@@ -39,8 +51,8 @@  data Stack   = SNil-  | SList {-# UNPACK #-} !Int ![Value] !Stack-  | SDict {-# UNPACK #-} !B.ByteString {-# UNPACK #-} !Int ![KeyValue] !Stack+  | SList {-# UNPACK #-} Int [Value] Stack+  | SDict {-# UNPACK #-} B.ByteString {-# UNPACK #-} Int [KeyValue] Stack  -- | Parse one Bencode value from the given bytestring. Fails if the string is -- not fully consumed.@@ -57,12 +69,10 @@ parseOne s = case BC.uncons s of   Nothing -> errItem Nothing pos   Just (c,s1) -> case c of-    _ | isDigit c -> do-      (str, s2, pos2) <- parseString s pos-      Right (String str, s2, unPos pos2)+    _ | isDigit c ->+      parseString s pos $ \str s2 pos2 -> Right (String str, s2, unPos pos2)     'i' -> do-      (i, s2, pos2) <- parseInteger s1 (pos+1)-      Right (Integer i, s2, unPos pos2)+      parseInteger s1 (pos+1) $ \i s2 pos2 -> Right (Integer i, s2, unPos pos2)     'l' -> parseList SNil 0 [] s1 (pos+1)     'd' -> parseDict SNil s1 (pos+1)     _   -> errItem (Just c) pos@@ -71,71 +81,69 @@  -- | Parse a Bencode list. After the \'l\' marker. parseList :: Stack -> Int -> [Value] -> B.ByteString -> Pos -> ParseOneResult-parseList stk !n !acc s !pos = case BC.uncons s of+parseList stk n acc s pos = case BC.uncons s of   Nothing -> errItemOrEnd Nothing pos   Just (c,s1) -> case c of     _ | isDigit c -> do-      (str, s2, pos2) <- parseString s pos-      parseList stk (n+1) (String str : acc) s2 pos2+      parseString s pos $ \str -> parseList stk (n+1) (String str : acc)     'i' -> do-      (i, s2, pos2) <- parseInteger s1 (pos+1)-      parseList stk (n+1) (Integer i : acc) s2 pos2+      parseInteger s1 (pos+1) $ \i -> parseList stk (n+1) (Integer i : acc)     'l' -> parseList (SList n acc stk) 0 [] s1 (pos+1)     'd' -> parseDict (SList n acc stk) s1 (pos+1)-    'e' -> resumeParse stk (List (arrayFromRevListN n acc)) s1 (pos+1)+    'e' -> resumeParse stk (List (Util.arrayFromRevListN n acc)) s1 (pos+1)     _   -> errItemOrEnd (Just c) pos  -- | Parse a Bencode dict. After the \'d\' marker. parseDict :: Stack -> B.ByteString -> Pos -> ParseOneResult-parseDict stk s !pos = case BC.uncons s of+parseDict stk s pos = case BC.uncons s of   Nothing -> errStringOrEnd Nothing pos   Just (c1,s1) -> case c1 of     _ | isDigit c1 -> do-      (key, s2, pos2) <- parseString s pos-      case BC.uncons s2 of-        Nothing -> errItem Nothing pos2-        Just (c3,s3) -> case c3 of-          _ | isDigit c3 -> do-            (str, s4, pos4) <- parseString s2 pos2-            parseDict1 key stk 1 [KeyValue key (String str)] s4 pos4-          'i' -> do-            (i, s4, pos4) <- parseInteger s3 (pos2+1)-            parseDict1 key stk 1 [KeyValue key (Integer i)] s4 pos4-          'l' -> parseList (SDict key 0 [] stk) 0 [] s3 (pos2+1)-          'd' -> parseDict (SDict key 0 [] stk) s3 (pos2+1)-          _   -> errItem (Just c3) pos2-    'e' -> resumeParse stk (Dict (arrayFromRevListN 0 [])) s1 (pos+1)+      parseString s pos $ \key s2 pos2 ->+        case BC.uncons s2 of+          Nothing -> errItem Nothing pos2+          Just (c3,s3) -> case c3 of+            _ | isDigit c3 -> do+              parseString s2 pos2 $ \str ->+                parseDict1 key stk 1 [KeyValue key (String str)]+            'i' -> do+              parseInteger s3 (pos2+1) $ \i ->+                parseDict1 key stk 1 [KeyValue key (Integer i)]+            'l' -> parseList (SDict key 0 [] stk) 0 [] s3 (pos2+1)+            'd' -> parseDict (SDict key 0 [] stk) s3 (pos2+1)+            _   -> errItem (Just c3) pos2+    'e' -> resumeParse stk (Dict (Util.arrayFromRevListN 0 [])) s1 (pos+1)     _   -> errStringOrEnd (Just c1) pos  -- | Parse a Bencode dict. After the first key-value pair. parseDict1 :: B.ByteString -> Stack -> Int -> [KeyValue] -> B.ByteString -> Pos            -> ParseOneResult-parseDict1 !pkey stk !n !acc s !pos = case BC.uncons s of+parseDict1 pkey stk n acc s pos = case BC.uncons s of   Nothing -> errStringOrEnd Nothing pos   Just (c1,s1) -> case c1 of     _ | isDigit c1 -> do-      (key, s2, pos2) <- parseString s pos-      if pkey >= key-      then errUnsortedKeys pkey key pos-      else case BC.uncons s2 of-        Nothing -> errItem Nothing pos2-        Just (c3,s3) -> case c3 of-          _ | isDigit c3 -> do-            (str, s4, pos4) <- parseString s2 pos2-            parseDict1 key stk (n+1) (KeyValue key (String str) : acc) s4 pos4-          'i' -> do-            (i, s4, pos4) <- parseInteger s3 (pos2+1)-            parseDict1 key stk (n+1) (KeyValue key (Integer i) : acc) s4 pos4-          'l' -> parseList (SDict key n acc stk) 0 [] s3 (pos2+1)-          'd' -> parseDict (SDict key n acc stk) s3 (pos2+1)-          _   -> errItem (Just c3) pos2-    'e' -> resumeParse stk (Dict (arrayFromRevListN n acc)) s1 (pos+1)+      parseString s pos $ \key s2 pos2 ->+        if pkey >= key+        then errUnsortedKeys pkey key pos+        else case BC.uncons s2 of+          Nothing -> errItem Nothing pos2+          Just (c3,s3) -> case c3 of+            _ | isDigit c3 -> do+              parseString s2 pos2 $ \str ->+                parseDict1 key stk (n+1) (KeyValue key (String str) : acc)+            'i' -> do+              parseInteger s3 (pos2+1) $ \i ->+                parseDict1 key stk (n+1) (KeyValue key (Integer i) : acc)+            'l' -> parseList (SDict key n acc stk) 0 [] s3 (pos2+1)+            'd' -> parseDict (SDict key n acc stk) s3 (pos2+1)+            _   -> errItem (Just c3) pos2+    'e' -> resumeParse stk (Dict (Util.arrayFromRevListN n acc)) s1 (pos+1)     _   -> errStringOrEnd (Just c1) pos  -- | Add the value to the previously incomplete value on the stack, and resume -- parsing it. resumeParse :: Stack -> Value -> B.ByteString -> Pos -> ParseOneResult-resumeParse stk !x s !pos = case stk of+resumeParse stk x s pos = case stk of   SNil               -> Right (x, s, unPos pos)   SList n xs stk1    -> parseList stk1 (n+1) (x:xs) s pos   SDict k n acc stk1 -> parseDict1 k stk1 (n+1) (KeyValue k x : acc) s pos@@ -143,8 +151,9 @@  -- | Parse a Bencode integer. After the \'i\' to the \'e\'. parseInteger :: B.ByteString -> Pos-             -> Either String (B.ByteString, B.ByteString, Pos)-parseInteger s !pos = case BC.uncons s of+             -> (B.ByteString -> B.ByteString -> Pos -> ParseOneResult)+             -> ParseOneResult+parseInteger s pos k = case BC.uncons s of   Nothing -> errDigit Nothing pos   Just (c1,s1) -> case c1 of     '0' -> end (B.take 1 s) s1 (pos+1)@@ -158,32 +167,38 @@         then errDigitOrNeg (Just c1) pos         else let n = B.length x in end x s2 (pos + Pos n)   where-    end x s' !pos' = case BC.uncons s' of+    end x s' pos' = case BC.uncons s' of       Nothing -> errEnd Nothing pos'       Just (c,s'') -> case c of-        'e' -> Right (x, s'', pos'+1)+        'e' -> k x s'' (pos'+1)         _   -> errEnd (Just c) pos'+    {-# INLINE end #-} {-# INLINE parseInteger #-}  -- | Parse a Bencode string. From the length count to the end of the string. parseString :: B.ByteString -> Pos-            -> Either String (B.ByteString, B.ByteString, Pos)-parseString s !pos = case BC.span isDigit s of-  (digs,s1) -> case readKnownNaturalAsInt False (BC.dropWhile (=='0') digs) of-    Nothing -> errTooLargeStringLength pos-    Just n ->-      let pos2 = pos + Pos (B.length digs)-      in case BC.uncons s1 of-          Nothing -> errColon Nothing pos2-          Just (c3,s3) -> case c3 of-            ':' -> case B.splitAt n s3 of-              (str,s4) | B.length str == n -> Right (str, s4, pos2 + 1 + Pos n)-              _ -> errTooLargeStringLength pos-            _   -> errColon (Just c3) pos2+            -> (B.ByteString -> B.ByteString -> Pos -> ParseOneResult)+            -> ParseOneResult+parseString s pos k = case BC.span isDigit s of+  (digs,s1) ->+    case Util.readKnownNaturalAsInt False (BC.dropWhile (=='0') digs) of+      Nothing -> errTooLargeStringLength pos+      Just n ->+        let pos2 = pos + Pos (B.length digs)+        in case BC.uncons s1 of+             Nothing -> errColon Nothing pos2+             Just (c3,s3) -> case c3 of+               ':' -> case B.splitAt n s3 of+                 (str,!s4) | B.length str == n -> k str s4 (pos2 + 1 + Pos n)+                 -- For some reason GHC does not realize without the bang that+                 -- s4 does not need to be boxed.+                 _ -> errTooLargeStringLength pos+               _   -> errColon (Just c3) pos2 {-# INLINE parseString #-}  ------------------------------ -- Error stuff+------------------------------  errorAtPos :: String -> Pos -> Either String a errorAtPos e (Pos n) = Left $ "ParseErrorAt " ++ show n ++ ": " ++ e@@ -209,19 +224,3 @@  errTooLargeStringLength :: Pos -> Either String a errTooLargeStringLength = errorAtPos "TooLargeStringLength"----------------------------------- Array---- | Create an array from a list in reverse order.-arrayFromRevListN :: Int -> [a] -> A.Array a-arrayFromRevListN n xs = A.createArray n errorElement $ \a ->-  let f x k = \i ->-        if i == -1-        then pure ()-        else A.writeArray a i x *> k (i-1)-  in foldr f (\ !_ -> pure ()) xs (n-1)-{-# INLINE arrayFromRevListN #-}--errorElement :: a-errorElement = error "errorElement"

@@ -1,99 +1,87 @@-{-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-} -- | -- Conversions from Bencoded @ByteString@s to Haskell values. ----- == Introduction------ Decoding is done using parsers. There are parsers for the four Bencode types:------ * 'string' decodes Bencode strings as 'B.ByteString's--- * 'integer' decodes Bencode integers as 'Prelude.Integer's--- * 'list' decodes Bencode lists as 'V.Vector's--- * 'dict' decodes Bencode dictionaries as 'M.Map's with 'B.ByteString' keys.------ These can be used to build more complex parsers for arbitrary types.------ @--- data File = File---   { hash :: ByteString---   , size :: Integer---   , tags :: Vector Text---   } deriving Show--- @------ Assuming a @File@ is encoded as a Bencode dictionary with the field names as--- keys and appropriate value types, a parser for @File@ can be defined as------ @--- {-# LANGUAGE OverloadedStrings #-}--- import qualified Data.Bencode.Decode as D------ fileParser :: D.'Parser' File--- fileParser =---   File \<\$> D.'field' "hash" D.'string'---        \<*> D.'field' "size" D.'integer'---        \<*> D.'field' "tags" (D.'list' D.'text')--- @------ The parser can then be run on a @ByteString@ with 'decode'.------ >>> D.decode fileParser "d4:hash4:xxxx4:sizei1024e4:tagsl4:work6:backupee"--- Right (File {hash = "xxxx", size = 1024, tags = ["work","backup"]})------ Of course, invalid Bencode or Bencode that does not satisfy our @File@ parser--- will fail to decode.------ >>> D.decode fileParser "d4:hash4:xxxx4:tagsl4:work6:backupee"--- Left "KeyNotFound \"size\""------ For more examples, see the \"Recipes\" section at the end of this page.--- module Data.Bencode.Decode-  ( -- * Parser+  (+    -- * Quick start+    -- $quick++    -- * Parser     Parser   , decode   , decodeMaybe -    -- * Primary parsers+    -- * String parsers   , string-  , integer-  , list-  , dict--    -- * More parsers   , stringEq   , text   , textEq++    -- * Integer parsers+  , integer   , int   , intEq+  , int64+  , int32+  , int16+  , int8   , word+  , word64+  , word32+  , word16+  , word8++    -- * List parsers+  , list+  , index+  , elem+  , list'+  , Elems++    -- * Dictionary parsers+  , dict   , field+  , field'+  , dict'+  , Fields++    -- * Miscellaneous   , value   , fail+  , mapMaybe+  , mapOrFail -    -- * Recipes-    --+    -- * Recipes #recipes#     -- $recipes   ) where -import Prelude hiding (fail)+import Prelude hiding (elem, fail) import Control.Applicative import Control.Monad hiding (fail) import Control.Monad.ST+import Control.Monad.Trans.Class import Control.Monad.Trans.Reader+import Control.Monad.Trans.State.Strict+import Data.Int+import Data.Word import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import qualified Data.Foldable as F+import qualified Data.IntSet as IS import qualified Data.Map as M import qualified Data.Primitive.Array as A import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Vector as V import qualified Data.Vector.Mutable as VM+import qualified GHC.Exts as X  import Data.Bencode.Type (Value(..))-import Data.Bencode.Util (readKnownNaturalAsInt, readKnownNaturalAsWord)+import qualified Data.Bencode.Util as Util import qualified Data.Bencode.AST as AST  newtype ParseResult a = ParseResult { unParseResult :: Either String a }@@ -108,21 +96,29 @@   l <|> r = ParseResult $ unParseResult l <> unParseResult r   -- Discards left error, not ideal +instance MonadPlus ParseResult+-- Does not satisfy MonadPlus laws because of the failure String+-- But required for Alternative (StateT _ ParseResult)+ -- | A parser from a Bencode value to a Haskell value.-newtype Parser a = Parser { runParser :: AST.Value -> ParseResult a }+newtype Parser a = Parser { runParser_ :: ReaderT AST.Value ParseResult a }   deriving (Functor, Applicative, Alternative, Monad)-    via ReaderT AST.Value ParseResult -lift :: ParseResult a -> Parser a-lift = Parser . const-{-# INLINE lift #-}+runParser :: Parser a -> AST.Value -> ParseResult a+runParser = runReaderT . runParser_+{-# INLINE runParser #-} +liftP :: ParseResult a -> Parser a+liftP = Parser . lift+{-# INLINE liftP #-}+ failParser :: String -> Parser a-failParser = lift . failResult+failParser = liftP . failResult {-# INLINE failParser #-}  -- | Decode a value from the given @ByteString@. If decoding fails, returns--- @Left@ with a failure message.+-- @Left@ with a failure message. The message is a short human-readable error+-- description and should not be relied on programmatically. decode :: Parser a -> B.ByteString -> Either String a decode p s = AST.parseOnly s >>= unParseResult . runParser p @@ -146,27 +142,27 @@ -- Eithers using "case-of-case".  stringDirect :: Parser B.ByteString-stringDirect = Parser $ \v -> case v of+stringDirect = Parser $ ReaderT $ \v -> case v of   AST.String s -> pure s-  _ -> errTypeMismatch "String" v+  _            -> errTypeMismatch "String" v {-# INLINE stringDirect #-}  integerDirect :: Parser B.ByteString-integerDirect = Parser $ \v -> case v of+integerDirect = Parser $ ReaderT $ \v -> case v of   AST.Integer s -> pure s-  _ -> errTypeMismatch "Integer" v+  _             -> errTypeMismatch "Integer" v {-# INLINE integerDirect #-}  listDirect :: Parser (A.Array AST.Value)-listDirect = Parser $ \v -> case v of+listDirect = Parser $ ReaderT $ \v -> case v of   AST.List a -> pure a-  _ -> errTypeMismatch "List" v+  _          -> errTypeMismatch "List" v {-# INLINE listDirect #-}  dictDirect :: Parser (A.Array AST.KeyValue)-dictDirect = Parser $ \v -> case v of+dictDirect = Parser $ ReaderT $ \v -> case v of   AST.Dict a -> pure a-  _ -> errTypeMismatch "Dict" v+  _          -> errTypeMismatch "Dict" v {-# INLINE dictDirect #-}  -- | Decode a Bencode string as a ByteString. Fails on a non-string.@@ -192,7 +188,7 @@ -- | Decode a Bencode list with the given parser for elements. Fails on a -- non-list or if any element in the list fails to parse. list :: Parser a -> Parser (V.Vector a)-list p = listDirect >>= lift . traverseAToV (runParser p)+list p = listDirect >>= liftP . traverseAToV (runParser p) {-# INLINE list #-}  traverseAToV :: (a -> ParseResult b) -> A.Array a -> ParseResult (V.Vector b)@@ -211,7 +207,7 @@ -- non-dict or if any value in the dict fails to parse. dict :: Parser a -> Parser (M.Map B.ByteString a) dict p =-  dictDirect >>= lift . fmap M.fromDistinctAscList . traverse f .  F.toList+  dictDirect >>= liftP . fmap M.fromDistinctAscList . traverse f .  F.toList   where     f (AST.KeyValue k v) = (,) k <$> runParser p v {-# INLINE dict #-}@@ -246,8 +242,8 @@ int = integerDirect >>= maybe (failParser "IntOutOfBounds") pure . go   where     go s = case BC.uncons s of-      Just ('-', s') -> readKnownNaturalAsInt True s'-      _              -> readKnownNaturalAsInt False s+      Just ('-', s') -> Util.readKnownNaturalAsInt True s'+      _              -> Util.readKnownNaturalAsInt False s {-# INLINE int #-}  -- | Succeeds only on a Bencode integer that equals the given value.@@ -265,7 +261,7 @@   where     go s = case BC.uncons s of       Just ('-',_) -> Nothing-      _            -> readKnownNaturalAsWord s+      _            -> Util.readKnownNaturalAsWord s {-# INLINE word #-}  -- | Decode a @Value@. Always succeeds for valid Bencode.@@ -282,31 +278,313 @@  -- | Decode a value with the given parser for the given key. Fails on a -- non-dict, if the key is absent, or if the value parser fails.+--+-- If keys should not be left over in the dict, use 'field'' and 'dict''+-- instead.+--+-- ==== __Examples__+-- @+-- data File = File { name :: Text, size :: Int }+--+-- fileParser :: D.'Parser' File+-- fileParser =+--   File \<$> D.field "name" D.'text'+--        \<*> D.field "size" D.'int'+-- @ field :: B.ByteString -> Parser a -> Parser a-field k p =-  dictDirect >>=-  maybe (failParser $ "KeyNotFound " ++ show k) pure . binarySearch k >>=-  lift . runParser p+field k p = do+  a <- dictDirect+  case binarySearch k a of+    (# _ |            #) -> failParser $ "KeyNotFound " ++ show k+    (#   | (# _, x #) #) -> liftP $ runParser p x {-# INLINE field #-} -------------- Utils+-- | Decode a value with the given parser for the given key. Convert to a+-- @Parser@ with 'dict''.+--+-- @since 0.1.1.0+field' :: B.ByteString -> Parser a -> Fields a+field' k p = Fields $ ReaderT $ \a -> case binarySearch k a of+  (# _ |             #) -> lift . failResult $ "KeyNotFound " ++ show k+  (#   | (# i#, v #) #) -> lift (runParser p v) <* modify' (IS.insert (X.I# i#))+{-# INLINE field' #-} +-- | Create a @Parser@ from a 'Fields'. Fails on a non-dict, if a key is+-- absent, or if any value fails to parse. Also fails if there are leftover+-- unparsed keys in the dict.+--+-- If leftover keys should be ignored, use 'field' instead.+--+-- ==== __Examples__+-- @+-- data File = File { name :: Text, size :: Int }+--+-- fileParser :: D.'Parser' File+-- fileParser = D.dict' $+--   File \<$> D.'field'' "name" D.'text'+--        \<*> D.'field'' "size" D.'int'+-- @+--+-- @since 0.1.1.0+dict' :: Fields a -> Parser a+dict' fs = do+  a <- dictDirect+  liftP $ do+    (v, is) <- runStateT (runReaderT (runFields fs) a) IS.empty+    if IS.size is == A.sizeofArray a+    then pure v+    else let i = head $ filter (`IS.notMember` is) [0..]+             AST.KeyValue k _ = A.indexArray a i+         in failResult $ "UnrecognizedKey " ++ show k+{-# INLINE dict' #-}++-- | Key-value parsers. See 'dict'' and 'field''.+newtype Fields a = Fields+  { runFields ::+      ReaderT (A.Array AST.KeyValue) (StateT IS.IntSet ParseResult) a+  } deriving (Functor, Applicative, Alternative, Monad)+-- We could use WriterT (CPS) but StateT is a teeny bit more efficient because+-- we can do IS.insert x instead of IS.union (IS.singleton x).++-- | Decode a list element with the given parser at the given (0-based) index.+-- Fails on a non-list, if the index is out of bounds, or if the element parser+-- fails.+--+-- Also see 'elem' and 'list''.+--+-- ==== __Examples__+-- @+-- data File = File { name :: Text, size :: Int }+--+-- fileParser :: D.'Parser' File+-- fileParser =+--   File \<$> D.index 0 D.'text'+--        \<*> D.index 1 D.'int'+-- @+--+-- @since 0.1.1.0+index :: Int -> Parser a -> Parser a+index i _ | i < 0 = failParser "IndexOutOfBounds"+index i p = do+  a <- listDirect+  if i < A.sizeofArray a+  then liftP $ runParser p (A.indexArray a i)+  else failParser "IndexOutOfBounds"+{-# INLINE index #-}++-- | Decode the next list element with the given parser. Convert to a @Parser@+-- with 'list''.+--+-- @since 0.1.1.0+elem :: Parser a -> Elems a+elem p = Elems $ ReaderT $ \a -> do+  i <- get+  if i < A.sizeofArray a+  then lift (runParser p (A.indexArray a i)) <* (put $! i+1)+  else lift $ failResult "ListElemsExhausted"+{-# INLINE elem #-}++-- | Create a @Parser@ from an @Elems@. Fails on a non-list, if the number of+-- elements does not match the @Elems@ exactly, or if any element parser fails.+--+-- ==== __Examples__+-- @+-- data File = File { name :: Text, size :: Int }+--+-- fileParser :: D.'Parser' File+-- fileParser = D.list' $+--   File \<$> D.'elem' D.'text'+--        \<*> D.'elem' D.'int'+-- @+--+-- @since 0.1.1.0+list' :: Elems a -> Parser a+list' es = do+  a <- listDirect+  liftP $ do+    (x, i) <- runStateT (runReaderT (runElems es) a) 0+    if i == A.sizeofArray a+    then pure x+    else failResult $ "ListElemsLeft"+{-# INLINE list' #-}++-- | List elements parser. See 'elem' and 'list''.+newtype Elems a = Elems+  { runElems :: ReaderT (A.Array AST.Value) (StateT Int ParseResult) a+  } deriving (Functor, Applicative, Alternative, Monad)++-- | Decode a Bencode integer as an @Int64@. Fails on a non-integer or if the+-- integer is out of bounds for an @Int64@.+--+-- @since 0.1.1.0+int64 :: Parser Int64+int64 = integerDirect >>= maybe (failParser "IntOutOfBounds") pure . go+  where+    go s = case BC.uncons s of+      Just ('-', s') -> Util.readKnownNaturalAsInt64 True s'+      _              -> Util.readKnownNaturalAsInt64 False s+{-# INLINE int64 #-}++-- | Decode a Bencode integer as an @Int32@. Fails on a non-integer or if the+-- integer is out of bounds for an @Int32@.+--+-- @since 0.1.1.0+int32 :: Parser Int32+int32 = intL32+{-# INLINE int32 #-}++-- | Decode a Bencode integer as an @Int16@. Fails on a non-integer or if the+-- integer is out of bounds for an @Int16@.+--+-- @since 0.1.1.0+int16 :: Parser Int16+int16 = intL32+{-# INLINE int16 #-}++-- | Decode a Bencode integer as an @Int8@. Fails on a non-integer or if the+-- integer is out of bounds for an @Int8@.+--+-- @since 0.1.1.0+int8 :: Parser Int8+int8 = intL32+{-# INLINE int8 #-}++-- Parse an Int(<=32) via Int.+intL32 :: forall a. (Bounded a, Integral a) => Parser a+intL32 = int >>= \i ->+  if fromIntegral (minBound :: a) <= i && i <= fromIntegral (maxBound :: a)+  then pure $! fromIntegral i+  else failParser "IntOutOfBounds"+{-# INLINE intL32 #-}++-- | Decode a Bencode integer as a @Word64@. Fails on a non-integer or if the+-- integer is out of bounds for a @Word64@.+--+-- @since 0.1.1.0+word64 :: Parser Word64+word64 = integerDirect >>= maybe (failParser "WordOutOfBounds") pure . go+  where+    go s = case BC.uncons s of+      Just ('-', _) -> Nothing+      _             -> Util.readKnownNaturalAsWord64 s+{-# INLINE word64 #-}++-- | Decode a Bencode integer as a @Word32@. Fails on a non-integer or if the+-- integer is out of bounds for a @Word32@.+--+-- @since 0.1.1.0+word32 :: Parser Word32+word32 = wordL32+{-# INLINE word32 #-}++-- | Decode a Bencode integer as a @Word16@. Fails on a non-integer or if the+-- integer is out of bounds for a @Word16@.+--+-- @since 0.1.1.0+word16 :: Parser Word16+word16 = wordL32+{-# INLINE word16 #-}++-- | Decode a Bencode integer as a @Word8@. Fails on a non-integer or if the+-- integer is out of bounds for a @Word8@.+--+-- @since 0.1.1.0+word8 :: Parser Word8+word8 = wordL32+{-# INLINE word8 #-}++-- Parse a Word(<=32) via Word.+wordL32 :: forall a. (Bounded a, Integral a) => Parser a+wordL32 = word >>= \i ->+  if fromIntegral (minBound :: a) <= i && i <= fromIntegral (maxBound :: a)+  then pure $! fromIntegral i+  else failParser "WordOutOfBounds"+{-# INLINE wordL32 #-}++-- | Run the function on the parsed value, fail with 'empty' if the result is+-- @Nothing@.+--+-- @since 0.1.1.0+mapMaybe :: (a -> Maybe b) -> Parser a -> Parser b+mapMaybe f p = p >>= maybe empty pure . f+{-# INLINE mapMaybe #-}++-- | Run the function on the parsed value, fail with 'fail' if the result is a+-- @Left@.+--+-- @since 0.1.1.0+mapOrFail :: (a -> Either String b) -> Parser a -> Parser b+mapOrFail f p = p >>= either fail pure . f+{-# INLINE mapOrFail #-}+ -- | Binary search. The array must be sorted by key.-binarySearch :: B.ByteString -> A.Array AST.KeyValue -> Maybe AST.Value+binarySearch+  :: B.ByteString+  -> A.Array AST.KeyValue+  -> (# (# #) | (# X.Int#,  AST.Value #) #) binarySearch k a = go 0 (A.sizeofArray a)   where-    go l r | l == r = Nothing+    go l r | l == r = (# (# #) | #)     go l r = case compare k k' of       LT -> go l m-      EQ -> Just v+      EQ -> (# | (# case m of X.I# m# -> m#, v #) #)       GT -> go (m+1) r       where         -- Overflow, careful!         m = fromIntegral ((fromIntegral (l+r) :: Word) `div` 2) :: Int         AST.KeyValue k' v = A.indexArray a m {-# INLINABLE binarySearch #-}+-- binarySearch returns an unboxed type, which serves as an equivalent of+-- Maybe (Int, Value). This is to avoid allocating the (,) and the I#. This+-- won't be necessary if GHC gets+-- https://gitlab.haskell.org/ghc/ghc/-/issues/14259.+-- A (not-so-good) alternative is to inline binarySearch. +------------------------------+-- Documentation+------------------------------++-- $quick+-- Decoding is done using parsers. This module defines parsers that can be+-- composed to build parsers for arbitrary types.+--+-- @+-- data File = File+--   { hash :: ByteString+--   , size :: Integer+--   , tags :: Vector Text+--   } deriving Show+-- @+--+-- Assuming a @File@ is encoded as a Bencode dictionary with the field names as+-- keys and appropriate value types, a parser for @File@ can be defined as+--+-- @+-- {-# LANGUAGE OverloadedStrings #-}+-- import qualified Data.Bencode.Decode as D+--+-- fileParser :: D.'Parser' File+-- fileParser =+--   File \<\$> D.'field' "hash" D.'string'+--        \<*> D.'field' "size" D.'integer'+--        \<*> D.'field' "tags" (D.'list' D.'text')+-- @+--+-- The parser can then be run on a @ByteString@ with 'decode'.+--+-- >>> D.decode fileParser "d4:hash4:xxxx4:sizei1024e4:tagsl4:work6:backupee"+-- Right (File {hash = "xxxx", size = 1024, tags = ["work","backup"]})+--+-- Of course, invalid Bencode or Bencode that does not satisfy the @File@ parser+-- will fail to decode.+--+-- >>> D.decode fileParser "d4:hash4:xxxx4:tagsl4:work6:backupee"+-- Left "KeyNotFound \"size\""+--+-- For more examples, see the [Recipes](#g:recipes) section at the end of this+-- page.++ -- $recipes -- Recipes for some common and uncommon usages. --@@ -358,11 +636,26 @@ -- >>> D.decode colorParser "5:black" -- Left "Fail: unknown color" ----- === Decode differently based on dict contents+-- === Decode a dict, failing on leftover keys -- -- @--- import Control.Applicative ('(<|>)')+-- data File = File { name :: Text, size :: Int } deriving Show --+-- fileParser :: D.'Parser' File+-- fileParser = D.'dict'' $+--   File+--     \<$> D.'field'' "name" D.'text'+--     \<*> D.'field'' "size" D.'int'+-- @+--+-- >>> D.decode fileParser "d4:name9:hello.txt4:sizei32ee"+-- Right (File {name = "hello.txt", size = 32})+-- >>> D.decode fileParser "d6:hiddeni1e4:name9:hello.txt4:sizei32ee"+-- Left "UnrecognizedKey \"hidden\""+--+-- === Decode differently based on dict contents+--+-- @ -- data Response = Response --   { id_    :: Int --   , result :: Either Text ByteString@@ -371,14 +664,15 @@ -- responseParser :: D.'Parser' Response -- responseParser = do --   id_ <- D.'field' "id" D.'int'---   success <- D.'field' "status" $---         False \<$ D.'stringEq' "failure"---     \<|> True  \<$ D.'stringEq' "success"---     \<|> D.'fail' "unknown status"---   Response id_---     \<$> if success---         then Right \<$> D.'field' "data" D.'string'---         else Left  \<$> D.'field' "reason" D.'text'+--   status <- D.'field' "status" D.'string'+--   case status of+--     "failure" -> do+--       reason <- D.'field' "reason" D.'text'+--       pure $ Response id_ (Left reason)+--     "success" -> do+--       data_ <- D.'field' "data" D.'string'+--       pure $ Response id_ (Right data_)+--     _ -> D.'fail' "unknown status" -- @ -- -- >>> D.decode responseParser "d2:idi42e6:reason12:unauthorized6:status7:failuree"@@ -399,5 +693,20 @@ -- @ -- -- >>> D.decode fileParser "d8:metadatad4:infod4:sizei32eee4:name9:hello.txte"+-- Right (File {name = "hello.txt", size = 32})+--+-- === Decode a heterogeneous list+--+-- @+-- data File = File { name :: Text, size :: Int } deriving Show+--+-- fileParser :: D.'Parser' File+-- fileParser = D.'list'' $+--   File+--     \<$> D.'elem' D.'text'+--     \<*> D.'elem' D.'int'+-- @+--+-- >>> D.decode fileParser "l9:hello.txti32ee" -- Right (File {name = "hello.txt", size = 32}) --

@@ -2,85 +2,51 @@ -- | -- Conversions from Haskell values to Bencoded @ByteString@s. ----- == Introduction------ Encoding is done using encoders. An encoder is simply a function from a--- Haskell type to 'Encoding'. There are encoders for the four Bencode types:------ * 'string' encodes 'B.ByteString's as Bencode strings--- * 'integer' encodes 'Prelude.Integer's as Bencode integers--- * 'list' encodes 'V.Vector's as Bencode lists--- * 'dict' encodes 'M.Map's with 'B.ByteString' keys as Bencode dictionaries------ These can used to build more complex encoders for arbitrary types.------ @--- data File = File---   { hash :: ByteString---   , size :: Integer---   , tags :: Vector Text---   } deriving Show--- @------ It is reasonable to encode a @File@ as a Bencode dictionary with the field--- names as keys, and appropriate types for the values.------ @--- {-# LANGUAGE OverloadedStrings #-}--- import qualified Data.Bencode.Encode as E------ encodeFile :: File -> E.'Encoding'--- encodeFile (File hash size tags) = E.'dict'' $---      E.'field' "hash" E.'string' hash---   <> E.'field' "size" E.'integer' size---   <> E.'field' "tags" (E.'list' E.'text') tags--- @------ Applying 'toBuilder' to an 'Encoding' gives a @ByteString@--- 'Data.ByteString.Builder', which can then be converted to a lazy--- @ByteString@, written to a file, or used otherwise.------ @--- import qualified Data.ByteString.Builder (toLazyByteString)--- import qualified Data.Vector as V--- @------ >>> toLazyByteString $ encodeFile $ File "xxxx" 1024 (V.fromList ["work", "backup"])--- "d4:hash4:xxxx4:sizei1024e4:tagsl4:work6:backupee"------ In this module, encodings are total conversions from Haskell values to--- @ByteString@s. If some data should fail to encode, it should be handled--- separately.------ For more examples, see the \"Recipes\" section at the end of this page.- module Data.Bencode.Encode   (-  -- * Encoding+    -- * Quick start+    -- $quick++    -- * Encoding     Encoding   , toBuilder -  -- * Primary encoders+    -- * String encoders   , string-  , integer-  , list-  , dict--  -- * More encoders   , text++    -- * Integer encoders+  , integer   , int+  , int64+  , int32+  , int16+  , int8   , word+  , word64+  , word32+  , word16+  , word8++    -- * List encoders+  , list++    -- * Dictionary encoders+  , dict   , field   , dict'   , FieldEncodings++    -- * Miscellaneous   , value -  -- * Recipes-  ---  -- $recipes+    -- * Recipes #recipes#+    -- $recipes   ) where +import Data.Int import Data.Monoid (Endo(..))+import Data.Word import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB import qualified Data.Map as M@@ -103,37 +69,39 @@  -- | Encode an integer as a Bencode integer. integer :: Integer -> Encoding-integer i = Encoding $ BB.char7 'i' <> BB.integerDec i <> BB.char7 'e'+integer = integer_ BB.integerDec  -- | Encode a @Vector@ as a Bencode list, using the given encoder for elements. list :: (a -> Encoding) -> V.Vector a -> Encoding list enc vs =   Encoding $ BB.char7 'l' <> foldMap (unEncoding . enc) vs <> BB.char7 'e'+{-# INLINE list #-}  -- | Encode a @Map@ as a Bencode dictionary, using the given encoder for values. dict :: (a -> Encoding) -> M.Map B.ByteString a -> Encoding dict enc kvs = Encoding $ BB.char7 'd' <> f kvs <> BB.char7 'e'   where     f = M.foldMapWithKey (\k v -> unEncoding (string k) <> unEncoding (enc v))+{-# INLINE dict #-}  -- | Encode @Text@ as a Bencode string. As per the Bencode specification, all -- text must be encoded as UTF-8 strings. text :: T.Text -> Encoding text = string . T.encodeUtf8+{-# INLINE text #-} -- TODO: Check if Text's encodeUtf8Builder is more efficient. But we would -- also need to know the UTF-8 len, which is only viable for text >= 2.0.  -- | Encode an @Int@ as a Bencode integer. int :: Int -> Encoding-int i = Encoding $ BB.char7 'i' <> BB.intDec i <> BB.char7 'e'+int = integer_ BB.intDec  -- | Encode a @Word@ as a Bencode integer. word :: Word -> Encoding-word w = Encoding $ BB.char7 'i' <> BB.wordDec w <> BB.char7 'e'---- Option 1+word = integer_ BB.wordDec --- | A key-value encoding for a Bencode dictionary.+-- | A key-value encoding for a Bencode dictionary. Convert to an @Encoding@+-- with 'dict''. field :: B.ByteString -> (a -> Encoding) -> a -> FieldEncodings field k enc v = FE (Endo ((k, enc v):)) {-# INLINE field #-}@@ -144,8 +112,9 @@ -- arbitrary key-value pair among them will be encoded and the rest discarded. dict' :: FieldEncodings -> Encoding dict' = dict id . M.fromList . ($ []) . appEndo . unFE+{-# INLINE dict' #-} --- | Key-value encodings for a Bencode dictionary.+-- | Key-value encodings for a Bencode dictionary. See 'field' and 'dict''. newtype FieldEncodings = FE { unFE :: Endo [(B.ByteString, Encoding)] }   deriving (Semigroup, Monoid) -- FieldEncodings is not just a type alias because there are multiple ways to@@ -160,8 +129,111 @@   List vs   -> list value vs   Dict vs   -> dict value vs +-- | Encode an @Int64@ as a Bencode integer.+--+-- @since 0.1.1.0+int64 :: Int64 -> Encoding+int64 = integer_ BB.int64Dec++-- | Encode an @Int32@ as a Bencode integer.+--+-- @since 0.1.1.0+int32 :: Int32 -> Encoding+int32 = integer_ BB.int32Dec++-- | Encode an @Int16@ as a Bencode integer.+--+-- @since 0.1.1.0+int16 :: Int16 -> Encoding+int16 = integer_ BB.int16Dec++-- | Encode an @Int8@ as a Bencode integer.+--+-- @since 0.1.1.0+int8 :: Int8 -> Encoding+int8 = integer_ BB.int8Dec++-- | Encode a @Word64@ as a Bencode integer.+--+-- @since 0.1.1.0+word64 :: Word64 -> Encoding+word64 = integer_ BB.word64Dec++-- | Encode a @Word32@ as a Bencode integer.+--+-- @since 0.1.1.0+word32 :: Word32 -> Encoding+word32 = integer_ BB.word32Dec++-- | Encode a @Word16@ as a Bencode integer.+--+-- @since 0.1.1.0+word16 :: Word16 -> Encoding+word16 = integer_ BB.word16Dec++-- | Encode a @Word8@ as a Bencode integer.+--+-- @since 0.1.1.0+word8 :: Word8 -> Encoding+word8 = integer_ BB.word8Dec++integer_ :: (a -> BB.Builder) -> a -> Encoding+integer_ f = \x -> Encoding $ BB.char7 'i' <> f x <> BB.char7 'e'+{-# INLINE integer_ #-}++------------------------------+-- Documentation+------------------------------++-- $quick+-- Encoding is done using encoders. An encoder is simply a function from a+-- Haskell type to 'Encoding'. This module defines encoders that can be+-- composed to build encoders for arbitrary types.+--+-- @+-- data File = File+--   { hash :: ByteString+--   , size :: Integer+--   , tags :: Vector Text+--   } deriving Show+-- @+--+-- It is reasonable to encode a @File@ as a Bencode dictionary with the field+-- names as keys, and appropriate types for the values.+--+-- @+-- {-# LANGUAGE OverloadedStrings #-}+-- import qualified Data.Bencode.Encode as E+--+-- encodeFile :: File -> E.'Encoding'+-- encodeFile (File hash size tags) = E.'dict'' $+--      E.'field' "hash" E.'string' hash+--   <> E.'field' "size" E.'integer' size+--   <> E.'field' "tags" (E.'list' E.'text') tags+-- @+--+-- Applying 'toBuilder' to an 'Encoding' gives a @ByteString@+-- 'Data.ByteString.Builder', which can then be converted to a lazy+-- @ByteString@, written to a file, or used otherwise.+--+-- @+-- import qualified Data.ByteString.Builder (toLazyByteString)+-- import qualified Data.Vector as V+-- @+--+-- >>> toLazyByteString $ encodeFile $ File "xxxx" 1024 (V.fromList ["work", "backup"])+-- "d4:hash4:xxxx4:sizei1024e4:tagsl4:work6:backupee"+--+-- In this module, encodings are total conversions from Haskell values to+-- @ByteString@s. If some data should fail to encode, it should be handled+-- separately.+--+-- For more examples, see the [Recipes](#g:recipes) section at the end of this+-- page.++ -- $recipes--- Recipies for some common and uncommon usages.+-- Recipes for some common and uncommon usages. -- -- The following preface is assumed. --@@ -169,6 +241,7 @@ -- {-# LANGUAGE OverloadedStrings #-} -- import Data.ByteString.Builder (toLazyByteString) -- import Data.Text (Text)+-- import qualified Data.Vector as V -- import qualified Data.Bencode.Encode as E -- -- toLBS = toLazyByteString . E.toBuilder@@ -244,4 +317,17 @@ -- -- >>> toLBS $ encodeFile $ File "hello.txt" 32 -- "d8:metadatad4:infod4:sizei32eee4:name9:hello.txte"+--+-- === Encode as a heterogeneous list+--+-- @+-- data File = File { name :: Text, size :: Int }+--+-- encodeFile :: File -> E.'Encoding'+-- encodeFile (File name size) =\+--   E.'list' id $ V.fromList [E.'text' name, E.'int' size]+-- @+--+-- >>> toLBS $ encodeFile $ File "hello.txt" 32+-- "l9:hello.txti32ee" --

@@ -1,9 +1,8 @@ -- | -- This module defines the 'Value' type to represent any valid Bencode value. ----- Generally you will want to write decoders and encoders to work with your--- own types. See "Data.Bencode.Decode" and "Data.Bencode.Encode" to get--- started.+-- See "Data.Bencode.Decode" and "Data.Bencode.Encode" to perform decoding+-- and encoding. -- module Data.Bencode.Type   ( Value(..)

@@ -1,58 +1,100 @@+{-# LANGUAGE BangPatterns #-} module Data.Bencode.Util-  ( readKnownNaturalAsInt+  ( arrayFromRevListN+  , readKnownNaturalAsInt+  , readKnownNaturalAsInt64   , readKnownNaturalAsWord+  , readKnownNaturalAsWord64   ) where  import Data.Bits+import Data.Int+import Data.Word import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B+import qualified Data.Primitive.Array as A +-- | Create an array from a list in reverse order. The list length must be n.+arrayFromRevListN :: Int -> [a] -> A.Array a+arrayFromRevListN n xs = A.createArray n errorElement $ \a ->+  let f x k = \i ->+        if i == -1+        then pure ()+        else A.writeArray a i x *> k (i-1)+  in foldr f (\ !_ -> pure ()) xs (n-1)+{-# INLINE arrayFromRevListN #-}++errorElement :: a+errorElement = error "errorElement"+ -- | The input string must be an unsigned decimal integer with no extraneous -- leading zeros. Returns Nothing if the value is outside the bounds of an -- @Int@. readKnownNaturalAsInt :: Bool -> B.ByteString -> Maybe Int-readKnownNaturalAsInt neg s = case B.uncons sr of-  Nothing -> Just $! if neg then -n else n-  Just (d,sr')-    | B.null sr'-    , let d' = fromIntegral d - 48-    , n < iMaxDiv10 || n == iMaxDiv10 && d' <= (7 + fromEnum neg)-                       -- last digit of maxBound = 7, minBound = 8-    -> Just $! if neg then -n * 10 - d' else n * 10 + d'-    | otherwise -> Nothing+readKnownNaturalAsInt = readInt maxIntLen   where-    (sl,sr) = B.splitAt (maxIntLen - 1) s-    n = B.foldl' (\acc d -> acc * 10 + fromIntegral d - 48) 0 sl+    maxIntLen = case finiteBitSize (0 :: Int) of+      32 -> 10+      64 -> 19+      _  -> error "unsupported word size"+{-# INLINE readKnownNaturalAsInt #-} -iMaxDiv10 :: Int-iMaxDiv10 = maxBound `div` 10+-- | Similar to 'readKnownNaturalAsInt', for 'Int64'.+readKnownNaturalAsInt64 :: Bool -> B.ByteString -> Maybe Int64+readKnownNaturalAsInt64 = readInt 19+{-# INLINE readKnownNaturalAsInt64 #-} -maxIntLen :: Int-maxIntLen = case finiteBitSize (0 :: Int) of-  32 -> 10-  64 -> 19-  _  -> error "unsupported word size"+readInt :: (Bounded a, Integral a) => Int -> Bool -> B.ByteString -> Maybe a+readInt maxLen neg s = if neg then fmap negate n else n+  where+    -- last digit of maxBound = 7, minBound = 8+    n = readWord maxLen (maxBound `div` 10) (7 + fromIntegral (fromEnum neg)) s+{-# INLINE readInt #-}  -- | The input string must be an unsigned decimal integer with no extraneous -- leading zeros. Returns Nothing if the value is outside the bounds of a -- @Word@. readKnownNaturalAsWord :: B.ByteString -> Maybe Word-readKnownNaturalAsWord s = case B.uncons sr of-  Nothing -> Just $! n-  Just (d,sr')-    | B.null sr'-    , let d' = fromIntegral d - 48-    , n < wMaxDiv10 || n == wMaxDiv10 && d' <= 5 -- last digit of maxBound is 5-    -> Just $! n * 10 + d'-    | otherwise -> Nothing+readKnownNaturalAsWord = readWord maxWordLen (maxBound `div` 10) 5   where-    (sl,sr) = B.splitAt (maxWordLen - 1) s-    n = B.foldl' (\acc d -> acc * 10 + fromIntegral d - 48) 0 sl+    -- last digit of maxBound = 5+    maxWordLen = case finiteBitSize (0 :: Word) of+      32 -> 10+      64 -> 20+      _  -> error "unsupported word size"+{-# INLINE readKnownNaturalAsWord #-} -wMaxDiv10 :: Word-wMaxDiv10 = maxBound `div` 10+-- | Similar to 'readKnownNaturalAsWord', for 'Word64'.+readKnownNaturalAsWord64 :: B.ByteString -> Maybe Word64+readKnownNaturalAsWord64 = readWord 20 (maxBound `div` 10) 5+{-# INLINE readKnownNaturalAsWord64 #-} -maxWordLen :: Int-maxWordLen = case finiteBitSize (0 :: Word) of-  32 -> 10-  64 -> 20-  _  -> error "unsupported word size"+-- maxLen must be > 0!+readWord :: (Bounded a, Integral a) => Int -> a -> a -> B.ByteString -> Maybe a+readWord maxLen maxValueDiv10 maxValueMod10 s =+  case compare (B.length s) maxLen of+    LT -> Just $! readFull' s+    EQ ->+      let n = readFull (B.unsafeInit s)+          d = digitToI (B.unsafeLast s)+      in if n < maxValueDiv10 || n == maxValueDiv10 && d <= maxValueMod10+         then Just $! n*10 + d+         else Nothing+    GT -> Nothing+{-# INLINE readWord #-}++readFull :: Integral a => B.ByteString -> a+readFull = B.foldl' (\acc c -> acc * 10 + digitToI c) 0+{-# INLINE readFull #-}++-- Same as readFull but avoids+-- https://gitlab.haskell.org/ghc/ghc/-/issues/24203+readFull' :: Integral a => B.ByteString -> a+readFull' s = case B.unsnoc s of+  Nothing     -> 0+  Just (s',c) -> readFull s' * 10 + digitToI c+{-# INLINE readFull' #-}++digitToI :: Integral a => Word8 -> a+digitToI c = fromIntegral c - 48+{-# INLINE digitToI #-}

@@ -1,15 +1,19 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  -- Arbitrary instances import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck +import Control.Applicative+import Control.Monad import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BLC+import qualified Data.Foldable as F import qualified Data.Map as M import qualified Data.Vector as V @@ -18,7 +22,7 @@ import qualified Data.Bencode.Type as Ben  main :: IO ()-main = defaultMain $ testGroup "Tests"+main = defaultMain $ localOption (QuickCheckTests 2000) $ testGroup "Tests"   [ astTests   , decodeTests   , encodeTests@@ -102,81 +106,144 @@   [ testGroup "string"     [ testCase "0:" $ D.decode D.string "0:" @?= Right ""     , testCase "3:foo" $ D.decode D.string "3:foo" @?= Right "foo"-    , testCase "i0e" $ D.decode D.string "i0e" @?= Left "TypeMismatch String Integer"-    , testCase "le" $ D.decode D.string "le" @?= Left "TypeMismatch String List"-    , testCase "de" $ D.decode D.string "de" @?= Left "TypeMismatch String Dict"+    , testCase "type mismatch integer" $ D.decode D.string "i0e" @?= Left "TypeMismatch String Integer"+    , testCase "type mismatch list" $ D.decode D.string "le" @?= Left "TypeMismatch String List"+    , testCase "type mismatch dict" $ D.decode D.string "de" @?= Left "TypeMismatch String Dict"     ]   , testGroup "integer"     [ testCase "i0e" $ D.decode D.integer "i0e" @?= Right 0     , testCase "i-32e" $ D.decode D.integer "i-32e" @?= Right (-32)     , testCase "i98765432109876543210e" $ D.decode D.integer "i98765432109876543210e" @?= Right 98765432109876543210-    , testCase "0:" $ D.decode D.integer "0:" @?= Left "TypeMismatch Integer String"-    , testCase "le" $ D.decode D.integer "le" @?= Left "TypeMismatch Integer List"-    , testCase "de" $ D.decode D.integer "de" @?= Left "TypeMismatch Integer Dict"+    , testCase "type mismatch string" $ D.decode D.integer "0:" @?= Left "TypeMismatch Integer String"+    , testCase "type mismatch list" $ D.decode D.integer "le" @?= Left "TypeMismatch Integer List"+    , testCase "type mismatch dict" $ D.decode D.integer "de" @?= Left "TypeMismatch Integer Dict"     ]   , testGroup "list"     [ testCase "le" $ D.decode (D.list D.value) "le" @?= Right []     , testCase "l3:foo3:bare" $ D.decode (D.list D.string) "l3:foo3:bare" @?= Right ["foo", "bar"]-    , testCase "l3:fooi1ee" $ D.decode (D.list D.string) "l3:fooi1ee" @?= Left "TypeMismatch String Integer"-    , testCase "0:" $ D.decode (D.list D.value) "0:" @?= Left "TypeMismatch List String"-    , testCase "i0e" $ D.decode (D.list D.value) "i0e" @?= Left "TypeMismatch List Integer"-    , testCase "de" $ D.decode (D.list D.value) "de" @?= Left "TypeMismatch List Dict"+    , testCase "elem type mismatch" $ D.decode (D.list D.string) "l3:fooi1ee" @?= Left "TypeMismatch String Integer"+    , testCase "type mismatch string" $ D.decode (D.list D.value) "0:" @?= Left "TypeMismatch List String"+    , testCase "type mismatch integer" $ D.decode (D.list D.value) "i0e" @?= Left "TypeMismatch List Integer"+    , testCase "type mismatch dict" $ D.decode (D.list D.value) "de" @?= Left "TypeMismatch List Dict"     ]   , testGroup "dict"     [ testCase "de" $ D.decode (D.dict D.value) "de" @?= Right []     , testCase "d3:foo3:bare" $ D.decode (D.dict D.string) "d3:foo3:bare" @?= Right [("foo", "bar")]-    , testCase "d3:foo3:bar3:quxi1ee" $ D.decode (D.dict D.string) "d3:foo3:bar3:quxi1ee" @?= Left "TypeMismatch String Integer"-    , testCase "0:" $ D.decode (D.dict D.value) "0:" @?= Left "TypeMismatch Dict String"-    , testCase "i0e" $ D.decode (D.dict D.value) "i0e" @?= Left "TypeMismatch Dict Integer"-    , testCase "le" $ D.decode (D.dict D.value)"le" @?= Left "TypeMismatch Dict List"+    , testCase "value type mismatch" $ D.decode (D.dict D.string) "d3:foo3:bar3:quxi1ee" @?= Left "TypeMismatch String Integer"+    , testCase "type mismatch string" $ D.decode (D.dict D.value) "0:" @?= Left "TypeMismatch Dict String"+    , testCase "type mismatch integer" $ D.decode (D.dict D.value) "i0e" @?= Left "TypeMismatch Dict Integer"+    , testCase "type mismatch list" $ D.decode (D.dict D.value) "le" @?= Left "TypeMismatch Dict List"     ]   , testGroup "text"     [ testCase "0:" $ D.decode D.text "0:" @?= Right ""     , testCase "3:foo" $ D.decode D.text "3:foo" @?= Right "foo"     , testCase "こんにちは" $ D.decode D.text "15:\227\129\147\227\130\147\227\129\171\227\129\161\227\129\175" @?= Right "こんにちは"-    , testCase "<invalid UTF-8>" $ D.decode D.text "2:\xd8\x00" @?= Left "UTF8DecodeFailure"-    , testCase "i0e" $ D.decode D.text"i0e" @?= Left "TypeMismatch String Integer"-    , testCase "le" $ D.decode D.text"le" @?= Left "TypeMismatch String List"-    , testCase "de" $ D.decode D.text"de" @?= Left "TypeMismatch String Dict"+    , testCase "invalid UTF-8" $ D.decode D.text "2:\xd8\x00" @?= Left "UTF8DecodeFailure"+    , testCase "type mismatch integer" $ D.decode D.text "i0e" @?= Left "TypeMismatch String Integer"+    , testCase "type mismatch list" $ D.decode D.text"le" @?= Left "TypeMismatch String List"+    , testCase "type mismatch dict" $ D.decode D.text"de" @?= Left "TypeMismatch String Dict"     ]-  , testGroup "int"-    [ testCase "i0e" $ D.decode D.int "i0e" @?= Right 0-    , testCase "i-32e" $ D.decode D.int "i-32e" @?= Right (-32)-    , let x = show (fromIntegral (minBound :: Int) - 1 :: Integer) in-      testCase "minBound-1" $ D.decode D.int ("i" <> BC.pack x <> "e") @?= Left "IntOutOfBounds"-    , testCase "minBound" $ D.decode D.int ("i" <> BC.pack (show (minBound :: Int)) <> "e") @?= Right minBound-    , testCase "maxBound" $ D.decode D.int ("i" <> BC.pack (show (maxBound :: Int)) <> "e") @?= Right maxBound-    , let x = show (fromIntegral (maxBound :: Int) + 1 :: Integer) in-      testCase "maxBound+1" $ D.decode D.int ("i" <> BC.pack x <> "e") @?= Left "IntOutOfBounds"-    , testCase "i98765432109876543210e" $ D.decode D.int "i98765432109876543210e" @?= Left "IntOutOfBounds"-    , testCase "0:" $ D.decode D.int "0:" @?= Left "TypeMismatch Integer String"-    , testCase "le" $ D.decode D.int "le" @?= Left "TypeMismatch Integer List"-    , testCase "de" $ D.decode D.int "de" @?= Left "TypeMismatch Integer Dict"+  , testGroupIntegral "int" False D.int+  , testGroupIntegral "int64" False D.int64+  , testGroupIntegral "int32" False D.int32+  , testGroupIntegral "int16" False D.int16+  , testGroupIntegral "int8" False D.int8+  , testGroupIntegral "word" True D.word+  , testGroupIntegral "word64" True D.word64+  , testGroupIntegral "word32" True D.word32+  , testGroupIntegral "word16" True D.word16+  , testGroupIntegral "word8" True D.word8+  , testGroup "index"+    [ testCase "l3:fooe" $ D.decode (D.index 0 D.string) "l3:fooe" @?= Right "foo"+    , testCase "out of bounds -1" $ D.decode (D.index (-1) D.string) "l3:fooe" @?= Left "IndexOutOfBounds"+    , testCase "out of bounds 1" $ D.decode (D.index 1 D.string) "l3:fooe" @?= Left "IndexOutOfBounds"+    , testCase "li2ee" $ D.decode (D.index 0 D.string) "li2ee" @?= Left "TypeMismatch String Integer"+    , let p =     D.index 5 (Left <$> D.string)+              <|> D.index 0 (Right <$> D.int)+              <|> D.index 1 (Left <$> D.string) in+      testCase "alt" $ D.decode p "l3:foo3:bare" @?= Right (Left "bar")+    , let p = (,,) <$> D.index 1 D.string+                   <*> D.index 2 (D.list D.integer)+                   <*> D.index 0 D.integer in+      testCase "multiple types" $ D.decode p "li1e3:twoli0ei0ei0eee" @?= Right ("two", [0,0,0], 1)+    , testCase "type mismatch string" $ D.decode (D.index 0 D.string) "0:" @?= Left "TypeMismatch List String"+    , testCase "type mismatch integer" $ D.decode (D.index 0 D.string) "i0e" @?= Left "TypeMismatch List Integer"+    , testCase "type mismatch dict" $ D.decode (D.index 0 D.string) "de" @?= Left "TypeMismatch List Dict"     ]-  , testGroup "word"-    [ testCase "i0e" $ D.decode D.word "i0e" @?= Right 0-    , testCase "i-1e" $ D.decode D.word "i-1e" @?= Left "WordOutOfBounds"-    , testCase "maxBound" $ D.decode D.word ("i" <> BC.pack (show (maxBound :: Word)) <> "e") @?= Right maxBound-    , let x = show (fromIntegral (maxBound :: Word) + 1 :: Integer) in-      testCase "maxBound+1" $ D.decode D.word ("i" <> BC.pack x <> "e") @?= Left "WordOutOfBounds"-    , testCase "i98765432109876543210e" $ D.decode D.word "i98765432109876543210e" @?= Left "WordOutOfBounds"-    , testCase "0:" $ D.decode D.word "0:" @?= Left "TypeMismatch Integer String"-    , testCase "le" $ D.decode D.word "le" @?= Left "TypeMismatch Integer List"-    , testCase "de" $ D.decode D.word "de" @?= Left "TypeMismatch Integer Dict"+  , testGroup "list'"+    [ testCase "l3:fooe" $ D.decode (D.list' $ D.elem D.string) "l3:fooe" @?= Right "foo"+    , testCase "too short" $ D.decode (D.list' $ D.elem D.string) "le" @?= Left "ListElemsExhausted"+    , testCase "too long" $ D.decode (D.list' $ D.elem D.string) "l3:foo3:bare" @?= Left "ListElemsLeft"+    , testCase "elem type mismatch" $ D.decode (D.list' $ D.elem D.string) "li2ee" @?= Left "TypeMismatch String Integer"+    , let p = D.list' $+                    D.elem D.string+                <|> D.elem D.integer *> D.elem D.string in+      testCase "Elem alt" $ D.decode p "li1e3:fooe" @?= Right "foo"+    , let p = D.list' $+                (,,) <$> D.elem D.integer+                     <*> D.elem D.string+                     <*> D.elem (D.list D.integer) in+      testCase "multiple types" $ D.decode p "li1e3:twoli0ei0ei0eee" @?= Right (1, "two", [0,0,0])+    , testCase "type mismatch string" $ D.decode (D.list' $ pure ()) "0:" @?= Left "TypeMismatch List String"+    , testCase "type mismatch integer" $ D.decode (D.list' $ pure ()) "i0e" @?= Left "TypeMismatch List Integer"+    , testCase "type mismatch dict" $ D.decode (D.list' $ pure ()) "de" @?= Left "TypeMismatch List Dict"     ]   , testGroup "field"-    [ testCase "d3:foo3:bare" $ D.decode (D.field "foo" D.string) "d3:foo3:bare" @?= Right "bar"-    , testCase "d3:fooi2ee" $ D.decode (D.field "foo" D.string) "d3:fooi2ee" @?= Left "TypeMismatch String Integer"+    [ testCase "key not found" $ D.decode (D.field "foo" D.string) "de" @?= Left "KeyNotFound \"foo\""+    , testCase "d3:foo3:bare" $ D.decode (D.field "foo" D.string) "d3:foo3:bare" @?= Right "bar"+    , testCase "extra keys ignored" $ D.decode (D.field "baz" D.string) "d3:baz3:qux3:foo3:bare" @?= Right "qux"+    , let p = D.field "bar" D.string <|> D.field "foo" D.string in+      testCase "alt" $ D.decode p "d3:foo3:bare" @?= Right "bar"+    , testCase "value type mismatch" $ D.decode (D.field "foo" D.string) "d3:fooi2ee" @?= Left "TypeMismatch String Integer"     , let p = (,,) <$> D.field "one" D.integer                    <*> D.field "two" D.string                    <*> D.field "three" (D.list D.integer) in-      testCase "d3:onei1e5:threeli0ei0ei0ee3:two3:twoe" $-        D.decode p "d3:onei1e5:threeli0ei0ei0ee3:two3:twoe" @?= Right (1, "two", [0,0,0])+      testCase "multiple types" $ D.decode p "d3:onei1e5:threeli0ei0ei0ee3:two3:twoe" @?= Right (1, "two", [0,0,0])+    , testCase "type mismatch string" $ D.decode (D.field "foo" D.string) "0:" @?= Left "TypeMismatch Dict String"+    , testCase "type mismatch integer" $ D.decode (D.field "foo" D.string) "i0e" @?= Left "TypeMismatch Dict Integer"+    , testCase "type mismatch list" $ D.decode (D.field "foo" D.string) "le" @?= Left "TypeMismatch Dict List"     ]+  , testGroup "dict'"+    [ testCase "key not found" $ D.decode (D.dict' $ D.field' "foo" D.string) "de" @?= Left "KeyNotFound \"foo\""+    , testCase "d3:foo3:bare" $ D.decode (D.dict' $ D.field' "foo" D.string) "d3:foo3:bare" @?= Right "bar"+    , testCase "extra keys fails" $ D.decode (D.dict' $ D.field' "baz" D.string) "d3:baz3:qux3:foo3:bare" @?= Left "UnrecognizedKey \"foo\""+    , let p = D.dict' $ D.field' "bar" D.string <|> D.field' "foo" D.string in+      testCase "Fields alt" $ D.decode p "d3:foo3:bare" @?= Right "bar"+    , testCase "value type mismatch" $ D.decode (D.dict' $ D.field' "foo" D.string) "d3:fooi2ee" @?= Left "TypeMismatch String Integer"+    , let p = D.dict' $+                (,,) <$> D.field' "one" D.integer+                     <*> D.field' "two" D.string+                     <*> D.field' "three" (D.list D.integer) in+      testCase "multiple types" $ D.decode p "d3:onei1e5:threeli0ei0ei0ee3:two3:twoe" @?= Right (1, "two", [0,0,0])+    , testCase "type mismatch string" $ D.decode (D.dict' $ pure ()) "0:" @?= Left "TypeMismatch Dict String"+    , testCase "type mismatch integer" $ D.decode (D.dict' $ pure ()) "i0e" @?= Left "TypeMismatch Dict Integer"+    , testCase "type mismatch list" $ D.decode (D.dict' $ pure ()) "le" @?= Left "TypeMismatch Dict List"+    ]   , testGroup "fail"     [ testCase "3:foo" $ D.decode (D.fail "error!" :: D.Parser B.ByteString) "3:foo" @?= Left "Fail: error!"     ]   ]+  where+    testGroupIntegral :: forall a. (Bounded a, Integral a, Show a)+                      => String -> Bool -> D.Parser a -> TestTree+    testGroupIntegral name isW p = testGroup name+      [ testCase "i0e" $ D.decode p "i0e" @?= Right 0+      , testCase "i32e" $ D.decode p "i32e" @?= Right 32+      , testCase "i-32e" $ D.decode p "i-32e" @?= if isW then Left oob else Right (-32)+      , testCase "minBound-1" $ D.decode p ("i" <> BC.pack (show (minBoundI - 1)) <> "e") @?= Left oob+      , testCase "minBound" $ D.decode p ("i" <> BC.pack (show minBoundI) <> "e") @?= Right minBound+      , testCase "maxBound" $ D.decode p ("i" <> BC.pack (show maxBoundI) <> "e") @?= Right maxBound+      , testCase "maxBound+1" $ D.decode p ("i" <> BC.pack (show (maxBoundI + 1)) <> "e") @?= Left oob+      , testCase "i98765432109876543210e" $ D.decode p "i98765432109876543210e" @?= Left oob+      , testCase "type mismatch string" $ D.decode p "0:" @?= Left "TypeMismatch Integer String"+      , testCase "type mismatch list" $ D.decode p "le" @?= Left "TypeMismatch Integer List"+      , testCase "type mismatch dict" $ D.decode p "de" @?= Left "TypeMismatch Integer Dict"+      ]+      where+        minBoundI, maxBoundI :: Integer+        minBoundI = fromIntegral (minBound :: a)+        maxBoundI = fromIntegral (maxBound :: a)+        oob = if isW then "WordOutOfBounds" else "IntOutOfBounds"  encodeTests :: TestTree encodeTests = testGroup "Encode"@@ -202,19 +269,16 @@     [ testCase "Hello, World!" $ enc E.text "Hello, World!" @?= "13:Hello, World!"     , testCase "こんにちは" $ enc E.text "こんにちは" @?= "15:\227\129\147\227\130\147\227\129\171\227\129\161\227\129\175"     ]-  , testGroup "int"-    [ testCase "0" $ enc E.int 0 @?= "i0e"-    , testCase "1" $ enc E.int 1 @?= "i1e"-    , testCase "-1" $ enc E.int (-1) @?= "i-1e"-    , testCase "minBound" $ enc E.int minBound @?= "i" <> BLC.pack (show (minBound :: Int)) <> "e"-    , testCase "maxBound" $ enc E.int maxBound @?= "i" <> BLC.pack (show (maxBound :: Int)) <> "e"-    ]-  , testGroup "word"-    [ testCase "0" $ enc E.word 0 @?= "i0e"-    , testCase "1" $ enc E.word 1 @?= "i1e"-    , testCase "minBound" $ enc E.word minBound @?= "i0e"-    , testCase "maxBound" $ enc E.word maxBound @?= "i" <> BLC.pack (show (maxBound :: Word)) <> "e"-    ]+  , testGroupIntegral "int" False E.int+  , testGroupIntegral "int64" False E.int64+  , testGroupIntegral "int32" False E.int32+  , testGroupIntegral "int16" False E.int16+  , testGroupIntegral "int8" False E.int8+  , testGroupIntegral "word" True E.word+  , testGroupIntegral "word64" True E.word64+  , testGroupIntegral "word32" True E.word32+  , testGroupIntegral "word16" True E.word16+  , testGroupIntegral "word8" True E.word8   , testGroup "field"     [ testCase "{}" $ enc id (E.dict' mempty) @?= "de"     , let e =  E.dict' $@@ -224,20 +288,32 @@       testCase "{one:1,two:two,three:[0,0,0]}" $ enc id e @?= "d3:onei1e5:threeli0ei0ei0ee3:two3:twoe"     ]   ]+  where+    testGroupIntegral :: forall a. (Bounded a, Integral a, Show a)+                      => String -> Bool -> (a -> E.Encoding) -> TestTree+    testGroupIntegral name isW e = testGroup name $+      [ testCase "0" $ enc e 0 @?= "i0e"+      , testCase "32" $ enc e 32 @?= "i32e"+      ] +++      [ testCase "-32" $ enc e (-32) @?= "i-32e" | not isW ] +++      [ testCase "minBound" $ enc e minBound @?= "i" <> BLC.pack (show (minBound :: a)) <> "e"+      , testCase "maxBound" $ enc e maxBound @?= "i" <> BLC.pack (show (maxBound :: a)) <> "e"+      ]  enc :: (a -> E.Encoding) -> a -> BL.ByteString  enc f = BB.toLazyByteString . E.toBuilder . f  encodeDecodeTests :: TestTree-encodeDecodeTests = testGroup "EncodeDecode"-  [ testProperty "decode . encode == Right" $ withMaxSuccess 1000 $-      \v -> ( D.decode D.value .-              BL.toStrict .-              BB.toLazyByteString .-              E.toBuilder .-              E.value ) v-            === Right v+encodeDecodeTests = testGroup "EncodeDecode, decode . encode == Right"+  [ testProperty "Value" $+      \v -> (D.decode D.value . toBS . E.value) v === Right v+  , testProperty "Val" $+      \(TV t v) ->+        (fmap Clean . D.decode (mkParser t) . toBS . encodeVal) v+        === Right (Clean v)   ]+  where+    toBS = BL.toStrict . BB.toLazyByteString . E.toBuilder  instance Arbitrary Ben.Value where   arbitrary = sized $ \n -> do@@ -250,16 +326,214 @@         then Ben.String <$> arbitrary         else Ben.Integer <$> arbitrary       go n = do-        ns <- partition n >>= shuffle+        ns <- partition (n-1)         lOrD <- arbitrary         if lOrD         then Ben.List . V.fromList <$> traverse go ns         else Ben.Dict . M.fromList                <$> traverse (\n' -> (,) <$> arbitrary <*> go n') ns-      partition 0 = pure []-      partition n = do-        x <- choose (1,n)-        (x:) <$> partition (n-x) +  shrink (Ben.String s)  = Ben.String <$> shrink s+  shrink (Ben.Integer i) = Ben.Integer <$> shrink i+  shrink (Ben.List xs)   = Ben.List . V.fromList <$> shrink (V.toList xs)+  shrink (Ben.Dict kxs)  = Ben.Dict . M.fromList <$> shrink (M.toList kxs)+ instance Arbitrary B.ByteString where   arbitrary = B.pack <$> arbitrary+  shrink = map B.pack . shrink . B.unpack++-- The code below generates some random "type" (Typ) together with a "value"+-- (Val) of that type.+-- The Typ describes how to generate a value and how to parse a value.+-- A Val can have some junk which will be encoded but not decoded, to test that+-- parsers which are supposed to ignore data do so (field and index).++data Val+  = String !B.ByteString+  | Integer !Integer+  | List !(V.Vector Val)+  | Dict !(M.Map B.ByteString Val)+  | Int !Int+  | Word !Word+  | Fields+      !(M.Map B.ByteString Val) -- ^ contents+      !(M.Map B.ByteString Val) -- ^ junk+  | Fields' !(M.Map B.ByteString Val)+  | Index+      !(V.Vector Val) -- ^ contents and junk together+      !(V.Vector Int) -- ^ indices of the contents+  | Elems !(V.Vector Val)+  deriving Show++data Sized a = Sized !Int !a deriving Show++data Typ+  = TString+  | TInteger+  | TList !(Sized Typ)+  | TDict !(Sized Typ)+  | TInt+  | TWord+  | TFields !(M.Map B.ByteString (Sized Typ)) !(M.Map B.ByteString (Sized Typ))+  | TFields' !(M.Map B.ByteString (Sized Typ))+  | TIndex !(V.Vector (Sized Typ)) !(V.Vector Int)+  | TElems !(V.Vector (Sized Typ))+  deriving Show++-- Newtype to compare the non-junk parts of a Val via Eq.+newtype Clean = Clean Val deriving Show++instance Eq Clean where+  Clean x1 == Clean x2 = case (x1,x2) of+    (String s1   , String s2   ) -> s1 == s2+    (Integer i1  , Integer i2  ) -> i1 == i2+    (List l1     , List l2     ) -> fmap Clean l1 == fmap Clean l2+    (Dict d1     , Dict d2     ) -> fmap Clean d1 == fmap Clean d2+    (Int i1      , Int i2      ) -> i1 == i2+    (Word w1     , Word w2     ) -> w1 == w2+    (Fields m1 _ , Fields m2 _ ) -> fmap Clean m1 == fmap Clean m2+    (Fields' m1  , Fields' m2  ) -> fmap Clean m1 == fmap Clean m2+    (Index l1 is1, Index l2 is2) -> fmap Clean (V.backpermute l1 is1) ==+                                    fmap Clean (V.backpermute l2 is2)+    (Elems l1    , Elems l2    ) -> fmap Clean l1 == fmap Clean l2+    _                            -> False++encodeVal :: Val -> E.Encoding+encodeVal x = case x of+  String s     -> E.string s+  Integer i    -> E.integer i+  List l       -> E.list encodeVal l+  Dict d       -> E.dict encodeVal d+  Int i        -> E.int i+  Word w       -> E.word w+  Fields m1 m2 -> E.dict' $+                    M.foldMapWithKey (\k -> E.field k encodeVal) (m1 <> m2)+  Fields' m    -> E.dict' $ M.foldMapWithKey (\k -> E.field k encodeVal) m+  Index l _    -> E.list encodeVal l+  Elems l      -> E.list encodeVal l++mkParser :: Sized Typ -> D.Parser Val+mkParser (Sized _ t) = case t of+  TString  -> String <$> D.string+  TInteger -> Integer <$> D.integer+  TList t' -> List <$> D.list (mkParser t')+  TDict t' -> Dict <$> D.dict (mkParser t')+  TInt     -> Int <$> D.int+  TWord    -> Word <$> D.word+  TFields m1 _ ->+    Fields <$> M.traverseWithKey (\k -> D.field k . mkParser) m1+           <*> pure M.empty+  TFields' m ->+    Fields' <$> D.dict' (M.traverseWithKey (\k -> D.field' k . mkParser) m)+  TIndex l is ->+    Index <$> traverse (\i -> D.index i (mkParser (l V.! i))) is+          <*> pure (V.generate (V.length is) id)+  TElems l -> Elems <$> D.list' (traverse (D.elem . mkParser) l)++data TV = TV !(Sized Typ) !Val deriving Show++instance Arbitrary TV where+  arbitrary = sized $ \n -> do+    n' <- choose (0,n)+    go (n'+1)+    where+      go n = do+        t <- genTyp n+        v <- genVal n t+        pure $ TV t v++-- | Generate a Typ and its minimum number of nodes, such that it is <= n.+genTyp :: Int -> Gen (Sized Typ)+genTyp n | n <= 0 = error "genTyp n | n <= 0"+genTyp 1 = Sized 1 <$> elements [TString, TInteger, TInt, TWord]+genTyp n = oneof+  [ Sized 1 . TList <$> genTypMany (n-1)+  , Sized 1 . TDict <$> genTypMany (n-1)+  , do+      n' <- choose (0, n-1)+      Sized n1 m1 <- goMap n'+      Sized n2 m2 <- goMap (n-1-n')+      pure $ Sized (n1+n2+1) (TFields m1 m2)+  , do+      Sized n1 m1 <- goMap (n-1)+      pure $ Sized (n1+1) (TFields' m1)+  , do+      Sized n1 v1 <- goVec (n-1)+      is <- V.fromList <$> sublistOf [0 .. V.length v1 - 1]+      pure $ Sized (n1+1) (TIndex v1 is)+  , do+      Sized n1 v1 <- goVec (n-1)+      pure $ Sized (n1+1) (TElems v1)+  ]+  where+    genTypMany m = partition m >>= genTyp . minimum+    goMap m = do+      ms <- partition m+      kvs <- traverse (\m' -> (,) <$> arbitrary <*> genTyp m') ms+      pure $ sizedF (M.fromList kvs)+    goVec m = do+      ms <- partition m+      sizedF . V.fromList <$> traverse genTyp ms+    sizedF xs = Sized (sizeF xs) xs++-- | Generate a value with at most n nodes+genVal :: Int -> Sized Typ -> Gen Val+genVal n (Sized n' _) | n < n' = error "genVal: n < size of type"+genVal n (Sized _ t) = case t of+  TString -> String <$> arbitrary+  TInteger -> Integer <$> arbitrary+  TList t' -> List . V.fromList <$> goMany (n-1) t'+  TDict t' -> do+    vs <- goMany (n-1) t'+    ks <- replicateM (length vs) arbitrary+    pure $ Dict $ M.fromList $ zip ks vs+  TInt -> Int <$> arbitrary+  TWord -> Word <$> arbitrary+  TFields mp1 mp2 -> do+    ~[m1,m2] <- partitionWithMin (n-1) [sizeF mp1, sizeF mp2]+    Fields <$> goMap m1 mp1 <*> goMap m2 mp2+  TFields' mp -> Fields' <$> goMap (n-1) mp+  TIndex l is -> flip Index is . V.fromList <$> goVec (n-1) (F.toList l)+  TElems l -> Elems . V.fromList <$> goVec (n-1) (F.toList l)+  where+    goMany m t'@(Sized n' _) = do+      ns <- partitionWithMin m (replicate (div m n') n')+      traverse (flip genVal t') ns+    goMap m mp = do+      ns <- partitionWithMin m (sizes (M.elems mp))+      M.fromList . zip (M.keys mp) <$> zipWithM genVal ns (M.elems mp)+    goVec m l = do+      ns <- partitionWithMin m (sizes l)+      zipWithM genVal ns l++sizeF :: Foldable f => f (Sized a) -> Int+sizeF = F.foldl' (\acc (Sized n _) -> acc + n) 0++sizes :: Functor f => f (Sized a) -> f Int+sizes = fmap (\(Sized n _) -> n)++-- | Partition m into pieces with a given minimum value of each piece.+partitionWithMin :: Int -> [Int] -> Gen [Int]+partitionWithMin m xs | m < sum xs = error "partitionWithMin: n not big enough"+partitionWithMin m xs = zipWith (+) xs <$> partitionN (length xs) (m - sum xs)++-- | Partition m into n pieces. Pieces can be 0.+partitionN :: Int -> Int -> Gen [Int]+partitionN n0 _ | n0 <= 0 = error "partitionN: n <= 0"+partitionN n0 m0 = go n0 m0 >>= shuffle+  where+    go 1 m = pure [m]+    go n 0 = (0:) <$> go (n-1) 0+    go n m = do+      x <- choose (1,m)+      (x:) <$> go (n-1) (m-x)++-- | Partition into pieces >= 0+partition :: Int -> Gen [Int]+partition m0 | m0 < 0 = error "partition: m < 0"+partition m0 = go m0 >>= shuffle+  where+    go 0 = pure []+    go m = do+      x <- choose (1,m)+      (x:) <$> go (m-x)