summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Data/BEncode.hs16
-rw-r--r--tests/properties.hs6
2 files changed, 21 insertions, 1 deletions
diff --git a/src/Data/BEncode.hs b/src/Data/BEncode.hs
index 8768dac..a866a6e 100644
--- a/src/Data/BEncode.hs
+++ b/src/Data/BEncode.hs
@@ -643,7 +643,21 @@ endDict = Nil
643-- "length" < "md5sum" < "path" < "tags". 643-- "length" < "md5sum" < "path" < "tags".
644-- 644--
645newtype Get a = Get { runGet :: StateT BDict Result a } 645newtype Get a = Get { runGet :: StateT BDict Result a }
646 deriving (Functor, Applicative, Alternative, Monad) 646 deriving (Functor, Applicative, Alternative)
647
648-- | 'fail' is catchable from pure code.
649instance Monad Get where
650 return a = Get (return a)
651 {-# INLINE return #-}
652
653 Get m >>= f = Get (m >>= runGet . f)
654 {-# INLINE (>>=) #-}
655
656 Get m >> Get n = Get (m >> n)
657 {-# INLINE (>>) #-}
658
659 fail msg = Get (lift (Left msg))
660 {-# INLINE fail #-}
647 661
648-- | Get lexicographical successor of the current key\/value pair. 662-- | Get lexicographical successor of the current key\/value pair.
649next :: Get BValue 663next :: Get BValue
diff --git a/tests/properties.hs b/tests/properties.hs
index 2e5345f..876b954 100644
--- a/tests/properties.hs
+++ b/tests/properties.hs
@@ -70,3 +70,9 @@ main = hspec $ do
70 70
71 it "generic records" $ property $ 71 it "generic records" $ property $
72 prop_bencodable (T :: T FileInfo) 72 prop_bencodable (T :: T FileInfo)
73
74 describe "Get" $ do
75 it "catchable from pure code" $ do
76 fromDict (fail "fatal error" :: Get Int) (BDict BE.Nil)
77 `shouldBe`
78 Left "fatal error"