Merge dfcfaa6 into 36b16d1

TokTok · May 8, 2019 · 36c044d · 36c044d
2 parents 36b16d1 + dfcfaa6
commit 36c044d
Show file tree

Hide file tree

Showing 4 changed files with 44 additions and 3 deletions.
diff --git a/src/Data/MessagePack/Types/Class.hs b/src/Data/MessagePack/Types/Class.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP                  #-}
 {-# LANGUAGE DefaultSignatures    #-}
 {-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE FlexibleInstances    #-}
@@ -51,17 +52,28 @@ import           Data.MessagePack.Types.Object
 
 class GMessagePack f where
   gToObject   :: f a -> Object
+#if (MIN_VERSION_base(4,13,0))
+  gFromObject :: (Applicative m, Monad m, MonadFail m) => Object -> m (f a)
+#else
   gFromObject :: (Applicative m, Monad m) => Object -> m (f a)
+#endif
 
 
 class MessagePack a where
   toObject   :: a -> Object
+#if (MIN_VERSION_base(4,13,0))
+  fromObject :: (Applicative m, Monad m, MonadFail m) => Object -> m a
+#else
   fromObject :: (Applicative m, Monad m) => Object -> m a
+#endif
 
   default toObject :: (Generic a, GMessagePack (Rep a))
                    => a -> Object
   toObject = genericToObject
   default fromObject :: ( Applicative m, Monad m
+#if (MIN_VERSION_base(4,13,0))
+                        , MonadFail m
+#endif
                         , Generic a, GMessagePack (Rep a))
                      => Object -> m a
   fromObject = genericFromObject
@@ -72,6 +84,9 @@ genericToObject :: (Generic a, GMessagePack (Rep a))
 genericToObject = gToObject . from
 
 genericFromObject :: ( Applicative m, Monad m
+#if (MIN_VERSION_base(4,13,0))
+                     , MonadFail m
+#endif
                      , Generic a, GMessagePack (Rep a))
                   => Object -> m a
 genericFromObject x = to <$> gFromObject x

diff --git a/src/Data/MessagePack/Types/Generic.hs b/src/Data/MessagePack/Types/Generic.hs
@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE CPP                 #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE FlexibleInstances   #-}
 {-# LANGUAGE IncoherentInstances #-}
@@ -20,7 +21,7 @@ import           Data.MessagePack.Types.Object (Object (..))
 
 instance GMessagePack V1 where
   gToObject = undefined
-  gFromObject = fail "can't instantiate void type"
+  gFromObject _ = fail "can't instantiate void type"
 
 instance GMessagePack U1 where
   gToObject U1 = ObjectNil
@@ -55,7 +56,11 @@ instance MessagePack a => GMessagePack (K1 i a) where
 
 class GProdPack f where
   prodToObject :: f a -> [Object]
+#if (MIN_VERSION_base(4,13,0))
+  prodFromObject :: (Applicative m, Monad m, MonadFail m) => [Object] -> m (f a)
+#else
   prodFromObject :: (Applicative m, Monad m) => [Object] -> m (f a)
+#endif
 
 
 instance (GMessagePack a, GProdPack b) => GProdPack (a :*: b) where
@@ -71,21 +76,33 @@ instance GMessagePack a => GProdPack (M1 t c a) where
 
 -- Sum type packing.
 
+#if (MIN_VERSION_base(4,13,0))
+checkSumFromObject0 :: (Applicative m, Monad m, MonadFail m) => (GSumPack f) => Word64 -> Word64 -> m (f a)
+#else
 checkSumFromObject0 :: (Applicative m, Monad m) => (GSumPack f) => Word64 -> Word64 -> m (f a)
+#endif
 checkSumFromObject0 size code
   | code < size = sumFromObject code size ObjectNil
   | otherwise   = fail "invalid encoding for sum type"
 
 
+#if (MIN_VERSION_base(4,13,0))
+checkSumFromObject :: (Applicative m, Monad m, MonadFail m) => (GSumPack f) => Word64 -> Word64 -> Object -> m (f a)
+#else
 checkSumFromObject :: (Applicative m, Monad m) => (GSumPack f) => Word64 -> Word64 -> Object -> m (f a)
+#endif
 checkSumFromObject size code x
   | code < size = sumFromObject code size x
   | otherwise   = fail "invalid encoding for sum type"
 
 
 class GSumPack f where
   sumToObject :: Word64 -> Word64 -> f a -> Object
+#if (MIN_VERSION_base(4,13,0))
+  sumFromObject :: (Applicative m, Monad m, MonadFail m) => Word64 -> Word64 -> Object -> m (f a)
+#else
   sumFromObject :: (Applicative m, Monad m) => Word64 -> Word64 -> Object -> m (f a)
+#endif
 
 
 instance (GSumPack a, GSumPack b) => GSumPack (a :+: b) where

diff --git a/src/Data/MessagePack/Types/Option.hs b/src/Data/MessagePack/Types/Option.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP                #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveFoldable     #-}
 {-# LANGUAGE DeriveFunctor      #-}
@@ -33,10 +34,13 @@ instance Applicative Option where
 
 instance Monad Option where
   return = Some
-  fail _ = None
 
   None   >>= _ = None
   Some x >>= f = f x
+#if (MIN_VERSION_base(4,13,0))
+instance MonadFail Option where
+#endif
+  fail _ = None
 
 instance Alternative Option where
   empty = None

diff --git a/src/Data/MessagePack/Types/Result.hs b/src/Data/MessagePack/Types/Result.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP               #-}
 {-# LANGUAGE DeriveFoldable    #-}
 {-# LANGUAGE DeriveFunctor     #-}
 {-# LANGUAGE DeriveTraversable #-}
@@ -36,11 +37,15 @@ instance Alternative Result where
 
 instance Monad Result where
   return = pure
-  fail = Failure
 
   Success x   >>= f = f x
   Failure msg >>= _ = Failure msg
 
+#if (MIN_VERSION_base(4,13,0))
+instance MonadFail Result where
+#endif
+  fail = Failure
+
 
 instance Arbitrary a => Arbitrary (Result a) where
   arbitrary = Gen.oneof