diff --git a/Control/Monad/ST/Trans.hs b/Control/Monad/ST/Trans.hs --- a/Control/Monad/ST/Trans.hs +++ b/Control/Monad/ST/Trans.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE CPP, MagicHash, UnboxedTuples, Rank2Types, FlexibleInstances, - MultiParamTypeClasses, UndecidableInstances, RecursiveDo #-} +{-# LANGUAGE CPP, MagicHash, Rank2Types #-} {- | Module : Control.Monad.ST.Trans Copyright : Josef Svenningsson 2008-2017 @@ -53,17 +52,19 @@ )where import GHC.Base -import GHC.Arr (Ix(..), safeRangeSize, safeIndex, - Array(..), arrEleBottom) +import GHC.Arr (Ix(..), Array(..)) import qualified GHC.Arr as STArray import Data.STRef (STRef) import qualified Data.STRef as STRef import Data.Array.ST hiding (runSTArray) -import qualified Data.Array.ST as STArray +--import qualified Data.Array.ST as STArray +#if __GLASGOW_HASKELL__ <= 708 import Control.Applicative +#endif + import Control.Monad.ST.Trans.Internal import Data.IORef @@ -71,24 +72,19 @@ import Unsafe.Coerce import System.IO.Unsafe -#if __GLASGOW_HASKELL__ < 708 -isTrue# :: Bool -> Bool -isTrue# x = x -#endif - {-# INLINE newSTRef #-} -- | Create a new reference -newSTRef :: (Applicative m, Monad m) => a -> STT s m (STRef s a) -newSTRef init = liftST (STRef.newSTRef init) +newSTRef :: (Applicative m) => a -> STT s m (STRef s a) +newSTRef i = liftST (STRef.newSTRef i) {-# INLINE readSTRef #-} -- | Reads the value of a reference -readSTRef :: (Applicative m, Monad m) => STRef s a -> STT s m a +readSTRef :: (Applicative m) => STRef s a -> STT s m a readSTRef ref = liftST (STRef.readSTRef ref) {-# INLINE writeSTRef #-} -- | Modifies the value of a reference -writeSTRef :: (Applicative m, Monad m) => STRef s a -> a -> STT s m () +writeSTRef :: (Applicative m) => STRef s a -> a -> STT s m () writeSTRef ref a = liftST (STRef.writeSTRef ref a) {-# DEPRECATED runST "Use runSTT instead" #-} @@ -111,9 +107,9 @@ {-# INLINE newSTArray #-} -- | Creates a new mutable array -newSTArray :: (Ix i, Applicative m, Monad m) => +newSTArray :: (Ix i, Applicative m) => (i,i) -> e -> STT s m (STArray s i e) -newSTArray bounds init = liftST (newArray bounds init) +newSTArray bnds i = liftST (newArray bnds i) {-# INLINE boundsSTArray #-} -- | Returns the lowest and highest indices of the array @@ -127,45 +123,69 @@ {-# INLINE readSTArray #-} -- | Retrieves an element from the array -readSTArray :: (Ix i, Applicative m, Monad m) => +readSTArray :: (Ix i, Applicative m) => STArray s i e -> i -> STT s m e readSTArray arr i = liftST (readArray arr i) {-# INLINE unsafeReadSTArray #-} -unsafeReadSTArray :: (Ix i, Applicative m, Monad m) => +unsafeReadSTArray :: ( +#if __GLASGOW_HASKELL__ <= 710 + Ix i, +#endif + Applicative m) => STArray s i e -> Int -> STT s m e unsafeReadSTArray arr i = liftST (STArray.unsafeReadSTArray arr i) {-# INLINE writeSTArray #-} -- | Modifies an element in the array -writeSTArray :: (Ix i, Applicative m, Monad m) => +writeSTArray :: (Ix i, Applicative m) => STArray s i e -> i -> e -> STT s m () writeSTArray arr i e = liftST (writeArray arr i e) {-# INLINE unsafeWriteSTArray #-} -unsafeWriteSTArray :: (Ix i, Applicative m, Monad m) => +unsafeWriteSTArray :: ( +#if __GLASGOW_HASKELL__ <= 710 + Ix i, +#endif + Applicative m) => STArray s i e -> Int -> e -> STT s m () unsafeWriteSTArray arr i e = liftST (STArray.unsafeWriteSTArray arr i e) {-# INLINE freezeSTArray #-} -- | Copy a mutable array and turn it into an immutable array -freezeSTArray :: (Ix i, Applicative m, Monad m) => +freezeSTArray :: ( +#if __GLASGOW_HASKELL__ <= 710 + Ix i, +#endif + Applicative m) => STArray s i e -> STT s m (Array i e) freezeSTArray arr = liftST (STArray.freezeSTArray arr) {-# INLINE unsafeFreezeSTArray #-} -unsafeFreezeSTArray :: (Ix i, Applicative m, Monad m) => +unsafeFreezeSTArray :: ( +#if __GLASGOW_HASKELL__ <= 710 + Ix i, +#endif + Applicative m) => STArray s i e -> STT s m (Array i e) unsafeFreezeSTArray arr = liftST (STArray.unsafeFreezeSTArray arr) {-# INLINE thawSTArray #-} -- | Copy an immutable array and turn it into a mutable array -thawSTArray :: (Ix i, Applicative m, Monad m) => +thawSTArray :: ( +#if __GLASGOW_HASKELL__ <= 710 + Ix i, +#endif + Applicative m) => Array i e -> STT s m (STArray s i e) thawSTArray arr = liftST (STArray.thawSTArray arr) {-# INLINE unsafeThawSTArray #-} -unsafeThawSTArray :: (Ix i, Applicative m, Monad m) => +unsafeThawSTArray :: ( +#if __GLASGOW_HASKELL__ <= 710 + Ix i, +#endif + Applicative m) => Array i e -> STT s m (STArray s i e) unsafeThawSTArray arr = liftST (STArray.unsafeThawSTArray arr) @@ -173,7 +193,14 @@ -- | A safe way to create and work with a mutable array before returning an -- immutable array for later perusal. This function avoids copying -- the array before returning it. -runSTArray :: (Ix i, Applicative m, Monad m) +runSTArray :: ( +#if __GLASGOW_HASKELL__ <= 710 + Ix i, +#endif +#if __GLASGOW_HASKELL__ <= 708 + Applicative m, +#endif + Monad m) => (forall s . STT s m (STArray s i e)) -> m (Array i e) runSTArray st = runSTT (st >>= unsafeFreezeSTArray) diff --git a/Control/Monad/ST/Trans/Internal.hs b/Control/Monad/ST/Trans/Internal.hs --- a/Control/Monad/ST/Trans/Internal.hs +++ b/Control/Monad/ST/Trans/Internal.hs @@ -26,6 +26,7 @@ import GHC.Base import GHC.ST hiding (liftST) +import qualified Control.Monad.Fail as MF import Control.Monad.Fix import Control.Monad.Trans import Control.Monad.Error.Class @@ -33,12 +34,14 @@ import Control.Monad.State.Class import Control.Monad.Writer.Class +#if __GLASGOW_HASKELL__ <= 708 import Control.Applicative +#endif import Data.Array.ST import Data.Array.Base -import GHC.Int (Int8, Int16, Int32, Int64) -import GHC.Word (Word8, Word16, Word32, Word64) +import GHC.Int ( Int8, Int16, Int32, Int64) +import GHC.Word (Word, Word8, Word16, Word32, Word64) import GHC.Ptr (Ptr, FunPtr) import GHC.Stable (StablePtr) @@ -69,6 +72,8 @@ case ret of STTRet new_st a -> unSTT (k a) new_st + +instance MF.MonadFail m => MF.MonadFail (STT s m) where fail msg = lift (fail msg) instance MonadTrans (STT s) where @@ -127,7 +132,7 @@ {-# INLINE getNumElements #-} getNumElements arr = liftST (getNumElements arr) {-# INLINE newArray #-} - newArray bounds e = liftST (newArray bounds e) + newArray bnds e = liftST (newArray bnds e) {-# INLINE unsafeRead #-} unsafeRead arr i = liftST (unsafeRead arr i) {-# INLINE unsafeWrite #-} @@ -139,7 +144,7 @@ {-# INLINE getNumElements #-} getNumElements arr = liftST (getNumElements arr) {-# INLINE newArray #-} - newArray bounds e = liftST (newArray bounds e) + newArray bnds e = liftST (newArray bnds e) {-# INLINE unsafeRead #-} unsafeRead arr i = liftST (unsafeRead arr i) {-# INLINE unsafeWrite #-} @@ -151,7 +156,7 @@ {-# INLINE getNumElements #-} getNumElements arr = liftST (getNumElements arr) {-# INLINE newArray #-} - newArray bounds e = liftST (newArray bounds e) + newArray bnds e = liftST (newArray bnds e) {-# INLINE unsafeRead #-} unsafeRead arr i = liftST (unsafeRead arr i) {-# INLINE unsafeWrite #-} @@ -163,7 +168,7 @@ {-# INLINE getNumElements #-} getNumElements arr = liftST (getNumElements arr) {-# INLINE newArray #-} - newArray bounds e = liftST (newArray bounds e) + newArray bnds e = liftST (newArray bnds e) {-# INLINE unsafeRead #-} unsafeRead arr i = liftST (unsafeRead arr i) {-# INLINE unsafeWrite #-} @@ -175,7 +180,7 @@ {-# INLINE getNumElements #-} getNumElements arr = liftST (getNumElements arr) {-# INLINE newArray #-} - newArray bounds e = liftST (newArray bounds e) + newArray bnds e = liftST (newArray bnds e) {-# INLINE unsafeRead #-} unsafeRead arr i = liftST (unsafeRead arr i) {-# INLINE unsafeWrite #-} @@ -187,7 +192,7 @@ {-# INLINE getNumElements #-} getNumElements arr = liftST (getNumElements arr) {-# INLINE newArray #-} - newArray bounds e = liftST (newArray bounds e) + newArray bnds e = liftST (newArray bnds e) {-# INLINE unsafeRead #-} unsafeRead arr i = liftST (unsafeRead arr i) {-# INLINE unsafeWrite #-} @@ -199,7 +204,7 @@ {-# INLINE getNumElements #-} getNumElements arr = liftST (getNumElements arr) {-# INLINE newArray #-} - newArray bounds e = liftST (newArray bounds e) + newArray bnds e = liftST (newArray bnds e) {-# INLINE unsafeRead #-} unsafeRead arr i = liftST (unsafeRead arr i) {-# INLINE unsafeWrite #-} @@ -211,7 +216,7 @@ {-# INLINE getNumElements #-} getNumElements arr = liftST (getNumElements arr) {-# INLINE newArray #-} - newArray bounds e = liftST (newArray bounds e) + newArray bnds e = liftST (newArray bnds e) {-# INLINE unsafeRead #-} unsafeRead arr i = liftST (unsafeRead arr i) {-# INLINE unsafeWrite #-} @@ -223,7 +228,7 @@ {-# INLINE getNumElements #-} getNumElements arr = liftST (getNumElements arr) {-# INLINE newArray #-} - newArray bounds e = liftST (newArray bounds e) + newArray bnds e = liftST (newArray bnds e) {-# INLINE unsafeRead #-} unsafeRead arr i = liftST (unsafeRead arr i) {-# INLINE unsafeWrite #-} @@ -235,7 +240,7 @@ {-# INLINE getNumElements #-} getNumElements arr = liftST (getNumElements arr) {-# INLINE newArray #-} - newArray bounds e = liftST (newArray bounds e) + newArray bnds e = liftST (newArray bnds e) {-# INLINE unsafeRead #-} unsafeRead arr i = liftST (unsafeRead arr i) {-# INLINE unsafeWrite #-} @@ -247,7 +252,7 @@ {-# INLINE getNumElements #-} getNumElements arr = liftST (getNumElements arr) {-# INLINE newArray #-} - newArray bounds e = liftST (newArray bounds e) + newArray bnds e = liftST (newArray bnds e) {-# INLINE unsafeRead #-} unsafeRead arr i = liftST (unsafeRead arr i) {-# INLINE unsafeWrite #-} @@ -259,7 +264,7 @@ {-# INLINE getNumElements #-} getNumElements arr = liftST (getNumElements arr) {-# INLINE newArray #-} - newArray bounds e = liftST (newArray bounds e) + newArray bnds e = liftST (newArray bnds e) {-# INLINE unsafeRead #-} unsafeRead arr i = liftST (unsafeRead arr i) {-# INLINE unsafeWrite #-} @@ -271,7 +276,7 @@ {-# INLINE getNumElements #-} getNumElements arr = liftST (getNumElements arr) {-# INLINE newArray #-} - newArray bounds e = liftST (newArray bounds e) + newArray bnds e = liftST (newArray bnds e) {-# INLINE unsafeRead #-} unsafeRead arr i = liftST (unsafeRead arr i) {-# INLINE unsafeWrite #-} @@ -283,7 +288,7 @@ {-# INLINE getNumElements #-} getNumElements arr = liftST (getNumElements arr) {-# INLINE newArray #-} - newArray bounds e = liftST (newArray bounds e) + newArray bnds e = liftST (newArray bnds e) {-# INLINE unsafeRead #-} unsafeRead arr i = liftST (unsafeRead arr i) {-# INLINE unsafeWrite #-} @@ -295,7 +300,7 @@ {-# INLINE getNumElements #-} getNumElements arr = liftST (getNumElements arr) {-# INLINE newArray #-} - newArray bounds e = liftST (newArray bounds e) + newArray bnds e = liftST (newArray bnds e) {-# INLINE unsafeRead #-} unsafeRead arr i = liftST (unsafeRead arr i) {-# INLINE unsafeWrite #-} @@ -307,7 +312,7 @@ {-# INLINE getNumElements #-} getNumElements arr = liftST (getNumElements arr) {-# INLINE newArray #-} - newArray bounds e = liftST (newArray bounds e) + newArray bnds e = liftST (newArray bnds e) {-# INLINE unsafeRead #-} unsafeRead arr i = liftST (unsafeRead arr i) {-# INLINE unsafeWrite #-} @@ -319,7 +324,7 @@ {-# INLINE getNumElements #-} getNumElements arr = liftST (getNumElements arr) {-# INLINE newArray #-} - newArray bounds e = liftST (newArray bounds e) + newArray bnds e = liftST (newArray bnds e) {-# INLINE unsafeRead #-} unsafeRead arr i = liftST (unsafeRead arr i) {-# INLINE unsafeWrite #-} @@ -331,7 +336,7 @@ {-# INLINE getNumElements #-} getNumElements arr = liftST (getNumElements arr) {-# INLINE newArray #-} - newArray bounds e = liftST (newArray bounds e) + newArray bnds e = liftST (newArray bnds e) {-# INLINE unsafeRead #-} unsafeRead arr i = liftST (unsafeRead arr i) {-# INLINE unsafeWrite #-} diff --git a/STMonadTrans.cabal b/STMonadTrans.cabal --- a/STMonadTrans.cabal +++ b/STMonadTrans.cabal @@ -1,12 +1,13 @@ name: STMonadTrans -version: 0.4.3 -cabal-version: >= 1.8 +version: 0.4.4 +cabal-version: >= 1.10 license: BSD3 license-file: LICENSE author: Josef Svenningsson maintainer: josef.svenningsson@gmail.com category: Monads build-type: Simple +Tested-With: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2, GHC == 8.0.1 synopsis: A monad transformer version of the ST monad description: A monad transformer version of the ST monad @@ -29,19 +30,34 @@ description: Choose the new smaller, split-up base package. library + default-language: Haskell2010 + build-depends: base >= 4.6 + if flag(splitBase) build-depends: base >= 3, base < 5, mtl, array else build-depends: base < 3 + if impl(ghc < 8.0) + build-depends: fail + exposed-modules: Control.Monad.ST.Trans, Control.Monad.ST.Trans.Internal - extensions: CPP, MagicHash, UnboxedTuples, Rank2Types, FlexibleInstances, - MultiParamTypeClasses, UndecidableInstances + default-extensions: CPP, MagicHash, UnboxedTuples, Rank2Types, + FlexibleInstances, + MultiParamTypeClasses, UndecidableInstances -Test-Suite foo - type: detailed-0.9 - hs-source-dirs: test - test-module: Test - build-depends: STMonadTrans, base, mtl, array, Cabal + ghc-options: -Wall -fwarn-tabs + +test-suite test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base >= 4 && < 5 + , tasty >= 0.11.0.4 && < 1.3 + , tasty-quickcheck >= 0.8.4 && < 0.11 + , tasty-hunit >= 0.9.2 && < 0.11 + , transformers >= 0.4 && < 0.6 + , STMonadTrans diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,8 @@ +0.4.4 + + * Fix compilation for GHC 8.8.1. Thanks to Andrés Sicard-Ramírez. + * Fix some tests and their dependencies. Thanks to Kirill Zaborsky. + 0.4.3 * Fix compilation for GHC 7.6.3. Thanks to Andrés Sicard-Ramírez. diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,54 @@ +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Tasty.HUnit + +import GHC.STRef (STRef) +import GHC.Arr (Array, listArray, (//)) +import Control.Monad.ST.Trans +import Control.Monad.Trans.Class +import Control.Monad (guard) + +props :: TestTree +props = testGroup "Properties" [ + testProperty "runSTT respects return" $ + \x -> runSTT (return x) == Just (x :: Int), + testProperty "STT respects MonadTrans" $ + \m -> runSTT (lift m) == (m :: Maybe Int), + testProperty "newSTRef . readSTRef == id" $ + \x -> runSTT ((newSTRef x :: STT s Maybe (STRef s Int)) >>= readSTRef) == Just x, + testProperty "writeSTRef overwrite" $ + \x y -> runSTT (do ref <- newSTRef x + writeSTRef ref y + readSTRef ref) == Just (y :: Int), + testProperty "newSTArray makes correct Arrays" $ + \t e -> 0 <= t ==> + runSTT (newSTArray (0,t) e >>= freezeSTArray) == + Just (listArray (0,t) (repeat e) :: Array Int Int), + testProperty "writeSTArray overwrite" $ + \t e y -> 0 <= t ==> + runSTT (do arr <- newSTArray (0,t) e + mapM_ (\i -> writeSTArray arr i y) [0..t] + freezeSTArray arr) == + Just (listArray (0,t) (repeat y) :: Array Int Int), + testProperty "thawSTArray . freezeSTArray == id" $ + \l -> let a = listArray (0,length l - 1) l in + runSTT (thawSTArray a >>= freezeSTArray) == Just (a :: Array Int Int), + testProperty "writeSTArray . thawSTArray == update a" $ + \l i e -> let a = listArray (0, length l - 1) l in + 0 <= i && i < length l ==> + runSTT (do stArr <- thawSTArray a + writeSTArray stArr i e + freezeSTArray stArr) == + Just (a // [(i,e)] :: Array Int Int) ] + +unitTests :: TestTree +unitTests = testGroup "Unit Tests" [ + testCase "ST Ref" $ runSTT (do ref <- newSTRef 0 + curNum <- readSTRef ref + writeSTRef ref (curNum + 6) + nextNum <- readSTRef ref + lift (guard (nextNum == 6)) + return nextNum) @?= Just 6 ] + +main :: IO () +main = defaultMain (testGroup "All Tests" [props,unitTests]) diff --git a/test/Test.hs b/test/Test.hs deleted file mode 100644 --- a/test/Test.hs +++ /dev/null @@ -1,37 +0,0 @@ -module Test where - -import Control.Monad -import Control.Monad.Trans -import Control.Monad.ST.Trans - -import Data.Array - -import Distribution.TestSuite - -foo :: Int -> Maybe (Array Int Int) -foo i = runSTArray $ do - arr <- newSTArray (1, 3) 0 - lift $ guard $ i > 0 - writeSTArray arr 2 i - return arr - -ups :: (Maybe (Array Int Int, Array Int Int)) -ups = (,) <$> foo 5 <*> foo 6 - -main :: IO () -main = print ups - -tests :: IO [Test] -tests = return [Test bar] - where - bar = TestInstance - { run = return $ Finished runUps - , name = "array creation" - , tags = [] - , options = [] - , setOption = \_ _ -> Right bar - } - runUps = case ups of - Just (a1,a2) | elems a1 /= elems a2 -> Pass - | otherwise -> Fail "Only created one array." - _ -> Error "Got Nothing! Shouldn't happen."