diff options
Diffstat (limited to 'src/Data/BEncode.hs')
-rw-r--r-- | src/Data/BEncode.hs | 117 |
1 files changed, 112 insertions, 5 deletions
diff --git a/src/Data/BEncode.hs b/src/Data/BEncode.hs index 81010b6..427d401 100644 --- a/src/Data/BEncode.hs +++ b/src/Data/BEncode.hs | |||
@@ -70,10 +70,11 @@ module Data.BEncode | |||
70 | -- ** Dictionaries | 70 | -- ** Dictionaries |
71 | -- *** Building | 71 | -- *** Building |
72 | , Assoc | 72 | , Assoc |
73 | , (-->) | 73 | , (.=!) |
74 | , (-->?) | 74 | , (.=?) |
75 | , fromAssocs | 75 | , (.:) |
76 | , fromAscAssocs | 76 | , endDict |
77 | , toDict | ||
77 | 78 | ||
78 | -- *** Extraction | 79 | -- *** Extraction |
79 | , decodingError | 80 | , decodingError |
@@ -81,11 +82,26 @@ module Data.BEncode | |||
81 | , optKey | 82 | , optKey |
82 | , (>--) | 83 | , (>--) |
83 | , (>--?) | 84 | , (>--?) |
85 | |||
86 | -- *** Extraction | ||
87 | , Get | ||
88 | , fromDict | ||
89 | |||
90 | , req | ||
91 | , opt | ||
92 | , field | ||
93 | |||
94 | , (<$>!) | ||
95 | , (<$>?) | ||
96 | , (<*>!) | ||
97 | , (<*>?) | ||
84 | ) where | 98 | ) where |
85 | 99 | ||
86 | 100 | ||
87 | import Control.Applicative | 101 | import Control.Applicative |
88 | import Control.Monad | 102 | import Control.Monad |
103 | import Control.Monad.State | ||
104 | import Control.Monad.Error | ||
89 | import Data.Int | 105 | import Data.Int |
90 | import Data.List as L | 106 | import Data.List as L |
91 | import Data.Maybe (mapMaybe) | 107 | import Data.Maybe (mapMaybe) |
@@ -546,9 +562,67 @@ instance (BEncode a, BEncode b, BEncode c, BEncode d, BEncode e) | |||
546 | {-# INLINE fromBEncode #-} | 562 | {-# INLINE fromBEncode #-} |
547 | 563 | ||
548 | {-------------------------------------------------------------------- | 564 | {-------------------------------------------------------------------- |
549 | Building dictionaries | 565 | -- Dictionary extraction |
550 | --------------------------------------------------------------------} | 566 | --------------------------------------------------------------------} |
551 | 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 | ||
624 | --------------------------------------------------------------------} | ||
625 | {- | ||
552 | -- | /Assoc/ used to easily build dictionaries with required and | 626 | -- | /Assoc/ used to easily build dictionaries with required and |
553 | -- optional keys. Suppose we have we following datatype we want to | 627 | -- optional keys. Suppose we have we following datatype we want to |
554 | -- serialize: | 628 | -- serialize: |
@@ -598,6 +672,39 @@ fromAssocs = undefined -- BDict . M.fromList . mapMaybe unAssoc | |||
598 | fromAscAssocs :: [Assoc] -> BValue | 672 | fromAscAssocs :: [Assoc] -> BValue |
599 | fromAscAssocs = BDict . BD.fromAscList . mapMaybe unAssoc | 673 | fromAscAssocs = BDict . BD.fromAscList . mapMaybe unAssoc |
600 | {-# INLINE fromAscAssocs #-} | 674 | {-# INLINE fromAscAssocs #-} |
675 | -} | ||
676 | |||
677 | type BPair = (BKey, BValue) | ||
678 | type Assoc = Maybe BPair | ||
679 | |||
680 | -- TODO better name | ||
681 | (.=!) :: BEncode a => BKey -> a -> Assoc | ||
682 | k .=! v = Just (k, toBEncode v) | ||
683 | {-# INLINE (.=!) #-} | ||
684 | |||
685 | infix 6 .=! | ||
686 | |||
687 | (.=?) :: BEncode a => BKey -> Maybe a -> Assoc | ||
688 | _ .=? Nothing = Nothing | ||
689 | k .=? Just v = Just (k, toBEncode v) | ||
690 | {-# INLINE (.=?) #-} | ||
691 | |||
692 | infix 6 .=? | ||
693 | |||
694 | (.:) :: Assoc -> BDict -> BDict | ||
695 | Nothing .: d = d | ||
696 | Just (k, v) .: d = Cons k v d | ||
697 | {-# INLINE (.:) #-} | ||
698 | |||
699 | infixr 5 .: | ||
700 | |||
701 | toDict :: BDict -> BValue | ||
702 | toDict = BDict | ||
703 | {-# INLINE toDict #-} | ||
704 | |||
705 | endDict :: BDict | ||
706 | endDict = Nil | ||
707 | {-# INLINE endDict #-} | ||
601 | 708 | ||
602 | {-------------------------------------------------------------------- | 709 | {-------------------------------------------------------------------- |
603 | Dictionary extraction | 710 | Dictionary extraction |