diff options
-rw-r--r-- | src/Data/BEncode.hs | 137 |
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 | |||
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 | 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. |
712 | reqKey :: BEncode a => BDict -> BKey -> Result a | 648 | -- |
713 | reqKey d key | 649 | newtype 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 | |
652 | next :: Get BValue | ||
653 | next = Get (StateT go) | ||
716 | where | 654 | where |
655 | go Nil = throwError "no next" | ||
656 | go (Cons _ v xs) = pure (v, xs) | ||
657 | |||
658 | req :: BKey -> Get BValue | ||
659 | req !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 | 671 | opt :: BKey -> Get (Maybe BValue) |
720 | -- 'Nothing'. | 672 | opt = optional . req |
721 | optKey :: BEncode a => BDict -> BKey -> Result (Maybe a) | 673 | {-# INLINE opt #-} |
722 | optKey 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) | 676 | field :: BEncode a => Get BValue -> Get a |
725 | | otherwise = return Nothing | 677 | field m = Get $ do |
678 | v <- runGet m | ||
679 | either throwError pure $ fromBEncode v | ||
680 | |||
681 | (<$>!) :: BEncode a => (a -> b) -> BKey -> Get b | ||
682 | f <$>! k = f <$> field (req k) | ||
683 | {-# INLINE (<$>!) #-} | ||
684 | |||
685 | (<$>?) :: BEncode a => (Maybe a -> b) -> BKey -> Get b | ||
686 | f <$>? 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 | 690 | f <*>! 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) | 694 | f <*>? k = f <*> optional (field (req k)) |
734 | (>--?) = optKey | 695 | {-# INLINE (<*>?) #-} |
735 | {-# INLINE (>--?) #-} | ||
736 | 696 | ||
697 | fromDict :: forall a. Typeable a => Get a -> BValue -> Result a | ||
698 | fromDict m (BDict d) = evalStateT (runGet m) d | ||
699 | fromDict _ _ = decodingError (show (typeOf inst)) | ||
700 | where | ||
701 | inst = error "fromDict: impossible" :: a | ||
737 | 702 | ||
738 | {-------------------------------------------------------------------- | 703 | {-------------------------------------------------------------------- |
739 | Encoding | 704 | Encoding |