diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.0 + +* Switch to `MonadUnliftIO` + ## 1.3.1 * Add terminal IO functions diff --git a/classy-prelude.cabal b/classy-prelude.cabal --- a/classy-prelude.cabal +++ b/classy-prelude.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 98de3d7c601e86d63d31d5e7347e6a74797e4c0e239fe6225646f2e870ca8e33 +-- hash: 647ba4603b5d219a6d274f99659ecd7683c8279bf0090aac1a69da0927940ae9 name: classy-prelude -version: 1.3.1 +version: 1.4.0 synopsis: A typeclass-based Prelude. description: See docs and README at category: Control, Prelude @@ -32,35 +32,29 @@ ghc-options: -Wall -fno-warn-orphans build-depends: async - , base >=4 && <5 - , basic-prelude >=0.4 + , base >=4.9 && <5 + , basic-prelude >=0.7 , bifunctors , bytestring , chunked-data >=0.3 , containers >=0.4.2 , deepseq , dlist >=0.7 - , exceptions >=0.5 , ghc-prim , hashable - , lifted-async >=0.3 - , lifted-base >=0.2 - , monad-unlift >=0.2 , mono-traversable >=1.0 , mono-traversable-instances , mtl , mutable-containers >=0.3 && <0.4 , primitive - , safe-exceptions >=0.1.1 , say , semigroups , stm , stm-chans >=3 , text - , time - , time-locale-compat + , time >=1.5 , transformers - , transformers-base + , unliftio >=0.2.1.0 , unordered-containers , vector , vector-instances @@ -78,7 +72,7 @@ ghc-options: -Wall build-depends: QuickCheck - , base >=4 && <5 + , base >=4.9 && <5 , classy-prelude , containers , hspec >=1.3 diff --git a/src/ClassyPrelude.hs b/src/ClassyPrelude.hs --- a/src/ClassyPrelude.hs +++ b/src/ClassyPrelude.hs @@ -20,20 +20,14 @@ , (<||>) -- ** Monad , module Control.Monad - , module Control.Monad.Trans.Unlift , whenM , unlessM + -- ** UnliftIO reexports + , module UnliftIO -- ** Mutable references - , module Control.Concurrent.MVar.Lifted - , module Control.Concurrent.Chan.Lifted - , module Control.Concurrent.STM - , atomically , alwaysSTM , alwaysSucceedsSTM - , retrySTM , orElseSTM - , checkSTM - , module Data.IORef.Lifted , module Data.Mutable -- ** STM Channels , module Control.Concurrent.STM.TBChan @@ -53,10 +47,8 @@ , traceM , traceShowId , traceShowM - , assert -- ** Time (since 0.6.1) , module Data.Time - , defaultTimeLocale -- ** Generics (since 0.8.1) , Generic -- ** Transformers (since 0.9.4) @@ -81,21 +73,12 @@ , toByteVector , fromByteVector -- * I\/O - , Handle - , stdin - , stdout - , stderr , module Say -- * Concurrency - , module Control.Concurrent.Lifted , yieldThread - , module Control.Concurrent.Async - , module Control.Concurrent.Async.Lifted.Safe , waitAsync , pollAsync , waitCatchAsync - , cancel - , cancelWith , linkAsync , link2Async -- * Non-standard @@ -133,7 +116,6 @@ , hPut , hGetChunk , print - , hClose -- Prelude IO operations , putChar , putStr @@ -147,7 +129,6 @@ , asDList , applyDList -- ** Exceptions - , module Control.Exception.Safe , module Control.DeepSeq -- ** Force types -- | Helper functions for situations where type inferer gets confused. @@ -173,44 +154,18 @@ import Control.Applicative ((<**>),liftA,liftA2,liftA3,Alternative (..), optional) import Data.Functor import Control.Exception (assert) -import Control.Exception.Safe import Control.DeepSeq (deepseq, ($!!), force, NFData (..)) import Control.Monad (when, unless, void, liftM, ap, forever, join, replicateM_, guard, MonadPlus (..), (=<<), (>=>), (<=<), liftM2, liftM3, liftM4, liftM5) -import Control.Concurrent.Lifted hiding (yield, throwTo) -import qualified Control.Concurrent.Lifted as Conc (yield) -import Control.Concurrent.MVar.Lifted -import Control.Concurrent.Chan.Lifted -import Control.Concurrent.STM hiding (atomically, always, alwaysSucceeds, retry, orElse, check) import qualified Control.Concurrent.STM as STM -import Data.IORef.Lifted import Data.Mutable import Data.Traversable (Traversable (..), for, forM) import Data.Foldable (Foldable) -import Control.Monad.Base -import Control.Monad.Trans.Unlift -import qualified Control.Concurrent.Async as Async -import Control.Concurrent.Async - ( Async - , waitSTM, pollSTM, waitCatchSTM - ) -import Control.Concurrent.Async.Lifted.Safe - ( Pure, Forall - , async, asyncBound, asyncOn, asyncWithUnmask, asyncOnWithUnmask - , withAsync, withAsyncBound, withAsyncOn, withAsyncWithUnmask, withAsyncOnWithUnmask - , asyncThreadId - , race, race_, concurrently, mapConcurrently, Concurrently (..) - ) +import UnliftIO import Data.Vector.Instances () import CorePrelude hiding ( putStr, putStrLn, print, undefined, (<>), catMaybes, first, second - , try, throwIO, onException, mask, mask_ - , handle, finally, catch, bracket, bracket_, bracketOnError , catchIOError - , uninterruptibleMask, uninterruptibleMask_ -#if MIN_VERSION_safe_exceptions(0,1,4) - , catchJust, handleJust, tryJust -#endif ) import Data.ChunkedZip import qualified Data.Char as Char @@ -228,8 +183,6 @@ import Data.ByteString.Lazy.Internal (defaultChunkSize) import Data.Vector.Storable (unsafeToForeignPtr, unsafeFromForeignPtr) -import System.IO (Handle, stdin, stdout, stderr, hClose) - import qualified Debug.Trace as Trace import Data.Semigroup (Semigroup (..), WrappedMonoid (..)) import Prelude (Show (..)) @@ -240,12 +193,10 @@ , fromGregorian , formatTime , parseTime -#if MIN_VERSION_time(1,5,0) , parseTimeM -#endif , getCurrentTime + , defaultTimeLocale ) -import Data.Time.Locale.Compat (defaultTimeLocale) import qualified Data.Set as Set import qualified Data.Map as Map @@ -267,6 +218,7 @@ import Control.Concurrent.STM.TBMQueue import Control.Concurrent.STM.TMChan import Control.Concurrent.STM.TMQueue +import qualified Control.Concurrent #if MIN_VERSION_base(4,9,0) import GHC.Stack (HasCallStack) @@ -432,8 +384,8 @@ traceShowM = traceM . show -- | Originally 'Conc.yield'. -yieldThread :: MonadBase IO m => m () -yieldThread = Conc.yield +yieldThread :: MonadIO m => m () +yieldThread = liftIO Control.Concurrent.yield {-# INLINE yieldThread #-} -- Below is a lot of coding for classy-prelude! @@ -481,15 +433,6 @@ elem_by _ _ [] = False elem_by eq y (x:xs) = y `eq` x || elem_by eq y xs --- | Generalized version of 'STM.atomically'. -atomically :: MonadIO m => STM a -> m a -atomically = liftIO . STM.atomically - --- | Synonym for 'STM.retry'. -retrySTM :: STM a -retrySTM = STM.retry -{-# INLINE retrySTM #-} - -- | Synonym for 'STM.always'. alwaysSTM :: STM Bool -> STM () alwaysSTM = STM.always @@ -505,11 +448,6 @@ orElseSTM = STM.orElse {-# INLINE orElseSTM #-} --- | Synonym for 'STM.check'. -checkSTM :: Bool -> STM () -checkSTM = STM.check -{-# INLINE checkSTM #-} - -- | Only perform the action if the predicate returns 'True'. -- -- Since 0.9.2 @@ -581,32 +519,19 @@ -- -- @since 1.0.0 waitCatchAsync :: MonadIO m => Async a -> m (Either SomeException a) -waitCatchAsync = atomically . waitCatchSTM - --- | 'Async.cancel' generalized to any 'MonadIO' --- --- @since 1.0.0 -cancel :: MonadIO m => Async a -> m () -cancel = liftIO . Async.cancel - --- | 'cancel' an 'Async' with the given exception. It is converted to --- an async exception via 'toAsyncException' first. --- --- @since 1.0.0 -cancelWith :: (MonadIO m, Exception e) => Async a -> e -> m () -cancelWith a e = liftIO (Async.cancelWith a (toAsyncException e)) +waitCatchAsync = waitCatch -- | 'Async.link' generalized to any 'MonadIO' -- -- @since 1.0.0 linkAsync :: MonadIO m => Async a -> m () -linkAsync = liftIO . Async.link +linkAsync = UnliftIO.link -- | 'Async.link2' generalized to any 'MonadIO' -- -- @since 1.0.0 link2Async :: MonadIO m => Async a -> Async b -> m () -link2Async a = liftIO . Async.link2 a +link2Async a = UnliftIO.link2 a -- | Strictly read a file into a 'ByteString'. -- diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -13,8 +13,6 @@ import Test.QuickCheck.Arbitrary import Prelude (undefined) import Control.Monad.Trans.Writer (tell, Writer, runWriter) -import Control.Concurrent (forkIO) -import Control.Exception (throw) import qualified Data.Set as Set import qualified Data.HashSet as HashSet @@ -187,19 +185,25 @@ prop "fromChunks . return . concat . toChunks == id" $ \a -> fromChunks [concat $ toChunks (a `asTypeOf` dummy)] == a -stripSuffixProps :: ( Eq c - , Show c - , Arbitrary c - , IsSequence c - , Eq (Element c) - ) - => c - -> Spec -stripSuffixProps dummy = do +suffixProps :: ( Eq c + , Show c + , Arbitrary c + , IsSequence c + , Eq (Element c) + ) + => c + -> Spec +suffixProps dummy = do + prop "y `isSuffixOf` (x ++ y)" $ \x y -> + (y `asTypeOf` dummy) `isSuffixOf` (x ++ y) prop "stripSuffix y (x ++ y) == Just x" $ \x y -> stripSuffix y (x ++ y) == Just (x `asTypeOf` dummy) prop "isJust (stripSuffix x y) == isSuffixOf x y" $ \x y -> isJust (stripSuffix x y) == isSuffixOf x (y `asTypeOf` dummy) + prop "dropSuffix y (x ++ y) == x" $ \x y -> + dropSuffix y (x ++ y) == (x `asTypeOf` dummy) + prop "dropSuffix x y == y || x `isSuffixOf` y" $ \x y -> + dropSuffix x y == y || x `isSuffixOf` (y `asTypeOf` dummy) replicateMProps :: ( Eq a , Show (Index a) @@ -252,6 +256,10 @@ stripPrefix x (x ++ y) == Just (y `asTypeOf` dummy) prop "stripPrefix x y == Nothing || x `isPrefixOf` y" $ \x y -> stripPrefix x y == Nothing || x `isPrefixOf` (y `asTypeOf` dummy) + prop "dropPrefix x (x ++ y) == y" $ \x y -> + dropPrefix x (x ++ y) == (y `asTypeOf` dummy) + prop "dropPrefix x y == y || x `isPrefixOf` y" $ \x y -> + dropPrefix x y == y || x `isPrefixOf` (y `asTypeOf` dummy) main :: IO () main = hspec $ do @@ -347,12 +355,15 @@ describe "chunks" $ do describe "ByteString" $ chunkProps (asLByteString undefined) describe "Text" $ chunkProps (asLText undefined) - describe "stripSuffix" $ do - describe "Text" $ stripSuffixProps (undefined :: Text) - describe "LText" $ stripSuffixProps (undefined :: LText) - describe "ByteString" $ stripSuffixProps (undefined :: ByteString) - describe "LByteString" $ stripSuffixProps (undefined :: LByteString) - describe "Seq" $ stripSuffixProps (undefined :: Seq Int) + describe "Suffix" $ do + describe "list" $ suffixProps (undefined :: [Int]) + describe "Text" $ suffixProps (undefined :: Text) + describe "LText" $ suffixProps (undefined :: LText) + describe "ByteString" $ suffixProps (undefined :: ByteString) + describe "LByteString" $ suffixProps (undefined :: LByteString) + describe "Vector" $ suffixProps (undefined :: Vector Int) + describe "UVector" $ suffixProps (undefined :: UVector Int) + describe "Seq" $ suffixProps (undefined :: Seq Int) describe "replicateM" $ do describe "list" $ replicateMProps (undefined :: [Int]) describe "Vector" $ replicateMProps (undefined :: Vector Int)