Allow to catch fail :: Get a from pure code

1 files changed, 15 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