Allow to catch fail :: Get a from pure code

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
 --  "length" < "md5sum" < "path" < "tags".
 --
 newtype Get a = Get { runGet :: StateT BDict Result a }
-  deriving (Functor, Applicative, Alternative, Monad)
+  deriving (Functor, Applicative, Alternative)
+
+-- | 'fail' is catchable from pure code.
+instance Monad Get where
+  return a = Get (return a)
+  {-# INLINE return #-}
+
+  Get m >>= f = Get (m >>= runGet . f)
+  {-# INLINE (>>=) #-}
+
+  Get m >> Get n = Get (m >> n)
+  {-# INLINE (>>) #-}
+
+  fail msg = Get (lift (Left msg))
+  {-# INLINE fail #-}
 
 -- | Get lexicographical successor of the current key\/value pair.
 next :: 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
 
     it "generic records" $ property $
       prop_bencodable (T :: T FileInfo)
+
+  describe "Get" $ do
+    it "catchable from pure code" $ do
+      fromDict (fail "fatal error" :: Get Int) (BDict BE.Nil)
+           `shouldBe`
+       Left "fatal error"