summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Data/BEncode.hs137
1 files changed, 51 insertions, 86 deletions
diff --git a/src/Data/BEncode.hs b/src/Data/BEncode.hs
index 189aedc..8c192c9 100644
--- a/src/Data/BEncode.hs
+++ b/src/Data/BEncode.hs
@@ -61,7 +61,6 @@ module Data.BEncode
61 61
62 -- * Conversion 62 -- * Conversion
63 , BEncode (..) 63 , BEncode (..)
64 , Result
65 64
66 -- * Serialization 65 -- * Serialization
67 , encode 66 , encode
@@ -77,14 +76,9 @@ module Data.BEncode
77 , toDict 76 , toDict
78 77
79 -- *** Extraction 78 -- *** Extraction
80 , decodingError
81 , reqKey
82 , optKey
83 , (>--)
84 , (>--?)
85
86 -- *** Extraction
87 , Get 79 , Get
80 , Result
81 , decodingError
88 , fromDict 82 , fromDict
89 83
90 , next 84 , next
@@ -562,64 +556,6 @@ instance (BEncode a, BEncode b, BEncode c, BEncode d, BEncode e)
562 {-# INLINE fromBEncode #-} 556 {-# INLINE fromBEncode #-}
563 557
564{-------------------------------------------------------------------- 558{--------------------------------------------------------------------
565-- Dictionary extraction
566--------------------------------------------------------------------}
567
568newtype Get a = Get { runGet :: StateT BDict Result a }
569 deriving (Functor, Applicative, Alternative)
570
571next :: Get BValue
572next = Get (StateT go)
573 where
574 go Nil = throwError "no next"
575 go (Cons _ v xs) = pure (v, xs)
576
577req :: BKey -> Get BValue
578req !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
590opt :: BKey -> Get (Maybe BValue)
591opt = optional . req
592{-# INLINE opt #-}
593
594{-# SPECIALIZE field :: Get BValue -> Get BValue #-}
595field :: BEncode a => Get BValue -> Get a
596field m = Get $ do
597 v <- runGet m
598 either throwError pure $ fromBEncode v
599
600(<$>!) :: BEncode a => (a -> b) -> BKey -> Get b
601f <$>! k = f <$> field (req k)
602{-# INLINE (<$>!) #-}
603
604(<$>?) :: BEncode a => (Maybe a -> b) -> BKey -> Get b
605f <$>? k = f <$> optional (field (req k))
606{-# INLINE (<$>?) #-}
607
608(<*>!) :: BEncode a => Get (a -> b) -> BKey -> Get b
609f <*>! k = f <*> field (req k)
610{-# INLINE (<*>!) #-}
611
612(<*>?) :: BEncode a => Get (Maybe a -> b) -> BKey -> Get b
613f <*>? k = f <*> optional (field (req k))
614{-# INLINE (<*>?) #-}
615
616fromDict :: forall a. Typeable a => Get a -> BValue -> Result a
617fromDict m (BDict d) = evalStateT (runGet m) d
618fromDict _ _ = decodingError (show (typeOf inst))
619 where
620 inst = error "fromDict: impossible" :: a
621
622{--------------------------------------------------------------------
623 Building dictionaries 559 Building dictionaries
624--------------------------------------------------------------------} 560--------------------------------------------------------------------}
625 561
@@ -690,7 +626,7 @@ endDict = Nil
690{-# INLINE endDict #-} 626{-# INLINE endDict #-}
691 627
692{-------------------------------------------------------------------- 628{--------------------------------------------------------------------
693 Dictionary extraction 629-- Dictionary extraction
694--------------------------------------------------------------------} 630--------------------------------------------------------------------}
695 631
696-- | Dictionary extractor are similar to dictionary builders, but play 632-- | Dictionary extractor are similar to dictionary builders, but play
@@ -709,31 +645,60 @@ endDict = Nil
709-- 645--
710-- The /reqKey/ is used to extract required key — if lookup is failed 646-- The /reqKey/ is used to extract required key — if lookup is failed
711-- then whole destructuring fail. 647-- then whole destructuring fail.
712reqKey :: BEncode a => BDict -> BKey -> Result a 648--
713reqKey d key 649newtype Get a = Get { runGet :: StateT BDict Result a }
714 | Just b <- BD.lookup key d = fromBEncode b 650 deriving (Functor, Applicative, Alternative)
715 | otherwise = Left msg 651
652next :: Get BValue
653next = Get (StateT go)
716 where 654 where
655 go Nil = throwError "no next"
656 go (Cons _ v xs) = pure (v, xs)
657
658req :: BKey -> Get BValue
659req !key = Get (StateT search)
660 where
661 search Nil = Left msg
662 search (Cons k v xs) =
663 case compare k key of
664 EQ -> Right (v, xs)
665 LT -> search xs
666 GT -> Left msg
667
717 msg = "required field `" ++ BC.unpack key ++ "' not found" 668 msg = "required field `" ++ BC.unpack key ++ "' not found"
669{-# INLINE req #-}
718 670
719-- | Used to extract optional key — if lookup is failed returns 671opt :: BKey -> Get (Maybe BValue)
720-- 'Nothing'. 672opt = optional . req
721optKey :: BEncode a => BDict -> BKey -> Result (Maybe a) 673{-# INLINE opt #-}
722optKey d key 674
723 | Just b <- BD.lookup key d 675{-# SPECIALIZE field :: Get BValue -> Get BValue #-}
724 , Right r <- fromBEncode b = return (Just r) 676field :: BEncode a => Get BValue -> Get a
725 | otherwise = return Nothing 677field m = Get $ do
678 v <- runGet m
679 either throwError pure $ fromBEncode v
680
681(<$>!) :: BEncode a => (a -> b) -> BKey -> Get b
682f <$>! k = f <$> field (req k)
683{-# INLINE (<$>!) #-}
684
685(<$>?) :: BEncode a => (Maybe a -> b) -> BKey -> Get b
686f <$>? k = f <$> optional (field (req k))
687{-# INLINE (<$>?) #-}
726 688
727-- | Infix version of the 'reqKey'. 689(<*>!) :: BEncode a => Get (a -> b) -> BKey -> Get b
728(>--) :: BEncode a => BDict -> BKey -> Result a 690f <*>! k = f <*> field (req k)
729(>--) = reqKey 691{-# INLINE (<*>!) #-}
730{-# INLINE (>--) #-}
731 692
732-- | Infix version of the 'optKey'. 693(<*>?) :: BEncode a => Get (Maybe a -> b) -> BKey -> Get b
733(>--?) :: BEncode a => BDict -> BKey -> Result (Maybe a) 694f <*>? k = f <*> optional (field (req k))
734(>--?) = optKey 695{-# INLINE (<*>?) #-}
735{-# INLINE (>--?) #-}
736 696
697fromDict :: forall a. Typeable a => Get a -> BValue -> Result a
698fromDict m (BDict d) = evalStateT (runGet m) d
699fromDict _ _ = decodingError (show (typeOf inst))
700 where
701 inst = error "fromDict: impossible" :: a
737 702
738{-------------------------------------------------------------------- 703{--------------------------------------------------------------------
739 Encoding 704 Encoding