From 3ac05740cb727b2868e2de191138b2dfbe610f85 Mon Sep 17 00:00:00 2001 From: Vincent Hanquez Date: Thu, 18 Jan 2018 09:45:48 +0000 Subject: [PATCH 1/6] fix use of shrinkMutableByteArray# for older GHC --- basement/Basement/Block/Base.hs | 5 +++-- basement/Basement/Block/Builder.hs | 3 +-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/basement/Basement/Block/Base.hs b/basement/Basement/Block/Base.hs index 818e1b50..1ac54e14 100644 --- a/basement/Basement/Block/Base.hs +++ b/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. -- diff --git a/basement/Basement/Block/Builder.hs b/basement/Basement/Block/Builder.hs index e1ddec66..66f0cb74 100644 --- a/basement/Basement/Block/Builder.hs +++ b/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 -- From 7910dda88ebe438cddfb82215c50d59974d4558b Mon Sep 17 00:00:00 2001 From: Vincent Hanquez Date: Thu, 18 Jan 2018 09:46:23 +0000 Subject: [PATCH 2/6] Introduce AMPMonad constraint to handle ghc compat before the AMP --- basement/Basement/Compat/AMP.hs | 14 ++++++++++++++ basement/basement.cabal | 1 + 2 files changed, 15 insertions(+) create mode 100644 basement/Basement/Compat/AMP.hs diff --git a/basement/Basement/Compat/AMP.hs b/basement/Basement/Compat/AMP.hs new file mode 100644 index 00000000..e3f9d58f --- /dev/null +++ b/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 diff --git a/basement/basement.cabal b/basement/basement.cabal index 20df506b..2c4c4f43 100644 --- a/basement/basement.cabal +++ b/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 From f7fdaeb7b80d1e3e2e2fd65ea87fbb06acd529c3 Mon Sep 17 00:00:00 2001 From: Vincent Hanquez Date: Thu, 18 Jan 2018 09:47:17 +0000 Subject: [PATCH 3/6] Use AMPMonad constraint instead of Monad for compat --- Foundation/Monad/Except.hs | 8 +++++--- Foundation/Monad/Exception.hs | 4 +++- Foundation/Monad/MonadIO.hs | 4 +++- Foundation/Monad/Reader.hs | 8 +++++--- Foundation/Monad/Transformer.hs | 4 +++- basement/Basement/Monad.hs | 4 +++- 6 files changed, 22 insertions(+), 10 deletions(-) diff --git a/Foundation/Monad/Except.hs b/Foundation/Monad/Except.hs index f4b63e4d..4eafd5a8 100644 --- a/Foundation/Monad/Except.hs +++ b/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 diff --git a/Foundation/Monad/Exception.hs b/Foundation/Monad/Exception.hs index 95b31017..212da152 100644 --- a/Foundation/Monad/Exception.hs +++ b/Foundation/Monad/Exception.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ConstraintKinds #-} module Foundation.Monad.Exception ( MonadThrow(..) , MonadCatch(..) @@ -6,10 +7,11 @@ module Foundation.Monad.Exception ) 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 diff --git a/Foundation/Monad/MonadIO.hs b/Foundation/Monad/MonadIO.hs index e25a5fda..914791af 100644 --- a/Foundation/Monad/MonadIO.hs +++ b/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 diff --git a/Foundation/Monad/Reader.hs b/Foundation/Monad/Reader.hs index 8f7b2d56..a9472e2f 100644 --- a/Foundation/Monad/Reader.hs +++ b/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 diff --git a/Foundation/Monad/Transformer.hs b/Foundation/Monad/Transformer.hs index ec23bd97..fd9b8fe9 100644 --- a/Foundation/Monad/Transformer.hs +++ b/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 diff --git a/basement/Basement/Monad.hs b/basement/Basement/Monad.hs index 96b92a0f..c1529be0 100644 --- a/basement/Basement/Monad.hs +++ b/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 From 8643558c6f20bfb58d7f6f9d1fbc47e14a2e02ea Mon Sep 17 00:00:00 2001 From: Vincent Hanquez Date: Thu, 18 Jan 2018 10:17:54 +0000 Subject: [PATCH 4/6] Add Typeable explicitely for Word128/Word256 and old ghc versions --- basement/Basement/Types/Word128.hs | 9 +++++---- basement/Basement/Types/Word256.hs | 9 +++++---- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/basement/Basement/Types/Word128.hs b/basement/Basement/Types/Word128.hs index 608805cd..d22dd31b 100644 --- a/basement/Basement/Types/Word128.hs +++ b/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) diff --git a/basement/Basement/Types/Word256.hs b/basement/Basement/Types/Word256.hs index e1aa8857..daaa1032 100644 --- a/basement/Basement/Types/Word256.hs +++ b/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) From 47d6a0bcd2adc1f93f48ec97159530660f84e4f3 Mon Sep 17 00:00:00 2001 From: Vincent Hanquez Date: Thu, 18 Jan 2018 15:06:04 +0000 Subject: [PATCH 5/6] add Typeable for Bitmap --- Foundation/Array/Bitmap.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Foundation/Array/Bitmap.hs b/Foundation/Array/Bitmap.hs index f1c8b0ae..7117ef4c 100644 --- a/Foundation/Array/Bitmap.hs +++ b/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) From 2297d658ec771c1f78c5cd6eb80b77a15975ae11 Mon Sep 17 00:00:00 2001 From: Vincent Hanquez Date: Thu, 18 Jan 2018 15:06:19 +0000 Subject: [PATCH 6/6] ghc 7.8 is missing Typeable for (,,,,,,,), so just comment the test --- tests/Test/Foundation/Network/IPv6.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/tests/Test/Foundation/Network/IPv6.hs b/tests/Test/Foundation/Network/IPv6.hs index a45174ba..6d2db8af 100644 --- a/tests/Test/Foundation/Network/IPv6.hs +++ b/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