diff options
-rw-r--r-- | bench/Main.hs | 87 | ||||
-rw-r--r-- | bencoding.cabal | 2 | ||||
-rw-r--r-- | src/Data/BEncode.hs | 117 | ||||
-rw-r--r-- | src/Data/BEncode/BDict.hs | 4 |
4 files changed, 166 insertions, 44 deletions
diff --git a/bench/Main.hs b/bench/Main.hs index 4953a06..0259b3c 100644 --- a/bench/Main.hs +++ b/bench/Main.hs | |||
@@ -1,7 +1,9 @@ | |||
1 | {-# LANGUAGE PackageImports #-} | 1 | {-# LANGUAGE PackageImports #-} |
2 | {-# LANGUAGE DeriveGeneric #-} | 2 | {-# LANGUAGE DeriveGeneric #-} |
3 | {-# LANGUAGE RecordWildCards #-} | 3 | {-# LANGUAGE RecordWildCards #-} |
4 | {-# LANGUAGE OverloadedStrings #-} | 4 | {-# LANGUAGE OverloadedStrings #-} |
5 | {-# LANGUAGE DeriveDataTypeable #-} | ||
6 | {-# LANGUAGE BangPatterns #-} | ||
5 | module Main (main) where | 7 | module Main (main) where |
6 | 8 | ||
7 | import Control.Applicative | 9 | import Control.Applicative |
@@ -12,6 +14,7 @@ import qualified Data.ByteString.Lazy as BL | |||
12 | import Data.List as L | 14 | import Data.List as L |
13 | import Data.Maybe | 15 | import Data.Maybe |
14 | import Data.Monoid | 16 | import Data.Monoid |
17 | import Data.Typeable | ||
15 | import System.Environment | 18 | import System.Environment |
16 | 19 | ||
17 | import Criterion.Main | 20 | import Criterion.Main |
@@ -23,6 +26,8 @@ import Data.AttoBencode.Parser as B | |||
23 | import "bencoding" Data.BEncode as C | 26 | import "bencoding" Data.BEncode as C |
24 | import "bencoding" Data.BEncode.Internal as C | 27 | import "bencoding" Data.BEncode.Internal as C |
25 | import "bencoding" Data.BEncode.Types as C | 28 | import "bencoding" Data.BEncode.Types as C |
29 | import Debug.Trace | ||
30 | |||
26 | 31 | ||
27 | instance NFData A.BEncode where | 32 | instance NFData A.BEncode where |
28 | rnf (A.BInt i) = rnf i | 33 | rnf (A.BInt i) = rnf i |
@@ -62,47 +67,47 @@ replicate' c x | |||
62 | 67 | ||
63 | data Torrent = Torrent { | 68 | data Torrent = Torrent { |
64 | tAnnounce :: !ByteString | 69 | tAnnounce :: !ByteString |
65 | , tInfo :: !BDict | ||
66 | , tAnnounceList :: !(Maybe ByteString) | 70 | , tAnnounceList :: !(Maybe ByteString) |
67 | , tComment :: !(Maybe ByteString) | 71 | , tComment :: !(Maybe ByteString) |
68 | , tCreatedBy :: !(Maybe ByteString) | 72 | , tCreatedBy :: !(Maybe ByteString) |
69 | , tCreationDate :: !(Maybe ByteString) | 73 | , tCreationDate :: !(Maybe ByteString) |
70 | , tEncoding :: !(Maybe ByteString) | 74 | , tEncoding :: !(Maybe ByteString) |
75 | , tInfo :: !BDict | ||
71 | , tPublisher :: !(Maybe ByteString) | 76 | , tPublisher :: !(Maybe ByteString) |
72 | , tPublisherURL :: !(Maybe ByteString) | 77 | , tPublisherURL :: !(Maybe ByteString) |
73 | , tSignature :: !(Maybe ByteString) | 78 | , tSignature :: !(Maybe ByteString) |
74 | } deriving (Show, Eq) | 79 | } deriving (Show, Eq, Typeable) |
75 | 80 | ||
76 | instance NFData Torrent where | 81 | instance NFData Torrent where |
77 | rnf Torrent {..} = () | 82 | rnf Torrent {..} = () |
78 | 83 | ||
79 | instance C.BEncode Torrent where | 84 | instance C.BEncode Torrent where |
80 | toBEncode Torrent {..} = fromAscAssocs | 85 | toBEncode Torrent {..} = toDict $ |
81 | [ "announce" --> tAnnounce | 86 | "announce" .=! tAnnounce |
82 | , "announce-list" -->? tAnnounceList | 87 | C..: "announce-list" .=? tAnnounceList |
83 | , "comment" -->? tComment | 88 | C..: "comment" .=? tComment |
84 | , "created by" -->? tCreatedBy | 89 | C..: "created by" .=? tCreatedBy |
85 | , "creation date" -->? tCreationDate | 90 | C..: "creation date" .=? tCreationDate |
86 | , "encoding" -->? tEncoding | 91 | C..: "encoding" .=? tEncoding |
87 | , "info" --> tInfo | 92 | C..: "info" .=! tInfo |
88 | , "publisher" -->? tPublisher | 93 | C..: "publisher" .=? tPublisher |
89 | , "publisher-url" -->? tPublisherURL | 94 | C..: "publisher-url" .=? tPublisherURL |
90 | , "signature" -->? tSignature | 95 | C..: "signature" .=? tSignature |
91 | ] | 96 | C..: endDict |
92 | 97 | ||
93 | fromBEncode (C.BDict d) = | 98 | |
94 | Torrent <$> d >-- "announce" | 99 | |
95 | <*> d >-- "info" | 100 | fromBEncode = fromDict $ do |
96 | <*> d >--? "announce-list" | 101 | Torrent <$>! "announce" |
97 | <*> d >--? "comment" | 102 | <*>? "announce-list" |
98 | <*> d >--? "created by" | 103 | <*>? "comment" |
99 | <*> d >--? "creation date" | 104 | <*>? "created by" |
100 | <*> d >--? "encoding" | 105 | <*>? "creation date" |
101 | <*> d >--? "publisher" | 106 | <*>? "encoding" |
102 | <*> d >--? "publisher-url" | 107 | <*>! "info" |
103 | <*> d >--? "signature" | 108 | <*>? "publisher" |
104 | 109 | <*>? "publisher-url" | |
105 | fromBEncode _ = decodingError "Torrent" | 110 | <*>? "signature" |
106 | 111 | ||
107 | {----------------------------------------------------------------------- | 112 | {----------------------------------------------------------------------- |
108 | -- Main | 113 | -- Main |
@@ -175,11 +180,21 @@ main = do | |||
175 | :: List Int -> List Int) | 180 | :: List Int -> List Int) |
176 | d | 181 | d |
177 | 182 | ||
178 | , let Right be = C.parse torrentFile | 183 | , let Right !be = C.parse torrentFile |
179 | id' x = let t = either error id (fromBEncode x) | 184 | id' x = let t = either error id (fromBEncode x) |
180 | in toBEncode (t :: Torrent) | 185 | in toBEncode (t :: Torrent) |
186 | !test = let Right t = C.decode torrentFile | ||
187 | in if C.decode (BL.toStrict (C.encode t)) | ||
188 | /= Right (t :: Torrent) | ||
189 | then error "invalid instance: BEncode Torrent" | ||
190 | else True | ||
191 | |||
192 | replFn n f = go n | ||
193 | where go 0 = id | ||
194 | go n = f . go (pred n) | ||
195 | |||
196 | in bench "bigdict" $ nf (replFn (1000 :: Int) id') be | ||
181 | 197 | ||
182 | in bench "bigdict" $ nf | 198 | , let fn x = let Right t = C.decode x in t :: Torrent |
183 | (appEndo $ mconcat $ L.replicate 1000 (Endo id')) | 199 | in bench "torrent/decode" $ nf fn torrentFile |
184 | be | ||
185 | ] | 200 | ] |
diff --git a/bencoding.cabal b/bencoding.cabal index b6fe821..6ac642f 100644 --- a/bencoding.cabal +++ b/bencoding.cabal | |||
@@ -51,7 +51,7 @@ library | |||
51 | , bytestring >= 0.10.0.2 | 51 | , bytestring >= 0.10.0.2 |
52 | , text >= 0.11 | 52 | , text >= 0.11 |
53 | , pretty | 53 | , pretty |
54 | ghc-options: -Wall -fno-warn-unused-do-bind | 54 | ghc-options: -Wall -O2 -fno-warn-unused-do-bind |
55 | 55 | ||
56 | 56 | ||
57 | test-suite properties | 57 | test-suite properties |
diff --git a/src/Data/BEncode.hs b/src/Data/BEncode.hs index 81010b6..427d401 100644 --- a/src/Data/BEncode.hs +++ b/src/Data/BEncode.hs | |||
@@ -70,10 +70,11 @@ module Data.BEncode | |||
70 | -- ** Dictionaries | 70 | -- ** Dictionaries |
71 | -- *** Building | 71 | -- *** Building |
72 | , Assoc | 72 | , Assoc |
73 | , (-->) | 73 | , (.=!) |
74 | , (-->?) | 74 | , (.=?) |
75 | , fromAssocs | 75 | , (.:) |
76 | , fromAscAssocs | 76 | , endDict |
77 | , toDict | ||
77 | 78 | ||
78 | -- *** Extraction | 79 | -- *** Extraction |
79 | , decodingError | 80 | , decodingError |
@@ -81,11 +82,26 @@ module Data.BEncode | |||
81 | , optKey | 82 | , optKey |
82 | , (>--) | 83 | , (>--) |
83 | , (>--?) | 84 | , (>--?) |
85 | |||
86 | -- *** Extraction | ||
87 | , Get | ||
88 | , fromDict | ||
89 | |||
90 | , req | ||
91 | , opt | ||
92 | , field | ||
93 | |||
94 | , (<$>!) | ||
95 | , (<$>?) | ||
96 | , (<*>!) | ||
97 | , (<*>?) | ||
84 | ) where | 98 | ) where |
85 | 99 | ||
86 | 100 | ||
87 | import Control.Applicative | 101 | import Control.Applicative |
88 | import Control.Monad | 102 | import Control.Monad |
103 | import Control.Monad.State | ||
104 | import Control.Monad.Error | ||
89 | import Data.Int | 105 | import Data.Int |
90 | import Data.List as L | 106 | import Data.List as L |
91 | import Data.Maybe (mapMaybe) | 107 | import Data.Maybe (mapMaybe) |
@@ -546,9 +562,67 @@ instance (BEncode a, BEncode b, BEncode c, BEncode d, BEncode e) | |||
546 | {-# INLINE fromBEncode #-} | 562 | {-# INLINE fromBEncode #-} |
547 | 563 | ||
548 | {-------------------------------------------------------------------- | 564 | {-------------------------------------------------------------------- |
549 | Building dictionaries | 565 | -- Dictionary extraction |
550 | --------------------------------------------------------------------} | 566 | --------------------------------------------------------------------} |
551 | 567 | ||
568 | newtype Get a = Get { runGet :: StateT BDict Result a } | ||
569 | deriving (Functor, Applicative, Alternative) | ||
570 | |||
571 | next :: Get BValue | ||
572 | next = Get (StateT go) | ||
573 | where | ||
574 | go Nil = throwError "no next" | ||
575 | go (Cons _ v xs) = pure (v, xs) | ||
576 | |||
577 | req :: BKey -> Get BValue | ||
578 | req !key = Get (StateT search) | ||
579 | where | ||
580 | search Nil = Left msg | ||
581 | search (Cons k v xs) = | ||
582 | case compare k key of | ||
583 | EQ -> Right (v, xs) | ||
584 | LT -> search xs | ||
585 | GT -> Left msg | ||
586 | |||
587 | msg = "required field `" ++ BC.unpack key ++ "' not found" | ||
588 | {-# INLINE req #-} | ||
589 | |||
590 | opt :: BKey -> Get (Maybe BValue) | ||
591 | opt = optional . req | ||
592 | {-# INLINE opt #-} | ||
593 | |||
594 | {-# SPECIALIZE field :: Get BValue -> Get BValue #-} | ||
595 | field :: BEncode a => Get BValue -> Get a | ||
596 | field m = Get $ do | ||
597 | v <- runGet m | ||
598 | either throwError pure $ fromBEncode v | ||
599 | |||
600 | (<$>!) :: BEncode a => (a -> b) -> BKey -> Get b | ||
601 | f <$>! k = f <$> field (req k) | ||
602 | {-# INLINE (<$>!) #-} | ||
603 | |||
604 | (<$>?) :: BEncode a => (Maybe a -> b) -> BKey -> Get b | ||
605 | f <$>? k = f <$> optional (field (req k)) | ||
606 | {-# INLINE (<$>?) #-} | ||
607 | |||
608 | (<*>!) :: BEncode a => Get (a -> b) -> BKey -> Get b | ||
609 | f <*>! k = f <*> field (req k) | ||
610 | {-# INLINE (<*>!) #-} | ||
611 | |||
612 | (<*>?) :: BEncode a => Get (Maybe a -> b) -> BKey -> Get b | ||
613 | f <*>? k = f <*> optional (field (req k)) | ||
614 | {-# INLINE (<*>?) #-} | ||
615 | |||
616 | fromDict :: forall a. Typeable a => Get a -> BValue -> Result a | ||
617 | fromDict m (BDict d) = evalStateT (runGet m) d | ||
618 | fromDict _ _ = decodingError (show (typeOf inst)) | ||
619 | where | ||
620 | inst = error "fromDict: impossible" :: a | ||
621 | |||
622 | {-------------------------------------------------------------------- | ||
623 | Building dictionaries | ||
624 | --------------------------------------------------------------------} | ||
625 | {- | ||
552 | -- | /Assoc/ used to easily build dictionaries with required and | 626 | -- | /Assoc/ used to easily build dictionaries with required and |
553 | -- optional keys. Suppose we have we following datatype we want to | 627 | -- optional keys. Suppose we have we following datatype we want to |
554 | -- serialize: | 628 | -- serialize: |
@@ -598,6 +672,39 @@ fromAssocs = undefined -- BDict . M.fromList . mapMaybe unAssoc | |||
598 | fromAscAssocs :: [Assoc] -> BValue | 672 | fromAscAssocs :: [Assoc] -> BValue |
599 | fromAscAssocs = BDict . BD.fromAscList . mapMaybe unAssoc | 673 | fromAscAssocs = BDict . BD.fromAscList . mapMaybe unAssoc |
600 | {-# INLINE fromAscAssocs #-} | 674 | {-# INLINE fromAscAssocs #-} |
675 | -} | ||
676 | |||
677 | type BPair = (BKey, BValue) | ||
678 | type Assoc = Maybe BPair | ||
679 | |||
680 | -- TODO better name | ||
681 | (.=!) :: BEncode a => BKey -> a -> Assoc | ||
682 | k .=! v = Just (k, toBEncode v) | ||
683 | {-# INLINE (.=!) #-} | ||
684 | |||
685 | infix 6 .=! | ||
686 | |||
687 | (.=?) :: BEncode a => BKey -> Maybe a -> Assoc | ||
688 | _ .=? Nothing = Nothing | ||
689 | k .=? Just v = Just (k, toBEncode v) | ||
690 | {-# INLINE (.=?) #-} | ||
691 | |||
692 | infix 6 .=? | ||
693 | |||
694 | (.:) :: Assoc -> BDict -> BDict | ||
695 | Nothing .: d = d | ||
696 | Just (k, v) .: d = Cons k v d | ||
697 | {-# INLINE (.:) #-} | ||
698 | |||
699 | infixr 5 .: | ||
700 | |||
701 | toDict :: BDict -> BValue | ||
702 | toDict = BDict | ||
703 | {-# INLINE toDict #-} | ||
704 | |||
705 | endDict :: BDict | ||
706 | endDict = Nil | ||
707 | {-# INLINE endDict #-} | ||
601 | 708 | ||
602 | {-------------------------------------------------------------------- | 709 | {-------------------------------------------------------------------- |
603 | Dictionary extraction | 710 | Dictionary extraction |
diff --git a/src/Data/BEncode/BDict.hs b/src/Data/BEncode/BDict.hs index 2884851..925027b 100644 --- a/src/Data/BEncode/BDict.hs +++ b/src/Data/BEncode/BDict.hs | |||
@@ -48,12 +48,12 @@ type BKey = ByteString | |||
48 | 48 | ||
49 | -- | BDictMap is list of key value pairs sorted by keys. | 49 | -- | BDictMap is list of key value pairs sorted by keys. |
50 | data BDictMap a | 50 | data BDictMap a |
51 | = Cons !BKey a (BDictMap a) | 51 | = Cons !BKey a !(BDictMap a) |
52 | | Nil | 52 | | Nil |
53 | deriving (Show, Read, Eq, Ord) | 53 | deriving (Show, Read, Eq, Ord) |
54 | 54 | ||
55 | instance NFData a => NFData (BDictMap a) where | 55 | instance NFData a => NFData (BDictMap a) where |
56 | rnf Nil = () | 56 | rnf Nil = () |
57 | rnf (Cons _ v xs)= rnf v `seq` rnf xs | 57 | rnf (Cons _ v xs)= rnf v `seq` rnf xs |
58 | 58 | ||
59 | instance Functor BDictMap where | 59 | instance Functor BDictMap where |