diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/Data/BEncode.hs | 21 |
1 files changed, 21 insertions, 0 deletions
diff --git a/src/Data/BEncode.hs b/src/Data/BEncode.hs index 2494166..5c93e2f 100644 --- a/src/Data/BEncode.hs +++ b/src/Data/BEncode.hs | |||
@@ -78,11 +78,13 @@ module Data.BEncode | |||
78 | , Result | 78 | , Result |
79 | , decodingError | 79 | , decodingError |
80 | , fromDict | 80 | , fromDict |
81 | , lookAhead | ||
81 | 82 | ||
82 | , next | 83 | , next |
83 | , req | 84 | , req |
84 | , opt | 85 | , opt |
85 | , field | 86 | , field |
87 | , match | ||
86 | 88 | ||
87 | , (<$>!) | 89 | , (<$>!) |
88 | , (<$>?) | 90 | , (<$>?) |
@@ -671,6 +673,15 @@ instance Monad Get where | |||
671 | fail msg = Get (lift (Left msg)) | 673 | fail msg = Get (lift (Left msg)) |
672 | {-# INLINE fail #-} | 674 | {-# INLINE fail #-} |
673 | 675 | ||
676 | -- | Run action, but return without consuming and key\/value pair. | ||
677 | -- Fails if the action fails. | ||
678 | lookAhead :: Get a -> Get a | ||
679 | lookAhead (Get m) = Get $ do | ||
680 | s <- get | ||
681 | r <- m | ||
682 | put s | ||
683 | return r | ||
684 | |||
674 | -- | Get lexicographical successor of the current key\/value pair. | 685 | -- | Get lexicographical successor of the current key\/value pair. |
675 | next :: Get BValue | 686 | next :: Get BValue |
676 | next = Get (StateT go) | 687 | next = Get (StateT go) |
@@ -704,6 +715,16 @@ field m = Get $ do | |||
704 | v <- runGet m | 715 | v <- runGet m |
705 | either throwError pure $ fromBEncode v | 716 | either throwError pure $ fromBEncode v |
706 | 717 | ||
718 | -- | Match key with value. | ||
719 | match :: BKey -> BValue -> Get () | ||
720 | match key expected = do | ||
721 | actual <- req key | ||
722 | if actual == expected | ||
723 | then return () | ||
724 | else fail $ "key match failure(" ++ show key ++ "): " ++ | ||
725 | "expected = " ++ show expected ++ | ||
726 | "actual = " ++ show actual | ||
727 | |||
707 | -- | Shorthand for: @f '<$>' 'field' ('req' k)@. | 728 | -- | Shorthand for: @f '<$>' 'field' ('req' k)@. |
708 | (<$>!) :: BEncode a => (a -> b) -> BKey -> Get b | 729 | (<$>!) :: BEncode a => (a -> b) -> BKey -> Get b |
709 | f <$>! k = f <$> field (req k) | 730 | f <$>! k = f <$> field (req k) |