Compat amp 78

Foundation/Array/Bitmap.hs

@@ -13,6 +13,7 @@
 -- unnecessary churn.
 --
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 module Foundation.Array.Bitmap
     ( Bitmap
     , MutableBitmap
@@ -46,6 +47,7 @@ import           GHC.ST
 import qualified Data.List
 
 data Bitmap = Bitmap (CountOf Bool) (UArray Word32)
+    deriving (Typeable)
 
 data MutableBitmap st = MutableBitmap (CountOf Bool) (MUArray Word32 st)
 

Foundation/Monad/Except.hs

@@ -1,9 +1,11 @@
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ConstraintKinds #-}
 module Foundation.Monad.Except
     ( ExceptT(..)
     ) where
 
 import Basement.Imports
+import Basement.Compat.AMP
 import Foundation.Monad.Base
 import Foundation.Monad.Reader
 
@@ -12,7 +14,7 @@ newtype ExceptT e m a = ExceptT { runExceptT :: m (Either e a) }
 instance Functor m => Functor (ExceptT e m) where
     fmap f = ExceptT . fmap (fmap f) . runExceptT
 
-instance (Functor m, Monad m) => Applicative (ExceptT e m) where
+instance AMPMonad m => Applicative (ExceptT e m) where
     pure a = ExceptT $ pure (Right a)
     ExceptT f <*> ExceptT v = ExceptT $ do
         mf <- f
@@ -24,11 +26,11 @@ instance (Functor m, Monad m) => Applicative (ExceptT e m) where
                     Left e -> pure (Left e)
                     Right x -> pure (Right (k x))
 
-instance Monad m => MonadFailure (ExceptT e m) where
+instance AMPMonad m => MonadFailure (ExceptT e m) where
     type Failure (ExceptT e m) = e
     mFail = ExceptT . pure . Left
 
-instance Monad m => Monad (ExceptT e m) where
+instance AMPMonad m => Monad (ExceptT e m) where
     return a = ExceptT $ return (Right a)
     m >>= k = ExceptT $ do
         a <- runExceptT m

Foundation/Monad/Exception.hs

@@ -1,15 +1,17 @@
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ConstraintKinds #-}
 module Foundation.Monad.Exception
     ( MonadThrow(..)
     , MonadCatch(..)
     , MonadBracket(..)
     ) where
 
 import           Basement.Compat.Base
+import           Basement.Compat.AMP
 import qualified Control.Exception as E
 
 -- | Monad that can throw exception
-class Monad m => MonadThrow m where
+class AMPMonad m => MonadThrow m where
     -- | Throw immediatity an exception.
     -- Only a 'MonadCatch' monad will be able to catch the exception using 'catch'
     throw :: Exception e => e -> m a

Foundation/Monad/MonadIO.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
 module Foundation.Monad.MonadIO
     ( MonadIO(..)
     ) where
@@ -7,9 +8,10 @@ module Foundation.Monad.MonadIO
 import Control.Monad.IO.Class
 #else
 import Basement.Compat.Base
+import Basement.Compat.AMP
 
 -- | Monads in which 'IO' computations may be embedded.
-class Monad m => MonadIO m where
+class AMPMonad m => MonadIO m where
     -- | Lift a computation from the 'IO' monad.
     liftIO :: IO a -> m a
 

Foundation/Monad/Reader.hs

@@ -3,6 +3,7 @@
 --
 -- This is useful to keep a non-modifiable value
 -- in a context
+{-# LANGUAGE ConstraintKinds #-}
 module Foundation.Monad.Reader
     ( -- * MonadReader
       MonadReader(..)
@@ -12,10 +13,11 @@ module Foundation.Monad.Reader
     ) where
 
 import Basement.Compat.Base (($), (.), const)
+import Basement.Compat.AMP
 import Foundation.Monad.Base
 import Foundation.Monad.Exception
 
-class Monad m => MonadReader m where
+class AMPMonad m => MonadReader m where
     type ReaderContext m
     ask :: m (ReaderContext m)
 
@@ -32,7 +34,7 @@ instance Applicative m => Applicative (ReaderT r m) where
     fab <*> fa = ReaderT $ \r -> runReaderT fab r <*> runReaderT fa r
     {-# INLINE (<*>) #-}
 
-instance Monad m => Monad (ReaderT r m) where
+instance AMPMonad m => Monad (ReaderT r m) where
     return a = ReaderT $ const (return a)
     {-# INLINE return #-}
     ma >>= mab = ReaderT $ \r -> runReaderT ma r >>= \a -> runReaderT (mab a) r
@@ -64,6 +66,6 @@ instance MonadBracket m => MonadBracket (ReaderT r m) where
                               (\a exn -> runReaderT (cleanupExcept a exn) c)
                               (\a -> runReaderT (innerAction a) c)
 
-instance Monad m => MonadReader (ReaderT r m) where
+instance AMPMonad m => MonadReader (ReaderT r m) where
     type ReaderContext (ReaderT r m) = r
     ask = ReaderT return

Foundation/Monad/Transformer.hs

@@ -1,10 +1,12 @@
+{-# LANGUAGE ConstraintKinds #-}
 module Foundation.Monad.Transformer
     ( MonadTrans(..)
     ) where
 
 import Basement.Compat.Base
+import Basement.Compat.AMP
 
 -- | Basic Transformer class
 class MonadTrans trans where
     -- | Lift a computation from an inner monad to the current transformer monad
-    lift :: Monad m => m a -> trans m a
+    lift :: AMPMonad m => m a -> trans m a

basement/Basement/Block/Base.hs

@@ -263,9 +263,10 @@ unsafeFreeze (MutableBlock mba) = primitive $ \s1 ->
         (# s2, ba #) -> (# s2, Block ba #)
 {-# INLINE unsafeFreeze #-}
 
-unsafeShrink :: PrimMonad prim => MutableBlock ty (PrimState prim) -> CountOf ty -> prim ()
+unsafeShrink :: PrimMonad prim => MutableBlock ty (PrimState prim) -> CountOf ty -> prim (MutableBlock ty (PrimState prim))
 unsafeShrink (MutableBlock mba) (CountOf (I# nsz)) = primitive $ \s ->
-  (# shrinkMutableByteArray# mba nsz s, () #)
+    case compatShrinkMutableByteArray# mba nsz s of
+        (# s, mba' #) -> (# s, MutableBlock mba' #)
 
 -- | Thaw an immutable block.
 --

basement/Basement/Block/Builder.hs

@@ -95,8 +95,7 @@ run :: PrimMonad prim => Builder -> prim (Block Word8)
 run (Builder sz action) = do
     mb <- B.new sz
     off <- runAction_ action mb 0
-    B.unsafeShrink mb (offsetAsSize off)
-    B.unsafeFreeze mb
+    B.unsafeShrink mb (offsetAsSize off) >>= B.unsafeFreeze
 
 -- | run the given builder and return a UTF8String
 --

basement/Basement/Compat/AMP.hs

@@ -0,0 +1,14 @@
+{-# LANGUAGE CPP             #-}
+{-# LANGUAGE ConstraintKinds #-}
+-- a compat module for ghc < 7.10 to handle the AMP change smoothly
+module Basement.Compat.AMP
+    ( AMPMonad
+    ) where
+
+import Basement.Compat.Base
+
+#if MIN_VERSION_base(4,8,0)
+type AMPMonad m = Monad m
+#else
+type AMPMonad m = (Functor m, Applicative m, Monad m)
+#endif

basement/Basement/Monad.hs

@@ -16,6 +16,7 @@
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE UnboxedTuples #-}
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE ConstraintKinds #-}
 module Basement.Monad
     ( PrimMonad(..)
     , MonadFailure(..)
@@ -34,6 +35,7 @@ import           GHC.IORef
 import           GHC.IO
 import           GHC.Prim
 import           Basement.Compat.Base (Exception, (.), ($), Applicative)
+import           Basement.Compat.AMP
 
 -- | Primitive monad that can handle mutation.
 --
@@ -120,7 +122,7 @@ primTouch x = unsafePrimFromIO $ primitive $ \s -> case touch# x s of { s2 -> (#
 -- | Monad that can represent failure
 --
 -- Similar to MonadFail but with a parametrized Failure linked to the Monad
-class Prelude.Monad m => MonadFailure m where
+class AMPMonad m => MonadFailure m where
     -- | The associated type with the MonadFailure, representing what
     -- failure can be encoded in this monad
     type Failure m

basement/Basement/Types/Word128.hs

@@ -1,6 +1,7 @@
-{-# LANGUAGE CPP                   #-}
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE CPP                #-}
+{-# LANGUAGE MagicHash          #-}
+{-# LANGUAGE UnboxedTuples      #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 module Basement.Types.Word128
     ( Word128(..)
     , (+)
@@ -37,7 +38,7 @@ import           Basement.Numerical.Number
 -- | 128 bits Word
 data Word128 = Word128 {-# UNPACK #-} !Word64
                        {-# UNPACK #-} !Word64
-    deriving (Eq)
+    deriving (Eq, Typeable)
 
 instance Show Word128 where
     show w = Prelude.show (toNatural w)

basement/Basement/Types/Word256.hs

@@ -1,6 +1,7 @@
-{-# LANGUAGE CPP                   #-}
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE CPP                #-}
+{-# LANGUAGE MagicHash          #-}
+{-# LANGUAGE UnboxedTuples      #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 module Basement.Types.Word256
     ( Word256(..)
     , (+)
@@ -39,7 +40,7 @@ data Word256 = Word256 {-# UNPACK #-} !Word64
                        {-# UNPACK #-} !Word64
                        {-# UNPACK #-} !Word64
                        {-# UNPACK #-} !Word64
-    deriving (Eq)
+    deriving (Eq, Typeable)
 
 instance Show Word256 where
     show w = Prelude.show (toNatural w)

basement/basement.cabal

@@ -80,6 +80,7 @@ library
                      Basement.Alg.XorShift
 
                      -- compat / base redefinition
+                     Basement.Compat.AMP
                      Basement.Compat.Base
                      Basement.Compat.Bifunctor
                      Basement.Compat.CallStack

tests/Test/Foundation/Network/IPv6.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP               #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 module Test.Foundation.Network.IPv6
@@ -27,6 +28,7 @@ testOrdering genElement = Property "ordering" $
 
 testNetworkIPv6 :: Test
 testNetworkIPv6 = Group "IPv6"
+#if __GLASGOW_HASKELL__ >= 710
     [ Property "toTuple . fromTuple == id" $
         forAll genIPv6Tuple $ \x -> x === toTuple (fromTuple x)
     , Property "toString . fromString == id" $
@@ -46,3 +48,6 @@ testNetworkIPv6 = Group "IPv6"
         , Property "0:0::FFFF:129.144.52.38" $ (fromTuple (0,0,0,0,0,0xffff,0x8190,0x3426)) === (fromString "0:0::FFFF:129.144.52.38")
         ]
     ]
+#else
+    []
+#endif