diff options
author | Sam Truzjan <pxqr.sta@gmail.com> | 2013-09-29 06:01:06 +0400 |
---|---|---|
committer | Sam Truzjan <pxqr.sta@gmail.com> | 2013-09-29 06:01:06 +0400 |
commit | 573487ff0d758e1c500c26bc1e8b90dd155eb97b (patch) | |
tree | 9e177fe4a599e1d12ad921e0ca7c8b39e1c7e26d /src/Data/BEncode.hs | |
parent | e0ad240589038f9cc61a43844067ad021c0a903f (diff) |
Introduce BDictMap
Diffstat (limited to 'src/Data/BEncode.hs')
-rw-r--r-- | src/Data/BEncode.hs | 47 |
1 files changed, 26 insertions, 21 deletions
diff --git a/src/Data/BEncode.hs b/src/Data/BEncode.hs index b6897ec..8858730 100644 --- a/src/Data/BEncode.hs +++ b/src/Data/BEncode.hs | |||
@@ -106,6 +106,7 @@ import Control.Applicative | |||
106 | import Control.DeepSeq | 106 | import Control.DeepSeq |
107 | import Control.Monad | 107 | import Control.Monad |
108 | import Data.Int | 108 | import Data.Int |
109 | import Data.List as L | ||
109 | import Data.Maybe (mapMaybe) | 110 | import Data.Maybe (mapMaybe) |
110 | import Data.Monoid | 111 | import Data.Monoid |
111 | import Data.Foldable (foldMap) | 112 | import Data.Foldable (foldMap) |
@@ -135,12 +136,13 @@ import qualified Text.ParserCombinators.ReadP as ReadP | |||
135 | import GHC.Generics | 136 | import GHC.Generics |
136 | #endif | 137 | #endif |
137 | 138 | ||
139 | import Data.BEncode.BDict as BD | ||
140 | |||
138 | 141 | ||
139 | type BInteger = Integer | 142 | type BInteger = Integer |
140 | type BString = ByteString | 143 | type BString = ByteString |
141 | type BList = [BValue] | 144 | type BList = [BValue] |
142 | type BDict = Map BKey BValue | 145 | type BDict = BDictMap BValue |
143 | type BKey = ByteString | ||
144 | 146 | ||
145 | -- | 'BEncode' is straightforward ADT for b-encoded values. Please | 147 | -- | 'BEncode' is straightforward ADT for b-encoded values. Please |
146 | -- note that since dictionaries are sorted, in most cases we can | 148 | -- note that since dictionaries are sorted, in most cases we can |
@@ -295,7 +297,7 @@ gfromM1S :: forall c. Selector c | |||
295 | => GBEncodable f BValue | 297 | => GBEncodable f BValue |
296 | => BDict -> Result (M1 i c f p) | 298 | => BDict -> Result (M1 i c f p) |
297 | gfromM1S dict | 299 | gfromM1S dict |
298 | | Just va <- M.lookup (BC.pack (selRename name)) dict = M1 <$> gfrom va | 300 | | Just va <- BD.lookup (BC.pack (selRename name)) dict = M1 <$> gfrom va |
299 | | otherwise = decodingError $ "generic: Selector not found " ++ show name | 301 | | otherwise = decodingError $ "generic: Selector not found " ++ show name |
300 | where | 302 | where |
301 | name = selName (error "gfromM1S: impossible" :: M1 i c f p) | 303 | name = selName (error "gfromM1S: impossible" :: M1 i c f p) |
@@ -303,7 +305,7 @@ gfromM1S dict | |||
303 | instance (Selector s, GBEncodable f BValue) | 305 | instance (Selector s, GBEncodable f BValue) |
304 | => GBEncodable (M1 S s f) BDict where | 306 | => GBEncodable (M1 S s f) BDict where |
305 | {-# INLINE gto #-} | 307 | {-# INLINE gto #-} |
306 | gto s @ (M1 x) = BC.pack (selRename (selName s)) `M.singleton` gto x | 308 | gto s @ (M1 x) = BC.pack (selRename (selName s)) `BD.singleton` gto x |
307 | 309 | ||
308 | {-# INLINE gfrom #-} | 310 | {-# INLINE gfrom #-} |
309 | gfrom = gfromM1S | 311 | gfrom = gfromM1S |
@@ -377,14 +379,15 @@ instance BEncodable BList where | |||
377 | fromBEncode _ = decodingError "BList" | 379 | fromBEncode _ = decodingError "BList" |
378 | {-# INLINE fromBEncode #-} | 380 | {-# INLINE fromBEncode #-} |
379 | 381 | ||
380 | instance BEncodable BDict where | 382 | -} |
381 | toBEncode = BDict | 383 | |
384 | instance BEncode BDict where | ||
385 | toBEncode = BDict | ||
382 | {-# INLINE toBEncode #-} | 386 | {-# INLINE toBEncode #-} |
383 | 387 | ||
384 | fromBEncode (BDict d) = pure d | 388 | fromBEncode (BDict d) = pure d |
385 | fromBEncode _ = decodingError "BDict" | 389 | fromBEncode _ = decodingError "BDict" |
386 | {-# INLINE fromBEncode #-} | 390 | {-# INLINE fromBEncode #-} |
387 | -} | ||
388 | 391 | ||
389 | {-------------------------------------------------------------------- | 392 | {-------------------------------------------------------------------- |
390 | -- Integral instances | 393 | -- Integral instances |
@@ -401,7 +404,7 @@ toBEncodeIntegral = BInteger . fromIntegral | |||
401 | fromBEncodeIntegral :: forall a. Typeable a => Integral a => BValue -> Result a | 404 | fromBEncodeIntegral :: forall a. Typeable a => Integral a => BValue -> Result a |
402 | fromBEncodeIntegral (BInteger i) = pure (fromIntegral i) | 405 | fromBEncodeIntegral (BInteger i) = pure (fromIntegral i) |
403 | fromBEncodeIntegral _ | 406 | fromBEncodeIntegral _ |
404 | = decodingError $ show $ typeOf (undefined :: a) | 407 | = decodingError $ show $ typeOf (error "fromBEncodeIntegral: imposible" :: a) |
405 | {-# INLINE fromBEncodeIntegral #-} | 408 | {-# INLINE fromBEncodeIntegral #-} |
406 | 409 | ||
407 | 410 | ||
@@ -500,16 +503,17 @@ instance BEncode Text where | |||
500 | 503 | ||
501 | instance BEncode a => BEncode [a] where | 504 | instance BEncode a => BEncode [a] where |
502 | {-# SPECIALIZE instance BEncode BList #-} | 505 | {-# SPECIALIZE instance BEncode BList #-} |
503 | toBEncode = BList . map toBEncode | 506 | toBEncode = BList . L.map toBEncode |
504 | {-# INLINE toBEncode #-} | 507 | {-# INLINE toBEncode #-} |
505 | 508 | ||
506 | fromBEncode (BList xs) = mapM fromBEncode xs | 509 | fromBEncode (BList xs) = mapM fromBEncode xs |
507 | fromBEncode _ = decodingError "list" | 510 | fromBEncode _ = decodingError "list" |
508 | {-# INLINE fromBEncode #-} | 511 | {-# INLINE fromBEncode #-} |
509 | 512 | ||
513 | {- | ||
510 | instance BEncode a => BEncode (Map BKey a) where | 514 | instance BEncode a => BEncode (Map BKey a) where |
511 | {-# SPECIALIZE instance BEncode BDict #-} | 515 | {-# SPECIALIZE instance BEncode (Map BKey BValue) #-} |
512 | toBEncode = BDict . M.map toBEncode | 516 | toBEncode = BDict . -- BD.map toBEncode |
513 | {-# INLINE toBEncode #-} | 517 | {-# INLINE toBEncode #-} |
514 | 518 | ||
515 | fromBEncode (BDict d) = traverse fromBEncode d | 519 | fromBEncode (BDict d) = traverse fromBEncode d |
@@ -524,7 +528,7 @@ instance (Eq a, BEncode a) => BEncode (Set a) where | |||
524 | fromBEncode (BList xs) = S.fromAscList <$> traverse fromBEncode xs | 528 | fromBEncode (BList xs) = S.fromAscList <$> traverse fromBEncode xs |
525 | fromBEncode _ = decodingError "Data.Set" | 529 | fromBEncode _ = decodingError "Data.Set" |
526 | {-# INLINE fromBEncode #-} | 530 | {-# INLINE fromBEncode #-} |
527 | 531 | -} | |
528 | instance BEncode Version where | 532 | instance BEncode Version where |
529 | toBEncode = toBEncode . BC.pack . showVersion | 533 | toBEncode = toBEncode . BC.pack . showVersion |
530 | {-# INLINE toBEncode #-} | 534 | {-# INLINE toBEncode #-} |
@@ -639,13 +643,13 @@ key -->? mval = Assoc $ ((,) key . toBEncode) <$> mval | |||
639 | 643 | ||
640 | -- | Build BEncode dictionary using key -> value description. | 644 | -- | Build BEncode dictionary using key -> value description. |
641 | fromAssocs :: [Assoc] -> BValue | 645 | fromAssocs :: [Assoc] -> BValue |
642 | fromAssocs = BDict . M.fromList . mapMaybe unAssoc | 646 | fromAssocs = undefined -- BDict . M.fromList . mapMaybe unAssoc |
643 | {-# INLINE fromAssocs #-} | 647 | {-# INLINE fromAssocs #-} |
644 | 648 | ||
645 | -- | A faster version of 'fromAssocs'. Should be used only when keys | 649 | -- | A faster version of 'fromAssocs'. Should be used only when keys |
646 | -- in builder list are sorted by ascending. | 650 | -- in builder list are sorted by ascending. |
647 | fromAscAssocs :: [Assoc] -> BValue | 651 | fromAscAssocs :: [Assoc] -> BValue |
648 | fromAscAssocs = BDict . M.fromAscList . mapMaybe unAssoc | 652 | fromAscAssocs = BDict . BD.fromAscList . mapMaybe unAssoc |
649 | {-# INLINE fromAscAssocs #-} | 653 | {-# INLINE fromAscAssocs #-} |
650 | 654 | ||
651 | {-------------------------------------------------------------------- | 655 | {-------------------------------------------------------------------- |
@@ -670,7 +674,7 @@ fromAscAssocs = BDict . M.fromAscList . mapMaybe unAssoc | |||
670 | -- then whole destructuring fail. | 674 | -- then whole destructuring fail. |
671 | reqKey :: BEncode a => BDict -> BKey -> Result a | 675 | reqKey :: BEncode a => BDict -> BKey -> Result a |
672 | reqKey d key | 676 | reqKey d key |
673 | | Just b <- M.lookup key d = fromBEncode b | 677 | | Just b <- BD.lookup key d = fromBEncode b |
674 | | otherwise = Left msg | 678 | | otherwise = Left msg |
675 | where | 679 | where |
676 | msg = "required field `" ++ BC.unpack key ++ "' not found" | 680 | msg = "required field `" ++ BC.unpack key ++ "' not found" |
@@ -679,7 +683,7 @@ reqKey d key | |||
679 | -- 'Nothing'. | 683 | -- 'Nothing'. |
680 | optKey :: BEncode a => BDict -> BKey -> Result (Maybe a) | 684 | optKey :: BEncode a => BDict -> BKey -> Result (Maybe a) |
681 | optKey d key | 685 | optKey d key |
682 | | Just b <- M.lookup key d | 686 | | Just b <- BD.lookup key d |
683 | , Right r <- fromBEncode b = return (Just r) | 687 | , Right r <- fromBEncode b = return (Just r) |
684 | | otherwise = return Nothing | 688 | | otherwise = return Nothing |
685 | 689 | ||
@@ -759,7 +763,7 @@ builder = go | |||
759 | foldMap go l <> | 763 | foldMap go l <> |
760 | B.word8 (c2w 'e') | 764 | B.word8 (c2w 'e') |
761 | go (BDict d) = B.word8 (c2w 'd') <> | 765 | go (BDict d) = B.word8 (c2w 'd') <> |
762 | foldMap mkKV (M.toAscList d) <> | 766 | foldMap mkKV (BD.toAscList d) <> |
763 | B.word8 (c2w 'e') | 767 | B.word8 (c2w 'e') |
764 | where | 768 | where |
765 | mkKV (k, v) = buildString k <> go v | 769 | mkKV (k, v) = buildString k <> go v |
@@ -786,7 +790,7 @@ parser = valueP | |||
786 | 'l' -> P.anyChar *> ((BList <$> listBody) <* P.anyChar) | 790 | 'l' -> P.anyChar *> ((BList <$> listBody) <* P.anyChar) |
787 | 'd' -> do | 791 | 'd' -> do |
788 | P.anyChar | 792 | P.anyChar |
789 | (BDict . M.fromDistinctAscList <$> | 793 | (BDict . BD.fromAscList <$> |
790 | many ((,) <$> stringP <*> valueP)) | 794 | many ((,) <$> stringP <*> valueP)) |
791 | <* P.anyChar | 795 | <* P.anyChar |
792 | t -> fail ("bencode unknown tag: " ++ [t]) | 796 | t -> fail ("bencode unknown tag: " ++ [t]) |
@@ -819,15 +823,16 @@ parser = valueP | |||
819 | --------------------------------------------------------------------} | 823 | --------------------------------------------------------------------} |
820 | 824 | ||
821 | ppBS :: ByteString -> Doc | 825 | ppBS :: ByteString -> Doc |
822 | ppBS = text . map w2c . B.unpack | 826 | ppBS = text . L.map w2c . B.unpack |
823 | 827 | ||
824 | -- | Convert to easily readable JSON-like document. Typically used for | 828 | -- | Convert to easily readable JSON-like document. Typically used for |
825 | -- debugging purposes. | 829 | -- debugging purposes. |
826 | ppBEncode :: BValue -> Doc | 830 | ppBEncode :: BValue -> Doc |
827 | ppBEncode (BInteger i) = int $ fromIntegral i | 831 | ppBEncode (BInteger i) = int $ fromIntegral i |
828 | ppBEncode (BString s) = ppBS s | 832 | ppBEncode (BString s) = ppBS s |
829 | ppBEncode (BList l) = brackets $ hsep $ punctuate comma $ map ppBEncode l | 833 | ppBEncode (BList l) |
834 | = brackets $ hsep $ punctuate comma $ L.map ppBEncode l | ||
830 | ppBEncode (BDict d) | 835 | ppBEncode (BDict d) |
831 | = braces $ vcat $ punctuate comma $ map ppKV $ M.toAscList d | 836 | = braces $ vcat $ punctuate comma $ L.map ppKV $ BD.toAscList d |
832 | where | 837 | where |
833 | ppKV (k, v) = ppBS k <+> colon <+> ppBEncode v | 838 | ppKV (k, v) = ppBS k <+> colon <+> ppBEncode v |