summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSam Truzjan <pxqr.sta@gmail.com>2013-09-28 00:25:20 +0400
committerSam Truzjan <pxqr.sta@gmail.com>2013-09-28 00:25:20 +0400
commitabd06172c9baa1a0a4013ea56de83a2d49d84c3a (patch)
tree62c86434220d3962c12f964967d0243a2c0f4e77
parentde857a4b8e96c2a9ea4cec974442f08a93cb0098 (diff)
Add type synonyms.
-rw-r--r--TODO.org6
-rw-r--r--src/Data/BEncode.hs52
2 files changed, 34 insertions, 24 deletions
diff --git a/TODO.org b/TODO.org
index 2f51de5..47beccc 100644
--- a/TODO.org
+++ b/TODO.org
@@ -5,5 +5,9 @@
5* DONE documentation 5* DONE documentation
6* DONE document generics 6* DONE document generics
7* DONE v0.2.0.0 (reason: dictAssoc is hidded now) 7* DONE v0.2.0.0 (reason: dictAssoc is hidded now)
8* TODO use HashMap 8* TODO fix portability issues
9make int's instances platform independent so we can make library
10portable.
11* TODO rename BEncode to BValue
12* TODO use HashMap for dicts
9* TODO CPS Result 13* TODO CPS Result
diff --git a/src/Data/BEncode.hs b/src/Data/BEncode.hs
index 5fb7e1e..715393f 100644
--- a/src/Data/BEncode.hs
+++ b/src/Data/BEncode.hs
@@ -1,6 +1,3 @@
1-- TODO: make int's instances platform independent so we can make
2-- library portable.
3
4-- | 1-- |
5-- Copyright : (c) Sam Truzjan 2013 2-- Copyright : (c) Sam Truzjan 2013
6-- License : BSD3 3-- License : BSD3
@@ -60,8 +57,13 @@
60 57
61module Data.BEncode 58module Data.BEncode
62 ( -- * Datatype 59 ( -- * Datatype
63 BEncode(..) 60 BInteger
64 , Dict 61 , BString
62 , BList
63 , BDict
64 , BKey
65
66 , BEncode(..)
65 , ppBEncode 67 , ppBEncode
66 68
67 -- * Conversion 69 -- * Conversion
@@ -133,18 +135,22 @@ import qualified Text.ParserCombinators.ReadP as ReadP
133import GHC.Generics 135import GHC.Generics
134#endif 136#endif
135 137
136-- | BEncode key-value dictionary. 138
137type Dict = Map ByteString BEncode 139type BInteger = Int64
140type BString = ByteString
141type BList = [BEncode]
142type BDict = Map BKey BEncode
143type BKey = ByteString
138 144
139-- | 'BEncode' is straightforward ADT for b-encoded values. Please 145-- | 'BEncode' is straightforward ADT for b-encoded values. Please
140-- note that since dictionaries are sorted, in most cases we can 146-- note that since dictionaries are sorted, in most cases we can
141-- compare BEncoded values without serialization and vice versa. 147-- compare BEncoded values without serialization and vice versa.
142-- Lists is not required to be sorted through. 148-- Lists is not required to be sorted through.
143-- 149--
144data BEncode = BInteger {-# UNPACK #-} !Int64 150data BEncode = BInteger {-# UNPACK #-} !BInteger -- ^ bencode integers;
145 | BString !ByteString 151 | BString {-# UNPACK #-} !BString -- ^ bencode strings;
146 | BList [BEncode] 152 | BList BList -- ^ list of bencode values;
147 | BDict Dict 153 | BDict BDict -- ^ bencode key-value dictionary.
148 deriving (Show, Read, Eq, Ord) 154 deriving (Show, Read, Eq, Ord)
149 155
150instance NFData BEncode where 156instance NFData BEncode where
@@ -248,8 +254,8 @@ instance (Eq e, Monoid e)
248 | x == mempty = pure U1 254 | x == mempty = pure U1
249 | otherwise = decodingError "U1" 255 | otherwise = decodingError "U1"
250 256
251instance (GBEncodable a [BEncode], GBEncodable b [BEncode]) 257instance (GBEncodable a BList, GBEncodable b BList)
252 => GBEncodable (a :*: b) [BEncode] where 258 => GBEncodable (a :*: b) BList where
253 {-# INLINE gto #-} 259 {-# INLINE gto #-}
254 gto (a :*: b) = gto a ++ gto b 260 gto (a :*: b) = gto a ++ gto b
255 261
@@ -257,8 +263,8 @@ instance (GBEncodable a [BEncode], GBEncodable b [BEncode])
257 gfrom (x : xs) = (:*:) <$> gfrom [x] <*> gfrom xs 263 gfrom (x : xs) = (:*:) <$> gfrom [x] <*> gfrom xs
258 gfrom [] = decodingError "generic: not enough fields" 264 gfrom [] = decodingError "generic: not enough fields"
259 265
260instance (GBEncodable a Dict, GBEncodable b Dict) 266instance (GBEncodable a BDict, GBEncodable b BDict)
261 => GBEncodable (a :*: b) Dict where 267 => GBEncodable (a :*: b) BDict where
262 {-# INLINE gto #-} 268 {-# INLINE gto #-}
263 gto (a :*: b) = gto a <> gto b 269 gto (a :*: b) = gto a <> gto b
264 270
@@ -286,7 +292,7 @@ selRename = dropWhile ('_'==)
286 292
287gfromM1S :: forall c. Selector c 293gfromM1S :: forall c. Selector c
288 => GBEncodable f BEncode 294 => GBEncodable f BEncode
289 => Dict -> Result (M1 i c f p) 295 => BDict -> Result (M1 i c f p)
290gfromM1S dict 296gfromM1S dict
291 | Just va <- M.lookup (BC.pack (selRename name)) dict = M1 <$> gfrom va 297 | Just va <- M.lookup (BC.pack (selRename name)) dict = M1 <$> gfrom va
292 | otherwise = decodingError $ "generic: Selector not found " ++ show name 298 | otherwise = decodingError $ "generic: Selector not found " ++ show name
@@ -294,7 +300,7 @@ gfromM1S dict
294 name = selName (error "gfromM1S: impossible" :: M1 i c f p) 300 name = selName (error "gfromM1S: impossible" :: M1 i c f p)
295 301
296instance (Selector s, GBEncodable f BEncode) 302instance (Selector s, GBEncodable f BEncode)
297 => GBEncodable (M1 S s f) Dict where 303 => GBEncodable (M1 S s f) BDict where
298 {-# INLINE gto #-} 304 {-# INLINE gto #-}
299 gto s @ (M1 x) = BC.pack (selRename (selName s)) `M.singleton` gto x 305 gto s @ (M1 x) = BC.pack (selRename (selName s)) `M.singleton` gto x
300 306
@@ -303,7 +309,7 @@ instance (Selector s, GBEncodable f BEncode)
303 309
304-- TODO DList 310-- TODO DList
305instance GBEncodable f BEncode 311instance GBEncodable f BEncode
306 => GBEncodable (M1 S s f) [BEncode] where 312 => GBEncodable (M1 S s f) BList where
307 {-# INLINE gto #-} 313 {-# INLINE gto #-}
308 gto (M1 x) = [gto x] 314 gto (M1 x) = [gto x]
309 315
@@ -311,7 +317,7 @@ instance GBEncodable f BEncode
311 gfrom _ = decodingError "generic: empty selector" 317 gfrom _ = decodingError "generic: empty selector"
312 {-# INLINE gfrom #-} 318 {-# INLINE gfrom #-}
313 319
314instance (Constructor c, GBEncodable f Dict, GBEncodable f [BEncode]) 320instance (Constructor c, GBEncodable f BDict, GBEncodable f BList)
315 => GBEncodable (M1 C c f) BEncode where 321 => GBEncodable (M1 C c f) BEncode where
316 {-# INLINE gto #-} 322 {-# INLINE gto #-}
317 gto con @ (M1 x) 323 gto con @ (M1 x)
@@ -568,7 +574,7 @@ fromAscAssocs = BDict . M.fromAscList . mapMaybe unAssoc
568-- 574--
569-- The /reqKey/ is used to extract required key — if lookup is failed 575-- The /reqKey/ is used to extract required key — if lookup is failed
570-- then whole destructuring fail. 576-- then whole destructuring fail.
571reqKey :: BEncodable a => Dict -> ByteString -> Result a 577reqKey :: BEncodable a => BDict -> BKey -> Result a
572reqKey d key 578reqKey d key
573 | Just b <- M.lookup key d = fromBEncode b 579 | Just b <- M.lookup key d = fromBEncode b
574 | otherwise = Left msg 580 | otherwise = Left msg
@@ -577,19 +583,19 @@ reqKey d key
577 583
578-- | Used to extract optional key — if lookup is failed returns 584-- | Used to extract optional key — if lookup is failed returns
579-- 'Nothing'. 585-- 'Nothing'.
580optKey :: BEncodable a => Dict -> ByteString -> Result (Maybe a) 586optKey :: BEncodable a => BDict -> BKey -> Result (Maybe a)
581optKey d key 587optKey d key
582 | Just b <- M.lookup key d 588 | Just b <- M.lookup key d
583 , Right r <- fromBEncode b = return (Just r) 589 , Right r <- fromBEncode b = return (Just r)
584 | otherwise = return Nothing 590 | otherwise = return Nothing
585 591
586-- | Infix version of the 'reqKey'. 592-- | Infix version of the 'reqKey'.
587(>--) :: BEncodable a => Dict -> ByteString -> Result a 593(>--) :: BEncodable a => BDict -> BKey -> Result a
588(>--) = reqKey 594(>--) = reqKey
589{-# INLINE (>--) #-} 595{-# INLINE (>--) #-}
590 596
591-- | Infix version of the 'optKey'. 597-- | Infix version of the 'optKey'.
592(>--?) :: BEncodable a => Dict -> ByteString -> Result (Maybe a) 598(>--?) :: BEncodable a => BDict -> BKey -> Result (Maybe a)
593(>--?) = optKey 599(>--?) = optKey
594{-# INLINE (>--?) #-} 600{-# INLINE (>--?) #-}
595 601