diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.3.1 + +* Add terminal IO functions + ## 1.3.0 * Tracing functions leave warnings when used diff --git a/ClassyPrelude.hs b/ClassyPrelude.hs deleted file mode 100644 --- a/ClassyPrelude.hs +++ /dev/null @@ -1,648 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -module ClassyPrelude - ( -- * CorePrelude - module CorePrelude - , undefined - -- * Standard - -- ** Monoid - , (++) - -- ** Semigroup - , Semigroup (..) - , WrappedMonoid - -- ** Functor - , module Data.Functor - -- ** Applicative - , module Control.Applicative - , (<&&>) - , (<||>) - -- ** Monad - , module Control.Monad - , module Control.Monad.Trans.Unlift - , whenM - , unlessM - -- ** 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 - , module Control.Concurrent.STM.TBMChan - , module Control.Concurrent.STM.TBMQueue - , module Control.Concurrent.STM.TMChan - , module Control.Concurrent.STM.TMQueue - -- ** Primitive (exported since 0.9.4) - , primToPrim - , primToIO - , primToST - , module Data.Primitive.MutVar - -- ** Debugging - , trace - , traceShow - , traceId - , traceM - , traceShowId - , traceShowM - , assert - -- ** Time (since 0.6.1) - , module Data.Time - , defaultTimeLocale - -- ** Generics (since 0.8.1) - , Generic - -- ** Transformers (since 0.9.4) - , Identity (..) - , MonadReader - , ask - , asks - , ReaderT (..) - , Reader - -- * Poly hierarchy - , module Data.Foldable - , module Data.Traversable - -- ** Bifunctor (since 0.10.0) - , module Data.Bifunctor - -- * Mono hierarchy - , module Data.MonoTraversable - , module Data.MonoTraversable.Unprefixed - , module Data.Sequences - , module Data.Containers - , module Data.Builder - , module Data.NonNull - , 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 - -- ** List-like classes - , map - --, split - , readMay - , zip, zip3, zip4, zip5, zip6, zip7 - , unzip, unzip3, unzip4, unzip5, unzip6, unzip7 - , zipWith, zipWith3, zipWith4, zipWith5, zipWith6, zipWith7 - - , hashNub - , ordNub - , ordNubBy - - , sortWith - , Prelude.repeat - -- ** Set-like - , (\\) - , intersect - -- FIXME , mapSet - -- ** Text-like - , Show (..) - , tshow - , tlshow - -- *** Case conversion - , charToLower - , charToUpper - -- ** IO - , readFile - , readFileUtf8 - , writeFile - , writeFileUtf8 - , hGetContents - , hPut - , hGetChunk - , print - , hClose - -- ** Difference lists - , DList - , asDList - , applyDList - -- ** Exceptions - , module Control.Exception.Safe - , module Control.DeepSeq - -- ** Force types - -- | Helper functions for situations where type inferer gets confused. - , asByteString - , asLByteString - , asHashMap - , asHashSet - , asText - , asLText - , asList - , asMap - , asIntMap - , asMaybe - , asSet - , asIntSet - , asVector - , asUVector - , asSVector - , asString - ) where - -import qualified Prelude -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 Data.Vector.Instances () -import CorePrelude hiding - ( 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 -import Data.Sequences -import Data.MonoTraversable -import Data.MonoTraversable.Unprefixed -import Data.MonoTraversable.Instances () -import Data.Containers -import Data.Builder -import Data.NonNull -import qualified Data.ByteString -import Data.ByteString.Internal (ByteString (PS)) -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 (..)) -import Data.Time - ( UTCTime (..) - , Day (..) - , toGregorian - , fromGregorian - , formatTime - , parseTime -#if MIN_VERSION_time(1,5,0) - , parseTimeM -#endif - , getCurrentTime - ) -import Data.Time.Locale.Compat (defaultTimeLocale) - -import qualified Data.Set as Set -import qualified Data.Map as Map -import qualified Data.HashSet as HashSet - -import GHC.Generics (Generic) - -import Control.Monad.Primitive (primToPrim, primToIO, primToST) -import Data.Primitive.MutVar - -import Data.Functor.Identity (Identity (..)) -import Control.Monad.Reader (MonadReader, ask, asks, ReaderT (..), Reader) -import Data.Bifunctor -import Data.DList (DList) -import qualified Data.DList as DList -import Say -import Control.Concurrent.STM.TBChan -import Control.Concurrent.STM.TBMChan -import Control.Concurrent.STM.TBMQueue -import Control.Concurrent.STM.TMChan -import Control.Concurrent.STM.TMQueue - -#if MIN_VERSION_base(4,9,0) -import GHC.Stack (HasCallStack) -#endif - -tshow :: Show a => a -> Text -tshow = fromList . Prelude.show - -tlshow :: Show a => a -> LText -tlshow = fromList . Prelude.show - --- | Convert a character to lower case. --- --- Character-based case conversion is lossy in comparison to string-based 'Data.MonoTraversable.toLower'. --- For instance, İ will be converted to i, instead of i̇. -charToLower :: Char -> Char -charToLower = Char.toLower - --- | Convert a character to upper case. --- --- Character-based case conversion is lossy in comparison to string-based 'Data.MonoTraversable.toUpper'. --- For instance, ß won't be converted to SS. -charToUpper :: Char -> Char -charToUpper = Char.toUpper - -readMay :: (Element c ~ Char, MonoFoldable c, Read a) => c -> Maybe a -readMay a = -- FIXME replace with safe-failure stuff - case [x | (x, t) <- Prelude.reads (otoList a :: String), onull t] of - [x] -> Just x - _ -> Nothing - -map :: Functor f => (a -> b) -> f a -> f b -map = fmap - -infixr 5 ++ -(++) :: Monoid m => m -> m -> m -(++) = mappend -{-# INLINE (++) #-} - -infixl 9 \\{-This comment teaches CPP correct behaviour -} --- | An alias for 'difference'. -(\\) :: SetContainer a => a -> a -> a -(\\) = difference -{-# INLINE (\\) #-} - --- | An alias for 'intersection'. -intersect :: SetContainer a => a -> a -> a -intersect = intersection -{-# INLINE intersect #-} - -asByteString :: ByteString -> ByteString -asByteString = id - -asLByteString :: LByteString -> LByteString -asLByteString = id - -asHashMap :: HashMap k v -> HashMap k v -asHashMap = id - -asHashSet :: HashSet a -> HashSet a -asHashSet = id - -asText :: Text -> Text -asText = id - -asLText :: LText -> LText -asLText = id - -asList :: [a] -> [a] -asList = id - -asMap :: Map k v -> Map k v -asMap = id - -asIntMap :: IntMap v -> IntMap v -asIntMap = id - -asMaybe :: Maybe a -> Maybe a -asMaybe = id - -asSet :: Set a -> Set a -asSet = id - -asIntSet :: IntSet -> IntSet -asIntSet = id - -asVector :: Vector a -> Vector a -asVector = id - -asUVector :: UVector a -> UVector a -asUVector = id - -asSVector :: SVector a -> SVector a -asSVector = id - -asString :: [Char] -> [Char] -asString = id - -print :: (Show a, MonadIO m) => a -> m () -print = liftIO . Prelude.print - --- | Sort elements using the user supplied function to project something out of --- each element. --- Inspired by . -sortWith :: (Ord a, IsSequence c) => (Element c -> a) -> c -> c -sortWith f = sortBy $ comparing f - --- | We define our own 'undefined' which is marked as deprecated. This makes it --- useful to use during development, but lets you more easily get --- notifications if you accidentally ship partial code in production. --- --- The classy prelude recommendation for when you need to really have a partial --- function in production is to use 'error' with a very descriptive message so --- that, in case an exception is thrown, you get more information than --- @"Prelude".'Prelude.undefined'@. --- --- Since 0.5.5 -#if MIN_VERSION_base(4,9,0) -undefined :: HasCallStack => a -#else -undefined :: a -#endif -undefined = error "ClassyPrelude.undefined" -{-# DEPRECATED undefined "It is highly recommended that you either avoid partial functions or provide meaningful error messages" #-} - --- | We define our own 'trace' (and also its variants) which provides a warning --- when used. So that tracing is available during development, but the compiler --- reminds you to not leave them in the code for production. -{-# WARNING trace "Leaving traces in the code" #-} -trace :: String -> a -> a -trace = Trace.trace - -{-# WARNING traceShow "Leaving traces in the code" #-} -traceShow :: Show a => a -> b -> b -traceShow = Trace.traceShow - --- | --- --- Since 0.5.9 -{-# WARNING traceId "Leaving traces in the code" #-} -traceId :: String -> String -traceId a = Trace.trace a a - --- | --- --- Since 0.5.9 -{-# WARNING traceM "Leaving traces in the code" #-} -traceM :: (Monad m) => String -> m () -traceM string = Trace.trace string $ return () - --- | --- --- Since 0.5.9 -{-# WARNING traceShowId "Leaving traces in the code" #-} -traceShowId :: (Show a) => a -> a -traceShowId a = Trace.trace (show a) a - --- | --- --- Since 0.5.9 -{-# WARNING traceShowM "Leaving traces in the code" #-} -traceShowM :: (Show a, Monad m) => a -> m () -traceShowM = traceM . show - --- | Originally 'Conc.yield'. -yieldThread :: MonadBase IO m => m () -yieldThread = Conc.yield -{-# INLINE yieldThread #-} - --- Below is a lot of coding for classy-prelude! --- These functions are restricted to lists right now. --- Should eventually exist in mono-foldable and be extended to MonoFoldable --- when doing that should re-run the haskell-ordnub benchmarks - --- | same behavior as 'Data.List.nub', but requires 'Hashable' & 'Eq' and is @O(n log n)@ --- --- -hashNub :: (Hashable a, Eq a) => [a] -> [a] -hashNub = go HashSet.empty - where - go _ [] = [] - go s (x:xs) | x `HashSet.member` s = go s xs - | otherwise = x : go (HashSet.insert x s) xs - --- | same behavior as 'Data.List.nub', but requires 'Ord' and is @O(n log n)@ --- --- -ordNub :: (Ord a) => [a] -> [a] -ordNub = go Set.empty - where - go _ [] = [] - go s (x:xs) | x `Set.member` s = go s xs - | otherwise = x : go (Set.insert x s) xs - --- | same behavior as 'Data.List.nubBy', but requires 'Ord' and is @O(n log n)@ --- --- -ordNubBy :: (Ord b) => (a -> b) -> (a -> a -> Bool) -> [a] -> [a] -ordNubBy p f = go Map.empty - -- When removing duplicates, the first function assigns the input to a bucket, - -- the second function checks whether it is already in the bucket (linear search). - where - go _ [] = [] - go m (x:xs) = let b = p x in case b `Map.lookup` m of - Nothing -> x : go (Map.insert b [x] m) xs - Just bucket - | elem_by f x bucket -> go m xs - | otherwise -> x : go (Map.insert b (x:bucket) m) xs - - -- From the Data.List source code. - elem_by :: (a -> a -> Bool) -> a -> [a] -> Bool - 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 -{-# INLINE alwaysSTM #-} - --- | Synonym for 'STM.alwaysSucceeds'. -alwaysSucceedsSTM :: STM a -> STM () -alwaysSucceedsSTM = STM.alwaysSucceeds -{-# INLINE alwaysSucceedsSTM #-} - --- | Synonym for 'STM.orElse'. -orElseSTM :: STM a -> STM a -> STM a -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 -whenM :: Monad m => m Bool -> m () -> m () -whenM mbool action = mbool >>= flip when action - --- | Only perform the action if the predicate returns 'False'. --- --- Since 0.9.2 -unlessM :: Monad m => m Bool -> m () -> m () -unlessM mbool action = mbool >>= flip unless action - --- | Force type to a 'DList' --- --- Since 0.11.0 -asDList :: DList a -> DList a -asDList = id -{-# INLINE asDList #-} - --- | Synonym for 'DList.apply' --- --- Since 0.11.0 -applyDList :: DList a -> [a] -> [a] -applyDList = DList.apply -{-# INLINE applyDList #-} - -infixr 3 <&&> --- | '&&' lifted to an Applicative. --- --- @since 0.12.8 -(<&&>) :: Applicative a => a Bool -> a Bool -> a Bool -(<&&>) = liftA2 (&&) -{-# INLINE (<&&>) #-} - -infixr 2 <||> --- | '||' lifted to an Applicative. --- --- @since 0.12.8 -(<||>) :: Applicative a => a Bool -> a Bool -> a Bool -(<||>) = liftA2 (||) -{-# INLINE (<||>) #-} - --- | Convert a 'ByteString' into a storable 'Vector'. -toByteVector :: ByteString -> SVector Word8 -toByteVector (PS fptr offset idx) = unsafeFromForeignPtr fptr offset idx -{-# INLINE toByteVector #-} - --- | Convert a storable 'Vector' into a 'ByteString'. -fromByteVector :: SVector Word8 -> ByteString -fromByteVector v = - PS fptr offset idx - where - (fptr, offset, idx) = unsafeToForeignPtr v -{-# INLINE fromByteVector #-} - --- | 'waitSTM' for any 'MonadIO' --- --- @since 1.0.0 -waitAsync :: MonadIO m => Async a -> m a -waitAsync = atomically . waitSTM - --- | 'pollSTM' for any 'MonadIO' --- --- @since 1.0.0 -pollAsync :: MonadIO m => Async a -> m (Maybe (Either SomeException a)) -pollAsync = atomically . pollSTM - --- | 'waitCatchSTM' for any 'MonadIO' --- --- @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)) - --- | 'Async.link' generalized to any 'MonadIO' --- --- @since 1.0.0 -linkAsync :: MonadIO m => Async a -> m () -linkAsync = liftIO . Async.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 - --- | Strictly read a file into a 'ByteString'. --- --- @since 1.2.0 -readFile :: MonadIO m => FilePath -> m ByteString -readFile = liftIO . Data.ByteString.readFile - --- | Strictly read a file into a 'Text' using a UTF-8 character --- encoding. In the event of a character encoding error, a Unicode --- replacement character will be used (a.k.a., @lenientDecode@). --- --- @since 1.2.0 -readFileUtf8 :: MonadIO m => FilePath -> m Text -readFileUtf8 = liftM decodeUtf8 . readFile - --- | Write a 'ByteString' to a file. --- --- @since 1.2.0 -writeFile :: MonadIO m => FilePath -> ByteString -> m () -writeFile fp = liftIO . Data.ByteString.writeFile fp - --- | Write a 'Text' to a file using a UTF-8 character encoding. --- --- @since 1.2.0 -writeFileUtf8 :: MonadIO m => FilePath -> Text -> m () -writeFileUtf8 fp = writeFile fp . encodeUtf8 - --- | Strictly read the contents of the given 'Handle' into a --- 'ByteString'. --- --- @since 1.2.0 -hGetContents :: MonadIO m => Handle -> m ByteString -hGetContents = liftIO . Data.ByteString.hGetContents - --- | Write a 'ByteString' to the given 'Handle'. --- --- @since 1.2.0 -hPut :: MonadIO m => Handle -> ByteString -> m () -hPut h = liftIO . Data.ByteString.hPut h - --- | Read a single chunk of data as a 'ByteString' from the given --- 'Handle'. --- --- Under the surface, this uses 'Data.ByteString.hGetSome' with the --- default chunk size. --- --- @since 1.2.0 -hGetChunk :: MonadIO m => Handle -> m ByteString -hGetChunk = liftIO . flip Data.ByteString.hGetSome defaultChunkSize diff --git a/classy-prelude.cabal b/classy-prelude.cabal --- a/classy-prelude.cabal +++ b/classy-prelude.cabal @@ -1,68 +1,89 @@ -name: classy-prelude -version: 1.3.0 -synopsis: A typeclass-based Prelude. -description: Modern best practices without name collisions. No partial functions are exposed, but modern data structures are, without requiring import lists. Qualified modules also are not needed: instead operations are based on type-classes from the mono-traversable package. +-- This file has been generated from package.yaml by hpack version 0.20.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 98de3d7c601e86d63d31d5e7347e6a74797e4c0e239fe6225646f2e870ca8e33 -homepage: https://github.com/snoyberg/mono-traversable -license: MIT -license-file: LICENSE -author: Michael Snoyman -maintainer: michael@snoyman.com -category: Control, Prelude -build-type: Simple -cabal-version: >=1.8 -extra-source-files: README.md ChangeLog.md +name: classy-prelude +version: 1.3.1 +synopsis: A typeclass-based Prelude. +description: See docs and README at +category: Control, Prelude +homepage: https://github.com/snoyberg/mono-traversable#readme +bug-reports: https://github.com/snoyberg/mono-traversable/issues +author: Michael Snoyman +maintainer: michael@snoyman.com +license: MIT +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + ChangeLog.md + README.md + +source-repository head + type: git + location: https://github.com/snoyberg/mono-traversable + library - exposed-modules: ClassyPrelude - build-depends: base >= 4 && < 5 - , basic-prelude >= 0.4 && < 0.7 - , transformers - , containers >= 0.4.2 - , text - , bytestring - , vector - , unordered-containers - , hashable - , lifted-base >= 0.2 - , lifted-async >= 0.3 - , async - , mono-traversable >= 1.0 - , mono-traversable-instances - , exceptions >= 0.5 - , semigroups - , vector-instances - , time - , time-locale-compat - , chunked-data >= 0.3 - , ghc-prim - , stm - , primitive - , mtl - , bifunctors - , mutable-containers >= 0.3 && < 0.4 - , dlist >= 0.7 - , transformers-base - , safe-exceptions >= 0.1.1 - , deepseq - , monad-unlift >= 0.2 - , say - , stm-chans >= 3 - ghc-options: -Wall -fno-warn-orphans + hs-source-dirs: + src + ghc-options: -Wall -fno-warn-orphans + build-depends: + async + , base >=4 && <5 + , basic-prelude >=0.4 + , 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 + , transformers + , transformers-base + , unordered-containers + , vector + , vector-instances + exposed-modules: + ClassyPrelude + other-modules: + Paths_classy_prelude + default-language: Haskell2010 test-suite test - hs-source-dirs: test - main-is: main.hs - type: exitcode-stdio-1.0 - build-depends: classy-prelude - , base - , hspec >= 1.3 - , QuickCheck - , transformers - , containers - , unordered-containers - ghc-options: -Wall - -source-repository head - type: git - location: https://github.com/snoyberg/mono-traversable.git + type: exitcode-stdio-1.0 + main-is: main.hs + hs-source-dirs: + test + ghc-options: -Wall + build-depends: + QuickCheck + , base >=4 && <5 + , classy-prelude + , containers + , hspec >=1.3 + , transformers + , unordered-containers + other-modules: + Paths_classy_prelude + default-language: Haskell2010 diff --git a/src/ClassyPrelude.hs b/src/ClassyPrelude.hs new file mode 100644 --- /dev/null +++ b/src/ClassyPrelude.hs @@ -0,0 +1,716 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +module ClassyPrelude + ( -- * CorePrelude + module CorePrelude + , undefined + -- * Standard + -- ** Monoid + , (++) + -- ** Semigroup + , Semigroup (..) + , WrappedMonoid + -- ** Functor + , module Data.Functor + -- ** Applicative + , module Control.Applicative + , (<&&>) + , (<||>) + -- ** Monad + , module Control.Monad + , module Control.Monad.Trans.Unlift + , whenM + , unlessM + -- ** 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 + , module Control.Concurrent.STM.TBMChan + , module Control.Concurrent.STM.TBMQueue + , module Control.Concurrent.STM.TMChan + , module Control.Concurrent.STM.TMQueue + -- ** Primitive (exported since 0.9.4) + , primToPrim + , primToIO + , primToST + , module Data.Primitive.MutVar + -- ** Debugging + , trace + , traceShow + , traceId + , traceM + , traceShowId + , traceShowM + , assert + -- ** Time (since 0.6.1) + , module Data.Time + , defaultTimeLocale + -- ** Generics (since 0.8.1) + , Generic + -- ** Transformers (since 0.9.4) + , Identity (..) + , MonadReader + , ask + , asks + , ReaderT (..) + , Reader + -- * Poly hierarchy + , module Data.Foldable + , module Data.Traversable + -- ** Bifunctor (since 0.10.0) + , module Data.Bifunctor + -- * Mono hierarchy + , module Data.MonoTraversable + , module Data.MonoTraversable.Unprefixed + , module Data.Sequences + , module Data.Containers + , module Data.Builder + , module Data.NonNull + , 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 + -- ** List-like classes + , map + --, split + , readMay + , zip, zip3, zip4, zip5, zip6, zip7 + , unzip, unzip3, unzip4, unzip5, unzip6, unzip7 + , zipWith, zipWith3, zipWith4, zipWith5, zipWith6, zipWith7 + + , hashNub + , ordNub + , ordNubBy + + , sortWith + , Prelude.repeat + -- ** Set-like + , (\\) + , intersect + -- FIXME , mapSet + -- ** Text-like + , Show (..) + , tshow + , tlshow + -- *** Case conversion + , charToLower + , charToUpper + -- ** IO + , readFile + , readFileUtf8 + , writeFile + , writeFileUtf8 + , hGetContents + , hPut + , hGetChunk + , print + , hClose + -- Prelude IO operations + , putChar + , putStr + , putStrLn + , getChar + , getLine + , getContents + , interact + -- ** Difference lists + , DList + , asDList + , applyDList + -- ** Exceptions + , module Control.Exception.Safe + , module Control.DeepSeq + -- ** Force types + -- | Helper functions for situations where type inferer gets confused. + , asByteString + , asLByteString + , asHashMap + , asHashSet + , asText + , asLText + , asList + , asMap + , asIntMap + , asMaybe + , asSet + , asIntSet + , asVector + , asUVector + , asSVector + , asString + ) where + +import qualified Prelude +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 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 +import Data.Sequences +import Data.MonoTraversable +import Data.MonoTraversable.Unprefixed +import Data.MonoTraversable.Instances () +import Data.Containers +import Data.Builder +import Data.NonNull +import qualified Data.ByteString +import qualified Data.Text.IO as TextIO +import qualified Data.Text.Lazy.IO as LTextIO +import Data.ByteString.Internal (ByteString (PS)) +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 (..)) +import Data.Time + ( UTCTime (..) + , Day (..) + , toGregorian + , fromGregorian + , formatTime + , parseTime +#if MIN_VERSION_time(1,5,0) + , parseTimeM +#endif + , getCurrentTime + ) +import Data.Time.Locale.Compat (defaultTimeLocale) + +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.HashSet as HashSet + +import GHC.Generics (Generic) + +import Control.Monad.Primitive (primToPrim, primToIO, primToST) +import Data.Primitive.MutVar + +import Data.Functor.Identity (Identity (..)) +import Control.Monad.Reader (MonadReader, ask, asks, ReaderT (..), Reader) +import Data.Bifunctor +import Data.DList (DList) +import qualified Data.DList as DList +import Say +import Control.Concurrent.STM.TBChan +import Control.Concurrent.STM.TBMChan +import Control.Concurrent.STM.TBMQueue +import Control.Concurrent.STM.TMChan +import Control.Concurrent.STM.TMQueue + +#if MIN_VERSION_base(4,9,0) +import GHC.Stack (HasCallStack) +#endif + +tshow :: Show a => a -> Text +tshow = fromList . Prelude.show + +tlshow :: Show a => a -> LText +tlshow = fromList . Prelude.show + +-- | Convert a character to lower case. +-- +-- Character-based case conversion is lossy in comparison to string-based 'Data.MonoTraversable.toLower'. +-- For instance, İ will be converted to i, instead of i̇. +charToLower :: Char -> Char +charToLower = Char.toLower + +-- | Convert a character to upper case. +-- +-- Character-based case conversion is lossy in comparison to string-based 'Data.MonoTraversable.toUpper'. +-- For instance, ß won't be converted to SS. +charToUpper :: Char -> Char +charToUpper = Char.toUpper + +readMay :: (Element c ~ Char, MonoFoldable c, Read a) => c -> Maybe a +readMay a = -- FIXME replace with safe-failure stuff + case [x | (x, t) <- Prelude.reads (otoList a :: String), onull t] of + [x] -> Just x + _ -> Nothing + +map :: Functor f => (a -> b) -> f a -> f b +map = fmap + +infixr 5 ++ +(++) :: Monoid m => m -> m -> m +(++) = mappend +{-# INLINE (++) #-} + +infixl 9 \\{-This comment teaches CPP correct behaviour -} +-- | An alias for 'difference'. +(\\) :: SetContainer a => a -> a -> a +(\\) = difference +{-# INLINE (\\) #-} + +-- | An alias for 'intersection'. +intersect :: SetContainer a => a -> a -> a +intersect = intersection +{-# INLINE intersect #-} + +asByteString :: ByteString -> ByteString +asByteString = id + +asLByteString :: LByteString -> LByteString +asLByteString = id + +asHashMap :: HashMap k v -> HashMap k v +asHashMap = id + +asHashSet :: HashSet a -> HashSet a +asHashSet = id + +asText :: Text -> Text +asText = id + +asLText :: LText -> LText +asLText = id + +asList :: [a] -> [a] +asList = id + +asMap :: Map k v -> Map k v +asMap = id + +asIntMap :: IntMap v -> IntMap v +asIntMap = id + +asMaybe :: Maybe a -> Maybe a +asMaybe = id + +asSet :: Set a -> Set a +asSet = id + +asIntSet :: IntSet -> IntSet +asIntSet = id + +asVector :: Vector a -> Vector a +asVector = id + +asUVector :: UVector a -> UVector a +asUVector = id + +asSVector :: SVector a -> SVector a +asSVector = id + +asString :: [Char] -> [Char] +asString = id + +print :: (Show a, MonadIO m) => a -> m () +print = liftIO . Prelude.print + +-- | Sort elements using the user supplied function to project something out of +-- each element. +-- Inspired by . +sortWith :: (Ord a, IsSequence c) => (Element c -> a) -> c -> c +sortWith f = sortBy $ comparing f + +-- | We define our own 'undefined' which is marked as deprecated. This makes it +-- useful to use during development, but lets you more easily get +-- notifications if you accidentally ship partial code in production. +-- +-- The classy prelude recommendation for when you need to really have a partial +-- function in production is to use 'error' with a very descriptive message so +-- that, in case an exception is thrown, you get more information than +-- @"Prelude".'Prelude.undefined'@. +-- +-- Since 0.5.5 +#if MIN_VERSION_base(4,9,0) +undefined :: HasCallStack => a +#else +undefined :: a +#endif +undefined = error "ClassyPrelude.undefined" +{-# DEPRECATED undefined "It is highly recommended that you either avoid partial functions or provide meaningful error messages" #-} + +-- | We define our own 'trace' (and also its variants) which provides a warning +-- when used. So that tracing is available during development, but the compiler +-- reminds you to not leave them in the code for production. +{-# WARNING trace "Leaving traces in the code" #-} +trace :: String -> a -> a +trace = Trace.trace + +{-# WARNING traceShow "Leaving traces in the code" #-} +traceShow :: Show a => a -> b -> b +traceShow = Trace.traceShow + +-- | +-- +-- Since 0.5.9 +{-# WARNING traceId "Leaving traces in the code" #-} +traceId :: String -> String +traceId a = Trace.trace a a + +-- | +-- +-- Since 0.5.9 +{-# WARNING traceM "Leaving traces in the code" #-} +traceM :: (Monad m) => String -> m () +traceM string = Trace.trace string $ return () + +-- | +-- +-- Since 0.5.9 +{-# WARNING traceShowId "Leaving traces in the code" #-} +traceShowId :: (Show a) => a -> a +traceShowId a = Trace.trace (show a) a + +-- | +-- +-- Since 0.5.9 +{-# WARNING traceShowM "Leaving traces in the code" #-} +traceShowM :: (Show a, Monad m) => a -> m () +traceShowM = traceM . show + +-- | Originally 'Conc.yield'. +yieldThread :: MonadBase IO m => m () +yieldThread = Conc.yield +{-# INLINE yieldThread #-} + +-- Below is a lot of coding for classy-prelude! +-- These functions are restricted to lists right now. +-- Should eventually exist in mono-foldable and be extended to MonoFoldable +-- when doing that should re-run the haskell-ordnub benchmarks + +-- | same behavior as 'Data.List.nub', but requires 'Hashable' & 'Eq' and is @O(n log n)@ +-- +-- +hashNub :: (Hashable a, Eq a) => [a] -> [a] +hashNub = go HashSet.empty + where + go _ [] = [] + go s (x:xs) | x `HashSet.member` s = go s xs + | otherwise = x : go (HashSet.insert x s) xs + +-- | same behavior as 'Data.List.nub', but requires 'Ord' and is @O(n log n)@ +-- +-- +ordNub :: (Ord a) => [a] -> [a] +ordNub = go Set.empty + where + go _ [] = [] + go s (x:xs) | x `Set.member` s = go s xs + | otherwise = x : go (Set.insert x s) xs + +-- | same behavior as 'Data.List.nubBy', but requires 'Ord' and is @O(n log n)@ +-- +-- +ordNubBy :: (Ord b) => (a -> b) -> (a -> a -> Bool) -> [a] -> [a] +ordNubBy p f = go Map.empty + -- When removing duplicates, the first function assigns the input to a bucket, + -- the second function checks whether it is already in the bucket (linear search). + where + go _ [] = [] + go m (x:xs) = let b = p x in case b `Map.lookup` m of + Nothing -> x : go (Map.insert b [x] m) xs + Just bucket + | elem_by f x bucket -> go m xs + | otherwise -> x : go (Map.insert b (x:bucket) m) xs + + -- From the Data.List source code. + elem_by :: (a -> a -> Bool) -> a -> [a] -> Bool + 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 +{-# INLINE alwaysSTM #-} + +-- | Synonym for 'STM.alwaysSucceeds'. +alwaysSucceedsSTM :: STM a -> STM () +alwaysSucceedsSTM = STM.alwaysSucceeds +{-# INLINE alwaysSucceedsSTM #-} + +-- | Synonym for 'STM.orElse'. +orElseSTM :: STM a -> STM a -> STM a +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 +whenM :: Monad m => m Bool -> m () -> m () +whenM mbool action = mbool >>= flip when action + +-- | Only perform the action if the predicate returns 'False'. +-- +-- Since 0.9.2 +unlessM :: Monad m => m Bool -> m () -> m () +unlessM mbool action = mbool >>= flip unless action + +-- | Force type to a 'DList' +-- +-- Since 0.11.0 +asDList :: DList a -> DList a +asDList = id +{-# INLINE asDList #-} + +-- | Synonym for 'DList.apply' +-- +-- Since 0.11.0 +applyDList :: DList a -> [a] -> [a] +applyDList = DList.apply +{-# INLINE applyDList #-} + +infixr 3 <&&> +-- | '&&' lifted to an Applicative. +-- +-- @since 0.12.8 +(<&&>) :: Applicative a => a Bool -> a Bool -> a Bool +(<&&>) = liftA2 (&&) +{-# INLINE (<&&>) #-} + +infixr 2 <||> +-- | '||' lifted to an Applicative. +-- +-- @since 0.12.8 +(<||>) :: Applicative a => a Bool -> a Bool -> a Bool +(<||>) = liftA2 (||) +{-# INLINE (<||>) #-} + +-- | Convert a 'ByteString' into a storable 'Vector'. +toByteVector :: ByteString -> SVector Word8 +toByteVector (PS fptr offset idx) = unsafeFromForeignPtr fptr offset idx +{-# INLINE toByteVector #-} + +-- | Convert a storable 'Vector' into a 'ByteString'. +fromByteVector :: SVector Word8 -> ByteString +fromByteVector v = + PS fptr offset idx + where + (fptr, offset, idx) = unsafeToForeignPtr v +{-# INLINE fromByteVector #-} + +-- | 'waitSTM' for any 'MonadIO' +-- +-- @since 1.0.0 +waitAsync :: MonadIO m => Async a -> m a +waitAsync = atomically . waitSTM + +-- | 'pollSTM' for any 'MonadIO' +-- +-- @since 1.0.0 +pollAsync :: MonadIO m => Async a -> m (Maybe (Either SomeException a)) +pollAsync = atomically . pollSTM + +-- | 'waitCatchSTM' for any 'MonadIO' +-- +-- @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)) + +-- | 'Async.link' generalized to any 'MonadIO' +-- +-- @since 1.0.0 +linkAsync :: MonadIO m => Async a -> m () +linkAsync = liftIO . Async.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 + +-- | Strictly read a file into a 'ByteString'. +-- +-- @since 1.2.0 +readFile :: MonadIO m => FilePath -> m ByteString +readFile = liftIO . Data.ByteString.readFile + +-- | Strictly read a file into a 'Text' using a UTF-8 character +-- encoding. In the event of a character encoding error, a Unicode +-- replacement character will be used (a.k.a., @lenientDecode@). +-- +-- @since 1.2.0 +readFileUtf8 :: MonadIO m => FilePath -> m Text +readFileUtf8 = liftM decodeUtf8 . readFile + +-- | Write a 'ByteString' to a file. +-- +-- @since 1.2.0 +writeFile :: MonadIO m => FilePath -> ByteString -> m () +writeFile fp = liftIO . Data.ByteString.writeFile fp + +-- | Write a 'Text' to a file using a UTF-8 character encoding. +-- +-- @since 1.2.0 +writeFileUtf8 :: MonadIO m => FilePath -> Text -> m () +writeFileUtf8 fp = writeFile fp . encodeUtf8 + +-- | Strictly read the contents of the given 'Handle' into a +-- 'ByteString'. +-- +-- @since 1.2.0 +hGetContents :: MonadIO m => Handle -> m ByteString +hGetContents = liftIO . Data.ByteString.hGetContents + +-- | Write a 'ByteString' to the given 'Handle'. +-- +-- @since 1.2.0 +hPut :: MonadIO m => Handle -> ByteString -> m () +hPut h = liftIO . Data.ByteString.hPut h + +-- | Read a single chunk of data as a 'ByteString' from the given +-- 'Handle'. +-- +-- Under the surface, this uses 'Data.ByteString.hGetSome' with the +-- default chunk size. +-- +-- @since 1.2.0 +hGetChunk :: MonadIO m => Handle -> m ByteString +hGetChunk = liftIO . flip Data.ByteString.hGetSome defaultChunkSize + +-- | Write a character to stdout +-- +-- Uses system locale settings +-- +-- @since 1.3.1 +putChar :: MonadIO m => Char -> m () +putChar = liftIO . Prelude.putChar + +-- | Write a Text to stdout +-- +-- Uses system locale settings +-- +-- @since 1.3.1 +putStr :: MonadIO m => Text -> m () +putStr = liftIO . TextIO.putStr + +-- | Write a Text followed by a newline to stdout +-- +-- Uses system locale settings +-- +-- @since 1.3.1 +putStrLn :: MonadIO m => Text -> m () +putStrLn = liftIO . TextIO.putStrLn + +-- | Read a character from stdin +-- +-- Uses system locale settings +-- +-- @since 1.3.1 +getChar :: MonadIO m => m Char +getChar = liftIO Prelude.getChar + +-- | Read a line from stdin +-- +-- Uses system locale settings +-- +-- @since 1.3.1 +getLine :: MonadIO m => m Text +getLine = liftIO TextIO.getLine + +-- | Read all input from stdin into a lazy Text ('LText') +-- +-- Uses system locale settings +-- +-- @since 1.3.1 +getContents :: MonadIO m => m LText +getContents = liftIO LTextIO.getContents + +-- | Takes a function of type 'LText -> LText' and passes all input on stdin +-- to it, then prints result to stdout +-- +-- Uses lazy IO +-- Uses system locale settings +-- +-- @since 1.3.1 +interact :: MonadIO m => (LText -> LText) -> m () +interact = liftIO . LTextIO.interact