diff options
Diffstat (limited to 'third_party/bazel/rules_haskell/examples')
124 files changed, 0 insertions, 33312 deletions
diff --git a/third_party/bazel/rules_haskell/examples/.bazelrc b/third_party/bazel/rules_haskell/examples/.bazelrc deleted file mode 120000 index adb61980d232..000000000000 --- a/third_party/bazel/rules_haskell/examples/.bazelrc +++ /dev/null @@ -1 +0,0 @@ -../.bazelrc \ No newline at end of file diff --git a/third_party/bazel/rules_haskell/examples/.gitignore b/third_party/bazel/rules_haskell/examples/.gitignore deleted file mode 100644 index a6ef824c1f83..000000000000 --- a/third_party/bazel/rules_haskell/examples/.gitignore +++ /dev/null @@ -1 +0,0 @@ -/bazel-* diff --git a/third_party/bazel/rules_haskell/examples/BUILD.bazel b/third_party/bazel/rules_haskell/examples/BUILD.bazel deleted file mode 100644 index ff7445a2f7c3..000000000000 --- a/third_party/bazel/rules_haskell/examples/BUILD.bazel +++ /dev/null @@ -1,10 +0,0 @@ -load( - "@io_tweag_rules_haskell//haskell:haskell.bzl", - "haskell_toolchain", -) - -haskell_toolchain( - name = "ghc", - tools = ["@ghc//:bin"], - version = "8.6.4", -) diff --git a/third_party/bazel/rules_haskell/examples/README.md b/third_party/bazel/rules_haskell/examples/README.md deleted file mode 100644 index 7b477f547619..000000000000 --- a/third_party/bazel/rules_haskell/examples/README.md +++ /dev/null @@ -1,45 +0,0 @@ -# rule_haskell examples - -Examples of using [rules_haskell][rules_haskell], the Bazel rule set -for building Haskell code. - -* [**vector:**](./vector/) shows how to build the `vector` package as - found on Hackage, using a Nix provided compiler toolchain. -* [**rts:**](./rts/) demonstrates foreign exports and shows how to - link against GHC's RTS library, i.e. `libHSrts.so`. - -## **Important** - -Run all commands from the root of `rules_haskell`. -If you `cd examples/`, bazel *will* [break on -you](https://github.com/tweag/rules_haskell/issues/740). -This is a current problem with bazel workspaces. - -## Root Workspace - -Build everything in the root workspace with; - -``` -$ bazel build @io_tweag_rules_haskell_examples//... -``` - -Show every target of the vector example; - -``` -$ bazel query @io_tweag_rules_haskell_examples//vector/... -@io_tweag_rules_haskell_examples//vector:vector -@io_tweag_rules_haskell_examples//vector:semigroups -@io_tweag_rules_haskell_examples//vector:primitive -@io_tweag_rules_haskell_examples//vector:ghc-prim -@io_tweag_rules_haskell_examples//vector:deepseq -@io_tweag_rules_haskell_examples//vector:base -``` - -Build the two main Haskell targets; - -``` -$ bazel build @io_tweag_rules_haskell_examples//vector -$ bazel build @io_tweag_rules_haskell_examples//rts:add-one-hs -``` - -[rules_haskell]: https://github.com/tweag/rules_haskell diff --git a/third_party/bazel/rules_haskell/examples/WORKSPACE b/third_party/bazel/rules_haskell/examples/WORKSPACE deleted file mode 100644 index 1e99f221190a..000000000000 --- a/third_party/bazel/rules_haskell/examples/WORKSPACE +++ /dev/null @@ -1,58 +0,0 @@ -workspace(name = "io_tweag_rules_haskell_examples") - -local_repository( - name = "io_tweag_rules_haskell", - path = "..", -) - -load("@bazel_tools//tools/build_defs/repo:http.bzl", "http_archive") -load("@io_tweag_rules_haskell//haskell:repositories.bzl", "haskell_repositories") - -haskell_repositories() - -rules_nixpkgs_version = "0.5.2" - -http_archive( - name = "io_tweag_rules_nixpkgs", - sha256 = "5a384daa57b49abf9f0b672852f1a66a3c52aecf9d4d2ac64f6de0fd307690c8", - strip_prefix = "rules_nixpkgs-%s" % rules_nixpkgs_version, - urls = ["https://github.com/tweag/rules_nixpkgs/archive/v%s.tar.gz" % rules_nixpkgs_version], -) - -load( - "@io_tweag_rules_nixpkgs//nixpkgs:nixpkgs.bzl", - "nixpkgs_cc_configure", - "nixpkgs_package", -) - -# For the rts example. -nixpkgs_package( - name = "ghc", - attribute_path = "haskellPackages.ghc", - build_file = "@io_tweag_rules_haskell//haskell:ghc.BUILD", - repository = "@io_tweag_rules_haskell//nixpkgs:default.nix", -) - -nixpkgs_cc_configure( - nix_file = "@io_tweag_rules_haskell//nixpkgs:cc-toolchain.nix", - repository = "@io_tweag_rules_haskell//nixpkgs:default.nix", -) - -load( - "@io_tweag_rules_haskell//haskell:nixpkgs.bzl", - "haskell_register_ghc_nixpkgs", -) - -haskell_register_ghc_nixpkgs( - repositories = { - "nixpkgs": "@io_tweag_rules_haskell//nixpkgs:default.nix", - }, - version = "8.6.4", -) - -load( - "@io_tweag_rules_haskell//haskell:haskell.bzl", - "haskell_register_ghc_bindists", -) - -haskell_register_ghc_bindists(version = "8.6.4") diff --git a/third_party/bazel/rules_haskell/examples/primitive/BUILD.bazel b/third_party/bazel/rules_haskell/examples/primitive/BUILD.bazel deleted file mode 100644 index 798e55f29be7..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/BUILD.bazel +++ /dev/null @@ -1,33 +0,0 @@ -load( - "@io_tweag_rules_haskell//haskell:haskell.bzl", - "haskell_cc_import", - "haskell_library", - "haskell_toolchain_library", -) - -haskell_toolchain_library(name = "base") - -haskell_toolchain_library(name = "ghc-prim") - -cc_library( - name = "memops", - srcs = ["cbits/primitive-memops.c"], - hdrs = ["cbits/primitive-memops.h"], - deps = ["@ghc//:threaded-rts"], -) - -haskell_library( - name = "primitive", - srcs = glob([ - "Data/**/*.hs", - "Control/**/*.hs", - ]), - version = "0", - visibility = ["//visibility:public"], - deps = [ - ":base", - ":ghc-prim", - ":memops", - "//transformers", - ], -) diff --git a/third_party/bazel/rules_haskell/examples/primitive/Control/Monad/Primitive.hs b/third_party/bazel/rules_haskell/examples/primitive/Control/Monad/Primitive.hs deleted file mode 100644 index f182c18b086b..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Control/Monad/Primitive.hs +++ /dev/null @@ -1,298 +0,0 @@ -{-# LANGUAGE CPP, MagicHash, UnboxedTuples, TypeFamilies #-} -{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-deprecations #-} - --- | --- Module : Control.Monad.Primitive --- Copyright : (c) Roman Leshchinskiy 2009 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Portability : non-portable --- --- Primitive state-transformer monads --- - -module Control.Monad.Primitive ( - PrimMonad(..), RealWorld, primitive_, - PrimBase(..), - liftPrim, primToPrim, primToIO, primToST, ioToPrim, stToPrim, - unsafePrimToPrim, unsafePrimToIO, unsafePrimToST, unsafeIOToPrim, - unsafeSTToPrim, unsafeInlinePrim, unsafeInlineIO, unsafeInlineST, - touch, evalPrim -) where - -import GHC.Prim ( State#, RealWorld, touch# ) -import GHC.Base ( unsafeCoerce#, realWorld# ) -#if MIN_VERSION_base(4,4,0) -import GHC.Base ( seq# ) -#else -import Control.Exception (evaluate) -#endif -#if MIN_VERSION_base(4,2,0) -import GHC.IO ( IO(..) ) -#else -import GHC.IOBase ( IO(..) ) -#endif -import GHC.ST ( ST(..) ) - -import Control.Monad.Trans.Class (lift) -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid (Monoid) -#endif - -import Control.Monad.Trans.Cont ( ContT ) -import Control.Monad.Trans.Identity ( IdentityT (IdentityT) ) -import Control.Monad.Trans.List ( ListT ) -import Control.Monad.Trans.Maybe ( MaybeT ) -import Control.Monad.Trans.Error ( ErrorT, Error) -import Control.Monad.Trans.Reader ( ReaderT ) -import Control.Monad.Trans.State ( StateT ) -import Control.Monad.Trans.Writer ( WriterT ) -import Control.Monad.Trans.RWS ( RWST ) - -#if MIN_VERSION_transformers(0,4,0) -import Control.Monad.Trans.Except ( ExceptT ) -#endif - -#if MIN_VERSION_transformers(0,5,3) -import Control.Monad.Trans.Accum ( AccumT ) -import Control.Monad.Trans.Select ( SelectT ) -#endif - -import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST ) -import qualified Control.Monad.Trans.State.Strict as Strict ( StateT ) -import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT ) - --- | Class of monads which can perform primitive state-transformer actions -class Monad m => PrimMonad m where - -- | State token type - type PrimState m - - -- | Execute a primitive operation - primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a - --- | Class of primitive monads for state-transformer actions. --- --- Unlike 'PrimMonad', this typeclass requires that the @Monad@ be fully --- expressed as a state transformer, therefore disallowing other monad --- transformers on top of the base @IO@ or @ST@. --- --- @since 0.6.0.0 -class PrimMonad m => PrimBase m where - -- | Expose the internal structure of the monad - internal :: m a -> State# (PrimState m) -> (# State# (PrimState m), a #) - --- | Execute a primitive operation with no result -primitive_ :: PrimMonad m - => (State# (PrimState m) -> State# (PrimState m)) -> m () -{-# INLINE primitive_ #-} -primitive_ f = primitive (\s# -> - case f s# of - s'# -> (# s'#, () #)) - -instance PrimMonad IO where - type PrimState IO = RealWorld - primitive = IO - {-# INLINE primitive #-} -instance PrimBase IO where - internal (IO p) = p - {-# INLINE internal #-} - --- | @since 0.6.3.0 -instance PrimMonad m => PrimMonad (ContT r m) where - type PrimState (ContT r m) = PrimState m - primitive = lift . primitive - {-# INLINE primitive #-} - -instance PrimMonad m => PrimMonad (IdentityT m) where - type PrimState (IdentityT m) = PrimState m - primitive = lift . primitive - {-# INLINE primitive #-} - --- | @since 0.6.2.0 -instance PrimBase m => PrimBase (IdentityT m) where - internal (IdentityT m) = internal m - {-# INLINE internal #-} - -instance PrimMonad m => PrimMonad (ListT m) where - type PrimState (ListT m) = PrimState m - primitive = lift . primitive - {-# INLINE primitive #-} - -instance PrimMonad m => PrimMonad (MaybeT m) where - type PrimState (MaybeT m) = PrimState m - primitive = lift . primitive - {-# INLINE primitive #-} - -instance (Error e, PrimMonad m) => PrimMonad (ErrorT e m) where - type PrimState (ErrorT e m) = PrimState m - primitive = lift . primitive - {-# INLINE primitive #-} - -instance PrimMonad m => PrimMonad (ReaderT r m) where - type PrimState (ReaderT r m) = PrimState m - primitive = lift . primitive - {-# INLINE primitive #-} - -instance PrimMonad m => PrimMonad (StateT s m) where - type PrimState (StateT s m) = PrimState m - primitive = lift . primitive - {-# INLINE primitive #-} - -instance (Monoid w, PrimMonad m) => PrimMonad (WriterT w m) where - type PrimState (WriterT w m) = PrimState m - primitive = lift . primitive - {-# INLINE primitive #-} - -instance (Monoid w, PrimMonad m) => PrimMonad (RWST r w s m) where - type PrimState (RWST r w s m) = PrimState m - primitive = lift . primitive - {-# INLINE primitive #-} - -#if MIN_VERSION_transformers(0,4,0) -instance PrimMonad m => PrimMonad (ExceptT e m) where - type PrimState (ExceptT e m) = PrimState m - primitive = lift . primitive - {-# INLINE primitive #-} -#endif - -#if MIN_VERSION_transformers(0,5,3) --- | @since 0.6.3.0 -instance ( Monoid w - , PrimMonad m -# if !(MIN_VERSION_base(4,8,0)) - , Functor m -# endif - ) => PrimMonad (AccumT w m) where - type PrimState (AccumT w m) = PrimState m - primitive = lift . primitive - {-# INLINE primitive #-} -instance PrimMonad m => PrimMonad (SelectT r m) where - type PrimState (SelectT r m) = PrimState m - primitive = lift . primitive - {-# INLINE primitive #-} -#endif - -instance PrimMonad m => PrimMonad (Strict.StateT s m) where - type PrimState (Strict.StateT s m) = PrimState m - primitive = lift . primitive - {-# INLINE primitive #-} - -instance (Monoid w, PrimMonad m) => PrimMonad (Strict.WriterT w m) where - type PrimState (Strict.WriterT w m) = PrimState m - primitive = lift . primitive - {-# INLINE primitive #-} - -instance (Monoid w, PrimMonad m) => PrimMonad (Strict.RWST r w s m) where - type PrimState (Strict.RWST r w s m) = PrimState m - primitive = lift . primitive - {-# INLINE primitive #-} - -instance PrimMonad (ST s) where - type PrimState (ST s) = s - primitive = ST - {-# INLINE primitive #-} -instance PrimBase (ST s) where - internal (ST p) = p - {-# INLINE internal #-} - --- | Lifts a 'PrimBase' into another 'PrimMonad' with the same underlying state --- token type. -liftPrim - :: (PrimBase m1, PrimMonad m2, PrimState m1 ~ PrimState m2) => m1 a -> m2 a -{-# INLINE liftPrim #-} -liftPrim = primToPrim - --- | Convert a 'PrimBase' to another monad with the same state token. -primToPrim :: (PrimBase m1, PrimMonad m2, PrimState m1 ~ PrimState m2) - => m1 a -> m2 a -{-# INLINE primToPrim #-} -primToPrim m = primitive (internal m) - --- | Convert a 'PrimBase' with a 'RealWorld' state token to 'IO' -primToIO :: (PrimBase m, PrimState m ~ RealWorld) => m a -> IO a -{-# INLINE primToIO #-} -primToIO = primToPrim - --- | Convert a 'PrimBase' to 'ST' -primToST :: PrimBase m => m a -> ST (PrimState m) a -{-# INLINE primToST #-} -primToST = primToPrim - --- | Convert an 'IO' action to a 'PrimMonad'. --- --- @since 0.6.2.0 -ioToPrim :: (PrimMonad m, PrimState m ~ RealWorld) => IO a -> m a -{-# INLINE ioToPrim #-} -ioToPrim = primToPrim - --- | Convert an 'ST' action to a 'PrimMonad'. --- --- @since 0.6.2.0 -stToPrim :: PrimMonad m => ST (PrimState m) a -> m a -{-# INLINE stToPrim #-} -stToPrim = primToPrim - --- | Convert a 'PrimBase' to another monad with a possibly different state --- token. This operation is highly unsafe! -unsafePrimToPrim :: (PrimBase m1, PrimMonad m2) => m1 a -> m2 a -{-# INLINE unsafePrimToPrim #-} -unsafePrimToPrim m = primitive (unsafeCoerce# (internal m)) - --- | Convert any 'PrimBase' to 'ST' with an arbitrary state token. This --- operation is highly unsafe! -unsafePrimToST :: PrimBase m => m a -> ST s a -{-# INLINE unsafePrimToST #-} -unsafePrimToST = unsafePrimToPrim - --- | Convert any 'PrimBase' to 'IO'. This operation is highly unsafe! -unsafePrimToIO :: PrimBase m => m a -> IO a -{-# INLINE unsafePrimToIO #-} -unsafePrimToIO = unsafePrimToPrim - --- | Convert an 'ST' action with an arbitraty state token to any 'PrimMonad'. --- This operation is highly unsafe! --- --- @since 0.6.2.0 -unsafeSTToPrim :: PrimMonad m => ST s a -> m a -{-# INLINE unsafeSTToPrim #-} -unsafeSTToPrim = unsafePrimToPrim - --- | Convert an 'IO' action to any 'PrimMonad'. This operation is highly --- unsafe! --- --- @since 0.6.2.0 -unsafeIOToPrim :: PrimMonad m => IO a -> m a -{-# INLINE unsafeIOToPrim #-} -unsafeIOToPrim = unsafePrimToPrim - -unsafeInlinePrim :: PrimBase m => m a -> a -{-# INLINE unsafeInlinePrim #-} -unsafeInlinePrim m = unsafeInlineIO (unsafePrimToIO m) - -unsafeInlineIO :: IO a -> a -{-# INLINE unsafeInlineIO #-} -unsafeInlineIO m = case internal m realWorld# of (# _, r #) -> r - -unsafeInlineST :: ST s a -> a -{-# INLINE unsafeInlineST #-} -unsafeInlineST = unsafeInlinePrim - -touch :: PrimMonad m => a -> m () -{-# INLINE touch #-} -touch x = unsafePrimToPrim - $ (primitive (\s -> case touch# x s of { s' -> (# s', () #) }) :: IO ()) - --- | Create an action to force a value; generalizes 'Control.Exception.evaluate' --- --- @since 0.6.2.0 -evalPrim :: forall a m . PrimMonad m => a -> m a -#if MIN_VERSION_base(4,4,0) -evalPrim a = primitive (\s -> seq# a s) -#else --- This may or may not work so well, but there's probably nothing better to do. -{-# NOINLINE evalPrim #-} -evalPrim a = unsafePrimToPrim (evaluate a :: IO a) -#endif diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive.hs deleted file mode 100644 index db545ed81514..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE MagicHash #-} -{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} --- | --- Module : Data.Primitive --- Copyright : (c) Roman Leshchinskiy 2009-2012 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Portability : non-portable --- --- Reexports all primitive operations --- -module Data.Primitive ( - -- * Re-exports - module Data.Primitive.Types - ,module Data.Primitive.Array - ,module Data.Primitive.ByteArray - ,module Data.Primitive.Addr - ,module Data.Primitive.SmallArray - ,module Data.Primitive.UnliftedArray - ,module Data.Primitive.PrimArray - ,module Data.Primitive.MutVar - -- * Naming Conventions - -- $namingConventions -) where - -import Data.Primitive.Types -import Data.Primitive.Array -import Data.Primitive.ByteArray -import Data.Primitive.Addr -import Data.Primitive.SmallArray -import Data.Primitive.UnliftedArray -import Data.Primitive.PrimArray -import Data.Primitive.MutVar - -{- $namingConventions -For historical reasons, this library embraces the practice of suffixing -the name of a function with the type it operates on. For example, three -of the variants of the array indexing function are: - -> indexArray :: Array a -> Int -> a -> indexSmallArray :: SmallArray a -> Int -> a -> indexPrimArray :: Prim a => PrimArray a -> Int -> a - -In a few places, where the language sounds more natural, the array type -is instead used as a prefix. For example, @Data.Primitive.SmallArray@ -exports @smallArrayFromList@, which would sound unnatural if it used -@SmallArray@ as a suffix instead. - -This library provides several functions traversing, building, and filtering -arrays. These functions are suffixed with an additional character to -indicate their the nature of their effectfulness: - -* No suffix: A non-effectful pass over the array. -* @-A@ suffix: An effectful pass over the array, where the effect is 'Applicative'. -* @-P@ suffix: An effectful pass over the array, where the effect is 'PrimMonad'. - -Additionally, an apostrophe can be used to indicate strictness in the elements. -The variants with an apostrophe are used in @Data.Primitive.Array@ but not -in @Data.Primitive.PrimArray@ since the array type it provides is always strict in the element. -For example, there are three variants of the function that filters elements -from a primitive array. - -> filterPrimArray :: (Prim a ) => (a -> Bool) -> PrimArray a -> PrimArray a -> filterPrimArrayA :: (Prim a, Applicative f) => (a -> f Bool) -> PrimArray a -> f (PrimArray a) -> filterPrimArrayP :: (Prim a, PrimMonad m) => (a -> m Bool) -> PrimArray a -> m (PrimArray a) - -As long as the effectful context is a monad that is sufficiently affine -the behaviors of the 'Applicative' and 'PrimMonad' variants produce the same results -and differ only in their strictness. Monads that are sufficiently affine -include: - -* 'IO' and 'ST' -* Any combination of 'MaybeT', 'ExceptT', 'StateT' and 'Writer' on top - of another sufficiently affine monad. - -There is one situation where the names deviate from effectful suffix convention -described above. Throughout the haskell ecosystem, the 'Applicative' variant of -'map' is known as 'traverse', not @mapA@. Consequently, we adopt the following -naming convention for mapping: - -> mapPrimArray :: (Prim a, Prim b) => (a -> b) -> PrimArray a -> PrimArray b -> traversePrimArray :: (Applicative f, Prim a, Prim b) => (a -> f b) -> PrimArray a -> f (PrimArray b) -> traversePrimArrayP :: (PrimMonad m, Prim a, Prim b) => (a -> m b) -> PrimArray a -> m (PrimArray b) --} diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Addr.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Addr.hs deleted file mode 100644 index 2ff25005c6aa..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Addr.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# LANGUAGE MagicHash, UnboxedTuples, CPP #-} - --- | --- Module : Data.Primitive.Addr --- Copyright : (c) Roman Leshchinskiy 2009-2012 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Portability : non-portable --- --- Primitive operations on machine addresses --- - -module Data.Primitive.Addr ( - -- * Types - Addr(..), - - -- * Address arithmetic - nullAddr, plusAddr, minusAddr, remAddr, - - -- * Element access - indexOffAddr, readOffAddr, writeOffAddr, - - -- * Block operations - copyAddr, -#if __GLASGOW_HASKELL__ >= 708 - copyAddrToByteArray, -#endif - moveAddr, setAddr, - - -- * Conversion - addrToInt -) where - -import Control.Monad.Primitive -import Data.Primitive.Types -#if __GLASGOW_HASKELL__ >= 708 -import Data.Primitive.ByteArray -#endif - -import GHC.Base ( Int(..) ) -import GHC.Prim - -import GHC.Ptr -import Foreign.Marshal.Utils - - --- | The null address -nullAddr :: Addr -nullAddr = Addr nullAddr# - -infixl 6 `plusAddr`, `minusAddr` -infixl 7 `remAddr` - --- | Offset an address by the given number of bytes -plusAddr :: Addr -> Int -> Addr -plusAddr (Addr a#) (I# i#) = Addr (plusAddr# a# i#) - --- | Distance in bytes between two addresses. The result is only valid if the --- difference fits in an 'Int'. -minusAddr :: Addr -> Addr -> Int -minusAddr (Addr a#) (Addr b#) = I# (minusAddr# a# b#) - --- | The remainder of the address and the integer. -remAddr :: Addr -> Int -> Int -remAddr (Addr a#) (I# i#) = I# (remAddr# a# i#) - --- | Read a value from a memory position given by an address and an offset. --- The memory block the address refers to must be immutable. The offset is in --- elements of type @a@ rather than in bytes. -indexOffAddr :: Prim a => Addr -> Int -> a -{-# INLINE indexOffAddr #-} -indexOffAddr (Addr addr#) (I# i#) = indexOffAddr# addr# i# - --- | Read a value from a memory position given by an address and an offset. --- The offset is in elements of type @a@ rather than in bytes. -readOffAddr :: (Prim a, PrimMonad m) => Addr -> Int -> m a -{-# INLINE readOffAddr #-} -readOffAddr (Addr addr#) (I# i#) = primitive (readOffAddr# addr# i#) - --- | Write a value to a memory position given by an address and an offset. --- The offset is in elements of type @a@ rather than in bytes. -writeOffAddr :: (Prim a, PrimMonad m) => Addr -> Int -> a -> m () -{-# INLINE writeOffAddr #-} -writeOffAddr (Addr addr#) (I# i#) x = primitive_ (writeOffAddr# addr# i# x) - --- | Copy the given number of bytes from the second 'Addr' to the first. The --- areas may not overlap. -copyAddr :: PrimMonad m => Addr -- ^ destination address - -> Addr -- ^ source address - -> Int -- ^ number of bytes - -> m () -{-# INLINE copyAddr #-} -copyAddr (Addr dst#) (Addr src#) n - = unsafePrimToPrim $ copyBytes (Ptr dst#) (Ptr src#) n - -#if __GLASGOW_HASKELL__ >= 708 --- | Copy the given number of bytes from the 'Addr' to the 'MutableByteArray'. --- The areas may not overlap. This function is only available when compiling --- with GHC 7.8 or newer. --- --- @since 0.6.4.0 -copyAddrToByteArray :: PrimMonad m - => MutableByteArray (PrimState m) -- ^ destination - -> Int -- ^ offset into the destination array - -> Addr -- ^ source - -> Int -- ^ number of bytes to copy - -> m () -{-# INLINE copyAddrToByteArray #-} -copyAddrToByteArray (MutableByteArray marr) (I# off) (Addr addr) (I# len) = - primitive_ $ copyAddrToByteArray# addr marr off len -#endif - --- | Copy the given number of bytes from the second 'Addr' to the first. The --- areas may overlap. -moveAddr :: PrimMonad m => Addr -- ^ destination address - -> Addr -- ^ source address - -> Int -- ^ number of bytes - -> m () -{-# INLINE moveAddr #-} -moveAddr (Addr dst#) (Addr src#) n - = unsafePrimToPrim $ moveBytes (Ptr dst#) (Ptr src#) n - --- | Fill a memory block of with the given value. The length is in --- elements of type @a@ rather than in bytes. -setAddr :: (Prim a, PrimMonad m) => Addr -> Int -> a -> m () -{-# INLINE setAddr #-} -setAddr (Addr addr#) (I# n#) x = primitive_ (setOffAddr# addr# 0# n# x) - --- | Convert an 'Addr' to an 'Int'. -addrToInt :: Addr -> Int -{-# INLINE addrToInt #-} -addrToInt (Addr addr#) = I# (addr2Int# addr#) diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Array.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Array.hs deleted file mode 100644 index 13352f6cb444..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Array.hs +++ /dev/null @@ -1,822 +0,0 @@ -{-# LANGUAGE CPP, MagicHash, UnboxedTuples, DeriveDataTypeable, BangPatterns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Data.Primitive.Array --- Copyright : (c) Roman Leshchinskiy 2009-2012 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Portability : non-portable --- --- Primitive arrays of boxed values. --- - -module Data.Primitive.Array ( - Array(..), MutableArray(..), - - newArray, readArray, writeArray, indexArray, indexArrayM, indexArray##, - freezeArray, thawArray, runArray, - unsafeFreezeArray, unsafeThawArray, sameMutableArray, - copyArray, copyMutableArray, - cloneArray, cloneMutableArray, - sizeofArray, sizeofMutableArray, - fromListN, fromList, - mapArray', - traverseArrayP -) where - -import Control.Monad.Primitive - -import GHC.Base ( Int(..) ) -import GHC.Prim -import qualified GHC.Exts as Exts -#if (MIN_VERSION_base(4,7,0)) -import GHC.Exts (fromListN, fromList) -#endif - -import Data.Typeable ( Typeable ) -import Data.Data - (Data(..), DataType, mkDataType, Constr, mkConstr, Fixity(..), constrIndex) -import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType ) - -import Control.Monad.ST(ST,runST) - -import Control.Applicative -import Control.Monad (MonadPlus(..), when) -import Control.Monad.Fix -#if MIN_VERSION_base(4,4,0) -import Control.Monad.Zip -#endif -import Data.Foldable (Foldable(..), toList) -#if !(MIN_VERSION_base(4,8,0)) -import Data.Traversable (Traversable(..)) -import Data.Monoid -#endif -#if MIN_VERSION_base(4,9,0) -import qualified GHC.ST as GHCST -import qualified Data.Foldable as F -import Data.Semigroup -#endif -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity -#endif -#if MIN_VERSION_base(4,10,0) -import GHC.Exts (runRW#) -#elif MIN_VERSION_base(4,9,0) -import GHC.Base (runRW#) -#endif - -import Text.ParserCombinators.ReadP - -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) -import Data.Functor.Classes (Eq1(..),Ord1(..),Show1(..),Read1(..)) -#endif - --- | Boxed arrays -data Array a = Array - { array# :: Array# a } - deriving ( Typeable ) - --- | Mutable boxed arrays associated with a primitive state token. -data MutableArray s a = MutableArray - { marray# :: MutableArray# s a } - deriving ( Typeable ) - -sizeofArray :: Array a -> Int -sizeofArray a = I# (sizeofArray# (array# a)) -{-# INLINE sizeofArray #-} - -sizeofMutableArray :: MutableArray s a -> Int -sizeofMutableArray a = I# (sizeofMutableArray# (marray# a)) -{-# INLINE sizeofMutableArray #-} - --- | Create a new mutable array of the specified size and initialise all --- elements with the given value. -newArray :: PrimMonad m => Int -> a -> m (MutableArray (PrimState m) a) -{-# INLINE newArray #-} -newArray (I# n#) x = primitive - (\s# -> case newArray# n# x s# of - (# s'#, arr# #) -> - let ma = MutableArray arr# - in (# s'# , ma #)) - --- | Read a value from the array at the given index. -readArray :: PrimMonad m => MutableArray (PrimState m) a -> Int -> m a -{-# INLINE readArray #-} -readArray arr (I# i#) = primitive (readArray# (marray# arr) i#) - --- | Write a value to the array at the given index. -writeArray :: PrimMonad m => MutableArray (PrimState m) a -> Int -> a -> m () -{-# INLINE writeArray #-} -writeArray arr (I# i#) x = primitive_ (writeArray# (marray# arr) i# x) - --- | Read a value from the immutable array at the given index. -indexArray :: Array a -> Int -> a -{-# INLINE indexArray #-} -indexArray arr (I# i#) = case indexArray# (array# arr) i# of (# x #) -> x - --- | Read a value from the immutable array at the given index, returning --- the result in an unboxed unary tuple. This is currently used to implement --- folds. -indexArray## :: Array a -> Int -> (# a #) -indexArray## arr (I# i) = indexArray# (array# arr) i -{-# INLINE indexArray## #-} - --- | Monadically read a value from the immutable array at the given index. --- This allows us to be strict in the array while remaining lazy in the read --- element which is very useful for collective operations. Suppose we want to --- copy an array. We could do something like this: --- --- > copy marr arr ... = do ... --- > writeArray marr i (indexArray arr i) ... --- > ... --- --- But since primitive arrays are lazy, the calls to 'indexArray' will not be --- evaluated. Rather, @marr@ will be filled with thunks each of which would --- retain a reference to @arr@. This is definitely not what we want! --- --- With 'indexArrayM', we can instead write --- --- > copy marr arr ... = do ... --- > x <- indexArrayM arr i --- > writeArray marr i x --- > ... --- --- Now, indexing is executed immediately although the returned element is --- still not evaluated. --- -indexArrayM :: Monad m => Array a -> Int -> m a -{-# INLINE indexArrayM #-} -indexArrayM arr (I# i#) - = case indexArray# (array# arr) i# of (# x #) -> return x - --- | Create an immutable copy of a slice of an array. --- --- This operation makes a copy of the specified section, so it is safe to --- continue using the mutable array afterward. -freezeArray - :: PrimMonad m - => MutableArray (PrimState m) a -- ^ source - -> Int -- ^ offset - -> Int -- ^ length - -> m (Array a) -{-# INLINE freezeArray #-} -freezeArray (MutableArray ma#) (I# off#) (I# len#) = - primitive $ \s -> case freezeArray# ma# off# len# s of - (# s', a# #) -> (# s', Array a# #) - --- | Convert a mutable array to an immutable one without copying. The --- array should not be modified after the conversion. -unsafeFreezeArray :: PrimMonad m => MutableArray (PrimState m) a -> m (Array a) -{-# INLINE unsafeFreezeArray #-} -unsafeFreezeArray arr - = primitive (\s# -> case unsafeFreezeArray# (marray# arr) s# of - (# s'#, arr'# #) -> - let a = Array arr'# - in (# s'#, a #)) - --- | Create a mutable array from a slice of an immutable array. --- --- This operation makes a copy of the specified slice, so it is safe to use the --- immutable array afterward. -thawArray - :: PrimMonad m - => Array a -- ^ source - -> Int -- ^ offset - -> Int -- ^ length - -> m (MutableArray (PrimState m) a) -{-# INLINE thawArray #-} -thawArray (Array a#) (I# off#) (I# len#) = - primitive $ \s -> case thawArray# a# off# len# s of - (# s', ma# #) -> (# s', MutableArray ma# #) - --- | Convert an immutable array to an mutable one without copying. The --- immutable array should not be used after the conversion. -unsafeThawArray :: PrimMonad m => Array a -> m (MutableArray (PrimState m) a) -{-# INLINE unsafeThawArray #-} -unsafeThawArray a - = primitive (\s# -> case unsafeThawArray# (array# a) s# of - (# s'#, arr'# #) -> - let ma = MutableArray arr'# - in (# s'#, ma #)) - --- | Check whether the two arrays refer to the same memory block. -sameMutableArray :: MutableArray s a -> MutableArray s a -> Bool -{-# INLINE sameMutableArray #-} -sameMutableArray arr brr - = isTrue# (sameMutableArray# (marray# arr) (marray# brr)) - --- | Copy a slice of an immutable array to a mutable array. -copyArray :: PrimMonad m - => MutableArray (PrimState m) a -- ^ destination array - -> Int -- ^ offset into destination array - -> Array a -- ^ source array - -> Int -- ^ offset into source array - -> Int -- ^ number of elements to copy - -> m () -{-# INLINE copyArray #-} -#if __GLASGOW_HASKELL__ > 706 --- NOTE: copyArray# and copyMutableArray# are slightly broken in GHC 7.6.* and earlier -copyArray (MutableArray dst#) (I# doff#) (Array src#) (I# soff#) (I# len#) - = primitive_ (copyArray# src# soff# dst# doff# len#) -#else -copyArray !dst !doff !src !soff !len = go 0 - where - go i | i < len = do - x <- indexArrayM src (soff+i) - writeArray dst (doff+i) x - go (i+1) - | otherwise = return () -#endif - --- | Copy a slice of a mutable array to another array. The two arrays may --- not be the same. -copyMutableArray :: PrimMonad m - => MutableArray (PrimState m) a -- ^ destination array - -> Int -- ^ offset into destination array - -> MutableArray (PrimState m) a -- ^ source array - -> Int -- ^ offset into source array - -> Int -- ^ number of elements to copy - -> m () -{-# INLINE copyMutableArray #-} -#if __GLASGOW_HASKELL__ >= 706 --- NOTE: copyArray# and copyMutableArray# are slightly broken in GHC 7.6.* and earlier -copyMutableArray (MutableArray dst#) (I# doff#) - (MutableArray src#) (I# soff#) (I# len#) - = primitive_ (copyMutableArray# src# soff# dst# doff# len#) -#else -copyMutableArray !dst !doff !src !soff !len = go 0 - where - go i | i < len = do - x <- readArray src (soff+i) - writeArray dst (doff+i) x - go (i+1) - | otherwise = return () -#endif - --- | Return a newly allocated Array with the specified subrange of the --- provided Array. The provided Array should contain the full subrange --- specified by the two Ints, but this is not checked. -cloneArray :: Array a -- ^ source array - -> Int -- ^ offset into destination array - -> Int -- ^ number of elements to copy - -> Array a -{-# INLINE cloneArray #-} -cloneArray (Array arr#) (I# off#) (I# len#) - = case cloneArray# arr# off# len# of arr'# -> Array arr'# - --- | Return a newly allocated MutableArray. with the specified subrange of --- the provided MutableArray. The provided MutableArray should contain the --- full subrange specified by the two Ints, but this is not checked. -cloneMutableArray :: PrimMonad m - => MutableArray (PrimState m) a -- ^ source array - -> Int -- ^ offset into destination array - -> Int -- ^ number of elements to copy - -> m (MutableArray (PrimState m) a) -{-# INLINE cloneMutableArray #-} -cloneMutableArray (MutableArray arr#) (I# off#) (I# len#) = primitive - (\s# -> case cloneMutableArray# arr# off# len# s# of - (# s'#, arr'# #) -> (# s'#, MutableArray arr'# #)) - -emptyArray :: Array a -emptyArray = - runST $ newArray 0 (die "emptyArray" "impossible") >>= unsafeFreezeArray -{-# NOINLINE emptyArray #-} - -#if !MIN_VERSION_base(4,9,0) -createArray - :: Int - -> a - -> (forall s. MutableArray s a -> ST s ()) - -> Array a -createArray 0 _ _ = emptyArray -createArray n x f = runArray $ do - mary <- newArray n x - f mary - pure mary - -runArray - :: (forall s. ST s (MutableArray s a)) - -> Array a -runArray m = runST $ m >>= unsafeFreezeArray - -#else /* Below, runRW# is available. */ - --- This low-level business is designed to work with GHC's worker-wrapper --- transformation. A lot of the time, we don't actually need an Array --- constructor. By putting it on the outside, and being careful about --- how we special-case the empty array, we can make GHC smarter about this. --- The only downside is that separately created 0-length arrays won't share --- their Array constructors, although they'll share their underlying --- Array#s. -createArray - :: Int - -> a - -> (forall s. MutableArray s a -> ST s ()) - -> Array a -createArray 0 _ _ = Array (emptyArray# (# #)) -createArray n x f = runArray $ do - mary <- newArray n x - f mary - pure mary - -runArray - :: (forall s. ST s (MutableArray s a)) - -> Array a -runArray m = Array (runArray# m) - -runArray# - :: (forall s. ST s (MutableArray s a)) - -> Array# a -runArray# m = case runRW# $ \s -> - case unST m s of { (# s', MutableArray mary# #) -> - unsafeFreezeArray# mary# s'} of (# _, ary# #) -> ary# - -unST :: ST s a -> State# s -> (# State# s, a #) -unST (GHCST.ST f) = f - -emptyArray# :: (# #) -> Array# a -emptyArray# _ = case emptyArray of Array ar -> ar -{-# NOINLINE emptyArray# #-} -#endif - - -die :: String -> String -> a -die fun problem = error $ "Data.Primitive.Array." ++ fun ++ ": " ++ problem - -arrayLiftEq :: (a -> b -> Bool) -> Array a -> Array b -> Bool -arrayLiftEq p a1 a2 = sizeofArray a1 == sizeofArray a2 && loop (sizeofArray a1 - 1) - where loop i | i < 0 = True - | (# x1 #) <- indexArray## a1 i - , (# x2 #) <- indexArray## a2 i - , otherwise = p x1 x2 && loop (i-1) - -instance Eq a => Eq (Array a) where - a1 == a2 = arrayLiftEq (==) a1 a2 - -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) --- | @since 0.6.4.0 -instance Eq1 Array where -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) - liftEq = arrayLiftEq -#else - eq1 = arrayLiftEq (==) -#endif -#endif - -instance Eq (MutableArray s a) where - ma1 == ma2 = isTrue# (sameMutableArray# (marray# ma1) (marray# ma2)) - -arrayLiftCompare :: (a -> b -> Ordering) -> Array a -> Array b -> Ordering -arrayLiftCompare elemCompare a1 a2 = loop 0 - where - mn = sizeofArray a1 `min` sizeofArray a2 - loop i - | i < mn - , (# x1 #) <- indexArray## a1 i - , (# x2 #) <- indexArray## a2 i - = elemCompare x1 x2 `mappend` loop (i+1) - | otherwise = compare (sizeofArray a1) (sizeofArray a2) - --- | Lexicographic ordering. Subject to change between major versions. -instance Ord a => Ord (Array a) where - compare a1 a2 = arrayLiftCompare compare a1 a2 - -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) --- | @since 0.6.4.0 -instance Ord1 Array where -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) - liftCompare = arrayLiftCompare -#else - compare1 = arrayLiftCompare compare -#endif -#endif - -instance Foldable Array where - -- Note: we perform the array lookups eagerly so we won't - -- create thunks to perform lookups even if GHC can't see - -- that the folding function is strict. - foldr f = \z !ary -> - let - !sz = sizeofArray ary - go i - | i == sz = z - | (# x #) <- indexArray## ary i - = f x (go (i+1)) - in go 0 - {-# INLINE foldr #-} - foldl f = \z !ary -> - let - go i - | i < 0 = z - | (# x #) <- indexArray## ary i - = f (go (i-1)) x - in go (sizeofArray ary - 1) - {-# INLINE foldl #-} - foldr1 f = \ !ary -> - let - !sz = sizeofArray ary - 1 - go i = - case indexArray## ary i of - (# x #) | i == sz -> x - | otherwise -> f x (go (i+1)) - in if sz < 0 - then die "foldr1" "empty array" - else go 0 - {-# INLINE foldr1 #-} - foldl1 f = \ !ary -> - let - !sz = sizeofArray ary - 1 - go i = - case indexArray## ary i of - (# x #) | i == 0 -> x - | otherwise -> f (go (i - 1)) x - in if sz < 0 - then die "foldl1" "empty array" - else go sz - {-# INLINE foldl1 #-} -#if MIN_VERSION_base(4,6,0) - foldr' f = \z !ary -> - let - go i !acc - | i == -1 = acc - | (# x #) <- indexArray## ary i - = go (i-1) (f x acc) - in go (sizeofArray ary - 1) z - {-# INLINE foldr' #-} - foldl' f = \z !ary -> - let - !sz = sizeofArray ary - go i !acc - | i == sz = acc - | (# x #) <- indexArray## ary i - = go (i+1) (f acc x) - in go 0 z - {-# INLINE foldl' #-} -#endif -#if MIN_VERSION_base(4,8,0) - null a = sizeofArray a == 0 - {-# INLINE null #-} - length = sizeofArray - {-# INLINE length #-} - maximum ary | sz == 0 = die "maximum" "empty array" - | (# frst #) <- indexArray## ary 0 - = go 1 frst - where - sz = sizeofArray ary - go i !e - | i == sz = e - | (# x #) <- indexArray## ary i - = go (i+1) (max e x) - {-# INLINE maximum #-} - minimum ary | sz == 0 = die "minimum" "empty array" - | (# frst #) <- indexArray## ary 0 - = go 1 frst - where sz = sizeofArray ary - go i !e - | i == sz = e - | (# x #) <- indexArray## ary i - = go (i+1) (min e x) - {-# INLINE minimum #-} - sum = foldl' (+) 0 - {-# INLINE sum #-} - product = foldl' (*) 1 - {-# INLINE product #-} -#endif - -newtype STA a = STA {_runSTA :: forall s. MutableArray# s a -> ST s (Array a)} - -runSTA :: Int -> STA a -> Array a -runSTA !sz = \ (STA m) -> runST $ newArray_ sz >>= \ ar -> m (marray# ar) -{-# INLINE runSTA #-} - -newArray_ :: Int -> ST s (MutableArray s a) -newArray_ !n = newArray n badTraverseValue - -badTraverseValue :: a -badTraverseValue = die "traverse" "bad indexing" -{-# NOINLINE badTraverseValue #-} - -instance Traversable Array where - traverse f = traverseArray f - {-# INLINE traverse #-} - -traverseArray - :: Applicative f - => (a -> f b) - -> Array a - -> f (Array b) -traverseArray f = \ !ary -> - let - !len = sizeofArray ary - go !i - | i == len = pure $ STA $ \mary -> unsafeFreezeArray (MutableArray mary) - | (# x #) <- indexArray## ary i - = liftA2 (\b (STA m) -> STA $ \mary -> - writeArray (MutableArray mary) i b >> m mary) - (f x) (go (i + 1)) - in if len == 0 - then pure emptyArray - else runSTA len <$> go 0 -{-# INLINE [1] traverseArray #-} - -{-# RULES -"traverse/ST" forall (f :: a -> ST s b). traverseArray f = - traverseArrayP f -"traverse/IO" forall (f :: a -> IO b). traverseArray f = - traverseArrayP f - #-} -#if MIN_VERSION_base(4,8,0) -{-# RULES -"traverse/Id" forall (f :: a -> Identity b). traverseArray f = - (coerce :: (Array a -> Array (Identity b)) - -> Array a -> Identity (Array b)) (fmap f) - #-} -#endif - --- | This is the fastest, most straightforward way to traverse --- an array, but it only works correctly with a sufficiently --- "affine" 'PrimMonad' instance. In particular, it must only produce --- *one* result array. 'Control.Monad.Trans.List.ListT'-transformed --- monads, for example, will not work right at all. -traverseArrayP - :: PrimMonad m - => (a -> m b) - -> Array a - -> m (Array b) -traverseArrayP f = \ !ary -> - let - !sz = sizeofArray ary - go !i !mary - | i == sz - = unsafeFreezeArray mary - | otherwise - = do - a <- indexArrayM ary i - b <- f a - writeArray mary i b - go (i + 1) mary - in do - mary <- newArray sz badTraverseValue - go 0 mary -{-# INLINE traverseArrayP #-} - --- | Strict map over the elements of the array. -mapArray' :: (a -> b) -> Array a -> Array b -mapArray' f a = - createArray (sizeofArray a) (die "mapArray'" "impossible") $ \mb -> - let go i | i == sizeofArray a - = return () - | otherwise - = do x <- indexArrayM a i - -- We use indexArrayM here so that we will perform the - -- indexing eagerly even if f is lazy. - let !y = f x - writeArray mb i y >> go (i+1) - in go 0 -{-# INLINE mapArray' #-} - -arrayFromListN :: Int -> [a] -> Array a -arrayFromListN n l = - createArray n (die "fromListN" "uninitialized element") $ \sma -> - let go !ix [] = if ix == n - then return () - else die "fromListN" "list length less than specified size" - go !ix (x : xs) = if ix < n - then do - writeArray sma ix x - go (ix+1) xs - else die "fromListN" "list length greater than specified size" - in go 0 l - -arrayFromList :: [a] -> Array a -arrayFromList l = arrayFromListN (length l) l - -#if MIN_VERSION_base(4,7,0) -instance Exts.IsList (Array a) where - type Item (Array a) = a - fromListN = arrayFromListN - fromList = arrayFromList - toList = toList -#else -fromListN :: Int -> [a] -> Array a -fromListN = arrayFromListN - -fromList :: [a] -> Array a -fromList = arrayFromList -#endif - -instance Functor Array where - fmap f a = - createArray (sizeofArray a) (die "fmap" "impossible") $ \mb -> - let go i | i == sizeofArray a - = return () - | otherwise - = do x <- indexArrayM a i - writeArray mb i (f x) >> go (i+1) - in go 0 -#if MIN_VERSION_base(4,8,0) - e <$ a = createArray (sizeofArray a) e (\ !_ -> pure ()) -#endif - -instance Applicative Array where - pure x = runArray $ newArray 1 x - ab <*> a = createArray (szab*sza) (die "<*>" "impossible") $ \mb -> - let go1 i = when (i < szab) $ - do - f <- indexArrayM ab i - go2 (i*sza) f 0 - go1 (i+1) - go2 off f j = when (j < sza) $ - do - x <- indexArrayM a j - writeArray mb (off + j) (f x) - go2 off f (j + 1) - in go1 0 - where szab = sizeofArray ab ; sza = sizeofArray a - a *> b = createArray (sza*szb) (die "*>" "impossible") $ \mb -> - let go i | i < sza = copyArray mb (i * szb) b 0 szb - | otherwise = return () - in go 0 - where sza = sizeofArray a ; szb = sizeofArray b - a <* b = createArray (sza*szb) (die "<*" "impossible") $ \ma -> - let fill off i e | i < szb = writeArray ma (off+i) e >> fill off (i+1) e - | otherwise = return () - go i | i < sza - = do x <- indexArrayM a i - fill (i*szb) 0 x >> go (i+1) - | otherwise = return () - in go 0 - where sza = sizeofArray a ; szb = sizeofArray b - -instance Alternative Array where - empty = emptyArray - a1 <|> a2 = createArray (sza1 + sza2) (die "<|>" "impossible") $ \ma -> - copyArray ma 0 a1 0 sza1 >> copyArray ma sza1 a2 0 sza2 - where sza1 = sizeofArray a1 ; sza2 = sizeofArray a2 - some a | sizeofArray a == 0 = emptyArray - | otherwise = die "some" "infinite arrays are not well defined" - many a | sizeofArray a == 0 = pure [] - | otherwise = die "many" "infinite arrays are not well defined" - -data ArrayStack a - = PushArray !(Array a) !(ArrayStack a) - | EmptyStack --- See the note in SmallArray about how we might improve this. - -instance Monad Array where - return = pure - (>>) = (*>) - - ary >>= f = collect 0 EmptyStack (la-1) - where - la = sizeofArray ary - collect sz stk i - | i < 0 = createArray sz (die ">>=" "impossible") $ fill 0 stk - | (# x #) <- indexArray## ary i - , let sb = f x - lsb = sizeofArray sb - -- If we don't perform this check, we could end up allocating - -- a stack full of empty arrays if someone is filtering most - -- things out. So we refrain from pushing empty arrays. - = if lsb == 0 - then collect sz stk (i - 1) - else collect (sz + lsb) (PushArray sb stk) (i-1) - - fill _ EmptyStack _ = return () - fill off (PushArray sb sbs) smb - | let lsb = sizeofArray sb - = copyArray smb off sb 0 (lsb) - *> fill (off + lsb) sbs smb - - fail _ = empty - -instance MonadPlus Array where - mzero = empty - mplus = (<|>) - -zipW :: String -> (a -> b -> c) -> Array a -> Array b -> Array c -zipW s f aa ab = createArray mn (die s "impossible") $ \mc -> - let go i | i < mn - = do - x <- indexArrayM aa i - y <- indexArrayM ab i - writeArray mc i (f x y) - go (i+1) - | otherwise = return () - in go 0 - where mn = sizeofArray aa `min` sizeofArray ab -{-# INLINE zipW #-} - -#if MIN_VERSION_base(4,4,0) -instance MonadZip Array where - mzip aa ab = zipW "mzip" (,) aa ab - mzipWith f aa ab = zipW "mzipWith" f aa ab - munzip aab = runST $ do - let sz = sizeofArray aab - ma <- newArray sz (die "munzip" "impossible") - mb <- newArray sz (die "munzip" "impossible") - let go i | i < sz = do - (a, b) <- indexArrayM aab i - writeArray ma i a - writeArray mb i b - go (i+1) - go _ = return () - go 0 - (,) <$> unsafeFreezeArray ma <*> unsafeFreezeArray mb -#endif - -instance MonadFix Array where - mfix f = createArray (sizeofArray (f err)) - (die "mfix" "impossible") $ flip fix 0 $ - \r !i !mary -> when (i < sz) $ do - writeArray mary i (fix (\xi -> f xi `indexArray` i)) - r (i + 1) mary - where - sz = sizeofArray (f err) - err = error "mfix for Data.Primitive.Array applied to strict function." - -#if MIN_VERSION_base(4,9,0) --- | @since 0.6.3.0 -instance Semigroup (Array a) where - (<>) = (<|>) - sconcat = mconcat . F.toList -#endif - -instance Monoid (Array a) where - mempty = empty -#if !(MIN_VERSION_base(4,11,0)) - mappend = (<|>) -#endif - mconcat l = createArray sz (die "mconcat" "impossible") $ \ma -> - let go !_ [ ] = return () - go off (a:as) = - copyArray ma off a 0 (sizeofArray a) >> go (off + sizeofArray a) as - in go 0 l - where sz = sum . fmap sizeofArray $ l - -arrayLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Array a -> ShowS -arrayLiftShowsPrec elemShowsPrec elemListShowsPrec p a = showParen (p > 10) $ - showString "fromListN " . shows (sizeofArray a) . showString " " - . listLiftShowsPrec elemShowsPrec elemListShowsPrec 11 (toList a) - --- this need to be included for older ghcs -listLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> [a] -> ShowS -listLiftShowsPrec _ sl _ = sl - -instance Show a => Show (Array a) where - showsPrec p a = arrayLiftShowsPrec showsPrec showList p a - -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) --- | @since 0.6.4.0 -instance Show1 Array where -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) - liftShowsPrec = arrayLiftShowsPrec -#else - showsPrec1 = arrayLiftShowsPrec showsPrec showList -#endif -#endif - -arrayLiftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Array a) -arrayLiftReadsPrec _ listReadsPrec p = readParen (p > 10) . readP_to_S $ do - () <$ string "fromListN" - skipSpaces - n <- readS_to_P reads - skipSpaces - l <- readS_to_P listReadsPrec - return $ arrayFromListN n l - -instance Read a => Read (Array a) where - readsPrec = arrayLiftReadsPrec readsPrec readList - -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) --- | @since 0.6.4.0 -instance Read1 Array where -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) - liftReadsPrec = arrayLiftReadsPrec -#else - readsPrec1 = arrayLiftReadsPrec readsPrec readList -#endif -#endif - - -arrayDataType :: DataType -arrayDataType = mkDataType "Data.Primitive.Array.Array" [fromListConstr] - -fromListConstr :: Constr -fromListConstr = mkConstr arrayDataType "fromList" [] Prefix - -instance Data a => Data (Array a) where - toConstr _ = fromListConstr - dataTypeOf _ = arrayDataType - gunfold k z c = case constrIndex c of - 1 -> k (z fromList) - _ -> error "gunfold" - gfoldl f z m = z fromList `f` toList m - -instance (Typeable s, Typeable a) => Data (MutableArray s a) where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Data.Primitive.Array.MutableArray" diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/ByteArray.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/ByteArray.hs deleted file mode 100644 index 527205330b8b..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/ByteArray.hs +++ /dev/null @@ -1,549 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples, UnliftedFFITypes, DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Data.Primitive.ByteArray --- Copyright : (c) Roman Leshchinskiy 2009-2012 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Portability : non-portable --- --- Primitive operations on ByteArrays --- - -module Data.Primitive.ByteArray ( - -- * Types - ByteArray(..), MutableByteArray(..), ByteArray#, MutableByteArray#, - - -- * Allocation - newByteArray, newPinnedByteArray, newAlignedPinnedByteArray, - resizeMutableByteArray, - - -- * Element access - readByteArray, writeByteArray, indexByteArray, - - -- * Constructing - byteArrayFromList, byteArrayFromListN, - - -- * Folding - foldrByteArray, - - -- * Freezing and thawing - unsafeFreezeByteArray, unsafeThawByteArray, - - -- * Block operations - copyByteArray, copyMutableByteArray, -#if __GLASGOW_HASKELL__ >= 708 - copyByteArrayToAddr, copyMutableByteArrayToAddr, -#endif - moveByteArray, - setByteArray, fillByteArray, - - -- * Information - sizeofByteArray, - sizeofMutableByteArray, getSizeofMutableByteArray, sameMutableByteArray, -#if __GLASGOW_HASKELL__ >= 802 - isByteArrayPinned, isMutableByteArrayPinned, -#endif - byteArrayContents, mutableByteArrayContents - -) where - -import Control.Monad.Primitive -import Control.Monad.ST -import Data.Primitive.Types - -import Foreign.C.Types -import Data.Word ( Word8 ) -import GHC.Base ( Int(..) ) -#if __GLASGOW_HASKELL__ >= 708 -import qualified GHC.Exts as Exts ( IsList(..) ) -#endif -import GHC.Prim -#if __GLASGOW_HASKELL__ >= 706 - hiding (setByteArray#) -#endif - -import Data.Typeable ( Typeable ) -import Data.Data ( Data(..) ) -import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType ) -import Numeric - -#if MIN_VERSION_base(4,9,0) -import qualified Data.Semigroup as SG -import qualified Data.Foldable as F -#endif - -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid (Monoid(..)) -#endif - -#if __GLASGOW_HASKELL__ >= 802 -import GHC.Exts as Exts (isByteArrayPinned#,isMutableByteArrayPinned#) -#endif - -#if __GLASGOW_HASKELL__ >= 804 -import GHC.Exts (compareByteArrays#) -#else -import System.IO.Unsafe (unsafeDupablePerformIO) -#endif - --- | Byte arrays -data ByteArray = ByteArray ByteArray# deriving ( Typeable ) - --- | Mutable byte arrays associated with a primitive state token -data MutableByteArray s = MutableByteArray (MutableByteArray# s) - deriving( Typeable ) - --- | Create a new mutable byte array of the specified size in bytes. -newByteArray :: PrimMonad m => Int -> m (MutableByteArray (PrimState m)) -{-# INLINE newByteArray #-} -newByteArray (I# n#) - = primitive (\s# -> case newByteArray# n# s# of - (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #)) - --- | Create a /pinned/ byte array of the specified size in bytes. The garbage --- collector is guaranteed not to move it. -newPinnedByteArray :: PrimMonad m => Int -> m (MutableByteArray (PrimState m)) -{-# INLINE newPinnedByteArray #-} -newPinnedByteArray (I# n#) - = primitive (\s# -> case newPinnedByteArray# n# s# of - (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #)) - --- | Create a /pinned/ byte array of the specified size in bytes and with the --- given alignment. The garbage collector is guaranteed not to move it. -newAlignedPinnedByteArray - :: PrimMonad m - => Int -- ^ size - -> Int -- ^ alignment - -> m (MutableByteArray (PrimState m)) -{-# INLINE newAlignedPinnedByteArray #-} -newAlignedPinnedByteArray (I# n#) (I# k#) - = primitive (\s# -> case newAlignedPinnedByteArray# n# k# s# of - (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #)) - --- | Yield a pointer to the array's data. This operation is only safe on --- /pinned/ byte arrays allocated by 'newPinnedByteArray' or --- 'newAlignedPinnedByteArray'. -byteArrayContents :: ByteArray -> Addr -{-# INLINE byteArrayContents #-} -byteArrayContents (ByteArray arr#) = Addr (byteArrayContents# arr#) - --- | Yield a pointer to the array's data. This operation is only safe on --- /pinned/ byte arrays allocated by 'newPinnedByteArray' or --- 'newAlignedPinnedByteArray'. -mutableByteArrayContents :: MutableByteArray s -> Addr -{-# INLINE mutableByteArrayContents #-} -mutableByteArrayContents (MutableByteArray arr#) - = Addr (byteArrayContents# (unsafeCoerce# arr#)) - --- | Check if the two arrays refer to the same memory block. -sameMutableByteArray :: MutableByteArray s -> MutableByteArray s -> Bool -{-# INLINE sameMutableByteArray #-} -sameMutableByteArray (MutableByteArray arr#) (MutableByteArray brr#) - = isTrue# (sameMutableByteArray# arr# brr#) - --- | Resize a mutable byte array. The new size is given in bytes. --- --- This will either resize the array in-place or, if not possible, allocate the --- contents into a new, unpinned array and copy the original array's contents. --- --- To avoid undefined behaviour, the original 'MutableByteArray' shall not be --- accessed anymore after a 'resizeMutableByteArray' has been performed. --- Moreover, no reference to the old one should be kept in order to allow --- garbage collection of the original 'MutableByteArray' in case a new --- 'MutableByteArray' had to be allocated. --- --- @since 0.6.4.0 -resizeMutableByteArray - :: PrimMonad m => MutableByteArray (PrimState m) -> Int - -> m (MutableByteArray (PrimState m)) -{-# INLINE resizeMutableByteArray #-} -#if __GLASGOW_HASKELL__ >= 710 -resizeMutableByteArray (MutableByteArray arr#) (I# n#) - = primitive (\s# -> case resizeMutableByteArray# arr# n# s# of - (# s'#, arr'# #) -> (# s'#, MutableByteArray arr'# #)) -#else -resizeMutableByteArray arr n - = do arr' <- newByteArray n - copyMutableByteArray arr' 0 arr 0 (min (sizeofMutableByteArray arr) n) - return arr' -#endif - --- | Get the size of a byte array in bytes. Unlike 'sizeofMutableByteArray', --- this function ensures sequencing in the presence of resizing. -getSizeofMutableByteArray - :: PrimMonad m => MutableByteArray (PrimState m) -> m Int -{-# INLINE getSizeofMutableByteArray #-} -#if __GLASGOW_HASKELL__ >= 801 -getSizeofMutableByteArray (MutableByteArray arr#) - = primitive (\s# -> case getSizeofMutableByteArray# arr# s# of - (# s'#, n# #) -> (# s'#, I# n# #)) -#else -getSizeofMutableByteArray arr - = return (sizeofMutableByteArray arr) -#endif - --- | Convert a mutable byte array to an immutable one without copying. The --- array should not be modified after the conversion. -unsafeFreezeByteArray - :: PrimMonad m => MutableByteArray (PrimState m) -> m ByteArray -{-# INLINE unsafeFreezeByteArray #-} -unsafeFreezeByteArray (MutableByteArray arr#) - = primitive (\s# -> case unsafeFreezeByteArray# arr# s# of - (# s'#, arr'# #) -> (# s'#, ByteArray arr'# #)) - --- | Convert an immutable byte array to a mutable one without copying. The --- original array should not be used after the conversion. -unsafeThawByteArray - :: PrimMonad m => ByteArray -> m (MutableByteArray (PrimState m)) -{-# INLINE unsafeThawByteArray #-} -unsafeThawByteArray (ByteArray arr#) - = primitive (\s# -> (# s#, MutableByteArray (unsafeCoerce# arr#) #)) - --- | Size of the byte array in bytes. -sizeofByteArray :: ByteArray -> Int -{-# INLINE sizeofByteArray #-} -sizeofByteArray (ByteArray arr#) = I# (sizeofByteArray# arr#) - --- | Size of the mutable byte array in bytes. This function\'s behavior --- is undefined if 'resizeMutableByteArray' is ever called on the mutable --- byte array given as the argument. Consequently, use of this function --- is discouraged. Prefer 'getSizeofMutableByteArray', which ensures correct --- sequencing in the presence of resizing. -sizeofMutableByteArray :: MutableByteArray s -> Int -{-# INLINE sizeofMutableByteArray #-} -sizeofMutableByteArray (MutableByteArray arr#) = I# (sizeofMutableByteArray# arr#) - -#if __GLASGOW_HASKELL__ >= 802 --- | Check whether or not the byte array is pinned. Pinned byte arrays cannot --- be moved by the garbage collector. It is safe to use 'byteArrayContents' --- on such byte arrays. This function is only available when compiling with --- GHC 8.2 or newer. --- --- @since 0.6.4.0 -isByteArrayPinned :: ByteArray -> Bool -{-# INLINE isByteArrayPinned #-} -isByteArrayPinned (ByteArray arr#) = isTrue# (Exts.isByteArrayPinned# arr#) - --- | Check whether or not the mutable byte array is pinned. This function is --- only available when compiling with GHC 8.2 or newer. --- --- @since 0.6.4.0 -isMutableByteArrayPinned :: MutableByteArray s -> Bool -{-# INLINE isMutableByteArrayPinned #-} -isMutableByteArrayPinned (MutableByteArray marr#) = isTrue# (Exts.isMutableByteArrayPinned# marr#) -#endif - --- | Read a primitive value from the byte array. The offset is given in --- elements of type @a@ rather than in bytes. -indexByteArray :: Prim a => ByteArray -> Int -> a -{-# INLINE indexByteArray #-} -indexByteArray (ByteArray arr#) (I# i#) = indexByteArray# arr# i# - --- | Read a primitive value from the byte array. The offset is given in --- elements of type @a@ rather than in bytes. -readByteArray - :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> m a -{-# INLINE readByteArray #-} -readByteArray (MutableByteArray arr#) (I# i#) - = primitive (readByteArray# arr# i#) - --- | Write a primitive value to the byte array. The offset is given in --- elements of type @a@ rather than in bytes. -writeByteArray - :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> a -> m () -{-# INLINE writeByteArray #-} -writeByteArray (MutableByteArray arr#) (I# i#) x - = primitive_ (writeByteArray# arr# i# x) - --- | Right-fold over the elements of a 'ByteArray'. -foldrByteArray :: forall a b. (Prim a) => (a -> b -> b) -> b -> ByteArray -> b -foldrByteArray f z arr = go 0 - where - go i - | sizeofByteArray arr > i * sz = f (indexByteArray arr i) (go (i+1)) - | otherwise = z - sz = sizeOf (undefined :: a) - -byteArrayFromList :: Prim a => [a] -> ByteArray -byteArrayFromList xs = byteArrayFromListN (length xs) xs - -byteArrayFromListN :: Prim a => Int -> [a] -> ByteArray -byteArrayFromListN n ys = runST $ do - marr <- newByteArray (n * sizeOf (head ys)) - let go !ix [] = if ix == n - then return () - else die "byteArrayFromListN" "list length less than specified size" - go !ix (x : xs) = if ix < n - then do - writeByteArray marr ix x - go (ix + 1) xs - else die "byteArrayFromListN" "list length greater than specified size" - go 0 ys - unsafeFreezeByteArray marr - -unI# :: Int -> Int# -unI# (I# n#) = n# - --- | Copy a slice of an immutable byte array to a mutable byte array. -copyByteArray - :: PrimMonad m => MutableByteArray (PrimState m) - -- ^ destination array - -> Int -- ^ offset into destination array - -> ByteArray -- ^ source array - -> Int -- ^ offset into source array - -> Int -- ^ number of bytes to copy - -> m () -{-# INLINE copyByteArray #-} -copyByteArray (MutableByteArray dst#) doff (ByteArray src#) soff sz - = primitive_ (copyByteArray# src# (unI# soff) dst# (unI# doff) (unI# sz)) - --- | Copy a slice of a mutable byte array into another array. The two slices --- may not overlap. -copyMutableByteArray - :: PrimMonad m => MutableByteArray (PrimState m) - -- ^ destination array - -> Int -- ^ offset into destination array - -> MutableByteArray (PrimState m) - -- ^ source array - -> Int -- ^ offset into source array - -> Int -- ^ number of bytes to copy - -> m () -{-# INLINE copyMutableByteArray #-} -copyMutableByteArray (MutableByteArray dst#) doff - (MutableByteArray src#) soff sz - = primitive_ (copyMutableByteArray# src# (unI# soff) dst# (unI# doff) (unI# sz)) - -#if __GLASGOW_HASKELL__ >= 708 --- | Copy a slice of a byte array to an unmanaged address. These must not --- overlap. This function is only available when compiling with GHC 7.8 --- or newer. --- --- @since 0.6.4.0 -copyByteArrayToAddr - :: PrimMonad m - => Addr -- ^ destination - -> ByteArray -- ^ source array - -> Int -- ^ offset into source array - -> Int -- ^ number of bytes to copy - -> m () -{-# INLINE copyByteArrayToAddr #-} -copyByteArrayToAddr (Addr dst#) (ByteArray src#) soff sz - = primitive_ (copyByteArrayToAddr# src# (unI# soff) dst# (unI# sz)) - --- | Copy a slice of a mutable byte array to an unmanaged address. These must --- not overlap. This function is only available when compiling with GHC 7.8 --- or newer. --- --- @since 0.6.4.0 -copyMutableByteArrayToAddr - :: PrimMonad m - => Addr -- ^ destination - -> MutableByteArray (PrimState m) -- ^ source array - -> Int -- ^ offset into source array - -> Int -- ^ number of bytes to copy - -> m () -{-# INLINE copyMutableByteArrayToAddr #-} -copyMutableByteArrayToAddr (Addr dst#) (MutableByteArray src#) soff sz - = primitive_ (copyMutableByteArrayToAddr# src# (unI# soff) dst# (unI# sz)) -#endif - --- | Copy a slice of a mutable byte array into another, potentially --- overlapping array. -moveByteArray - :: PrimMonad m => MutableByteArray (PrimState m) - -- ^ destination array - -> Int -- ^ offset into destination array - -> MutableByteArray (PrimState m) - -- ^ source array - -> Int -- ^ offset into source array - -> Int -- ^ number of bytes to copy - -> m () -{-# INLINE moveByteArray #-} -moveByteArray (MutableByteArray dst#) doff - (MutableByteArray src#) soff sz - = unsafePrimToPrim - $ memmove_mba dst# (fromIntegral doff) src# (fromIntegral soff) - (fromIntegral sz) - --- | Fill a slice of a mutable byte array with a value. The offset and length --- are given in elements of type @a@ rather than in bytes. -setByteArray - :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -- ^ array to fill - -> Int -- ^ offset into array - -> Int -- ^ number of values to fill - -> a -- ^ value to fill with - -> m () -{-# INLINE setByteArray #-} -setByteArray (MutableByteArray dst#) (I# doff#) (I# sz#) x - = primitive_ (setByteArray# dst# doff# sz# x) - --- | Fill a slice of a mutable byte array with a byte. -fillByteArray - :: PrimMonad m => MutableByteArray (PrimState m) - -- ^ array to fill - -> Int -- ^ offset into array - -> Int -- ^ number of bytes to fill - -> Word8 -- ^ byte to fill with - -> m () -{-# INLINE fillByteArray #-} -fillByteArray = setByteArray - -foreign import ccall unsafe "primitive-memops.h hsprimitive_memmove" - memmove_mba :: MutableByteArray# s -> CInt - -> MutableByteArray# s -> CInt - -> CSize -> IO () - -instance Data ByteArray where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Data.Primitive.ByteArray.ByteArray" - -instance Typeable s => Data (MutableByteArray s) where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Data.Primitive.ByteArray.MutableByteArray" - --- | @since 0.6.3.0 -instance Show ByteArray where - showsPrec _ ba = - showString "[" . go 0 - where - go i - | i < sizeofByteArray ba = comma . showString "0x" . showHex (indexByteArray ba i :: Word8) . go (i+1) - | otherwise = showChar ']' - where - comma | i == 0 = id - | otherwise = showString ", " - - -compareByteArrays :: ByteArray -> ByteArray -> Int -> Ordering -{-# INLINE compareByteArrays #-} -#if __GLASGOW_HASKELL__ >= 804 -compareByteArrays (ByteArray ba1#) (ByteArray ba2#) (I# n#) = - compare (I# (compareByteArrays# ba1# 0# ba2# 0# n#)) 0 -#else --- Emulate GHC 8.4's 'GHC.Prim.compareByteArrays#' -compareByteArrays (ByteArray ba1#) (ByteArray ba2#) (I# n#) - = compare (fromCInt (unsafeDupablePerformIO (memcmp_ba ba1# ba2# n))) 0 - where - n = fromIntegral (I# n#) :: CSize - fromCInt = fromIntegral :: CInt -> Int - -foreign import ccall unsafe "primitive-memops.h hsprimitive_memcmp" - memcmp_ba :: ByteArray# -> ByteArray# -> CSize -> IO CInt -#endif - - -sameByteArray :: ByteArray# -> ByteArray# -> Bool -sameByteArray ba1 ba2 = - case reallyUnsafePtrEquality# (unsafeCoerce# ba1 :: ()) (unsafeCoerce# ba2 :: ()) of -#if __GLASGOW_HASKELL__ >= 708 - r -> isTrue# r -#else - 1# -> True - 0# -> False -#endif - --- | @since 0.6.3.0 -instance Eq ByteArray where - ba1@(ByteArray ba1#) == ba2@(ByteArray ba2#) - | sameByteArray ba1# ba2# = True - | n1 /= n2 = False - | otherwise = compareByteArrays ba1 ba2 n1 == EQ - where - n1 = sizeofByteArray ba1 - n2 = sizeofByteArray ba2 - --- | Non-lexicographic ordering. This compares the lengths of --- the byte arrays first and uses a lexicographic ordering if --- the lengths are equal. Subject to change between major versions. --- --- @since 0.6.3.0 -instance Ord ByteArray where - ba1@(ByteArray ba1#) `compare` ba2@(ByteArray ba2#) - | sameByteArray ba1# ba2# = EQ - | n1 /= n2 = n1 `compare` n2 - | otherwise = compareByteArrays ba1 ba2 n1 - where - n1 = sizeofByteArray ba1 - n2 = sizeofByteArray ba2 --- Note: On GHC 8.4, the primop compareByteArrays# performs a check for pointer --- equality as a shortcut, so the check here is actually redundant. However, it --- is included here because it is likely better to check for pointer equality --- before checking for length equality. Getting the length requires deferencing --- the pointers, which could cause accesses to memory that is not in the cache. --- By contrast, a pointer equality check is always extremely cheap. - -appendByteArray :: ByteArray -> ByteArray -> ByteArray -appendByteArray a b = runST $ do - marr <- newByteArray (sizeofByteArray a + sizeofByteArray b) - copyByteArray marr 0 a 0 (sizeofByteArray a) - copyByteArray marr (sizeofByteArray a) b 0 (sizeofByteArray b) - unsafeFreezeByteArray marr - -concatByteArray :: [ByteArray] -> ByteArray -concatByteArray arrs = runST $ do - let len = calcLength arrs 0 - marr <- newByteArray len - pasteByteArrays marr 0 arrs - unsafeFreezeByteArray marr - -pasteByteArrays :: MutableByteArray s -> Int -> [ByteArray] -> ST s () -pasteByteArrays !_ !_ [] = return () -pasteByteArrays !marr !ix (x : xs) = do - copyByteArray marr ix x 0 (sizeofByteArray x) - pasteByteArrays marr (ix + sizeofByteArray x) xs - -calcLength :: [ByteArray] -> Int -> Int -calcLength [] !n = n -calcLength (x : xs) !n = calcLength xs (sizeofByteArray x + n) - -emptyByteArray :: ByteArray -emptyByteArray = runST (newByteArray 0 >>= unsafeFreezeByteArray) - -replicateByteArray :: Int -> ByteArray -> ByteArray -replicateByteArray n arr = runST $ do - marr <- newByteArray (n * sizeofByteArray arr) - let go i = if i < n - then do - copyByteArray marr (i * sizeofByteArray arr) arr 0 (sizeofByteArray arr) - go (i + 1) - else return () - go 0 - unsafeFreezeByteArray marr - -#if MIN_VERSION_base(4,9,0) -instance SG.Semigroup ByteArray where - (<>) = appendByteArray - sconcat = mconcat . F.toList - stimes i arr - | itgr < 1 = emptyByteArray - | itgr <= (fromIntegral (maxBound :: Int)) = replicateByteArray (fromIntegral itgr) arr - | otherwise = error "Data.Primitive.ByteArray#stimes: cannot allocate the requested amount of memory" - where itgr = toInteger i :: Integer -#endif - -instance Monoid ByteArray where - mempty = emptyByteArray -#if !(MIN_VERSION_base(4,11,0)) - mappend = appendByteArray -#endif - mconcat = concatByteArray - -#if __GLASGOW_HASKELL__ >= 708 --- | @since 0.6.3.0 -instance Exts.IsList ByteArray where - type Item ByteArray = Word8 - - toList = foldrByteArray (:) [] - fromList xs = byteArrayFromListN (length xs) xs - fromListN = byteArrayFromListN -#endif - -die :: String -> String -> a -die fun problem = error $ "Data.Primitive.ByteArray." ++ fun ++ ": " ++ problem - diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Compat.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Compat.hs deleted file mode 100644 index f6b8016ad92a..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Compat.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE CPP, MagicHash #-} - --- | --- Module : Data.Primitive.Internal.Compat --- Copyright : (c) Roman Leshchinskiy 2011-2012 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Portability : non-portable --- --- Compatibility functions --- - -module Data.Primitive.Internal.Compat ( - isTrue# - , mkNoRepType - ) where - -#if MIN_VERSION_base(4,2,0) -import Data.Data (mkNoRepType) -#else -import Data.Data (mkNorepType) -#endif - -#if MIN_VERSION_base(4,7,0) -import GHC.Exts (isTrue#) -#endif - - - -#if !MIN_VERSION_base(4,2,0) -mkNoRepType = mkNorepType -#endif - -#if !MIN_VERSION_base(4,7,0) -isTrue# :: Bool -> Bool -isTrue# b = b -#endif diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Operations.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Operations.hs deleted file mode 100644 index 091e11f5d6a9..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Operations.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE MagicHash, UnliftedFFITypes #-} - --- | --- Module : Data.Primitive.Internal.Operations --- Copyright : (c) Roman Leshchinskiy 2011-2012 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Portability : non-portable --- --- Internal operations --- - - -module Data.Primitive.Internal.Operations ( - setWord8Array#, setWord16Array#, setWord32Array#, - setWord64Array#, setWordArray#, - setInt8Array#, setInt16Array#, setInt32Array#, - setInt64Array#, setIntArray#, - setAddrArray#, setFloatArray#, setDoubleArray#, setWideCharArray#, - - setWord8OffAddr#, setWord16OffAddr#, setWord32OffAddr#, - setWord64OffAddr#, setWordOffAddr#, - setInt8OffAddr#, setInt16OffAddr#, setInt32OffAddr#, - setInt64OffAddr#, setIntOffAddr#, - setAddrOffAddr#, setFloatOffAddr#, setDoubleOffAddr#, setWideCharOffAddr# -) where - -import Data.Primitive.MachDeps (Word64_#, Int64_#) -import Foreign.C.Types -import GHC.Prim - -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8" - setWord8Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16" - setWord16Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32" - setWord32Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64" - setWord64Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word64_# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word" - setWordArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8" - setInt8Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16" - setInt16Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32" - setInt32Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64" - setInt64Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int64_# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word" - setIntArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Ptr" - setAddrArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Addr# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Float" - setFloatArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Float# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Double" - setDoubleArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Double# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Char" - setWideCharArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Char# -> IO () - -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8" - setWord8OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16" - setWord16OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32" - setWord32OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64" - setWord64OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word64_# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word" - setWordOffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8" - setInt8OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16" - setInt16OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32" - setInt32OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64" - setInt64OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int64_# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word" - setIntOffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Ptr" - setAddrOffAddr# :: Addr# -> CPtrdiff -> CSize -> Addr# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Float" - setFloatOffAddr# :: Addr# -> CPtrdiff -> CSize -> Float# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Double" - setDoubleOffAddr# :: Addr# -> CPtrdiff -> CSize -> Double# -> IO () -foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Char" - setWideCharOffAddr# :: Addr# -> CPtrdiff -> CSize -> Char# -> IO () - diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MVar.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MVar.hs deleted file mode 100644 index 3c7bfd1fa054..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MVar.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} - --- | --- Module : Data.Primitive.MVar --- License : BSD2 --- Portability : non-portable --- --- Primitive operations on @MVar@. This module provides a similar interface --- to "Control.Concurrent.MVar". However, the functions are generalized to --- work in any 'PrimMonad' instead of only working in 'IO'. Note that all --- of the functions here are completely deterministic. Users of 'MVar' are --- responsible for designing abstractions that guarantee determinism in --- the presence of multi-threading. --- --- @since 0.6.4.0 -module Data.Primitive.MVar - ( MVar(..) - , newMVar - , isEmptyMVar - , newEmptyMVar - , putMVar - , readMVar - , takeMVar - , tryPutMVar - , tryReadMVar - , tryTakeMVar - ) where - -import Control.Monad.Primitive -import Data.Primitive.Internal.Compat (isTrue#) -import GHC.Exts (MVar#,newMVar#,takeMVar#,sameMVar#,putMVar#,tryTakeMVar#, - isEmptyMVar#,tryPutMVar#,(/=#)) - -#if __GLASGOW_HASKELL__ >= 708 -import GHC.Exts (readMVar#,tryReadMVar#) -#endif - -data MVar s a = MVar (MVar# s a) - -instance Eq (MVar s a) where - MVar mvar1# == MVar mvar2# = isTrue# (sameMVar# mvar1# mvar2#) - --- | Create a new 'MVar' that is initially empty. -newEmptyMVar :: PrimMonad m => m (MVar (PrimState m) a) -newEmptyMVar = primitive $ \ s# -> - case newMVar# s# of - (# s2#, svar# #) -> (# s2#, MVar svar# #) - - --- | Create a new 'MVar' that holds the supplied argument. -newMVar :: PrimMonad m => a -> m (MVar (PrimState m) a) -newMVar value = - newEmptyMVar >>= \ mvar -> - putMVar mvar value >> - return mvar - --- | Return the contents of the 'MVar'. If the 'MVar' is currently --- empty, 'takeMVar' will wait until it is full. After a 'takeMVar', --- the 'MVar' is left empty. -takeMVar :: PrimMonad m => MVar (PrimState m) a -> m a -takeMVar (MVar mvar#) = primitive $ \ s# -> takeMVar# mvar# s# - --- | Atomically read the contents of an 'MVar'. If the 'MVar' is --- currently empty, 'readMVar' will wait until it is full. --- 'readMVar' is guaranteed to receive the next 'putMVar'. --- --- /Multiple Wakeup:/ 'readMVar' is multiple-wakeup, so when multiple readers --- are blocked on an 'MVar', all of them are woken up at the same time. --- --- /Compatibility note:/ On GHCs prior to 7.8, 'readMVar' is a combination --- of 'takeMVar' and 'putMVar'. Consequently, its behavior differs in the --- following ways: --- --- * It is single-wakeup instead of multiple-wakeup. --- * It might not receive the value from the next call to 'putMVar' if --- there is already a pending thread blocked on 'takeMVar'. --- * If another thread puts a value in the 'MVar' in between the --- calls to 'takeMVar' and 'putMVar', that value may be overridden. -readMVar :: PrimMonad m => MVar (PrimState m) a -> m a -#if __GLASGOW_HASKELL__ >= 708 -readMVar (MVar mvar#) = primitive $ \ s# -> readMVar# mvar# s# -#else -readMVar mv = do - a <- takeMVar mv - putMVar mv a - return a -#endif - --- |Put a value into an 'MVar'. If the 'MVar' is currently full, --- 'putMVar' will wait until it becomes empty. -putMVar :: PrimMonad m => MVar (PrimState m) a -> a -> m () -putMVar (MVar mvar#) x = primitive_ (putMVar# mvar# x) - --- |A non-blocking version of 'takeMVar'. The 'tryTakeMVar' function --- returns immediately, with 'Nothing' if the 'MVar' was empty, or --- @'Just' a@ if the 'MVar' was full with contents @a@. After 'tryTakeMVar', --- the 'MVar' is left empty. -tryTakeMVar :: PrimMonad m => MVar (PrimState m) a -> m (Maybe a) -tryTakeMVar (MVar m) = primitive $ \ s -> - case tryTakeMVar# m s of - (# s', 0#, _ #) -> (# s', Nothing #) -- MVar is empty - (# s', _, a #) -> (# s', Just a #) -- MVar is full - - --- |A non-blocking version of 'putMVar'. The 'tryPutMVar' function --- attempts to put the value @a@ into the 'MVar', returning 'True' if --- it was successful, or 'False' otherwise. -tryPutMVar :: PrimMonad m => MVar (PrimState m) a -> a -> m Bool -tryPutMVar (MVar mvar#) x = primitive $ \ s# -> - case tryPutMVar# mvar# x s# of - (# s, 0# #) -> (# s, False #) - (# s, _ #) -> (# s, True #) - --- | A non-blocking version of 'readMVar'. The 'tryReadMVar' function --- returns immediately, with 'Nothing' if the 'MVar' was empty, or --- @'Just' a@ if the 'MVar' was full with contents @a@. --- --- /Compatibility note:/ On GHCs prior to 7.8, 'tryReadMVar' is a combination --- of 'tryTakeMVar' and 'putMVar'. Consequently, its behavior differs in the --- following ways: --- --- * It is single-wakeup instead of multiple-wakeup. --- * In the presence of other threads calling 'putMVar', 'tryReadMVar' --- may block. --- * If another thread puts a value in the 'MVar' in between the --- calls to 'tryTakeMVar' and 'putMVar', that value may be overridden. -tryReadMVar :: PrimMonad m => MVar (PrimState m) a -> m (Maybe a) -#if __GLASGOW_HASKELL__ >= 708 -tryReadMVar (MVar m) = primitive $ \ s -> - case tryReadMVar# m s of - (# s', 0#, _ #) -> (# s', Nothing #) -- MVar is empty - (# s', _, a #) -> (# s', Just a #) -- MVar is full -#else -tryReadMVar mv = do - ma <- tryTakeMVar mv - case ma of - Just a -> do - putMVar mv a - return (Just a) - Nothing -> return Nothing -#endif - --- | Check whether a given 'MVar' is empty. --- --- Notice that the boolean value returned is just a snapshot of --- the state of the MVar. By the time you get to react on its result, --- the MVar may have been filled (or emptied) - so be extremely --- careful when using this operation. Use 'tryTakeMVar' instead if possible. -isEmptyMVar :: PrimMonad m => MVar (PrimState m) a -> m Bool -isEmptyMVar (MVar mv#) = primitive $ \ s# -> - case isEmptyMVar# mv# s# of - (# s2#, flg #) -> (# s2#, isTrue# (flg /=# 0#) #) diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MachDeps.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MachDeps.hs deleted file mode 100644 index d36c25236413..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MachDeps.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE CPP, MagicHash #-} --- | --- Module : Data.Primitive.MachDeps --- Copyright : (c) Roman Leshchinskiy 2009-2012 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Portability : non-portable --- --- Machine-dependent constants --- - -module Data.Primitive.MachDeps where - -#include "MachDeps.h" - -import GHC.Prim - -sIZEOF_CHAR, - aLIGNMENT_CHAR, - - sIZEOF_INT, - aLIGNMENT_INT, - - sIZEOF_WORD, - aLIGNMENT_WORD, - - sIZEOF_DOUBLE, - aLIGNMENT_DOUBLE, - - sIZEOF_FLOAT, - aLIGNMENT_FLOAT, - - sIZEOF_PTR, - aLIGNMENT_PTR, - - sIZEOF_FUNPTR, - aLIGNMENT_FUNPTR, - - sIZEOF_STABLEPTR, - aLIGNMENT_STABLEPTR, - - sIZEOF_INT8, - aLIGNMENT_INT8, - - sIZEOF_WORD8, - aLIGNMENT_WORD8, - - sIZEOF_INT16, - aLIGNMENT_INT16, - - sIZEOF_WORD16, - aLIGNMENT_WORD16, - - sIZEOF_INT32, - aLIGNMENT_INT32, - - sIZEOF_WORD32, - aLIGNMENT_WORD32, - - sIZEOF_INT64, - aLIGNMENT_INT64, - - sIZEOF_WORD64, - aLIGNMENT_WORD64 :: Int - - -sIZEOF_CHAR = SIZEOF_HSCHAR -aLIGNMENT_CHAR = ALIGNMENT_HSCHAR - -sIZEOF_INT = SIZEOF_HSINT -aLIGNMENT_INT = ALIGNMENT_HSINT - -sIZEOF_WORD = SIZEOF_HSWORD -aLIGNMENT_WORD = ALIGNMENT_HSWORD - -sIZEOF_DOUBLE = SIZEOF_HSDOUBLE -aLIGNMENT_DOUBLE = ALIGNMENT_HSDOUBLE - -sIZEOF_FLOAT = SIZEOF_HSFLOAT -aLIGNMENT_FLOAT = ALIGNMENT_HSFLOAT - -sIZEOF_PTR = SIZEOF_HSPTR -aLIGNMENT_PTR = ALIGNMENT_HSPTR - -sIZEOF_FUNPTR = SIZEOF_HSFUNPTR -aLIGNMENT_FUNPTR = ALIGNMENT_HSFUNPTR - -sIZEOF_STABLEPTR = SIZEOF_HSSTABLEPTR -aLIGNMENT_STABLEPTR = ALIGNMENT_HSSTABLEPTR - -sIZEOF_INT8 = SIZEOF_INT8 -aLIGNMENT_INT8 = ALIGNMENT_INT8 - -sIZEOF_WORD8 = SIZEOF_WORD8 -aLIGNMENT_WORD8 = ALIGNMENT_WORD8 - -sIZEOF_INT16 = SIZEOF_INT16 -aLIGNMENT_INT16 = ALIGNMENT_INT16 - -sIZEOF_WORD16 = SIZEOF_WORD16 -aLIGNMENT_WORD16 = ALIGNMENT_WORD16 - -sIZEOF_INT32 = SIZEOF_INT32 -aLIGNMENT_INT32 = ALIGNMENT_INT32 - -sIZEOF_WORD32 = SIZEOF_WORD32 -aLIGNMENT_WORD32 = ALIGNMENT_WORD32 - -sIZEOF_INT64 = SIZEOF_INT64 -aLIGNMENT_INT64 = ALIGNMENT_INT64 - -sIZEOF_WORD64 = SIZEOF_WORD64 -aLIGNMENT_WORD64 = ALIGNMENT_WORD64 - -#if WORD_SIZE_IN_BITS == 32 -type Word64_# = Word64# -type Int64_# = Int64# -#else -type Word64_# = Word# -type Int64_# = Int# -#endif - diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MutVar.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MutVar.hs deleted file mode 100644 index f707bfb6308c..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MutVar.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE MagicHash, UnboxedTuples, DeriveDataTypeable #-} - --- | --- Module : Data.Primitive.MutVar --- Copyright : (c) Justin Bonnar 2011, Roman Leshchinskiy 2011-2012 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Portability : non-portable --- --- Primitive boxed mutable variables --- - -module Data.Primitive.MutVar ( - MutVar(..), - - newMutVar, - readMutVar, - writeMutVar, - - atomicModifyMutVar, - atomicModifyMutVar', - modifyMutVar, - modifyMutVar' -) where - -import Control.Monad.Primitive ( PrimMonad(..), primitive_ ) -import GHC.Prim ( MutVar#, sameMutVar#, newMutVar#, - readMutVar#, writeMutVar#, atomicModifyMutVar# ) -import Data.Primitive.Internal.Compat ( isTrue# ) -import Data.Typeable ( Typeable ) - --- | A 'MutVar' behaves like a single-element mutable array associated --- with a primitive state token. -data MutVar s a = MutVar (MutVar# s a) - deriving ( Typeable ) - -instance Eq (MutVar s a) where - MutVar mva# == MutVar mvb# = isTrue# (sameMutVar# mva# mvb#) - --- | Create a new 'MutVar' with the specified initial value -newMutVar :: PrimMonad m => a -> m (MutVar (PrimState m) a) -{-# INLINE newMutVar #-} -newMutVar initialValue = primitive $ \s# -> - case newMutVar# initialValue s# of - (# s'#, mv# #) -> (# s'#, MutVar mv# #) - --- | Read the value of a 'MutVar' -readMutVar :: PrimMonad m => MutVar (PrimState m) a -> m a -{-# INLINE readMutVar #-} -readMutVar (MutVar mv#) = primitive (readMutVar# mv#) - --- | Write a new value into a 'MutVar' -writeMutVar :: PrimMonad m => MutVar (PrimState m) a -> a -> m () -{-# INLINE writeMutVar #-} -writeMutVar (MutVar mv#) newValue = primitive_ (writeMutVar# mv# newValue) - --- | Atomically mutate the contents of a 'MutVar' -atomicModifyMutVar :: PrimMonad m => MutVar (PrimState m) a -> (a -> (a,b)) -> m b -{-# INLINE atomicModifyMutVar #-} -atomicModifyMutVar (MutVar mv#) f = primitive $ atomicModifyMutVar# mv# f - --- | Strict version of 'atomicModifyMutVar'. This forces both the value stored --- in the 'MutVar' as well as the value returned. -atomicModifyMutVar' :: PrimMonad m => MutVar (PrimState m) a -> (a -> (a, b)) -> m b -{-# INLINE atomicModifyMutVar' #-} -atomicModifyMutVar' mv f = do - b <- atomicModifyMutVar mv force - b `seq` return b - where - force x = let (a, b) = f x in (a, a `seq` b) - --- | Mutate the contents of a 'MutVar' -modifyMutVar :: PrimMonad m => MutVar (PrimState m) a -> (a -> a) -> m () -{-# INLINE modifyMutVar #-} -modifyMutVar (MutVar mv#) g = primitive_ $ \s# -> - case readMutVar# mv# s# of - (# s'#, a #) -> writeMutVar# mv# (g a) s'# - --- | Strict version of 'modifyMutVar' -modifyMutVar' :: PrimMonad m => MutVar (PrimState m) a -> (a -> a) -> m () -{-# INLINE modifyMutVar' #-} -modifyMutVar' (MutVar mv#) g = primitive_ $ \s# -> - case readMutVar# mv# s# of - (# s'#, a #) -> let a' = g a in a' `seq` writeMutVar# mv# a' s'# - diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/PrimArray.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/PrimArray.hs deleted file mode 100644 index 33d81c2092ee..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/PrimArray.hs +++ /dev/null @@ -1,969 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} - -{-# OPTIONS_GHC -Wall #-} - --- | --- Module : Data.Primitive.PrimArray --- Copyright : (c) Roman Leshchinskiy 2009-2012 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Portability : non-portable --- --- Arrays of unboxed primitive types. The function provided by this module --- match the behavior of those provided by @Data.Primitive.ByteArray@, and --- the underlying types and primops that back them are the same. --- However, the type constructors 'PrimArray' and 'MutablePrimArray' take one additional --- argument than their respective counterparts 'ByteArray' and 'MutableByteArray'. --- This argument is used to designate the type of element in the array. --- Consequently, all function this modules accepts length and incides in --- terms of elements, not bytes. --- --- @since 0.6.4.0 -module Data.Primitive.PrimArray - ( -- * Types - PrimArray(..) - , MutablePrimArray(..) - -- * Allocation - , newPrimArray - , resizeMutablePrimArray -#if __GLASGOW_HASKELL__ >= 710 - , shrinkMutablePrimArray -#endif - -- * Element Access - , readPrimArray - , writePrimArray - , indexPrimArray - -- * Freezing and Thawing - , unsafeFreezePrimArray - , unsafeThawPrimArray - -- * Block Operations - , copyPrimArray - , copyMutablePrimArray -#if __GLASGOW_HASKELL__ >= 708 - , copyPrimArrayToPtr - , copyMutablePrimArrayToPtr -#endif - , setPrimArray - -- * Information - , sameMutablePrimArray - , getSizeofMutablePrimArray - , sizeofMutablePrimArray - , sizeofPrimArray - -- * List Conversion - , primArrayToList - , primArrayFromList - , primArrayFromListN - -- * Folding - , foldrPrimArray - , foldrPrimArray' - , foldlPrimArray - , foldlPrimArray' - , foldlPrimArrayM' - -- * Effectful Folding - , traversePrimArray_ - , itraversePrimArray_ - -- * Map/Create - , mapPrimArray - , imapPrimArray - , generatePrimArray - , replicatePrimArray - , filterPrimArray - , mapMaybePrimArray - -- * Effectful Map/Create - -- $effectfulMapCreate - -- ** Lazy Applicative - , traversePrimArray - , itraversePrimArray - , generatePrimArrayA - , replicatePrimArrayA - , filterPrimArrayA - , mapMaybePrimArrayA - -- ** Strict Primitive Monadic - , traversePrimArrayP - , itraversePrimArrayP - , generatePrimArrayP - , replicatePrimArrayP - , filterPrimArrayP - , mapMaybePrimArrayP - ) where - -import GHC.Prim -import GHC.Base ( Int(..) ) -import GHC.Exts (build) -import GHC.Ptr -import Data.Primitive.Internal.Compat (isTrue#) -import Data.Primitive.Types -import Data.Primitive.ByteArray (ByteArray(..)) -import Data.Monoid (Monoid(..),(<>)) -import Control.Applicative -import Control.Monad.Primitive -import Control.Monad.ST -import qualified Data.List as L -import qualified Data.Primitive.ByteArray as PB -import qualified Data.Primitive.Types as PT - -#if MIN_VERSION_base(4,7,0) -import GHC.Exts (IsList(..)) -#endif - -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup) -import qualified Data.Semigroup as SG -#endif - --- | Arrays of unboxed elements. This accepts types like 'Double', 'Char', --- 'Int', and 'Word', as well as their fixed-length variants ('Word8', --- 'Word16', etc.). Since the elements are unboxed, a 'PrimArray' is strict --- in its elements. This differs from the behavior of 'Array', which is lazy --- in its elements. -data PrimArray a = PrimArray ByteArray# - --- | Mutable primitive arrays associated with a primitive state token. --- These can be written to and read from in a monadic context that supports --- sequencing such as 'IO' or 'ST'. Typically, a mutable primitive array will --- be built and then convert to an immutable primitive array using --- 'unsafeFreezePrimArray'. However, it is also acceptable to simply discard --- a mutable primitive array since it lives in managed memory and will be --- garbage collected when no longer referenced. -data MutablePrimArray s a = MutablePrimArray (MutableByteArray# s) - -sameByteArray :: ByteArray# -> ByteArray# -> Bool -sameByteArray ba1 ba2 = - case reallyUnsafePtrEquality# (unsafeCoerce# ba1 :: ()) (unsafeCoerce# ba2 :: ()) of -#if __GLASGOW_HASKELL__ >= 708 - r -> isTrue# r -#else - 1# -> True - _ -> False -#endif - --- | @since 0.6.4.0 -instance (Eq a, Prim a) => Eq (PrimArray a) where - a1@(PrimArray ba1#) == a2@(PrimArray ba2#) - | sameByteArray ba1# ba2# = True - | sz1 /= sz2 = False - | otherwise = loop (quot sz1 (sizeOf (undefined :: a)) - 1) - where - -- Here, we take the size in bytes, not in elements. We do this - -- since it allows us to defer performing the division to - -- calculate the size in elements. - sz1 = PB.sizeofByteArray (ByteArray ba1#) - sz2 = PB.sizeofByteArray (ByteArray ba2#) - loop !i - | i < 0 = True - | otherwise = indexPrimArray a1 i == indexPrimArray a2 i && loop (i-1) - --- | Lexicographic ordering. Subject to change between major versions. --- --- @since 0.6.4.0 -instance (Ord a, Prim a) => Ord (PrimArray a) where - compare a1@(PrimArray ba1#) a2@(PrimArray ba2#) - | sameByteArray ba1# ba2# = EQ - | otherwise = loop 0 - where - sz1 = PB.sizeofByteArray (ByteArray ba1#) - sz2 = PB.sizeofByteArray (ByteArray ba2#) - sz = quot (min sz1 sz2) (sizeOf (undefined :: a)) - loop !i - | i < sz = compare (indexPrimArray a1 i) (indexPrimArray a2 i) <> loop (i+1) - | otherwise = compare sz1 sz2 - -#if MIN_VERSION_base(4,7,0) --- | @since 0.6.4.0 -instance Prim a => IsList (PrimArray a) where - type Item (PrimArray a) = a - fromList = primArrayFromList - fromListN = primArrayFromListN - toList = primArrayToList -#endif - --- | @since 0.6.4.0 -instance (Show a, Prim a) => Show (PrimArray a) where - showsPrec p a = showParen (p > 10) $ - showString "fromListN " . shows (sizeofPrimArray a) . showString " " - . shows (primArrayToList a) - -die :: String -> String -> a -die fun problem = error $ "Data.Primitive.PrimArray." ++ fun ++ ": " ++ problem - -primArrayFromList :: Prim a => [a] -> PrimArray a -primArrayFromList vs = primArrayFromListN (L.length vs) vs - -primArrayFromListN :: forall a. Prim a => Int -> [a] -> PrimArray a -primArrayFromListN len vs = runST run where - run :: forall s. ST s (PrimArray a) - run = do - arr <- newPrimArray len - let go :: [a] -> Int -> ST s () - go [] !ix = if ix == len - then return () - else die "fromListN" "list length less than specified size" - go (a : as) !ix = if ix < len - then do - writePrimArray arr ix a - go as (ix + 1) - else die "fromListN" "list length greater than specified size" - go vs 0 - unsafeFreezePrimArray arr - --- | Convert the primitive array to a list. -{-# INLINE primArrayToList #-} -primArrayToList :: forall a. Prim a => PrimArray a -> [a] -primArrayToList xs = build (\c n -> foldrPrimArray c n xs) - -primArrayToByteArray :: PrimArray a -> PB.ByteArray -primArrayToByteArray (PrimArray x) = PB.ByteArray x - -byteArrayToPrimArray :: ByteArray -> PrimArray a -byteArrayToPrimArray (PB.ByteArray x) = PrimArray x - -#if MIN_VERSION_base(4,9,0) --- | @since 0.6.4.0 -instance Semigroup (PrimArray a) where - x <> y = byteArrayToPrimArray (primArrayToByteArray x SG.<> primArrayToByteArray y) - sconcat = byteArrayToPrimArray . SG.sconcat . fmap primArrayToByteArray - stimes i arr = byteArrayToPrimArray (SG.stimes i (primArrayToByteArray arr)) -#endif - --- | @since 0.6.4.0 -instance Monoid (PrimArray a) where - mempty = emptyPrimArray -#if !(MIN_VERSION_base(4,11,0)) - mappend x y = byteArrayToPrimArray (mappend (primArrayToByteArray x) (primArrayToByteArray y)) -#endif - mconcat = byteArrayToPrimArray . mconcat . map primArrayToByteArray - --- | The empty primitive array. -emptyPrimArray :: PrimArray a -{-# NOINLINE emptyPrimArray #-} -emptyPrimArray = runST $ primitive $ \s0# -> case newByteArray# 0# s0# of - (# s1#, arr# #) -> case unsafeFreezeByteArray# arr# s1# of - (# s2#, arr'# #) -> (# s2#, PrimArray arr'# #) - --- | Create a new mutable primitive array of the given length. The --- underlying memory is left uninitialized. -newPrimArray :: forall m a. (PrimMonad m, Prim a) => Int -> m (MutablePrimArray (PrimState m) a) -{-# INLINE newPrimArray #-} -newPrimArray (I# n#) - = primitive (\s# -> - case newByteArray# (n# *# sizeOf# (undefined :: a)) s# of - (# s'#, arr# #) -> (# s'#, MutablePrimArray arr# #) - ) - --- | Resize a mutable primitive array. The new size is given in elements. --- --- This will either resize the array in-place or, if not possible, allocate the --- contents into a new, unpinned array and copy the original array\'s contents. --- --- To avoid undefined behaviour, the original 'MutablePrimArray' shall not be --- accessed anymore after a 'resizeMutablePrimArray' has been performed. --- Moreover, no reference to the old one should be kept in order to allow --- garbage collection of the original 'MutablePrimArray' in case a new --- 'MutablePrimArray' had to be allocated. -resizeMutablePrimArray :: forall m a. (PrimMonad m, Prim a) - => MutablePrimArray (PrimState m) a - -> Int -- ^ new size - -> m (MutablePrimArray (PrimState m) a) -{-# INLINE resizeMutablePrimArray #-} -#if __GLASGOW_HASKELL__ >= 710 -resizeMutablePrimArray (MutablePrimArray arr#) (I# n#) - = primitive (\s# -> case resizeMutableByteArray# arr# (n# *# sizeOf# (undefined :: a)) s# of - (# s'#, arr'# #) -> (# s'#, MutablePrimArray arr'# #)) -#else -resizeMutablePrimArray arr n - = do arr' <- newPrimArray n - copyMutablePrimArray arr' 0 arr 0 (min (sizeofMutablePrimArray arr) n) - return arr' -#endif - --- Although it is possible to shim resizeMutableByteArray for old GHCs, this --- is not the case with shrinkMutablePrimArray. -#if __GLASGOW_HASKELL__ >= 710 --- | Shrink a mutable primitive array. The new size is given in elements. --- It must be smaller than the old size. The array will be resized in place. --- This function is only available when compiling with GHC 7.10 or newer. -shrinkMutablePrimArray :: forall m a. (PrimMonad m, Prim a) - => MutablePrimArray (PrimState m) a - -> Int -- ^ new size - -> m () -{-# INLINE shrinkMutablePrimArray #-} -shrinkMutablePrimArray (MutablePrimArray arr#) (I# n#) - = primitive_ (shrinkMutableByteArray# arr# (n# *# sizeOf# (undefined :: a))) -#endif - -readPrimArray :: (Prim a, PrimMonad m) => MutablePrimArray (PrimState m) a -> Int -> m a -{-# INLINE readPrimArray #-} -readPrimArray (MutablePrimArray arr#) (I# i#) - = primitive (readByteArray# arr# i#) - --- | Write an element to the given index. -writePrimArray :: - (Prim a, PrimMonad m) - => MutablePrimArray (PrimState m) a -- ^ array - -> Int -- ^ index - -> a -- ^ element - -> m () -{-# INLINE writePrimArray #-} -writePrimArray (MutablePrimArray arr#) (I# i#) x - = primitive_ (writeByteArray# arr# i# x) - --- | Copy part of a mutable array into another mutable array. --- In the case that the destination and --- source arrays are the same, the regions may overlap. -copyMutablePrimArray :: forall m a. - (PrimMonad m, Prim a) - => MutablePrimArray (PrimState m) a -- ^ destination array - -> Int -- ^ offset into destination array - -> MutablePrimArray (PrimState m) a -- ^ source array - -> Int -- ^ offset into source array - -> Int -- ^ number of elements to copy - -> m () -{-# INLINE copyMutablePrimArray #-} -copyMutablePrimArray (MutablePrimArray dst#) (I# doff#) (MutablePrimArray src#) (I# soff#) (I# n#) - = primitive_ (copyMutableByteArray# - src# - (soff# *# (sizeOf# (undefined :: a))) - dst# - (doff# *# (sizeOf# (undefined :: a))) - (n# *# (sizeOf# (undefined :: a))) - ) - --- | Copy part of an array into another mutable array. -copyPrimArray :: forall m a. - (PrimMonad m, Prim a) - => MutablePrimArray (PrimState m) a -- ^ destination array - -> Int -- ^ offset into destination array - -> PrimArray a -- ^ source array - -> Int -- ^ offset into source array - -> Int -- ^ number of elements to copy - -> m () -{-# INLINE copyPrimArray #-} -copyPrimArray (MutablePrimArray dst#) (I# doff#) (PrimArray src#) (I# soff#) (I# n#) - = primitive_ (copyByteArray# - src# - (soff# *# (sizeOf# (undefined :: a))) - dst# - (doff# *# (sizeOf# (undefined :: a))) - (n# *# (sizeOf# (undefined :: a))) - ) - -#if __GLASGOW_HASKELL__ >= 708 --- | Copy a slice of an immutable primitive array to an address. --- The offset and length are given in elements of type @a@. --- This function assumes that the 'Prim' instance of @a@ --- agrees with the 'Storable' instance. This function is only --- available when building with GHC 7.8 or newer. -copyPrimArrayToPtr :: forall m a. (PrimMonad m, Prim a) - => Ptr a -- ^ destination pointer - -> PrimArray a -- ^ source array - -> Int -- ^ offset into source array - -> Int -- ^ number of prims to copy - -> m () -{-# INLINE copyPrimArrayToPtr #-} -copyPrimArrayToPtr (Ptr addr#) (PrimArray ba#) (I# soff#) (I# n#) = - primitive (\ s# -> - let s'# = copyByteArrayToAddr# ba# (soff# *# siz#) addr# (n# *# siz#) s# - in (# s'#, () #)) - where siz# = sizeOf# (undefined :: a) - --- | Copy a slice of an immutable primitive array to an address. --- The offset and length are given in elements of type @a@. --- This function assumes that the 'Prim' instance of @a@ --- agrees with the 'Storable' instance. This function is only --- available when building with GHC 7.8 or newer. -copyMutablePrimArrayToPtr :: forall m a. (PrimMonad m, Prim a) - => Ptr a -- ^ destination pointer - -> MutablePrimArray (PrimState m) a -- ^ source array - -> Int -- ^ offset into source array - -> Int -- ^ number of prims to copy - -> m () -{-# INLINE copyMutablePrimArrayToPtr #-} -copyMutablePrimArrayToPtr (Ptr addr#) (MutablePrimArray mba#) (I# soff#) (I# n#) = - primitive (\ s# -> - let s'# = copyMutableByteArrayToAddr# mba# (soff# *# siz#) addr# (n# *# siz#) s# - in (# s'#, () #)) - where siz# = sizeOf# (undefined :: a) -#endif - --- | Fill a slice of a mutable primitive array with a value. -setPrimArray - :: (Prim a, PrimMonad m) - => MutablePrimArray (PrimState m) a -- ^ array to fill - -> Int -- ^ offset into array - -> Int -- ^ number of values to fill - -> a -- ^ value to fill with - -> m () -{-# INLINE setPrimArray #-} -setPrimArray (MutablePrimArray dst#) (I# doff#) (I# sz#) x - = primitive_ (PT.setByteArray# dst# doff# sz# x) - --- | Get the size of a mutable primitive array in elements. Unlike 'sizeofMutablePrimArray', --- this function ensures sequencing in the presence of resizing. -getSizeofMutablePrimArray :: forall m a. (PrimMonad m, Prim a) - => MutablePrimArray (PrimState m) a -- ^ array - -> m Int -{-# INLINE getSizeofMutablePrimArray #-} -#if __GLASGOW_HASKELL__ >= 801 -getSizeofMutablePrimArray (MutablePrimArray arr#) - = primitive (\s# -> - case getSizeofMutableByteArray# arr# s# of - (# s'#, sz# #) -> (# s'#, I# (quotInt# sz# (sizeOf# (undefined :: a))) #) - ) -#else --- On older GHCs, it is not possible to resize a byte array, so --- this provides behavior consistent with the implementation for --- newer GHCs. -getSizeofMutablePrimArray arr - = return (sizeofMutablePrimArray arr) -#endif - --- | Size of the mutable primitive array in elements. This function shall not --- be used on primitive arrays that are an argument to or a result of --- 'resizeMutablePrimArray' or 'shrinkMutablePrimArray'. -sizeofMutablePrimArray :: forall s a. Prim a => MutablePrimArray s a -> Int -{-# INLINE sizeofMutablePrimArray #-} -sizeofMutablePrimArray (MutablePrimArray arr#) = - I# (quotInt# (sizeofMutableByteArray# arr#) (sizeOf# (undefined :: a))) - --- | Check if the two arrays refer to the same memory block. -sameMutablePrimArray :: MutablePrimArray s a -> MutablePrimArray s a -> Bool -{-# INLINE sameMutablePrimArray #-} -sameMutablePrimArray (MutablePrimArray arr#) (MutablePrimArray brr#) - = isTrue# (sameMutableByteArray# arr# brr#) - --- | Convert a mutable byte array to an immutable one without copying. The --- array should not be modified after the conversion. -unsafeFreezePrimArray - :: PrimMonad m => MutablePrimArray (PrimState m) a -> m (PrimArray a) -{-# INLINE unsafeFreezePrimArray #-} -unsafeFreezePrimArray (MutablePrimArray arr#) - = primitive (\s# -> case unsafeFreezeByteArray# arr# s# of - (# s'#, arr'# #) -> (# s'#, PrimArray arr'# #)) - --- | Convert an immutable array to a mutable one without copying. The --- original array should not be used after the conversion. -unsafeThawPrimArray - :: PrimMonad m => PrimArray a -> m (MutablePrimArray (PrimState m) a) -{-# INLINE unsafeThawPrimArray #-} -unsafeThawPrimArray (PrimArray arr#) - = primitive (\s# -> (# s#, MutablePrimArray (unsafeCoerce# arr#) #)) - --- | Read a primitive value from the primitive array. -indexPrimArray :: forall a. Prim a => PrimArray a -> Int -> a -{-# INLINE indexPrimArray #-} -indexPrimArray (PrimArray arr#) (I# i#) = indexByteArray# arr# i# - --- | Get the size, in elements, of the primitive array. -sizeofPrimArray :: forall a. Prim a => PrimArray a -> Int -{-# INLINE sizeofPrimArray #-} -sizeofPrimArray (PrimArray arr#) = I# (quotInt# (sizeofByteArray# arr#) (sizeOf# (undefined :: a))) - --- | Lazy right-associated fold over the elements of a 'PrimArray'. -{-# INLINE foldrPrimArray #-} -foldrPrimArray :: forall a b. Prim a => (a -> b -> b) -> b -> PrimArray a -> b -foldrPrimArray f z arr = go 0 - where - !sz = sizeofPrimArray arr - go !i - | sz > i = f (indexPrimArray arr i) (go (i+1)) - | otherwise = z - --- | Strict right-associated fold over the elements of a 'PrimArray'. -{-# INLINE foldrPrimArray' #-} -foldrPrimArray' :: forall a b. Prim a => (a -> b -> b) -> b -> PrimArray a -> b -foldrPrimArray' f z0 arr = go (sizeofPrimArray arr - 1) z0 - where - go !i !acc - | i < 0 = acc - | otherwise = go (i - 1) (f (indexPrimArray arr i) acc) - --- | Lazy left-associated fold over the elements of a 'PrimArray'. -{-# INLINE foldlPrimArray #-} -foldlPrimArray :: forall a b. Prim a => (b -> a -> b) -> b -> PrimArray a -> b -foldlPrimArray f z arr = go (sizeofPrimArray arr - 1) - where - go !i - | i < 0 = z - | otherwise = f (go (i - 1)) (indexPrimArray arr i) - --- | Strict left-associated fold over the elements of a 'PrimArray'. -{-# INLINE foldlPrimArray' #-} -foldlPrimArray' :: forall a b. Prim a => (b -> a -> b) -> b -> PrimArray a -> b -foldlPrimArray' f z0 arr = go 0 z0 - where - !sz = sizeofPrimArray arr - go !i !acc - | i < sz = go (i + 1) (f acc (indexPrimArray arr i)) - | otherwise = acc - --- | Strict left-associated fold over the elements of a 'PrimArray'. -{-# INLINE foldlPrimArrayM' #-} -foldlPrimArrayM' :: (Prim a, Monad m) => (b -> a -> m b) -> b -> PrimArray a -> m b -foldlPrimArrayM' f z0 arr = go 0 z0 - where - !sz = sizeofPrimArray arr - go !i !acc1 - | i < sz = do - acc2 <- f acc1 (indexPrimArray arr i) - go (i + 1) acc2 - | otherwise = return acc1 - --- | Traverse a primitive array. The traversal forces the resulting values and --- writes them to the new primitive array as it performs the monadic effects. --- Consequently: --- --- >>> traversePrimArrayP (\x -> print x $> bool x undefined (x == 2)) (fromList [1, 2, 3 :: Int]) --- 1 --- 2 --- *** Exception: Prelude.undefined --- --- In many situations, 'traversePrimArrayP' can replace 'traversePrimArray', --- changing the strictness characteristics of the traversal but typically improving --- the performance. Consider the following short-circuiting traversal: --- --- > incrPositiveA :: PrimArray Int -> Maybe (PrimArray Int) --- > incrPositiveA xs = traversePrimArray (\x -> bool Nothing (Just (x + 1)) (x > 0)) xs --- --- This can be rewritten using 'traversePrimArrayP'. To do this, we must --- change the traversal context to @MaybeT (ST s)@, which has a 'PrimMonad' --- instance: --- --- > incrPositiveB :: PrimArray Int -> Maybe (PrimArray Int) --- > incrPositiveB xs = runST $ runMaybeT $ traversePrimArrayP --- > (\x -> bool (MaybeT (return Nothing)) (MaybeT (return (Just (x + 1)))) (x > 0)) --- > xs --- --- Benchmarks demonstrate that the second implementation runs 150 times --- faster than the first. It also results in fewer allocations. -{-# INLINE traversePrimArrayP #-} -traversePrimArrayP :: (PrimMonad m, Prim a, Prim b) - => (a -> m b) - -> PrimArray a - -> m (PrimArray b) -traversePrimArrayP f arr = do - let !sz = sizeofPrimArray arr - marr <- newPrimArray sz - let go !ix = if ix < sz - then do - b <- f (indexPrimArray arr ix) - writePrimArray marr ix b - go (ix + 1) - else return () - go 0 - unsafeFreezePrimArray marr - --- | Filter the primitive array, keeping the elements for which the monadic --- predicate evaluates true. -{-# INLINE filterPrimArrayP #-} -filterPrimArrayP :: (PrimMonad m, Prim a) - => (a -> m Bool) - -> PrimArray a - -> m (PrimArray a) -filterPrimArrayP f arr = do - let !sz = sizeofPrimArray arr - marr <- newPrimArray sz - let go !ixSrc !ixDst = if ixSrc < sz - then do - let a = indexPrimArray arr ixSrc - b <- f a - if b - then do - writePrimArray marr ixDst a - go (ixSrc + 1) (ixDst + 1) - else go (ixSrc + 1) ixDst - else return ixDst - lenDst <- go 0 0 - marr' <- resizeMutablePrimArray marr lenDst - unsafeFreezePrimArray marr' - --- | Map over the primitive array, keeping the elements for which the monadic --- predicate provides a 'Just'. -{-# INLINE mapMaybePrimArrayP #-} -mapMaybePrimArrayP :: (PrimMonad m, Prim a, Prim b) - => (a -> m (Maybe b)) - -> PrimArray a - -> m (PrimArray b) -mapMaybePrimArrayP f arr = do - let !sz = sizeofPrimArray arr - marr <- newPrimArray sz - let go !ixSrc !ixDst = if ixSrc < sz - then do - let a = indexPrimArray arr ixSrc - mb <- f a - case mb of - Just b -> do - writePrimArray marr ixDst b - go (ixSrc + 1) (ixDst + 1) - Nothing -> go (ixSrc + 1) ixDst - else return ixDst - lenDst <- go 0 0 - marr' <- resizeMutablePrimArray marr lenDst - unsafeFreezePrimArray marr' - --- | Generate a primitive array by evaluating the monadic generator function --- at each index. -{-# INLINE generatePrimArrayP #-} -generatePrimArrayP :: (PrimMonad m, Prim a) - => Int -- ^ length - -> (Int -> m a) -- ^ generator - -> m (PrimArray a) -generatePrimArrayP sz f = do - marr <- newPrimArray sz - let go !ix = if ix < sz - then do - b <- f ix - writePrimArray marr ix b - go (ix + 1) - else return () - go 0 - unsafeFreezePrimArray marr - --- | Execute the monadic action the given number of times and store the --- results in a primitive array. -{-# INLINE replicatePrimArrayP #-} -replicatePrimArrayP :: (PrimMonad m, Prim a) - => Int - -> m a - -> m (PrimArray a) -replicatePrimArrayP sz f = do - marr <- newPrimArray sz - let go !ix = if ix < sz - then do - b <- f - writePrimArray marr ix b - go (ix + 1) - else return () - go 0 - unsafeFreezePrimArray marr - - --- | Map over the elements of a primitive array. -{-# INLINE mapPrimArray #-} -mapPrimArray :: (Prim a, Prim b) - => (a -> b) - -> PrimArray a - -> PrimArray b -mapPrimArray f arr = runST $ do - let !sz = sizeofPrimArray arr - marr <- newPrimArray sz - let go !ix = if ix < sz - then do - let b = f (indexPrimArray arr ix) - writePrimArray marr ix b - go (ix + 1) - else return () - go 0 - unsafeFreezePrimArray marr - --- | Indexed map over the elements of a primitive array. -{-# INLINE imapPrimArray #-} -imapPrimArray :: (Prim a, Prim b) - => (Int -> a -> b) - -> PrimArray a - -> PrimArray b -imapPrimArray f arr = runST $ do - let !sz = sizeofPrimArray arr - marr <- newPrimArray sz - let go !ix = if ix < sz - then do - let b = f ix (indexPrimArray arr ix) - writePrimArray marr ix b - go (ix + 1) - else return () - go 0 - unsafeFreezePrimArray marr - --- | Filter elements of a primitive array according to a predicate. -{-# INLINE filterPrimArray #-} -filterPrimArray :: Prim a - => (a -> Bool) - -> PrimArray a - -> PrimArray a -filterPrimArray p arr = runST $ do - let !sz = sizeofPrimArray arr - marr <- newPrimArray sz - let go !ixSrc !ixDst = if ixSrc < sz - then do - let !a = indexPrimArray arr ixSrc - if p a - then do - writePrimArray marr ixDst a - go (ixSrc + 1) (ixDst + 1) - else go (ixSrc + 1) ixDst - else return ixDst - dstLen <- go 0 0 - marr' <- resizeMutablePrimArray marr dstLen - unsafeFreezePrimArray marr' - --- | Filter the primitive array, keeping the elements for which the monadic --- predicate evaluates true. -filterPrimArrayA :: - (Applicative f, Prim a) - => (a -> f Bool) -- ^ mapping function - -> PrimArray a -- ^ primitive array - -> f (PrimArray a) -filterPrimArrayA f = \ !ary -> - let - !len = sizeofPrimArray ary - go !ixSrc - | ixSrc == len = pure $ IxSTA $ \ixDst _ -> return ixDst - | otherwise = let x = indexPrimArray ary ixSrc in - liftA2 - (\keep (IxSTA m) -> IxSTA $ \ixDst mary -> if keep - then writePrimArray (MutablePrimArray mary) ixDst x >> m (ixDst + 1) mary - else m ixDst mary - ) - (f x) - (go (ixSrc + 1)) - in if len == 0 - then pure emptyPrimArray - else runIxSTA len <$> go 0 - --- | Map over the primitive array, keeping the elements for which the applicative --- predicate provides a 'Just'. -mapMaybePrimArrayA :: - (Applicative f, Prim a, Prim b) - => (a -> f (Maybe b)) -- ^ mapping function - -> PrimArray a -- ^ primitive array - -> f (PrimArray b) -mapMaybePrimArrayA f = \ !ary -> - let - !len = sizeofPrimArray ary - go !ixSrc - | ixSrc == len = pure $ IxSTA $ \ixDst _ -> return ixDst - | otherwise = let x = indexPrimArray ary ixSrc in - liftA2 - (\mb (IxSTA m) -> IxSTA $ \ixDst mary -> case mb of - Just b -> writePrimArray (MutablePrimArray mary) ixDst b >> m (ixDst + 1) mary - Nothing -> m ixDst mary - ) - (f x) - (go (ixSrc + 1)) - in if len == 0 - then pure emptyPrimArray - else runIxSTA len <$> go 0 - --- | Map over a primitive array, optionally discarding some elements. This --- has the same behavior as @Data.Maybe.mapMaybe@. -{-# INLINE mapMaybePrimArray #-} -mapMaybePrimArray :: (Prim a, Prim b) - => (a -> Maybe b) - -> PrimArray a - -> PrimArray b -mapMaybePrimArray p arr = runST $ do - let !sz = sizeofPrimArray arr - marr <- newPrimArray sz - let go !ixSrc !ixDst = if ixSrc < sz - then do - let !a = indexPrimArray arr ixSrc - case p a of - Just b -> do - writePrimArray marr ixDst b - go (ixSrc + 1) (ixDst + 1) - Nothing -> go (ixSrc + 1) ixDst - else return ixDst - dstLen <- go 0 0 - marr' <- resizeMutablePrimArray marr dstLen - unsafeFreezePrimArray marr' - - --- | Traverse a primitive array. The traversal performs all of the applicative --- effects /before/ forcing the resulting values and writing them to the new --- primitive array. Consequently: --- --- >>> traversePrimArray (\x -> print x $> bool x undefined (x == 2)) (fromList [1, 2, 3 :: Int]) --- 1 --- 2 --- 3 --- *** Exception: Prelude.undefined --- --- The function 'traversePrimArrayP' always outperforms this function, but it --- requires a 'PrimAffineMonad' constraint, and it forces the values as --- it performs the effects. -traversePrimArray :: - (Applicative f, Prim a, Prim b) - => (a -> f b) -- ^ mapping function - -> PrimArray a -- ^ primitive array - -> f (PrimArray b) -traversePrimArray f = \ !ary -> - let - !len = sizeofPrimArray ary - go !i - | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary) - | x <- indexPrimArray ary i - = liftA2 (\b (STA m) -> STA $ \mary -> - writePrimArray (MutablePrimArray mary) i b >> m mary) - (f x) (go (i + 1)) - in if len == 0 - then pure emptyPrimArray - else runSTA len <$> go 0 - --- | Traverse a primitive array with the index of each element. -itraversePrimArray :: - (Applicative f, Prim a, Prim b) - => (Int -> a -> f b) - -> PrimArray a - -> f (PrimArray b) -itraversePrimArray f = \ !ary -> - let - !len = sizeofPrimArray ary - go !i - | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary) - | x <- indexPrimArray ary i - = liftA2 (\b (STA m) -> STA $ \mary -> - writePrimArray (MutablePrimArray mary) i b >> m mary) - (f i x) (go (i + 1)) - in if len == 0 - then pure emptyPrimArray - else runSTA len <$> go 0 - --- | Traverse a primitive array with the indices. The traversal forces the --- resulting values and writes them to the new primitive array as it performs --- the monadic effects. -{-# INLINE itraversePrimArrayP #-} -itraversePrimArrayP :: (Prim a, Prim b, PrimMonad m) - => (Int -> a -> m b) - -> PrimArray a - -> m (PrimArray b) -itraversePrimArrayP f arr = do - let !sz = sizeofPrimArray arr - marr <- newPrimArray sz - let go !ix - | ix < sz = do - writePrimArray marr ix =<< f ix (indexPrimArray arr ix) - go (ix + 1) - | otherwise = return () - go 0 - unsafeFreezePrimArray marr - --- | Generate a primitive array. -{-# INLINE generatePrimArray #-} -generatePrimArray :: Prim a - => Int -- ^ length - -> (Int -> a) -- ^ element from index - -> PrimArray a -generatePrimArray len f = runST $ do - marr <- newPrimArray len - let go !ix = if ix < len - then do - writePrimArray marr ix (f ix) - go (ix + 1) - else return () - go 0 - unsafeFreezePrimArray marr - --- | Create a primitive array by copying the element the given --- number of times. -{-# INLINE replicatePrimArray #-} -replicatePrimArray :: Prim a - => Int -- ^ length - -> a -- ^ element - -> PrimArray a -replicatePrimArray len a = runST $ do - marr <- newPrimArray len - setPrimArray marr 0 len a - unsafeFreezePrimArray marr - --- | Generate a primitive array by evaluating the applicative generator --- function at each index. -{-# INLINE generatePrimArrayA #-} -generatePrimArrayA :: - (Applicative f, Prim a) - => Int -- ^ length - -> (Int -> f a) -- ^ element from index - -> f (PrimArray a) -generatePrimArrayA len f = - let - go !i - | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary) - | otherwise - = liftA2 (\b (STA m) -> STA $ \mary -> - writePrimArray (MutablePrimArray mary) i b >> m mary) - (f i) (go (i + 1)) - in if len == 0 - then pure emptyPrimArray - else runSTA len <$> go 0 - --- | Execute the applicative action the given number of times and store the --- results in a vector. -{-# INLINE replicatePrimArrayA #-} -replicatePrimArrayA :: - (Applicative f, Prim a) - => Int -- ^ length - -> f a -- ^ applicative element producer - -> f (PrimArray a) -replicatePrimArrayA len f = - let - go !i - | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary) - | otherwise - = liftA2 (\b (STA m) -> STA $ \mary -> - writePrimArray (MutablePrimArray mary) i b >> m mary) - f (go (i + 1)) - in if len == 0 - then pure emptyPrimArray - else runSTA len <$> go 0 - --- | Traverse the primitive array, discarding the results. There --- is no 'PrimMonad' variant of this function since it would not provide --- any performance benefit. -traversePrimArray_ :: - (Applicative f, Prim a) - => (a -> f b) - -> PrimArray a - -> f () -traversePrimArray_ f a = go 0 where - !sz = sizeofPrimArray a - go !ix = if ix < sz - then f (indexPrimArray a ix) *> go (ix + 1) - else pure () - --- | Traverse the primitive array with the indices, discarding the results. --- There is no 'PrimMonad' variant of this function since it would not --- provide any performance benefit. -itraversePrimArray_ :: - (Applicative f, Prim a) - => (Int -> a -> f b) - -> PrimArray a - -> f () -itraversePrimArray_ f a = go 0 where - !sz = sizeofPrimArray a - go !ix = if ix < sz - then f ix (indexPrimArray a ix) *> go (ix + 1) - else pure () - -newtype IxSTA a = IxSTA {_runIxSTA :: forall s. Int -> MutableByteArray# s -> ST s Int} - -runIxSTA :: forall a. Prim a - => Int -- maximum possible size - -> IxSTA a - -> PrimArray a -runIxSTA !szUpper = \ (IxSTA m) -> runST $ do - ar :: MutablePrimArray s a <- newPrimArray szUpper - sz <- m 0 (unMutablePrimArray ar) - ar' <- resizeMutablePrimArray ar sz - unsafeFreezePrimArray ar' -{-# INLINE runIxSTA #-} - -newtype STA a = STA {_runSTA :: forall s. MutableByteArray# s -> ST s (PrimArray a)} - -runSTA :: forall a. Prim a => Int -> STA a -> PrimArray a -runSTA !sz = \ (STA m) -> runST $ newPrimArray sz >>= \ (ar :: MutablePrimArray s a) -> m (unMutablePrimArray ar) -{-# INLINE runSTA #-} - -unMutablePrimArray :: MutablePrimArray s a -> MutableByteArray# s -unMutablePrimArray (MutablePrimArray m) = m - -{- $effectfulMapCreate -The naming conventions adopted in this section are explained in the -documentation of the @Data.Primitive@ module. --} - - diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Ptr.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Ptr.hs deleted file mode 100644 index d93ae9ac114d..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Ptr.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | --- Module : Data.Primitive.Ptr --- Copyright : (c) Roman Leshchinskiy 2009-2012 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Portability : non-portable --- --- Primitive operations on machine addresses --- --- @since 0.6.4.0 - -module Data.Primitive.Ptr ( - -- * Types - Ptr(..), - - -- * Address arithmetic - nullPtr, advancePtr, subtractPtr, - - -- * Element access - indexOffPtr, readOffPtr, writeOffPtr, - - -- * Block operations - copyPtr, movePtr, setPtr - -#if __GLASGOW_HASKELL__ >= 708 - , copyPtrToMutablePrimArray -#endif -) where - -import Control.Monad.Primitive -import Data.Primitive.Types -#if __GLASGOW_HASKELL__ >= 708 -import Data.Primitive.PrimArray (MutablePrimArray(..)) -#endif - -import GHC.Base ( Int(..) ) -import GHC.Prim - -import GHC.Ptr -import Foreign.Marshal.Utils - - --- | Offset a pointer by the given number of elements. -advancePtr :: forall a. Prim a => Ptr a -> Int -> Ptr a -{-# INLINE advancePtr #-} -advancePtr (Ptr a#) (I# i#) = Ptr (plusAddr# a# (i# *# sizeOf# (undefined :: a))) - --- | Subtract a pointer from another pointer. The result represents --- the number of elements of type @a@ that fit in the contiguous --- memory range bounded by these two pointers. -subtractPtr :: forall a. Prim a => Ptr a -> Ptr a -> Int -{-# INLINE subtractPtr #-} -subtractPtr (Ptr a#) (Ptr b#) = I# (quotInt# (minusAddr# a# b#) (sizeOf# (undefined :: a))) - --- | Read a value from a memory position given by a pointer and an offset. --- The memory block the address refers to must be immutable. The offset is in --- elements of type @a@ rather than in bytes. -indexOffPtr :: Prim a => Ptr a -> Int -> a -{-# INLINE indexOffPtr #-} -indexOffPtr (Ptr addr#) (I# i#) = indexOffAddr# addr# i# - --- | Read a value from a memory position given by an address and an offset. --- The offset is in elements of type @a@ rather than in bytes. -readOffPtr :: (Prim a, PrimMonad m) => Ptr a -> Int -> m a -{-# INLINE readOffPtr #-} -readOffPtr (Ptr addr#) (I# i#) = primitive (readOffAddr# addr# i#) - --- | Write a value to a memory position given by an address and an offset. --- The offset is in elements of type @a@ rather than in bytes. -writeOffPtr :: (Prim a, PrimMonad m) => Ptr a -> Int -> a -> m () -{-# INLINE writeOffPtr #-} -writeOffPtr (Ptr addr#) (I# i#) x = primitive_ (writeOffAddr# addr# i# x) - --- | Copy the given number of elements from the second 'Ptr' to the first. The --- areas may not overlap. -copyPtr :: forall m a. (PrimMonad m, Prim a) - => Ptr a -- ^ destination pointer - -> Ptr a -- ^ source pointer - -> Int -- ^ number of elements - -> m () -{-# INLINE copyPtr #-} -copyPtr (Ptr dst#) (Ptr src#) n - = unsafePrimToPrim $ copyBytes (Ptr dst#) (Ptr src#) (n * sizeOf (undefined :: a)) - --- | Copy the given number of elements from the second 'Ptr' to the first. The --- areas may overlap. -movePtr :: forall m a. (PrimMonad m, Prim a) - => Ptr a -- ^ destination address - -> Ptr a -- ^ source address - -> Int -- ^ number of elements - -> m () -{-# INLINE movePtr #-} -movePtr (Ptr dst#) (Ptr src#) n - = unsafePrimToPrim $ moveBytes (Ptr dst#) (Ptr src#) (n * sizeOf (undefined :: a)) - --- | Fill a memory block with the given value. The length is in --- elements of type @a@ rather than in bytes. -setPtr :: (Prim a, PrimMonad m) => Ptr a -> Int -> a -> m () -{-# INLINE setPtr #-} -setPtr (Ptr addr#) (I# n#) x = primitive_ (setOffAddr# addr# 0# n# x) - - -#if __GLASGOW_HASKELL__ >= 708 --- | Copy from a pointer to a mutable primitive array. --- The offset and length are given in elements of type @a@. --- This function is only available when building with GHC 7.8 --- or newer. -copyPtrToMutablePrimArray :: forall m a. (PrimMonad m, Prim a) - => MutablePrimArray (PrimState m) a -- ^ destination array - -> Int -- ^ destination offset - -> Ptr a -- ^ source pointer - -> Int -- ^ number of elements - -> m () -{-# INLINE copyPtrToMutablePrimArray #-} -copyPtrToMutablePrimArray (MutablePrimArray ba#) (I# doff#) (Ptr addr#) (I# n#) = - primitive_ (copyAddrToByteArray# addr# ba# (doff# *# siz#) (n# *# siz#)) - where - siz# = sizeOf# (undefined :: a) -#endif diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/SmallArray.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/SmallArray.hs deleted file mode 100644 index 3a50cf218380..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/SmallArray.hs +++ /dev/null @@ -1,967 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE BangPatterns #-} - --- | --- Module : Data.Primitive.SmallArray --- Copyright: (c) 2015 Dan Doel --- License: BSD3 --- --- Maintainer: libraries@haskell.org --- Portability: non-portable --- --- Small arrays are boxed (im)mutable arrays. --- --- The underlying structure of the 'Array' type contains a card table, allowing --- segments of the array to be marked as having been mutated. This allows the --- garbage collector to only re-traverse segments of the array that have been --- marked during certain phases, rather than having to traverse the entire --- array. --- --- 'SmallArray' lacks this table. This means that it takes up less memory and --- has slightly faster writes. It is also more efficient during garbage --- collection so long as the card table would have a single entry covering the --- entire array. These advantages make them suitable for use as arrays that are --- known to be small. --- --- The card size is 128, so for uses much larger than that, 'Array' would likely --- be superior. --- --- The underlying type, 'SmallArray#', was introduced in GHC 7.10, so prior to --- that version, this module simply implements small arrays as 'Array'. - -module Data.Primitive.SmallArray - ( SmallArray(..) - , SmallMutableArray(..) - , newSmallArray - , readSmallArray - , writeSmallArray - , copySmallArray - , copySmallMutableArray - , indexSmallArray - , indexSmallArrayM - , indexSmallArray## - , cloneSmallArray - , cloneSmallMutableArray - , freezeSmallArray - , unsafeFreezeSmallArray - , thawSmallArray - , runSmallArray - , unsafeThawSmallArray - , sizeofSmallArray - , sizeofSmallMutableArray - , smallArrayFromList - , smallArrayFromListN - , mapSmallArray' - , traverseSmallArrayP - ) where - - -#if (__GLASGOW_HASKELL__ >= 710) -#define HAVE_SMALL_ARRAY 1 -#endif - -#if MIN_VERSION_base(4,7,0) -import GHC.Exts hiding (toList) -import qualified GHC.Exts -#endif - -import Control.Applicative -import Control.Monad -import Control.Monad.Fix -import Control.Monad.Primitive -import Control.Monad.ST -import Control.Monad.Zip -import Data.Data -import Data.Foldable as Foldable -import Data.Functor.Identity -#if !(MIN_VERSION_base(4,10,0)) -import Data.Monoid -#endif -#if MIN_VERSION_base(4,9,0) -import qualified GHC.ST as GHCST -import qualified Data.Semigroup as Sem -#endif -import Text.ParserCombinators.ReadP -#if MIN_VERSION_base(4,10,0) -import GHC.Exts (runRW#) -#elif MIN_VERSION_base(4,9,0) -import GHC.Base (runRW#) -#endif - -#if !(HAVE_SMALL_ARRAY) -import Data.Primitive.Array -import Data.Traversable -import qualified Data.Primitive.Array as Array -#endif - -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) -import Data.Functor.Classes (Eq1(..),Ord1(..),Show1(..),Read1(..)) -#endif - -#if HAVE_SMALL_ARRAY -data SmallArray a = SmallArray (SmallArray# a) - deriving Typeable -#else -newtype SmallArray a = SmallArray (Array a) deriving - ( Eq - , Ord - , Show - , Read - , Foldable - , Traversable - , Functor - , Applicative - , Alternative - , Monad - , MonadPlus - , MonadZip - , MonadFix - , Monoid - , Typeable -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) - , Eq1 - , Ord1 - , Show1 - , Read1 -#endif - ) - -#if MIN_VERSION_base(4,7,0) -instance IsList (SmallArray a) where - type Item (SmallArray a) = a - fromListN n l = SmallArray (fromListN n l) - fromList l = SmallArray (fromList l) - toList a = Foldable.toList a -#endif -#endif - -#if HAVE_SMALL_ARRAY -data SmallMutableArray s a = SmallMutableArray (SmallMutableArray# s a) - deriving Typeable -#else -newtype SmallMutableArray s a = SmallMutableArray (MutableArray s a) - deriving (Eq, Typeable) -#endif - --- | Create a new small mutable array. -newSmallArray - :: PrimMonad m - => Int -- ^ size - -> a -- ^ initial contents - -> m (SmallMutableArray (PrimState m) a) -#if HAVE_SMALL_ARRAY -newSmallArray (I# i#) x = primitive $ \s -> - case newSmallArray# i# x s of - (# s', sma# #) -> (# s', SmallMutableArray sma# #) -#else -newSmallArray n e = SmallMutableArray `liftM` newArray n e -#endif -{-# INLINE newSmallArray #-} - --- | Read the element at a given index in a mutable array. -readSmallArray - :: PrimMonad m - => SmallMutableArray (PrimState m) a -- ^ array - -> Int -- ^ index - -> m a -#if HAVE_SMALL_ARRAY -readSmallArray (SmallMutableArray sma#) (I# i#) = - primitive $ readSmallArray# sma# i# -#else -readSmallArray (SmallMutableArray a) = readArray a -#endif -{-# INLINE readSmallArray #-} - --- | Write an element at the given idex in a mutable array. -writeSmallArray - :: PrimMonad m - => SmallMutableArray (PrimState m) a -- ^ array - -> Int -- ^ index - -> a -- ^ new element - -> m () -#if HAVE_SMALL_ARRAY -writeSmallArray (SmallMutableArray sma#) (I# i#) x = - primitive_ $ writeSmallArray# sma# i# x -#else -writeSmallArray (SmallMutableArray a) = writeArray a -#endif -{-# INLINE writeSmallArray #-} - --- | Look up an element in an immutable array. --- --- The purpose of returning a result using a monad is to allow the caller to --- avoid retaining references to the array. Evaluating the return value will --- cause the array lookup to be performed, even though it may not require the --- element of the array to be evaluated (which could throw an exception). For --- instance: --- --- > data Box a = Box a --- > ... --- > --- > f sa = case indexSmallArrayM sa 0 of --- > Box x -> ... --- --- 'x' is not a closure that references 'sa' as it would be if we instead --- wrote: --- --- > let x = indexSmallArray sa 0 --- --- And does not prevent 'sa' from being garbage collected. --- --- Note that 'Identity' is not adequate for this use, as it is a newtype, and --- cannot be evaluated without evaluating the element. -indexSmallArrayM - :: Monad m - => SmallArray a -- ^ array - -> Int -- ^ index - -> m a -#if HAVE_SMALL_ARRAY -indexSmallArrayM (SmallArray sa#) (I# i#) = - case indexSmallArray# sa# i# of - (# x #) -> pure x -#else -indexSmallArrayM (SmallArray a) = indexArrayM a -#endif -{-# INLINE indexSmallArrayM #-} - --- | Look up an element in an immutable array. -indexSmallArray - :: SmallArray a -- ^ array - -> Int -- ^ index - -> a -#if HAVE_SMALL_ARRAY -indexSmallArray sa i = runIdentity $ indexSmallArrayM sa i -#else -indexSmallArray (SmallArray a) = indexArray a -#endif -{-# INLINE indexSmallArray #-} - --- | Read a value from the immutable array at the given index, returning --- the result in an unboxed unary tuple. This is currently used to implement --- folds. -indexSmallArray## :: SmallArray a -> Int -> (# a #) -#if HAVE_SMALL_ARRAY -indexSmallArray## (SmallArray ary) (I# i) = indexSmallArray# ary i -#else -indexSmallArray## (SmallArray a) = indexArray## a -#endif -{-# INLINE indexSmallArray## #-} - --- | Create a copy of a slice of an immutable array. -cloneSmallArray - :: SmallArray a -- ^ source - -> Int -- ^ offset - -> Int -- ^ length - -> SmallArray a -#if HAVE_SMALL_ARRAY -cloneSmallArray (SmallArray sa#) (I# i#) (I# j#) = - SmallArray (cloneSmallArray# sa# i# j#) -#else -cloneSmallArray (SmallArray a) i j = SmallArray $ cloneArray a i j -#endif -{-# INLINE cloneSmallArray #-} - --- | Create a copy of a slice of a mutable array. -cloneSmallMutableArray - :: PrimMonad m - => SmallMutableArray (PrimState m) a -- ^ source - -> Int -- ^ offset - -> Int -- ^ length - -> m (SmallMutableArray (PrimState m) a) -#if HAVE_SMALL_ARRAY -cloneSmallMutableArray (SmallMutableArray sma#) (I# o#) (I# l#) = - primitive $ \s -> case cloneSmallMutableArray# sma# o# l# s of - (# s', smb# #) -> (# s', SmallMutableArray smb# #) -#else -cloneSmallMutableArray (SmallMutableArray ma) i j = - SmallMutableArray `liftM` cloneMutableArray ma i j -#endif -{-# INLINE cloneSmallMutableArray #-} - --- | Create an immutable array corresponding to a slice of a mutable array. --- --- This operation copies the portion of the array to be frozen. -freezeSmallArray - :: PrimMonad m - => SmallMutableArray (PrimState m) a -- ^ source - -> Int -- ^ offset - -> Int -- ^ length - -> m (SmallArray a) -#if HAVE_SMALL_ARRAY -freezeSmallArray (SmallMutableArray sma#) (I# i#) (I# j#) = - primitive $ \s -> case freezeSmallArray# sma# i# j# s of - (# s', sa# #) -> (# s', SmallArray sa# #) -#else -freezeSmallArray (SmallMutableArray ma) i j = - SmallArray `liftM` freezeArray ma i j -#endif -{-# INLINE freezeSmallArray #-} - --- | Render a mutable array immutable. --- --- This operation performs no copying, so care must be taken not to modify the --- input array after freezing. -unsafeFreezeSmallArray - :: PrimMonad m => SmallMutableArray (PrimState m) a -> m (SmallArray a) -#if HAVE_SMALL_ARRAY -unsafeFreezeSmallArray (SmallMutableArray sma#) = - primitive $ \s -> case unsafeFreezeSmallArray# sma# s of - (# s', sa# #) -> (# s', SmallArray sa# #) -#else -unsafeFreezeSmallArray (SmallMutableArray ma) = - SmallArray `liftM` unsafeFreezeArray ma -#endif -{-# INLINE unsafeFreezeSmallArray #-} - --- | Create a mutable array corresponding to a slice of an immutable array. --- --- This operation copies the portion of the array to be thawed. -thawSmallArray - :: PrimMonad m - => SmallArray a -- ^ source - -> Int -- ^ offset - -> Int -- ^ length - -> m (SmallMutableArray (PrimState m) a) -#if HAVE_SMALL_ARRAY -thawSmallArray (SmallArray sa#) (I# o#) (I# l#) = - primitive $ \s -> case thawSmallArray# sa# o# l# s of - (# s', sma# #) -> (# s', SmallMutableArray sma# #) -#else -thawSmallArray (SmallArray a) off len = - SmallMutableArray `liftM` thawArray a off len -#endif -{-# INLINE thawSmallArray #-} - --- | Render an immutable array mutable. --- --- This operation performs no copying, so care must be taken with its use. -unsafeThawSmallArray - :: PrimMonad m => SmallArray a -> m (SmallMutableArray (PrimState m) a) -#if HAVE_SMALL_ARRAY -unsafeThawSmallArray (SmallArray sa#) = - primitive $ \s -> case unsafeThawSmallArray# sa# s of - (# s', sma# #) -> (# s', SmallMutableArray sma# #) -#else -unsafeThawSmallArray (SmallArray a) = SmallMutableArray `liftM` unsafeThawArray a -#endif -{-# INLINE unsafeThawSmallArray #-} - --- | Copy a slice of an immutable array into a mutable array. -copySmallArray - :: PrimMonad m - => SmallMutableArray (PrimState m) a -- ^ destination - -> Int -- ^ destination offset - -> SmallArray a -- ^ source - -> Int -- ^ source offset - -> Int -- ^ length - -> m () -#if HAVE_SMALL_ARRAY -copySmallArray - (SmallMutableArray dst#) (I# do#) (SmallArray src#) (I# so#) (I# l#) = - primitive_ $ copySmallArray# src# so# dst# do# l# -#else -copySmallArray (SmallMutableArray dst) i (SmallArray src) = copyArray dst i src -#endif -{-# INLINE copySmallArray #-} - --- | Copy a slice of one mutable array into another. -copySmallMutableArray - :: PrimMonad m - => SmallMutableArray (PrimState m) a -- ^ destination - -> Int -- ^ destination offset - -> SmallMutableArray (PrimState m) a -- ^ source - -> Int -- ^ source offset - -> Int -- ^ length - -> m () -#if HAVE_SMALL_ARRAY -copySmallMutableArray - (SmallMutableArray dst#) (I# do#) - (SmallMutableArray src#) (I# so#) - (I# l#) = - primitive_ $ copySmallMutableArray# src# so# dst# do# l# -#else -copySmallMutableArray (SmallMutableArray dst) i (SmallMutableArray src) = - copyMutableArray dst i src -#endif -{-# INLINE copySmallMutableArray #-} - -sizeofSmallArray :: SmallArray a -> Int -#if HAVE_SMALL_ARRAY -sizeofSmallArray (SmallArray sa#) = I# (sizeofSmallArray# sa#) -#else -sizeofSmallArray (SmallArray a) = sizeofArray a -#endif -{-# INLINE sizeofSmallArray #-} - -sizeofSmallMutableArray :: SmallMutableArray s a -> Int -#if HAVE_SMALL_ARRAY -sizeofSmallMutableArray (SmallMutableArray sa#) = - I# (sizeofSmallMutableArray# sa#) -#else -sizeofSmallMutableArray (SmallMutableArray ma) = sizeofMutableArray ma -#endif -{-# INLINE sizeofSmallMutableArray #-} - --- | This is the fastest, most straightforward way to traverse --- an array, but it only works correctly with a sufficiently --- "affine" 'PrimMonad' instance. In particular, it must only produce --- *one* result array. 'Control.Monad.Trans.List.ListT'-transformed --- monads, for example, will not work right at all. -traverseSmallArrayP - :: PrimMonad m - => (a -> m b) - -> SmallArray a - -> m (SmallArray b) -#if HAVE_SMALL_ARRAY -traverseSmallArrayP f = \ !ary -> - let - !sz = sizeofSmallArray ary - go !i !mary - | i == sz - = unsafeFreezeSmallArray mary - | otherwise - = do - a <- indexSmallArrayM ary i - b <- f a - writeSmallArray mary i b - go (i + 1) mary - in do - mary <- newSmallArray sz badTraverseValue - go 0 mary -#else -traverseSmallArrayP f (SmallArray ar) = SmallArray `liftM` traverseArrayP f ar -#endif -{-# INLINE traverseSmallArrayP #-} - --- | Strict map over the elements of the array. -mapSmallArray' :: (a -> b) -> SmallArray a -> SmallArray b -#if HAVE_SMALL_ARRAY -mapSmallArray' f sa = createSmallArray (length sa) (die "mapSmallArray'" "impossible") $ \smb -> - fix ? 0 $ \go i -> - when (i < length sa) $ do - x <- indexSmallArrayM sa i - let !y = f x - writeSmallArray smb i y *> go (i+1) -#else -mapSmallArray' f (SmallArray ar) = SmallArray (mapArray' f ar) -#endif -{-# INLINE mapSmallArray' #-} - -#ifndef HAVE_SMALL_ARRAY -runSmallArray - :: (forall s. ST s (SmallMutableArray s a)) - -> SmallArray a -runSmallArray m = SmallArray $ runArray $ - m >>= \(SmallMutableArray mary) -> return mary - -#elif !MIN_VERSION_base(4,9,0) -runSmallArray - :: (forall s. ST s (SmallMutableArray s a)) - -> SmallArray a -runSmallArray m = runST $ m >>= unsafeFreezeSmallArray - -#else --- This low-level business is designed to work with GHC's worker-wrapper --- transformation. A lot of the time, we don't actually need an Array --- constructor. By putting it on the outside, and being careful about --- how we special-case the empty array, we can make GHC smarter about this. --- The only downside is that separately created 0-length arrays won't share --- their Array constructors, although they'll share their underlying --- Array#s. -runSmallArray - :: (forall s. ST s (SmallMutableArray s a)) - -> SmallArray a -runSmallArray m = SmallArray (runSmallArray# m) - -runSmallArray# - :: (forall s. ST s (SmallMutableArray s a)) - -> SmallArray# a -runSmallArray# m = case runRW# $ \s -> - case unST m s of { (# s', SmallMutableArray mary# #) -> - unsafeFreezeSmallArray# mary# s'} of (# _, ary# #) -> ary# - -unST :: ST s a -> State# s -> (# State# s, a #) -unST (GHCST.ST f) = f - -#endif - -#if HAVE_SMALL_ARRAY --- See the comment on runSmallArray for why we use emptySmallArray#. -createSmallArray - :: Int - -> a - -> (forall s. SmallMutableArray s a -> ST s ()) - -> SmallArray a -createSmallArray 0 _ _ = SmallArray (emptySmallArray# (# #)) -createSmallArray n x f = runSmallArray $ do - mary <- newSmallArray n x - f mary - pure mary - -emptySmallArray# :: (# #) -> SmallArray# a -emptySmallArray# _ = case emptySmallArray of SmallArray ar -> ar -{-# NOINLINE emptySmallArray# #-} - -die :: String -> String -> a -die fun problem = error $ "Data.Primitive.SmallArray." ++ fun ++ ": " ++ problem - -emptySmallArray :: SmallArray a -emptySmallArray = - runST $ newSmallArray 0 (die "emptySmallArray" "impossible") - >>= unsafeFreezeSmallArray -{-# NOINLINE emptySmallArray #-} - - -infixl 1 ? -(?) :: (a -> b -> c) -> (b -> a -> c) -(?) = flip -{-# INLINE (?) #-} - -noOp :: a -> ST s () -noOp = const $ pure () - -smallArrayLiftEq :: (a -> b -> Bool) -> SmallArray a -> SmallArray b -> Bool -smallArrayLiftEq p sa1 sa2 = length sa1 == length sa2 && loop (length sa1 - 1) - where - loop i - | i < 0 - = True - | (# x #) <- indexSmallArray## sa1 i - , (# y #) <- indexSmallArray## sa2 i - = p x y && loop (i-1) - -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) --- | @since 0.6.4.0 -instance Eq1 SmallArray where -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) - liftEq = smallArrayLiftEq -#else - eq1 = smallArrayLiftEq (==) -#endif -#endif - -instance Eq a => Eq (SmallArray a) where - sa1 == sa2 = smallArrayLiftEq (==) sa1 sa2 - -instance Eq (SmallMutableArray s a) where - SmallMutableArray sma1# == SmallMutableArray sma2# = - isTrue# (sameSmallMutableArray# sma1# sma2#) - -smallArrayLiftCompare :: (a -> b -> Ordering) -> SmallArray a -> SmallArray b -> Ordering -smallArrayLiftCompare elemCompare a1 a2 = loop 0 - where - mn = length a1 `min` length a2 - loop i - | i < mn - , (# x1 #) <- indexSmallArray## a1 i - , (# x2 #) <- indexSmallArray## a2 i - = elemCompare x1 x2 `mappend` loop (i+1) - | otherwise = compare (length a1) (length a2) - -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) --- | @since 0.6.4.0 -instance Ord1 SmallArray where -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) - liftCompare = smallArrayLiftCompare -#else - compare1 = smallArrayLiftCompare compare -#endif -#endif - --- | Lexicographic ordering. Subject to change between major versions. -instance Ord a => Ord (SmallArray a) where - compare sa1 sa2 = smallArrayLiftCompare compare sa1 sa2 - -instance Foldable SmallArray where - -- Note: we perform the array lookups eagerly so we won't - -- create thunks to perform lookups even if GHC can't see - -- that the folding function is strict. - foldr f = \z !ary -> - let - !sz = sizeofSmallArray ary - go i - | i == sz = z - | (# x #) <- indexSmallArray## ary i - = f x (go (i+1)) - in go 0 - {-# INLINE foldr #-} - foldl f = \z !ary -> - let - go i - | i < 0 = z - | (# x #) <- indexSmallArray## ary i - = f (go (i-1)) x - in go (sizeofSmallArray ary - 1) - {-# INLINE foldl #-} - foldr1 f = \ !ary -> - let - !sz = sizeofSmallArray ary - 1 - go i = - case indexSmallArray## ary i of - (# x #) | i == sz -> x - | otherwise -> f x (go (i+1)) - in if sz < 0 - then die "foldr1" "Empty SmallArray" - else go 0 - {-# INLINE foldr1 #-} - foldl1 f = \ !ary -> - let - !sz = sizeofSmallArray ary - 1 - go i = - case indexSmallArray## ary i of - (# x #) | i == 0 -> x - | otherwise -> f (go (i - 1)) x - in if sz < 0 - then die "foldl1" "Empty SmallArray" - else go sz - {-# INLINE foldl1 #-} - foldr' f = \z !ary -> - let - go i !acc - | i == -1 = acc - | (# x #) <- indexSmallArray## ary i - = go (i-1) (f x acc) - in go (sizeofSmallArray ary - 1) z - {-# INLINE foldr' #-} - foldl' f = \z !ary -> - let - !sz = sizeofSmallArray ary - go i !acc - | i == sz = acc - | (# x #) <- indexSmallArray## ary i - = go (i+1) (f acc x) - in go 0 z - {-# INLINE foldl' #-} - null a = sizeofSmallArray a == 0 - {-# INLINE null #-} - length = sizeofSmallArray - {-# INLINE length #-} - maximum ary | sz == 0 = die "maximum" "Empty SmallArray" - | (# frst #) <- indexSmallArray## ary 0 - = go 1 frst - where - sz = sizeofSmallArray ary - go i !e - | i == sz = e - | (# x #) <- indexSmallArray## ary i - = go (i+1) (max e x) - {-# INLINE maximum #-} - minimum ary | sz == 0 = die "minimum" "Empty SmallArray" - | (# frst #) <- indexSmallArray## ary 0 - = go 1 frst - where sz = sizeofSmallArray ary - go i !e - | i == sz = e - | (# x #) <- indexSmallArray## ary i - = go (i+1) (min e x) - {-# INLINE minimum #-} - sum = foldl' (+) 0 - {-# INLINE sum #-} - product = foldl' (*) 1 - {-# INLINE product #-} - -newtype STA a = STA {_runSTA :: forall s. SmallMutableArray# s a -> ST s (SmallArray a)} - -runSTA :: Int -> STA a -> SmallArray a -runSTA !sz = \ (STA m) -> runST $ newSmallArray_ sz >>= - \ (SmallMutableArray ar#) -> m ar# -{-# INLINE runSTA #-} - -newSmallArray_ :: Int -> ST s (SmallMutableArray s a) -newSmallArray_ !n = newSmallArray n badTraverseValue - -badTraverseValue :: a -badTraverseValue = die "traverse" "bad indexing" -{-# NOINLINE badTraverseValue #-} - -instance Traversable SmallArray where - traverse f = traverseSmallArray f - {-# INLINE traverse #-} - -traverseSmallArray - :: Applicative f - => (a -> f b) -> SmallArray a -> f (SmallArray b) -traverseSmallArray f = \ !ary -> - let - !len = sizeofSmallArray ary - go !i - | i == len - = pure $ STA $ \mary -> unsafeFreezeSmallArray (SmallMutableArray mary) - | (# x #) <- indexSmallArray## ary i - = liftA2 (\b (STA m) -> STA $ \mary -> - writeSmallArray (SmallMutableArray mary) i b >> m mary) - (f x) (go (i + 1)) - in if len == 0 - then pure emptySmallArray - else runSTA len <$> go 0 -{-# INLINE [1] traverseSmallArray #-} - -{-# RULES -"traverse/ST" forall (f :: a -> ST s b). traverseSmallArray f = traverseSmallArrayP f -"traverse/IO" forall (f :: a -> IO b). traverseSmallArray f = traverseSmallArrayP f -"traverse/Id" forall (f :: a -> Identity b). traverseSmallArray f = - (coerce :: (SmallArray a -> SmallArray (Identity b)) - -> SmallArray a -> Identity (SmallArray b)) (fmap f) - #-} - - -instance Functor SmallArray where - fmap f sa = createSmallArray (length sa) (die "fmap" "impossible") $ \smb -> - fix ? 0 $ \go i -> - when (i < length sa) $ do - x <- indexSmallArrayM sa i - writeSmallArray smb i (f x) *> go (i+1) - {-# INLINE fmap #-} - - x <$ sa = createSmallArray (length sa) x noOp - -instance Applicative SmallArray where - pure x = createSmallArray 1 x noOp - - sa *> sb = createSmallArray (la*lb) (die "*>" "impossible") $ \smb -> - fix ? 0 $ \go i -> - when (i < la) $ - copySmallArray smb 0 sb 0 lb *> go (i+1) - where - la = length sa ; lb = length sb - - a <* b = createSmallArray (sza*szb) (die "<*" "impossible") $ \ma -> - let fill off i e = when (i < szb) $ - writeSmallArray ma (off+i) e >> fill off (i+1) e - go i = when (i < sza) $ do - x <- indexSmallArrayM a i - fill (i*szb) 0 x - go (i+1) - in go 0 - where sza = sizeofSmallArray a ; szb = sizeofSmallArray b - - ab <*> a = createSmallArray (szab*sza) (die "<*>" "impossible") $ \mb -> - let go1 i = when (i < szab) $ - do - f <- indexSmallArrayM ab i - go2 (i*sza) f 0 - go1 (i+1) - go2 off f j = when (j < sza) $ - do - x <- indexSmallArrayM a j - writeSmallArray mb (off + j) (f x) - go2 off f (j + 1) - in go1 0 - where szab = sizeofSmallArray ab ; sza = sizeofSmallArray a - -instance Alternative SmallArray where - empty = emptySmallArray - - sl <|> sr = - createSmallArray (length sl + length sr) (die "<|>" "impossible") $ \sma -> - copySmallArray sma 0 sl 0 (length sl) - *> copySmallArray sma (length sl) sr 0 (length sr) - - many sa | null sa = pure [] - | otherwise = die "many" "infinite arrays are not well defined" - - some sa | null sa = emptySmallArray - | otherwise = die "some" "infinite arrays are not well defined" - -data ArrayStack a - = PushArray !(SmallArray a) !(ArrayStack a) - | EmptyStack --- TODO: This isn't terribly efficient. It would be better to wrap --- ArrayStack with a type like --- --- data NES s a = NES !Int !(SmallMutableArray s a) !(ArrayStack a) --- --- We'd copy incoming arrays into the mutable array until we would --- overflow it. Then we'd freeze it, push it on the stack, and continue. --- Any sufficiently large incoming arrays would go straight on the stack. --- Such a scheme would make the stack much more compact in the case --- of many small arrays. - -instance Monad SmallArray where - return = pure - (>>) = (*>) - - sa >>= f = collect 0 EmptyStack (la-1) - where - la = length sa - collect sz stk i - | i < 0 = createSmallArray sz (die ">>=" "impossible") $ fill 0 stk - | (# x #) <- indexSmallArray## sa i - , let sb = f x - lsb = length sb - -- If we don't perform this check, we could end up allocating - -- a stack full of empty arrays if someone is filtering most - -- things out. So we refrain from pushing empty arrays. - = if lsb == 0 - then collect sz stk (i-1) - else collect (sz + lsb) (PushArray sb stk) (i-1) - - fill _ EmptyStack _ = return () - fill off (PushArray sb sbs) smb = - copySmallArray smb off sb 0 (length sb) - *> fill (off + length sb) sbs smb - - fail _ = emptySmallArray - -instance MonadPlus SmallArray where - mzero = empty - mplus = (<|>) - -zipW :: String -> (a -> b -> c) -> SmallArray a -> SmallArray b -> SmallArray c -zipW nm = \f sa sb -> let mn = length sa `min` length sb in - createSmallArray mn (die nm "impossible") $ \mc -> - fix ? 0 $ \go i -> when (i < mn) $ do - x <- indexSmallArrayM sa i - y <- indexSmallArrayM sb i - writeSmallArray mc i (f x y) - go (i+1) -{-# INLINE zipW #-} - -instance MonadZip SmallArray where - mzip = zipW "mzip" (,) - mzipWith = zipW "mzipWith" - {-# INLINE mzipWith #-} - munzip sab = runST $ do - let sz = length sab - sma <- newSmallArray sz $ die "munzip" "impossible" - smb <- newSmallArray sz $ die "munzip" "impossible" - fix ? 0 $ \go i -> - when (i < sz) $ case indexSmallArray sab i of - (x, y) -> do writeSmallArray sma i x - writeSmallArray smb i y - go $ i+1 - (,) <$> unsafeFreezeSmallArray sma - <*> unsafeFreezeSmallArray smb - -instance MonadFix SmallArray where - mfix f = createSmallArray (sizeofSmallArray (f err)) - (die "mfix" "impossible") $ flip fix 0 $ - \r !i !mary -> when (i < sz) $ do - writeSmallArray mary i (fix (\xi -> f xi `indexSmallArray` i)) - r (i + 1) mary - where - sz = sizeofSmallArray (f err) - err = error "mfix for Data.Primitive.SmallArray applied to strict function." - -#if MIN_VERSION_base(4,9,0) --- | @since 0.6.3.0 -instance Sem.Semigroup (SmallArray a) where - (<>) = (<|>) - sconcat = mconcat . toList -#endif - -instance Monoid (SmallArray a) where - mempty = empty -#if !(MIN_VERSION_base(4,11,0)) - mappend = (<|>) -#endif - mconcat l = createSmallArray n (die "mconcat" "impossible") $ \ma -> - let go !_ [ ] = return () - go off (a:as) = - copySmallArray ma off a 0 (sizeofSmallArray a) >> go (off + sizeofSmallArray a) as - in go 0 l - where n = sum . fmap length $ l - -instance IsList (SmallArray a) where - type Item (SmallArray a) = a - fromListN = smallArrayFromListN - fromList = smallArrayFromList - toList = Foldable.toList - -smallArrayLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> SmallArray a -> ShowS -smallArrayLiftShowsPrec elemShowsPrec elemListShowsPrec p sa = showParen (p > 10) $ - showString "fromListN " . shows (length sa) . showString " " - . listLiftShowsPrec elemShowsPrec elemListShowsPrec 11 (toList sa) - --- this need to be included for older ghcs -listLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> [a] -> ShowS -listLiftShowsPrec _ sl _ = sl - -instance Show a => Show (SmallArray a) where - showsPrec p sa = smallArrayLiftShowsPrec showsPrec showList p sa - -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) --- | @since 0.6.4.0 -instance Show1 SmallArray where -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) - liftShowsPrec = smallArrayLiftShowsPrec -#else - showsPrec1 = smallArrayLiftShowsPrec showsPrec showList -#endif -#endif - -smallArrayLiftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (SmallArray a) -smallArrayLiftReadsPrec _ listReadsPrec p = readParen (p > 10) . readP_to_S $ do - () <$ string "fromListN" - skipSpaces - n <- readS_to_P reads - skipSpaces - l <- readS_to_P listReadsPrec - return $ smallArrayFromListN n l - -instance Read a => Read (SmallArray a) where - readsPrec = smallArrayLiftReadsPrec readsPrec readList - -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) --- | @since 0.6.4.0 -instance Read1 SmallArray where -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) - liftReadsPrec = smallArrayLiftReadsPrec -#else - readsPrec1 = smallArrayLiftReadsPrec readsPrec readList -#endif -#endif - - - -smallArrayDataType :: DataType -smallArrayDataType = - mkDataType "Data.Primitive.SmallArray.SmallArray" [fromListConstr] - -fromListConstr :: Constr -fromListConstr = mkConstr smallArrayDataType "fromList" [] Prefix - -instance Data a => Data (SmallArray a) where - toConstr _ = fromListConstr - dataTypeOf _ = smallArrayDataType - gunfold k z c = case constrIndex c of - 1 -> k (z fromList) - _ -> die "gunfold" "SmallArray" - gfoldl f z m = z fromList `f` toList m - -instance (Typeable s, Typeable a) => Data (SmallMutableArray s a) where - toConstr _ = die "toConstr" "SmallMutableArray" - gunfold _ _ = die "gunfold" "SmallMutableArray" - dataTypeOf _ = mkNoRepType "Data.Primitive.SmallArray.SmallMutableArray" -#endif - --- | Create a 'SmallArray' from a list of a known length. If the length --- of the list does not match the given length, this throws an exception. -smallArrayFromListN :: Int -> [a] -> SmallArray a -#if HAVE_SMALL_ARRAY -smallArrayFromListN n l = - createSmallArray n - (die "smallArrayFromListN" "uninitialized element") $ \sma -> - let go !ix [] = if ix == n - then return () - else die "smallArrayFromListN" "list length less than specified size" - go !ix (x : xs) = if ix < n - then do - writeSmallArray sma ix x - go (ix+1) xs - else die "smallArrayFromListN" "list length greater than specified size" - in go 0 l -#else -smallArrayFromListN n l = SmallArray (Array.fromListN n l) -#endif - --- | Create a 'SmallArray' from a list. -smallArrayFromList :: [a] -> SmallArray a -smallArrayFromList l = smallArrayFromListN (length l) l diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Types.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Types.hs deleted file mode 100644 index fd36ea0c9455..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Types.hs +++ /dev/null @@ -1,395 +0,0 @@ -{-# LANGUAGE CPP, UnboxedTuples, MagicHash, DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -#if __GLASGOW_HASKELL__ >= 800 -{-# LANGUAGE TypeInType #-} -#endif - -#include "HsBaseConfig.h" - --- | --- Module : Data.Primitive.Types --- Copyright : (c) Roman Leshchinskiy 2009-2012 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Portability : non-portable --- --- Basic types and classes for primitive array operations --- - -module Data.Primitive.Types ( - Prim(..), - sizeOf, alignment, defaultSetByteArray#, defaultSetOffAddr#, - - Addr(..), - PrimStorable(..) -) where - -import Control.Monad.Primitive -import Data.Primitive.MachDeps -import Data.Primitive.Internal.Operations -import Foreign.C.Types -import System.Posix.Types - -import GHC.Base ( - Int(..), Char(..), - ) -import GHC.Float ( - Float(..), Double(..) - ) -import GHC.Word ( - Word(..), Word8(..), Word16(..), Word32(..), Word64(..) - ) -import GHC.Int ( - Int8(..), Int16(..), Int32(..), Int64(..) - ) - -import GHC.Ptr ( - Ptr(..), FunPtr(..) - ) - -import GHC.Prim -#if __GLASGOW_HASKELL__ >= 706 - hiding (setByteArray#) -#endif - -import Data.Typeable ( Typeable ) -import Data.Data ( Data(..) ) -import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType ) -import Foreign.Storable (Storable) -import Numeric - -import qualified Foreign.Storable as FS - --- | A machine address -data Addr = Addr Addr# deriving ( Typeable ) - -instance Show Addr where - showsPrec _ (Addr a) = - showString "0x" . showHex (fromIntegral (I# (addr2Int# a)) :: Word) - -instance Eq Addr where - Addr a# == Addr b# = isTrue# (eqAddr# a# b#) - Addr a# /= Addr b# = isTrue# (neAddr# a# b#) - -instance Ord Addr where - Addr a# > Addr b# = isTrue# (gtAddr# a# b#) - Addr a# >= Addr b# = isTrue# (geAddr# a# b#) - Addr a# < Addr b# = isTrue# (ltAddr# a# b#) - Addr a# <= Addr b# = isTrue# (leAddr# a# b#) - -instance Data Addr where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Data.Primitive.Types.Addr" - - --- | Class of types supporting primitive array operations -class Prim a where - - -- | Size of values of type @a@. The argument is not used. - sizeOf# :: a -> Int# - - -- | Alignment of values of type @a@. The argument is not used. - alignment# :: a -> Int# - - -- | Read a value from the array. The offset is in elements of type - -- @a@ rather than in bytes. - indexByteArray# :: ByteArray# -> Int# -> a - - -- | Read a value from the mutable array. The offset is in elements of type - -- @a@ rather than in bytes. - readByteArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, a #) - - -- | Write a value to the mutable array. The offset is in elements of type - -- @a@ rather than in bytes. - writeByteArray# :: MutableByteArray# s -> Int# -> a -> State# s -> State# s - - -- | Fill a slice of the mutable array with a value. The offset and length - -- of the chunk are in elements of type @a@ rather than in bytes. - setByteArray# :: MutableByteArray# s -> Int# -> Int# -> a -> State# s -> State# s - - -- | Read a value from a memory position given by an address and an offset. - -- The memory block the address refers to must be immutable. The offset is in - -- elements of type @a@ rather than in bytes. - indexOffAddr# :: Addr# -> Int# -> a - - -- | Read a value from a memory position given by an address and an offset. - -- The offset is in elements of type @a@ rather than in bytes. - readOffAddr# :: Addr# -> Int# -> State# s -> (# State# s, a #) - - -- | Write a value to a memory position given by an address and an offset. - -- The offset is in elements of type @a@ rather than in bytes. - writeOffAddr# :: Addr# -> Int# -> a -> State# s -> State# s - - -- | Fill a memory block given by an address, an offset and a length. - -- The offset and length are in elements of type @a@ rather than in bytes. - setOffAddr# :: Addr# -> Int# -> Int# -> a -> State# s -> State# s - --- | Size of values of type @a@. The argument is not used. --- --- This function has existed since 0.1, but was moved from 'Data.Primitive' --- to 'Data.Primitive.Types' in version 0.6.3.0 -sizeOf :: Prim a => a -> Int -sizeOf x = I# (sizeOf# x) - --- | Alignment of values of type @a@. The argument is not used. --- --- This function has existed since 0.1, but was moved from 'Data.Primitive' --- to 'Data.Primitive.Types' in version 0.6.3.0 -alignment :: Prim a => a -> Int -alignment x = I# (alignment# x) - --- | An implementation of 'setByteArray#' that calls 'writeByteArray#' --- to set each element. This is helpful when writing a 'Prim' instance --- for a multi-word data type for which there is no cpu-accelerated way --- to broadcast a value to contiguous memory. It is typically used --- alongside 'defaultSetOffAddr#'. For example: --- --- > data Trip = Trip Int Int Int --- > --- > instance Prim Trip --- > sizeOf# _ = 3# *# sizeOf# (undefined :: Int) --- > alignment# _ = alignment# (undefined :: Int) --- > indexByteArray# arr# i# = ... --- > readByteArray# arr# i# = ... --- > writeByteArray# arr# i# (Trip a b c) = --- > \s0 -> case writeByteArray# arr# (3# *# i#) a s0 of --- > s1 -> case writeByteArray# arr# ((3# *# i#) +# 1#) b s1 of --- > s2 -> case writeByteArray# arr# ((3# *# i#) +# 2# ) c s2 of --- > s3 -> s3 --- > setByteArray# = defaultSetByteArray# --- > indexOffAddr# addr# i# = ... --- > readOffAddr# addr# i# = ... --- > writeOffAddr# addr# i# (Trip a b c) = --- > \s0 -> case writeOffAddr# addr# (3# *# i#) a s0 of --- > s1 -> case writeOffAddr# addr# ((3# *# i#) +# 1#) b s1 of --- > s2 -> case writeOffAddr# addr# ((3# *# i#) +# 2# ) c s2 of --- > s3 -> s3 --- > setOffAddr# = defaultSetOffAddr# -defaultSetByteArray# :: Prim a => MutableByteArray# s -> Int# -> Int# -> a -> State# s -> State# s -defaultSetByteArray# arr# i# len# ident = go 0# - where - go ix# s0 = if isTrue# (ix# <# len#) - then case writeByteArray# arr# (i# +# ix#) ident s0 of - s1 -> go (ix# +# 1#) s1 - else s0 - --- | An implementation of 'setOffAddr#' that calls 'writeOffAddr#' --- to set each element. The documentation of 'defaultSetByteArray#' --- provides an example of how to use this. -defaultSetOffAddr# :: Prim a => Addr# -> Int# -> Int# -> a -> State# s -> State# s -defaultSetOffAddr# addr# i# len# ident = go 0# - where - go ix# s0 = if isTrue# (ix# <# len#) - then case writeOffAddr# addr# (i# +# ix#) ident s0 of - s1 -> go (ix# +# 1#) s1 - else s0 - --- | Newtype that uses a 'Prim' instance to give rise to a 'Storable' instance. --- This type is intended to be used with the @DerivingVia@ extension available --- in GHC 8.6 and up. For example, consider a user-defined 'Prim' instance for --- a multi-word data type. --- --- > data Uuid = Uuid Word64 Word64 --- > deriving Storable via (PrimStorable Uuid) --- > instance Prim Uuid where ... --- --- Writing the 'Prim' instance is tedious and unavoidable, but the 'Storable' --- instance comes for free once the 'Prim' instance is written. -newtype PrimStorable a = PrimStorable { getPrimStorable :: a } - -instance Prim a => Storable (PrimStorable a) where - sizeOf _ = sizeOf (undefined :: a) - alignment _ = alignment (undefined :: a) - peekElemOff (Ptr addr#) (I# i#) = - primitive $ \s0# -> case readOffAddr# addr# i# s0# of - (# s1, x #) -> (# s1, PrimStorable x #) - pokeElemOff (Ptr addr#) (I# i#) (PrimStorable a) = primitive_ $ \s# -> - writeOffAddr# addr# i# a s# - -#define derivePrim(ty, ctr, sz, align, idx_arr, rd_arr, wr_arr, set_arr, idx_addr, rd_addr, wr_addr, set_addr) \ -instance Prim (ty) where { \ - sizeOf# _ = unI# sz \ -; alignment# _ = unI# align \ -; indexByteArray# arr# i# = ctr (idx_arr arr# i#) \ -; readByteArray# arr# i# s# = case rd_arr arr# i# s# of \ - { (# s1#, x# #) -> (# s1#, ctr x# #) } \ -; writeByteArray# arr# i# (ctr x#) s# = wr_arr arr# i# x# s# \ -; setByteArray# arr# i# n# (ctr x#) s# \ - = let { i = fromIntegral (I# i#) \ - ; n = fromIntegral (I# n#) \ - } in \ - case unsafeCoerce# (internal (set_arr arr# i n x#)) s# of \ - { (# s1#, _ #) -> s1# } \ - \ -; indexOffAddr# addr# i# = ctr (idx_addr addr# i#) \ -; readOffAddr# addr# i# s# = case rd_addr addr# i# s# of \ - { (# s1#, x# #) -> (# s1#, ctr x# #) } \ -; writeOffAddr# addr# i# (ctr x#) s# = wr_addr addr# i# x# s# \ -; setOffAddr# addr# i# n# (ctr x#) s# \ - = let { i = fromIntegral (I# i#) \ - ; n = fromIntegral (I# n#) \ - } in \ - case unsafeCoerce# (internal (set_addr addr# i n x#)) s# of \ - { (# s1#, _ #) -> s1# } \ -; {-# INLINE sizeOf# #-} \ -; {-# INLINE alignment# #-} \ -; {-# INLINE indexByteArray# #-} \ -; {-# INLINE readByteArray# #-} \ -; {-# INLINE writeByteArray# #-} \ -; {-# INLINE setByteArray# #-} \ -; {-# INLINE indexOffAddr# #-} \ -; {-# INLINE readOffAddr# #-} \ -; {-# INLINE writeOffAddr# #-} \ -; {-# INLINE setOffAddr# #-} \ -} - -unI# :: Int -> Int# -unI# (I# n#) = n# - -derivePrim(Word, W#, sIZEOF_WORD, aLIGNMENT_WORD, - indexWordArray#, readWordArray#, writeWordArray#, setWordArray#, - indexWordOffAddr#, readWordOffAddr#, writeWordOffAddr#, setWordOffAddr#) -derivePrim(Word8, W8#, sIZEOF_WORD8, aLIGNMENT_WORD8, - indexWord8Array#, readWord8Array#, writeWord8Array#, setWord8Array#, - indexWord8OffAddr#, readWord8OffAddr#, writeWord8OffAddr#, setWord8OffAddr#) -derivePrim(Word16, W16#, sIZEOF_WORD16, aLIGNMENT_WORD16, - indexWord16Array#, readWord16Array#, writeWord16Array#, setWord16Array#, - indexWord16OffAddr#, readWord16OffAddr#, writeWord16OffAddr#, setWord16OffAddr#) -derivePrim(Word32, W32#, sIZEOF_WORD32, aLIGNMENT_WORD32, - indexWord32Array#, readWord32Array#, writeWord32Array#, setWord32Array#, - indexWord32OffAddr#, readWord32OffAddr#, writeWord32OffAddr#, setWord32OffAddr#) -derivePrim(Word64, W64#, sIZEOF_WORD64, aLIGNMENT_WORD64, - indexWord64Array#, readWord64Array#, writeWord64Array#, setWord64Array#, - indexWord64OffAddr#, readWord64OffAddr#, writeWord64OffAddr#, setWord64OffAddr#) -derivePrim(Int, I#, sIZEOF_INT, aLIGNMENT_INT, - indexIntArray#, readIntArray#, writeIntArray#, setIntArray#, - indexIntOffAddr#, readIntOffAddr#, writeIntOffAddr#, setIntOffAddr#) -derivePrim(Int8, I8#, sIZEOF_INT8, aLIGNMENT_INT8, - indexInt8Array#, readInt8Array#, writeInt8Array#, setInt8Array#, - indexInt8OffAddr#, readInt8OffAddr#, writeInt8OffAddr#, setInt8OffAddr#) -derivePrim(Int16, I16#, sIZEOF_INT16, aLIGNMENT_INT16, - indexInt16Array#, readInt16Array#, writeInt16Array#, setInt16Array#, - indexInt16OffAddr#, readInt16OffAddr#, writeInt16OffAddr#, setInt16OffAddr#) -derivePrim(Int32, I32#, sIZEOF_INT32, aLIGNMENT_INT32, - indexInt32Array#, readInt32Array#, writeInt32Array#, setInt32Array#, - indexInt32OffAddr#, readInt32OffAddr#, writeInt32OffAddr#, setInt32OffAddr#) -derivePrim(Int64, I64#, sIZEOF_INT64, aLIGNMENT_INT64, - indexInt64Array#, readInt64Array#, writeInt64Array#, setInt64Array#, - indexInt64OffAddr#, readInt64OffAddr#, writeInt64OffAddr#, setInt64OffAddr#) -derivePrim(Float, F#, sIZEOF_FLOAT, aLIGNMENT_FLOAT, - indexFloatArray#, readFloatArray#, writeFloatArray#, setFloatArray#, - indexFloatOffAddr#, readFloatOffAddr#, writeFloatOffAddr#, setFloatOffAddr#) -derivePrim(Double, D#, sIZEOF_DOUBLE, aLIGNMENT_DOUBLE, - indexDoubleArray#, readDoubleArray#, writeDoubleArray#, setDoubleArray#, - indexDoubleOffAddr#, readDoubleOffAddr#, writeDoubleOffAddr#, setDoubleOffAddr#) -derivePrim(Char, C#, sIZEOF_CHAR, aLIGNMENT_CHAR, - indexWideCharArray#, readWideCharArray#, writeWideCharArray#, setWideCharArray#, - indexWideCharOffAddr#, readWideCharOffAddr#, writeWideCharOffAddr#, setWideCharOffAddr#) -derivePrim(Addr, Addr, sIZEOF_PTR, aLIGNMENT_PTR, - indexAddrArray#, readAddrArray#, writeAddrArray#, setAddrArray#, - indexAddrOffAddr#, readAddrOffAddr#, writeAddrOffAddr#, setAddrOffAddr#) -derivePrim(Ptr a, Ptr, sIZEOF_PTR, aLIGNMENT_PTR, - indexAddrArray#, readAddrArray#, writeAddrArray#, setAddrArray#, - indexAddrOffAddr#, readAddrOffAddr#, writeAddrOffAddr#, setAddrOffAddr#) -derivePrim(FunPtr a, FunPtr, sIZEOF_PTR, aLIGNMENT_PTR, - indexAddrArray#, readAddrArray#, writeAddrArray#, setAddrArray#, - indexAddrOffAddr#, readAddrOffAddr#, writeAddrOffAddr#, setAddrOffAddr#) - --- Prim instances for newtypes in Foreign.C.Types -deriving instance Prim CChar -deriving instance Prim CSChar -deriving instance Prim CUChar -deriving instance Prim CShort -deriving instance Prim CUShort -deriving instance Prim CInt -deriving instance Prim CUInt -deriving instance Prim CLong -deriving instance Prim CULong -deriving instance Prim CPtrdiff -deriving instance Prim CSize -deriving instance Prim CWchar -deriving instance Prim CSigAtomic -deriving instance Prim CLLong -deriving instance Prim CULLong -#if MIN_VERSION_base(4,10,0) -deriving instance Prim CBool -#endif -deriving instance Prim CIntPtr -deriving instance Prim CUIntPtr -deriving instance Prim CIntMax -deriving instance Prim CUIntMax -deriving instance Prim CClock -deriving instance Prim CTime -deriving instance Prim CUSeconds -deriving instance Prim CSUSeconds -deriving instance Prim CFloat -deriving instance Prim CDouble - --- Prim instances for newtypes in System.Posix.Types -#if defined(HTYPE_DEV_T) -deriving instance Prim CDev -#endif -#if defined(HTYPE_INO_T) -deriving instance Prim CIno -#endif -#if defined(HTYPE_MODE_T) -deriving instance Prim CMode -#endif -#if defined(HTYPE_OFF_T) -deriving instance Prim COff -#endif -#if defined(HTYPE_PID_T) -deriving instance Prim CPid -#endif -#if defined(HTYPE_SSIZE_T) -deriving instance Prim CSsize -#endif -#if defined(HTYPE_GID_T) -deriving instance Prim CGid -#endif -#if defined(HTYPE_NLINK_T) -deriving instance Prim CNlink -#endif -#if defined(HTYPE_UID_T) -deriving instance Prim CUid -#endif -#if defined(HTYPE_CC_T) -deriving instance Prim CCc -#endif -#if defined(HTYPE_SPEED_T) -deriving instance Prim CSpeed -#endif -#if defined(HTYPE_TCFLAG_T) -deriving instance Prim CTcflag -#endif -#if defined(HTYPE_RLIM_T) -deriving instance Prim CRLim -#endif -#if defined(HTYPE_BLKSIZE_T) -deriving instance Prim CBlkSize -#endif -#if defined(HTYPE_BLKCNT_T) -deriving instance Prim CBlkCnt -#endif -#if defined(HTYPE_CLOCKID_T) -deriving instance Prim CClockId -#endif -#if defined(HTYPE_FSBLKCNT_T) -deriving instance Prim CFsBlkCnt -#endif -#if defined(HTYPE_FSFILCNT_T) -deriving instance Prim CFsFilCnt -#endif -#if defined(HTYPE_ID_T) -deriving instance Prim CId -#endif -#if defined(HTYPE_KEY_T) -deriving instance Prim CKey -#endif -#if defined(HTYPE_TIMER_T) -deriving instance Prim CTimer -#endif -deriving instance Prim Fd diff --git a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/UnliftedArray.hs b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/UnliftedArray.hs deleted file mode 100644 index 75a4847364dc..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/UnliftedArray.hs +++ /dev/null @@ -1,638 +0,0 @@ -{-# Language BangPatterns #-} -{-# Language CPP #-} -{-# Language DeriveDataTypeable #-} -{-# Language MagicHash #-} -{-# Language RankNTypes #-} -{-# Language ScopedTypeVariables #-} -{-# Language TypeFamilies #-} -{-# Language UnboxedTuples #-} - --- | --- Module : Data.Primitive.UnliftedArray --- Copyright : (c) Dan Doel 2016 --- License : BSD-style --- --- Maintainer : Libraries <libraries@haskell.org> --- Portability : non-portable --- --- GHC contains three general classes of value types: --- --- 1. Unboxed types: values are machine values made up of fixed numbers of bytes --- 2. Unlifted types: values are pointers, but strictly evaluated --- 3. Lifted types: values are pointers, lazily evaluated --- --- The first category can be stored in a 'ByteArray', and this allows types in --- category 3 that are simple wrappers around category 1 types to be stored --- more efficiently using a 'ByteArray'. This module provides the same facility --- for category 2 types. --- --- GHC has two primitive types, 'ArrayArray#' and 'MutableArrayArray#'. These --- are arrays of pointers, but of category 2 values, so they are known to not --- be bottom. This allows types that are wrappers around such types to be stored --- in an array without an extra level of indirection. --- --- The way that the 'ArrayArray#' API works is that one can read and write --- 'ArrayArray#' values to the positions. This works because all category 2 --- types share a uniform representation, unlike unboxed values which are --- represented by varying (by type) numbers of bytes. However, using the --- this makes the internal API very unsafe to use, as one has to coerce values --- to and from 'ArrayArray#'. --- --- The API presented by this module is more type safe. 'UnliftedArray' and --- 'MutableUnliftedArray' are parameterized by the type of arrays they contain, and --- the coercions necessary are abstracted into a class, 'PrimUnlifted', of things --- that are eligible to be stored. - -module Data.Primitive.UnliftedArray - ( -- * Types - UnliftedArray(..) - , MutableUnliftedArray(..) - , PrimUnlifted(..) - -- * Operations - , unsafeNewUnliftedArray - , newUnliftedArray - , setUnliftedArray - , sizeofUnliftedArray - , sizeofMutableUnliftedArray - , readUnliftedArray - , writeUnliftedArray - , indexUnliftedArray - , indexUnliftedArrayM - , unsafeFreezeUnliftedArray - , freezeUnliftedArray - , thawUnliftedArray - , runUnliftedArray - , sameMutableUnliftedArray - , copyUnliftedArray - , copyMutableUnliftedArray - , cloneUnliftedArray - , cloneMutableUnliftedArray - -- * List Conversion - , unliftedArrayToList - , unliftedArrayFromList - , unliftedArrayFromListN - -- * Folding - , foldrUnliftedArray - , foldrUnliftedArray' - , foldlUnliftedArray - , foldlUnliftedArray' - -- * Mapping - , mapUnliftedArray --- Missing operations: --- , unsafeThawUnliftedArray - ) where - -import Data.Typeable -import Control.Applicative - -import GHC.Prim -import GHC.Base (Int(..),build) - -import Control.Monad.Primitive - -import Control.Monad.ST (runST,ST) - -import Data.Monoid (Monoid,mappend) -import Data.Primitive.Internal.Compat ( isTrue# ) - -import qualified Data.List as L -import Data.Primitive.Array (Array) -import qualified Data.Primitive.Array as A -import Data.Primitive.ByteArray (ByteArray) -import qualified Data.Primitive.ByteArray as BA -import qualified Data.Primitive.PrimArray as PA -import qualified Data.Primitive.SmallArray as SA -import qualified Data.Primitive.MutVar as MV -import qualified Data.Monoid -import qualified GHC.MVar as GM (MVar(..)) -import qualified GHC.Conc as GC (TVar(..)) -import qualified GHC.Stable as GSP (StablePtr(..)) -import qualified GHC.Weak as GW (Weak(..)) -import qualified GHC.Conc.Sync as GCS (ThreadId(..)) -import qualified GHC.Exts as E -import qualified GHC.ST as GHCST - -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup) -import qualified Data.Semigroup -#endif - -#if MIN_VERSION_base(4,10,0) -import GHC.Exts (runRW#) -#elif MIN_VERSION_base(4,9,0) -import GHC.Base (runRW#) -#endif - --- | Immutable arrays that efficiently store types that are simple wrappers --- around unlifted primitive types. The values of the unlifted type are --- stored directly, eliminating a layer of indirection. -data UnliftedArray e = UnliftedArray ArrayArray# - deriving (Typeable) - --- | Mutable arrays that efficiently store types that are simple wrappers --- around unlifted primitive types. The values of the unlifted type are --- stored directly, eliminating a layer of indirection. -data MutableUnliftedArray s e = MutableUnliftedArray (MutableArrayArray# s) - deriving (Typeable) - --- | Classifies the types that are able to be stored in 'UnliftedArray' and --- 'MutableUnliftedArray'. These should be types that are just liftings of the --- unlifted pointer types, so that their internal contents can be safely coerced --- into an 'ArrayArray#'. -class PrimUnlifted a where - toArrayArray# :: a -> ArrayArray# - fromArrayArray# :: ArrayArray# -> a - -instance PrimUnlifted (UnliftedArray e) where - toArrayArray# (UnliftedArray aa#) = aa# - fromArrayArray# aa# = UnliftedArray aa# - -instance PrimUnlifted (MutableUnliftedArray s e) where - toArrayArray# (MutableUnliftedArray maa#) = unsafeCoerce# maa# - fromArrayArray# aa# = MutableUnliftedArray (unsafeCoerce# aa#) - -instance PrimUnlifted (Array a) where - toArrayArray# (A.Array a#) = unsafeCoerce# a# - fromArrayArray# aa# = A.Array (unsafeCoerce# aa#) - -instance PrimUnlifted (A.MutableArray s a) where - toArrayArray# (A.MutableArray ma#) = unsafeCoerce# ma# - fromArrayArray# aa# = A.MutableArray (unsafeCoerce# aa#) - -instance PrimUnlifted ByteArray where - toArrayArray# (BA.ByteArray ba#) = unsafeCoerce# ba# - fromArrayArray# aa# = BA.ByteArray (unsafeCoerce# aa#) - -instance PrimUnlifted (BA.MutableByteArray s) where - toArrayArray# (BA.MutableByteArray mba#) = unsafeCoerce# mba# - fromArrayArray# aa# = BA.MutableByteArray (unsafeCoerce# aa#) - --- | @since 0.6.4.0 -instance PrimUnlifted (PA.PrimArray a) where - toArrayArray# (PA.PrimArray ba#) = unsafeCoerce# ba# - fromArrayArray# aa# = PA.PrimArray (unsafeCoerce# aa#) - --- | @since 0.6.4.0 -instance PrimUnlifted (PA.MutablePrimArray s a) where - toArrayArray# (PA.MutablePrimArray mba#) = unsafeCoerce# mba# - fromArrayArray# aa# = PA.MutablePrimArray (unsafeCoerce# aa#) - -instance PrimUnlifted (SA.SmallArray a) where - toArrayArray# (SA.SmallArray sa#) = unsafeCoerce# sa# - fromArrayArray# aa# = SA.SmallArray (unsafeCoerce# aa#) - -instance PrimUnlifted (SA.SmallMutableArray s a) where - toArrayArray# (SA.SmallMutableArray sma#) = unsafeCoerce# sma# - fromArrayArray# aa# = SA.SmallMutableArray (unsafeCoerce# aa#) - -instance PrimUnlifted (MV.MutVar s a) where - toArrayArray# (MV.MutVar mv#) = unsafeCoerce# mv# - fromArrayArray# aa# = MV.MutVar (unsafeCoerce# aa#) - --- | @since 0.6.4.0 -instance PrimUnlifted (GM.MVar a) where - toArrayArray# (GM.MVar mv#) = unsafeCoerce# mv# - fromArrayArray# mv# = GM.MVar (unsafeCoerce# mv#) - --- | @since 0.6.4.0 -instance PrimUnlifted (GC.TVar a) where - toArrayArray# (GC.TVar tv#) = unsafeCoerce# tv# - fromArrayArray# tv# = GC.TVar (unsafeCoerce# tv#) - --- | @since 0.6.4.0 -instance PrimUnlifted (GSP.StablePtr a) where - toArrayArray# (GSP.StablePtr tv#) = unsafeCoerce# tv# - fromArrayArray# tv# = GSP.StablePtr (unsafeCoerce# tv#) - --- | @since 0.6.4.0 -instance PrimUnlifted (GW.Weak a) where - toArrayArray# (GW.Weak tv#) = unsafeCoerce# tv# - fromArrayArray# tv# = GW.Weak (unsafeCoerce# tv#) - --- | @since 0.6.4.0 -instance PrimUnlifted GCS.ThreadId where - toArrayArray# (GCS.ThreadId tv#) = unsafeCoerce# tv# - fromArrayArray# tv# = GCS.ThreadId (unsafeCoerce# tv#) - -die :: String -> String -> a -die fun problem = error $ "Data.Primitive.UnliftedArray." ++ fun ++ ": " ++ problem - --- | Creates a new 'MutableUnliftedArray'. This function is unsafe because it --- initializes all elements of the array as pointers to the array itself. Attempting --- to read one of these elements before writing to it is in effect an unsafe --- coercion from the @MutableUnliftedArray s a@ to the element type. -unsafeNewUnliftedArray - :: (PrimMonad m) - => Int -- ^ size - -> m (MutableUnliftedArray (PrimState m) a) -unsafeNewUnliftedArray (I# i#) = primitive $ \s -> case newArrayArray# i# s of - (# s', maa# #) -> (# s', MutableUnliftedArray maa# #) -{-# inline unsafeNewUnliftedArray #-} - --- | Sets all the positions in an unlifted array to the designated value. -setUnliftedArray - :: (PrimMonad m, PrimUnlifted a) - => MutableUnliftedArray (PrimState m) a -- ^ destination - -> a -- ^ value to fill with - -> m () -setUnliftedArray mua v = loop $ sizeofMutableUnliftedArray mua - 1 - where - loop i | i < 0 = return () - | otherwise = writeUnliftedArray mua i v >> loop (i-1) -{-# inline setUnliftedArray #-} - --- | Creates a new 'MutableUnliftedArray' with the specified value as initial --- contents. This is slower than 'unsafeNewUnliftedArray', but safer. -newUnliftedArray - :: (PrimMonad m, PrimUnlifted a) - => Int -- ^ size - -> a -- ^ initial value - -> m (MutableUnliftedArray (PrimState m) a) -newUnliftedArray len v = - unsafeNewUnliftedArray len >>= \mua -> setUnliftedArray mua v >> return mua -{-# inline newUnliftedArray #-} - --- | Yields the length of an 'UnliftedArray'. -sizeofUnliftedArray :: UnliftedArray e -> Int -sizeofUnliftedArray (UnliftedArray aa#) = I# (sizeofArrayArray# aa#) -{-# inline sizeofUnliftedArray #-} - --- | Yields the length of a 'MutableUnliftedArray'. -sizeofMutableUnliftedArray :: MutableUnliftedArray s e -> Int -sizeofMutableUnliftedArray (MutableUnliftedArray maa#) - = I# (sizeofMutableArrayArray# maa#) -{-# inline sizeofMutableUnliftedArray #-} - --- Internal indexing function. --- --- Note: ArrayArray# is strictly evaluated, so this should have similar --- consequences to indexArray#, where matching on the unboxed single causes the --- array access to happen. -indexUnliftedArrayU - :: PrimUnlifted a - => UnliftedArray a - -> Int - -> (# a #) -indexUnliftedArrayU (UnliftedArray src#) (I# i#) - = case indexArrayArrayArray# src# i# of - aa# -> (# fromArrayArray# aa# #) -{-# inline indexUnliftedArrayU #-} - --- | Gets the value at the specified position of an 'UnliftedArray'. -indexUnliftedArray - :: PrimUnlifted a - => UnliftedArray a -- ^ source - -> Int -- ^ index - -> a -indexUnliftedArray ua i - = case indexUnliftedArrayU ua i of (# v #) -> v -{-# inline indexUnliftedArray #-} - --- | Gets the value at the specified position of an 'UnliftedArray'. --- The purpose of the 'Monad' is to allow for being eager in the --- 'UnliftedArray' value without having to introduce a data dependency --- directly on the result value. --- --- It should be noted that this is not as much of a problem as with a normal --- 'Array', because elements of an 'UnliftedArray' are guaranteed to not --- be exceptional. This function is provided in case it is more desirable --- than being strict in the result value. -indexUnliftedArrayM - :: (PrimUnlifted a, Monad m) - => UnliftedArray a -- ^ source - -> Int -- ^ index - -> m a -indexUnliftedArrayM ua i - = case indexUnliftedArrayU ua i of - (# v #) -> return v -{-# inline indexUnliftedArrayM #-} - --- | Gets the value at the specified position of a 'MutableUnliftedArray'. -readUnliftedArray - :: (PrimMonad m, PrimUnlifted a) - => MutableUnliftedArray (PrimState m) a -- ^ source - -> Int -- ^ index - -> m a -readUnliftedArray (MutableUnliftedArray maa#) (I# i#) - = primitive $ \s -> case readArrayArrayArray# maa# i# s of - (# s', aa# #) -> (# s', fromArrayArray# aa# #) -{-# inline readUnliftedArray #-} - --- | Sets the value at the specified position of a 'MutableUnliftedArray'. -writeUnliftedArray - :: (PrimMonad m, PrimUnlifted a) - => MutableUnliftedArray (PrimState m) a -- ^ destination - -> Int -- ^ index - -> a -- ^ value - -> m () -writeUnliftedArray (MutableUnliftedArray maa#) (I# i#) a - = primitive_ (writeArrayArrayArray# maa# i# (toArrayArray# a)) -{-# inline writeUnliftedArray #-} - --- | Freezes a 'MutableUnliftedArray', yielding an 'UnliftedArray'. This simply --- marks the array as frozen in place, so it should only be used when no further --- modifications to the mutable array will be performed. -unsafeFreezeUnliftedArray - :: (PrimMonad m) - => MutableUnliftedArray (PrimState m) a - -> m (UnliftedArray a) -unsafeFreezeUnliftedArray (MutableUnliftedArray maa#) - = primitive $ \s -> case unsafeFreezeArrayArray# maa# s of - (# s', aa# #) -> (# s', UnliftedArray aa# #) -{-# inline unsafeFreezeUnliftedArray #-} - --- | Determines whether two 'MutableUnliftedArray' values are the same. This is --- object/pointer identity, not based on the contents. -sameMutableUnliftedArray - :: MutableUnliftedArray s a - -> MutableUnliftedArray s a - -> Bool -sameMutableUnliftedArray (MutableUnliftedArray maa1#) (MutableUnliftedArray maa2#) - = isTrue# (sameMutableArrayArray# maa1# maa2#) -{-# inline sameMutableUnliftedArray #-} - --- | Copies the contents of an immutable array into a mutable array. -copyUnliftedArray - :: (PrimMonad m) - => MutableUnliftedArray (PrimState m) a -- ^ destination - -> Int -- ^ offset into destination - -> UnliftedArray a -- ^ source - -> Int -- ^ offset into source - -> Int -- ^ number of elements to copy - -> m () -copyUnliftedArray - (MutableUnliftedArray dst) (I# doff) - (UnliftedArray src) (I# soff) (I# ln) = - primitive_ $ copyArrayArray# src soff dst doff ln -{-# inline copyUnliftedArray #-} - --- | Copies the contents of one mutable array into another. -copyMutableUnliftedArray - :: (PrimMonad m) - => MutableUnliftedArray (PrimState m) a -- ^ destination - -> Int -- ^ offset into destination - -> MutableUnliftedArray (PrimState m) a -- ^ source - -> Int -- ^ offset into source - -> Int -- ^ number of elements to copy - -> m () -copyMutableUnliftedArray - (MutableUnliftedArray dst) (I# doff) - (MutableUnliftedArray src) (I# soff) (I# ln) = - primitive_ $ copyMutableArrayArray# src soff dst doff ln -{-# inline copyMutableUnliftedArray #-} - --- | Freezes a portion of a 'MutableUnliftedArray', yielding an 'UnliftedArray'. --- This operation is safe, in that it copies the frozen portion, and the --- existing mutable array may still be used afterward. -freezeUnliftedArray - :: (PrimMonad m) - => MutableUnliftedArray (PrimState m) a -- ^ source - -> Int -- ^ offset - -> Int -- ^ length - -> m (UnliftedArray a) -freezeUnliftedArray src off len = do - dst <- unsafeNewUnliftedArray len - copyMutableUnliftedArray dst 0 src off len - unsafeFreezeUnliftedArray dst -{-# inline freezeUnliftedArray #-} - --- | Thaws a portion of an 'UnliftedArray', yielding a 'MutableUnliftedArray'. --- This copies the thawed portion, so mutations will not affect the original --- array. -thawUnliftedArray - :: (PrimMonad m) - => UnliftedArray a -- ^ source - -> Int -- ^ offset - -> Int -- ^ length - -> m (MutableUnliftedArray (PrimState m) a) -thawUnliftedArray src off len = do - dst <- unsafeNewUnliftedArray len - copyUnliftedArray dst 0 src off len - return dst -{-# inline thawUnliftedArray #-} - -#if !MIN_VERSION_base(4,9,0) -unsafeCreateUnliftedArray - :: Int - -> (forall s. MutableUnliftedArray s a -> ST s ()) - -> UnliftedArray a -unsafeCreateUnliftedArray 0 _ = emptyUnliftedArray -unsafeCreateUnliftedArray n f = runUnliftedArray $ do - mary <- unsafeNewUnliftedArray n - f mary - pure mary - --- | Execute a stateful computation and freeze the resulting array. -runUnliftedArray - :: (forall s. ST s (MutableUnliftedArray s a)) - -> UnliftedArray a -runUnliftedArray m = runST $ m >>= unsafeFreezeUnliftedArray - -#else /* Below, runRW# is available. */ - --- This low-level business is designed to work with GHC's worker-wrapper --- transformation. A lot of the time, we don't actually need an Array --- constructor. By putting it on the outside, and being careful about --- how we special-case the empty array, we can make GHC smarter about this. --- The only downside is that separately created 0-length arrays won't share --- their Array constructors, although they'll share their underlying --- Array#s. -unsafeCreateUnliftedArray - :: Int - -> (forall s. MutableUnliftedArray s a -> ST s ()) - -> UnliftedArray a -unsafeCreateUnliftedArray 0 _ = UnliftedArray (emptyArrayArray# (# #)) -unsafeCreateUnliftedArray n f = runUnliftedArray $ do - mary <- unsafeNewUnliftedArray n - f mary - pure mary - --- | Execute a stateful computation and freeze the resulting array. -runUnliftedArray - :: (forall s. ST s (MutableUnliftedArray s a)) - -> UnliftedArray a -runUnliftedArray m = UnliftedArray (runUnliftedArray# m) - -runUnliftedArray# - :: (forall s. ST s (MutableUnliftedArray s a)) - -> ArrayArray# -runUnliftedArray# m = case runRW# $ \s -> - case unST m s of { (# s', MutableUnliftedArray mary# #) -> - unsafeFreezeArrayArray# mary# s'} of (# _, ary# #) -> ary# - -unST :: ST s a -> State# s -> (# State# s, a #) -unST (GHCST.ST f) = f - -emptyArrayArray# :: (# #) -> ArrayArray# -emptyArrayArray# _ = case emptyUnliftedArray of UnliftedArray ar -> ar -{-# NOINLINE emptyArrayArray# #-} -#endif - --- | Creates a copy of a portion of an 'UnliftedArray' -cloneUnliftedArray - :: UnliftedArray a -- ^ source - -> Int -- ^ offset - -> Int -- ^ length - -> UnliftedArray a -cloneUnliftedArray src off len = - runUnliftedArray (thawUnliftedArray src off len) -{-# inline cloneUnliftedArray #-} - --- | Creates a new 'MutableUnliftedArray' containing a copy of a portion of --- another mutable array. -cloneMutableUnliftedArray - :: (PrimMonad m) - => MutableUnliftedArray (PrimState m) a -- ^ source - -> Int -- ^ offset - -> Int -- ^ length - -> m (MutableUnliftedArray (PrimState m) a) -cloneMutableUnliftedArray src off len = do - dst <- unsafeNewUnliftedArray len - copyMutableUnliftedArray dst 0 src off len - return dst -{-# inline cloneMutableUnliftedArray #-} - -instance Eq (MutableUnliftedArray s a) where - (==) = sameMutableUnliftedArray - -instance (Eq a, PrimUnlifted a) => Eq (UnliftedArray a) where - aa1 == aa2 = sizeofUnliftedArray aa1 == sizeofUnliftedArray aa2 - && loop (sizeofUnliftedArray aa1 - 1) - where - loop i - | i < 0 = True - | otherwise = indexUnliftedArray aa1 i == indexUnliftedArray aa2 i && loop (i-1) - --- | Lexicographic ordering. Subject to change between major versions. --- --- @since 0.6.4.0 -instance (Ord a, PrimUnlifted a) => Ord (UnliftedArray a) where - compare a1 a2 = loop 0 - where - mn = sizeofUnliftedArray a1 `min` sizeofUnliftedArray a2 - loop i - | i < mn - , x1 <- indexUnliftedArray a1 i - , x2 <- indexUnliftedArray a2 i - = compare x1 x2 `mappend` loop (i+1) - | otherwise = compare (sizeofUnliftedArray a1) (sizeofUnliftedArray a2) - --- | @since 0.6.4.0 -instance (Show a, PrimUnlifted a) => Show (UnliftedArray a) where - showsPrec p a = showParen (p > 10) $ - showString "fromListN " . shows (sizeofUnliftedArray a) . showString " " - . shows (unliftedArrayToList a) - -#if MIN_VERSION_base(4,9,0) --- | @since 0.6.4.0 -instance PrimUnlifted a => Semigroup (UnliftedArray a) where - (<>) = concatUnliftedArray -#endif - --- | @since 0.6.4.0 -instance PrimUnlifted a => Monoid (UnliftedArray a) where - mempty = emptyUnliftedArray -#if !(MIN_VERSION_base(4,11,0)) - mappend = concatUnliftedArray -#endif - -emptyUnliftedArray :: UnliftedArray a -emptyUnliftedArray = runUnliftedArray (unsafeNewUnliftedArray 0) -{-# NOINLINE emptyUnliftedArray #-} - -concatUnliftedArray :: UnliftedArray a -> UnliftedArray a -> UnliftedArray a -concatUnliftedArray x y = unsafeCreateUnliftedArray (sizeofUnliftedArray x + sizeofUnliftedArray y) $ \m -> do - copyUnliftedArray m 0 x 0 (sizeofUnliftedArray x) - copyUnliftedArray m (sizeofUnliftedArray x) y 0 (sizeofUnliftedArray y) - --- | Lazy right-associated fold over the elements of an 'UnliftedArray'. -{-# INLINE foldrUnliftedArray #-} -foldrUnliftedArray :: forall a b. PrimUnlifted a => (a -> b -> b) -> b -> UnliftedArray a -> b -foldrUnliftedArray f z arr = go 0 - where - !sz = sizeofUnliftedArray arr - go !i - | sz > i = f (indexUnliftedArray arr i) (go (i+1)) - | otherwise = z - --- | Strict right-associated fold over the elements of an 'UnliftedArray. -{-# INLINE foldrUnliftedArray' #-} -foldrUnliftedArray' :: forall a b. PrimUnlifted a => (a -> b -> b) -> b -> UnliftedArray a -> b -foldrUnliftedArray' f z0 arr = go (sizeofUnliftedArray arr - 1) z0 - where - go !i !acc - | i < 0 = acc - | otherwise = go (i - 1) (f (indexUnliftedArray arr i) acc) - --- | Lazy left-associated fold over the elements of an 'UnliftedArray'. -{-# INLINE foldlUnliftedArray #-} -foldlUnliftedArray :: forall a b. PrimUnlifted a => (b -> a -> b) -> b -> UnliftedArray a -> b -foldlUnliftedArray f z arr = go (sizeofUnliftedArray arr - 1) - where - go !i - | i < 0 = z - | otherwise = f (go (i - 1)) (indexUnliftedArray arr i) - --- | Strict left-associated fold over the elements of an 'UnliftedArray'. -{-# INLINE foldlUnliftedArray' #-} -foldlUnliftedArray' :: forall a b. PrimUnlifted a => (b -> a -> b) -> b -> UnliftedArray a -> b -foldlUnliftedArray' f z0 arr = go 0 z0 - where - !sz = sizeofUnliftedArray arr - go !i !acc - | i < sz = go (i + 1) (f acc (indexUnliftedArray arr i)) - | otherwise = acc - --- | Map over the elements of an 'UnliftedArray'. -{-# INLINE mapUnliftedArray #-} -mapUnliftedArray :: (PrimUnlifted a, PrimUnlifted b) - => (a -> b) - -> UnliftedArray a - -> UnliftedArray b -mapUnliftedArray f arr = unsafeCreateUnliftedArray sz $ \marr -> do - let go !ix = if ix < sz - then do - let b = f (indexUnliftedArray arr ix) - writeUnliftedArray marr ix b - go (ix + 1) - else return () - go 0 - where - !sz = sizeofUnliftedArray arr - --- | Convert the unlifted array to a list. -{-# INLINE unliftedArrayToList #-} -unliftedArrayToList :: PrimUnlifted a => UnliftedArray a -> [a] -unliftedArrayToList xs = build (\c n -> foldrUnliftedArray c n xs) - -unliftedArrayFromList :: PrimUnlifted a => [a] -> UnliftedArray a -unliftedArrayFromList xs = unliftedArrayFromListN (L.length xs) xs - -unliftedArrayFromListN :: forall a. PrimUnlifted a => Int -> [a] -> UnliftedArray a -unliftedArrayFromListN len vs = unsafeCreateUnliftedArray len run where - run :: forall s. MutableUnliftedArray s a -> ST s () - run arr = do - let go :: [a] -> Int -> ST s () - go [] !ix = if ix == len - -- The size check is mandatory since failure to initialize all elements - -- introduces the possibility of a segfault happening when someone attempts - -- to read the unitialized element. See the docs for unsafeNewUnliftedArray. - then return () - else die "unliftedArrayFromListN" "list length less than specified size" - go (a : as) !ix = if ix < len - then do - writeUnliftedArray arr ix a - go as (ix + 1) - else die "unliftedArrayFromListN" "list length greater than specified size" - go vs 0 - - -#if MIN_VERSION_base(4,7,0) --- | @since 0.6.4.0 -instance PrimUnlifted a => E.IsList (UnliftedArray a) where - type Item (UnliftedArray a) = a - fromList = unliftedArrayFromList - fromListN = unliftedArrayFromListN - toList = unliftedArrayToList -#endif - diff --git a/third_party/bazel/rules_haskell/examples/primitive/LICENSE b/third_party/bazel/rules_haskell/examples/primitive/LICENSE deleted file mode 100644 index fc213a6ffbfe..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright (c) 2008-2009, Roman Leshchinskiy -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -- Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. - -- Redistributions in binary form must reproduce the above copyright notice, -this list of conditions and the following disclaimer in the documentation -and/or other materials provided with the distribution. - -- Neither name of the University nor the names of its contributors may be -used to endorse or promote products derived from this software without -specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF -GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, -INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH -DAMAGE. - diff --git a/third_party/bazel/rules_haskell/examples/primitive/Setup.hs b/third_party/bazel/rules_haskell/examples/primitive/Setup.hs deleted file mode 100644 index 200a2e51d0b4..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff --git a/third_party/bazel/rules_haskell/examples/primitive/cbits/primitive-memops.c b/third_party/bazel/rules_haskell/examples/primitive/cbits/primitive-memops.c deleted file mode 100644 index 81b1d6f57530..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/cbits/primitive-memops.c +++ /dev/null @@ -1,56 +0,0 @@ -#include <string.h> -#include "primitive-memops.h" - -void hsprimitive_memcpy( void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len ) -{ - memcpy( (char *)dst + doff, (char *)src + soff, len ); -} - -void hsprimitive_memmove( void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len ) -{ - memmove( (char *)dst + doff, (char *)src + soff, len ); -} - -#define MEMSET(TYPE, ATYPE) \ -void hsprimitive_memset_ ## TYPE (Hs ## TYPE *p, ptrdiff_t off, size_t n, ATYPE x) \ -{ \ - p += off; \ - if (x == 0) \ - memset(p, 0, n * sizeof(Hs ## TYPE)); \ - else if (sizeof(Hs ## TYPE) == sizeof(int)*2) { \ - int *q = (int *)p; \ - const int *r = (const int *)(void *)&x; \ - while (n>0) { \ - q[0] = r[0]; \ - q[1] = r[1]; \ - q += 2; \ - --n; \ - } \ - } \ - else { \ - while (n>0) { \ - *p++ = x; \ - --n; \ - } \ - } \ -} - -int hsprimitive_memcmp( HsWord8 *s1, HsWord8 *s2, size_t n ) -{ - return memcmp( s1, s2, n ); -} - -void hsprimitive_memset_Word8 (HsWord8 *p, ptrdiff_t off, size_t n, HsWord x) -{ - memset( (char *)(p+off), x, n ); -} - -/* MEMSET(HsWord8, HsWord) */ -MEMSET(Word16, HsWord) -MEMSET(Word32, HsWord) -MEMSET(Word64, HsWord64) -MEMSET(Word, HsWord) -MEMSET(Ptr, HsPtr) -MEMSET(Float, HsFloat) -MEMSET(Double, HsDouble) -MEMSET(Char, HsChar) diff --git a/third_party/bazel/rules_haskell/examples/primitive/cbits/primitive-memops.h b/third_party/bazel/rules_haskell/examples/primitive/cbits/primitive-memops.h deleted file mode 100644 index d7c3396f8f8b..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/cbits/primitive-memops.h +++ /dev/null @@ -1,23 +0,0 @@ -#ifndef haskell_primitive_memops_h -#define haskell_primitive_memops_h - -#include <stdlib.h> -#include <stddef.h> -#include <HsFFI.h> - -void hsprimitive_memcpy( void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len ); -void hsprimitive_memmove( void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len ); -int hsprimitive_memcmp( HsWord8 *s1, HsWord8 *s2, size_t n ); - -void hsprimitive_memset_Word8 (HsWord8 *, ptrdiff_t, size_t, HsWord); -void hsprimitive_memset_Word16 (HsWord16 *, ptrdiff_t, size_t, HsWord); -void hsprimitive_memset_Word32 (HsWord32 *, ptrdiff_t, size_t, HsWord); -void hsprimitive_memset_Word64 (HsWord64 *, ptrdiff_t, size_t, HsWord64); -void hsprimitive_memset_Word (HsWord *, ptrdiff_t, size_t, HsWord); -void hsprimitive_memset_Ptr (HsPtr *, ptrdiff_t, size_t, HsPtr); -void hsprimitive_memset_Float (HsFloat *, ptrdiff_t, size_t, HsFloat); -void hsprimitive_memset_Double (HsDouble *, ptrdiff_t, size_t, HsDouble); -void hsprimitive_memset_Char (HsChar *, ptrdiff_t, size_t, HsChar); - -#endif - diff --git a/third_party/bazel/rules_haskell/examples/primitive/changelog.md b/third_party/bazel/rules_haskell/examples/primitive/changelog.md deleted file mode 100644 index 53485f664428..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/changelog.md +++ /dev/null @@ -1,164 +0,0 @@ -## Changes in version 0.6.4.0 - - * Introduce `Data.Primitive.PrimArray`, which offers types and function - for dealing with a `ByteArray` tagged with a phantom type variable for - tracking the element type. - - * Implement `isByteArrayPinned` and `isMutableByteArrayPinned`. - - * Add `Eq1`, `Ord1`, `Show1`, and `Read1` instances for `Array` and - `SmallArray`. - - * Improve the test suite. This includes having property tests for - typeclasses from `base` such as `Eq`, `Ord`, `Functor`, `Applicative`, - `Monad`, `IsList`, `Monoid`, `Foldable`, and `Traversable`. - - * Fix the broken `IsList` instance for `ByteArray`. The old definition - would allocate a byte array of the correct size and then leave the - memory unitialized instead of writing the list elements to it. - - * Fix the broken `Functor` instance for `Array`. The old definition - would allocate an array of the correct size with thunks for erroring - installed at every index. It failed to replace these thunks with - the result of the function applied to the elements of the argument array. - - * Fix the broken `Applicative` instances of `Array` and `SmallArray`. - The old implementation of `<*>` for `Array` failed to initialize - some elements but correctly initialized others in the resulting - `Array`. It is unclear what the old behavior of `<*>` was for - `SmallArray`, but it was incorrect. - - * Fix the broken `Monad` instances for `Array` and `SmallArray`. - - * Fix the implementation of `foldl1` in the `Foldable` instances for - `Array` and `SmallArray`. In both cases, the old implementation - simply returned the first element of the array and made no use of - the other elements in the array. - - * Fix the implementation of `mconcat` in the `Monoid` instance for - `SmallArray`. - - * Implement `Data.Primitive.Ptr`, implementations of `Ptr` functions - that require a `Prim` constraint instead of a `Storable` constraint. - - - * Add `PrimUnlifted` instances for `TVar` and `MVar`. - - * Use `compareByteArrays#` for the `Eq` and `Ord` instances of - `ByteArray` when building with GHC 8.4 and newer. - - * Add `Prim` instances for lots of types in `Foreign.C.Types` and - `System.Posix.Types`. - - * Reexport `Data.Primitive.SmallArray` and `Data.Primitive.UnliftedArray` - from `Data.Primitive`. - - * Add fold functions and map function to `Data.Primitive.UnliftedArray`. - Add typeclass instances for `IsList`, `Ord`, and `Show`. - - * Add `defaultSetByteArray#` and `defaultSetOffAddr#` to - `Data.Primitive.Types`. - -## Changes in version 0.6.3.0 - - * Add `PrimMonad` instances for `ContT`, `AccumT`, and `SelectT` from - `transformers` - - * Add `Eq`, `Ord`, `Show`, and `IsList` instances for `ByteArray` - - * Add `Semigroup` instances for `Array` and `SmallArray`. This allows - `primitive` to build on GHC 8.4 and later. - -## Changes in version 0.6.2.0 - - * Drop support for GHCs before 7.4 - - * `SmallArray` support - - * `ArrayArray#` based support for more efficient arrays of unlifted pointer types - - * Make `Array` and the like instances of various classes for convenient use - - * Add `Prim` instances for Ptr and FunPtr - - * Add `ioToPrim`, `stToPrim` and unsafe counterparts for situations that would - otherwise require type ascriptions on `primToPrim` - - * Add `evalPrim` - - * Add `PrimBase` instance for `IdentityT` - -## Changes in version 0.6.1.0 - - * Use more appropriate types in internal memset functions, which prevents - overflows/segfaults on 64-bit systems. - - * Fixed a warning on GHC 7.10 - - * Worked around a -dcore-lint bug in GHC 7.6/7.7 - -## Changes in version 0.6 - - * Split PrimMonad into two classes to allow automatic lifting of primitive - operations into monad transformers. The `internal` operation has moved to the - `PrimBase` class. - - * Fixed the test suite on older GHCs - -## Changes in version 0.5.4.0 - - * Changed primitive_ to work around an oddity with GHC's code generation - on certain versions that led to side effects not happening when used - in conjunction with certain very unsafe IO performers. - - * Allow primitive to build on GHC 7.9 - -## Changes in version 0.5.3.0 - - * Implement `cloneArray` and `cloneMutableArray` primitives - (with fall-back implementations for GHCs prior to version 7.2.1) - -## Changes in version 0.5.2.1 - - * Add strict variants of `MutVar` modification functions - `atomicModifyMutVar'` and `modifyMutVar'` - - * Fix compilation on Solaris 10 with GNU C 3.4.3 - -## Changes in version 0.5.1.0 - - * Add support for GHC 7.7's new primitive `Bool` representation - -## Changes in version 0.5.0.1 - - * Disable array copying primitives for GHC 7.6.* and earlier - -## Changes in version 0.5 - - * New in `Data.Primitive.MutVar`: `atomicModifyMutVar` - - * Efficient block fill operations: `setByteArray`, `setAddr` - -## Changes in version 0.4.1 - - * New module `Data.Primitive.MutVar` - -## Changes in version 0.4.0.1 - - * Critical bug fix in `fillByteArray` - -## Changes in version 0.4 - - * Support for GHC 7.2 array copying primitives - - * New in `Data.Primitive.ByteArray`: `copyByteArray`, - `copyMutableByteArray`, `moveByteArray`, `fillByteArray` - - * Deprecated in `Data.Primitive.ByteArray`: `memcpyByteArray`, - `memcpyByteArray'`, `memmoveByteArray`, `memsetByteArray` - - * New in `Data.Primitive.Array`: `copyArray`, `copyMutableByteArray` - - * New in `Data.Primitive.Addr`: `copyAddr`, `moveAddr` - - * Deprecated in `Data.Primitive.Addr`: `memcpyAddr` diff --git a/third_party/bazel/rules_haskell/examples/primitive/primitive.cabal b/third_party/bazel/rules_haskell/examples/primitive/primitive.cabal deleted file mode 100644 index e370f6d005a1..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/primitive.cabal +++ /dev/null @@ -1,74 +0,0 @@ -Name: primitive -Version: 0.6.4.0 -x-revision: 1 -License: BSD3 -License-File: LICENSE - -Author: Roman Leshchinskiy <rl@cse.unsw.edu.au> -Maintainer: libraries@haskell.org -Copyright: (c) Roman Leshchinskiy 2009-2012 -Homepage: https://github.com/haskell/primitive -Bug-Reports: https://github.com/haskell/primitive/issues -Category: Data -Synopsis: Primitive memory-related operations -Cabal-Version: >= 1.10 -Build-Type: Simple -Description: This package provides various primitive memory-related operations. - -Extra-Source-Files: changelog.md - test/*.hs - test/LICENSE - test/primitive-tests.cabal - -Tested-With: - GHC == 7.4.2, - GHC == 7.6.3, - GHC == 7.8.4, - GHC == 7.10.3, - GHC == 8.0.2, - GHC == 8.2.2, - GHC == 8.4.2 - -Library - Default-Language: Haskell2010 - Other-Extensions: - BangPatterns, CPP, DeriveDataTypeable, - MagicHash, TypeFamilies, UnboxedTuples, UnliftedFFITypes - - Exposed-Modules: - Control.Monad.Primitive - Data.Primitive - Data.Primitive.MachDeps - Data.Primitive.Types - Data.Primitive.Array - Data.Primitive.ByteArray - Data.Primitive.PrimArray - Data.Primitive.SmallArray - Data.Primitive.UnliftedArray - Data.Primitive.Addr - Data.Primitive.Ptr - Data.Primitive.MutVar - Data.Primitive.MVar - - Other-Modules: - Data.Primitive.Internal.Compat - Data.Primitive.Internal.Operations - - Build-Depends: base >= 4.5 && < 4.13 - , ghc-prim >= 0.2 && < 0.6 - , transformers >= 0.2 && < 0.6 - - Ghc-Options: -O2 - - Include-Dirs: cbits - Install-Includes: primitive-memops.h - includes: primitive-memops.h - c-sources: cbits/primitive-memops.c - if !os(solaris) - cc-options: -ftree-vectorize - if arch(i386) || arch(x86_64) - cc-options: -msse2 - -source-repository head - type: git - location: https://github.com/haskell/primitive diff --git a/third_party/bazel/rules_haskell/examples/primitive/test/LICENSE b/third_party/bazel/rules_haskell/examples/primitive/test/LICENSE deleted file mode 100644 index fc213a6ffbfe..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/test/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright (c) 2008-2009, Roman Leshchinskiy -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -- Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. - -- Redistributions in binary form must reproduce the above copyright notice, -this list of conditions and the following disclaimer in the documentation -and/or other materials provided with the distribution. - -- Neither name of the University nor the names of its contributors may be -used to endorse or promote products derived from this software without -specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF -GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, -INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH -DAMAGE. - diff --git a/third_party/bazel/rules_haskell/examples/primitive/test/main.hs b/third_party/bazel/rules_haskell/examples/primitive/test/main.hs deleted file mode 100644 index abec96df032d..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/test/main.hs +++ /dev/null @@ -1,342 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE ScopedTypeVariables #-} - -import Control.Applicative -import Control.Monad -import Control.Monad.Fix (fix) -import Control.Monad.Primitive -import Control.Monad.ST -import Data.Monoid -import Data.Primitive -import Data.Primitive.Array -import Data.Primitive.ByteArray -import Data.Primitive.Types -import Data.Primitive.SmallArray -import Data.Primitive.PrimArray -import Data.Word -import Data.Proxy (Proxy(..)) -import GHC.Int -import GHC.IO -import GHC.Prim -import Data.Function (on) -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup (stimes) -#endif - -import Test.Tasty (defaultMain,testGroup,TestTree) -import Test.QuickCheck (Arbitrary,Arbitrary1,Gen,(===),CoArbitrary,Function) -import qualified Test.Tasty.QuickCheck as TQC -import qualified Test.QuickCheck as QC -import qualified Test.QuickCheck.Classes as QCC -import qualified Test.QuickCheck.Classes.IsList as QCCL -import qualified Data.List as L - -main :: IO () -main = do - testArray - testByteArray - defaultMain $ testGroup "properties" - [ testGroup "Array" - [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (Array Int))) - , lawsToTest (QCC.ordLaws (Proxy :: Proxy (Array Int))) - , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (Array Int))) - , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int))) -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) - , lawsToTest (QCC.functorLaws (Proxy1 :: Proxy1 Array)) - , lawsToTest (QCC.applicativeLaws (Proxy1 :: Proxy1 Array)) - , lawsToTest (QCC.monadLaws (Proxy1 :: Proxy1 Array)) - , lawsToTest (QCC.foldableLaws (Proxy1 :: Proxy1 Array)) - , lawsToTest (QCC.traversableLaws (Proxy1 :: Proxy1 Array)) -#endif -#if MIN_VERSION_base(4,7,0) - , lawsToTest (QCC.isListLaws (Proxy :: Proxy (Array Int))) - , TQC.testProperty "mapArray'" (QCCL.mapProp int16 int32 mapArray') -#endif - ] - , testGroup "SmallArray" - [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (SmallArray Int))) - , lawsToTest (QCC.ordLaws (Proxy :: Proxy (SmallArray Int))) - , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (SmallArray Int))) - , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int))) -#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) - , lawsToTest (QCC.functorLaws (Proxy1 :: Proxy1 SmallArray)) - , lawsToTest (QCC.applicativeLaws (Proxy1 :: Proxy1 SmallArray)) - , lawsToTest (QCC.monadLaws (Proxy1 :: Proxy1 SmallArray)) - , lawsToTest (QCC.foldableLaws (Proxy1 :: Proxy1 SmallArray)) - , lawsToTest (QCC.traversableLaws (Proxy1 :: Proxy1 SmallArray)) -#endif -#if MIN_VERSION_base(4,7,0) - , lawsToTest (QCC.isListLaws (Proxy :: Proxy (SmallArray Int))) - , TQC.testProperty "mapSmallArray'" (QCCL.mapProp int16 int32 mapSmallArray') -#endif - ] - , testGroup "ByteArray" - [ testGroup "Ordering" - [ TQC.testProperty "equality" byteArrayEqProp - , TQC.testProperty "compare" byteArrayCompareProp - ] - , testGroup "Resize" - [ TQC.testProperty "shrink" byteArrayShrinkProp - , TQC.testProperty "grow" byteArrayGrowProp - ] - , lawsToTest (QCC.eqLaws (Proxy :: Proxy ByteArray)) - , lawsToTest (QCC.ordLaws (Proxy :: Proxy ByteArray)) - , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int))) -#if MIN_VERSION_base(4,7,0) - , lawsToTest (QCC.isListLaws (Proxy :: Proxy ByteArray)) -#endif - ] - , testGroup "PrimArray" - [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (PrimArray Word16))) - , lawsToTest (QCC.ordLaws (Proxy :: Proxy (PrimArray Word16))) - , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (PrimArray Word16))) -#if MIN_VERSION_base(4,7,0) - , lawsToTest (QCC.isListLaws (Proxy :: Proxy (PrimArray Word16))) - , TQC.testProperty "foldrPrimArray" (QCCL.foldrProp int16 foldrPrimArray) - , TQC.testProperty "foldrPrimArray'" (QCCL.foldrProp int16 foldrPrimArray') - , TQC.testProperty "foldlPrimArray" (QCCL.foldlProp int16 foldlPrimArray) - , TQC.testProperty "foldlPrimArray'" (QCCL.foldlProp int16 foldlPrimArray') - , TQC.testProperty "foldlPrimArrayM'" (QCCL.foldlMProp int16 foldlPrimArrayM') - , TQC.testProperty "mapPrimArray" (QCCL.mapProp int16 int32 mapPrimArray) - , TQC.testProperty "traversePrimArray" (QCCL.traverseProp int16 int32 traversePrimArray) - , TQC.testProperty "traversePrimArrayP" (QCCL.traverseProp int16 int32 traversePrimArrayP) - , TQC.testProperty "imapPrimArray" (QCCL.imapProp int16 int32 imapPrimArray) - , TQC.testProperty "itraversePrimArray" (QCCL.imapMProp int16 int32 itraversePrimArray) - , TQC.testProperty "itraversePrimArrayP" (QCCL.imapMProp int16 int32 itraversePrimArrayP) - , TQC.testProperty "generatePrimArray" (QCCL.generateProp int16 generatePrimArray) - , TQC.testProperty "generatePrimArrayA" (QCCL.generateMProp int16 generatePrimArrayA) - , TQC.testProperty "generatePrimArrayP" (QCCL.generateMProp int16 generatePrimArrayP) - , TQC.testProperty "replicatePrimArray" (QCCL.replicateProp int16 replicatePrimArray) - , TQC.testProperty "replicatePrimArrayA" (QCCL.replicateMProp int16 replicatePrimArrayA) - , TQC.testProperty "replicatePrimArrayP" (QCCL.replicateMProp int16 replicatePrimArrayP) - , TQC.testProperty "filterPrimArray" (QCCL.filterProp int16 filterPrimArray) - , TQC.testProperty "filterPrimArrayA" (QCCL.filterMProp int16 filterPrimArrayA) - , TQC.testProperty "filterPrimArrayP" (QCCL.filterMProp int16 filterPrimArrayP) - , TQC.testProperty "mapMaybePrimArray" (QCCL.mapMaybeProp int16 int32 mapMaybePrimArray) - , TQC.testProperty "mapMaybePrimArrayA" (QCCL.mapMaybeMProp int16 int32 mapMaybePrimArrayA) - , TQC.testProperty "mapMaybePrimArrayP" (QCCL.mapMaybeMProp int16 int32 mapMaybePrimArrayP) -#endif - ] - , testGroup "UnliftedArray" - [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16)))) - , lawsToTest (QCC.ordLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16)))) - , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16)))) -#if MIN_VERSION_base(4,7,0) - , lawsToTest (QCC.isListLaws (Proxy :: Proxy (UnliftedArray (PrimArray Int16)))) - , TQC.testProperty "mapUnliftedArray" (QCCL.mapProp arrInt16 arrInt32 mapUnliftedArray) - , TQC.testProperty "foldrUnliftedArray" (QCCL.foldrProp arrInt16 foldrUnliftedArray) - , TQC.testProperty "foldrUnliftedArray'" (QCCL.foldrProp arrInt16 foldrUnliftedArray') - , TQC.testProperty "foldlUnliftedArray" (QCCL.foldlProp arrInt16 foldlUnliftedArray) - , TQC.testProperty "foldlUnliftedArray'" (QCCL.foldlProp arrInt16 foldlUnliftedArray') -#endif - ] - , testGroup "DefaultSetMethod" - [ lawsToTest (QCC.primLaws (Proxy :: Proxy DefaultSetMethod)) - ] - -- , testGroup "PrimStorable" - -- [ lawsToTest (QCC.storableLaws (Proxy :: Proxy Derived)) - -- ] - ] - -int16 :: Proxy Int16 -int16 = Proxy - -int32 :: Proxy Int32 -int32 = Proxy - -arrInt16 :: Proxy (PrimArray Int16) -arrInt16 = Proxy - -arrInt32 :: Proxy (PrimArray Int16) -arrInt32 = Proxy - --- Tests that using resizeByteArray to shrink a byte array produces --- the same results as calling Data.List.take on the list that the --- byte array corresponds to. -byteArrayShrinkProp :: QC.Property -byteArrayShrinkProp = QC.property $ \(QC.NonNegative (n :: Int)) (QC.NonNegative (m :: Int)) -> - let large = max n m - small = min n m - xs = intsLessThan large - ys = byteArrayFromList xs - largeBytes = large * sizeOf (undefined :: Int) - smallBytes = small * sizeOf (undefined :: Int) - expected = byteArrayFromList (L.take small xs) - actual = runST $ do - mzs0 <- newByteArray largeBytes - copyByteArray mzs0 0 ys 0 largeBytes - mzs1 <- resizeMutableByteArray mzs0 smallBytes - unsafeFreezeByteArray mzs1 - in expected === actual - --- Tests that using resizeByteArray with copyByteArray (to fill in the --- new empty space) to grow a byte array produces the same results as --- calling Data.List.++ on the lists corresponding to the original --- byte array and the appended byte array. -byteArrayGrowProp :: QC.Property -byteArrayGrowProp = QC.property $ \(QC.NonNegative (n :: Int)) (QC.NonNegative (m :: Int)) -> - let large = max n m - small = min n m - xs1 = intsLessThan small - xs2 = intsLessThan (large - small) - ys1 = byteArrayFromList xs1 - ys2 = byteArrayFromList xs2 - largeBytes = large * sizeOf (undefined :: Int) - smallBytes = small * sizeOf (undefined :: Int) - expected = byteArrayFromList (xs1 ++ xs2) - actual = runST $ do - mzs0 <- newByteArray smallBytes - copyByteArray mzs0 0 ys1 0 smallBytes - mzs1 <- resizeMutableByteArray mzs0 largeBytes - copyByteArray mzs1 smallBytes ys2 0 ((large - small) * sizeOf (undefined :: Int)) - unsafeFreezeByteArray mzs1 - in expected === actual - --- Provide the non-negative integers up to the bound. For example: --- --- >>> intsLessThan 5 --- [0,1,2,3,4] -intsLessThan :: Int -> [Int] -intsLessThan i = if i < 1 - then [] - else (i - 1) : intsLessThan (i - 1) - -byteArrayCompareProp :: QC.Property -byteArrayCompareProp = QC.property $ \(xs :: [Word8]) (ys :: [Word8]) -> - compareLengthFirst xs ys === compare (byteArrayFromList xs) (byteArrayFromList ys) - -byteArrayEqProp :: QC.Property -byteArrayEqProp = QC.property $ \(xs :: [Word8]) (ys :: [Word8]) -> - (compareLengthFirst xs ys == EQ) === (byteArrayFromList xs == byteArrayFromList ys) - -compareLengthFirst :: [Word8] -> [Word8] -> Ordering -compareLengthFirst xs ys = (compare `on` length) xs ys <> compare xs ys - --- on GHC 7.4, Proxy is not polykinded, so we need this instead. -data Proxy1 (f :: * -> *) = Proxy1 - -lawsToTest :: QCC.Laws -> TestTree -lawsToTest (QCC.Laws name pairs) = testGroup name (map (uncurry TQC.testProperty) pairs) - -testArray :: IO () -testArray = do - arr <- newArray 1 'A' - let unit = - case writeArray arr 0 'B' of - IO f -> - case f realWorld# of - (# _, _ #) -> () - c1 <- readArray arr 0 - return $! unit - c2 <- readArray arr 0 - if c1 == 'A' && c2 == 'B' - then return () - else error $ "Expected AB, got: " ++ show (c1, c2) - -testByteArray :: IO () -testByteArray = do - let arr1 = mkByteArray ([0xde, 0xad, 0xbe, 0xef] :: [Word8]) - arr2 = mkByteArray ([0xde, 0xad, 0xbe, 0xef] :: [Word8]) - arr3 = mkByteArray ([0xde, 0xad, 0xbe, 0xee] :: [Word8]) - arr4 = mkByteArray ([0xde, 0xad, 0xbe, 0xdd] :: [Word8]) - arr5 = mkByteArray ([0xde, 0xad, 0xbe, 0xef, 0xde, 0xad, 0xbe, 0xdd] :: [Word8]) - when (show arr1 /= "[0xde, 0xad, 0xbe, 0xef]") $ - fail $ "ByteArray Show incorrect: "++show arr1 - unless (arr1 > arr3) $ - fail $ "ByteArray Ord incorrect" - unless (arr1 == arr2) $ - fail $ "ByteArray Eq incorrect" - unless (mappend arr1 arr4 == arr5) $ - fail $ "ByteArray Monoid mappend incorrect" - unless (mappend arr1 (mappend arr3 arr4) == mappend (mappend arr1 arr3) arr4) $ - fail $ "ByteArray Monoid mappend not associative" - unless (mconcat [arr1,arr2,arr3,arr4,arr5] == (arr1 <> arr2 <> arr3 <> arr4 <> arr5)) $ - fail $ "ByteArray Monoid mconcat incorrect" -#if MIN_VERSION_base(4,9,0) - unless (stimes (3 :: Int) arr4 == (arr4 <> arr4 <> arr4)) $ - fail $ "ByteArray Semigroup stimes incorrect" -#endif - -mkByteArray :: Prim a => [a] -> ByteArray -mkByteArray xs = runST $ do - marr <- newByteArray (length xs * sizeOf (head xs)) - sequence $ zipWith (writeByteArray marr) [0..] xs - unsafeFreezeByteArray marr - -instance Arbitrary1 Array where - liftArbitrary elemGen = fmap fromList (QC.liftArbitrary elemGen) - -instance Arbitrary a => Arbitrary (Array a) where - arbitrary = fmap fromList QC.arbitrary - -instance Arbitrary1 SmallArray where - liftArbitrary elemGen = fmap smallArrayFromList (QC.liftArbitrary elemGen) - -instance Arbitrary a => Arbitrary (SmallArray a) where - arbitrary = fmap smallArrayFromList QC.arbitrary - -instance Arbitrary ByteArray where - arbitrary = do - xs <- QC.arbitrary :: Gen [Word8] - return $ runST $ do - a <- newByteArray (L.length xs) - iforM_ xs $ \ix x -> do - writeByteArray a ix x - unsafeFreezeByteArray a - -instance (Arbitrary a, Prim a) => Arbitrary (PrimArray a) where - arbitrary = do - xs <- QC.arbitrary :: Gen [a] - return $ runST $ do - a <- newPrimArray (L.length xs) - iforM_ xs $ \ix x -> do - writePrimArray a ix x - unsafeFreezePrimArray a - -instance (Arbitrary a, PrimUnlifted a) => Arbitrary (UnliftedArray a) where - arbitrary = do - xs <- QC.vector =<< QC.choose (0,3) - return (unliftedArrayFromList xs) - -instance (Prim a, CoArbitrary a) => CoArbitrary (PrimArray a) where - coarbitrary x = QC.coarbitrary (primArrayToList x) - -instance (Prim a, Function a) => Function (PrimArray a) where - function = QC.functionMap primArrayToList primArrayFromList - -iforM_ :: Monad m => [a] -> (Int -> a -> m b) -> m () -iforM_ xs0 f = go 0 xs0 where - go !_ [] = return () - go !ix (x : xs) = f ix x >> go (ix + 1) xs - -newtype DefaultSetMethod = DefaultSetMethod Int16 - deriving (Eq,Show,Arbitrary) - -instance Prim DefaultSetMethod where - sizeOf# _ = sizeOf# (undefined :: Int16) - alignment# _ = alignment# (undefined :: Int16) - indexByteArray# arr ix = DefaultSetMethod (indexByteArray# arr ix) - readByteArray# arr ix s0 = case readByteArray# arr ix s0 of - (# s1, n #) -> (# s1, DefaultSetMethod n #) - writeByteArray# arr ix (DefaultSetMethod n) s0 = writeByteArray# arr ix n s0 - setByteArray# = defaultSetByteArray# - indexOffAddr# addr off = DefaultSetMethod (indexOffAddr# addr off) - readOffAddr# addr off s0 = case readOffAddr# addr off s0 of - (# s1, n #) -> (# s1, DefaultSetMethod n #) - writeOffAddr# addr off (DefaultSetMethod n) s0 = writeOffAddr# addr off n s0 - setOffAddr# = defaultSetOffAddr# - --- TODO: Uncomment this out when GHC 8.6 is release. Also, uncomment --- the corresponding PrimStorable test group above. --- --- newtype Derived = Derived Int16 --- deriving newtype (Prim) --- deriving Storable via (PrimStorable Derived) - - - diff --git a/third_party/bazel/rules_haskell/examples/primitive/test/primitive-tests.cabal b/third_party/bazel/rules_haskell/examples/primitive/test/primitive-tests.cabal deleted file mode 100644 index 957fe5ee1f64..000000000000 --- a/third_party/bazel/rules_haskell/examples/primitive/test/primitive-tests.cabal +++ /dev/null @@ -1,45 +0,0 @@ -Name: primitive-tests -Version: 0.1 -License: BSD3 -License-File: LICENSE - -Author: Roman Leshchinskiy <rl@cse.unsw.edu.au> -Maintainer: libraries@haskell.org -Copyright: (c) Roman Leshchinskiy 2009-2012 -Homepage: https://github.com/haskell/primitive -Bug-Reports: https://github.com/haskell/primitive/issues -Category: Data -Synopsis: primitive tests -Cabal-Version: >= 1.10 -Build-Type: Simple -Description: @primitive@ tests - -Tested-With: - GHC == 7.4.2, - GHC == 7.6.3, - GHC == 7.8.4, - GHC == 7.10.3, - GHC == 8.0.2, - GHC == 8.2.2, - GHC == 8.4.2 - -test-suite test - Default-Language: Haskell2010 - hs-source-dirs: . - main-is: main.hs - type: exitcode-stdio-1.0 - build-depends: base >= 4.5 && < 4.12 - , ghc-prim - , primitive - , QuickCheck - , tasty - , tasty-quickcheck - , tagged - , transformers >= 0.3 - , quickcheck-classes >= 0.4.11.1 - ghc-options: -O2 - -source-repository head - type: git - location: https://github.com/haskell/primitive - subdir: test diff --git a/third_party/bazel/rules_haskell/examples/rts/BUILD.bazel b/third_party/bazel/rules_haskell/examples/rts/BUILD.bazel deleted file mode 100644 index 1bbf94b1c0a9..000000000000 --- a/third_party/bazel/rules_haskell/examples/rts/BUILD.bazel +++ /dev/null @@ -1,29 +0,0 @@ -load( - "@io_tweag_rules_haskell//haskell:haskell.bzl", - "cc_haskell_import", - "haskell_library", - "haskell_toolchain_library", -) - -haskell_toolchain_library(name = "base") - -haskell_library( - name = "add-one-hs", - srcs = ["One.hs"], - deps = [":base"], -) - -cc_haskell_import( - name = "add-one-so", - dep = ":add-one-hs", -) - -cc_test( - name = "add-one", - srcs = [ - "main.c", - ":add-one-so", - ], - visibility = ["//visibility:public"], - deps = ["@ghc//:threaded-rts"], -) diff --git a/third_party/bazel/rules_haskell/examples/rts/One.hs b/third_party/bazel/rules_haskell/examples/rts/One.hs deleted file mode 100644 index bc24fb7cb274..000000000000 --- a/third_party/bazel/rules_haskell/examples/rts/One.hs +++ /dev/null @@ -1,6 +0,0 @@ -module One () where - -add_one_hs :: Int -> Int -add_one_hs x = x + 1 - -foreign export ccall add_one_hs :: Int -> Int diff --git a/third_party/bazel/rules_haskell/examples/rts/main.c b/third_party/bazel/rules_haskell/examples/rts/main.c deleted file mode 100644 index 28624227d8c0..000000000000 --- a/third_party/bazel/rules_haskell/examples/rts/main.c +++ /dev/null @@ -1,11 +0,0 @@ -#include <stdio.h> -#include "HsFFI.h" - -extern HsInt add_one_hs(HsInt a0); - -int main(int argc, char *argv[]) { - hs_init(&argc, &argv); - printf("Adding one to 5 through Haskell is %ld\n", add_one_hs(5)); - hs_exit(); - return 0; -} diff --git a/third_party/bazel/rules_haskell/examples/transformers/BUILD.bazel b/third_party/bazel/rules_haskell/examples/transformers/BUILD.bazel deleted file mode 100644 index 092111f9f19a..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/BUILD.bazel +++ /dev/null @@ -1,19 +0,0 @@ -load( - "@io_tweag_rules_haskell//haskell:haskell.bzl", - "haskell_cc_import", - "haskell_library", - "haskell_toolchain_library", -) - -haskell_toolchain_library(name = "base") - -haskell_library( - name = "transformers", - srcs = glob([ - "Data/**/*.hs", - "Control/**/*.hs", - ]), - version = "0", - visibility = ["//visibility:public"], - deps = [":base"], -) diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Applicative/Backwards.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Applicative/Backwards.hs deleted file mode 100644 index 7ed74acbace0..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Control/Applicative/Backwards.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -#endif -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE AutoDeriveTypeable #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Applicative.Backwards --- Copyright : (c) Russell O'Connor 2009 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- Making functors with an 'Applicative' instance that performs actions --- in the reverse order. ------------------------------------------------------------------------------ - -module Control.Applicative.Backwards ( - Backwards(..), - ) where - -import Data.Functor.Classes -#if MIN_VERSION_base(4,12,0) -import Data.Functor.Contravariant -#endif - -import Prelude hiding (foldr, foldr1, foldl, foldl1, null, length) -import Control.Applicative -import Data.Foldable -import Data.Traversable - --- | The same functor, but with an 'Applicative' instance that performs --- actions in the reverse order. -newtype Backwards f a = Backwards { forwards :: f a } - -instance (Eq1 f) => Eq1 (Backwards f) where - liftEq eq (Backwards x) (Backwards y) = liftEq eq x y - {-# INLINE liftEq #-} - -instance (Ord1 f) => Ord1 (Backwards f) where - liftCompare comp (Backwards x) (Backwards y) = liftCompare comp x y - {-# INLINE liftCompare #-} - -instance (Read1 f) => Read1 (Backwards f) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp rl) "Backwards" Backwards - -instance (Show1 f) => Show1 (Backwards f) where - liftShowsPrec sp sl d (Backwards x) = - showsUnaryWith (liftShowsPrec sp sl) "Backwards" d x - -instance (Eq1 f, Eq a) => Eq (Backwards f a) where (==) = eq1 -instance (Ord1 f, Ord a) => Ord (Backwards f a) where compare = compare1 -instance (Read1 f, Read a) => Read (Backwards f a) where readsPrec = readsPrec1 -instance (Show1 f, Show a) => Show (Backwards f a) where showsPrec = showsPrec1 - --- | Derived instance. -instance (Functor f) => Functor (Backwards f) where - fmap f (Backwards a) = Backwards (fmap f a) - {-# INLINE fmap #-} - --- | Apply @f@-actions in the reverse order. -instance (Applicative f) => Applicative (Backwards f) where - pure a = Backwards (pure a) - {-# INLINE pure #-} - Backwards f <*> Backwards a = Backwards (a <**> f) - {-# INLINE (<*>) #-} - --- | Try alternatives in the same order as @f@. -instance (Alternative f) => Alternative (Backwards f) where - empty = Backwards empty - {-# INLINE empty #-} - Backwards x <|> Backwards y = Backwards (x <|> y) - {-# INLINE (<|>) #-} - --- | Derived instance. -instance (Foldable f) => Foldable (Backwards f) where - foldMap f (Backwards t) = foldMap f t - {-# INLINE foldMap #-} - foldr f z (Backwards t) = foldr f z t - {-# INLINE foldr #-} - foldl f z (Backwards t) = foldl f z t - {-# INLINE foldl #-} - foldr1 f (Backwards t) = foldr1 f t - {-# INLINE foldr1 #-} - foldl1 f (Backwards t) = foldl1 f t - {-# INLINE foldl1 #-} -#if MIN_VERSION_base(4,8,0) - null (Backwards t) = null t - length (Backwards t) = length t -#endif - --- | Derived instance. -instance (Traversable f) => Traversable (Backwards f) where - traverse f (Backwards t) = fmap Backwards (traverse f t) - {-# INLINE traverse #-} - sequenceA (Backwards t) = fmap Backwards (sequenceA t) - {-# INLINE sequenceA #-} - -#if MIN_VERSION_base(4,12,0) --- | Derived instance. -instance Contravariant f => Contravariant (Backwards f) where - contramap f = Backwards . contramap f . forwards - {-# INLINE contramap #-} -#endif diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Applicative/Lift.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Applicative/Lift.hs deleted file mode 100644 index 8d35e288c025..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Control/Applicative/Lift.hs +++ /dev/null @@ -1,165 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE AutoDeriveTypeable #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Applicative.Lift --- Copyright : (c) Ross Paterson 2010 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- Adding a new kind of pure computation to an applicative functor. ------------------------------------------------------------------------------ - -module Control.Applicative.Lift ( - -- * Lifting an applicative - Lift(..), - unLift, - mapLift, - elimLift, - -- * Collecting errors - Errors, - runErrors, - failure, - eitherToErrors - ) where - -import Data.Functor.Classes - -import Control.Applicative -import Data.Foldable (Foldable(foldMap)) -import Data.Functor.Constant -import Data.Monoid (Monoid(..)) -import Data.Traversable (Traversable(traverse)) - --- | Applicative functor formed by adding pure computations to a given --- applicative functor. -data Lift f a = Pure a | Other (f a) - -instance (Eq1 f) => Eq1 (Lift f) where - liftEq eq (Pure x1) (Pure x2) = eq x1 x2 - liftEq _ (Pure _) (Other _) = False - liftEq _ (Other _) (Pure _) = False - liftEq eq (Other y1) (Other y2) = liftEq eq y1 y2 - {-# INLINE liftEq #-} - -instance (Ord1 f) => Ord1 (Lift f) where - liftCompare comp (Pure x1) (Pure x2) = comp x1 x2 - liftCompare _ (Pure _) (Other _) = LT - liftCompare _ (Other _) (Pure _) = GT - liftCompare comp (Other y1) (Other y2) = liftCompare comp y1 y2 - {-# INLINE liftCompare #-} - -instance (Read1 f) => Read1 (Lift f) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith rp "Pure" Pure `mappend` - readsUnaryWith (liftReadsPrec rp rl) "Other" Other - -instance (Show1 f) => Show1 (Lift f) where - liftShowsPrec sp _ d (Pure x) = showsUnaryWith sp "Pure" d x - liftShowsPrec sp sl d (Other y) = - showsUnaryWith (liftShowsPrec sp sl) "Other" d y - -instance (Eq1 f, Eq a) => Eq (Lift f a) where (==) = eq1 -instance (Ord1 f, Ord a) => Ord (Lift f a) where compare = compare1 -instance (Read1 f, Read a) => Read (Lift f a) where readsPrec = readsPrec1 -instance (Show1 f, Show a) => Show (Lift f a) where showsPrec = showsPrec1 - -instance (Functor f) => Functor (Lift f) where - fmap f (Pure x) = Pure (f x) - fmap f (Other y) = Other (fmap f y) - {-# INLINE fmap #-} - -instance (Foldable f) => Foldable (Lift f) where - foldMap f (Pure x) = f x - foldMap f (Other y) = foldMap f y - {-# INLINE foldMap #-} - -instance (Traversable f) => Traversable (Lift f) where - traverse f (Pure x) = Pure <$> f x - traverse f (Other y) = Other <$> traverse f y - {-# INLINE traverse #-} - --- | A combination is 'Pure' only if both parts are. -instance (Applicative f) => Applicative (Lift f) where - pure = Pure - {-# INLINE pure #-} - Pure f <*> Pure x = Pure (f x) - Pure f <*> Other y = Other (f <$> y) - Other f <*> Pure x = Other (($ x) <$> f) - Other f <*> Other y = Other (f <*> y) - {-# INLINE (<*>) #-} - --- | A combination is 'Pure' only either part is. -instance (Alternative f) => Alternative (Lift f) where - empty = Other empty - {-# INLINE empty #-} - Pure x <|> _ = Pure x - Other _ <|> Pure y = Pure y - Other x <|> Other y = Other (x <|> y) - {-# INLINE (<|>) #-} - --- | Projection to the other functor. -unLift :: (Applicative f) => Lift f a -> f a -unLift (Pure x) = pure x -unLift (Other e) = e -{-# INLINE unLift #-} - --- | Apply a transformation to the other computation. -mapLift :: (f a -> g a) -> Lift f a -> Lift g a -mapLift _ (Pure x) = Pure x -mapLift f (Other e) = Other (f e) -{-# INLINE mapLift #-} - --- | Eliminator for 'Lift'. --- --- * @'elimLift' f g . 'pure' = f@ --- --- * @'elimLift' f g . 'Other' = g@ --- -elimLift :: (a -> r) -> (f a -> r) -> Lift f a -> r -elimLift f _ (Pure x) = f x -elimLift _ g (Other e) = g e -{-# INLINE elimLift #-} - --- | An applicative functor that collects a monoid (e.g. lists) of errors. --- A sequence of computations fails if any of its components do, but --- unlike monads made with 'ExceptT' from "Control.Monad.Trans.Except", --- these computations continue after an error, collecting all the errors. --- --- * @'pure' f '<*>' 'pure' x = 'pure' (f x)@ --- --- * @'pure' f '<*>' 'failure' e = 'failure' e@ --- --- * @'failure' e '<*>' 'pure' x = 'failure' e@ --- --- * @'failure' e1 '<*>' 'failure' e2 = 'failure' (e1 '<>' e2)@ --- -type Errors e = Lift (Constant e) - --- | Extractor for computations with accumulating errors. --- --- * @'runErrors' ('pure' x) = 'Right' x@ --- --- * @'runErrors' ('failure' e) = 'Left' e@ --- -runErrors :: Errors e a -> Either e a -runErrors (Other (Constant e)) = Left e -runErrors (Pure x) = Right x -{-# INLINE runErrors #-} - --- | Report an error. -failure :: e -> Errors e a -failure e = Other (Constant e) -{-# INLINE failure #-} - --- | Convert from 'Either' to 'Errors' (inverse of 'runErrors'). -eitherToErrors :: Either e a -> Errors e a -eitherToErrors = either failure Pure diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Signatures.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Signatures.hs deleted file mode 100644 index ce128ee182e1..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Signatures.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Signatures --- Copyright : (c) Ross Paterson 2012 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- Signatures for monad operations that require specialized lifting. --- Each signature has a uniformity property that the lifting should satisfy. ------------------------------------------------------------------------------ - -module Control.Monad.Signatures ( - CallCC, Catch, Listen, Pass - ) where - --- | Signature of the @callCC@ operation, --- introduced in "Control.Monad.Trans.Cont". --- Any lifting function @liftCallCC@ should satisfy --- --- * @'lift' (f k) = f' ('lift' . k) => 'lift' (cf f) = liftCallCC cf f'@ --- -type CallCC m a b = ((a -> m b) -> m a) -> m a - --- | Signature of the @catchE@ operation, --- introduced in "Control.Monad.Trans.Except". --- Any lifting function @liftCatch@ should satisfy --- --- * @'lift' (cf m f) = liftCatch ('lift' . cf) ('lift' f)@ --- -type Catch e m a = m a -> (e -> m a) -> m a - --- | Signature of the @listen@ operation, --- introduced in "Control.Monad.Trans.Writer". --- Any lifting function @liftListen@ should satisfy --- --- * @'lift' . liftListen = liftListen . 'lift'@ --- -type Listen w m a = m a -> m (a, w) - --- | Signature of the @pass@ operation, --- introduced in "Control.Monad.Trans.Writer". --- Any lifting function @liftPass@ should satisfy --- --- * @'lift' . liftPass = liftPass . 'lift'@ --- -type Pass w m a = m (a, w -> w) -> m a diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Accum.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Accum.hs deleted file mode 100644 index 0a85c43f62bb..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Accum.hs +++ /dev/null @@ -1,292 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE AutoDeriveTypeable #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Trans.Accum --- Copyright : (c) Nickolay Kudasov 2016 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- The lazy 'AccumT' monad transformer, which adds accumulation --- capabilities (such as declarations or document patches) to a given monad. --- --- This monad transformer provides append-only accumulation --- during the computation. For more general access, use --- "Control.Monad.Trans.State" instead. ------------------------------------------------------------------------------ - -module Control.Monad.Trans.Accum ( - -- * The Accum monad - Accum, - accum, - runAccum, - execAccum, - evalAccum, - mapAccum, - -- * The AccumT monad transformer - AccumT(AccumT), - runAccumT, - execAccumT, - evalAccumT, - mapAccumT, - -- * Accum operations - look, - looks, - add, - -- * Lifting other operations - liftCallCC, - liftCallCC', - liftCatch, - liftListen, - liftPass, - -- * Monad transformations - readerToAccumT, - writerToAccumT, - accumToStateT, - ) where - -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader (ReaderT(..)) -import Control.Monad.Trans.Writer (WriterT(..)) -import Control.Monad.Trans.State (StateT(..)) -import Data.Functor.Identity - -import Control.Applicative -import Control.Monad -#if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail -#endif -import Control.Monad.Fix -import Control.Monad.Signatures -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid -#endif - --- --------------------------------------------------------------------------- --- | An accumulation monad parameterized by the type @w@ of output to accumulate. --- --- The 'return' function produces the output 'mempty', while @>>=@ --- combines the outputs of the subcomputations using 'mappend'. -type Accum w = AccumT w Identity - --- | Construct an accumulation computation from a (result, output) pair. --- (The inverse of 'runAccum'.) -accum :: (Monad m) => (w -> (a, w)) -> AccumT w m a -accum f = AccumT $ \ w -> return (f w) -{-# INLINE accum #-} - --- | Unwrap an accumulation computation as a (result, output) pair. --- (The inverse of 'accum'.) -runAccum :: Accum w a -> w -> (a, w) -runAccum m = runIdentity . runAccumT m -{-# INLINE runAccum #-} - --- | Extract the output from an accumulation computation. --- --- * @'execAccum' m w = 'snd' ('runAccum' m w)@ -execAccum :: Accum w a -> w -> w -execAccum m w = snd (runAccum m w) -{-# INLINE execAccum #-} - --- | Evaluate an accumulation computation with the given initial output history --- and return the final value, discarding the final output. --- --- * @'evalAccum' m w = 'fst' ('runAccum' m w)@ -evalAccum :: (Monoid w) => Accum w a -> w -> a -evalAccum m w = fst (runAccum m w) -{-# INLINE evalAccum #-} - --- | Map both the return value and output of a computation using --- the given function. --- --- * @'runAccum' ('mapAccum' f m) = f . 'runAccum' m@ -mapAccum :: ((a, w) -> (b, w)) -> Accum w a -> Accum w b -mapAccum f = mapAccumT (Identity . f . runIdentity) -{-# INLINE mapAccum #-} - --- --------------------------------------------------------------------------- --- | An accumulation monad parameterized by: --- --- * @w@ - the output to accumulate. --- --- * @m@ - The inner monad. --- --- The 'return' function produces the output 'mempty', while @>>=@ --- combines the outputs of the subcomputations using 'mappend'. --- --- This monad transformer is similar to both state and writer monad transformers. --- Thus it can be seen as --- --- * a restricted append-only version of a state monad transformer or --- --- * a writer monad transformer with the extra ability to read all previous output. -newtype AccumT w m a = AccumT (w -> m (a, w)) - --- | Unwrap an accumulation computation. -runAccumT :: AccumT w m a -> w -> m (a, w) -runAccumT (AccumT f) = f -{-# INLINE runAccumT #-} - --- | Extract the output from an accumulation computation. --- --- * @'execAccumT' m w = 'liftM' 'snd' ('runAccumT' m w)@ -execAccumT :: (Monad m) => AccumT w m a -> w -> m w -execAccumT m w = do - ~(_, w') <- runAccumT m w - return w' -{-# INLINE execAccumT #-} - --- | Evaluate an accumulation computation with the given initial output history --- and return the final value, discarding the final output. --- --- * @'evalAccumT' m w = 'liftM' 'fst' ('runAccumT' m w)@ -evalAccumT :: (Monad m, Monoid w) => AccumT w m a -> w -> m a -evalAccumT m w = do - ~(a, _) <- runAccumT m w - return a -{-# INLINE evalAccumT #-} - --- | Map both the return value and output of a computation using --- the given function. --- --- * @'runAccumT' ('mapAccumT' f m) = f . 'runAccumT' m@ -mapAccumT :: (m (a, w) -> n (b, w)) -> AccumT w m a -> AccumT w n b -mapAccumT f m = AccumT (f . runAccumT m) -{-# INLINE mapAccumT #-} - -instance (Functor m) => Functor (AccumT w m) where - fmap f = mapAccumT $ fmap $ \ ~(a, w) -> (f a, w) - {-# INLINE fmap #-} - -instance (Monoid w, Functor m, Monad m) => Applicative (AccumT w m) where - pure a = AccumT $ const $ return (a, mempty) - {-# INLINE pure #-} - mf <*> mv = AccumT $ \ w -> do - ~(f, w') <- runAccumT mf w - ~(v, w'') <- runAccumT mv (w `mappend` w') - return (f v, w' `mappend` w'') - {-# INLINE (<*>) #-} - -instance (Monoid w, Functor m, MonadPlus m) => Alternative (AccumT w m) where - empty = AccumT $ const mzero - {-# INLINE empty #-} - m <|> n = AccumT $ \ w -> runAccumT m w `mplus` runAccumT n w - {-# INLINE (<|>) #-} - -instance (Monoid w, Functor m, Monad m) => Monad (AccumT w m) where -#if !(MIN_VERSION_base(4,8,0)) - return a = AccumT $ const $ return (a, mempty) - {-# INLINE return #-} -#endif - m >>= k = AccumT $ \ w -> do - ~(a, w') <- runAccumT m w - ~(b, w'') <- runAccumT (k a) (w `mappend` w') - return (b, w' `mappend` w'') - {-# INLINE (>>=) #-} -#if !(MIN_VERSION_base(4,13,0)) - fail msg = AccumT $ const (fail msg) - {-# INLINE fail #-} -#endif - -#if MIN_VERSION_base(4,9,0) -instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (AccumT w m) where - fail msg = AccumT $ const (Fail.fail msg) - {-# INLINE fail #-} -#endif - -instance (Monoid w, Functor m, MonadPlus m) => MonadPlus (AccumT w m) where - mzero = AccumT $ const mzero - {-# INLINE mzero #-} - m `mplus` n = AccumT $ \ w -> runAccumT m w `mplus` runAccumT n w - {-# INLINE mplus #-} - -instance (Monoid w, Functor m, MonadFix m) => MonadFix (AccumT w m) where - mfix m = AccumT $ \ w -> mfix $ \ ~(a, _) -> runAccumT (m a) w - {-# INLINE mfix #-} - -instance (Monoid w) => MonadTrans (AccumT w) where - lift m = AccumT $ const $ do - a <- m - return (a, mempty) - {-# INLINE lift #-} - -instance (Monoid w, Functor m, MonadIO m) => MonadIO (AccumT w m) where - liftIO = lift . liftIO - {-# INLINE liftIO #-} - --- | @'look'@ is an action that fetches all the previously accumulated output. -look :: (Monoid w, Monad m) => AccumT w m w -look = AccumT $ \ w -> return (w, mempty) - --- | @'look'@ is an action that retrieves a function of the previously accumulated output. -looks :: (Monoid w, Monad m) => (w -> a) -> AccumT w m a -looks f = AccumT $ \ w -> return (f w, mempty) - --- | @'add' w@ is an action that produces the output @w@. -add :: (Monad m) => w -> AccumT w m () -add w = accum $ const ((), w) -{-# INLINE add #-} - --- | Uniform lifting of a @callCC@ operation to the new monad. --- This version rolls back to the original output history on entering the --- continuation. -liftCallCC :: CallCC m (a, w) (b, w) -> CallCC (AccumT w m) a b -liftCallCC callCC f = AccumT $ \ w -> - callCC $ \ c -> - runAccumT (f (\ a -> AccumT $ \ _ -> c (a, w))) w -{-# INLINE liftCallCC #-} - --- | In-situ lifting of a @callCC@ operation to the new monad. --- This version uses the current output history on entering the continuation. --- It does not satisfy the uniformity property (see "Control.Monad.Signatures"). -liftCallCC' :: CallCC m (a, w) (b, w) -> CallCC (AccumT w m) a b -liftCallCC' callCC f = AccumT $ \ s -> - callCC $ \ c -> - runAccumT (f (\ a -> AccumT $ \ s' -> c (a, s'))) s -{-# INLINE liftCallCC' #-} - --- | Lift a @catchE@ operation to the new monad. -liftCatch :: Catch e m (a, w) -> Catch e (AccumT w m) a -liftCatch catchE m h = - AccumT $ \ w -> runAccumT m w `catchE` \ e -> runAccumT (h e) w -{-# INLINE liftCatch #-} - --- | Lift a @listen@ operation to the new monad. -liftListen :: (Monad m) => Listen w m (a, s) -> Listen w (AccumT s m) a -liftListen listen m = AccumT $ \ s -> do - ~((a, s'), w) <- listen (runAccumT m s) - return ((a, w), s') -{-# INLINE liftListen #-} - --- | Lift a @pass@ operation to the new monad. -liftPass :: (Monad m) => Pass w m (a, s) -> Pass w (AccumT s m) a -liftPass pass m = AccumT $ \ s -> pass $ do - ~((a, f), s') <- runAccumT m s - return ((a, s'), f) -{-# INLINE liftPass #-} - --- | Convert a read-only computation into an accumulation computation. -readerToAccumT :: (Functor m, Monoid w) => ReaderT w m a -> AccumT w m a -readerToAccumT (ReaderT f) = AccumT $ \ w -> fmap (\ a -> (a, mempty)) (f w) -{-# INLINE readerToAccumT #-} - --- | Convert a writer computation into an accumulation computation. -writerToAccumT :: WriterT w m a -> AccumT w m a -writerToAccumT (WriterT m) = AccumT $ const $ m -{-# INLINE writerToAccumT #-} - --- | Convert an accumulation (append-only) computation into a fully --- stateful computation. -accumToStateT :: (Functor m, Monoid s) => AccumT s m a -> StateT s m a -accumToStateT (AccumT f) = - StateT $ \ w -> fmap (\ ~(a, w') -> (a, w `mappend` w')) (f w) -{-# INLINE accumToStateT #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Class.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Class.hs deleted file mode 100644 index b92bc0e8b0f6..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Class.hs +++ /dev/null @@ -1,262 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE AutoDeriveTypeable #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Trans.Class --- Copyright : (c) Andy Gill 2001, --- (c) Oregon Graduate Institute of Science and Technology, 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- The class of monad transformers. --- --- A monad transformer makes a new monad out of an existing monad, such --- that computations of the old monad may be embedded in the new one. --- To construct a monad with a desired set of features, one typically --- starts with a base monad, such as 'Data.Functor.Identity.Identity', @[]@ or 'IO', and --- applies a sequence of monad transformers. ------------------------------------------------------------------------------ - -module Control.Monad.Trans.Class ( - -- * Transformer class - MonadTrans(..) - - -- * Conventions - -- $conventions - - -- * Strict monads - -- $strict - - -- * Examples - -- ** Parsing - -- $example1 - - -- ** Parsing and counting - -- $example2 - - -- ** Interpreter monad - -- $example3 - ) where - --- | The class of monad transformers. Instances should satisfy the --- following laws, which state that 'lift' is a monad transformation: --- --- * @'lift' . 'return' = 'return'@ --- --- * @'lift' (m >>= f) = 'lift' m >>= ('lift' . f)@ - -class MonadTrans t where - -- | Lift a computation from the argument monad to the constructed monad. - lift :: (Monad m) => m a -> t m a - -{- $conventions -Most monad transformer modules include the special case of applying -the transformer to 'Data.Functor.Identity.Identity'. For example, -@'Control.Monad.Trans.State.Lazy.State' s@ is an abbreviation for -@'Control.Monad.Trans.State.Lazy.StateT' s 'Data.Functor.Identity.Identity'@. - -Each monad transformer also comes with an operation @run@/XXX/@T@ to -unwrap the transformer, exposing a computation of the inner monad. -(Currently these functions are defined as field labels, but in the next -major release they will be separate functions.) - -All of the monad transformers except 'Control.Monad.Trans.Cont.ContT' -and 'Control.Monad.Trans.Cont.SelectT' are functors on the category -of monads: in addition to defining a mapping of monads, they -also define a mapping from transformations between base monads to -transformations between transformed monads, called @map@/XXX/@T@. -Thus given a monad transformation @t :: M a -> N a@, the combinator -'Control.Monad.Trans.State.Lazy.mapStateT' constructs a monad -transformation - -> mapStateT t :: StateT s M a -> StateT s N a - -For these monad transformers, 'lift' is a natural transformation in the -category of monads, i.e. for any monad transformation @t :: M a -> N a@, - -* @map@/XXX/@T t . 'lift' = 'lift' . t@ - -Each of the monad transformers introduces relevant operations. -In a sequence of monad transformers, most of these operations.can be -lifted through other transformers using 'lift' or the @map@/XXX/@T@ -combinator, but a few with more complex type signatures require -specialized lifting combinators, called @lift@/Op/ -(see "Control.Monad.Signatures"). --} - -{- $strict - -A monad is said to be /strict/ if its '>>=' operation is strict in its first -argument. The base monads 'Maybe', @[]@ and 'IO' are strict: - ->>> undefined >> return 2 :: Maybe Integer -*** Exception: Prelude.undefined - -However the monad 'Data.Functor.Identity.Identity' is not: - ->>> runIdentity (undefined >> return 2) -2 - -In a strict monad you know when each action is executed, but the monad -is not necessarily strict in the return value, or in other components -of the monad, such as a state. However you can use 'seq' to create -an action that is strict in the component you want evaluated. --} - -{- $example1 - -The first example is a parser monad in the style of - -* \"Monadic parsing in Haskell\", by Graham Hutton and Erik Meijer, -/Journal of Functional Programming/ 8(4):437-444, July 1998 -(<http://www.cs.nott.ac.uk/~pszgmh/bib.html#pearl>). - -We can define such a parser monad by adding a state (the 'String' remaining -to be parsed) to the @[]@ monad, which provides non-determinism: - -> import Control.Monad.Trans.State -> -> type Parser = StateT String [] - -Then @Parser@ is an instance of @MonadPlus@: monadic sequencing implements -concatenation of parsers, while @mplus@ provides choice. To use parsers, -we need a primitive to run a constructed parser on an input string: - -> runParser :: Parser a -> String -> [a] -> runParser p s = [x | (x, "") <- runStateT p s] - -Finally, we need a primitive parser that matches a single character, -from which arbitrarily complex parsers may be constructed: - -> item :: Parser Char -> item = do -> c:cs <- get -> put cs -> return c - -In this example we use the operations @get@ and @put@ from -"Control.Monad.Trans.State", which are defined only for monads that are -applications of 'Control.Monad.Trans.State.Lazy.StateT'. Alternatively one -could use monad classes from the @mtl@ package or similar, which contain -methods @get@ and @put@ with types generalized over all suitable monads. --} - -{- $example2 - -We can define a parser that also counts by adding a -'Control.Monad.Trans.Writer.Lazy.WriterT' transformer: - -> import Control.Monad.Trans.Class -> import Control.Monad.Trans.State -> import Control.Monad.Trans.Writer -> import Data.Monoid -> -> type Parser = WriterT (Sum Int) (StateT String []) - -The function that applies a parser must now unwrap each of the monad -transformers in turn: - -> runParser :: Parser a -> String -> [(a, Int)] -> runParser p s = [(x, n) | ((x, Sum n), "") <- runStateT (runWriterT p) s] - -To define the @item@ parser, we need to lift the -'Control.Monad.Trans.State.Lazy.StateT' operations through the -'Control.Monad.Trans.Writer.Lazy.WriterT' transformer. - -> item :: Parser Char -> item = do -> c:cs <- lift get -> lift (put cs) -> return c - -In this case, we were able to do this with 'lift', but operations with -more complex types require special lifting functions, which are provided -by monad transformers for which they can be implemented. If you use the -monad classes of the @mtl@ package or similar, this lifting is handled -automatically by the instances of the classes, and you need only use -the generalized methods @get@ and @put@. - -We can also define a primitive using the Writer: - -> tick :: Parser () -> tick = tell (Sum 1) - -Then the parser will keep track of how many @tick@s it executes. --} - -{- $example3 - -This example is a cut-down version of the one in - -* \"Monad Transformers and Modular Interpreters\", -by Sheng Liang, Paul Hudak and Mark Jones in /POPL'95/ -(<http://web.cecs.pdx.edu/~mpj/pubs/modinterp.html>). - -Suppose we want to define an interpreter that can do I\/O and has -exceptions, an environment and a modifiable store. We can define -a monad that supports all these things as a stack of monad transformers: - -> import Control.Monad.Trans.Class -> import Control.Monad.Trans.State -> import qualified Control.Monad.Trans.Reader as R -> import qualified Control.Monad.Trans.Except as E -> import Control.Monad.IO.Class -> -> type InterpM = StateT Store (R.ReaderT Env (E.ExceptT Err IO)) - -for suitable types @Store@, @Env@ and @Err@. - -Now we would like to be able to use the operations associated with each -of those monad transformers on @InterpM@ actions. Since the uppermost -monad transformer of @InterpM@ is 'Control.Monad.Trans.State.Lazy.StateT', -it already has the state operations @get@ and @set@. - -The first of the 'Control.Monad.Trans.Reader.ReaderT' operations, -'Control.Monad.Trans.Reader.ask', is a simple action, so we can lift it -through 'Control.Monad.Trans.State.Lazy.StateT' to @InterpM@ using 'lift': - -> ask :: InterpM Env -> ask = lift R.ask - -The other 'Control.Monad.Trans.Reader.ReaderT' operation, -'Control.Monad.Trans.Reader.local', has a suitable type for lifting -using 'Control.Monad.Trans.State.Lazy.mapStateT': - -> local :: (Env -> Env) -> InterpM a -> InterpM a -> local f = mapStateT (R.local f) - -We also wish to lift the operations of 'Control.Monad.Trans.Except.ExceptT' -through both 'Control.Monad.Trans.Reader.ReaderT' and -'Control.Monad.Trans.State.Lazy.StateT'. For the operation -'Control.Monad.Trans.Except.throwE', we know @throwE e@ is a simple -action, so we can lift it through the two monad transformers to @InterpM@ -with two 'lift's: - -> throwE :: Err -> InterpM a -> throwE e = lift (lift (E.throwE e)) - -The 'Control.Monad.Trans.Except.catchE' operation has a more -complex type, so we need to use the special-purpose lifting function -@liftCatch@ provided by most monad transformers. Here we use -the 'Control.Monad.Trans.Reader.ReaderT' version followed by the -'Control.Monad.Trans.State.Lazy.StateT' version: - -> catchE :: InterpM a -> (Err -> InterpM a) -> InterpM a -> catchE = liftCatch (R.liftCatch E.catchE) - -We could lift 'IO' actions to @InterpM@ using three 'lift's, but @InterpM@ -is automatically an instance of 'Control.Monad.IO.Class.MonadIO', -so we can use 'Control.Monad.IO.Class.liftIO' instead: - -> putStr :: String -> InterpM () -> putStr s = liftIO (Prelude.putStr s) - --} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Cont.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Cont.hs deleted file mode 100644 index ce2005d4b29f..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Cont.hs +++ /dev/null @@ -1,240 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -#endif -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE AutoDeriveTypeable #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Trans.Cont --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- Continuation monads. --- --- Delimited continuation operators are taken from Kenichi Asai and Oleg --- Kiselyov's tutorial at CW 2011, \"Introduction to programming with --- shift and reset\" (<http://okmij.org/ftp/continuations/#tutorial>). --- ------------------------------------------------------------------------------ - -module Control.Monad.Trans.Cont ( - -- * The Cont monad - Cont, - cont, - runCont, - evalCont, - mapCont, - withCont, - -- ** Delimited continuations - reset, shift, - -- * The ContT monad transformer - ContT(..), - evalContT, - mapContT, - withContT, - callCC, - -- ** Delimited continuations - resetT, shiftT, - -- * Lifting other operations - liftLocal, - ) where - -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Data.Functor.Identity - -import Control.Applicative -#if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail -#endif - -{- | -Continuation monad. -@Cont r a@ is a CPS ("continuation-passing style") computation that produces an -intermediate result of type @a@ within a CPS computation whose final result type -is @r@. - -The @return@ function simply creates a continuation which passes the value on. - -The @>>=@ operator adds the bound function into the continuation chain. --} -type Cont r = ContT r Identity - --- | Construct a continuation-passing computation from a function. --- (The inverse of 'runCont') -cont :: ((a -> r) -> r) -> Cont r a -cont f = ContT (\ c -> Identity (f (runIdentity . c))) -{-# INLINE cont #-} - --- | The result of running a CPS computation with a given final continuation. --- (The inverse of 'cont') -runCont - :: Cont r a -- ^ continuation computation (@Cont@). - -> (a -> r) -- ^ the final continuation, which produces - -- the final result (often 'id'). - -> r -runCont m k = runIdentity (runContT m (Identity . k)) -{-# INLINE runCont #-} - --- | The result of running a CPS computation with the identity as the --- final continuation. --- --- * @'evalCont' ('return' x) = x@ -evalCont :: Cont r r -> r -evalCont m = runIdentity (evalContT m) -{-# INLINE evalCont #-} - --- | Apply a function to transform the result of a continuation-passing --- computation. --- --- * @'runCont' ('mapCont' f m) = f . 'runCont' m@ -mapCont :: (r -> r) -> Cont r a -> Cont r a -mapCont f = mapContT (Identity . f . runIdentity) -{-# INLINE mapCont #-} - --- | Apply a function to transform the continuation passed to a CPS --- computation. --- --- * @'runCont' ('withCont' f m) = 'runCont' m . f@ -withCont :: ((b -> r) -> (a -> r)) -> Cont r a -> Cont r b -withCont f = withContT ((Identity .) . f . (runIdentity .)) -{-# INLINE withCont #-} - --- | @'reset' m@ delimits the continuation of any 'shift' inside @m@. --- --- * @'reset' ('return' m) = 'return' m@ --- -reset :: Cont r r -> Cont r' r -reset = resetT -{-# INLINE reset #-} - --- | @'shift' f@ captures the continuation up to the nearest enclosing --- 'reset' and passes it to @f@: --- --- * @'reset' ('shift' f >>= k) = 'reset' (f ('evalCont' . k))@ --- -shift :: ((a -> r) -> Cont r r) -> Cont r a -shift f = shiftT (f . (runIdentity .)) -{-# INLINE shift #-} - --- | The continuation monad transformer. --- Can be used to add continuation handling to any type constructor: --- the 'Monad' instance and most of the operations do not require @m@ --- to be a monad. --- --- 'ContT' is not a functor on the category of monads, and many operations --- cannot be lifted through it. -newtype ContT r m a = ContT { runContT :: (a -> m r) -> m r } - --- | The result of running a CPS computation with 'return' as the --- final continuation. --- --- * @'evalContT' ('lift' m) = m@ -evalContT :: (Monad m) => ContT r m r -> m r -evalContT m = runContT m return -{-# INLINE evalContT #-} - --- | Apply a function to transform the result of a continuation-passing --- computation. This has a more restricted type than the @map@ operations --- for other monad transformers, because 'ContT' does not define a functor --- in the category of monads. --- --- * @'runContT' ('mapContT' f m) = f . 'runContT' m@ -mapContT :: (m r -> m r) -> ContT r m a -> ContT r m a -mapContT f m = ContT $ f . runContT m -{-# INLINE mapContT #-} - --- | Apply a function to transform the continuation passed to a CPS --- computation. --- --- * @'runContT' ('withContT' f m) = 'runContT' m . f@ -withContT :: ((b -> m r) -> (a -> m r)) -> ContT r m a -> ContT r m b -withContT f m = ContT $ runContT m . f -{-# INLINE withContT #-} - -instance Functor (ContT r m) where - fmap f m = ContT $ \ c -> runContT m (c . f) - {-# INLINE fmap #-} - -instance Applicative (ContT r m) where - pure x = ContT ($ x) - {-# INLINE pure #-} - f <*> v = ContT $ \ c -> runContT f $ \ g -> runContT v (c . g) - {-# INLINE (<*>) #-} - m *> k = m >>= \_ -> k - {-# INLINE (*>) #-} - -instance Monad (ContT r m) where -#if !(MIN_VERSION_base(4,8,0)) - return x = ContT ($ x) - {-# INLINE return #-} -#endif - m >>= k = ContT $ \ c -> runContT m (\ x -> runContT (k x) c) - {-# INLINE (>>=) #-} - -#if MIN_VERSION_base(4,9,0) -instance (Fail.MonadFail m) => Fail.MonadFail (ContT r m) where - fail msg = ContT $ \ _ -> Fail.fail msg - {-# INLINE fail #-} -#endif - -instance MonadTrans (ContT r) where - lift m = ContT (m >>=) - {-# INLINE lift #-} - -instance (MonadIO m) => MonadIO (ContT r m) where - liftIO = lift . liftIO - {-# INLINE liftIO #-} - --- | @callCC@ (call-with-current-continuation) calls its argument --- function, passing it the current continuation. It provides --- an escape continuation mechanism for use with continuation --- monads. Escape continuations one allow to abort the current --- computation and return a value immediately. They achieve --- a similar effect to 'Control.Monad.Trans.Except.throwE' --- and 'Control.Monad.Trans.Except.catchE' within an --- 'Control.Monad.Trans.Except.ExceptT' monad. The advantage of this --- function over calling 'return' is that it makes the continuation --- explicit, allowing more flexibility and better control. --- --- The standard idiom used with @callCC@ is to provide a lambda-expression --- to name the continuation. Then calling the named continuation anywhere --- within its scope will escape from the computation, even if it is many --- layers deep within nested computations. -callCC :: ((a -> ContT r m b) -> ContT r m a) -> ContT r m a -callCC f = ContT $ \ c -> runContT (f (\ x -> ContT $ \ _ -> c x)) c -{-# INLINE callCC #-} - --- | @'resetT' m@ delimits the continuation of any 'shiftT' inside @m@. --- --- * @'resetT' ('lift' m) = 'lift' m@ --- -resetT :: (Monad m) => ContT r m r -> ContT r' m r -resetT = lift . evalContT -{-# INLINE resetT #-} - --- | @'shiftT' f@ captures the continuation up to the nearest enclosing --- 'resetT' and passes it to @f@: --- --- * @'resetT' ('shiftT' f >>= k) = 'resetT' (f ('evalContT' . k))@ --- -shiftT :: (Monad m) => ((a -> m r) -> ContT r m r) -> ContT r m a -shiftT f = ContT (evalContT . f) -{-# INLINE shiftT #-} - --- | @'liftLocal' ask local@ yields a @local@ function for @'ContT' r m@. -liftLocal :: (Monad m) => m r' -> ((r' -> r') -> m r -> m r) -> - (r' -> r') -> ContT r m a -> ContT r m a -liftLocal ask local f m = ContT $ \ c -> do - r <- ask - local f (runContT m (local (const r) . c)) -{-# INLINE liftLocal #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Error.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Error.hs deleted file mode 100644 index 6eda4b3e015a..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Error.hs +++ /dev/null @@ -1,333 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE AutoDeriveTypeable #-} -#endif -#if !(MIN_VERSION_base(4,9,0)) -{-# OPTIONS_GHC -fno-warn-orphans #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Trans.Error --- Copyright : (c) Michael Weber <michael.weber@post.rwth-aachen.de> 2001, --- (c) Jeff Newbern 2003-2006, --- (c) Andriy Palamarchuk 2006 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- This monad transformer adds the ability to fail or throw exceptions --- to a monad. --- --- A sequence of actions succeeds, producing a value, only if all the --- actions in the sequence are successful. If one fails with an error, --- the rest of the sequence is skipped and the composite action fails --- with that error. --- --- If the value of the error is not required, the variant in --- "Control.Monad.Trans.Maybe" may be used instead. --- --- /Note:/ This module will be removed in a future release. --- Instead, use "Control.Monad.Trans.Except", which does not restrict --- the exception type, and also includes a base exception monad. ------------------------------------------------------------------------------ - -module Control.Monad.Trans.Error - {-# DEPRECATED "Use Control.Monad.Trans.Except instead" #-} ( - -- * The ErrorT monad transformer - Error(..), - ErrorList(..), - ErrorT(..), - mapErrorT, - -- * Error operations - throwError, - catchError, - -- * Lifting other operations - liftCallCC, - liftListen, - liftPass, - -- * Examples - -- $examples - ) where - -import Control.Monad.IO.Class -import Control.Monad.Signatures -import Control.Monad.Trans.Class -import Data.Functor.Classes -#if MIN_VERSION_base(4,12,0) -import Data.Functor.Contravariant -#endif - -import Control.Applicative -import Control.Exception (IOException) -import Control.Monad -#if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail -#endif -import Control.Monad.Fix -#if !(MIN_VERSION_base(4,6,0)) -import Control.Monad.Instances () -- deprecated from base-4.6 -#endif -import Data.Foldable (Foldable(foldMap)) -import Data.Monoid (mempty) -import Data.Traversable (Traversable(traverse)) -import System.IO.Error - -#if !(MIN_VERSION_base(4,9,0)) --- These instances are in base-4.9.0 - -instance MonadPlus IO where - mzero = ioError (userError "mzero") - m `mplus` n = m `catchIOError` \ _ -> n - -instance Alternative IO where - empty = mzero - (<|>) = mplus - -# if !(MIN_VERSION_base(4,4,0)) --- exported by System.IO.Error from base-4.4 -catchIOError :: IO a -> (IOError -> IO a) -> IO a -catchIOError = catch -# endif -#endif - -instance (Error e) => Alternative (Either e) where - empty = Left noMsg - Left _ <|> n = n - m <|> _ = m - -instance (Error e) => MonadPlus (Either e) where - mzero = Left noMsg - Left _ `mplus` n = n - m `mplus` _ = m - -#if !(MIN_VERSION_base(4,3,0)) --- These instances are in base-4.3 - -instance Applicative (Either e) where - pure = Right - Left e <*> _ = Left e - Right f <*> r = fmap f r - -instance Monad (Either e) where - return = Right - Left l >>= _ = Left l - Right r >>= k = k r - -instance MonadFix (Either e) where - mfix f = let - a = f $ case a of - Right r -> r - _ -> error "empty mfix argument" - in a - -#endif /* base to 4.2.0.x */ - --- | An exception to be thrown. --- --- Minimal complete definition: 'noMsg' or 'strMsg'. -class Error a where - -- | Creates an exception without a message. - -- The default implementation is @'strMsg' \"\"@. - noMsg :: a - -- | Creates an exception with a message. - -- The default implementation of @'strMsg' s@ is 'noMsg'. - strMsg :: String -> a - - noMsg = strMsg "" - strMsg _ = noMsg - -instance Error IOException where - strMsg = userError - --- | A string can be thrown as an error. -instance (ErrorList a) => Error [a] where - strMsg = listMsg - --- | Workaround so that we can have a Haskell 98 instance @'Error' 'String'@. -class ErrorList a where - listMsg :: String -> [a] - -instance ErrorList Char where - listMsg = id - --- | The error monad transformer. It can be used to add error handling --- to other monads. --- --- The @ErrorT@ Monad structure is parameterized over two things: --- --- * e - The error type. --- --- * m - The inner monad. --- --- The 'return' function yields a successful computation, while @>>=@ --- sequences two subcomputations, failing on the first error. -newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) } - -instance (Eq e, Eq1 m) => Eq1 (ErrorT e m) where - liftEq eq (ErrorT x) (ErrorT y) = liftEq (liftEq eq) x y - -instance (Ord e, Ord1 m) => Ord1 (ErrorT e m) where - liftCompare comp (ErrorT x) (ErrorT y) = liftCompare (liftCompare comp) x y - -instance (Read e, Read1 m) => Read1 (ErrorT e m) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "ErrorT" ErrorT - where - rp' = liftReadsPrec rp rl - rl' = liftReadList rp rl - -instance (Show e, Show1 m) => Show1 (ErrorT e m) where - liftShowsPrec sp sl d (ErrorT m) = - showsUnaryWith (liftShowsPrec sp' sl') "ErrorT" d m - where - sp' = liftShowsPrec sp sl - sl' = liftShowList sp sl - -instance (Eq e, Eq1 m, Eq a) => Eq (ErrorT e m a) where (==) = eq1 -instance (Ord e, Ord1 m, Ord a) => Ord (ErrorT e m a) where compare = compare1 -instance (Read e, Read1 m, Read a) => Read (ErrorT e m a) where - readsPrec = readsPrec1 -instance (Show e, Show1 m, Show a) => Show (ErrorT e m a) where - showsPrec = showsPrec1 - --- | Map the unwrapped computation using the given function. --- --- * @'runErrorT' ('mapErrorT' f m) = f ('runErrorT' m)@ -mapErrorT :: (m (Either e a) -> n (Either e' b)) - -> ErrorT e m a - -> ErrorT e' n b -mapErrorT f m = ErrorT $ f (runErrorT m) - -instance (Functor m) => Functor (ErrorT e m) where - fmap f = ErrorT . fmap (fmap f) . runErrorT - -instance (Foldable f) => Foldable (ErrorT e f) where - foldMap f (ErrorT a) = foldMap (either (const mempty) f) a - -instance (Traversable f) => Traversable (ErrorT e f) where - traverse f (ErrorT a) = - ErrorT <$> traverse (either (pure . Left) (fmap Right . f)) a - -instance (Functor m, Monad m) => Applicative (ErrorT e m) where - pure a = ErrorT $ return (Right a) - f <*> v = ErrorT $ do - mf <- runErrorT f - case mf of - Left e -> return (Left e) - Right k -> do - mv <- runErrorT v - case mv of - Left e -> return (Left e) - Right x -> return (Right (k x)) - -instance (Functor m, Monad m, Error e) => Alternative (ErrorT e m) where - empty = mzero - (<|>) = mplus - -instance (Monad m, Error e) => Monad (ErrorT e m) where -#if !(MIN_VERSION_base(4,8,0)) - return a = ErrorT $ return (Right a) -#endif - m >>= k = ErrorT $ do - a <- runErrorT m - case a of - Left l -> return (Left l) - Right r -> runErrorT (k r) -#if !(MIN_VERSION_base(4,13,0)) - fail msg = ErrorT $ return (Left (strMsg msg)) -#endif - -#if MIN_VERSION_base(4,9,0) -instance (Monad m, Error e) => Fail.MonadFail (ErrorT e m) where - fail msg = ErrorT $ return (Left (strMsg msg)) -#endif - -instance (Monad m, Error e) => MonadPlus (ErrorT e m) where - mzero = ErrorT $ return (Left noMsg) - m `mplus` n = ErrorT $ do - a <- runErrorT m - case a of - Left _ -> runErrorT n - Right r -> return (Right r) - -instance (MonadFix m, Error e) => MonadFix (ErrorT e m) where - mfix f = ErrorT $ mfix $ \ a -> runErrorT $ f $ case a of - Right r -> r - _ -> error "empty mfix argument" - -instance MonadTrans (ErrorT e) where - lift m = ErrorT $ do - a <- m - return (Right a) - -instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where - liftIO = lift . liftIO - -#if MIN_VERSION_base(4,12,0) -instance Contravariant m => Contravariant (ErrorT e m) where - contramap f = ErrorT . contramap (fmap f) . runErrorT -#endif - --- | Signal an error value @e@. --- --- * @'runErrorT' ('throwError' e) = 'return' ('Left' e)@ --- --- * @'throwError' e >>= m = 'throwError' e@ -throwError :: (Monad m) => e -> ErrorT e m a -throwError l = ErrorT $ return (Left l) - --- | Handle an error. --- --- * @'catchError' h ('lift' m) = 'lift' m@ --- --- * @'catchError' h ('throwError' e) = h e@ -catchError :: (Monad m) => - ErrorT e m a -- ^ the inner computation - -> (e -> ErrorT e m a) -- ^ a handler for errors in the inner - -- computation - -> ErrorT e m a -m `catchError` h = ErrorT $ do - a <- runErrorT m - case a of - Left l -> runErrorT (h l) - Right r -> return (Right r) - --- | Lift a @callCC@ operation to the new monad. -liftCallCC :: CallCC m (Either e a) (Either e b) -> CallCC (ErrorT e m) a b -liftCallCC callCC f = ErrorT $ - callCC $ \ c -> - runErrorT (f (\ a -> ErrorT $ c (Right a))) - --- | Lift a @listen@ operation to the new monad. -liftListen :: (Monad m) => Listen w m (Either e a) -> Listen w (ErrorT e m) a -liftListen listen = mapErrorT $ \ m -> do - (a, w) <- listen m - return $! fmap (\ r -> (r, w)) a - --- | Lift a @pass@ operation to the new monad. -liftPass :: (Monad m) => Pass w m (Either e a) -> Pass w (ErrorT e m) a -liftPass pass = mapErrorT $ \ m -> pass $ do - a <- m - return $! case a of - Left l -> (Left l, id) - Right (r, f) -> (Right r, f) - -{- $examples - -Wrapping an IO action that can throw an error @e@: - -> type ErrorWithIO e a = ErrorT e IO a -> ==> ErrorT (IO (Either e a)) - -An IO monad wrapped in @StateT@ inside of @ErrorT@: - -> type ErrorAndStateWithIO e s a = ErrorT e (StateT s IO) a -> ==> ErrorT (StateT s IO (Either e a)) -> ==> ErrorT (StateT (s -> IO (Either e a,s))) - --} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Except.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Except.hs deleted file mode 100644 index 477b9dd4826c..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Except.hs +++ /dev/null @@ -1,316 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE AutoDeriveTypeable #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Trans.Except --- Copyright : (C) 2013 Ross Paterson --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- This monad transformer extends a monad with the ability to throw exceptions. --- --- A sequence of actions terminates normally, producing a value, --- only if none of the actions in the sequence throws an exception. --- If one throws an exception, the rest of the sequence is skipped and --- the composite action exits with that exception. --- --- If the value of the exception is not required, the variant in --- "Control.Monad.Trans.Maybe" may be used instead. ------------------------------------------------------------------------------ - -module Control.Monad.Trans.Except ( - -- * The Except monad - Except, - except, - runExcept, - mapExcept, - withExcept, - -- * The ExceptT monad transformer - ExceptT(ExceptT), - runExceptT, - mapExceptT, - withExceptT, - -- * Exception operations - throwE, - catchE, - -- * Lifting other operations - liftCallCC, - liftListen, - liftPass, - ) where - -import Control.Monad.IO.Class -import Control.Monad.Signatures -import Control.Monad.Trans.Class -import Data.Functor.Classes -#if MIN_VERSION_base(4,12,0) -import Data.Functor.Contravariant -#endif -import Data.Functor.Identity - -import Control.Applicative -import Control.Monad -#if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail -#endif -import Control.Monad.Fix -#if MIN_VERSION_base(4,4,0) -import Control.Monad.Zip (MonadZip(mzipWith)) -#endif -import Data.Foldable (Foldable(foldMap)) -import Data.Monoid -import Data.Traversable (Traversable(traverse)) - --- | The parameterizable exception monad. --- --- Computations are either exceptions or normal values. --- --- The 'return' function returns a normal value, while @>>=@ exits on --- the first exception. For a variant that continues after an error --- and collects all the errors, see 'Control.Applicative.Lift.Errors'. -type Except e = ExceptT e Identity - --- | Constructor for computations in the exception monad. --- (The inverse of 'runExcept'). -except :: (Monad m) => Either e a -> ExceptT e m a -except m = ExceptT (return m) -{-# INLINE except #-} - --- | Extractor for computations in the exception monad. --- (The inverse of 'except'). -runExcept :: Except e a -> Either e a -runExcept (ExceptT m) = runIdentity m -{-# INLINE runExcept #-} - --- | Map the unwrapped computation using the given function. --- --- * @'runExcept' ('mapExcept' f m) = f ('runExcept' m)@ -mapExcept :: (Either e a -> Either e' b) - -> Except e a - -> Except e' b -mapExcept f = mapExceptT (Identity . f . runIdentity) -{-# INLINE mapExcept #-} - --- | Transform any exceptions thrown by the computation using the given --- function (a specialization of 'withExceptT'). -withExcept :: (e -> e') -> Except e a -> Except e' a -withExcept = withExceptT -{-# INLINE withExcept #-} - --- | A monad transformer that adds exceptions to other monads. --- --- @ExceptT@ constructs a monad parameterized over two things: --- --- * e - The exception type. --- --- * m - The inner monad. --- --- The 'return' function yields a computation that produces the given --- value, while @>>=@ sequences two subcomputations, exiting on the --- first exception. -newtype ExceptT e m a = ExceptT (m (Either e a)) - -instance (Eq e, Eq1 m) => Eq1 (ExceptT e m) where - liftEq eq (ExceptT x) (ExceptT y) = liftEq (liftEq eq) x y - {-# INLINE liftEq #-} - -instance (Ord e, Ord1 m) => Ord1 (ExceptT e m) where - liftCompare comp (ExceptT x) (ExceptT y) = - liftCompare (liftCompare comp) x y - {-# INLINE liftCompare #-} - -instance (Read e, Read1 m) => Read1 (ExceptT e m) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "ExceptT" ExceptT - where - rp' = liftReadsPrec rp rl - rl' = liftReadList rp rl - -instance (Show e, Show1 m) => Show1 (ExceptT e m) where - liftShowsPrec sp sl d (ExceptT m) = - showsUnaryWith (liftShowsPrec sp' sl') "ExceptT" d m - where - sp' = liftShowsPrec sp sl - sl' = liftShowList sp sl - -instance (Eq e, Eq1 m, Eq a) => Eq (ExceptT e m a) - where (==) = eq1 -instance (Ord e, Ord1 m, Ord a) => Ord (ExceptT e m a) - where compare = compare1 -instance (Read e, Read1 m, Read a) => Read (ExceptT e m a) where - readsPrec = readsPrec1 -instance (Show e, Show1 m, Show a) => Show (ExceptT e m a) where - showsPrec = showsPrec1 - --- | The inverse of 'ExceptT'. -runExceptT :: ExceptT e m a -> m (Either e a) -runExceptT (ExceptT m) = m -{-# INLINE runExceptT #-} - --- | Map the unwrapped computation using the given function. --- --- * @'runExceptT' ('mapExceptT' f m) = f ('runExceptT' m)@ -mapExceptT :: (m (Either e a) -> n (Either e' b)) - -> ExceptT e m a - -> ExceptT e' n b -mapExceptT f m = ExceptT $ f (runExceptT m) -{-# INLINE mapExceptT #-} - --- | Transform any exceptions thrown by the computation using the --- given function. -withExceptT :: (Functor m) => (e -> e') -> ExceptT e m a -> ExceptT e' m a -withExceptT f = mapExceptT $ fmap $ either (Left . f) Right -{-# INLINE withExceptT #-} - -instance (Functor m) => Functor (ExceptT e m) where - fmap f = ExceptT . fmap (fmap f) . runExceptT - {-# INLINE fmap #-} - -instance (Foldable f) => Foldable (ExceptT e f) where - foldMap f (ExceptT a) = foldMap (either (const mempty) f) a - {-# INLINE foldMap #-} - -instance (Traversable f) => Traversable (ExceptT e f) where - traverse f (ExceptT a) = - ExceptT <$> traverse (either (pure . Left) (fmap Right . f)) a - {-# INLINE traverse #-} - -instance (Functor m, Monad m) => Applicative (ExceptT e m) where - pure a = ExceptT $ return (Right a) - {-# INLINE pure #-} - ExceptT f <*> ExceptT v = ExceptT $ do - mf <- f - case mf of - Left e -> return (Left e) - Right k -> do - mv <- v - case mv of - Left e -> return (Left e) - Right x -> return (Right (k x)) - {-# INLINEABLE (<*>) #-} - m *> k = m >>= \_ -> k - {-# INLINE (*>) #-} - -instance (Functor m, Monad m, Monoid e) => Alternative (ExceptT e m) where - empty = ExceptT $ return (Left mempty) - {-# INLINE empty #-} - ExceptT mx <|> ExceptT my = ExceptT $ do - ex <- mx - case ex of - Left e -> liftM (either (Left . mappend e) Right) my - Right x -> return (Right x) - {-# INLINEABLE (<|>) #-} - -instance (Monad m) => Monad (ExceptT e m) where -#if !(MIN_VERSION_base(4,8,0)) - return a = ExceptT $ return (Right a) - {-# INLINE return #-} -#endif - m >>= k = ExceptT $ do - a <- runExceptT m - case a of - Left e -> return (Left e) - Right x -> runExceptT (k x) - {-# INLINE (>>=) #-} -#if !(MIN_VERSION_base(4,13,0)) - fail = ExceptT . fail - {-# INLINE fail #-} -#endif - -#if MIN_VERSION_base(4,9,0) -instance (Fail.MonadFail m) => Fail.MonadFail (ExceptT e m) where - fail = ExceptT . Fail.fail - {-# INLINE fail #-} -#endif - -instance (Monad m, Monoid e) => MonadPlus (ExceptT e m) where - mzero = ExceptT $ return (Left mempty) - {-# INLINE mzero #-} - ExceptT mx `mplus` ExceptT my = ExceptT $ do - ex <- mx - case ex of - Left e -> liftM (either (Left . mappend e) Right) my - Right x -> return (Right x) - {-# INLINEABLE mplus #-} - -instance (MonadFix m) => MonadFix (ExceptT e m) where - mfix f = ExceptT (mfix (runExceptT . f . either (const bomb) id)) - where bomb = error "mfix (ExceptT): inner computation returned Left value" - {-# INLINE mfix #-} - -instance MonadTrans (ExceptT e) where - lift = ExceptT . liftM Right - {-# INLINE lift #-} - -instance (MonadIO m) => MonadIO (ExceptT e m) where - liftIO = lift . liftIO - {-# INLINE liftIO #-} - -#if MIN_VERSION_base(4,4,0) -instance (MonadZip m) => MonadZip (ExceptT e m) where - mzipWith f (ExceptT a) (ExceptT b) = ExceptT $ mzipWith (liftA2 f) a b - {-# INLINE mzipWith #-} -#endif - -#if MIN_VERSION_base(4,12,0) -instance Contravariant m => Contravariant (ExceptT e m) where - contramap f = ExceptT . contramap (fmap f) . runExceptT - {-# INLINE contramap #-} -#endif - --- | Signal an exception value @e@. --- --- * @'runExceptT' ('throwE' e) = 'return' ('Left' e)@ --- --- * @'throwE' e >>= m = 'throwE' e@ -throwE :: (Monad m) => e -> ExceptT e m a -throwE = ExceptT . return . Left -{-# INLINE throwE #-} - --- | Handle an exception. --- --- * @'catchE' ('lift' m) h = 'lift' m@ --- --- * @'catchE' ('throwE' e) h = h e@ -catchE :: (Monad m) => - ExceptT e m a -- ^ the inner computation - -> (e -> ExceptT e' m a) -- ^ a handler for exceptions in the inner - -- computation - -> ExceptT e' m a -m `catchE` h = ExceptT $ do - a <- runExceptT m - case a of - Left l -> runExceptT (h l) - Right r -> return (Right r) -{-# INLINE catchE #-} - --- | Lift a @callCC@ operation to the new monad. -liftCallCC :: CallCC m (Either e a) (Either e b) -> CallCC (ExceptT e m) a b -liftCallCC callCC f = ExceptT $ - callCC $ \ c -> - runExceptT (f (\ a -> ExceptT $ c (Right a))) -{-# INLINE liftCallCC #-} - --- | Lift a @listen@ operation to the new monad. -liftListen :: (Monad m) => Listen w m (Either e a) -> Listen w (ExceptT e m) a -liftListen listen = mapExceptT $ \ m -> do - (a, w) <- listen m - return $! fmap (\ r -> (r, w)) a -{-# INLINE liftListen #-} - --- | Lift a @pass@ operation to the new monad. -liftPass :: (Monad m) => Pass w m (Either e a) -> Pass w (ExceptT e m) a -liftPass pass = mapExceptT $ \ m -> pass $ do - a <- m - return $! case a of - Left l -> (Left l, id) - Right (r, f) -> (Right r, f) -{-# INLINE liftPass #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Identity.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Identity.hs deleted file mode 100644 index 2a0db5e5a165..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Identity.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -#endif -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE AutoDeriveTypeable #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Trans.Identity --- Copyright : (c) 2007 Magnus Therning --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- The identity monad transformer. --- --- This is useful for functions parameterized by a monad transformer. ------------------------------------------------------------------------------ - -module Control.Monad.Trans.Identity ( - -- * The identity monad transformer - IdentityT(..), - mapIdentityT, - -- * Lifting other operations - liftCatch, - liftCallCC, - ) where - -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Signatures -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Data.Functor.Classes -#if MIN_VERSION_base(4,12,0) -import Data.Functor.Contravariant -#endif - -import Control.Applicative -import Control.Monad (MonadPlus(mzero, mplus)) -#if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail -#endif -import Control.Monad.Fix (MonadFix(mfix)) -#if MIN_VERSION_base(4,4,0) -import Control.Monad.Zip (MonadZip(mzipWith)) -#endif -import Data.Foldable -import Data.Traversable (Traversable(traverse)) -import Prelude hiding (foldr, foldr1, foldl, foldl1, null, length) - --- | The trivial monad transformer, which maps a monad to an equivalent monad. -newtype IdentityT f a = IdentityT { runIdentityT :: f a } - -instance (Eq1 f) => Eq1 (IdentityT f) where - liftEq eq (IdentityT x) (IdentityT y) = liftEq eq x y - {-# INLINE liftEq #-} - -instance (Ord1 f) => Ord1 (IdentityT f) where - liftCompare comp (IdentityT x) (IdentityT y) = liftCompare comp x y - {-# INLINE liftCompare #-} - -instance (Read1 f) => Read1 (IdentityT f) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp rl) "IdentityT" IdentityT - -instance (Show1 f) => Show1 (IdentityT f) where - liftShowsPrec sp sl d (IdentityT m) = - showsUnaryWith (liftShowsPrec sp sl) "IdentityT" d m - -instance (Eq1 f, Eq a) => Eq (IdentityT f a) where (==) = eq1 -instance (Ord1 f, Ord a) => Ord (IdentityT f a) where compare = compare1 -instance (Read1 f, Read a) => Read (IdentityT f a) where readsPrec = readsPrec1 -instance (Show1 f, Show a) => Show (IdentityT f a) where showsPrec = showsPrec1 - -instance (Functor m) => Functor (IdentityT m) where - fmap f = mapIdentityT (fmap f) - {-# INLINE fmap #-} - -instance (Foldable f) => Foldable (IdentityT f) where - foldMap f (IdentityT t) = foldMap f t - {-# INLINE foldMap #-} - foldr f z (IdentityT t) = foldr f z t - {-# INLINE foldr #-} - foldl f z (IdentityT t) = foldl f z t - {-# INLINE foldl #-} - foldr1 f (IdentityT t) = foldr1 f t - {-# INLINE foldr1 #-} - foldl1 f (IdentityT t) = foldl1 f t - {-# INLINE foldl1 #-} -#if MIN_VERSION_base(4,8,0) - null (IdentityT t) = null t - length (IdentityT t) = length t -#endif - -instance (Traversable f) => Traversable (IdentityT f) where - traverse f (IdentityT a) = IdentityT <$> traverse f a - {-# INLINE traverse #-} - -instance (Applicative m) => Applicative (IdentityT m) where - pure x = IdentityT (pure x) - {-# INLINE pure #-} - (<*>) = lift2IdentityT (<*>) - {-# INLINE (<*>) #-} - (*>) = lift2IdentityT (*>) - {-# INLINE (*>) #-} - (<*) = lift2IdentityT (<*) - {-# INLINE (<*) #-} - -instance (Alternative m) => Alternative (IdentityT m) where - empty = IdentityT empty - {-# INLINE empty #-} - (<|>) = lift2IdentityT (<|>) - {-# INLINE (<|>) #-} - -instance (Monad m) => Monad (IdentityT m) where -#if !(MIN_VERSION_base(4,8,0)) - return = IdentityT . return - {-# INLINE return #-} -#endif - m >>= k = IdentityT $ runIdentityT . k =<< runIdentityT m - {-# INLINE (>>=) #-} -#if !(MIN_VERSION_base(4,13,0)) - fail msg = IdentityT $ fail msg - {-# INLINE fail #-} -#endif - -#if MIN_VERSION_base(4,9,0) -instance (Fail.MonadFail m) => Fail.MonadFail (IdentityT m) where - fail msg = IdentityT $ Fail.fail msg - {-# INLINE fail #-} -#endif - -instance (MonadPlus m) => MonadPlus (IdentityT m) where - mzero = IdentityT mzero - {-# INLINE mzero #-} - mplus = lift2IdentityT mplus - {-# INLINE mplus #-} - -instance (MonadFix m) => MonadFix (IdentityT m) where - mfix f = IdentityT (mfix (runIdentityT . f)) - {-# INLINE mfix #-} - -instance (MonadIO m) => MonadIO (IdentityT m) where - liftIO = IdentityT . liftIO - {-# INLINE liftIO #-} - -#if MIN_VERSION_base(4,4,0) -instance (MonadZip m) => MonadZip (IdentityT m) where - mzipWith f = lift2IdentityT (mzipWith f) - {-# INLINE mzipWith #-} -#endif - -instance MonadTrans IdentityT where - lift = IdentityT - {-# INLINE lift #-} - -#if MIN_VERSION_base(4,12,0) -instance Contravariant f => Contravariant (IdentityT f) where - contramap f = IdentityT . contramap f . runIdentityT - {-# INLINE contramap #-} -#endif - --- | Lift a unary operation to the new monad. -mapIdentityT :: (m a -> n b) -> IdentityT m a -> IdentityT n b -mapIdentityT f = IdentityT . f . runIdentityT -{-# INLINE mapIdentityT #-} - --- | Lift a binary operation to the new monad. -lift2IdentityT :: - (m a -> n b -> p c) -> IdentityT m a -> IdentityT n b -> IdentityT p c -lift2IdentityT f a b = IdentityT (f (runIdentityT a) (runIdentityT b)) -{-# INLINE lift2IdentityT #-} - --- | Lift a @callCC@ operation to the new monad. -liftCallCC :: CallCC m a b -> CallCC (IdentityT m) a b -liftCallCC callCC f = - IdentityT $ callCC $ \ c -> runIdentityT (f (IdentityT . c)) -{-# INLINE liftCallCC #-} - --- | Lift a @catchE@ operation to the new monad. -liftCatch :: Catch e m a -> Catch e (IdentityT m) a -liftCatch f m h = IdentityT $ f (runIdentityT m) (runIdentityT . h) -{-# INLINE liftCatch #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/List.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/List.hs deleted file mode 100644 index 0bdbcc732e83..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/List.hs +++ /dev/null @@ -1,185 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE AutoDeriveTypeable #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Trans.List --- Copyright : (c) Andy Gill 2001, --- (c) Oregon Graduate Institute of Science and Technology, 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- The ListT monad transformer, adding backtracking to a given monad, --- which must be commutative. ------------------------------------------------------------------------------ - -module Control.Monad.Trans.List - {-# DEPRECATED "This transformer is invalid on most monads" #-} ( - -- * The ListT monad transformer - ListT(..), - mapListT, - -- * Lifting other operations - liftCallCC, - liftCatch, - ) where - -import Control.Monad.IO.Class -import Control.Monad.Signatures -import Control.Monad.Trans.Class -import Data.Functor.Classes -#if MIN_VERSION_base(4,12,0) -import Data.Functor.Contravariant -#endif - -import Control.Applicative -import Control.Monad -#if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail -#endif -import Control.Monad.Fix -#if MIN_VERSION_base(4,4,0) -import Control.Monad.Zip (MonadZip(mzipWith)) -#endif -import Data.Foldable (Foldable(foldMap)) -import Data.Traversable (Traversable(traverse)) - --- | Parameterizable list monad, with an inner monad. --- --- /Note:/ this does not yield a monad unless the argument monad is commutative. -newtype ListT m a = ListT { runListT :: m [a] } - -instance (Eq1 m) => Eq1 (ListT m) where - liftEq eq (ListT x) (ListT y) = liftEq (liftEq eq) x y - {-# INLINE liftEq #-} - -instance (Ord1 m) => Ord1 (ListT m) where - liftCompare comp (ListT x) (ListT y) = liftCompare (liftCompare comp) x y - {-# INLINE liftCompare #-} - -instance (Read1 m) => Read1 (ListT m) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "ListT" ListT - where - rp' = liftReadsPrec rp rl - rl' = liftReadList rp rl - -instance (Show1 m) => Show1 (ListT m) where - liftShowsPrec sp sl d (ListT m) = - showsUnaryWith (liftShowsPrec sp' sl') "ListT" d m - where - sp' = liftShowsPrec sp sl - sl' = liftShowList sp sl - -instance (Eq1 m, Eq a) => Eq (ListT m a) where (==) = eq1 -instance (Ord1 m, Ord a) => Ord (ListT m a) where compare = compare1 -instance (Read1 m, Read a) => Read (ListT m a) where readsPrec = readsPrec1 -instance (Show1 m, Show a) => Show (ListT m a) where showsPrec = showsPrec1 - --- | Map between 'ListT' computations. --- --- * @'runListT' ('mapListT' f m) = f ('runListT' m)@ -mapListT :: (m [a] -> n [b]) -> ListT m a -> ListT n b -mapListT f m = ListT $ f (runListT m) -{-# INLINE mapListT #-} - -instance (Functor m) => Functor (ListT m) where - fmap f = mapListT $ fmap $ map f - {-# INLINE fmap #-} - -instance (Foldable f) => Foldable (ListT f) where - foldMap f (ListT a) = foldMap (foldMap f) a - {-# INLINE foldMap #-} - -instance (Traversable f) => Traversable (ListT f) where - traverse f (ListT a) = ListT <$> traverse (traverse f) a - {-# INLINE traverse #-} - -instance (Applicative m) => Applicative (ListT m) where - pure a = ListT $ pure [a] - {-# INLINE pure #-} - f <*> v = ListT $ (<*>) <$> runListT f <*> runListT v - {-# INLINE (<*>) #-} - -instance (Applicative m) => Alternative (ListT m) where - empty = ListT $ pure [] - {-# INLINE empty #-} - m <|> n = ListT $ (++) <$> runListT m <*> runListT n - {-# INLINE (<|>) #-} - -instance (Monad m) => Monad (ListT m) where -#if !(MIN_VERSION_base(4,8,0)) - return a = ListT $ return [a] - {-# INLINE return #-} -#endif - m >>= k = ListT $ do - a <- runListT m - b <- mapM (runListT . k) a - return (concat b) - {-# INLINE (>>=) #-} -#if !(MIN_VERSION_base(4,13,0)) - fail _ = ListT $ return [] - {-# INLINE fail #-} -#endif - -#if MIN_VERSION_base(4,9,0) -instance (Monad m) => Fail.MonadFail (ListT m) where - fail _ = ListT $ return [] - {-# INLINE fail #-} -#endif - -instance (Monad m) => MonadPlus (ListT m) where - mzero = ListT $ return [] - {-# INLINE mzero #-} - m `mplus` n = ListT $ do - a <- runListT m - b <- runListT n - return (a ++ b) - {-# INLINE mplus #-} - -instance (MonadFix m) => MonadFix (ListT m) where - mfix f = ListT $ mfix (runListT . f . head) >>= \ xs -> case xs of - [] -> return [] - x:_ -> liftM (x:) (runListT (mfix (mapListT (liftM tail) . f))) - {-# INLINE mfix #-} - -instance MonadTrans ListT where - lift m = ListT $ do - a <- m - return [a] - {-# INLINE lift #-} - -instance (MonadIO m) => MonadIO (ListT m) where - liftIO = lift . liftIO - {-# INLINE liftIO #-} - -#if MIN_VERSION_base(4,4,0) -instance (MonadZip m) => MonadZip (ListT m) where - mzipWith f (ListT a) (ListT b) = ListT $ mzipWith (zipWith f) a b - {-# INLINE mzipWith #-} -#endif - -#if MIN_VERSION_base(4,12,0) -instance Contravariant m => Contravariant (ListT m) where - contramap f = ListT . contramap (fmap f) . runListT - {-# INLINE contramap #-} -#endif - --- | Lift a @callCC@ operation to the new monad. -liftCallCC :: CallCC m [a] [b] -> CallCC (ListT m) a b -liftCallCC callCC f = ListT $ - callCC $ \ c -> - runListT (f (\ a -> ListT $ c [a])) -{-# INLINE liftCallCC #-} - --- | Lift a @catchE@ operation to the new monad. -liftCatch :: Catch e m [a] -> Catch e (ListT m) a -liftCatch catchE m h = ListT $ runListT m - `catchE` \ e -> runListT (h e) -{-# INLINE liftCatch #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Maybe.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Maybe.hs deleted file mode 100644 index f02b225444f8..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Maybe.hs +++ /dev/null @@ -1,241 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE AutoDeriveTypeable #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Trans.Maybe --- Copyright : (c) 2007 Yitzak Gale, Eric Kidd --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- The 'MaybeT' monad transformer extends a monad with the ability to exit --- the computation without returning a value. --- --- A sequence of actions produces a value only if all the actions in --- the sequence do. If one exits, the rest of the sequence is skipped --- and the composite action exits. --- --- For a variant allowing a range of exception values, see --- "Control.Monad.Trans.Except". ------------------------------------------------------------------------------ - -module Control.Monad.Trans.Maybe ( - -- * The MaybeT monad transformer - MaybeT(..), - mapMaybeT, - -- * Monad transformations - maybeToExceptT, - exceptToMaybeT, - -- * Lifting other operations - liftCallCC, - liftCatch, - liftListen, - liftPass, - ) where - -import Control.Monad.IO.Class -import Control.Monad.Signatures -import Control.Monad.Trans.Class -import Control.Monad.Trans.Except (ExceptT(..)) -import Data.Functor.Classes -#if MIN_VERSION_base(4,12,0) -import Data.Functor.Contravariant -#endif - -import Control.Applicative -import Control.Monad (MonadPlus(mzero, mplus), liftM) -#if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail -#endif -import Control.Monad.Fix (MonadFix(mfix)) -#if MIN_VERSION_base(4,4,0) -import Control.Monad.Zip (MonadZip(mzipWith)) -#endif -import Data.Foldable (Foldable(foldMap)) -import Data.Maybe (fromMaybe) -import Data.Traversable (Traversable(traverse)) - --- | The parameterizable maybe monad, obtained by composing an arbitrary --- monad with the 'Maybe' monad. --- --- Computations are actions that may produce a value or exit. --- --- The 'return' function yields a computation that produces that --- value, while @>>=@ sequences two subcomputations, exiting if either --- computation does. -newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) } - -instance (Eq1 m) => Eq1 (MaybeT m) where - liftEq eq (MaybeT x) (MaybeT y) = liftEq (liftEq eq) x y - {-# INLINE liftEq #-} - -instance (Ord1 m) => Ord1 (MaybeT m) where - liftCompare comp (MaybeT x) (MaybeT y) = liftCompare (liftCompare comp) x y - {-# INLINE liftCompare #-} - -instance (Read1 m) => Read1 (MaybeT m) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "MaybeT" MaybeT - where - rp' = liftReadsPrec rp rl - rl' = liftReadList rp rl - -instance (Show1 m) => Show1 (MaybeT m) where - liftShowsPrec sp sl d (MaybeT m) = - showsUnaryWith (liftShowsPrec sp' sl') "MaybeT" d m - where - sp' = liftShowsPrec sp sl - sl' = liftShowList sp sl - -instance (Eq1 m, Eq a) => Eq (MaybeT m a) where (==) = eq1 -instance (Ord1 m, Ord a) => Ord (MaybeT m a) where compare = compare1 -instance (Read1 m, Read a) => Read (MaybeT m a) where readsPrec = readsPrec1 -instance (Show1 m, Show a) => Show (MaybeT m a) where showsPrec = showsPrec1 - --- | Transform the computation inside a @MaybeT@. --- --- * @'runMaybeT' ('mapMaybeT' f m) = f ('runMaybeT' m)@ -mapMaybeT :: (m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b -mapMaybeT f = MaybeT . f . runMaybeT -{-# INLINE mapMaybeT #-} - --- | Convert a 'MaybeT' computation to 'ExceptT', with a default --- exception value. -maybeToExceptT :: (Functor m) => e -> MaybeT m a -> ExceptT e m a -maybeToExceptT e (MaybeT m) = ExceptT $ fmap (maybe (Left e) Right) m -{-# INLINE maybeToExceptT #-} - --- | Convert a 'ExceptT' computation to 'MaybeT', discarding the --- value of any exception. -exceptToMaybeT :: (Functor m) => ExceptT e m a -> MaybeT m a -exceptToMaybeT (ExceptT m) = MaybeT $ fmap (either (const Nothing) Just) m -{-# INLINE exceptToMaybeT #-} - -instance (Functor m) => Functor (MaybeT m) where - fmap f = mapMaybeT (fmap (fmap f)) - {-# INLINE fmap #-} - -instance (Foldable f) => Foldable (MaybeT f) where - foldMap f (MaybeT a) = foldMap (foldMap f) a - {-# INLINE foldMap #-} - -instance (Traversable f) => Traversable (MaybeT f) where - traverse f (MaybeT a) = MaybeT <$> traverse (traverse f) a - {-# INLINE traverse #-} - -instance (Functor m, Monad m) => Applicative (MaybeT m) where - pure = MaybeT . return . Just - {-# INLINE pure #-} - mf <*> mx = MaybeT $ do - mb_f <- runMaybeT mf - case mb_f of - Nothing -> return Nothing - Just f -> do - mb_x <- runMaybeT mx - case mb_x of - Nothing -> return Nothing - Just x -> return (Just (f x)) - {-# INLINE (<*>) #-} - m *> k = m >>= \_ -> k - {-# INLINE (*>) #-} - -instance (Functor m, Monad m) => Alternative (MaybeT m) where - empty = MaybeT (return Nothing) - {-# INLINE empty #-} - x <|> y = MaybeT $ do - v <- runMaybeT x - case v of - Nothing -> runMaybeT y - Just _ -> return v - {-# INLINE (<|>) #-} - -instance (Monad m) => Monad (MaybeT m) where -#if !(MIN_VERSION_base(4,8,0)) - return = MaybeT . return . Just - {-# INLINE return #-} -#endif - x >>= f = MaybeT $ do - v <- runMaybeT x - case v of - Nothing -> return Nothing - Just y -> runMaybeT (f y) - {-# INLINE (>>=) #-} -#if !(MIN_VERSION_base(4,13,0)) - fail _ = MaybeT (return Nothing) - {-# INLINE fail #-} -#endif - -#if MIN_VERSION_base(4,9,0) -instance (Monad m) => Fail.MonadFail (MaybeT m) where - fail _ = MaybeT (return Nothing) - {-# INLINE fail #-} -#endif - -instance (Monad m) => MonadPlus (MaybeT m) where - mzero = MaybeT (return Nothing) - {-# INLINE mzero #-} - mplus x y = MaybeT $ do - v <- runMaybeT x - case v of - Nothing -> runMaybeT y - Just _ -> return v - {-# INLINE mplus #-} - -instance (MonadFix m) => MonadFix (MaybeT m) where - mfix f = MaybeT (mfix (runMaybeT . f . fromMaybe bomb)) - where bomb = error "mfix (MaybeT): inner computation returned Nothing" - {-# INLINE mfix #-} - -instance MonadTrans MaybeT where - lift = MaybeT . liftM Just - {-# INLINE lift #-} - -instance (MonadIO m) => MonadIO (MaybeT m) where - liftIO = lift . liftIO - {-# INLINE liftIO #-} - -#if MIN_VERSION_base(4,4,0) -instance (MonadZip m) => MonadZip (MaybeT m) where - mzipWith f (MaybeT a) (MaybeT b) = MaybeT $ mzipWith (liftA2 f) a b - {-# INLINE mzipWith #-} -#endif - -#if MIN_VERSION_base(4,12,0) -instance Contravariant m => Contravariant (MaybeT m) where - contramap f = MaybeT . contramap (fmap f) . runMaybeT - {-# INLINE contramap #-} -#endif - --- | Lift a @callCC@ operation to the new monad. -liftCallCC :: CallCC m (Maybe a) (Maybe b) -> CallCC (MaybeT m) a b -liftCallCC callCC f = - MaybeT $ callCC $ \ c -> runMaybeT (f (MaybeT . c . Just)) -{-# INLINE liftCallCC #-} - --- | Lift a @catchE@ operation to the new monad. -liftCatch :: Catch e m (Maybe a) -> Catch e (MaybeT m) a -liftCatch f m h = MaybeT $ f (runMaybeT m) (runMaybeT . h) -{-# INLINE liftCatch #-} - --- | Lift a @listen@ operation to the new monad. -liftListen :: (Monad m) => Listen w m (Maybe a) -> Listen w (MaybeT m) a -liftListen listen = mapMaybeT $ \ m -> do - (a, w) <- listen m - return $! fmap (\ r -> (r, w)) a -{-# INLINE liftListen #-} - --- | Lift a @pass@ operation to the new monad. -liftPass :: (Monad m) => Pass w m (Maybe a) -> Pass w (MaybeT m) a -liftPass pass = mapMaybeT $ \ m -> pass $ do - a <- m - return $! case a of - Nothing -> (Nothing, id) - Just (v, f) -> (Just v, f) -{-# INLINE liftPass #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS.hs deleted file mode 100644 index b4cc6adaad78..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Trans.RWS --- Copyright : (c) Andy Gill 2001, --- (c) Oregon Graduate Institute of Science and Technology, 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- A monad transformer that combines 'ReaderT', 'WriterT' and 'StateT'. --- This version is lazy; for a constant-space version with almost the --- same interface, see "Control.Monad.Trans.RWS.CPS". ------------------------------------------------------------------------------ - -module Control.Monad.Trans.RWS ( - module Control.Monad.Trans.RWS.Lazy - ) where - -import Control.Monad.Trans.RWS.Lazy diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/CPS.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/CPS.hs deleted file mode 100644 index 8a565e1652c3..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/CPS.hs +++ /dev/null @@ -1,406 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE AutoDeriveTypeable #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Trans.RWS.CPS --- Copyright : (c) Daniel Mendler 2016, --- (c) Andy Gill 2001, --- (c) Oregon Graduate Institute of Science and Technology, 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- A monad transformer that combines 'ReaderT', 'WriterT' and 'StateT'. --- This version uses continuation-passing-style for the writer part --- to achieve constant space usage. --- For a lazy version with the same interface, --- see "Control.Monad.Trans.RWS.Lazy". ------------------------------------------------------------------------------ - -module Control.Monad.Trans.RWS.CPS ( - -- * The RWS monad - RWS, - rws, - runRWS, - evalRWS, - execRWS, - mapRWS, - withRWS, - -- * The RWST monad transformer - RWST, - rwsT, - runRWST, - evalRWST, - execRWST, - mapRWST, - withRWST, - -- * Reader operations - reader, - ask, - local, - asks, - -- * Writer operations - writer, - tell, - listen, - listens, - pass, - censor, - -- * State operations - state, - get, - put, - modify, - gets, - -- * Lifting other operations - liftCallCC, - liftCallCC', - liftCatch, - ) where - -import Control.Applicative -import Control.Monad -import Control.Monad.Fix -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Signatures -import Data.Functor.Identity - -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid -#endif - -#if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail -#endif - --- | A monad containing an environment of type @r@, output of type @w@ --- and an updatable state of type @s@. -type RWS r w s = RWST r w s Identity - --- | Construct an RWS computation from a function. --- (The inverse of 'runRWS'.) -rws :: (Monoid w) => (r -> s -> (a, s, w)) -> RWS r w s a -rws f = RWST $ \ r s w -> - let (a, s', w') = f r s; wt = w `mappend` w' in wt `seq` return (a, s', wt) -{-# INLINE rws #-} - --- | Unwrap an RWS computation as a function. --- (The inverse of 'rws'.) -runRWS :: (Monoid w) => RWS r w s a -> r -> s -> (a, s, w) -runRWS m r s = runIdentity (runRWST m r s) -{-# INLINE runRWS #-} - --- | Evaluate a computation with the given initial state and environment, --- returning the final value and output, discarding the final state. -evalRWS :: (Monoid w) - => RWS r w s a -- ^RWS computation to execute - -> r -- ^initial environment - -> s -- ^initial value - -> (a, w) -- ^final value and output -evalRWS m r s = let - (a, _, w) = runRWS m r s - in (a, w) -{-# INLINE evalRWS #-} - --- | Evaluate a computation with the given initial state and environment, --- returning the final state and output, discarding the final value. -execRWS :: (Monoid w) - => RWS r w s a -- ^RWS computation to execute - -> r -- ^initial environment - -> s -- ^initial value - -> (s, w) -- ^final state and output -execRWS m r s = let - (_, s', w) = runRWS m r s - in (s', w) -{-# INLINE execRWS #-} - --- | Map the return value, final state and output of a computation using --- the given function. --- --- * @'runRWS' ('mapRWS' f m) r s = f ('runRWS' m r s)@ -mapRWS :: (Monoid w, Monoid w') => ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b -mapRWS f = mapRWST (Identity . f . runIdentity) -{-# INLINE mapRWS #-} - --- | @'withRWS' f m@ executes action @m@ with an initial environment --- and state modified by applying @f@. --- --- * @'runRWS' ('withRWS' f m) r s = 'uncurry' ('runRWS' m) (f r s)@ -withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a -withRWS = withRWST -{-# INLINE withRWS #-} - --- --------------------------------------------------------------------------- --- | A monad transformer adding reading an environment of type @r@, --- collecting an output of type @w@ and updating a state of type @s@ --- to an inner monad @m@. -newtype RWST r w s m a = RWST { unRWST :: r -> s -> w -> m (a, s, w) } - --- | Construct an RWST computation from a function. --- (The inverse of 'runRWST'.) -rwsT :: (Functor m, Monoid w) => (r -> s -> m (a, s, w)) -> RWST r w s m a -rwsT f = RWST $ \ r s w -> - (\ (a, s', w') -> let wt = w `mappend` w' in wt `seq` (a, s', wt)) <$> f r s -{-# INLINE rwsT #-} - --- | Unwrap an RWST computation as a function. --- (The inverse of 'rwsT'.) -runRWST :: (Monoid w) => RWST r w s m a -> r -> s -> m (a, s, w) -runRWST m r s = unRWST m r s mempty -{-# INLINE runRWST #-} - --- | Evaluate a computation with the given initial state and environment, --- returning the final value and output, discarding the final state. -evalRWST :: (Monad m, Monoid w) - => RWST r w s m a -- ^computation to execute - -> r -- ^initial environment - -> s -- ^initial value - -> m (a, w) -- ^computation yielding final value and output -evalRWST m r s = do - (a, _, w) <- runRWST m r s - return (a, w) -{-# INLINE evalRWST #-} - --- | Evaluate a computation with the given initial state and environment, --- returning the final state and output, discarding the final value. -execRWST :: (Monad m, Monoid w) - => RWST r w s m a -- ^computation to execute - -> r -- ^initial environment - -> s -- ^initial value - -> m (s, w) -- ^computation yielding final state and output -execRWST m r s = do - (_, s', w) <- runRWST m r s - return (s', w) -{-# INLINE execRWST #-} - --- | Map the inner computation using the given function. --- --- * @'runRWST' ('mapRWST' f m) r s = f ('runRWST' m r s)@ ---mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b -mapRWST :: (Monad n, Monoid w, Monoid w') => - (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b -mapRWST f m = RWST $ \ r s w -> do - (a, s', w') <- f (runRWST m r s) - let wt = w `mappend` w' - wt `seq` return (a, s', wt) -{-# INLINE mapRWST #-} - --- | @'withRWST' f m@ executes action @m@ with an initial environment --- and state modified by applying @f@. --- --- * @'runRWST' ('withRWST' f m) r s = 'uncurry' ('runRWST' m) (f r s)@ -withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a -withRWST f m = RWST $ \ r s -> uncurry (unRWST m) (f r s) -{-# INLINE withRWST #-} - -instance (Functor m) => Functor (RWST r w s m) where - fmap f m = RWST $ \ r s w -> (\ (a, s', w') -> (f a, s', w')) <$> unRWST m r s w - {-# INLINE fmap #-} - -instance (Functor m, Monad m) => Applicative (RWST r w s m) where - pure a = RWST $ \ _ s w -> return (a, s, w) - {-# INLINE pure #-} - - RWST mf <*> RWST mx = RWST $ \ r s w -> do - (f, s', w') <- mf r s w - (x, s'', w'') <- mx r s' w' - return (f x, s'', w'') - {-# INLINE (<*>) #-} - -instance (Functor m, MonadPlus m) => Alternative (RWST r w s m) where - empty = RWST $ \ _ _ _ -> mzero - {-# INLINE empty #-} - - RWST m <|> RWST n = RWST $ \ r s w -> m r s w `mplus` n r s w - {-# INLINE (<|>) #-} - -instance (Monad m) => Monad (RWST r w s m) where -#if !(MIN_VERSION_base(4,8,0)) - return a = RWST $ \ _ s w -> return (a, s, w) - {-# INLINE return #-} -#endif - - m >>= k = RWST $ \ r s w -> do - (a, s', w') <- unRWST m r s w - unRWST (k a) r s' w' - {-# INLINE (>>=) #-} - -#if !(MIN_VERSION_base(4,13,0)) - fail msg = RWST $ \ _ _ _ -> fail msg - {-# INLINE fail #-} -#endif - -#if MIN_VERSION_base(4,9,0) -instance (Fail.MonadFail m) => Fail.MonadFail (RWST r w s m) where - fail msg = RWST $ \ _ _ _ -> Fail.fail msg - {-# INLINE fail #-} -#endif - -instance (Functor m, MonadPlus m) => MonadPlus (RWST r w s m) where - mzero = empty - {-# INLINE mzero #-} - mplus = (<|>) - {-# INLINE mplus #-} - -instance (MonadFix m) => MonadFix (RWST r w s m) where - mfix f = RWST $ \ r s w -> mfix $ \ ~(a, _, _) -> unRWST (f a) r s w - {-# INLINE mfix #-} - -instance MonadTrans (RWST r w s) where - lift m = RWST $ \ _ s w -> do - a <- m - return (a, s, w) - {-# INLINE lift #-} - -instance (MonadIO m) => MonadIO (RWST r w s m) where - liftIO = lift . liftIO - {-# INLINE liftIO #-} --- --------------------------------------------------------------------------- --- Reader operations - --- | Constructor for computations in the reader monad (equivalent to 'asks'). -reader :: (Monad m) => (r -> a) -> RWST r w s m a -reader = asks -{-# INLINE reader #-} - --- | Fetch the value of the environment. -ask :: (Monad m) => RWST r w s m r -ask = asks id -{-# INLINE ask #-} - --- | Execute a computation in a modified environment --- --- * @'runRWST' ('local' f m) r s = 'runRWST' m (f r) s@ -local :: (r -> r) -> RWST r w s m a -> RWST r w s m a -local f m = RWST $ \ r s w -> unRWST m (f r) s w -{-# INLINE local #-} - --- | Retrieve a function of the current environment. --- --- * @'asks' f = 'liftM' f 'ask'@ -asks :: (Monad m) => (r -> a) -> RWST r w s m a -asks f = RWST $ \ r s w -> return (f r, s, w) -{-# INLINE asks #-} - --- --------------------------------------------------------------------------- --- Writer operations - --- | Construct a writer computation from a (result, output) pair. -writer :: (Monoid w, Monad m) => (a, w) -> RWST r w s m a -writer (a, w') = RWST $ \ _ s w -> let wt = w `mappend` w' in wt `seq` return (a, s, wt) -{-# INLINE writer #-} - --- | @'tell' w@ is an action that produces the output @w@. -tell :: (Monoid w, Monad m) => w -> RWST r w s m () -tell w' = writer ((), w') -{-# INLINE tell #-} - --- | @'listen' m@ is an action that executes the action @m@ and adds its --- output to the value of the computation. --- --- * @'runRWST' ('listen' m) r s = 'liftM' (\\ (a, w) -> ((a, w), w)) ('runRWST' m r s)@ -listen :: (Monoid w, Monad m) => RWST r w s m a -> RWST r w s m (a, w) -listen = listens id -{-# INLINE listen #-} - --- | @'listens' f m@ is an action that executes the action @m@ and adds --- the result of applying @f@ to the output to the value of the computation. --- --- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@ --- --- * @'runRWST' ('listens' f m) r s = 'liftM' (\\ (a, w) -> ((a, f w), w)) ('runRWST' m r s)@ -listens :: (Monoid w, Monad m) => (w -> b) -> RWST r w s m a -> RWST r w s m (a, b) -listens f m = RWST $ \ r s w -> do - (a, s', w') <- runRWST m r s - let wt = w `mappend` w' - wt `seq` return ((a, f w'), s', wt) -{-# INLINE listens #-} - --- | @'pass' m@ is an action that executes the action @m@, which returns --- a value and a function, and returns the value, applying the function --- to the output. --- --- * @'runRWST' ('pass' m) r s = 'liftM' (\\ ((a, f), w) -> (a, f w)) ('runRWST' m r s)@ -pass :: (Monoid w, Monoid w', Monad m) => RWST r w s m (a, w -> w') -> RWST r w' s m a -pass m = RWST $ \ r s w -> do - ((a, f), s', w') <- runRWST m r s - let wt = w `mappend` f w' - wt `seq` return (a, s', wt) -{-# INLINE pass #-} - --- | @'censor' f m@ is an action that executes the action @m@ and --- applies the function @f@ to its output, leaving the return value --- unchanged. --- --- * @'censor' f m = 'pass' ('liftM' (\\ x -> (x,f)) m)@ --- --- * @'runRWST' ('censor' f m) r s = 'liftM' (\\ (a, w) -> (a, f w)) ('runRWST' m r s)@ -censor :: (Monoid w, Monad m) => (w -> w) -> RWST r w s m a -> RWST r w s m a -censor f m = RWST $ \ r s w -> do - (a, s', w') <- runRWST m r s - let wt = w `mappend` f w' - wt `seq` return (a, s', wt) -{-# INLINE censor #-} - --- --------------------------------------------------------------------------- --- State operations - --- | Construct a state monad computation from a state transformer function. -state :: (Monad m) => (s -> (a, s)) -> RWST r w s m a -state f = RWST $ \ _ s w -> let (a, s') = f s in return (a, s', w) -{-# INLINE state #-} - --- | Fetch the current value of the state within the monad. -get :: (Monad m) =>RWST r w s m s -get = gets id -{-# INLINE get #-} - --- | @'put' s@ sets the state within the monad to @s@. -put :: (Monad m) =>s -> RWST r w s m () -put s = RWST $ \ _ _ w -> return ((), s, w) -{-# INLINE put #-} - --- | @'modify' f@ is an action that updates the state to the result of --- applying @f@ to the current state. --- --- * @'modify' f = 'get' >>= ('put' . f)@ -modify :: (Monad m) =>(s -> s) -> RWST r w s m () -modify f = RWST $ \ _ s w -> return ((), f s, w) -{-# INLINE modify #-} - --- | Get a specific component of the state, using a projection function --- supplied. --- --- * @'gets' f = 'liftM' f 'get'@ -gets :: (Monad m) =>(s -> a) -> RWST r w s m a -gets f = RWST $ \ _ s w -> return (f s, s, w) -{-# INLINE gets #-} - --- | Uniform lifting of a @callCC@ operation to the new monad. --- This version rolls back to the original state on entering the --- continuation. -liftCallCC :: CallCC m (a,s,w) (b,s,w) -> CallCC (RWST r w s m) a b -liftCallCC callCC f = RWST $ \ r s w -> - callCC $ \ c -> unRWST (f (\ a -> RWST $ \ _ _ _ -> c (a, s, w))) r s w -{-# INLINE liftCallCC #-} - --- | In-situ lifting of a @callCC@ operation to the new monad. --- This version uses the current state on entering the continuation. -liftCallCC' :: CallCC m (a,s,w) (b,s,w) -> CallCC (RWST r w s m) a b -liftCallCC' callCC f = RWST $ \ r s w -> - callCC $ \ c -> unRWST (f (\ a -> RWST $ \ _ s' _ -> c (a, s', w))) r s w -{-# INLINE liftCallCC' #-} - --- | Lift a @catchE@ operation to the new monad. -liftCatch :: Catch e m (a,s,w) -> Catch e (RWST r w s m) a -liftCatch catchE m h = - RWST $ \ r s w -> unRWST m r s w `catchE` \ e -> unRWST (h e) r s w -{-# INLINE liftCatch #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/Lazy.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/Lazy.hs deleted file mode 100644 index 8f98b2c5e05a..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/Lazy.hs +++ /dev/null @@ -1,389 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE AutoDeriveTypeable #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Trans.RWS.Lazy --- Copyright : (c) Andy Gill 2001, --- (c) Oregon Graduate Institute of Science and Technology, 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- A monad transformer that combines 'ReaderT', 'WriterT' and 'StateT'. --- This version is lazy; for a constant-space version with almost the --- same interface, see "Control.Monad.Trans.RWS.CPS". ------------------------------------------------------------------------------ - -module Control.Monad.Trans.RWS.Lazy ( - -- * The RWS monad - RWS, - rws, - runRWS, - evalRWS, - execRWS, - mapRWS, - withRWS, - -- * The RWST monad transformer - RWST(..), - evalRWST, - execRWST, - mapRWST, - withRWST, - -- * Reader operations - reader, - ask, - local, - asks, - -- * Writer operations - writer, - tell, - listen, - listens, - pass, - censor, - -- * State operations - state, - get, - put, - modify, - gets, - -- * Lifting other operations - liftCallCC, - liftCallCC', - liftCatch, - ) where - -import Control.Monad.IO.Class -import Control.Monad.Signatures -import Control.Monad.Trans.Class -#if MIN_VERSION_base(4,12,0) -import Data.Functor.Contravariant -#endif -import Data.Functor.Identity - -import Control.Applicative -import Control.Monad -#if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail -#endif -import Control.Monad.Fix -import Data.Monoid - --- | A monad containing an environment of type @r@, output of type @w@ --- and an updatable state of type @s@. -type RWS r w s = RWST r w s Identity - --- | Construct an RWS computation from a function. --- (The inverse of 'runRWS'.) -rws :: (r -> s -> (a, s, w)) -> RWS r w s a -rws f = RWST (\ r s -> Identity (f r s)) -{-# INLINE rws #-} - --- | Unwrap an RWS computation as a function. --- (The inverse of 'rws'.) -runRWS :: RWS r w s a -> r -> s -> (a, s, w) -runRWS m r s = runIdentity (runRWST m r s) -{-# INLINE runRWS #-} - --- | Evaluate a computation with the given initial state and environment, --- returning the final value and output, discarding the final state. -evalRWS :: RWS r w s a -- ^RWS computation to execute - -> r -- ^initial environment - -> s -- ^initial value - -> (a, w) -- ^final value and output -evalRWS m r s = let - (a, _, w) = runRWS m r s - in (a, w) -{-# INLINE evalRWS #-} - --- | Evaluate a computation with the given initial state and environment, --- returning the final state and output, discarding the final value. -execRWS :: RWS r w s a -- ^RWS computation to execute - -> r -- ^initial environment - -> s -- ^initial value - -> (s, w) -- ^final state and output -execRWS m r s = let - (_, s', w) = runRWS m r s - in (s', w) -{-# INLINE execRWS #-} - --- | Map the return value, final state and output of a computation using --- the given function. --- --- * @'runRWS' ('mapRWS' f m) r s = f ('runRWS' m r s)@ -mapRWS :: ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b -mapRWS f = mapRWST (Identity . f . runIdentity) -{-# INLINE mapRWS #-} - --- | @'withRWS' f m@ executes action @m@ with an initial environment --- and state modified by applying @f@. --- --- * @'runRWS' ('withRWS' f m) r s = 'uncurry' ('runRWS' m) (f r s)@ -withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a -withRWS = withRWST -{-# INLINE withRWS #-} - --- --------------------------------------------------------------------------- --- | A monad transformer adding reading an environment of type @r@, --- collecting an output of type @w@ and updating a state of type @s@ --- to an inner monad @m@. -newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) } - --- | Evaluate a computation with the given initial state and environment, --- returning the final value and output, discarding the final state. -evalRWST :: (Monad m) - => RWST r w s m a -- ^computation to execute - -> r -- ^initial environment - -> s -- ^initial value - -> m (a, w) -- ^computation yielding final value and output -evalRWST m r s = do - ~(a, _, w) <- runRWST m r s - return (a, w) -{-# INLINE evalRWST #-} - --- | Evaluate a computation with the given initial state and environment, --- returning the final state and output, discarding the final value. -execRWST :: (Monad m) - => RWST r w s m a -- ^computation to execute - -> r -- ^initial environment - -> s -- ^initial value - -> m (s, w) -- ^computation yielding final state and output -execRWST m r s = do - ~(_, s', w) <- runRWST m r s - return (s', w) -{-# INLINE execRWST #-} - --- | Map the inner computation using the given function. --- --- * @'runRWST' ('mapRWST' f m) r s = f ('runRWST' m r s)@ -mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b -mapRWST f m = RWST $ \ r s -> f (runRWST m r s) -{-# INLINE mapRWST #-} - --- | @'withRWST' f m@ executes action @m@ with an initial environment --- and state modified by applying @f@. --- --- * @'runRWST' ('withRWST' f m) r s = 'uncurry' ('runRWST' m) (f r s)@ -withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a -withRWST f m = RWST $ \ r s -> uncurry (runRWST m) (f r s) -{-# INLINE withRWST #-} - -instance (Functor m) => Functor (RWST r w s m) where - fmap f m = RWST $ \ r s -> - fmap (\ ~(a, s', w) -> (f a, s', w)) $ runRWST m r s - {-# INLINE fmap #-} - -instance (Monoid w, Functor m, Monad m) => Applicative (RWST r w s m) where - pure a = RWST $ \ _ s -> return (a, s, mempty) - {-# INLINE pure #-} - RWST mf <*> RWST mx = RWST $ \ r s -> do - ~(f, s', w) <- mf r s - ~(x, s'',w') <- mx r s' - return (f x, s'', w `mappend` w') - {-# INLINE (<*>) #-} - -instance (Monoid w, Functor m, MonadPlus m) => Alternative (RWST r w s m) where - empty = RWST $ \ _ _ -> mzero - {-# INLINE empty #-} - RWST m <|> RWST n = RWST $ \ r s -> m r s `mplus` n r s - {-# INLINE (<|>) #-} - -instance (Monoid w, Monad m) => Monad (RWST r w s m) where -#if !(MIN_VERSION_base(4,8,0)) - return a = RWST $ \ _ s -> return (a, s, mempty) - {-# INLINE return #-} -#endif - m >>= k = RWST $ \ r s -> do - ~(a, s', w) <- runRWST m r s - ~(b, s'',w') <- runRWST (k a) r s' - return (b, s'', w `mappend` w') - {-# INLINE (>>=) #-} -#if !(MIN_VERSION_base(4,13,0)) - fail msg = RWST $ \ _ _ -> fail msg - {-# INLINE fail #-} -#endif - -#if MIN_VERSION_base(4,9,0) -instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (RWST r w s m) where - fail msg = RWST $ \ _ _ -> Fail.fail msg - {-# INLINE fail #-} -#endif - -instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where - mzero = RWST $ \ _ _ -> mzero - {-# INLINE mzero #-} - RWST m `mplus` RWST n = RWST $ \ r s -> m r s `mplus` n r s - {-# INLINE mplus #-} - -instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where - mfix f = RWST $ \ r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s - {-# INLINE mfix #-} - -instance (Monoid w) => MonadTrans (RWST r w s) where - lift m = RWST $ \ _ s -> do - a <- m - return (a, s, mempty) - {-# INLINE lift #-} - -instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where - liftIO = lift . liftIO - {-# INLINE liftIO #-} - -#if MIN_VERSION_base(4,12,0) -instance Contravariant m => Contravariant (RWST r w s m) where - contramap f m = RWST $ \r s -> - contramap (\ ~(a, s', w) -> (f a, s', w)) $ runRWST m r s - {-# INLINE contramap #-} -#endif - --- --------------------------------------------------------------------------- --- Reader operations - --- | Constructor for computations in the reader monad (equivalent to 'asks'). -reader :: (Monoid w, Monad m) => (r -> a) -> RWST r w s m a -reader = asks -{-# INLINE reader #-} - --- | Fetch the value of the environment. -ask :: (Monoid w, Monad m) => RWST r w s m r -ask = RWST $ \ r s -> return (r, s, mempty) -{-# INLINE ask #-} - --- | Execute a computation in a modified environment --- --- * @'runRWST' ('local' f m) r s = 'runRWST' m (f r) s@ -local :: (r -> r) -> RWST r w s m a -> RWST r w s m a -local f m = RWST $ \ r s -> runRWST m (f r) s -{-# INLINE local #-} - --- | Retrieve a function of the current environment. --- --- * @'asks' f = 'liftM' f 'ask'@ -asks :: (Monoid w, Monad m) => (r -> a) -> RWST r w s m a -asks f = RWST $ \ r s -> return (f r, s, mempty) -{-# INLINE asks #-} - --- --------------------------------------------------------------------------- --- Writer operations - --- | Construct a writer computation from a (result, output) pair. -writer :: (Monad m) => (a, w) -> RWST r w s m a -writer (a, w) = RWST $ \ _ s -> return (a, s, w) -{-# INLINE writer #-} - --- | @'tell' w@ is an action that produces the output @w@. -tell :: (Monad m) => w -> RWST r w s m () -tell w = RWST $ \ _ s -> return ((),s,w) -{-# INLINE tell #-} - --- | @'listen' m@ is an action that executes the action @m@ and adds its --- output to the value of the computation. --- --- * @'runRWST' ('listen' m) r s = 'liftM' (\\ (a, w) -> ((a, w), w)) ('runRWST' m r s)@ -listen :: (Monad m) => RWST r w s m a -> RWST r w s m (a, w) -listen m = RWST $ \ r s -> do - ~(a, s', w) <- runRWST m r s - return ((a, w), s', w) -{-# INLINE listen #-} - --- | @'listens' f m@ is an action that executes the action @m@ and adds --- the result of applying @f@ to the output to the value of the computation. --- --- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@ --- --- * @'runRWST' ('listens' f m) r s = 'liftM' (\\ (a, w) -> ((a, f w), w)) ('runRWST' m r s)@ -listens :: (Monad m) => (w -> b) -> RWST r w s m a -> RWST r w s m (a, b) -listens f m = RWST $ \ r s -> do - ~(a, s', w) <- runRWST m r s - return ((a, f w), s', w) -{-# INLINE listens #-} - --- | @'pass' m@ is an action that executes the action @m@, which returns --- a value and a function, and returns the value, applying the function --- to the output. --- --- * @'runRWST' ('pass' m) r s = 'liftM' (\\ ((a, f), w) -> (a, f w)) ('runRWST' m r s)@ -pass :: (Monad m) => RWST r w s m (a, w -> w) -> RWST r w s m a -pass m = RWST $ \ r s -> do - ~((a, f), s', w) <- runRWST m r s - return (a, s', f w) -{-# INLINE pass #-} - --- | @'censor' f m@ is an action that executes the action @m@ and --- applies the function @f@ to its output, leaving the return value --- unchanged. --- --- * @'censor' f m = 'pass' ('liftM' (\\ x -> (x,f)) m)@ --- --- * @'runRWST' ('censor' f m) r s = 'liftM' (\\ (a, w) -> (a, f w)) ('runRWST' m r s)@ -censor :: (Monad m) => (w -> w) -> RWST r w s m a -> RWST r w s m a -censor f m = RWST $ \ r s -> do - ~(a, s', w) <- runRWST m r s - return (a, s', f w) -{-# INLINE censor #-} - --- --------------------------------------------------------------------------- --- State operations - --- | Construct a state monad computation from a state transformer function. -state :: (Monoid w, Monad m) => (s -> (a,s)) -> RWST r w s m a -state f = RWST $ \ _ s -> let (a,s') = f s in return (a, s', mempty) -{-# INLINE state #-} - --- | Fetch the current value of the state within the monad. -get :: (Monoid w, Monad m) => RWST r w s m s -get = RWST $ \ _ s -> return (s, s, mempty) -{-# INLINE get #-} - --- | @'put' s@ sets the state within the monad to @s@. -put :: (Monoid w, Monad m) => s -> RWST r w s m () -put s = RWST $ \ _ _ -> return ((), s, mempty) -{-# INLINE put #-} - --- | @'modify' f@ is an action that updates the state to the result of --- applying @f@ to the current state. --- --- * @'modify' f = 'get' >>= ('put' . f)@ -modify :: (Monoid w, Monad m) => (s -> s) -> RWST r w s m () -modify f = RWST $ \ _ s -> return ((), f s, mempty) -{-# INLINE modify #-} - --- | Get a specific component of the state, using a projection function --- supplied. --- --- * @'gets' f = 'liftM' f 'get'@ -gets :: (Monoid w, Monad m) => (s -> a) -> RWST r w s m a -gets f = RWST $ \ _ s -> return (f s, s, mempty) -{-# INLINE gets #-} - --- | Uniform lifting of a @callCC@ operation to the new monad. --- This version rolls back to the original state on entering the --- continuation. -liftCallCC :: (Monoid w) => - CallCC m (a,s,w) (b,s,w) -> CallCC (RWST r w s m) a b -liftCallCC callCC f = RWST $ \ r s -> - callCC $ \ c -> - runRWST (f (\ a -> RWST $ \ _ _ -> c (a, s, mempty))) r s -{-# INLINE liftCallCC #-} - --- | In-situ lifting of a @callCC@ operation to the new monad. --- This version uses the current state on entering the continuation. -liftCallCC' :: (Monoid w) => - CallCC m (a,s,w) (b,s,w) -> CallCC (RWST r w s m) a b -liftCallCC' callCC f = RWST $ \ r s -> - callCC $ \ c -> - runRWST (f (\ a -> RWST $ \ _ s' -> c (a, s', mempty))) r s -{-# INLINE liftCallCC' #-} - --- | Lift a @catchE@ operation to the new monad. -liftCatch :: Catch e m (a,s,w) -> Catch e (RWST r w s m) a -liftCatch catchE m h = - RWST $ \ r s -> runRWST m r s `catchE` \ e -> runRWST (h e) r s -{-# INLINE liftCatch #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/Strict.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/Strict.hs deleted file mode 100644 index 557dd2028dd0..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/Strict.hs +++ /dev/null @@ -1,392 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE AutoDeriveTypeable #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Trans.RWS.Strict --- Copyright : (c) Andy Gill 2001, --- (c) Oregon Graduate Institute of Science and Technology, 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- A monad transformer that combines 'ReaderT', 'WriterT' and 'StateT'. --- This version is strict; for a lazy version with the same interface, --- see "Control.Monad.Trans.RWS.Lazy". --- Although the output is built strictly, it is not possible to --- achieve constant space behaviour with this transformer: for that, --- use "Control.Monad.Trans.RWS.CPS" instead. ------------------------------------------------------------------------------ - -module Control.Monad.Trans.RWS.Strict ( - -- * The RWS monad - RWS, - rws, - runRWS, - evalRWS, - execRWS, - mapRWS, - withRWS, - -- * The RWST monad transformer - RWST(..), - evalRWST, - execRWST, - mapRWST, - withRWST, - -- * Reader operations - reader, - ask, - local, - asks, - -- * Writer operations - writer, - tell, - listen, - listens, - pass, - censor, - -- * State operations - state, - get, - put, - modify, - gets, - -- * Lifting other operations - liftCallCC, - liftCallCC', - liftCatch, - ) where - -import Control.Monad.IO.Class -import Control.Monad.Signatures -import Control.Monad.Trans.Class -#if MIN_VERSION_base(4,12,0) -import Data.Functor.Contravariant -#endif -import Data.Functor.Identity - -import Control.Applicative -import Control.Monad -#if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail -#endif -import Control.Monad.Fix -import Data.Monoid - --- | A monad containing an environment of type @r@, output of type @w@ --- and an updatable state of type @s@. -type RWS r w s = RWST r w s Identity - --- | Construct an RWS computation from a function. --- (The inverse of 'runRWS'.) -rws :: (r -> s -> (a, s, w)) -> RWS r w s a -rws f = RWST (\ r s -> Identity (f r s)) -{-# INLINE rws #-} - --- | Unwrap an RWS computation as a function. --- (The inverse of 'rws'.) -runRWS :: RWS r w s a -> r -> s -> (a, s, w) -runRWS m r s = runIdentity (runRWST m r s) -{-# INLINE runRWS #-} - --- | Evaluate a computation with the given initial state and environment, --- returning the final value and output, discarding the final state. -evalRWS :: RWS r w s a -- ^RWS computation to execute - -> r -- ^initial environment - -> s -- ^initial value - -> (a, w) -- ^final value and output -evalRWS m r s = let - (a, _, w) = runRWS m r s - in (a, w) -{-# INLINE evalRWS #-} - --- | Evaluate a computation with the given initial state and environment, --- returning the final state and output, discarding the final value. -execRWS :: RWS r w s a -- ^RWS computation to execute - -> r -- ^initial environment - -> s -- ^initial value - -> (s, w) -- ^final state and output -execRWS m r s = let - (_, s', w) = runRWS m r s - in (s', w) -{-# INLINE execRWS #-} - --- | Map the return value, final state and output of a computation using --- the given function. --- --- * @'runRWS' ('mapRWS' f m) r s = f ('runRWS' m r s)@ -mapRWS :: ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b -mapRWS f = mapRWST (Identity . f . runIdentity) -{-# INLINE mapRWS #-} - --- | @'withRWS' f m@ executes action @m@ with an initial environment --- and state modified by applying @f@. --- --- * @'runRWS' ('withRWS' f m) r s = 'uncurry' ('runRWS' m) (f r s)@ -withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a -withRWS = withRWST -{-# INLINE withRWS #-} - --- --------------------------------------------------------------------------- --- | A monad transformer adding reading an environment of type @r@, --- collecting an output of type @w@ and updating a state of type @s@ --- to an inner monad @m@. -newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) } - --- | Evaluate a computation with the given initial state and environment, --- returning the final value and output, discarding the final state. -evalRWST :: (Monad m) - => RWST r w s m a -- ^computation to execute - -> r -- ^initial environment - -> s -- ^initial value - -> m (a, w) -- ^computation yielding final value and output -evalRWST m r s = do - (a, _, w) <- runRWST m r s - return (a, w) -{-# INLINE evalRWST #-} - --- | Evaluate a computation with the given initial state and environment, --- returning the final state and output, discarding the final value. -execRWST :: (Monad m) - => RWST r w s m a -- ^computation to execute - -> r -- ^initial environment - -> s -- ^initial value - -> m (s, w) -- ^computation yielding final state and output -execRWST m r s = do - (_, s', w) <- runRWST m r s - return (s', w) -{-# INLINE execRWST #-} - --- | Map the inner computation using the given function. --- --- * @'runRWST' ('mapRWST' f m) r s = f ('runRWST' m r s)@ -mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b -mapRWST f m = RWST $ \ r s -> f (runRWST m r s) -{-# INLINE mapRWST #-} - --- | @'withRWST' f m@ executes action @m@ with an initial environment --- and state modified by applying @f@. --- --- * @'runRWST' ('withRWST' f m) r s = 'uncurry' ('runRWST' m) (f r s)@ -withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a -withRWST f m = RWST $ \ r s -> uncurry (runRWST m) (f r s) -{-# INLINE withRWST #-} - -instance (Functor m) => Functor (RWST r w s m) where - fmap f m = RWST $ \ r s -> - fmap (\ (a, s', w) -> (f a, s', w)) $ runRWST m r s - {-# INLINE fmap #-} - -instance (Monoid w, Functor m, Monad m) => Applicative (RWST r w s m) where - pure a = RWST $ \ _ s -> return (a, s, mempty) - {-# INLINE pure #-} - RWST mf <*> RWST mx = RWST $ \ r s -> do - (f, s', w) <- mf r s - (x, s'',w') <- mx r s' - return (f x, s'', w `mappend` w') - {-# INLINE (<*>) #-} - -instance (Monoid w, Functor m, MonadPlus m) => Alternative (RWST r w s m) where - empty = RWST $ \ _ _ -> mzero - {-# INLINE empty #-} - RWST m <|> RWST n = RWST $ \ r s -> m r s `mplus` n r s - {-# INLINE (<|>) #-} - -instance (Monoid w, Monad m) => Monad (RWST r w s m) where -#if !(MIN_VERSION_base(4,8,0)) - return a = RWST $ \ _ s -> return (a, s, mempty) - {-# INLINE return #-} -#endif - m >>= k = RWST $ \ r s -> do - (a, s', w) <- runRWST m r s - (b, s'',w') <- runRWST (k a) r s' - return (b, s'', w `mappend` w') - {-# INLINE (>>=) #-} -#if !(MIN_VERSION_base(4,13,0)) - fail msg = RWST $ \ _ _ -> fail msg - {-# INLINE fail #-} -#endif - -#if MIN_VERSION_base(4,9,0) -instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (RWST r w s m) where - fail msg = RWST $ \ _ _ -> Fail.fail msg - {-# INLINE fail #-} -#endif - -instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where - mzero = RWST $ \ _ _ -> mzero - {-# INLINE mzero #-} - RWST m `mplus` RWST n = RWST $ \ r s -> m r s `mplus` n r s - {-# INLINE mplus #-} - -instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where - mfix f = RWST $ \ r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s - {-# INLINE mfix #-} - -instance (Monoid w) => MonadTrans (RWST r w s) where - lift m = RWST $ \ _ s -> do - a <- m - return (a, s, mempty) - {-# INLINE lift #-} - -instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where - liftIO = lift . liftIO - {-# INLINE liftIO #-} - -#if MIN_VERSION_base(4,12,0) -instance Contravariant m => Contravariant (RWST r w s m) where - contramap f m = RWST $ \r s -> - contramap (\ (a, s', w) -> (f a, s', w)) $ runRWST m r s - {-# INLINE contramap #-} -#endif - --- --------------------------------------------------------------------------- --- Reader operations - --- | Constructor for computations in the reader monad (equivalent to 'asks'). -reader :: (Monoid w, Monad m) => (r -> a) -> RWST r w s m a -reader = asks -{-# INLINE reader #-} - --- | Fetch the value of the environment. -ask :: (Monoid w, Monad m) => RWST r w s m r -ask = RWST $ \ r s -> return (r, s, mempty) -{-# INLINE ask #-} - --- | Execute a computation in a modified environment --- --- * @'runRWST' ('local' f m) r s = 'runRWST' m (f r) s@ -local :: (r -> r) -> RWST r w s m a -> RWST r w s m a -local f m = RWST $ \ r s -> runRWST m (f r) s -{-# INLINE local #-} - --- | Retrieve a function of the current environment. --- --- * @'asks' f = 'liftM' f 'ask'@ -asks :: (Monoid w, Monad m) => (r -> a) -> RWST r w s m a -asks f = RWST $ \ r s -> return (f r, s, mempty) -{-# INLINE asks #-} - --- --------------------------------------------------------------------------- --- Writer operations - --- | Construct a writer computation from a (result, output) pair. -writer :: (Monad m) => (a, w) -> RWST r w s m a -writer (a, w) = RWST $ \ _ s -> return (a, s, w) -{-# INLINE writer #-} - --- | @'tell' w@ is an action that produces the output @w@. -tell :: (Monad m) => w -> RWST r w s m () -tell w = RWST $ \ _ s -> return ((),s,w) -{-# INLINE tell #-} - --- | @'listen' m@ is an action that executes the action @m@ and adds its --- output to the value of the computation. --- --- * @'runRWST' ('listen' m) r s = 'liftM' (\\ (a, w) -> ((a, w), w)) ('runRWST' m r s)@ -listen :: (Monad m) => RWST r w s m a -> RWST r w s m (a, w) -listen m = RWST $ \ r s -> do - (a, s', w) <- runRWST m r s - return ((a, w), s', w) -{-# INLINE listen #-} - --- | @'listens' f m@ is an action that executes the action @m@ and adds --- the result of applying @f@ to the output to the value of the computation. --- --- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@ --- --- * @'runRWST' ('listens' f m) r s = 'liftM' (\\ (a, w) -> ((a, f w), w)) ('runRWST' m r s)@ -listens :: (Monad m) => (w -> b) -> RWST r w s m a -> RWST r w s m (a, b) -listens f m = RWST $ \ r s -> do - (a, s', w) <- runRWST m r s - return ((a, f w), s', w) -{-# INLINE listens #-} - --- | @'pass' m@ is an action that executes the action @m@, which returns --- a value and a function, and returns the value, applying the function --- to the output. --- --- * @'runRWST' ('pass' m) r s = 'liftM' (\\ ((a, f), w) -> (a, f w)) ('runRWST' m r s)@ -pass :: (Monad m) => RWST r w s m (a, w -> w) -> RWST r w s m a -pass m = RWST $ \ r s -> do - ((a, f), s', w) <- runRWST m r s - return (a, s', f w) -{-# INLINE pass #-} - --- | @'censor' f m@ is an action that executes the action @m@ and --- applies the function @f@ to its output, leaving the return value --- unchanged. --- --- * @'censor' f m = 'pass' ('liftM' (\\ x -> (x,f)) m)@ --- --- * @'runRWST' ('censor' f m) r s = 'liftM' (\\ (a, w) -> (a, f w)) ('runRWST' m r s)@ -censor :: (Monad m) => (w -> w) -> RWST r w s m a -> RWST r w s m a -censor f m = RWST $ \ r s -> do - (a, s', w) <- runRWST m r s - return (a, s', f w) -{-# INLINE censor #-} - --- --------------------------------------------------------------------------- --- State operations - --- | Construct a state monad computation from a state transformer function. -state :: (Monoid w, Monad m) => (s -> (a,s)) -> RWST r w s m a -state f = RWST $ \ _ s -> case f s of (a,s') -> return (a, s', mempty) -{-# INLINE state #-} - --- | Fetch the current value of the state within the monad. -get :: (Monoid w, Monad m) => RWST r w s m s -get = RWST $ \ _ s -> return (s, s, mempty) -{-# INLINE get #-} - --- | @'put' s@ sets the state within the monad to @s@. -put :: (Monoid w, Monad m) => s -> RWST r w s m () -put s = RWST $ \ _ _ -> return ((), s, mempty) -{-# INLINE put #-} - --- | @'modify' f@ is an action that updates the state to the result of --- applying @f@ to the current state. --- --- * @'modify' f = 'get' >>= ('put' . f)@ -modify :: (Monoid w, Monad m) => (s -> s) -> RWST r w s m () -modify f = RWST $ \ _ s -> return ((), f s, mempty) -{-# INLINE modify #-} - --- | Get a specific component of the state, using a projection function --- supplied. --- --- * @'gets' f = 'liftM' f 'get'@ -gets :: (Monoid w, Monad m) => (s -> a) -> RWST r w s m a -gets f = RWST $ \ _ s -> return (f s, s, mempty) -{-# INLINE gets #-} - --- | Uniform lifting of a @callCC@ operation to the new monad. --- This version rolls back to the original state on entering the --- continuation. -liftCallCC :: (Monoid w) => - CallCC m (a,s,w) (b,s,w) -> CallCC (RWST r w s m) a b -liftCallCC callCC f = RWST $ \ r s -> - callCC $ \ c -> - runRWST (f (\ a -> RWST $ \ _ _ -> c (a, s, mempty))) r s -{-# INLINE liftCallCC #-} - --- | In-situ lifting of a @callCC@ operation to the new monad. --- This version uses the current state on entering the continuation. -liftCallCC' :: (Monoid w) => - CallCC m (a,s,w) (b,s,w) -> CallCC (RWST r w s m) a b -liftCallCC' callCC f = RWST $ \ r s -> - callCC $ \ c -> - runRWST (f (\ a -> RWST $ \ _ s' -> c (a, s', mempty))) r s -{-# INLINE liftCallCC' #-} - --- | Lift a @catchE@ operation to the new monad. -liftCatch :: Catch e m (a,s,w) -> Catch e (RWST r w s m) a -liftCatch catchE m h = - RWST $ \ r s -> runRWST m r s `catchE` \ e -> runRWST (h e) r s -{-# INLINE liftCatch #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Reader.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Reader.hs deleted file mode 100644 index 25e3ad27c3c6..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Reader.hs +++ /dev/null @@ -1,262 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE AutoDeriveTypeable #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Trans.Reader --- Copyright : (c) Andy Gill 2001, --- (c) Oregon Graduate Institute of Science and Technology, 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- Declaration of the 'ReaderT' monad transformer, which adds a static --- environment to a given monad. --- --- If the computation is to modify the stored information, use --- "Control.Monad.Trans.State" instead. ------------------------------------------------------------------------------ - -module Control.Monad.Trans.Reader ( - -- * The Reader monad - Reader, - reader, - runReader, - mapReader, - withReader, - -- * The ReaderT monad transformer - ReaderT(..), - mapReaderT, - withReaderT, - -- * Reader operations - ask, - local, - asks, - -- * Lifting other operations - liftCallCC, - liftCatch, - ) where - -import Control.Monad.IO.Class -import Control.Monad.Signatures -import Control.Monad.Trans.Class -#if MIN_VERSION_base(4,12,0) -import Data.Functor.Contravariant -#endif -import Data.Functor.Identity - -import Control.Applicative -import Control.Monad -#if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail -#endif -import Control.Monad.Fix -#if !(MIN_VERSION_base(4,6,0)) -import Control.Monad.Instances () -- deprecated from base-4.6 -#endif -#if MIN_VERSION_base(4,4,0) -import Control.Monad.Zip (MonadZip(mzipWith)) -#endif -#if MIN_VERSION_base(4,2,0) -import Data.Functor(Functor(..)) -#endif - --- | The parameterizable reader monad. --- --- Computations are functions of a shared environment. --- --- The 'return' function ignores the environment, while @>>=@ passes --- the inherited environment to both subcomputations. -type Reader r = ReaderT r Identity - --- | Constructor for computations in the reader monad (equivalent to 'asks'). -reader :: (Monad m) => (r -> a) -> ReaderT r m a -reader f = ReaderT (return . f) -{-# INLINE reader #-} - --- | Runs a @Reader@ and extracts the final value from it. --- (The inverse of 'reader'.) -runReader - :: Reader r a -- ^ A @Reader@ to run. - -> r -- ^ An initial environment. - -> a -runReader m = runIdentity . runReaderT m -{-# INLINE runReader #-} - --- | Transform the value returned by a @Reader@. --- --- * @'runReader' ('mapReader' f m) = f . 'runReader' m@ -mapReader :: (a -> b) -> Reader r a -> Reader r b -mapReader f = mapReaderT (Identity . f . runIdentity) -{-# INLINE mapReader #-} - --- | Execute a computation in a modified environment --- (a specialization of 'withReaderT'). --- --- * @'runReader' ('withReader' f m) = 'runReader' m . f@ -withReader - :: (r' -> r) -- ^ The function to modify the environment. - -> Reader r a -- ^ Computation to run in the modified environment. - -> Reader r' a -withReader = withReaderT -{-# INLINE withReader #-} - --- | The reader monad transformer, --- which adds a read-only environment to the given monad. --- --- The 'return' function ignores the environment, while @>>=@ passes --- the inherited environment to both subcomputations. -newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a } - --- | Transform the computation inside a @ReaderT@. --- --- * @'runReaderT' ('mapReaderT' f m) = f . 'runReaderT' m@ -mapReaderT :: (m a -> n b) -> ReaderT r m a -> ReaderT r n b -mapReaderT f m = ReaderT $ f . runReaderT m -{-# INLINE mapReaderT #-} - --- | Execute a computation in a modified environment --- (a more general version of 'local'). --- --- * @'runReaderT' ('withReaderT' f m) = 'runReaderT' m . f@ -withReaderT - :: (r' -> r) -- ^ The function to modify the environment. - -> ReaderT r m a -- ^ Computation to run in the modified environment. - -> ReaderT r' m a -withReaderT f m = ReaderT $ runReaderT m . f -{-# INLINE withReaderT #-} - -instance (Functor m) => Functor (ReaderT r m) where - fmap f = mapReaderT (fmap f) - {-# INLINE fmap #-} -#if MIN_VERSION_base(4,2,0) - x <$ v = mapReaderT (x <$) v - {-# INLINE (<$) #-} -#endif - -instance (Applicative m) => Applicative (ReaderT r m) where - pure = liftReaderT . pure - {-# INLINE pure #-} - f <*> v = ReaderT $ \ r -> runReaderT f r <*> runReaderT v r - {-# INLINE (<*>) #-} -#if MIN_VERSION_base(4,2,0) - u *> v = ReaderT $ \ r -> runReaderT u r *> runReaderT v r - {-# INLINE (*>) #-} - u <* v = ReaderT $ \ r -> runReaderT u r <* runReaderT v r - {-# INLINE (<*) #-} -#endif -#if MIN_VERSION_base(4,10,0) - liftA2 f x y = ReaderT $ \ r -> liftA2 f (runReaderT x r) (runReaderT y r) - {-# INLINE liftA2 #-} -#endif - -instance (Alternative m) => Alternative (ReaderT r m) where - empty = liftReaderT empty - {-# INLINE empty #-} - m <|> n = ReaderT $ \ r -> runReaderT m r <|> runReaderT n r - {-# INLINE (<|>) #-} - -instance (Monad m) => Monad (ReaderT r m) where -#if !(MIN_VERSION_base(4,8,0)) - return = lift . return - {-# INLINE return #-} -#endif - m >>= k = ReaderT $ \ r -> do - a <- runReaderT m r - runReaderT (k a) r - {-# INLINE (>>=) #-} -#if MIN_VERSION_base(4,8,0) - (>>) = (*>) -#else - m >> k = ReaderT $ \ r -> runReaderT m r >> runReaderT k r -#endif - {-# INLINE (>>) #-} -#if !(MIN_VERSION_base(4,13,0)) - fail msg = lift (fail msg) - {-# INLINE fail #-} -#endif - -#if MIN_VERSION_base(4,9,0) -instance (Fail.MonadFail m) => Fail.MonadFail (ReaderT r m) where - fail msg = lift (Fail.fail msg) - {-# INLINE fail #-} -#endif - -instance (MonadPlus m) => MonadPlus (ReaderT r m) where - mzero = lift mzero - {-# INLINE mzero #-} - m `mplus` n = ReaderT $ \ r -> runReaderT m r `mplus` runReaderT n r - {-# INLINE mplus #-} - -instance (MonadFix m) => MonadFix (ReaderT r m) where - mfix f = ReaderT $ \ r -> mfix $ \ a -> runReaderT (f a) r - {-# INLINE mfix #-} - -instance MonadTrans (ReaderT r) where - lift = liftReaderT - {-# INLINE lift #-} - -instance (MonadIO m) => MonadIO (ReaderT r m) where - liftIO = lift . liftIO - {-# INLINE liftIO #-} - -#if MIN_VERSION_base(4,4,0) -instance (MonadZip m) => MonadZip (ReaderT r m) where - mzipWith f (ReaderT m) (ReaderT n) = ReaderT $ \ a -> - mzipWith f (m a) (n a) - {-# INLINE mzipWith #-} -#endif - -#if MIN_VERSION_base(4,12,0) -instance Contravariant m => Contravariant (ReaderT r m) where - contramap f = ReaderT . fmap (contramap f) . runReaderT - {-# INLINE contramap #-} -#endif - -liftReaderT :: m a -> ReaderT r m a -liftReaderT m = ReaderT (const m) -{-# INLINE liftReaderT #-} - --- | Fetch the value of the environment. -ask :: (Monad m) => ReaderT r m r -ask = ReaderT return -{-# INLINE ask #-} - --- | Execute a computation in a modified environment --- (a specialization of 'withReaderT'). --- --- * @'runReaderT' ('local' f m) = 'runReaderT' m . f@ -local - :: (r -> r) -- ^ The function to modify the environment. - -> ReaderT r m a -- ^ Computation to run in the modified environment. - -> ReaderT r m a -local = withReaderT -{-# INLINE local #-} - --- | Retrieve a function of the current environment. --- --- * @'asks' f = 'liftM' f 'ask'@ -asks :: (Monad m) - => (r -> a) -- ^ The selector function to apply to the environment. - -> ReaderT r m a -asks f = ReaderT (return . f) -{-# INLINE asks #-} - --- | Lift a @callCC@ operation to the new monad. -liftCallCC :: CallCC m a b -> CallCC (ReaderT r m) a b -liftCallCC callCC f = ReaderT $ \ r -> - callCC $ \ c -> - runReaderT (f (ReaderT . const . c)) r -{-# INLINE liftCallCC #-} - --- | Lift a @catchE@ operation to the new monad. -liftCatch :: Catch e m a -> Catch e (ReaderT r m) a -liftCatch f m h = - ReaderT $ \ r -> f (runReaderT m r) (\ e -> runReaderT (h e) r) -{-# INLINE liftCatch #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Select.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Select.hs deleted file mode 100644 index 22fdf8fd8abc..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Select.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -#endif -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE AutoDeriveTypeable #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Trans.Select --- Copyright : (c) Ross Paterson 2017 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- Selection monad transformer, modelling search algorithms. --- --- * Martin Escardo and Paulo Oliva. --- "Selection functions, bar recursion and backward induction", --- /Mathematical Structures in Computer Science/ 20:2 (2010), pp. 127-168. --- <https://www.cs.bham.ac.uk/~mhe/papers/selection-escardo-oliva.pdf> --- --- * Jules Hedges. "Monad transformers for backtracking search". --- In /Proceedings of MSFP 2014/. <https://arxiv.org/abs/1406.2058> ------------------------------------------------------------------------------ - -module Control.Monad.Trans.Select ( - -- * The Select monad - Select, - select, - runSelect, - mapSelect, - -- * The SelectT monad transformer - SelectT(SelectT), - runSelectT, - mapSelectT, - -- * Monad transformation - selectToContT, - selectToCont, - ) where - -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.Cont - -import Control.Applicative -import Control.Monad -#if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail -#endif -import Data.Functor.Identity - --- | Selection monad. -type Select r = SelectT r Identity - --- | Constructor for computations in the selection monad. -select :: ((a -> r) -> a) -> Select r a -select f = SelectT $ \ k -> Identity (f (runIdentity . k)) -{-# INLINE select #-} - --- | Runs a @Select@ computation with a function for evaluating answers --- to select a particular answer. (The inverse of 'select'.) -runSelect :: Select r a -> (a -> r) -> a -runSelect m k = runIdentity (runSelectT m (Identity . k)) -{-# INLINE runSelect #-} - --- | Apply a function to transform the result of a selection computation. --- --- * @'runSelect' ('mapSelect' f m) = f . 'runSelect' m@ -mapSelect :: (a -> a) -> Select r a -> Select r a -mapSelect f = mapSelectT (Identity . f . runIdentity) -{-# INLINE mapSelect #-} - --- | Selection monad transformer. --- --- 'SelectT' is not a functor on the category of monads, and many operations --- cannot be lifted through it. -newtype SelectT r m a = SelectT ((a -> m r) -> m a) - --- | Runs a @SelectT@ computation with a function for evaluating answers --- to select a particular answer. (The inverse of 'select'.) -runSelectT :: SelectT r m a -> (a -> m r) -> m a -runSelectT (SelectT g) = g -{-# INLINE runSelectT #-} - --- | Apply a function to transform the result of a selection computation. --- This has a more restricted type than the @map@ operations for other --- monad transformers, because 'SelectT' does not define a functor in --- the category of monads. --- --- * @'runSelectT' ('mapSelectT' f m) = f . 'runSelectT' m@ -mapSelectT :: (m a -> m a) -> SelectT r m a -> SelectT r m a -mapSelectT f m = SelectT $ f . runSelectT m -{-# INLINE mapSelectT #-} - -instance (Functor m) => Functor (SelectT r m) where - fmap f (SelectT g) = SelectT (fmap f . g . (. f)) - {-# INLINE fmap #-} - -instance (Functor m, Monad m) => Applicative (SelectT r m) where - pure = lift . return - {-# INLINE pure #-} - SelectT gf <*> SelectT gx = SelectT $ \ k -> do - let h f = liftM f (gx (k . f)) - f <- gf ((>>= k) . h) - h f - {-# INLINE (<*>) #-} - m *> k = m >>= \_ -> k - {-# INLINE (*>) #-} - -instance (Functor m, MonadPlus m) => Alternative (SelectT r m) where - empty = mzero - {-# INLINE empty #-} - (<|>) = mplus - {-# INLINE (<|>) #-} - -instance (Monad m) => Monad (SelectT r m) where -#if !(MIN_VERSION_base(4,8,0)) - return = lift . return - {-# INLINE return #-} -#endif - SelectT g >>= f = SelectT $ \ k -> do - let h x = runSelectT (f x) k - y <- g ((>>= k) . h) - h y - {-# INLINE (>>=) #-} - -#if MIN_VERSION_base(4,9,0) -instance (Fail.MonadFail m) => Fail.MonadFail (SelectT r m) where - fail msg = lift (Fail.fail msg) - {-# INLINE fail #-} -#endif - -instance (MonadPlus m) => MonadPlus (SelectT r m) where - mzero = SelectT (const mzero) - {-# INLINE mzero #-} - SelectT f `mplus` SelectT g = SelectT $ \ k -> f k `mplus` g k - {-# INLINE mplus #-} - -instance MonadTrans (SelectT r) where - lift = SelectT . const - {-# INLINE lift #-} - -instance (MonadIO m) => MonadIO (SelectT r m) where - liftIO = lift . liftIO - {-# INLINE liftIO #-} - --- | Convert a selection computation to a continuation-passing computation. -selectToContT :: (Monad m) => SelectT r m a -> ContT r m a -selectToContT (SelectT g) = ContT $ \ k -> g k >>= k -{-# INLINE selectToCont #-} - --- | Deprecated name for 'selectToContT'. -{-# DEPRECATED selectToCont "Use selectToContT instead" #-} -selectToCont :: (Monad m) => SelectT r m a -> ContT r m a -selectToCont = selectToContT diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State.hs deleted file mode 100644 index 36de964ea1d3..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Trans.State --- Copyright : (c) Andy Gill 2001, --- (c) Oregon Graduate Institute of Science and Technology, 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- State monads, passing an updatable state through a computation. --- --- Some computations may not require the full power of state transformers: --- --- * For a read-only state, see "Control.Monad.Trans.Reader". --- --- * To accumulate a value without using it on the way, see --- "Control.Monad.Trans.Writer". --- --- This version is lazy; for a strict version, see --- "Control.Monad.Trans.State.Strict", which has the same interface. ------------------------------------------------------------------------------ - -module Control.Monad.Trans.State ( - module Control.Monad.Trans.State.Lazy - ) where - -import Control.Monad.Trans.State.Lazy diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State/Lazy.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State/Lazy.hs deleted file mode 100644 index d7cdde5444a8..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State/Lazy.hs +++ /dev/null @@ -1,428 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE AutoDeriveTypeable #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Trans.State.Lazy --- Copyright : (c) Andy Gill 2001, --- (c) Oregon Graduate Institute of Science and Technology, 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- Lazy state monads, passing an updatable state through a computation. --- See below for examples. --- --- Some computations may not require the full power of state transformers: --- --- * For a read-only state, see "Control.Monad.Trans.Reader". --- --- * To accumulate a value without using it on the way, see --- "Control.Monad.Trans.Writer". --- --- In this version, sequencing of computations is lazy, so that for --- example the following produces a usable result: --- --- > evalState (sequence $ repeat $ do { n <- get; put (n*2); return n }) 1 --- --- For a strict version with the same interface, see --- "Control.Monad.Trans.State.Strict". ------------------------------------------------------------------------------ - -module Control.Monad.Trans.State.Lazy ( - -- * The State monad - State, - state, - runState, - evalState, - execState, - mapState, - withState, - -- * The StateT monad transformer - StateT(..), - evalStateT, - execStateT, - mapStateT, - withStateT, - -- * State operations - get, - put, - modify, - modify', - gets, - -- * Lifting other operations - liftCallCC, - liftCallCC', - liftCatch, - liftListen, - liftPass, - -- * Examples - -- ** State monads - -- $examples - - -- ** Counting - -- $counting - - -- ** Labelling trees - -- $labelling - ) where - -import Control.Monad.IO.Class -import Control.Monad.Signatures -import Control.Monad.Trans.Class -#if MIN_VERSION_base(4,12,0) -import Data.Functor.Contravariant -#endif -import Data.Functor.Identity - -import Control.Applicative -import Control.Monad -#if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail -#endif -import Control.Monad.Fix - --- --------------------------------------------------------------------------- --- | A state monad parameterized by the type @s@ of the state to carry. --- --- The 'return' function leaves the state unchanged, while @>>=@ uses --- the final state of the first computation as the initial state of --- the second. -type State s = StateT s Identity - --- | Construct a state monad computation from a function. --- (The inverse of 'runState'.) -state :: (Monad m) - => (s -> (a, s)) -- ^pure state transformer - -> StateT s m a -- ^equivalent state-passing computation -state f = StateT (return . f) -{-# INLINE state #-} - --- | Unwrap a state monad computation as a function. --- (The inverse of 'state'.) -runState :: State s a -- ^state-passing computation to execute - -> s -- ^initial state - -> (a, s) -- ^return value and final state -runState m = runIdentity . runStateT m -{-# INLINE runState #-} - --- | Evaluate a state computation with the given initial state --- and return the final value, discarding the final state. --- --- * @'evalState' m s = 'fst' ('runState' m s)@ -evalState :: State s a -- ^state-passing computation to execute - -> s -- ^initial value - -> a -- ^return value of the state computation -evalState m s = fst (runState m s) -{-# INLINE evalState #-} - --- | Evaluate a state computation with the given initial state --- and return the final state, discarding the final value. --- --- * @'execState' m s = 'snd' ('runState' m s)@ -execState :: State s a -- ^state-passing computation to execute - -> s -- ^initial value - -> s -- ^final state -execState m s = snd (runState m s) -{-# INLINE execState #-} - --- | Map both the return value and final state of a computation using --- the given function. --- --- * @'runState' ('mapState' f m) = f . 'runState' m@ -mapState :: ((a, s) -> (b, s)) -> State s a -> State s b -mapState f = mapStateT (Identity . f . runIdentity) -{-# INLINE mapState #-} - --- | @'withState' f m@ executes action @m@ on a state modified by --- applying @f@. --- --- * @'withState' f m = 'modify' f >> m@ -withState :: (s -> s) -> State s a -> State s a -withState = withStateT -{-# INLINE withState #-} - --- --------------------------------------------------------------------------- --- | A state transformer monad parameterized by: --- --- * @s@ - The state. --- --- * @m@ - The inner monad. --- --- The 'return' function leaves the state unchanged, while @>>=@ uses --- the final state of the first computation as the initial state of --- the second. -newtype StateT s m a = StateT { runStateT :: s -> m (a,s) } - --- | Evaluate a state computation with the given initial state --- and return the final value, discarding the final state. --- --- * @'evalStateT' m s = 'liftM' 'fst' ('runStateT' m s)@ -evalStateT :: (Monad m) => StateT s m a -> s -> m a -evalStateT m s = do - ~(a, _) <- runStateT m s - return a -{-# INLINE evalStateT #-} - --- | Evaluate a state computation with the given initial state --- and return the final state, discarding the final value. --- --- * @'execStateT' m s = 'liftM' 'snd' ('runStateT' m s)@ -execStateT :: (Monad m) => StateT s m a -> s -> m s -execStateT m s = do - ~(_, s') <- runStateT m s - return s' -{-# INLINE execStateT #-} - --- | Map both the return value and final state of a computation using --- the given function. --- --- * @'runStateT' ('mapStateT' f m) = f . 'runStateT' m@ -mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b -mapStateT f m = StateT $ f . runStateT m -{-# INLINE mapStateT #-} - --- | @'withStateT' f m@ executes action @m@ on a state modified by --- applying @f@. --- --- * @'withStateT' f m = 'modify' f >> m@ -withStateT :: (s -> s) -> StateT s m a -> StateT s m a -withStateT f m = StateT $ runStateT m . f -{-# INLINE withStateT #-} - -instance (Functor m) => Functor (StateT s m) where - fmap f m = StateT $ \ s -> - fmap (\ ~(a, s') -> (f a, s')) $ runStateT m s - {-# INLINE fmap #-} - -instance (Functor m, Monad m) => Applicative (StateT s m) where - pure a = StateT $ \ s -> return (a, s) - {-# INLINE pure #-} - StateT mf <*> StateT mx = StateT $ \ s -> do - ~(f, s') <- mf s - ~(x, s'') <- mx s' - return (f x, s'') - {-# INLINE (<*>) #-} - m *> k = m >>= \_ -> k - {-# INLINE (*>) #-} - -instance (Functor m, MonadPlus m) => Alternative (StateT s m) where - empty = StateT $ \ _ -> mzero - {-# INLINE empty #-} - StateT m <|> StateT n = StateT $ \ s -> m s `mplus` n s - {-# INLINE (<|>) #-} - -instance (Monad m) => Monad (StateT s m) where -#if !(MIN_VERSION_base(4,8,0)) - return a = StateT $ \ s -> return (a, s) - {-# INLINE return #-} -#endif - m >>= k = StateT $ \ s -> do - ~(a, s') <- runStateT m s - runStateT (k a) s' - {-# INLINE (>>=) #-} -#if !(MIN_VERSION_base(4,13,0)) - fail str = StateT $ \ _ -> fail str - {-# INLINE fail #-} -#endif - -#if MIN_VERSION_base(4,9,0) -instance (Fail.MonadFail m) => Fail.MonadFail (StateT s m) where - fail str = StateT $ \ _ -> Fail.fail str - {-# INLINE fail #-} -#endif - -instance (MonadPlus m) => MonadPlus (StateT s m) where - mzero = StateT $ \ _ -> mzero - {-# INLINE mzero #-} - StateT m `mplus` StateT n = StateT $ \ s -> m s `mplus` n s - {-# INLINE mplus #-} - -instance (MonadFix m) => MonadFix (StateT s m) where - mfix f = StateT $ \ s -> mfix $ \ ~(a, _) -> runStateT (f a) s - {-# INLINE mfix #-} - -instance MonadTrans (StateT s) where - lift m = StateT $ \ s -> do - a <- m - return (a, s) - {-# INLINE lift #-} - -instance (MonadIO m) => MonadIO (StateT s m) where - liftIO = lift . liftIO - {-# INLINE liftIO #-} - -#if MIN_VERSION_base(4,12,0) -instance Contravariant m => Contravariant (StateT s m) where - contramap f m = StateT $ \s -> - contramap (\ ~(a, s') -> (f a, s')) $ runStateT m s - {-# INLINE contramap #-} -#endif - --- | Fetch the current value of the state within the monad. -get :: (Monad m) => StateT s m s -get = state $ \ s -> (s, s) -{-# INLINE get #-} - --- | @'put' s@ sets the state within the monad to @s@. -put :: (Monad m) => s -> StateT s m () -put s = state $ \ _ -> ((), s) -{-# INLINE put #-} - --- | @'modify' f@ is an action that updates the state to the result of --- applying @f@ to the current state. --- --- * @'modify' f = 'get' >>= ('put' . f)@ -modify :: (Monad m) => (s -> s) -> StateT s m () -modify f = state $ \ s -> ((), f s) -{-# INLINE modify #-} - --- | A variant of 'modify' in which the computation is strict in the --- new state. --- --- * @'modify'' f = 'get' >>= (('$!') 'put' . f)@ -modify' :: (Monad m) => (s -> s) -> StateT s m () -modify' f = do - s <- get - put $! f s -{-# INLINE modify' #-} - --- | Get a specific component of the state, using a projection function --- supplied. --- --- * @'gets' f = 'liftM' f 'get'@ -gets :: (Monad m) => (s -> a) -> StateT s m a -gets f = state $ \ s -> (f s, s) -{-# INLINE gets #-} - --- | Uniform lifting of a @callCC@ operation to the new monad. --- This version rolls back to the original state on entering the --- continuation. -liftCallCC :: CallCC m (a,s) (b,s) -> CallCC (StateT s m) a b -liftCallCC callCC f = StateT $ \ s -> - callCC $ \ c -> - runStateT (f (\ a -> StateT $ \ _ -> c (a, s))) s -{-# INLINE liftCallCC #-} - --- | In-situ lifting of a @callCC@ operation to the new monad. --- This version uses the current state on entering the continuation. --- It does not satisfy the uniformity property (see "Control.Monad.Signatures"). -liftCallCC' :: CallCC m (a,s) (b,s) -> CallCC (StateT s m) a b -liftCallCC' callCC f = StateT $ \ s -> - callCC $ \ c -> - runStateT (f (\ a -> StateT $ \ s' -> c (a, s'))) s -{-# INLINE liftCallCC' #-} - --- | Lift a @catchE@ operation to the new monad. -liftCatch :: Catch e m (a,s) -> Catch e (StateT s m) a -liftCatch catchE m h = - StateT $ \ s -> runStateT m s `catchE` \ e -> runStateT (h e) s -{-# INLINE liftCatch #-} - --- | Lift a @listen@ operation to the new monad. -liftListen :: (Monad m) => Listen w m (a,s) -> Listen w (StateT s m) a -liftListen listen m = StateT $ \ s -> do - ~((a, s'), w) <- listen (runStateT m s) - return ((a, w), s') -{-# INLINE liftListen #-} - --- | Lift a @pass@ operation to the new monad. -liftPass :: (Monad m) => Pass w m (a,s) -> Pass w (StateT s m) a -liftPass pass m = StateT $ \ s -> pass $ do - ~((a, f), s') <- runStateT m s - return ((a, s'), f) -{-# INLINE liftPass #-} - -{- $examples - -Parser from ParseLib with Hugs: - -> type Parser a = StateT String [] a -> ==> StateT (String -> [(a,String)]) - -For example, item can be written as: - -> item = do (x:xs) <- get -> put xs -> return x -> -> type BoringState s a = StateT s Identity a -> ==> StateT (s -> Identity (a,s)) -> -> type StateWithIO s a = StateT s IO a -> ==> StateT (s -> IO (a,s)) -> -> type StateWithErr s a = StateT s Maybe a -> ==> StateT (s -> Maybe (a,s)) - --} - -{- $counting - -A function to increment a counter. -Taken from the paper \"Generalising Monads to Arrows\", -John Hughes (<http://www.cse.chalmers.se/~rjmh/>), November 1998: - -> tick :: State Int Int -> tick = do n <- get -> put (n+1) -> return n - -Add one to the given number using the state monad: - -> plusOne :: Int -> Int -> plusOne n = execState tick n - -A contrived addition example. Works only with positive numbers: - -> plus :: Int -> Int -> Int -> plus n x = execState (sequence $ replicate n tick) x - --} - -{- $labelling - -An example from /The Craft of Functional Programming/, Simon -Thompson (<http://www.cs.kent.ac.uk/people/staff/sjt/>), -Addison-Wesley 1999: \"Given an arbitrary tree, transform it to a -tree of integers in which the original elements are replaced by -natural numbers, starting from 0. The same element has to be -replaced by the same number at every occurrence, and when we meet -an as-yet-unvisited element we have to find a \'new\' number to match -it with:\" - -> data Tree a = Nil | Node a (Tree a) (Tree a) deriving (Show, Eq) -> type Table a = [a] - -> numberTree :: Eq a => Tree a -> State (Table a) (Tree Int) -> numberTree Nil = return Nil -> numberTree (Node x t1 t2) = do -> num <- numberNode x -> nt1 <- numberTree t1 -> nt2 <- numberTree t2 -> return (Node num nt1 nt2) -> where -> numberNode :: Eq a => a -> State (Table a) Int -> numberNode x = do -> table <- get -> case elemIndex x table of -> Nothing -> do -> put (table ++ [x]) -> return (length table) -> Just i -> return i - -numTree applies numberTree with an initial state: - -> numTree :: (Eq a) => Tree a -> Tree Int -> numTree t = evalState (numberTree t) [] - -> testTree = Node "Zero" (Node "One" (Node "Two" Nil Nil) (Node "One" (Node "Zero" Nil Nil) Nil)) Nil -> numTree testTree => Node 0 (Node 1 (Node 2 Nil Nil) (Node 1 (Node 0 Nil Nil) Nil)) Nil - --} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State/Strict.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State/Strict.hs deleted file mode 100644 index d0fb58edb4cf..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State/Strict.hs +++ /dev/null @@ -1,425 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE AutoDeriveTypeable #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Trans.State.Strict --- Copyright : (c) Andy Gill 2001, --- (c) Oregon Graduate Institute of Science and Technology, 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- Strict state monads, passing an updatable state through a computation. --- See below for examples. --- --- Some computations may not require the full power of state transformers: --- --- * For a read-only state, see "Control.Monad.Trans.Reader". --- --- * To accumulate a value without using it on the way, see --- "Control.Monad.Trans.Writer". --- --- In this version, sequencing of computations is strict (but computations --- are not strict in the state unless you force it with 'seq' or the like). --- For a lazy version with the same interface, see --- "Control.Monad.Trans.State.Lazy". ------------------------------------------------------------------------------ - -module Control.Monad.Trans.State.Strict ( - -- * The State monad - State, - state, - runState, - evalState, - execState, - mapState, - withState, - -- * The StateT monad transformer - StateT(..), - evalStateT, - execStateT, - mapStateT, - withStateT, - -- * State operations - get, - put, - modify, - modify', - gets, - -- * Lifting other operations - liftCallCC, - liftCallCC', - liftCatch, - liftListen, - liftPass, - -- * Examples - -- ** State monads - -- $examples - - -- ** Counting - -- $counting - - -- ** Labelling trees - -- $labelling - ) where - -import Control.Monad.IO.Class -import Control.Monad.Signatures -import Control.Monad.Trans.Class -#if MIN_VERSION_base(4,12,0) -import Data.Functor.Contravariant -#endif -import Data.Functor.Identity - -import Control.Applicative -import Control.Monad -#if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail -#endif -import Control.Monad.Fix - --- --------------------------------------------------------------------------- --- | A state monad parameterized by the type @s@ of the state to carry. --- --- The 'return' function leaves the state unchanged, while @>>=@ uses --- the final state of the first computation as the initial state of --- the second. -type State s = StateT s Identity - --- | Construct a state monad computation from a function. --- (The inverse of 'runState'.) -state :: (Monad m) - => (s -> (a, s)) -- ^pure state transformer - -> StateT s m a -- ^equivalent state-passing computation -state f = StateT (return . f) -{-# INLINE state #-} - --- | Unwrap a state monad computation as a function. --- (The inverse of 'state'.) -runState :: State s a -- ^state-passing computation to execute - -> s -- ^initial state - -> (a, s) -- ^return value and final state -runState m = runIdentity . runStateT m -{-# INLINE runState #-} - --- | Evaluate a state computation with the given initial state --- and return the final value, discarding the final state. --- --- * @'evalState' m s = 'fst' ('runState' m s)@ -evalState :: State s a -- ^state-passing computation to execute - -> s -- ^initial value - -> a -- ^return value of the state computation -evalState m s = fst (runState m s) -{-# INLINE evalState #-} - --- | Evaluate a state computation with the given initial state --- and return the final state, discarding the final value. --- --- * @'execState' m s = 'snd' ('runState' m s)@ -execState :: State s a -- ^state-passing computation to execute - -> s -- ^initial value - -> s -- ^final state -execState m s = snd (runState m s) -{-# INLINE execState #-} - --- | Map both the return value and final state of a computation using --- the given function. --- --- * @'runState' ('mapState' f m) = f . 'runState' m@ -mapState :: ((a, s) -> (b, s)) -> State s a -> State s b -mapState f = mapStateT (Identity . f . runIdentity) -{-# INLINE mapState #-} - --- | @'withState' f m@ executes action @m@ on a state modified by --- applying @f@. --- --- * @'withState' f m = 'modify' f >> m@ -withState :: (s -> s) -> State s a -> State s a -withState = withStateT -{-# INLINE withState #-} - --- --------------------------------------------------------------------------- --- | A state transformer monad parameterized by: --- --- * @s@ - The state. --- --- * @m@ - The inner monad. --- --- The 'return' function leaves the state unchanged, while @>>=@ uses --- the final state of the first computation as the initial state of --- the second. -newtype StateT s m a = StateT { runStateT :: s -> m (a,s) } - --- | Evaluate a state computation with the given initial state --- and return the final value, discarding the final state. --- --- * @'evalStateT' m s = 'liftM' 'fst' ('runStateT' m s)@ -evalStateT :: (Monad m) => StateT s m a -> s -> m a -evalStateT m s = do - (a, _) <- runStateT m s - return a -{-# INLINE evalStateT #-} - --- | Evaluate a state computation with the given initial state --- and return the final state, discarding the final value. --- --- * @'execStateT' m s = 'liftM' 'snd' ('runStateT' m s)@ -execStateT :: (Monad m) => StateT s m a -> s -> m s -execStateT m s = do - (_, s') <- runStateT m s - return s' -{-# INLINE execStateT #-} - --- | Map both the return value and final state of a computation using --- the given function. --- --- * @'runStateT' ('mapStateT' f m) = f . 'runStateT' m@ -mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b -mapStateT f m = StateT $ f . runStateT m -{-# INLINE mapStateT #-} - --- | @'withStateT' f m@ executes action @m@ on a state modified by --- applying @f@. --- --- * @'withStateT' f m = 'modify' f >> m@ -withStateT :: (s -> s) -> StateT s m a -> StateT s m a -withStateT f m = StateT $ runStateT m . f -{-# INLINE withStateT #-} - -instance (Functor m) => Functor (StateT s m) where - fmap f m = StateT $ \ s -> - fmap (\ (a, s') -> (f a, s')) $ runStateT m s - {-# INLINE fmap #-} - -instance (Functor m, Monad m) => Applicative (StateT s m) where - pure a = StateT $ \ s -> return (a, s) - {-# INLINE pure #-} - StateT mf <*> StateT mx = StateT $ \ s -> do - (f, s') <- mf s - (x, s'') <- mx s' - return (f x, s'') - {-# INLINE (<*>) #-} - m *> k = m >>= \_ -> k - {-# INLINE (*>) #-} - -instance (Functor m, MonadPlus m) => Alternative (StateT s m) where - empty = StateT $ \ _ -> mzero - {-# INLINE empty #-} - StateT m <|> StateT n = StateT $ \ s -> m s `mplus` n s - {-# INLINE (<|>) #-} - -instance (Monad m) => Monad (StateT s m) where -#if !(MIN_VERSION_base(4,8,0)) - return a = StateT $ \ s -> return (a, s) - {-# INLINE return #-} -#endif - m >>= k = StateT $ \ s -> do - (a, s') <- runStateT m s - runStateT (k a) s' - {-# INLINE (>>=) #-} -#if !(MIN_VERSION_base(4,13,0)) - fail str = StateT $ \ _ -> fail str - {-# INLINE fail #-} -#endif - -#if MIN_VERSION_base(4,9,0) -instance (Fail.MonadFail m) => Fail.MonadFail (StateT s m) where - fail str = StateT $ \ _ -> Fail.fail str - {-# INLINE fail #-} -#endif - -instance (MonadPlus m) => MonadPlus (StateT s m) where - mzero = StateT $ \ _ -> mzero - {-# INLINE mzero #-} - StateT m `mplus` StateT n = StateT $ \ s -> m s `mplus` n s - {-# INLINE mplus #-} - -instance (MonadFix m) => MonadFix (StateT s m) where - mfix f = StateT $ \ s -> mfix $ \ ~(a, _) -> runStateT (f a) s - {-# INLINE mfix #-} - -instance MonadTrans (StateT s) where - lift m = StateT $ \ s -> do - a <- m - return (a, s) - {-# INLINE lift #-} - -instance (MonadIO m) => MonadIO (StateT s m) where - liftIO = lift . liftIO - {-# INLINE liftIO #-} - -#if MIN_VERSION_base(4,12,0) -instance Contravariant m => Contravariant (StateT s m) where - contramap f m = StateT $ \s -> - contramap (\ (a, s') -> (f a, s')) $ runStateT m s - {-# INLINE contramap #-} -#endif - --- | Fetch the current value of the state within the monad. -get :: (Monad m) => StateT s m s -get = state $ \ s -> (s, s) -{-# INLINE get #-} - --- | @'put' s@ sets the state within the monad to @s@. -put :: (Monad m) => s -> StateT s m () -put s = state $ \ _ -> ((), s) -{-# INLINE put #-} - --- | @'modify' f@ is an action that updates the state to the result of --- applying @f@ to the current state. --- --- * @'modify' f = 'get' >>= ('put' . f)@ -modify :: (Monad m) => (s -> s) -> StateT s m () -modify f = state $ \ s -> ((), f s) -{-# INLINE modify #-} - --- | A variant of 'modify' in which the computation is strict in the --- new state. --- --- * @'modify'' f = 'get' >>= (('$!') 'put' . f)@ -modify' :: (Monad m) => (s -> s) -> StateT s m () -modify' f = do - s <- get - put $! f s -{-# INLINE modify' #-} - --- | Get a specific component of the state, using a projection function --- supplied. --- --- * @'gets' f = 'liftM' f 'get'@ -gets :: (Monad m) => (s -> a) -> StateT s m a -gets f = state $ \ s -> (f s, s) -{-# INLINE gets #-} - --- | Uniform lifting of a @callCC@ operation to the new monad. --- This version rolls back to the original state on entering the --- continuation. -liftCallCC :: CallCC m (a,s) (b,s) -> CallCC (StateT s m) a b -liftCallCC callCC f = StateT $ \ s -> - callCC $ \ c -> - runStateT (f (\ a -> StateT $ \ _ -> c (a, s))) s -{-# INLINE liftCallCC #-} - --- | In-situ lifting of a @callCC@ operation to the new monad. --- This version uses the current state on entering the continuation. --- It does not satisfy the uniformity property (see "Control.Monad.Signatures"). -liftCallCC' :: CallCC m (a,s) (b,s) -> CallCC (StateT s m) a b -liftCallCC' callCC f = StateT $ \ s -> - callCC $ \ c -> - runStateT (f (\ a -> StateT $ \ s' -> c (a, s'))) s -{-# INLINE liftCallCC' #-} - --- | Lift a @catchE@ operation to the new monad. -liftCatch :: Catch e m (a,s) -> Catch e (StateT s m) a -liftCatch catchE m h = - StateT $ \ s -> runStateT m s `catchE` \ e -> runStateT (h e) s -{-# INLINE liftCatch #-} - --- | Lift a @listen@ operation to the new monad. -liftListen :: (Monad m) => Listen w m (a,s) -> Listen w (StateT s m) a -liftListen listen m = StateT $ \ s -> do - ((a, s'), w) <- listen (runStateT m s) - return ((a, w), s') -{-# INLINE liftListen #-} - --- | Lift a @pass@ operation to the new monad. -liftPass :: (Monad m) => Pass w m (a,s) -> Pass w (StateT s m) a -liftPass pass m = StateT $ \ s -> pass $ do - ((a, f), s') <- runStateT m s - return ((a, s'), f) -{-# INLINE liftPass #-} - -{- $examples - -Parser from ParseLib with Hugs: - -> type Parser a = StateT String [] a -> ==> StateT (String -> [(a,String)]) - -For example, item can be written as: - -> item = do (x:xs) <- get -> put xs -> return x -> -> type BoringState s a = StateT s Identity a -> ==> StateT (s -> Identity (a,s)) -> -> type StateWithIO s a = StateT s IO a -> ==> StateT (s -> IO (a,s)) -> -> type StateWithErr s a = StateT s Maybe a -> ==> StateT (s -> Maybe (a,s)) - --} - -{- $counting - -A function to increment a counter. -Taken from the paper \"Generalising Monads to Arrows\", -John Hughes (<http://www.cse.chalmers.se/~rjmh/>), November 1998: - -> tick :: State Int Int -> tick = do n <- get -> put (n+1) -> return n - -Add one to the given number using the state monad: - -> plusOne :: Int -> Int -> plusOne n = execState tick n - -A contrived addition example. Works only with positive numbers: - -> plus :: Int -> Int -> Int -> plus n x = execState (sequence $ replicate n tick) x - --} - -{- $labelling - -An example from /The Craft of Functional Programming/, Simon -Thompson (<http://www.cs.kent.ac.uk/people/staff/sjt/>), -Addison-Wesley 1999: \"Given an arbitrary tree, transform it to a -tree of integers in which the original elements are replaced by -natural numbers, starting from 0. The same element has to be -replaced by the same number at every occurrence, and when we meet -an as-yet-unvisited element we have to find a \'new\' number to match -it with:\" - -> data Tree a = Nil | Node a (Tree a) (Tree a) deriving (Show, Eq) -> type Table a = [a] - -> numberTree :: Eq a => Tree a -> State (Table a) (Tree Int) -> numberTree Nil = return Nil -> numberTree (Node x t1 t2) = do -> num <- numberNode x -> nt1 <- numberTree t1 -> nt2 <- numberTree t2 -> return (Node num nt1 nt2) -> where -> numberNode :: Eq a => a -> State (Table a) Int -> numberNode x = do -> table <- get -> case elemIndex x table of -> Nothing -> do -> put (table ++ [x]) -> return (length table) -> Just i -> return i - -numTree applies numberTree with an initial state: - -> numTree :: (Eq a) => Tree a -> Tree Int -> numTree t = evalState (numberTree t) [] - -> testTree = Node "Zero" (Node "One" (Node "Two" Nil Nil) (Node "One" (Node "Zero" Nil Nil) Nil)) Nil -> numTree testTree => Node 0 (Node 1 (Node 2 Nil Nil) (Node 1 (Node 0 Nil Nil) Nil)) Nil - --} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer.hs deleted file mode 100644 index f45f4d27687c..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Trans.Writer --- Copyright : (c) Andy Gill 2001, --- (c) Oregon Graduate Institute of Science and Technology, 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- The WriterT monad transformer. --- This version builds its output lazily; for a constant-space version --- with almost the same interface, see "Control.Monad.Trans.Writer.CPS". ------------------------------------------------------------------------------ - -module Control.Monad.Trans.Writer ( - module Control.Monad.Trans.Writer.Lazy - ) where - -import Control.Monad.Trans.Writer.Lazy diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/CPS.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/CPS.hs deleted file mode 100644 index 28951016cf81..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/CPS.hs +++ /dev/null @@ -1,283 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE AutoDeriveTypeable #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Trans.Writer.CPS --- Copyright : (c) Daniel Mendler 2016, --- (c) Andy Gill 2001, --- (c) Oregon Graduate Institute of Science and Technology, 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- The strict 'WriterT' monad transformer, which adds collection of --- outputs (such as a count or string output) to a given monad. --- --- This monad transformer provides only limited access to the output --- during the computation. For more general access, use --- "Control.Monad.Trans.State" instead. --- --- This version builds its output strictly and uses continuation-passing-style --- to achieve constant space usage. This transformer can be used as a --- drop-in replacement for "Control.Monad.Trans.Writer.Strict". ------------------------------------------------------------------------------ - -module Control.Monad.Trans.Writer.CPS ( - -- * The Writer monad - Writer, - writer, - runWriter, - execWriter, - mapWriter, - -- * The WriterT monad transformer - WriterT, - writerT, - runWriterT, - execWriterT, - mapWriterT, - -- * Writer operations - tell, - listen, - listens, - pass, - censor, - -- * Lifting other operations - liftCallCC, - liftCatch, - ) where - -import Control.Applicative -import Control.Monad -import Control.Monad.Fix -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Signatures -import Data.Functor.Identity - -#if !(MIN_VERSION_base(4,8,0)) -import Data.Monoid -#endif - -#if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail -#endif - --- --------------------------------------------------------------------------- --- | A writer monad parameterized by the type @w@ of output to accumulate. --- --- The 'return' function produces the output 'mempty', while '>>=' --- combines the outputs of the subcomputations using 'mappend'. -type Writer w = WriterT w Identity - --- | Construct a writer computation from a (result, output) pair. --- (The inverse of 'runWriter'.) -writer :: (Monoid w, Monad m) => (a, w) -> WriterT w m a -writer (a, w') = WriterT $ \ w -> - let wt = w `mappend` w' in wt `seq` return (a, wt) -{-# INLINE writer #-} - --- | Unwrap a writer computation as a (result, output) pair. --- (The inverse of 'writer'.) -runWriter :: (Monoid w) => Writer w a -> (a, w) -runWriter = runIdentity . runWriterT -{-# INLINE runWriter #-} - --- | Extract the output from a writer computation. --- --- * @'execWriter' m = 'snd' ('runWriter' m)@ -execWriter :: (Monoid w) => Writer w a -> w -execWriter = runIdentity . execWriterT -{-# INLINE execWriter #-} - --- | Map both the return value and output of a computation using --- the given function. --- --- * @'runWriter' ('mapWriter' f m) = f ('runWriter' m)@ -mapWriter :: (Monoid w, Monoid w') => - ((a, w) -> (b, w')) -> Writer w a -> Writer w' b -mapWriter f = mapWriterT (Identity . f . runIdentity) -{-# INLINE mapWriter #-} - --- --------------------------------------------------------------------------- --- | A writer monad parameterized by: --- --- * @w@ - the output to accumulate. --- --- * @m@ - The inner monad. --- --- The 'return' function produces the output 'mempty', while '>>=' --- combines the outputs of the subcomputations using 'mappend'. - -newtype WriterT w m a = WriterT { unWriterT :: w -> m (a, w) } - --- | Construct a writer computation from a (result, output) computation. --- (The inverse of 'runWriterT'.) -writerT :: (Functor m, Monoid w) => m (a, w) -> WriterT w m a -writerT f = WriterT $ \ w -> - (\ (a, w') -> let wt = w `mappend` w' in wt `seq` (a, wt)) <$> f -{-# INLINE writerT #-} - --- | Unwrap a writer computation. --- (The inverse of 'writerT'.) -runWriterT :: (Monoid w) => WriterT w m a -> m (a, w) -runWriterT m = unWriterT m mempty -{-# INLINE runWriterT #-} - --- | Extract the output from a writer computation. --- --- * @'execWriterT' m = 'liftM' 'snd' ('runWriterT' m)@ -execWriterT :: (Monad m, Monoid w) => WriterT w m a -> m w -execWriterT m = do - (_, w) <- runWriterT m - return w -{-# INLINE execWriterT #-} - --- | Map both the return value and output of a computation using --- the given function. --- --- * @'runWriterT' ('mapWriterT' f m) = f ('runWriterT' m)@ -mapWriterT :: (Monad n, Monoid w, Monoid w') => - (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b -mapWriterT f m = WriterT $ \ w -> do - (a, w') <- f (runWriterT m) - let wt = w `mappend` w' - wt `seq` return (a, wt) -{-# INLINE mapWriterT #-} - -instance (Functor m) => Functor (WriterT w m) where - fmap f m = WriterT $ \ w -> (\ (a, w') -> (f a, w')) <$> unWriterT m w - {-# INLINE fmap #-} - -instance (Functor m, Monad m) => Applicative (WriterT w m) where - pure a = WriterT $ \ w -> return (a, w) - {-# INLINE pure #-} - - WriterT mf <*> WriterT mx = WriterT $ \ w -> do - (f, w') <- mf w - (x, w'') <- mx w' - return (f x, w'') - {-# INLINE (<*>) #-} - -instance (Functor m, MonadPlus m) => Alternative (WriterT w m) where - empty = WriterT $ const mzero - {-# INLINE empty #-} - - WriterT m <|> WriterT n = WriterT $ \ w -> m w `mplus` n w - {-# INLINE (<|>) #-} - -instance (Monad m) => Monad (WriterT w m) where -#if !(MIN_VERSION_base(4,8,0)) - return a = WriterT $ \ w -> return (a, w) - {-# INLINE return #-} -#endif - - m >>= k = WriterT $ \ w -> do - (a, w') <- unWriterT m w - unWriterT (k a) w' - {-# INLINE (>>=) #-} - -#if !(MIN_VERSION_base(4,13,0)) - fail msg = WriterT $ \ _ -> fail msg - {-# INLINE fail #-} -#endif - -#if MIN_VERSION_base(4,9,0) -instance (Fail.MonadFail m) => Fail.MonadFail (WriterT w m) where - fail msg = WriterT $ \ _ -> Fail.fail msg - {-# INLINE fail #-} -#endif - -instance (Functor m, MonadPlus m) => MonadPlus (WriterT w m) where - mzero = empty - {-# INLINE mzero #-} - mplus = (<|>) - {-# INLINE mplus #-} - -instance (MonadFix m) => MonadFix (WriterT w m) where - mfix f = WriterT $ \ w -> mfix $ \ ~(a, _) -> unWriterT (f a) w - {-# INLINE mfix #-} - -instance MonadTrans (WriterT w) where - lift m = WriterT $ \ w -> do - a <- m - return (a, w) - {-# INLINE lift #-} - -instance (MonadIO m) => MonadIO (WriterT w m) where - liftIO = lift . liftIO - {-# INLINE liftIO #-} - --- | @'tell' w@ is an action that produces the output @w@. -tell :: (Monoid w, Monad m) => w -> WriterT w m () -tell w = writer ((), w) -{-# INLINE tell #-} - --- | @'listen' m@ is an action that executes the action @m@ and adds its --- output to the value of the computation. --- --- * @'runWriterT' ('listen' m) = 'liftM' (\\ (a, w) -> ((a, w), w)) ('runWriterT' m)@ -listen :: (Monoid w, Monad m) => WriterT w m a -> WriterT w m (a, w) -listen = listens id -{-# INLINE listen #-} - --- | @'listens' f m@ is an action that executes the action @m@ and adds --- the result of applying @f@ to the output to the value of the computation. --- --- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@ --- --- * @'runWriterT' ('listens' f m) = 'liftM' (\\ (a, w) -> ((a, f w), w)) ('runWriterT' m)@ -listens :: (Monoid w, Monad m) => - (w -> b) -> WriterT w m a -> WriterT w m (a, b) -listens f m = WriterT $ \ w -> do - (a, w') <- runWriterT m - let wt = w `mappend` w' - wt `seq` return ((a, f w'), wt) -{-# INLINE listens #-} - --- | @'pass' m@ is an action that executes the action @m@, which returns --- a value and a function, and returns the value, applying the function --- to the output. --- --- * @'runWriterT' ('pass' m) = 'liftM' (\\ ((a, f), w) -> (a, f w)) ('runWriterT' m)@ -pass :: (Monoid w, Monoid w', Monad m) => - WriterT w m (a, w -> w') -> WriterT w' m a -pass m = WriterT $ \ w -> do - ((a, f), w') <- runWriterT m - let wt = w `mappend` f w' - wt `seq` return (a, wt) -{-# INLINE pass #-} - --- | @'censor' f m@ is an action that executes the action @m@ and --- applies the function @f@ to its output, leaving the return value --- unchanged. --- --- * @'censor' f m = 'pass' ('liftM' (\\ x -> (x,f)) m)@ --- --- * @'runWriterT' ('censor' f m) = 'liftM' (\\ (a, w) -> (a, f w)) ('runWriterT' m)@ -censor :: (Monoid w, Monad m) => (w -> w) -> WriterT w m a -> WriterT w m a -censor f m = WriterT $ \ w -> do - (a, w') <- runWriterT m - let wt = w `mappend` f w' - wt `seq` return (a, wt) -{-# INLINE censor #-} - --- | Uniform lifting of a @callCC@ operation to the new monad. --- This version rolls back to the original state on entering the --- continuation. -liftCallCC :: CallCC m (a, w) (b, w) -> CallCC (WriterT w m) a b -liftCallCC callCC f = WriterT $ \ w -> - callCC $ \ c -> unWriterT (f (\ a -> WriterT $ \ _ -> c (a, w))) w -{-# INLINE liftCallCC #-} - --- | Lift a @catchE@ operation to the new monad. -liftCatch :: Catch e m (a, w) -> Catch e (WriterT w m) a -liftCatch catchE m h = WriterT $ \ w -> - unWriterT m w `catchE` \ e -> unWriterT (h e) w -{-# INLINE liftCatch #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/Lazy.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/Lazy.hs deleted file mode 100644 index d12b0e7d583c..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/Lazy.hs +++ /dev/null @@ -1,313 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE AutoDeriveTypeable #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Trans.Writer.Lazy --- Copyright : (c) Andy Gill 2001, --- (c) Oregon Graduate Institute of Science and Technology, 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- The lazy 'WriterT' monad transformer, which adds collection of --- outputs (such as a count or string output) to a given monad. --- --- This monad transformer provides only limited access to the output --- during the computation. For more general access, use --- "Control.Monad.Trans.State" instead. --- --- This version builds its output lazily; for a constant-space version --- with almost the same interface, see "Control.Monad.Trans.Writer.CPS". ------------------------------------------------------------------------------ - -module Control.Monad.Trans.Writer.Lazy ( - -- * The Writer monad - Writer, - writer, - runWriter, - execWriter, - mapWriter, - -- * The WriterT monad transformer - WriterT(..), - execWriterT, - mapWriterT, - -- * Writer operations - tell, - listen, - listens, - pass, - censor, - -- * Lifting other operations - liftCallCC, - liftCatch, - ) where - -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Data.Functor.Classes -#if MIN_VERSION_base(4,12,0) -import Data.Functor.Contravariant -#endif -import Data.Functor.Identity - -import Control.Applicative -import Control.Monad -#if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail -#endif -import Control.Monad.Fix -import Control.Monad.Signatures -#if MIN_VERSION_base(4,4,0) -import Control.Monad.Zip (MonadZip(mzipWith)) -#endif -import Data.Foldable -import Data.Monoid -import Data.Traversable (Traversable(traverse)) -import Prelude hiding (null, length) - --- --------------------------------------------------------------------------- --- | A writer monad parameterized by the type @w@ of output to accumulate. --- --- The 'return' function produces the output 'mempty', while @>>=@ --- combines the outputs of the subcomputations using 'mappend'. -type Writer w = WriterT w Identity - --- | Construct a writer computation from a (result, output) pair. --- (The inverse of 'runWriter'.) -writer :: (Monad m) => (a, w) -> WriterT w m a -writer = WriterT . return -{-# INLINE writer #-} - --- | Unwrap a writer computation as a (result, output) pair. --- (The inverse of 'writer'.) -runWriter :: Writer w a -> (a, w) -runWriter = runIdentity . runWriterT -{-# INLINE runWriter #-} - --- | Extract the output from a writer computation. --- --- * @'execWriter' m = 'snd' ('runWriter' m)@ -execWriter :: Writer w a -> w -execWriter m = snd (runWriter m) -{-# INLINE execWriter #-} - --- | Map both the return value and output of a computation using --- the given function. --- --- * @'runWriter' ('mapWriter' f m) = f ('runWriter' m)@ -mapWriter :: ((a, w) -> (b, w')) -> Writer w a -> Writer w' b -mapWriter f = mapWriterT (Identity . f . runIdentity) -{-# INLINE mapWriter #-} - --- --------------------------------------------------------------------------- --- | A writer monad parameterized by: --- --- * @w@ - the output to accumulate. --- --- * @m@ - The inner monad. --- --- The 'return' function produces the output 'mempty', while @>>=@ --- combines the outputs of the subcomputations using 'mappend'. -newtype WriterT w m a = WriterT { runWriterT :: m (a, w) } - -instance (Eq w, Eq1 m) => Eq1 (WriterT w m) where - liftEq eq (WriterT m1) (WriterT m2) = liftEq (liftEq2 eq (==)) m1 m2 - {-# INLINE liftEq #-} - -instance (Ord w, Ord1 m) => Ord1 (WriterT w m) where - liftCompare comp (WriterT m1) (WriterT m2) = - liftCompare (liftCompare2 comp compare) m1 m2 - {-# INLINE liftCompare #-} - -instance (Read w, Read1 m) => Read1 (WriterT w m) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "WriterT" WriterT - where - rp' = liftReadsPrec2 rp rl readsPrec readList - rl' = liftReadList2 rp rl readsPrec readList - -instance (Show w, Show1 m) => Show1 (WriterT w m) where - liftShowsPrec sp sl d (WriterT m) = - showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d m - where - sp' = liftShowsPrec2 sp sl showsPrec showList - sl' = liftShowList2 sp sl showsPrec showList - -instance (Eq w, Eq1 m, Eq a) => Eq (WriterT w m a) where (==) = eq1 -instance (Ord w, Ord1 m, Ord a) => Ord (WriterT w m a) where compare = compare1 -instance (Read w, Read1 m, Read a) => Read (WriterT w m a) where - readsPrec = readsPrec1 -instance (Show w, Show1 m, Show a) => Show (WriterT w m a) where - showsPrec = showsPrec1 - --- | Extract the output from a writer computation. --- --- * @'execWriterT' m = 'liftM' 'snd' ('runWriterT' m)@ -execWriterT :: (Monad m) => WriterT w m a -> m w -execWriterT m = do - ~(_, w) <- runWriterT m - return w -{-# INLINE execWriterT #-} - --- | Map both the return value and output of a computation using --- the given function. --- --- * @'runWriterT' ('mapWriterT' f m) = f ('runWriterT' m)@ -mapWriterT :: (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b -mapWriterT f m = WriterT $ f (runWriterT m) -{-# INLINE mapWriterT #-} - -instance (Functor m) => Functor (WriterT w m) where - fmap f = mapWriterT $ fmap $ \ ~(a, w) -> (f a, w) - {-# INLINE fmap #-} - -instance (Foldable f) => Foldable (WriterT w f) where - foldMap f = foldMap (f . fst) . runWriterT - {-# INLINE foldMap #-} -#if MIN_VERSION_base(4,8,0) - null (WriterT t) = null t - length (WriterT t) = length t -#endif - -instance (Traversable f) => Traversable (WriterT w f) where - traverse f = fmap WriterT . traverse f' . runWriterT where - f' (a, b) = fmap (\ c -> (c, b)) (f a) - {-# INLINE traverse #-} - -instance (Monoid w, Applicative m) => Applicative (WriterT w m) where - pure a = WriterT $ pure (a, mempty) - {-# INLINE pure #-} - f <*> v = WriterT $ liftA2 k (runWriterT f) (runWriterT v) - where k ~(a, w) ~(b, w') = (a b, w `mappend` w') - {-# INLINE (<*>) #-} - -instance (Monoid w, Alternative m) => Alternative (WriterT w m) where - empty = WriterT empty - {-# INLINE empty #-} - m <|> n = WriterT $ runWriterT m <|> runWriterT n - {-# INLINE (<|>) #-} - -instance (Monoid w, Monad m) => Monad (WriterT w m) where -#if !(MIN_VERSION_base(4,8,0)) - return a = writer (a, mempty) - {-# INLINE return #-} -#endif - m >>= k = WriterT $ do - ~(a, w) <- runWriterT m - ~(b, w') <- runWriterT (k a) - return (b, w `mappend` w') - {-# INLINE (>>=) #-} -#if !(MIN_VERSION_base(4,13,0)) - fail msg = WriterT $ fail msg - {-# INLINE fail #-} -#endif - -#if MIN_VERSION_base(4,9,0) -instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (WriterT w m) where - fail msg = WriterT $ Fail.fail msg - {-# INLINE fail #-} -#endif - -instance (Monoid w, MonadPlus m) => MonadPlus (WriterT w m) where - mzero = WriterT mzero - {-# INLINE mzero #-} - m `mplus` n = WriterT $ runWriterT m `mplus` runWriterT n - {-# INLINE mplus #-} - -instance (Monoid w, MonadFix m) => MonadFix (WriterT w m) where - mfix m = WriterT $ mfix $ \ ~(a, _) -> runWriterT (m a) - {-# INLINE mfix #-} - -instance (Monoid w) => MonadTrans (WriterT w) where - lift m = WriterT $ do - a <- m - return (a, mempty) - {-# INLINE lift #-} - -instance (Monoid w, MonadIO m) => MonadIO (WriterT w m) where - liftIO = lift . liftIO - {-# INLINE liftIO #-} - -#if MIN_VERSION_base(4,4,0) -instance (Monoid w, MonadZip m) => MonadZip (WriterT w m) where - mzipWith f (WriterT x) (WriterT y) = WriterT $ - mzipWith (\ ~(a, w) ~(b, w') -> (f a b, w `mappend` w')) x y - {-# INLINE mzipWith #-} -#endif - -#if MIN_VERSION_base(4,12,0) -instance Contravariant m => Contravariant (WriterT w m) where - contramap f = mapWriterT $ contramap $ \ ~(a, w) -> (f a, w) - {-# INLINE contramap #-} -#endif - --- | @'tell' w@ is an action that produces the output @w@. -tell :: (Monad m) => w -> WriterT w m () -tell w = writer ((), w) -{-# INLINE tell #-} - --- | @'listen' m@ is an action that executes the action @m@ and adds its --- output to the value of the computation. --- --- * @'runWriterT' ('listen' m) = 'liftM' (\\ (a, w) -> ((a, w), w)) ('runWriterT' m)@ -listen :: (Monad m) => WriterT w m a -> WriterT w m (a, w) -listen m = WriterT $ do - ~(a, w) <- runWriterT m - return ((a, w), w) -{-# INLINE listen #-} - --- | @'listens' f m@ is an action that executes the action @m@ and adds --- the result of applying @f@ to the output to the value of the computation. --- --- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@ --- --- * @'runWriterT' ('listens' f m) = 'liftM' (\\ (a, w) -> ((a, f w), w)) ('runWriterT' m)@ -listens :: (Monad m) => (w -> b) -> WriterT w m a -> WriterT w m (a, b) -listens f m = WriterT $ do - ~(a, w) <- runWriterT m - return ((a, f w), w) -{-# INLINE listens #-} - --- | @'pass' m@ is an action that executes the action @m@, which returns --- a value and a function, and returns the value, applying the function --- to the output. --- --- * @'runWriterT' ('pass' m) = 'liftM' (\\ ((a, f), w) -> (a, f w)) ('runWriterT' m)@ -pass :: (Monad m) => WriterT w m (a, w -> w) -> WriterT w m a -pass m = WriterT $ do - ~((a, f), w) <- runWriterT m - return (a, f w) -{-# INLINE pass #-} - --- | @'censor' f m@ is an action that executes the action @m@ and --- applies the function @f@ to its output, leaving the return value --- unchanged. --- --- * @'censor' f m = 'pass' ('liftM' (\\ x -> (x,f)) m)@ --- --- * @'runWriterT' ('censor' f m) = 'liftM' (\\ (a, w) -> (a, f w)) ('runWriterT' m)@ -censor :: (Monad m) => (w -> w) -> WriterT w m a -> WriterT w m a -censor f m = WriterT $ do - ~(a, w) <- runWriterT m - return (a, f w) -{-# INLINE censor #-} - --- | Lift a @callCC@ operation to the new monad. -liftCallCC :: (Monoid w) => CallCC m (a,w) (b,w) -> CallCC (WriterT w m) a b -liftCallCC callCC f = WriterT $ - callCC $ \ c -> - runWriterT (f (\ a -> WriterT $ c (a, mempty))) -{-# INLINE liftCallCC #-} - --- | Lift a @catchE@ operation to the new monad. -liftCatch :: Catch e m (a,w) -> Catch e (WriterT w m) a -liftCatch catchE m h = - WriterT $ runWriterT m `catchE` \ e -> runWriterT (h e) -{-# INLINE liftCatch #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/Strict.hs b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/Strict.hs deleted file mode 100644 index f39862c02044..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/Strict.hs +++ /dev/null @@ -1,316 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE AutoDeriveTypeable #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Trans.Writer.Strict --- Copyright : (c) Andy Gill 2001, --- (c) Oregon Graduate Institute of Science and Technology, 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- The strict 'WriterT' monad transformer, which adds collection of --- outputs (such as a count or string output) to a given monad. --- --- This monad transformer provides only limited access to the output --- during the computation. For more general access, use --- "Control.Monad.Trans.State" instead. --- --- This version builds its output strictly; for a lazy version with --- the same interface, see "Control.Monad.Trans.Writer.Lazy". --- Although the output is built strictly, it is not possible to --- achieve constant space behaviour with this transformer: for that, --- use "Control.Monad.Trans.Writer.CPS" instead. ------------------------------------------------------------------------------ - -module Control.Monad.Trans.Writer.Strict ( - -- * The Writer monad - Writer, - writer, - runWriter, - execWriter, - mapWriter, - -- * The WriterT monad transformer - WriterT(..), - execWriterT, - mapWriterT, - -- * Writer operations - tell, - listen, - listens, - pass, - censor, - -- * Lifting other operations - liftCallCC, - liftCatch, - ) where - -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Data.Functor.Classes -#if MIN_VERSION_base(4,12,0) -import Data.Functor.Contravariant -#endif -import Data.Functor.Identity - -import Control.Applicative -import Control.Monad -#if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail -#endif -import Control.Monad.Fix -import Control.Monad.Signatures -#if MIN_VERSION_base(4,4,0) -import Control.Monad.Zip (MonadZip(mzipWith)) -#endif -import Data.Foldable -import Data.Monoid -import Data.Traversable (Traversable(traverse)) -import Prelude hiding (null, length) - --- --------------------------------------------------------------------------- --- | A writer monad parameterized by the type @w@ of output to accumulate. --- --- The 'return' function produces the output 'mempty', while @>>=@ --- combines the outputs of the subcomputations using 'mappend'. -type Writer w = WriterT w Identity - --- | Construct a writer computation from a (result, output) pair. --- (The inverse of 'runWriter'.) -writer :: (Monad m) => (a, w) -> WriterT w m a -writer = WriterT . return -{-# INLINE writer #-} - --- | Unwrap a writer computation as a (result, output) pair. --- (The inverse of 'writer'.) -runWriter :: Writer w a -> (a, w) -runWriter = runIdentity . runWriterT -{-# INLINE runWriter #-} - --- | Extract the output from a writer computation. --- --- * @'execWriter' m = 'snd' ('runWriter' m)@ -execWriter :: Writer w a -> w -execWriter m = snd (runWriter m) -{-# INLINE execWriter #-} - --- | Map both the return value and output of a computation using --- the given function. --- --- * @'runWriter' ('mapWriter' f m) = f ('runWriter' m)@ -mapWriter :: ((a, w) -> (b, w')) -> Writer w a -> Writer w' b -mapWriter f = mapWriterT (Identity . f . runIdentity) -{-# INLINE mapWriter #-} - --- --------------------------------------------------------------------------- --- | A writer monad parameterized by: --- --- * @w@ - the output to accumulate. --- --- * @m@ - The inner monad. --- --- The 'return' function produces the output 'mempty', while @>>=@ --- combines the outputs of the subcomputations using 'mappend'. -newtype WriterT w m a = WriterT { runWriterT :: m (a, w) } - -instance (Eq w, Eq1 m) => Eq1 (WriterT w m) where - liftEq eq (WriterT m1) (WriterT m2) = liftEq (liftEq2 eq (==)) m1 m2 - {-# INLINE liftEq #-} - -instance (Ord w, Ord1 m) => Ord1 (WriterT w m) where - liftCompare comp (WriterT m1) (WriterT m2) = - liftCompare (liftCompare2 comp compare) m1 m2 - {-# INLINE liftCompare #-} - -instance (Read w, Read1 m) => Read1 (WriterT w m) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "WriterT" WriterT - where - rp' = liftReadsPrec2 rp rl readsPrec readList - rl' = liftReadList2 rp rl readsPrec readList - -instance (Show w, Show1 m) => Show1 (WriterT w m) where - liftShowsPrec sp sl d (WriterT m) = - showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d m - where - sp' = liftShowsPrec2 sp sl showsPrec showList - sl' = liftShowList2 sp sl showsPrec showList - -instance (Eq w, Eq1 m, Eq a) => Eq (WriterT w m a) where (==) = eq1 -instance (Ord w, Ord1 m, Ord a) => Ord (WriterT w m a) where compare = compare1 -instance (Read w, Read1 m, Read a) => Read (WriterT w m a) where - readsPrec = readsPrec1 -instance (Show w, Show1 m, Show a) => Show (WriterT w m a) where - showsPrec = showsPrec1 - --- | Extract the output from a writer computation. --- --- * @'execWriterT' m = 'liftM' 'snd' ('runWriterT' m)@ -execWriterT :: (Monad m) => WriterT w m a -> m w -execWriterT m = do - (_, w) <- runWriterT m - return w -{-# INLINE execWriterT #-} - --- | Map both the return value and output of a computation using --- the given function. --- --- * @'runWriterT' ('mapWriterT' f m) = f ('runWriterT' m)@ -mapWriterT :: (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b -mapWriterT f m = WriterT $ f (runWriterT m) -{-# INLINE mapWriterT #-} - -instance (Functor m) => Functor (WriterT w m) where - fmap f = mapWriterT $ fmap $ \ (a, w) -> (f a, w) - {-# INLINE fmap #-} - -instance (Foldable f) => Foldable (WriterT w f) where - foldMap f = foldMap (f . fst) . runWriterT - {-# INLINE foldMap #-} -#if MIN_VERSION_base(4,8,0) - null (WriterT t) = null t - length (WriterT t) = length t -#endif - -instance (Traversable f) => Traversable (WriterT w f) where - traverse f = fmap WriterT . traverse f' . runWriterT where - f' (a, b) = fmap (\ c -> (c, b)) (f a) - {-# INLINE traverse #-} - -instance (Monoid w, Applicative m) => Applicative (WriterT w m) where - pure a = WriterT $ pure (a, mempty) - {-# INLINE pure #-} - f <*> v = WriterT $ liftA2 k (runWriterT f) (runWriterT v) - where k (a, w) (b, w') = (a b, w `mappend` w') - {-# INLINE (<*>) #-} - -instance (Monoid w, Alternative m) => Alternative (WriterT w m) where - empty = WriterT empty - {-# INLINE empty #-} - m <|> n = WriterT $ runWriterT m <|> runWriterT n - {-# INLINE (<|>) #-} - -instance (Monoid w, Monad m) => Monad (WriterT w m) where -#if !(MIN_VERSION_base(4,8,0)) - return a = writer (a, mempty) - {-# INLINE return #-} -#endif - m >>= k = WriterT $ do - (a, w) <- runWriterT m - (b, w') <- runWriterT (k a) - return (b, w `mappend` w') - {-# INLINE (>>=) #-} -#if !(MIN_VERSION_base(4,13,0)) - fail msg = WriterT $ fail msg - {-# INLINE fail #-} -#endif - -#if MIN_VERSION_base(4,9,0) -instance (Monoid w, Fail.MonadFail m) => Fail.MonadFail (WriterT w m) where - fail msg = WriterT $ Fail.fail msg - {-# INLINE fail #-} -#endif - -instance (Monoid w, MonadPlus m) => MonadPlus (WriterT w m) where - mzero = WriterT mzero - {-# INLINE mzero #-} - m `mplus` n = WriterT $ runWriterT m `mplus` runWriterT n - {-# INLINE mplus #-} - -instance (Monoid w, MonadFix m) => MonadFix (WriterT w m) where - mfix m = WriterT $ mfix $ \ ~(a, _) -> runWriterT (m a) - {-# INLINE mfix #-} - -instance (Monoid w) => MonadTrans (WriterT w) where - lift m = WriterT $ do - a <- m - return (a, mempty) - {-# INLINE lift #-} - -instance (Monoid w, MonadIO m) => MonadIO (WriterT w m) where - liftIO = lift . liftIO - {-# INLINE liftIO #-} - -#if MIN_VERSION_base(4,4,0) -instance (Monoid w, MonadZip m) => MonadZip (WriterT w m) where - mzipWith f (WriterT x) (WriterT y) = WriterT $ - mzipWith (\ (a, w) (b, w') -> (f a b, w `mappend` w')) x y - {-# INLINE mzipWith #-} -#endif - -#if MIN_VERSION_base(4,12,0) -instance Contravariant m => Contravariant (WriterT w m) where - contramap f = mapWriterT $ contramap $ \ (a, w) -> (f a, w) - {-# INLINE contramap #-} -#endif - --- | @'tell' w@ is an action that produces the output @w@. -tell :: (Monad m) => w -> WriterT w m () -tell w = writer ((), w) -{-# INLINE tell #-} - --- | @'listen' m@ is an action that executes the action @m@ and adds its --- output to the value of the computation. --- --- * @'runWriterT' ('listen' m) = 'liftM' (\\ (a, w) -> ((a, w), w)) ('runWriterT' m)@ -listen :: (Monad m) => WriterT w m a -> WriterT w m (a, w) -listen m = WriterT $ do - (a, w) <- runWriterT m - return ((a, w), w) -{-# INLINE listen #-} - --- | @'listens' f m@ is an action that executes the action @m@ and adds --- the result of applying @f@ to the output to the value of the computation. --- --- * @'listens' f m = 'liftM' (id *** f) ('listen' m)@ --- --- * @'runWriterT' ('listens' f m) = 'liftM' (\\ (a, w) -> ((a, f w), w)) ('runWriterT' m)@ -listens :: (Monad m) => (w -> b) -> WriterT w m a -> WriterT w m (a, b) -listens f m = WriterT $ do - (a, w) <- runWriterT m - return ((a, f w), w) -{-# INLINE listens #-} - --- | @'pass' m@ is an action that executes the action @m@, which returns --- a value and a function, and returns the value, applying the function --- to the output. --- --- * @'runWriterT' ('pass' m) = 'liftM' (\\ ((a, f), w) -> (a, f w)) ('runWriterT' m)@ -pass :: (Monad m) => WriterT w m (a, w -> w) -> WriterT w m a -pass m = WriterT $ do - ((a, f), w) <- runWriterT m - return (a, f w) -{-# INLINE pass #-} - --- | @'censor' f m@ is an action that executes the action @m@ and --- applies the function @f@ to its output, leaving the return value --- unchanged. --- --- * @'censor' f m = 'pass' ('liftM' (\\ x -> (x,f)) m)@ --- --- * @'runWriterT' ('censor' f m) = 'liftM' (\\ (a, w) -> (a, f w)) ('runWriterT' m)@ -censor :: (Monad m) => (w -> w) -> WriterT w m a -> WriterT w m a -censor f m = WriterT $ do - (a, w) <- runWriterT m - return (a, f w) -{-# INLINE censor #-} - --- | Lift a @callCC@ operation to the new monad. -liftCallCC :: (Monoid w) => CallCC m (a,w) (b,w) -> CallCC (WriterT w m) a b -liftCallCC callCC f = WriterT $ - callCC $ \ c -> - runWriterT (f (\ a -> WriterT $ c (a, mempty))) -{-# INLINE liftCallCC #-} - --- | Lift a @catchE@ operation to the new monad. -liftCatch :: Catch e m (a,w) -> Catch e (WriterT w m) a -liftCatch catchE m h = - WriterT $ runWriterT m `catchE` \ e -> runWriterT (h e) -{-# INLINE liftCatch #-} diff --git a/third_party/bazel/rules_haskell/examples/transformers/Data/Functor/Constant.hs b/third_party/bazel/rules_haskell/examples/transformers/Data/Functor/Constant.hs deleted file mode 100644 index 9c0b8d42dcad..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Data/Functor/Constant.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -#endif -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE AutoDeriveTypeable #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Data.Functor.Constant --- Copyright : (c) Ross Paterson 2010 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- The constant functor. ------------------------------------------------------------------------------ - -module Data.Functor.Constant ( - Constant(..), - ) where - -import Data.Functor.Classes -#if MIN_VERSION_base(4,12,0) -import Data.Functor.Contravariant -#endif - -import Control.Applicative -import Data.Foldable -import Data.Monoid (Monoid(..)) -import Data.Traversable (Traversable(traverse)) -#if MIN_VERSION_base(4,8,0) -import Data.Bifunctor (Bifunctor(..)) -#endif -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup(..)) -#endif -#if MIN_VERSION_base(4,10,0) -import Data.Bifoldable (Bifoldable(..)) -import Data.Bitraversable (Bitraversable(..)) -#endif -import Prelude hiding (null, length) - --- | Constant functor. -newtype Constant a b = Constant { getConstant :: a } - deriving (Eq, Ord) - --- These instances would be equivalent to the derived instances of the --- newtype if the field were removed. - -instance (Read a) => Read (Constant a b) where - readsPrec = readsData $ - readsUnaryWith readsPrec "Constant" Constant - -instance (Show a) => Show (Constant a b) where - showsPrec d (Constant x) = showsUnaryWith showsPrec "Constant" d x - --- Instances of lifted Prelude classes - -instance Eq2 Constant where - liftEq2 eq _ (Constant x) (Constant y) = eq x y - {-# INLINE liftEq2 #-} - -instance Ord2 Constant where - liftCompare2 comp _ (Constant x) (Constant y) = comp x y - {-# INLINE liftCompare2 #-} - -instance Read2 Constant where - liftReadsPrec2 rp _ _ _ = readsData $ - readsUnaryWith rp "Constant" Constant - -instance Show2 Constant where - liftShowsPrec2 sp _ _ _ d (Constant x) = showsUnaryWith sp "Constant" d x - -instance (Eq a) => Eq1 (Constant a) where - liftEq = liftEq2 (==) - {-# INLINE liftEq #-} -instance (Ord a) => Ord1 (Constant a) where - liftCompare = liftCompare2 compare - {-# INLINE liftCompare #-} -instance (Read a) => Read1 (Constant a) where - liftReadsPrec = liftReadsPrec2 readsPrec readList - {-# INLINE liftReadsPrec #-} -instance (Show a) => Show1 (Constant a) where - liftShowsPrec = liftShowsPrec2 showsPrec showList - {-# INLINE liftShowsPrec #-} - -instance Functor (Constant a) where - fmap _ (Constant x) = Constant x - {-# INLINE fmap #-} - -instance Foldable (Constant a) where - foldMap _ (Constant _) = mempty - {-# INLINE foldMap #-} -#if MIN_VERSION_base(4,8,0) - null (Constant _) = True - length (Constant _) = 0 -#endif - -instance Traversable (Constant a) where - traverse _ (Constant x) = pure (Constant x) - {-# INLINE traverse #-} - -#if MIN_VERSION_base(4,9,0) -instance (Semigroup a) => Semigroup (Constant a b) where - Constant x <> Constant y = Constant (x <> y) - {-# INLINE (<>) #-} -#endif - -instance (Monoid a) => Applicative (Constant a) where - pure _ = Constant mempty - {-# INLINE pure #-} - Constant x <*> Constant y = Constant (x `mappend` y) - {-# INLINE (<*>) #-} - -instance (Monoid a) => Monoid (Constant a b) where - mempty = Constant mempty - {-# INLINE mempty #-} -#if !MIN_VERSION_base(4,11,0) - -- From base-4.11, Monoid(mappend) defaults to Semigroup((<>)) - Constant x `mappend` Constant y = Constant (x `mappend` y) - {-# INLINE mappend #-} -#endif - -#if MIN_VERSION_base(4,8,0) -instance Bifunctor Constant where - first f (Constant x) = Constant (f x) - {-# INLINE first #-} - second _ (Constant x) = Constant x - {-# INLINE second #-} -#endif - -#if MIN_VERSION_base(4,10,0) -instance Bifoldable Constant where - bifoldMap f _ (Constant a) = f a - {-# INLINE bifoldMap #-} - -instance Bitraversable Constant where - bitraverse f _ (Constant a) = Constant <$> f a - {-# INLINE bitraverse #-} -#endif - -#if MIN_VERSION_base(4,12,0) -instance Contravariant (Constant a) where - contramap _ (Constant a) = Constant a - {-# INLINE contramap #-} -#endif diff --git a/third_party/bazel/rules_haskell/examples/transformers/Data/Functor/Reverse.hs b/third_party/bazel/rules_haskell/examples/transformers/Data/Functor/Reverse.hs deleted file mode 100644 index 5d8c41fa15c1..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Data/Functor/Reverse.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -#endif -#if __GLASGOW_HASKELL__ >= 710 -{-# LANGUAGE AutoDeriveTypeable #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Data.Functor.Reverse --- Copyright : (c) Russell O'Connor 2009 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- Making functors whose elements are notionally in the reverse order --- from the original functor. ------------------------------------------------------------------------------ - -module Data.Functor.Reverse ( - Reverse(..), - ) where - -import Control.Applicative.Backwards -import Data.Functor.Classes -#if MIN_VERSION_base(4,12,0) -import Data.Functor.Contravariant -#endif - -import Prelude hiding (foldr, foldr1, foldl, foldl1, null, length) -import Control.Applicative -import Control.Monad -#if MIN_VERSION_base(4,9,0) -import qualified Control.Monad.Fail as Fail -#endif -import Data.Foldable -import Data.Traversable -import Data.Monoid - --- | The same functor, but with 'Foldable' and 'Traversable' instances --- that process the elements in the reverse order. -newtype Reverse f a = Reverse { getReverse :: f a } - -instance (Eq1 f) => Eq1 (Reverse f) where - liftEq eq (Reverse x) (Reverse y) = liftEq eq x y - {-# INLINE liftEq #-} - -instance (Ord1 f) => Ord1 (Reverse f) where - liftCompare comp (Reverse x) (Reverse y) = liftCompare comp x y - {-# INLINE liftCompare #-} - -instance (Read1 f) => Read1 (Reverse f) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp rl) "Reverse" Reverse - -instance (Show1 f) => Show1 (Reverse f) where - liftShowsPrec sp sl d (Reverse x) = - showsUnaryWith (liftShowsPrec sp sl) "Reverse" d x - -instance (Eq1 f, Eq a) => Eq (Reverse f a) where (==) = eq1 -instance (Ord1 f, Ord a) => Ord (Reverse f a) where compare = compare1 -instance (Read1 f, Read a) => Read (Reverse f a) where readsPrec = readsPrec1 -instance (Show1 f, Show a) => Show (Reverse f a) where showsPrec = showsPrec1 - --- | Derived instance. -instance (Functor f) => Functor (Reverse f) where - fmap f (Reverse a) = Reverse (fmap f a) - {-# INLINE fmap #-} - --- | Derived instance. -instance (Applicative f) => Applicative (Reverse f) where - pure a = Reverse (pure a) - {-# INLINE pure #-} - Reverse f <*> Reverse a = Reverse (f <*> a) - {-# INLINE (<*>) #-} - --- | Derived instance. -instance (Alternative f) => Alternative (Reverse f) where - empty = Reverse empty - {-# INLINE empty #-} - Reverse x <|> Reverse y = Reverse (x <|> y) - {-# INLINE (<|>) #-} - --- | Derived instance. -instance (Monad m) => Monad (Reverse m) where -#if !(MIN_VERSION_base(4,8,0)) - return a = Reverse (return a) - {-# INLINE return #-} -#endif - m >>= f = Reverse (getReverse m >>= getReverse . f) - {-# INLINE (>>=) #-} -#if !(MIN_VERSION_base(4,13,0)) - fail msg = Reverse (fail msg) - {-# INLINE fail #-} -#endif - -#if MIN_VERSION_base(4,9,0) -instance (Fail.MonadFail m) => Fail.MonadFail (Reverse m) where - fail msg = Reverse (Fail.fail msg) - {-# INLINE fail #-} -#endif - --- | Derived instance. -instance (MonadPlus m) => MonadPlus (Reverse m) where - mzero = Reverse mzero - {-# INLINE mzero #-} - Reverse x `mplus` Reverse y = Reverse (x `mplus` y) - {-# INLINE mplus #-} - --- | Fold from right to left. -instance (Foldable f) => Foldable (Reverse f) where - foldMap f (Reverse t) = getDual (foldMap (Dual . f) t) - {-# INLINE foldMap #-} - foldr f z (Reverse t) = foldl (flip f) z t - {-# INLINE foldr #-} - foldl f z (Reverse t) = foldr (flip f) z t - {-# INLINE foldl #-} - foldr1 f (Reverse t) = foldl1 (flip f) t - {-# INLINE foldr1 #-} - foldl1 f (Reverse t) = foldr1 (flip f) t - {-# INLINE foldl1 #-} -#if MIN_VERSION_base(4,8,0) - null (Reverse t) = null t - length (Reverse t) = length t -#endif - --- | Traverse from right to left. -instance (Traversable f) => Traversable (Reverse f) where - traverse f (Reverse t) = - fmap Reverse . forwards $ traverse (Backwards . f) t - {-# INLINE traverse #-} - -#if MIN_VERSION_base(4,12,0) --- | Derived instance. -instance Contravariant f => Contravariant (Reverse f) where - contramap f = Reverse . contramap f . getReverse - {-# INLINE contramap #-} -#endif diff --git a/third_party/bazel/rules_haskell/examples/transformers/LICENSE b/third_party/bazel/rules_haskell/examples/transformers/LICENSE deleted file mode 100644 index 92337b951eb0..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/LICENSE +++ /dev/null @@ -1,31 +0,0 @@ -The Glasgow Haskell Compiler License - -Copyright 2004, The University Court of the University of Glasgow. -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -- Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. - -- Redistributions in binary form must reproduce the above copyright notice, -this list of conditions and the following disclaimer in the documentation -and/or other materials provided with the distribution. - -- Neither name of the University nor the names of its contributors may be -used to endorse or promote products derived from this software without -specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF -GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, -INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH -DAMAGE. diff --git a/third_party/bazel/rules_haskell/examples/transformers/Setup.hs b/third_party/bazel/rules_haskell/examples/transformers/Setup.hs deleted file mode 100644 index 9a994af677b0..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/third_party/bazel/rules_haskell/examples/transformers/changelog b/third_party/bazel/rules_haskell/examples/transformers/changelog deleted file mode 100644 index 5dd688f35b78..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/changelog +++ /dev/null @@ -1,124 +0,0 @@ --*-change-log-*- - -0.5.6.2 Ross Paterson <R.Paterson@city.ac.uk> Feb 2019 - * Further backward compatability fix - -0.5.6.1 Ross Paterson <R.Paterson@city.ac.uk> Feb 2019 - * Backward compatability fix for MonadFix ListT instance - -0.5.6.0 Ross Paterson <R.Paterson@city.ac.uk> Feb 2019 - * Generalized type of except - * Added Control.Monad.Trans.Writer.CPS and Control.Monad.Trans.RWS.CPS - * Added Contravariant instances - * Added MonadFix instance for ListT - -0.5.5.0 Ross Paterson <R.Paterson@city.ac.uk> Oct 2017 - * Added mapSelect and mapSelectT - * Renamed selectToCont to selectToContT for consistency - * Defined explicit method definitions to fix space leaks - * Added missing Semigroup instance to `Constant` functor - -0.5.4.0 Ross Paterson <R.Paterson@city.ac.uk> Feb 2017 - * Migrate Bifoldable and Bitraversable instances for Constant - -0.5.3.1 Ross Paterson <R.Paterson@city.ac.uk> Feb 2017 - * Fixed for pre-AMP environments - -0.5.3.0 Ross Paterson <R.Paterson@city.ac.uk> Feb 2017 - * Added AccumT and SelectT monad transformers - * Deprecated ListT - * Added Monad (and related) instances for Reverse - * Added elimLift and eitherToErrors - * Added specialized definitions of several methods for efficiency - * Removed specialized definition of sequenceA for Reverse - * Backported Eq1/Ord1/Read1/Show1 instances for Proxy - -0.5.2.0 Ross Paterson <R.Paterson@city.ac.uk> Feb 2016 - * Re-added orphan instances for Either to deprecated module - * Added lots of INLINE pragmas - -0.5.1.0 Ross Paterson <R.Paterson@city.ac.uk> Jan 2016 - * Bump minor version number, required by added instances - -0.5.0.2 Ross Paterson <R.Paterson@city.ac.uk> Jan 2016 - * Backported extra instances for Identity - -0.5.0.1 Ross Paterson <R.Paterson@city.ac.uk> Jan 2016 - * Tightened GHC bounds for PolyKinds and DeriveDataTypeable - -0.5.0.0 Ross Paterson <R.Paterson@city.ac.uk> Dec 2015 - * Control.Monad.IO.Class in base for GHC >= 8.0 - * Data.Functor.{Classes,Compose,Product,Sum} in base for GHC >= 8.0 - * Added PolyKinds for GHC >= 7.4 - * Added instances of base classes MonadZip and MonadFail - * Changed liftings of Prelude classes to use explicit dictionaries - -0.4.3.0 Ross Paterson <R.Paterson@city.ac.uk> Mar 2015 - * Added Eq1, Ord1, Show1 and Read1 instances for Const - -0.4.2.0 Ross Paterson <ross@soi.city.ac.uk> Nov 2014 - * Dropped compatibility with base-1.x - * Data.Functor.Identity in base for GHC >= 7.10 - * Added mapLift and runErrors to Control.Applicative.Lift - * Added AutoDeriveTypeable for GHC >= 7.10 - * Expanded messages from mfix on ExceptT and MaybeT - -0.4.1.0 Ross Paterson <ross@soi.city.ac.uk> May 2014 - * Reverted to record syntax for newtypes until next major release - -0.4.0.0 Ross Paterson <ross@soi.city.ac.uk> May 2014 - * Added Sum type - * Added modify', a strict version of modify, to the state monads - * Added ExceptT and deprecated ErrorT - * Added infixr 9 `Compose` to match (.) - * Added Eq, Ord, Read and Show instances where possible - * Replaced record syntax for newtypes with separate inverse functions - * Added delimited continuation functions to ContT - * Added instance Alternative IO to ErrorT - * Handled disappearance of Control.Monad.Instances - -0.3.0.0 Ross Paterson <ross@soi.city.ac.uk> Mar 2012 - * Added type synonyms for signatures of complex operations - * Generalized state, reader and writer constructor functions - * Added Lift, Backwards/Reverse - * Added MonadFix instances for IdentityT and MaybeT - * Added Foldable and Traversable instances - * Added Monad instances for Product - -0.2.2.1 Ross Paterson <ross@soi.city.ac.uk> Oct 2013 - * Backport of fix for disappearance of Control.Monad.Instances - -0.2.2.0 Ross Paterson <ross@soi.city.ac.uk> Sep 2010 - * Handled move of Either instances to base package - -0.2.1.0 Ross Paterson <ross@soi.city.ac.uk> Apr 2010 - * Added Alternative instance for Compose - * Added Data.Functor.Product - -0.2.0.0 Ross Paterson <ross@soi.city.ac.uk> Mar 2010 - * Added Constant and Compose - * Renamed modules to avoid clash with mtl - * Removed Monad constraint from Monad instance for ContT - -0.1.4.0 Ross Paterson <ross@soi.city.ac.uk> Mar 2009 - * Adjusted lifting of Identity and Maybe transformers - -0.1.3.0 Ross Paterson <ross@soi.city.ac.uk> Mar 2009 - * Added IdentityT transformer - * Added Applicative and Alternative instances for (Either e) - -0.1.1.0 Ross Paterson <ross@soi.city.ac.uk> Jan 2009 - * Made all Functor instances assume Functor - -0.1.0.1 Ross Paterson <ross@soi.city.ac.uk> Jan 2009 - * Adjusted dependencies - -0.1.0.0 Ross Paterson <ross@soi.city.ac.uk> Jan 2009 - * Two versions of lifting of callcc through StateT - * Added Applicative instances - -0.0.1.0 Ross Paterson <ross@soi.city.ac.uk> Jan 2009 - * Added constructors state, etc for simple monads - -0.0.0.0 Ross Paterson <ross@soi.city.ac.uk> Jan 2009 - * Split Haskell 98 transformers from the mtl diff --git a/third_party/bazel/rules_haskell/examples/transformers/legacy/pre709/Data/Functor/Identity.hs b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre709/Data/Functor/Identity.hs deleted file mode 100644 index 940e4e470f47..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/legacy/pre709/Data/Functor/Identity.hs +++ /dev/null @@ -1,259 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 700 -{-# LANGUAGE DeriveDataTypeable #-} -#endif -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE Trustworthy #-} -#endif -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -#endif -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE AutoDeriveTypeable #-} -{-# LANGUAGE DataKinds #-} -#endif -#if MIN_VERSION_base(4,7,0) --- We need to implement bitSize for the Bits instance, but it's deprecated. -{-# OPTIONS_GHC -fno-warn-deprecations #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Data.Functor.Identity --- Copyright : (c) Andy Gill 2001, --- (c) Oregon Graduate Institute of Science and Technology 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : ross@soi.city.ac.uk --- Stability : experimental --- Portability : portable --- --- The identity functor and monad. --- --- This trivial type constructor serves two purposes: --- --- * It can be used with functions parameterized by functor or monad classes. --- --- * It can be used as a base monad to which a series of monad --- transformers may be applied to construct a composite monad. --- Most monad transformer modules include the special case of --- applying the transformer to 'Identity'. For example, @State s@ --- is an abbreviation for @StateT s 'Identity'@. ------------------------------------------------------------------------------ - -module Data.Functor.Identity ( - Identity(..), - ) where - -import Data.Bits -import Control.Applicative -import Control.Arrow (Arrow((***))) -import Control.Monad.Fix -#if MIN_VERSION_base(4,4,0) -import Control.Monad.Zip (MonadZip(mzipWith, munzip)) -#endif -import Data.Foldable (Foldable(foldMap)) -import Data.Monoid (Monoid(mempty, mappend)) -import Data.String (IsString(fromString)) -import Data.Traversable (Traversable(traverse)) -#if __GLASGOW_HASKELL__ >= 700 -import Data.Data -#endif -import Data.Ix (Ix(..)) -import Foreign (Storable(..), castPtr) -#if __GLASGOW_HASKELL__ >= 702 -import GHC.Generics -#endif - --- | Identity functor and monad. (a non-strict monad) -newtype Identity a = Identity { runIdentity :: a } - deriving ( Eq, Ord -#if __GLASGOW_HASKELL__ >= 700 - , Data, Typeable -#endif -#if __GLASGOW_HASKELL__ >= 702 - , Generic -#endif -#if __GLASGOW_HASKELL__ >= 706 - , Generic1 -#endif - ) - -instance (Bits a) => Bits (Identity a) where - Identity x .&. Identity y = Identity (x .&. y) - Identity x .|. Identity y = Identity (x .|. y) - xor (Identity x) (Identity y) = Identity (xor x y) - complement (Identity x) = Identity (complement x) - shift (Identity x) i = Identity (shift x i) - rotate (Identity x) i = Identity (rotate x i) - setBit (Identity x) i = Identity (setBit x i) - clearBit (Identity x) i = Identity (clearBit x i) - shiftL (Identity x) i = Identity (shiftL x i) - shiftR (Identity x) i = Identity (shiftR x i) - rotateL (Identity x) i = Identity (rotateL x i) - rotateR (Identity x) i = Identity (rotateR x i) - testBit (Identity x) i = testBit x i - bitSize (Identity x) = bitSize x - isSigned (Identity x) = isSigned x - bit i = Identity (bit i) -#if MIN_VERSION_base(4,5,0) - unsafeShiftL (Identity x) i = Identity (unsafeShiftL x i) - unsafeShiftR (Identity x) i = Identity (unsafeShiftR x i) - popCount (Identity x) = popCount x -#endif -#if MIN_VERSION_base(4,7,0) - zeroBits = Identity zeroBits - bitSizeMaybe (Identity x) = bitSizeMaybe x -#endif - -instance (Bounded a) => Bounded (Identity a) where - minBound = Identity minBound - maxBound = Identity maxBound - -instance (Enum a) => Enum (Identity a) where - succ (Identity x) = Identity (succ x) - pred (Identity x) = Identity (pred x) - toEnum i = Identity (toEnum i) - fromEnum (Identity x) = fromEnum x - enumFrom (Identity x) = map Identity (enumFrom x) - enumFromThen (Identity x) (Identity y) = map Identity (enumFromThen x y) - enumFromTo (Identity x) (Identity y) = map Identity (enumFromTo x y) - enumFromThenTo (Identity x) (Identity y) (Identity z) = - map Identity (enumFromThenTo x y z) - -#if MIN_VERSION_base(4,7,0) -instance (FiniteBits a) => FiniteBits (Identity a) where - finiteBitSize (Identity x) = finiteBitSize x -#endif - -instance (Floating a) => Floating (Identity a) where - pi = Identity pi - exp (Identity x) = Identity (exp x) - log (Identity x) = Identity (log x) - sqrt (Identity x) = Identity (sqrt x) - sin (Identity x) = Identity (sin x) - cos (Identity x) = Identity (cos x) - tan (Identity x) = Identity (tan x) - asin (Identity x) = Identity (asin x) - acos (Identity x) = Identity (acos x) - atan (Identity x) = Identity (atan x) - sinh (Identity x) = Identity (sinh x) - cosh (Identity x) = Identity (cosh x) - tanh (Identity x) = Identity (tanh x) - asinh (Identity x) = Identity (asinh x) - acosh (Identity x) = Identity (acosh x) - atanh (Identity x) = Identity (atanh x) - Identity x ** Identity y = Identity (x ** y) - logBase (Identity x) (Identity y) = Identity (logBase x y) - -instance (Fractional a) => Fractional (Identity a) where - Identity x / Identity y = Identity (x / y) - recip (Identity x) = Identity (recip x) - fromRational r = Identity (fromRational r) - -instance (IsString a) => IsString (Identity a) where - fromString s = Identity (fromString s) - -instance (Ix a) => Ix (Identity a) where - range (Identity x, Identity y) = map Identity (range (x, y)) - index (Identity x, Identity y) (Identity i) = index (x, y) i - inRange (Identity x, Identity y) (Identity e) = inRange (x, y) e - rangeSize (Identity x, Identity y) = rangeSize (x, y) - -instance (Integral a) => Integral (Identity a) where - quot (Identity x) (Identity y) = Identity (quot x y) - rem (Identity x) (Identity y) = Identity (rem x y) - div (Identity x) (Identity y) = Identity (div x y) - mod (Identity x) (Identity y) = Identity (mod x y) - quotRem (Identity x) (Identity y) = (Identity *** Identity) (quotRem x y) - divMod (Identity x) (Identity y) = (Identity *** Identity) (divMod x y) - toInteger (Identity x) = toInteger x - -instance (Monoid a) => Monoid (Identity a) where - mempty = Identity mempty - mappend (Identity x) (Identity y) = Identity (mappend x y) - -instance (Num a) => Num (Identity a) where - Identity x + Identity y = Identity (x + y) - Identity x - Identity y = Identity (x - y) - Identity x * Identity y = Identity (x * y) - negate (Identity x) = Identity (negate x) - abs (Identity x) = Identity (abs x) - signum (Identity x) = Identity (signum x) - fromInteger n = Identity (fromInteger n) - -instance (Real a) => Real (Identity a) where - toRational (Identity x) = toRational x - -instance (RealFloat a) => RealFloat (Identity a) where - floatRadix (Identity x) = floatRadix x - floatDigits (Identity x) = floatDigits x - floatRange (Identity x) = floatRange x - decodeFloat (Identity x) = decodeFloat x - exponent (Identity x) = exponent x - isNaN (Identity x) = isNaN x - isInfinite (Identity x) = isInfinite x - isDenormalized (Identity x) = isDenormalized x - isNegativeZero (Identity x) = isNegativeZero x - isIEEE (Identity x) = isIEEE x - significand (Identity x) = significand (Identity x) - scaleFloat s (Identity x) = Identity (scaleFloat s x) - encodeFloat m n = Identity (encodeFloat m n) - atan2 (Identity x) (Identity y) = Identity (atan2 x y) - -instance (RealFrac a) => RealFrac (Identity a) where - properFraction (Identity x) = (id *** Identity) (properFraction x) - truncate (Identity x) = truncate x - round (Identity x) = round x - ceiling (Identity x) = ceiling x - floor (Identity x) = floor x - -instance (Storable a) => Storable (Identity a) where - sizeOf (Identity x) = sizeOf x - alignment (Identity x) = alignment x - peekElemOff p i = fmap Identity (peekElemOff (castPtr p) i) - pokeElemOff p i (Identity x) = pokeElemOff (castPtr p) i x - peekByteOff p i = fmap Identity (peekByteOff p i) - pokeByteOff p i (Identity x) = pokeByteOff p i x - peek p = fmap runIdentity (peek (castPtr p)) - poke p (Identity x) = poke (castPtr p) x - --- These instances would be equivalent to the derived instances of the --- newtype if the field were removed. - -instance (Read a) => Read (Identity a) where - readsPrec d = readParen (d > 10) $ \ r -> - [(Identity x,t) | ("Identity",s) <- lex r, (x,t) <- readsPrec 11 s] - -instance (Show a) => Show (Identity a) where - showsPrec d (Identity x) = showParen (d > 10) $ - showString "Identity " . showsPrec 11 x - --- --------------------------------------------------------------------------- --- Identity instances for Functor and Monad - -instance Functor Identity where - fmap f m = Identity (f (runIdentity m)) - -instance Foldable Identity where - foldMap f (Identity x) = f x - -instance Traversable Identity where - traverse f (Identity x) = Identity <$> f x - -instance Applicative Identity where - pure a = Identity a - Identity f <*> Identity x = Identity (f x) - -instance Monad Identity where - return a = Identity a - m >>= k = k (runIdentity m) - -instance MonadFix Identity where - mfix f = Identity (fix (runIdentity . f)) - -#if MIN_VERSION_base(4,4,0) -instance MonadZip Identity where - mzipWith f (Identity x) (Identity y) = Identity (f x y) - munzip (Identity (a, b)) = (Identity a, Identity b) -#endif diff --git a/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Control/Monad/IO/Class.hs b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Control/Monad/IO/Class.hs deleted file mode 100644 index 7c74d4ef0d71..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Control/Monad/IO/Class.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE StandaloneDeriving #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.IO.Class --- Copyright : (c) Andy Gill 2001, --- (c) Oregon Graduate Institute of Science and Technology, 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- Class of monads based on @IO@. ------------------------------------------------------------------------------ - -module Control.Monad.IO.Class ( - MonadIO(..) - ) where - -#if __GLASGOW_HASKELL__ >= 708 -import Data.Typeable -#endif - --- | Monads in which 'IO' computations may be embedded. --- Any monad built by applying a sequence of monad transformers to the --- 'IO' monad will be an instance of this class. --- --- Instances should satisfy the following laws, which state that 'liftIO' --- is a transformer of monads: --- --- * @'liftIO' . 'return' = 'return'@ --- --- * @'liftIO' (m >>= f) = 'liftIO' m >>= ('liftIO' . f)@ - -class (Monad m) => MonadIO m where - -- | Lift a computation from the 'IO' monad. - liftIO :: IO a -> m a - -#if __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable MonadIO -#endif - -instance MonadIO IO where - liftIO = id diff --git a/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Classes.hs b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Classes.hs deleted file mode 100644 index bda1749643d1..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Classes.hs +++ /dev/null @@ -1,529 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Safe #-} -#endif -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE StandaloneDeriving #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Data.Functor.Classes --- Copyright : (c) Ross Paterson 2013 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- Liftings of the Prelude classes 'Eq', 'Ord', 'Read' and 'Show' to --- unary and binary type constructors. --- --- These classes are needed to express the constraints on arguments of --- transformers in portable Haskell. Thus for a new transformer @T@, --- one might write instances like --- --- > instance (Eq1 f) => Eq1 (T f) where ... --- > instance (Ord1 f) => Ord1 (T f) where ... --- > instance (Read1 f) => Read1 (T f) where ... --- > instance (Show1 f) => Show1 (T f) where ... --- --- If these instances can be defined, defining instances of the base --- classes is mechanical: --- --- > instance (Eq1 f, Eq a) => Eq (T f a) where (==) = eq1 --- > instance (Ord1 f, Ord a) => Ord (T f a) where compare = compare1 --- > instance (Read1 f, Read a) => Read (T f a) where readsPrec = readsPrec1 --- > instance (Show1 f, Show a) => Show (T f a) where showsPrec = showsPrec1 --- ------------------------------------------------------------------------------ - -module Data.Functor.Classes ( - -- * Liftings of Prelude classes - -- ** For unary constructors - Eq1(..), eq1, - Ord1(..), compare1, - Read1(..), readsPrec1, - Show1(..), showsPrec1, - -- ** For binary constructors - Eq2(..), eq2, - Ord2(..), compare2, - Read2(..), readsPrec2, - Show2(..), showsPrec2, - -- * Helper functions - -- $example - readsData, - readsUnaryWith, - readsBinaryWith, - showsUnaryWith, - showsBinaryWith, - -- ** Obsolete helpers - readsUnary, - readsUnary1, - readsBinary1, - showsUnary, - showsUnary1, - showsBinary1, - ) where - -import Control.Applicative (Const(Const)) -import Data.Functor.Identity (Identity(Identity)) -import Data.Monoid (mappend) -#if MIN_VERSION_base(4,7,0) -import Data.Proxy (Proxy(Proxy)) -#endif -#if __GLASGOW_HASKELL__ >= 708 -import Data.Typeable -#endif -import Text.Show (showListWith) - --- | Lifting of the 'Eq' class to unary type constructors. -class Eq1 f where - -- | Lift an equality test through the type constructor. - -- - -- The function will usually be applied to an equality function, - -- but the more general type ensures that the implementation uses - -- it to compare elements of the first container with elements of - -- the second. - liftEq :: (a -> b -> Bool) -> f a -> f b -> Bool - -#if __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable Eq1 -#endif - --- | Lift the standard @('==')@ function through the type constructor. -eq1 :: (Eq1 f, Eq a) => f a -> f a -> Bool -eq1 = liftEq (==) - --- | Lifting of the 'Ord' class to unary type constructors. -class (Eq1 f) => Ord1 f where - -- | Lift a 'compare' function through the type constructor. - -- - -- The function will usually be applied to a comparison function, - -- but the more general type ensures that the implementation uses - -- it to compare elements of the first container with elements of - -- the second. - liftCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering - -#if __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable Ord1 -#endif - --- | Lift the standard 'compare' function through the type constructor. -compare1 :: (Ord1 f, Ord a) => f a -> f a -> Ordering -compare1 = liftCompare compare - --- | Lifting of the 'Read' class to unary type constructors. -class Read1 f where - -- | 'readsPrec' function for an application of the type constructor - -- based on 'readsPrec' and 'readList' functions for the argument type. - liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a) - - -- | 'readList' function for an application of the type constructor - -- based on 'readsPrec' and 'readList' functions for the argument type. - -- The default implementation using standard list syntax is correct - -- for most types. - liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [f a] - liftReadList rp rl = readListWith (liftReadsPrec rp rl 0) - -#if __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable Read1 -#endif - --- | Read a list (using square brackets and commas), given a function --- for reading elements. -readListWith :: ReadS a -> ReadS [a] -readListWith rp = - readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s]) - where - readl s = [([],t) | ("]",t) <- lex s] ++ - [(x:xs,u) | (x,t) <- rp s, (xs,u) <- readl' t] - readl' s = [([],t) | ("]",t) <- lex s] ++ - [(x:xs,v) | (",",t) <- lex s, (x,u) <- rp t, (xs,v) <- readl' u] - --- | Lift the standard 'readsPrec' and 'readList' functions through the --- type constructor. -readsPrec1 :: (Read1 f, Read a) => Int -> ReadS (f a) -readsPrec1 = liftReadsPrec readsPrec readList - --- | Lifting of the 'Show' class to unary type constructors. -class Show1 f where - -- | 'showsPrec' function for an application of the type constructor - -- based on 'showsPrec' and 'showList' functions for the argument type. - liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> - Int -> f a -> ShowS - - -- | 'showList' function for an application of the type constructor - -- based on 'showsPrec' and 'showList' functions for the argument type. - -- The default implementation using standard list syntax is correct - -- for most types. - liftShowList :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> - [f a] -> ShowS - liftShowList sp sl = showListWith (liftShowsPrec sp sl 0) - -#if __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable Show1 -#endif - --- | Lift the standard 'showsPrec' and 'showList' functions through the --- type constructor. -showsPrec1 :: (Show1 f, Show a) => Int -> f a -> ShowS -showsPrec1 = liftShowsPrec showsPrec showList - --- | Lifting of the 'Eq' class to binary type constructors. -class Eq2 f where - -- | Lift equality tests through the type constructor. - -- - -- The function will usually be applied to equality functions, - -- but the more general type ensures that the implementation uses - -- them to compare elements of the first container with elements of - -- the second. - liftEq2 :: (a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool - -#if __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable Eq2 -#endif - --- | Lift the standard @('==')@ function through the type constructor. -eq2 :: (Eq2 f, Eq a, Eq b) => f a b -> f a b -> Bool -eq2 = liftEq2 (==) (==) - --- | Lifting of the 'Ord' class to binary type constructors. -class (Eq2 f) => Ord2 f where - -- | Lift 'compare' functions through the type constructor. - -- - -- The function will usually be applied to comparison functions, - -- but the more general type ensures that the implementation uses - -- them to compare elements of the first container with elements of - -- the second. - liftCompare2 :: (a -> b -> Ordering) -> (c -> d -> Ordering) -> - f a c -> f b d -> Ordering - -#if __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable Ord2 -#endif - --- | Lift the standard 'compare' function through the type constructor. -compare2 :: (Ord2 f, Ord a, Ord b) => f a b -> f a b -> Ordering -compare2 = liftCompare2 compare compare - --- | Lifting of the 'Read' class to binary type constructors. -class Read2 f where - -- | 'readsPrec' function for an application of the type constructor - -- based on 'readsPrec' and 'readList' functions for the argument types. - liftReadsPrec2 :: (Int -> ReadS a) -> ReadS [a] -> - (Int -> ReadS b) -> ReadS [b] -> Int -> ReadS (f a b) - - -- | 'readList' function for an application of the type constructor - -- based on 'readsPrec' and 'readList' functions for the argument types. - -- The default implementation using standard list syntax is correct - -- for most types. - liftReadList2 :: (Int -> ReadS a) -> ReadS [a] -> - (Int -> ReadS b) -> ReadS [b] -> ReadS [f a b] - liftReadList2 rp1 rl1 rp2 rl2 = - readListWith (liftReadsPrec2 rp1 rl1 rp2 rl2 0) - -#if __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable Read2 -#endif - --- | Lift the standard 'readsPrec' function through the type constructor. -readsPrec2 :: (Read2 f, Read a, Read b) => Int -> ReadS (f a b) -readsPrec2 = liftReadsPrec2 readsPrec readList readsPrec readList - --- | Lifting of the 'Show' class to binary type constructors. -class Show2 f where - -- | 'showsPrec' function for an application of the type constructor - -- based on 'showsPrec' and 'showList' functions for the argument types. - liftShowsPrec2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> - (Int -> b -> ShowS) -> ([b] -> ShowS) -> Int -> f a b -> ShowS - - -- | 'showList' function for an application of the type constructor - -- based on 'showsPrec' and 'showList' functions for the argument types. - -- The default implementation using standard list syntax is correct - -- for most types. - liftShowList2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> - (Int -> b -> ShowS) -> ([b] -> ShowS) -> [f a b] -> ShowS - liftShowList2 sp1 sl1 sp2 sl2 = - showListWith (liftShowsPrec2 sp1 sl1 sp2 sl2 0) - -#if __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable Show2 -#endif - --- | Lift the standard 'showsPrec' function through the type constructor. -showsPrec2 :: (Show2 f, Show a, Show b) => Int -> f a b -> ShowS -showsPrec2 = liftShowsPrec2 showsPrec showList showsPrec showList - --- Instances for Prelude type constructors - -instance Eq1 Maybe where - liftEq _ Nothing Nothing = True - liftEq _ Nothing (Just _) = False - liftEq _ (Just _) Nothing = False - liftEq eq (Just x) (Just y) = eq x y - -instance Ord1 Maybe where - liftCompare _ Nothing Nothing = EQ - liftCompare _ Nothing (Just _) = LT - liftCompare _ (Just _) Nothing = GT - liftCompare comp (Just x) (Just y) = comp x y - -instance Read1 Maybe where - liftReadsPrec rp _ d = - readParen False (\ r -> [(Nothing,s) | ("Nothing",s) <- lex r]) - `mappend` - readsData (readsUnaryWith rp "Just" Just) d - -instance Show1 Maybe where - liftShowsPrec _ _ _ Nothing = showString "Nothing" - liftShowsPrec sp _ d (Just x) = showsUnaryWith sp "Just" d x - -instance Eq1 [] where - liftEq _ [] [] = True - liftEq _ [] (_:_) = False - liftEq _ (_:_) [] = False - liftEq eq (x:xs) (y:ys) = eq x y && liftEq eq xs ys - -instance Ord1 [] where - liftCompare _ [] [] = EQ - liftCompare _ [] (_:_) = LT - liftCompare _ (_:_) [] = GT - liftCompare comp (x:xs) (y:ys) = comp x y `mappend` liftCompare comp xs ys - -instance Read1 [] where - liftReadsPrec _ rl _ = rl - -instance Show1 [] where - liftShowsPrec _ sl _ = sl - -instance Eq2 (,) where - liftEq2 e1 e2 (x1, y1) (x2, y2) = e1 x1 x2 && e2 y1 y2 - -instance Ord2 (,) where - liftCompare2 comp1 comp2 (x1, y1) (x2, y2) = - comp1 x1 x2 `mappend` comp2 y1 y2 - -instance Read2 (,) where - liftReadsPrec2 rp1 _ rp2 _ _ = readParen False $ \ r -> - [((x,y), w) | ("(",s) <- lex r, - (x,t) <- rp1 0 s, - (",",u) <- lex t, - (y,v) <- rp2 0 u, - (")",w) <- lex v] - -instance Show2 (,) where - liftShowsPrec2 sp1 _ sp2 _ _ (x, y) = - showChar '(' . sp1 0 x . showChar ',' . sp2 0 y . showChar ')' - -instance (Eq a) => Eq1 ((,) a) where - liftEq = liftEq2 (==) - -instance (Ord a) => Ord1 ((,) a) where - liftCompare = liftCompare2 compare - -instance (Read a) => Read1 ((,) a) where - liftReadsPrec = liftReadsPrec2 readsPrec readList - -instance (Show a) => Show1 ((,) a) where - liftShowsPrec = liftShowsPrec2 showsPrec showList - -instance Eq2 Either where - liftEq2 e1 _ (Left x) (Left y) = e1 x y - liftEq2 _ _ (Left _) (Right _) = False - liftEq2 _ _ (Right _) (Left _) = False - liftEq2 _ e2 (Right x) (Right y) = e2 x y - -instance Ord2 Either where - liftCompare2 comp1 _ (Left x) (Left y) = comp1 x y - liftCompare2 _ _ (Left _) (Right _) = LT - liftCompare2 _ _ (Right _) (Left _) = GT - liftCompare2 _ comp2 (Right x) (Right y) = comp2 x y - -instance Read2 Either where - liftReadsPrec2 rp1 _ rp2 _ = readsData $ - readsUnaryWith rp1 "Left" Left `mappend` - readsUnaryWith rp2 "Right" Right - -instance Show2 Either where - liftShowsPrec2 sp1 _ _ _ d (Left x) = showsUnaryWith sp1 "Left" d x - liftShowsPrec2 _ _ sp2 _ d (Right x) = showsUnaryWith sp2 "Right" d x - -instance (Eq a) => Eq1 (Either a) where - liftEq = liftEq2 (==) - -instance (Ord a) => Ord1 (Either a) where - liftCompare = liftCompare2 compare - -instance (Read a) => Read1 (Either a) where - liftReadsPrec = liftReadsPrec2 readsPrec readList - -instance (Show a) => Show1 (Either a) where - liftShowsPrec = liftShowsPrec2 showsPrec showList - -#if MIN_VERSION_base(4,7,0) -instance Eq1 Proxy where - liftEq _ _ _ = True - -instance Ord1 Proxy where - liftCompare _ _ _ = EQ - -instance Show1 Proxy where - liftShowsPrec _ _ _ _ = showString "Proxy" - -instance Read1 Proxy where - liftReadsPrec _ _ d = - readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ]) -#endif - --- Instances for other functors defined in the base package - -instance Eq1 Identity where - liftEq eq (Identity x) (Identity y) = eq x y - -instance Ord1 Identity where - liftCompare comp (Identity x) (Identity y) = comp x y - -instance Read1 Identity where - liftReadsPrec rp _ = readsData $ - readsUnaryWith rp "Identity" Identity - -instance Show1 Identity where - liftShowsPrec sp _ d (Identity x) = showsUnaryWith sp "Identity" d x - -instance Eq2 Const where - liftEq2 eq _ (Const x) (Const y) = eq x y - -instance Ord2 Const where - liftCompare2 comp _ (Const x) (Const y) = comp x y - -instance Read2 Const where - liftReadsPrec2 rp _ _ _ = readsData $ - readsUnaryWith rp "Const" Const - -instance Show2 Const where - liftShowsPrec2 sp _ _ _ d (Const x) = showsUnaryWith sp "Const" d x - -instance (Eq a) => Eq1 (Const a) where - liftEq = liftEq2 (==) -instance (Ord a) => Ord1 (Const a) where - liftCompare = liftCompare2 compare -instance (Read a) => Read1 (Const a) where - liftReadsPrec = liftReadsPrec2 readsPrec readList -instance (Show a) => Show1 (Const a) where - liftShowsPrec = liftShowsPrec2 showsPrec showList - --- Building blocks - --- | @'readsData' p d@ is a parser for datatypes where each alternative --- begins with a data constructor. It parses the constructor and --- passes it to @p@. Parsers for various constructors can be constructed --- with 'readsUnary', 'readsUnary1' and 'readsBinary1', and combined with --- @mappend@ from the @Monoid@ class. -readsData :: (String -> ReadS a) -> Int -> ReadS a -readsData reader d = - readParen (d > 10) $ \ r -> [res | (kw,s) <- lex r, res <- reader kw s] - --- | @'readsUnaryWith' rp n c n'@ matches the name of a unary data constructor --- and then parses its argument using @rp@. -readsUnaryWith :: (Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t -readsUnaryWith rp name cons kw s = - [(cons x,t) | kw == name, (x,t) <- rp 11 s] - --- | @'readsBinaryWith' rp1 rp2 n c n'@ matches the name of a binary --- data constructor and then parses its arguments using @rp1@ and @rp2@ --- respectively. -readsBinaryWith :: (Int -> ReadS a) -> (Int -> ReadS b) -> - String -> (a -> b -> t) -> String -> ReadS t -readsBinaryWith rp1 rp2 name cons kw s = - [(cons x y,u) | kw == name, (x,t) <- rp1 11 s, (y,u) <- rp2 11 t] - --- | @'showsUnaryWith' sp n d x@ produces the string representation of a --- unary data constructor with name @n@ and argument @x@, in precedence --- context @d@. -showsUnaryWith :: (Int -> a -> ShowS) -> String -> Int -> a -> ShowS -showsUnaryWith sp name d x = showParen (d > 10) $ - showString name . showChar ' ' . sp 11 x - --- | @'showsBinaryWith' sp1 sp2 n d x y@ produces the string --- representation of a binary data constructor with name @n@ and arguments --- @x@ and @y@, in precedence context @d@. -showsBinaryWith :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) -> - String -> Int -> a -> b -> ShowS -showsBinaryWith sp1 sp2 name d x y = showParen (d > 10) $ - showString name . showChar ' ' . sp1 11 x . showChar ' ' . sp2 11 y - --- Obsolete building blocks - --- | @'readsUnary' n c n'@ matches the name of a unary data constructor --- and then parses its argument using 'readsPrec'. -{-# DEPRECATED readsUnary "Use readsUnaryWith to define liftReadsPrec" #-} -readsUnary :: (Read a) => String -> (a -> t) -> String -> ReadS t -readsUnary name cons kw s = - [(cons x,t) | kw == name, (x,t) <- readsPrec 11 s] - --- | @'readsUnary1' n c n'@ matches the name of a unary data constructor --- and then parses its argument using 'readsPrec1'. -{-# DEPRECATED readsUnary1 "Use readsUnaryWith to define liftReadsPrec" #-} -readsUnary1 :: (Read1 f, Read a) => String -> (f a -> t) -> String -> ReadS t -readsUnary1 name cons kw s = - [(cons x,t) | kw == name, (x,t) <- readsPrec1 11 s] - --- | @'readsBinary1' n c n'@ matches the name of a binary data constructor --- and then parses its arguments using 'readsPrec1'. -{-# DEPRECATED readsBinary1 "Use readsBinaryWith to define liftReadsPrec" #-} -readsBinary1 :: (Read1 f, Read1 g, Read a) => - String -> (f a -> g a -> t) -> String -> ReadS t -readsBinary1 name cons kw s = - [(cons x y,u) | kw == name, - (x,t) <- readsPrec1 11 s, (y,u) <- readsPrec1 11 t] - --- | @'showsUnary' n d x@ produces the string representation of a unary data --- constructor with name @n@ and argument @x@, in precedence context @d@. -{-# DEPRECATED showsUnary "Use showsUnaryWith to define liftShowsPrec" #-} -showsUnary :: (Show a) => String -> Int -> a -> ShowS -showsUnary name d x = showParen (d > 10) $ - showString name . showChar ' ' . showsPrec 11 x - --- | @'showsUnary1' n d x@ produces the string representation of a unary data --- constructor with name @n@ and argument @x@, in precedence context @d@. -{-# DEPRECATED showsUnary1 "Use showsUnaryWith to define liftShowsPrec" #-} -showsUnary1 :: (Show1 f, Show a) => String -> Int -> f a -> ShowS -showsUnary1 name d x = showParen (d > 10) $ - showString name . showChar ' ' . showsPrec1 11 x - --- | @'showsBinary1' n d x y@ produces the string representation of a binary --- data constructor with name @n@ and arguments @x@ and @y@, in precedence --- context @d@. -{-# DEPRECATED showsBinary1 "Use showsBinaryWith to define liftShowsPrec" #-} -showsBinary1 :: (Show1 f, Show1 g, Show a) => - String -> Int -> f a -> g a -> ShowS -showsBinary1 name d x y = showParen (d > 10) $ - showString name . showChar ' ' . showsPrec1 11 x . - showChar ' ' . showsPrec1 11 y - -{- $example -These functions can be used to assemble 'Read' and 'Show' instances for -new algebraic types. For example, given the definition - -> data T f a = Zero a | One (f a) | Two a (f a) - -a standard 'Read1' instance may be defined as - -> instance (Read1 f) => Read1 (T f) where -> liftReadsPrec rp rl = readsData $ -> readsUnaryWith rp "Zero" Zero `mappend` -> readsUnaryWith (liftReadsPrec rp rl) "One" One `mappend` -> readsBinaryWith rp (liftReadsPrec rp rl) "Two" Two - -and the corresponding 'Show1' instance as - -> instance (Show1 f) => Show1 (T f) where -> liftShowsPrec sp _ d (Zero x) = -> showsUnaryWith sp "Zero" d x -> liftShowsPrec sp sl d (One x) = -> showsUnaryWith (liftShowsPrec sp sl) "One" d x -> liftShowsPrec sp sl d (Two x y) = -> showsBinaryWith sp (liftShowsPrec sp sl) "Two" d x y - --} diff --git a/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Compose.hs b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Compose.hs deleted file mode 100644 index ed781309aff8..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Compose.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -#endif -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -#endif -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE AutoDeriveTypeable #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Data.Functor.Compose --- Copyright : (c) Ross Paterson 2010 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- Composition of functors. ------------------------------------------------------------------------------ - -module Data.Functor.Compose ( - Compose(..), - ) where - -import Data.Functor.Classes -#if MIN_VERSION_base(4,12,0) -import Data.Functor.Contravariant -#endif - -import Control.Applicative -#if __GLASGOW_HASKELL__ >= 708 -import Data.Data -#endif -import Data.Foldable (Foldable(foldMap)) -import Data.Traversable (Traversable(traverse)) -#if __GLASGOW_HASKELL__ >= 702 -import GHC.Generics -#endif - -infixr 9 `Compose` - --- | Right-to-left composition of functors. --- The composition of applicative functors is always applicative, --- but the composition of monads is not always a monad. -newtype Compose f g a = Compose { getCompose :: f (g a) } - -#if __GLASGOW_HASKELL__ >= 702 -deriving instance Generic (Compose f g a) - -instance Functor f => Generic1 (Compose f g) where - type Rep1 (Compose f g) = - D1 MDCompose - (C1 MCCompose - (S1 MSCompose (f :.: Rec1 g))) - from1 (Compose x) = M1 (M1 (M1 (Comp1 (fmap Rec1 x)))) - to1 (M1 (M1 (M1 x))) = Compose (fmap unRec1 (unComp1 x)) - -data MDCompose -data MCCompose -data MSCompose - -instance Datatype MDCompose where - datatypeName _ = "Compose" - moduleName _ = "Data.Functor.Compose" -# if __GLASGOW_HASKELL__ >= 708 - isNewtype _ = True -# endif - -instance Constructor MCCompose where - conName _ = "Compose" - conIsRecord _ = True - -instance Selector MSCompose where - selName _ = "getCompose" -#endif - -#if __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable Compose -deriving instance (Data (f (g a)), Typeable f, Typeable g, Typeable a) - => Data (Compose (f :: * -> *) (g :: * -> *) (a :: *)) -#endif - --- Instances of lifted Prelude classes - -instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where - liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y - -instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where - liftCompare comp (Compose x) (Compose y) = - liftCompare (liftCompare comp) x y - -instance (Read1 f, Read1 g) => Read1 (Compose f g) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "Compose" Compose - where - rp' = liftReadsPrec rp rl - rl' = liftReadList rp rl - -instance (Show1 f, Show1 g) => Show1 (Compose f g) where - liftShowsPrec sp sl d (Compose x) = - showsUnaryWith (liftShowsPrec sp' sl') "Compose" d x - where - sp' = liftShowsPrec sp sl - sl' = liftShowList sp sl - --- Instances of Prelude classes - -instance (Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where - (==) = eq1 - -instance (Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where - compare = compare1 - -instance (Read1 f, Read1 g, Read a) => Read (Compose f g a) where - readsPrec = readsPrec1 - -instance (Show1 f, Show1 g, Show a) => Show (Compose f g a) where - showsPrec = showsPrec1 - --- Functor instances - -instance (Functor f, Functor g) => Functor (Compose f g) where - fmap f (Compose x) = Compose (fmap (fmap f) x) - -instance (Foldable f, Foldable g) => Foldable (Compose f g) where - foldMap f (Compose t) = foldMap (foldMap f) t - -instance (Traversable f, Traversable g) => Traversable (Compose f g) where - traverse f (Compose t) = Compose <$> traverse (traverse f) t - -instance (Applicative f, Applicative g) => Applicative (Compose f g) where - pure x = Compose (pure (pure x)) - Compose f <*> Compose x = Compose ((<*>) <$> f <*> x) - -instance (Alternative f, Applicative g) => Alternative (Compose f g) where - empty = Compose empty - Compose x <|> Compose y = Compose (x <|> y) - -#if MIN_VERSION_base(4,12,0) -instance (Functor f, Contravariant g) => Contravariant (Compose f g) where - contramap f (Compose fga) = Compose (fmap (contramap f) fga) -#endif diff --git a/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Product.hs b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Product.hs deleted file mode 100644 index ba0dc0407e00..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Product.hs +++ /dev/null @@ -1,156 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -#endif -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -#endif -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE AutoDeriveTypeable #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Data.Functor.Product --- Copyright : (c) Ross Paterson 2010 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- Products, lifted to functors. ------------------------------------------------------------------------------ - -module Data.Functor.Product ( - Product(..), - ) where - -import Control.Applicative -import Control.Monad (MonadPlus(..)) -import Control.Monad.Fix (MonadFix(..)) -#if MIN_VERSION_base(4,4,0) -import Control.Monad.Zip (MonadZip(mzipWith)) -#endif -#if __GLASGOW_HASKELL__ >= 708 -import Data.Data -#endif -import Data.Foldable (Foldable(foldMap)) -import Data.Functor.Classes -#if MIN_VERSION_base(4,12,0) -import Data.Functor.Contravariant -#endif -import Data.Monoid (mappend) -import Data.Traversable (Traversable(traverse)) -#if __GLASGOW_HASKELL__ >= 702 -import GHC.Generics -#endif - --- | Lifted product of functors. -data Product f g a = Pair (f a) (g a) - -#if __GLASGOW_HASKELL__ >= 702 -deriving instance Generic (Product f g a) - -instance Generic1 (Product f g) where - type Rep1 (Product f g) = - D1 MDProduct - (C1 MCPair - (S1 NoSelector (Rec1 f) :*: S1 NoSelector (Rec1 g))) - from1 (Pair f g) = M1 (M1 (M1 (Rec1 f) :*: M1 (Rec1 g))) - to1 (M1 (M1 (M1 f :*: M1 g))) = Pair (unRec1 f) (unRec1 g) - -data MDProduct -data MCPair - -instance Datatype MDProduct where - datatypeName _ = "Product" - moduleName _ = "Data.Functor.Product" - -instance Constructor MCPair where - conName _ = "Pair" -#endif - -#if __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable Product -deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a) - => Data (Product (f :: * -> *) (g :: * -> *) (a :: *)) -#endif - -instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where - liftEq eq (Pair x1 y1) (Pair x2 y2) = liftEq eq x1 x2 && liftEq eq y1 y2 - -instance (Ord1 f, Ord1 g) => Ord1 (Product f g) where - liftCompare comp (Pair x1 y1) (Pair x2 y2) = - liftCompare comp x1 x2 `mappend` liftCompare comp y1 y2 - -instance (Read1 f, Read1 g) => Read1 (Product f g) where - liftReadsPrec rp rl = readsData $ - readsBinaryWith (liftReadsPrec rp rl) (liftReadsPrec rp rl) "Pair" Pair - -instance (Show1 f, Show1 g) => Show1 (Product f g) where - liftShowsPrec sp sl d (Pair x y) = - showsBinaryWith (liftShowsPrec sp sl) (liftShowsPrec sp sl) "Pair" d x y - -instance (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a) - where (==) = eq1 -instance (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a) where - compare = compare1 -instance (Read1 f, Read1 g, Read a) => Read (Product f g a) where - readsPrec = readsPrec1 -instance (Show1 f, Show1 g, Show a) => Show (Product f g a) where - showsPrec = showsPrec1 - -instance (Functor f, Functor g) => Functor (Product f g) where - fmap f (Pair x y) = Pair (fmap f x) (fmap f y) - -instance (Foldable f, Foldable g) => Foldable (Product f g) where - foldMap f (Pair x y) = foldMap f x `mappend` foldMap f y - -instance (Traversable f, Traversable g) => Traversable (Product f g) where - traverse f (Pair x y) = Pair <$> traverse f x <*> traverse f y - -instance (Applicative f, Applicative g) => Applicative (Product f g) where - pure x = Pair (pure x) (pure x) - Pair f g <*> Pair x y = Pair (f <*> x) (g <*> y) - -instance (Alternative f, Alternative g) => Alternative (Product f g) where - empty = Pair empty empty - Pair x1 y1 <|> Pair x2 y2 = Pair (x1 <|> x2) (y1 <|> y2) - -instance (Monad f, Monad g) => Monad (Product f g) where -#if !(MIN_VERSION_base(4,8,0)) - return x = Pair (return x) (return x) -#endif - Pair m n >>= f = Pair (m >>= fstP . f) (n >>= sndP . f) - where - fstP (Pair a _) = a - sndP (Pair _ b) = b - -instance (MonadPlus f, MonadPlus g) => MonadPlus (Product f g) where - mzero = Pair mzero mzero - Pair x1 y1 `mplus` Pair x2 y2 = Pair (x1 `mplus` x2) (y1 `mplus` y2) - -instance (MonadFix f, MonadFix g) => MonadFix (Product f g) where - mfix f = Pair (mfix (fstP . f)) (mfix (sndP . f)) - where - fstP (Pair a _) = a - sndP (Pair _ b) = b - -#if MIN_VERSION_base(4,4,0) -instance (MonadZip f, MonadZip g) => MonadZip (Product f g) where - mzipWith f (Pair x1 y1) (Pair x2 y2) = Pair (mzipWith f x1 x2) (mzipWith f y1 y2) -#endif - -#if MIN_VERSION_base(4,12,0) -instance (Contravariant f, Contravariant g) => Contravariant (Product f g) where - contramap f (Pair a b) = Pair (contramap f a) (contramap f b) -#endif diff --git a/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Sum.hs b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Sum.hs deleted file mode 100644 index e6d1428b30e3..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Sum.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -#endif -#if __GLASGOW_HASKELL__ >= 706 -{-# LANGUAGE PolyKinds #-} -#endif -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE AutoDeriveTypeable #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : Data.Functor.Sum --- Copyright : (c) Ross Paterson 2014 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : portable --- --- Sums, lifted to functors. ------------------------------------------------------------------------------ - -module Data.Functor.Sum ( - Sum(..), - ) where - -import Control.Applicative -#if __GLASGOW_HASKELL__ >= 708 -import Data.Data -#endif -import Data.Foldable (Foldable(foldMap)) -import Data.Functor.Classes -#if MIN_VERSION_base(4,12,0) -import Data.Functor.Contravariant -#endif -import Data.Monoid (mappend) -import Data.Traversable (Traversable(traverse)) -#if __GLASGOW_HASKELL__ >= 702 -import GHC.Generics -#endif - --- | Lifted sum of functors. -data Sum f g a = InL (f a) | InR (g a) - -#if __GLASGOW_HASKELL__ >= 702 -deriving instance Generic (Sum f g a) - -instance Generic1 (Sum f g) where - type Rep1 (Sum f g) = - D1 MDSum (C1 MCInL (S1 NoSelector (Rec1 f)) - :+: C1 MCInR (S1 NoSelector (Rec1 g))) - from1 (InL f) = M1 (L1 (M1 (M1 (Rec1 f)))) - from1 (InR g) = M1 (R1 (M1 (M1 (Rec1 g)))) - to1 (M1 (L1 (M1 (M1 f)))) = InL (unRec1 f) - to1 (M1 (R1 (M1 (M1 g)))) = InR (unRec1 g) - -data MDSum -data MCInL -data MCInR - -instance Datatype MDSum where - datatypeName _ = "Sum" - moduleName _ = "Data.Functor.Sum" - -instance Constructor MCInL where - conName _ = "InL" - -instance Constructor MCInR where - conName _ = "InR" -#endif - -#if __GLASGOW_HASKELL__ >= 708 -deriving instance Typeable Sum -deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a) - => Data (Sum (f :: * -> *) (g :: * -> *) (a :: *)) -#endif - -instance (Eq1 f, Eq1 g) => Eq1 (Sum f g) where - liftEq eq (InL x1) (InL x2) = liftEq eq x1 x2 - liftEq _ (InL _) (InR _) = False - liftEq _ (InR _) (InL _) = False - liftEq eq (InR y1) (InR y2) = liftEq eq y1 y2 - -instance (Ord1 f, Ord1 g) => Ord1 (Sum f g) where - liftCompare comp (InL x1) (InL x2) = liftCompare comp x1 x2 - liftCompare _ (InL _) (InR _) = LT - liftCompare _ (InR _) (InL _) = GT - liftCompare comp (InR y1) (InR y2) = liftCompare comp y1 y2 - -instance (Read1 f, Read1 g) => Read1 (Sum f g) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp rl) "InL" InL `mappend` - readsUnaryWith (liftReadsPrec rp rl) "InR" InR - -instance (Show1 f, Show1 g) => Show1 (Sum f g) where - liftShowsPrec sp sl d (InL x) = - showsUnaryWith (liftShowsPrec sp sl) "InL" d x - liftShowsPrec sp sl d (InR y) = - showsUnaryWith (liftShowsPrec sp sl) "InR" d y - -instance (Eq1 f, Eq1 g, Eq a) => Eq (Sum f g a) where - (==) = eq1 -instance (Ord1 f, Ord1 g, Ord a) => Ord (Sum f g a) where - compare = compare1 -instance (Read1 f, Read1 g, Read a) => Read (Sum f g a) where - readsPrec = readsPrec1 -instance (Show1 f, Show1 g, Show a) => Show (Sum f g a) where - showsPrec = showsPrec1 - -instance (Functor f, Functor g) => Functor (Sum f g) where - fmap f (InL x) = InL (fmap f x) - fmap f (InR y) = InR (fmap f y) - -instance (Foldable f, Foldable g) => Foldable (Sum f g) where - foldMap f (InL x) = foldMap f x - foldMap f (InR y) = foldMap f y - -instance (Traversable f, Traversable g) => Traversable (Sum f g) where - traverse f (InL x) = InL <$> traverse f x - traverse f (InR y) = InR <$> traverse f y - -#if MIN_VERSION_base(4,12,0) -instance (Contravariant f, Contravariant g) => Contravariant (Sum f g) where - contramap f (InL xs) = InL (contramap f xs) - contramap f (InR ys) = InR (contramap f ys) -#endif diff --git a/third_party/bazel/rules_haskell/examples/transformers/transformers.cabal b/third_party/bazel/rules_haskell/examples/transformers/transformers.cabal deleted file mode 100644 index 945adda910fd..000000000000 --- a/third_party/bazel/rules_haskell/examples/transformers/transformers.cabal +++ /dev/null @@ -1,91 +0,0 @@ -name: transformers -version: 0.5.6.2 -license: BSD3 -license-file: LICENSE -author: Andy Gill, Ross Paterson -maintainer: Ross Paterson <R.Paterson@city.ac.uk> -bug-reports: http://hub.darcs.net/ross/transformers/issues -category: Control -synopsis: Concrete functor and monad transformers -description: - A portable library of functor and monad transformers, inspired by - the paper - . - * \"Functional Programming with Overloading and Higher-Order - Polymorphism\", by Mark P Jones, - in /Advanced School of Functional Programming/, 1995 - (<http://web.cecs.pdx.edu/~mpj/pubs/springschool.html>). - . - This package contains: - . - * the monad transformer class (in "Control.Monad.Trans.Class") - . - * concrete functor and monad transformers, each with associated - operations and functions to lift operations associated with other - transformers. - . - The package can be used on its own in portable Haskell code, in - which case operations need to be manually lifted through transformer - stacks (see "Control.Monad.Trans.Class" for some examples). - Alternatively, it can be used with the non-portable monad classes in - the @mtl@ or @monads-tf@ packages, which automatically lift operations - introduced by monad transformers through other transformers. -build-type: Simple -extra-source-files: - changelog -cabal-version: >= 1.6 - -source-repository head - type: darcs - location: http://hub.darcs.net/ross/transformers - -library - build-depends: base >= 2 && < 6 - hs-source-dirs: . - if !impl(ghc>=7.9) - -- Data.Functor.Identity was moved into base-4.8.0.0 (GHC 7.10) - -- see also https://ghc.haskell.org/trac/ghc/ticket/9664 - -- NB: using impl(ghc>=7.9) instead of fragile Cabal flags - hs-source-dirs: legacy/pre709 - exposed-modules: Data.Functor.Identity - if !impl(ghc>=7.11) - -- modules moved into base-4.9.0 (GHC 8.0) - -- see https://ghc.haskell.org/trac/ghc/ticket/10773 - -- see https://ghc.haskell.org/trac/ghc/ticket/11135 - hs-source-dirs: legacy/pre711 - exposed-modules: - Control.Monad.IO.Class - Data.Functor.Classes - Data.Functor.Compose - Data.Functor.Product - Data.Functor.Sum - if impl(ghc>=7.2 && <7.5) - -- Prior to GHC 7.5, GHC.Generics lived in ghc-prim - build-depends: ghc-prim - exposed-modules: - Control.Applicative.Backwards - Control.Applicative.Lift - Control.Monad.Signatures - Control.Monad.Trans.Accum - Control.Monad.Trans.Class - Control.Monad.Trans.Cont - Control.Monad.Trans.Except - Control.Monad.Trans.Error - Control.Monad.Trans.Identity - Control.Monad.Trans.List - Control.Monad.Trans.Maybe - Control.Monad.Trans.Reader - Control.Monad.Trans.RWS - Control.Monad.Trans.RWS.CPS - Control.Monad.Trans.RWS.Lazy - Control.Monad.Trans.RWS.Strict - Control.Monad.Trans.Select - Control.Monad.Trans.State - Control.Monad.Trans.State.Lazy - Control.Monad.Trans.State.Strict - Control.Monad.Trans.Writer - Control.Monad.Trans.Writer.CPS - Control.Monad.Trans.Writer.Lazy - Control.Monad.Trans.Writer.Strict - Data.Functor.Constant - Data.Functor.Reverse diff --git a/third_party/bazel/rules_haskell/examples/vector/BUILD.bazel b/third_party/bazel/rules_haskell/examples/vector/BUILD.bazel deleted file mode 100644 index 7c00806efe5f..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/BUILD.bazel +++ /dev/null @@ -1,38 +0,0 @@ -load( - "@io_tweag_rules_haskell//haskell:haskell.bzl", - "haskell_cc_import", - "haskell_library", - "haskell_toolchain_library", -) - -haskell_toolchain_library(name = "base") - -haskell_toolchain_library(name = "deepseq") - -haskell_toolchain_library(name = "ghc-prim") - -haskell_toolchain_library(name = "primitive") - -haskell_toolchain_library(name = "semigroups") - -haskell_library( - name = "vector", - testonly = 1, - srcs = glob(["Data/**/*.*hs"]), - compiler_flags = [ - "-Iexternal/io_tweag_rules_haskell_examples/vector/include", - "-Iexternal/io_tweag_rules_haskell_examples/vector/internal", - ], - extra_srcs = [ - "include/vector.h", - "internal/unbox-tuple-instances", - ], - version = "0", - visibility = ["//visibility:public"], - deps = [ - ":base", - ":deepseq", - ":ghc-prim", - "//primitive", - ], -) diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector.hs deleted file mode 100644 index 21b61960ca40..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/Data/Vector.hs +++ /dev/null @@ -1,1719 +0,0 @@ -{-# LANGUAGE CPP - , DeriveDataTypeable - , FlexibleInstances - , MultiParamTypeClasses - , TypeFamilies - , Rank2Types - , BangPatterns - #-} - --- | --- Module : Data.Vector --- Copyright : (c) Roman Leshchinskiy 2008-2010 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Stability : experimental --- Portability : non-portable --- --- A library for boxed vectors (that is, polymorphic arrays capable of --- holding any Haskell value). The vectors come in two flavours: --- --- * mutable --- --- * immutable --- --- and support a rich interface of both list-like operations, and bulk --- array operations. --- --- For unboxed arrays, use "Data.Vector.Unboxed" --- - -module Data.Vector ( - -- * Boxed vectors - Vector, MVector, - - -- * Accessors - - -- ** Length information - length, null, - - -- ** Indexing - (!), (!?), head, last, - unsafeIndex, unsafeHead, unsafeLast, - - -- ** Monadic indexing - indexM, headM, lastM, - unsafeIndexM, unsafeHeadM, unsafeLastM, - - -- ** Extracting subvectors (slicing) - slice, init, tail, take, drop, splitAt, - unsafeSlice, unsafeInit, unsafeTail, unsafeTake, unsafeDrop, - - -- * Construction - - -- ** Initialisation - empty, singleton, replicate, generate, iterateN, - - -- ** Monadic initialisation - replicateM, generateM, iterateNM, create, createT, - - -- ** Unfolding - unfoldr, unfoldrN, - unfoldrM, unfoldrNM, - constructN, constructrN, - - -- ** Enumeration - enumFromN, enumFromStepN, enumFromTo, enumFromThenTo, - - -- ** Concatenation - cons, snoc, (++), concat, - - -- ** Restricting memory usage - force, - - -- * Modifying vectors - - -- ** Bulk updates - (//), update, update_, - unsafeUpd, unsafeUpdate, unsafeUpdate_, - - -- ** Accumulations - accum, accumulate, accumulate_, - unsafeAccum, unsafeAccumulate, unsafeAccumulate_, - - -- ** Permutations - reverse, backpermute, unsafeBackpermute, - - -- ** Safe destructive updates - modify, - - -- * Elementwise operations - - -- ** Indexing - indexed, - - -- ** Mapping - map, imap, concatMap, - - -- ** Monadic mapping - mapM, imapM, mapM_, imapM_, forM, forM_, - - -- ** Zipping - zipWith, zipWith3, zipWith4, zipWith5, zipWith6, - izipWith, izipWith3, izipWith4, izipWith5, izipWith6, - zip, zip3, zip4, zip5, zip6, - - -- ** Monadic zipping - zipWithM, izipWithM, zipWithM_, izipWithM_, - - -- ** Unzipping - unzip, unzip3, unzip4, unzip5, unzip6, - - -- * Working with predicates - - -- ** Filtering - filter, ifilter, uniq, - mapMaybe, imapMaybe, - filterM, - takeWhile, dropWhile, - - -- ** Partitioning - partition, unstablePartition, span, break, - - -- ** Searching - elem, notElem, find, findIndex, findIndices, elemIndex, elemIndices, - - -- * Folding - foldl, foldl1, foldl', foldl1', foldr, foldr1, foldr', foldr1', - ifoldl, ifoldl', ifoldr, ifoldr', - - -- ** Specialised folds - all, any, and, or, - sum, product, - maximum, maximumBy, minimum, minimumBy, - minIndex, minIndexBy, maxIndex, maxIndexBy, - - -- ** Monadic folds - foldM, ifoldM, foldM', ifoldM', - fold1M, fold1M',foldM_, ifoldM_, - foldM'_, ifoldM'_, fold1M_, fold1M'_, - - -- ** Monadic sequencing - sequence, sequence_, - - -- * Prefix sums (scans) - prescanl, prescanl', - postscanl, postscanl', - scanl, scanl', scanl1, scanl1', - iscanl, iscanl', - prescanr, prescanr', - postscanr, postscanr', - scanr, scanr', scanr1, scanr1', - iscanr, iscanr', - - -- * Conversions - - -- ** Lists - toList, Data.Vector.fromList, Data.Vector.fromListN, - - -- ** Other vector types - G.convert, - - -- ** Mutable vectors - freeze, thaw, copy, unsafeFreeze, unsafeThaw, unsafeCopy -) where - -import qualified Data.Vector.Generic as G -import Data.Vector.Mutable ( MVector(..) ) -import Data.Primitive.Array -import qualified Data.Vector.Fusion.Bundle as Bundle - -import Control.DeepSeq ( NFData, rnf ) -import Control.Monad ( MonadPlus(..), liftM, ap ) -import Control.Monad.ST ( ST ) -import Control.Monad.Primitive - - -import Control.Monad.Zip - -import Prelude hiding ( length, null, - replicate, (++), concat, - head, last, - init, tail, take, drop, splitAt, reverse, - map, concatMap, - zipWith, zipWith3, zip, zip3, unzip, unzip3, - filter, takeWhile, dropWhile, span, break, - elem, notElem, - foldl, foldl1, foldr, foldr1, - all, any, and, or, sum, product, minimum, maximum, - scanl, scanl1, scanr, scanr1, - enumFromTo, enumFromThenTo, - mapM, mapM_, sequence, sequence_ ) - -#if MIN_VERSION_base(4,9,0) -import Data.Functor.Classes (Eq1 (..), Ord1 (..), Read1 (..), Show1 (..)) -#endif - -import Data.Typeable ( Typeable ) -import Data.Data ( Data(..) ) -import Text.Read ( Read(..), readListPrecDefault ) -import Data.Semigroup ( Semigroup(..) ) - -import qualified Control.Applicative as Applicative -import qualified Data.Foldable as Foldable -import qualified Data.Traversable as Traversable - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid ( Monoid(..) ) -#endif - -#if __GLASGOW_HASKELL__ >= 708 -import qualified GHC.Exts as Exts (IsList(..)) -#endif - - --- | Boxed vectors, supporting efficient slicing. -data Vector a = Vector {-# UNPACK #-} !Int - {-# UNPACK #-} !Int - {-# UNPACK #-} !(Array a) - deriving ( Typeable ) - -instance NFData a => NFData (Vector a) where - rnf (Vector i n arr) = rnfAll i - where - rnfAll ix | ix < n = rnf (indexArray arr ix) `seq` rnfAll (ix+1) - | otherwise = () - -instance Show a => Show (Vector a) where - showsPrec = G.showsPrec - -instance Read a => Read (Vector a) where - readPrec = G.readPrec - readListPrec = readListPrecDefault - -#if MIN_VERSION_base(4,9,0) -instance Show1 Vector where - liftShowsPrec = G.liftShowsPrec - -instance Read1 Vector where - liftReadsPrec = G.liftReadsPrec -#endif - -#if __GLASGOW_HASKELL__ >= 708 - -instance Exts.IsList (Vector a) where - type Item (Vector a) = a - fromList = Data.Vector.fromList - fromListN = Data.Vector.fromListN - toList = toList -#endif - -instance Data a => Data (Vector a) where - gfoldl = G.gfoldl - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = G.mkType "Data.Vector.Vector" - dataCast1 = G.dataCast - -type instance G.Mutable Vector = MVector - -instance G.Vector Vector a where - {-# INLINE basicUnsafeFreeze #-} - basicUnsafeFreeze (MVector i n marr) - = Vector i n `liftM` unsafeFreezeArray marr - - {-# INLINE basicUnsafeThaw #-} - basicUnsafeThaw (Vector i n arr) - = MVector i n `liftM` unsafeThawArray arr - - {-# INLINE basicLength #-} - basicLength (Vector _ n _) = n - - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice j n (Vector i _ arr) = Vector (i+j) n arr - - {-# INLINE basicUnsafeIndexM #-} - basicUnsafeIndexM (Vector i _ arr) j = indexArrayM arr (i+j) - - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy (MVector i n dst) (Vector j _ src) - = copyArray dst i src j n - --- See http://trac.haskell.org/vector/ticket/12 -instance Eq a => Eq (Vector a) where - {-# INLINE (==) #-} - xs == ys = Bundle.eq (G.stream xs) (G.stream ys) - - {-# INLINE (/=) #-} - xs /= ys = not (Bundle.eq (G.stream xs) (G.stream ys)) - --- See http://trac.haskell.org/vector/ticket/12 -instance Ord a => Ord (Vector a) where - {-# INLINE compare #-} - compare xs ys = Bundle.cmp (G.stream xs) (G.stream ys) - - {-# INLINE (<) #-} - xs < ys = Bundle.cmp (G.stream xs) (G.stream ys) == LT - - {-# INLINE (<=) #-} - xs <= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= GT - - {-# INLINE (>) #-} - xs > ys = Bundle.cmp (G.stream xs) (G.stream ys) == GT - - {-# INLINE (>=) #-} - xs >= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= LT - -#if MIN_VERSION_base(4,9,0) -instance Eq1 Vector where - liftEq eq xs ys = Bundle.eqBy eq (G.stream xs) (G.stream ys) - -instance Ord1 Vector where - liftCompare cmp xs ys = Bundle.cmpBy cmp (G.stream xs) (G.stream ys) -#endif - -instance Semigroup (Vector a) where - {-# INLINE (<>) #-} - (<>) = (++) - - {-# INLINE sconcat #-} - sconcat = G.concatNE - -instance Monoid (Vector a) where - {-# INLINE mempty #-} - mempty = empty - - {-# INLINE mappend #-} - mappend = (++) - - {-# INLINE mconcat #-} - mconcat = concat - -instance Functor Vector where - {-# INLINE fmap #-} - fmap = map - -instance Monad Vector where - {-# INLINE return #-} - return = Applicative.pure - - {-# INLINE (>>=) #-} - (>>=) = flip concatMap - - {-# INLINE fail #-} - fail _ = empty - -instance MonadPlus Vector where - {-# INLINE mzero #-} - mzero = empty - - {-# INLINE mplus #-} - mplus = (++) - -instance MonadZip Vector where - {-# INLINE mzip #-} - mzip = zip - - {-# INLINE mzipWith #-} - mzipWith = zipWith - - {-# INLINE munzip #-} - munzip = unzip - - -instance Applicative.Applicative Vector where - {-# INLINE pure #-} - pure = singleton - - {-# INLINE (<*>) #-} - (<*>) = ap - -instance Applicative.Alternative Vector where - {-# INLINE empty #-} - empty = empty - - {-# INLINE (<|>) #-} - (<|>) = (++) - -instance Foldable.Foldable Vector where - {-# INLINE foldr #-} - foldr = foldr - - {-# INLINE foldl #-} - foldl = foldl - - {-# INLINE foldr1 #-} - foldr1 = foldr1 - - {-# INLINE foldl1 #-} - foldl1 = foldl1 - -#if MIN_VERSION_base(4,6,0) - {-# INLINE foldr' #-} - foldr' = foldr' - - {-# INLINE foldl' #-} - foldl' = foldl' -#endif - -#if MIN_VERSION_base(4,8,0) - {-# INLINE toList #-} - toList = toList - - {-# INLINE length #-} - length = length - - {-# INLINE null #-} - null = null - - {-# INLINE elem #-} - elem = elem - - {-# INLINE maximum #-} - maximum = maximum - - {-# INLINE minimum #-} - minimum = minimum - - {-# INLINE sum #-} - sum = sum - - {-# INLINE product #-} - product = product -#endif - -instance Traversable.Traversable Vector where - {-# INLINE traverse #-} - traverse f xs = Data.Vector.fromList Applicative.<$> Traversable.traverse f (toList xs) - - {-# INLINE mapM #-} - mapM = mapM - - {-# INLINE sequence #-} - sequence = sequence - --- Length information --- ------------------ - --- | /O(1)/ Yield the length of the vector -length :: Vector a -> Int -{-# INLINE length #-} -length = G.length - --- | /O(1)/ Test whether a vector is empty -null :: Vector a -> Bool -{-# INLINE null #-} -null = G.null - --- Indexing --- -------- - --- | O(1) Indexing -(!) :: Vector a -> Int -> a -{-# INLINE (!) #-} -(!) = (G.!) - --- | O(1) Safe indexing -(!?) :: Vector a -> Int -> Maybe a -{-# INLINE (!?) #-} -(!?) = (G.!?) - --- | /O(1)/ First element -head :: Vector a -> a -{-# INLINE head #-} -head = G.head - --- | /O(1)/ Last element -last :: Vector a -> a -{-# INLINE last #-} -last = G.last - --- | /O(1)/ Unsafe indexing without bounds checking -unsafeIndex :: Vector a -> Int -> a -{-# INLINE unsafeIndex #-} -unsafeIndex = G.unsafeIndex - --- | /O(1)/ First element without checking if the vector is empty -unsafeHead :: Vector a -> a -{-# INLINE unsafeHead #-} -unsafeHead = G.unsafeHead - --- | /O(1)/ Last element without checking if the vector is empty -unsafeLast :: Vector a -> a -{-# INLINE unsafeLast #-} -unsafeLast = G.unsafeLast - --- Monadic indexing --- ---------------- - --- | /O(1)/ Indexing in a monad. --- --- The monad allows operations to be strict in the vector when necessary. --- Suppose vector copying is implemented like this: --- --- > copy mv v = ... write mv i (v ! i) ... --- --- For lazy vectors, @v ! i@ would not be evaluated which means that @mv@ --- would unnecessarily retain a reference to @v@ in each element written. --- --- With 'indexM', copying can be implemented like this instead: --- --- > copy mv v = ... do --- > x <- indexM v i --- > write mv i x --- --- Here, no references to @v@ are retained because indexing (but /not/ the --- elements) is evaluated eagerly. --- -indexM :: Monad m => Vector a -> Int -> m a -{-# INLINE indexM #-} -indexM = G.indexM - --- | /O(1)/ First element of a vector in a monad. See 'indexM' for an --- explanation of why this is useful. -headM :: Monad m => Vector a -> m a -{-# INLINE headM #-} -headM = G.headM - --- | /O(1)/ Last element of a vector in a monad. See 'indexM' for an --- explanation of why this is useful. -lastM :: Monad m => Vector a -> m a -{-# INLINE lastM #-} -lastM = G.lastM - --- | /O(1)/ Indexing in a monad without bounds checks. See 'indexM' for an --- explanation of why this is useful. -unsafeIndexM :: Monad m => Vector a -> Int -> m a -{-# INLINE unsafeIndexM #-} -unsafeIndexM = G.unsafeIndexM - --- | /O(1)/ First element in a monad without checking for empty vectors. --- See 'indexM' for an explanation of why this is useful. -unsafeHeadM :: Monad m => Vector a -> m a -{-# INLINE unsafeHeadM #-} -unsafeHeadM = G.unsafeHeadM - --- | /O(1)/ Last element in a monad without checking for empty vectors. --- See 'indexM' for an explanation of why this is useful. -unsafeLastM :: Monad m => Vector a -> m a -{-# INLINE unsafeLastM #-} -unsafeLastM = G.unsafeLastM - --- Extracting subvectors (slicing) --- ------------------------------- - --- | /O(1)/ Yield a slice of the vector without copying it. The vector must --- contain at least @i+n@ elements. -slice :: Int -- ^ @i@ starting index - -> Int -- ^ @n@ length - -> Vector a - -> Vector a -{-# INLINE slice #-} -slice = G.slice - --- | /O(1)/ Yield all but the last element without copying. The vector may not --- be empty. -init :: Vector a -> Vector a -{-# INLINE init #-} -init = G.init - --- | /O(1)/ Yield all but the first element without copying. The vector may not --- be empty. -tail :: Vector a -> Vector a -{-# INLINE tail #-} -tail = G.tail - --- | /O(1)/ Yield at the first @n@ elements without copying. The vector may --- contain less than @n@ elements in which case it is returned unchanged. -take :: Int -> Vector a -> Vector a -{-# INLINE take #-} -take = G.take - --- | /O(1)/ Yield all but the first @n@ elements without copying. The vector may --- contain less than @n@ elements in which case an empty vector is returned. -drop :: Int -> Vector a -> Vector a -{-# INLINE drop #-} -drop = G.drop - --- | /O(1)/ Yield the first @n@ elements paired with the remainder without copying. --- --- Note that @'splitAt' n v@ is equivalent to @('take' n v, 'drop' n v)@ --- but slightly more efficient. -{-# INLINE splitAt #-} -splitAt :: Int -> Vector a -> (Vector a, Vector a) -splitAt = G.splitAt - --- | /O(1)/ Yield a slice of the vector without copying. The vector must --- contain at least @i+n@ elements but this is not checked. -unsafeSlice :: Int -- ^ @i@ starting index - -> Int -- ^ @n@ length - -> Vector a - -> Vector a -{-# INLINE unsafeSlice #-} -unsafeSlice = G.unsafeSlice - --- | /O(1)/ Yield all but the last element without copying. The vector may not --- be empty but this is not checked. -unsafeInit :: Vector a -> Vector a -{-# INLINE unsafeInit #-} -unsafeInit = G.unsafeInit - --- | /O(1)/ Yield all but the first element without copying. The vector may not --- be empty but this is not checked. -unsafeTail :: Vector a -> Vector a -{-# INLINE unsafeTail #-} -unsafeTail = G.unsafeTail - --- | /O(1)/ Yield the first @n@ elements without copying. The vector must --- contain at least @n@ elements but this is not checked. -unsafeTake :: Int -> Vector a -> Vector a -{-# INLINE unsafeTake #-} -unsafeTake = G.unsafeTake - --- | /O(1)/ Yield all but the first @n@ elements without copying. The vector --- must contain at least @n@ elements but this is not checked. -unsafeDrop :: Int -> Vector a -> Vector a -{-# INLINE unsafeDrop #-} -unsafeDrop = G.unsafeDrop - --- Initialisation --- -------------- - --- | /O(1)/ Empty vector -empty :: Vector a -{-# INLINE empty #-} -empty = G.empty - --- | /O(1)/ Vector with exactly one element -singleton :: a -> Vector a -{-# INLINE singleton #-} -singleton = G.singleton - --- | /O(n)/ Vector of the given length with the same value in each position -replicate :: Int -> a -> Vector a -{-# INLINE replicate #-} -replicate = G.replicate - --- | /O(n)/ Construct a vector of the given length by applying the function to --- each index -generate :: Int -> (Int -> a) -> Vector a -{-# INLINE generate #-} -generate = G.generate - --- | /O(n)/ Apply function n times to value. Zeroth element is original value. -iterateN :: Int -> (a -> a) -> a -> Vector a -{-# INLINE iterateN #-} -iterateN = G.iterateN - --- Unfolding --- --------- - --- | /O(n)/ Construct a vector by repeatedly applying the generator function --- to a seed. The generator function yields 'Just' the next element and the --- new seed or 'Nothing' if there are no more elements. --- --- > unfoldr (\n -> if n == 0 then Nothing else Just (n,n-1)) 10 --- > = <10,9,8,7,6,5,4,3,2,1> -unfoldr :: (b -> Maybe (a, b)) -> b -> Vector a -{-# INLINE unfoldr #-} -unfoldr = G.unfoldr - --- | /O(n)/ Construct a vector with at most @n@ elements by repeatedly applying --- the generator function to a seed. The generator function yields 'Just' the --- next element and the new seed or 'Nothing' if there are no more elements. --- --- > unfoldrN 3 (\n -> Just (n,n-1)) 10 = <10,9,8> -unfoldrN :: Int -> (b -> Maybe (a, b)) -> b -> Vector a -{-# INLINE unfoldrN #-} -unfoldrN = G.unfoldrN - --- | /O(n)/ Construct a vector by repeatedly applying the monadic --- generator function to a seed. The generator function yields 'Just' --- the next element and the new seed or 'Nothing' if there are no more --- elements. -unfoldrM :: (Monad m) => (b -> m (Maybe (a, b))) -> b -> m (Vector a) -{-# INLINE unfoldrM #-} -unfoldrM = G.unfoldrM - --- | /O(n)/ Construct a vector by repeatedly applying the monadic --- generator function to a seed. The generator function yields 'Just' --- the next element and the new seed or 'Nothing' if there are no more --- elements. -unfoldrNM :: (Monad m) => Int -> (b -> m (Maybe (a, b))) -> b -> m (Vector a) -{-# INLINE unfoldrNM #-} -unfoldrNM = G.unfoldrNM - --- | /O(n)/ Construct a vector with @n@ elements by repeatedly applying the --- generator function to the already constructed part of the vector. --- --- > constructN 3 f = let a = f <> ; b = f <a> ; c = f <a,b> in f <a,b,c> --- -constructN :: Int -> (Vector a -> a) -> Vector a -{-# INLINE constructN #-} -constructN = G.constructN - --- | /O(n)/ Construct a vector with @n@ elements from right to left by --- repeatedly applying the generator function to the already constructed part --- of the vector. --- --- > constructrN 3 f = let a = f <> ; b = f<a> ; c = f <b,a> in f <c,b,a> --- -constructrN :: Int -> (Vector a -> a) -> Vector a -{-# INLINE constructrN #-} -constructrN = G.constructrN - --- Enumeration --- ----------- - --- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+1@ --- etc. This operation is usually more efficient than 'enumFromTo'. --- --- > enumFromN 5 3 = <5,6,7> -enumFromN :: Num a => a -> Int -> Vector a -{-# INLINE enumFromN #-} -enumFromN = G.enumFromN - --- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+y@, --- @x+y+y@ etc. This operations is usually more efficient than 'enumFromThenTo'. --- --- > enumFromStepN 1 0.1 5 = <1,1.1,1.2,1.3,1.4> -enumFromStepN :: Num a => a -> a -> Int -> Vector a -{-# INLINE enumFromStepN #-} -enumFromStepN = G.enumFromStepN - --- | /O(n)/ Enumerate values from @x@ to @y@. --- --- /WARNING:/ This operation can be very inefficient. If at all possible, use --- 'enumFromN' instead. -enumFromTo :: Enum a => a -> a -> Vector a -{-# INLINE enumFromTo #-} -enumFromTo = G.enumFromTo - --- | /O(n)/ Enumerate values from @x@ to @y@ with a specific step @z@. --- --- /WARNING:/ This operation can be very inefficient. If at all possible, use --- 'enumFromStepN' instead. -enumFromThenTo :: Enum a => a -> a -> a -> Vector a -{-# INLINE enumFromThenTo #-} -enumFromThenTo = G.enumFromThenTo - --- Concatenation --- ------------- - --- | /O(n)/ Prepend an element -cons :: a -> Vector a -> Vector a -{-# INLINE cons #-} -cons = G.cons - --- | /O(n)/ Append an element -snoc :: Vector a -> a -> Vector a -{-# INLINE snoc #-} -snoc = G.snoc - -infixr 5 ++ --- | /O(m+n)/ Concatenate two vectors -(++) :: Vector a -> Vector a -> Vector a -{-# INLINE (++) #-} -(++) = (G.++) - --- | /O(n)/ Concatenate all vectors in the list -concat :: [Vector a] -> Vector a -{-# INLINE concat #-} -concat = G.concat - --- Monadic initialisation --- ---------------------- - --- | /O(n)/ Execute the monadic action the given number of times and store the --- results in a vector. -replicateM :: Monad m => Int -> m a -> m (Vector a) -{-# INLINE replicateM #-} -replicateM = G.replicateM - --- | /O(n)/ Construct a vector of the given length by applying the monadic --- action to each index -generateM :: Monad m => Int -> (Int -> m a) -> m (Vector a) -{-# INLINE generateM #-} -generateM = G.generateM - --- | /O(n)/ Apply monadic function n times to value. Zeroth element is original value. -iterateNM :: Monad m => Int -> (a -> m a) -> a -> m (Vector a) -{-# INLINE iterateNM #-} -iterateNM = G.iterateNM - --- | Execute the monadic action and freeze the resulting vector. --- --- @ --- create (do { v \<- new 2; write v 0 \'a\'; write v 1 \'b\'; return v }) = \<'a','b'\> --- @ -create :: (forall s. ST s (MVector s a)) -> Vector a -{-# INLINE create #-} --- NOTE: eta-expanded due to http://hackage.haskell.org/trac/ghc/ticket/4120 -create p = G.create p - --- | Execute the monadic action and freeze the resulting vectors. -createT :: Traversable.Traversable f => (forall s. ST s (f (MVector s a))) -> f (Vector a) -{-# INLINE createT #-} -createT p = G.createT p - - - --- Restricting memory usage --- ------------------------ - --- | /O(n)/ Yield the argument but force it not to retain any extra memory, --- possibly by copying it. --- --- This is especially useful when dealing with slices. For example: --- --- > force (slice 0 2 <huge vector>) --- --- Here, the slice retains a reference to the huge vector. Forcing it creates --- a copy of just the elements that belong to the slice and allows the huge --- vector to be garbage collected. -force :: Vector a -> Vector a -{-# INLINE force #-} -force = G.force - --- Bulk updates --- ------------ - --- | /O(m+n)/ For each pair @(i,a)@ from the list, replace the vector --- element at position @i@ by @a@. --- --- > <5,9,2,7> // [(2,1),(0,3),(2,8)] = <3,9,8,7> --- -(//) :: Vector a -- ^ initial vector (of length @m@) - -> [(Int, a)] -- ^ list of index/value pairs (of length @n@) - -> Vector a -{-# INLINE (//) #-} -(//) = (G.//) - --- | /O(m+n)/ For each pair @(i,a)@ from the vector of index/value pairs, --- replace the vector element at position @i@ by @a@. --- --- > update <5,9,2,7> <(2,1),(0,3),(2,8)> = <3,9,8,7> --- -update :: Vector a -- ^ initial vector (of length @m@) - -> Vector (Int, a) -- ^ vector of index/value pairs (of length @n@) - -> Vector a -{-# INLINE update #-} -update = G.update - --- | /O(m+min(n1,n2))/ For each index @i@ from the index vector and the --- corresponding value @a@ from the value vector, replace the element of the --- initial vector at position @i@ by @a@. --- --- > update_ <5,9,2,7> <2,0,2> <1,3,8> = <3,9,8,7> --- --- The function 'update' provides the same functionality and is usually more --- convenient. --- --- @ --- update_ xs is ys = 'update' xs ('zip' is ys) --- @ -update_ :: Vector a -- ^ initial vector (of length @m@) - -> Vector Int -- ^ index vector (of length @n1@) - -> Vector a -- ^ value vector (of length @n2@) - -> Vector a -{-# INLINE update_ #-} -update_ = G.update_ - --- | Same as ('//') but without bounds checking. -unsafeUpd :: Vector a -> [(Int, a)] -> Vector a -{-# INLINE unsafeUpd #-} -unsafeUpd = G.unsafeUpd - --- | Same as 'update' but without bounds checking. -unsafeUpdate :: Vector a -> Vector (Int, a) -> Vector a -{-# INLINE unsafeUpdate #-} -unsafeUpdate = G.unsafeUpdate - --- | Same as 'update_' but without bounds checking. -unsafeUpdate_ :: Vector a -> Vector Int -> Vector a -> Vector a -{-# INLINE unsafeUpdate_ #-} -unsafeUpdate_ = G.unsafeUpdate_ - --- Accumulations --- ------------- - --- | /O(m+n)/ For each pair @(i,b)@ from the list, replace the vector element --- @a@ at position @i@ by @f a b@. --- --- > accum (+) <5,9,2> [(2,4),(1,6),(0,3),(1,7)] = <5+3, 9+6+7, 2+4> -accum :: (a -> b -> a) -- ^ accumulating function @f@ - -> Vector a -- ^ initial vector (of length @m@) - -> [(Int,b)] -- ^ list of index/value pairs (of length @n@) - -> Vector a -{-# INLINE accum #-} -accum = G.accum - --- | /O(m+n)/ For each pair @(i,b)@ from the vector of pairs, replace the vector --- element @a@ at position @i@ by @f a b@. --- --- > accumulate (+) <5,9,2> <(2,4),(1,6),(0,3),(1,7)> = <5+3, 9+6+7, 2+4> -accumulate :: (a -> b -> a) -- ^ accumulating function @f@ - -> Vector a -- ^ initial vector (of length @m@) - -> Vector (Int,b) -- ^ vector of index/value pairs (of length @n@) - -> Vector a -{-# INLINE accumulate #-} -accumulate = G.accumulate - --- | /O(m+min(n1,n2))/ For each index @i@ from the index vector and the --- corresponding value @b@ from the the value vector, --- replace the element of the initial vector at --- position @i@ by @f a b@. --- --- > accumulate_ (+) <5,9,2> <2,1,0,1> <4,6,3,7> = <5+3, 9+6+7, 2+4> --- --- The function 'accumulate' provides the same functionality and is usually more --- convenient. --- --- @ --- accumulate_ f as is bs = 'accumulate' f as ('zip' is bs) --- @ -accumulate_ :: (a -> b -> a) -- ^ accumulating function @f@ - -> Vector a -- ^ initial vector (of length @m@) - -> Vector Int -- ^ index vector (of length @n1@) - -> Vector b -- ^ value vector (of length @n2@) - -> Vector a -{-# INLINE accumulate_ #-} -accumulate_ = G.accumulate_ - --- | Same as 'accum' but without bounds checking. -unsafeAccum :: (a -> b -> a) -> Vector a -> [(Int,b)] -> Vector a -{-# INLINE unsafeAccum #-} -unsafeAccum = G.unsafeAccum - --- | Same as 'accumulate' but without bounds checking. -unsafeAccumulate :: (a -> b -> a) -> Vector a -> Vector (Int,b) -> Vector a -{-# INLINE unsafeAccumulate #-} -unsafeAccumulate = G.unsafeAccumulate - --- | Same as 'accumulate_' but without bounds checking. -unsafeAccumulate_ - :: (a -> b -> a) -> Vector a -> Vector Int -> Vector b -> Vector a -{-# INLINE unsafeAccumulate_ #-} -unsafeAccumulate_ = G.unsafeAccumulate_ - --- Permutations --- ------------ - --- | /O(n)/ Reverse a vector -reverse :: Vector a -> Vector a -{-# INLINE reverse #-} -reverse = G.reverse - --- | /O(n)/ Yield the vector obtained by replacing each element @i@ of the --- index vector by @xs'!'i@. This is equivalent to @'map' (xs'!') is@ but is --- often much more efficient. --- --- > backpermute <a,b,c,d> <0,3,2,3,1,0> = <a,d,c,d,b,a> -backpermute :: Vector a -> Vector Int -> Vector a -{-# INLINE backpermute #-} -backpermute = G.backpermute - --- | Same as 'backpermute' but without bounds checking. -unsafeBackpermute :: Vector a -> Vector Int -> Vector a -{-# INLINE unsafeBackpermute #-} -unsafeBackpermute = G.unsafeBackpermute - --- Safe destructive updates --- ------------------------ - --- | Apply a destructive operation to a vector. The operation will be --- performed in place if it is safe to do so and will modify a copy of the --- vector otherwise. --- --- @ --- modify (\\v -> write v 0 \'x\') ('replicate' 3 \'a\') = \<\'x\',\'a\',\'a\'\> --- @ -modify :: (forall s. MVector s a -> ST s ()) -> Vector a -> Vector a -{-# INLINE modify #-} -modify p = G.modify p - --- Indexing --- -------- - --- | /O(n)/ Pair each element in a vector with its index -indexed :: Vector a -> Vector (Int,a) -{-# INLINE indexed #-} -indexed = G.indexed - --- Mapping --- ------- - --- | /O(n)/ Map a function over a vector -map :: (a -> b) -> Vector a -> Vector b -{-# INLINE map #-} -map = G.map - --- | /O(n)/ Apply a function to every element of a vector and its index -imap :: (Int -> a -> b) -> Vector a -> Vector b -{-# INLINE imap #-} -imap = G.imap - --- | Map a function over a vector and concatenate the results. -concatMap :: (a -> Vector b) -> Vector a -> Vector b -{-# INLINE concatMap #-} -concatMap = G.concatMap - --- Monadic mapping --- --------------- - --- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a --- vector of results -mapM :: Monad m => (a -> m b) -> Vector a -> m (Vector b) -{-# INLINE mapM #-} -mapM = G.mapM - --- | /O(n)/ Apply the monadic action to every element of a vector and its --- index, yielding a vector of results -imapM :: Monad m => (Int -> a -> m b) -> Vector a -> m (Vector b) -{-# INLINE imapM #-} -imapM = G.imapM - --- | /O(n)/ Apply the monadic action to all elements of a vector and ignore the --- results -mapM_ :: Monad m => (a -> m b) -> Vector a -> m () -{-# INLINE mapM_ #-} -mapM_ = G.mapM_ - --- | /O(n)/ Apply the monadic action to every element of a vector and its --- index, ignoring the results -imapM_ :: Monad m => (Int -> a -> m b) -> Vector a -> m () -{-# INLINE imapM_ #-} -imapM_ = G.imapM_ - --- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a --- vector of results. Equivalent to @flip 'mapM'@. -forM :: Monad m => Vector a -> (a -> m b) -> m (Vector b) -{-# INLINE forM #-} -forM = G.forM - --- | /O(n)/ Apply the monadic action to all elements of a vector and ignore the --- results. Equivalent to @flip 'mapM_'@. -forM_ :: Monad m => Vector a -> (a -> m b) -> m () -{-# INLINE forM_ #-} -forM_ = G.forM_ - --- Zipping --- ------- - --- | /O(min(m,n))/ Zip two vectors with the given function. -zipWith :: (a -> b -> c) -> Vector a -> Vector b -> Vector c -{-# INLINE zipWith #-} -zipWith = G.zipWith - --- | Zip three vectors with the given function. -zipWith3 :: (a -> b -> c -> d) -> Vector a -> Vector b -> Vector c -> Vector d -{-# INLINE zipWith3 #-} -zipWith3 = G.zipWith3 - -zipWith4 :: (a -> b -> c -> d -> e) - -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e -{-# INLINE zipWith4 #-} -zipWith4 = G.zipWith4 - -zipWith5 :: (a -> b -> c -> d -> e -> f) - -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e - -> Vector f -{-# INLINE zipWith5 #-} -zipWith5 = G.zipWith5 - -zipWith6 :: (a -> b -> c -> d -> e -> f -> g) - -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e - -> Vector f -> Vector g -{-# INLINE zipWith6 #-} -zipWith6 = G.zipWith6 - --- | /O(min(m,n))/ Zip two vectors with a function that also takes the --- elements' indices. -izipWith :: (Int -> a -> b -> c) -> Vector a -> Vector b -> Vector c -{-# INLINE izipWith #-} -izipWith = G.izipWith - --- | Zip three vectors and their indices with the given function. -izipWith3 :: (Int -> a -> b -> c -> d) - -> Vector a -> Vector b -> Vector c -> Vector d -{-# INLINE izipWith3 #-} -izipWith3 = G.izipWith3 - -izipWith4 :: (Int -> a -> b -> c -> d -> e) - -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e -{-# INLINE izipWith4 #-} -izipWith4 = G.izipWith4 - -izipWith5 :: (Int -> a -> b -> c -> d -> e -> f) - -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e - -> Vector f -{-# INLINE izipWith5 #-} -izipWith5 = G.izipWith5 - -izipWith6 :: (Int -> a -> b -> c -> d -> e -> f -> g) - -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e - -> Vector f -> Vector g -{-# INLINE izipWith6 #-} -izipWith6 = G.izipWith6 - --- | Elementwise pairing of array elements. -zip :: Vector a -> Vector b -> Vector (a, b) -{-# INLINE zip #-} -zip = G.zip - --- | zip together three vectors into a vector of triples -zip3 :: Vector a -> Vector b -> Vector c -> Vector (a, b, c) -{-# INLINE zip3 #-} -zip3 = G.zip3 - -zip4 :: Vector a -> Vector b -> Vector c -> Vector d - -> Vector (a, b, c, d) -{-# INLINE zip4 #-} -zip4 = G.zip4 - -zip5 :: Vector a -> Vector b -> Vector c -> Vector d -> Vector e - -> Vector (a, b, c, d, e) -{-# INLINE zip5 #-} -zip5 = G.zip5 - -zip6 :: Vector a -> Vector b -> Vector c -> Vector d -> Vector e -> Vector f - -> Vector (a, b, c, d, e, f) -{-# INLINE zip6 #-} -zip6 = G.zip6 - --- Unzipping --- --------- - --- | /O(min(m,n))/ Unzip a vector of pairs. -unzip :: Vector (a, b) -> (Vector a, Vector b) -{-# INLINE unzip #-} -unzip = G.unzip - -unzip3 :: Vector (a, b, c) -> (Vector a, Vector b, Vector c) -{-# INLINE unzip3 #-} -unzip3 = G.unzip3 - -unzip4 :: Vector (a, b, c, d) -> (Vector a, Vector b, Vector c, Vector d) -{-# INLINE unzip4 #-} -unzip4 = G.unzip4 - -unzip5 :: Vector (a, b, c, d, e) - -> (Vector a, Vector b, Vector c, Vector d, Vector e) -{-# INLINE unzip5 #-} -unzip5 = G.unzip5 - -unzip6 :: Vector (a, b, c, d, e, f) - -> (Vector a, Vector b, Vector c, Vector d, Vector e, Vector f) -{-# INLINE unzip6 #-} -unzip6 = G.unzip6 - --- Monadic zipping --- --------------- - --- | /O(min(m,n))/ Zip the two vectors with the monadic action and yield a --- vector of results -zipWithM :: Monad m => (a -> b -> m c) -> Vector a -> Vector b -> m (Vector c) -{-# INLINE zipWithM #-} -zipWithM = G.zipWithM - --- | /O(min(m,n))/ Zip the two vectors with a monadic action that also takes --- the element index and yield a vector of results -izipWithM :: Monad m => (Int -> a -> b -> m c) -> Vector a -> Vector b -> m (Vector c) -{-# INLINE izipWithM #-} -izipWithM = G.izipWithM - --- | /O(min(m,n))/ Zip the two vectors with the monadic action and ignore the --- results -zipWithM_ :: Monad m => (a -> b -> m c) -> Vector a -> Vector b -> m () -{-# INLINE zipWithM_ #-} -zipWithM_ = G.zipWithM_ - --- | /O(min(m,n))/ Zip the two vectors with a monadic action that also takes --- the element index and ignore the results -izipWithM_ :: Monad m => (Int -> a -> b -> m c) -> Vector a -> Vector b -> m () -{-# INLINE izipWithM_ #-} -izipWithM_ = G.izipWithM_ - --- Filtering --- --------- - --- | /O(n)/ Drop elements that do not satisfy the predicate -filter :: (a -> Bool) -> Vector a -> Vector a -{-# INLINE filter #-} -filter = G.filter - --- | /O(n)/ Drop elements that do not satisfy the predicate which is applied to --- values and their indices -ifilter :: (Int -> a -> Bool) -> Vector a -> Vector a -{-# INLINE ifilter #-} -ifilter = G.ifilter - --- | /O(n)/ Drop repeated adjacent elements. -uniq :: (Eq a) => Vector a -> Vector a -{-# INLINE uniq #-} -uniq = G.uniq - --- | /O(n)/ Drop elements when predicate returns Nothing -mapMaybe :: (a -> Maybe b) -> Vector a -> Vector b -{-# INLINE mapMaybe #-} -mapMaybe = G.mapMaybe - --- | /O(n)/ Drop elements when predicate, applied to index and value, returns Nothing -imapMaybe :: (Int -> a -> Maybe b) -> Vector a -> Vector b -{-# INLINE imapMaybe #-} -imapMaybe = G.imapMaybe - --- | /O(n)/ Drop elements that do not satisfy the monadic predicate -filterM :: Monad m => (a -> m Bool) -> Vector a -> m (Vector a) -{-# INLINE filterM #-} -filterM = G.filterM - --- | /O(n)/ Yield the longest prefix of elements satisfying the predicate --- without copying. -takeWhile :: (a -> Bool) -> Vector a -> Vector a -{-# INLINE takeWhile #-} -takeWhile = G.takeWhile - --- | /O(n)/ Drop the longest prefix of elements that satisfy the predicate --- without copying. -dropWhile :: (a -> Bool) -> Vector a -> Vector a -{-# INLINE dropWhile #-} -dropWhile = G.dropWhile - --- Parititioning --- ------------- - --- | /O(n)/ Split the vector in two parts, the first one containing those --- elements that satisfy the predicate and the second one those that don't. The --- relative order of the elements is preserved at the cost of a sometimes --- reduced performance compared to 'unstablePartition'. -partition :: (a -> Bool) -> Vector a -> (Vector a, Vector a) -{-# INLINE partition #-} -partition = G.partition - --- | /O(n)/ Split the vector in two parts, the first one containing those --- elements that satisfy the predicate and the second one those that don't. --- The order of the elements is not preserved but the operation is often --- faster than 'partition'. -unstablePartition :: (a -> Bool) -> Vector a -> (Vector a, Vector a) -{-# INLINE unstablePartition #-} -unstablePartition = G.unstablePartition - --- | /O(n)/ Split the vector into the longest prefix of elements that satisfy --- the predicate and the rest without copying. -span :: (a -> Bool) -> Vector a -> (Vector a, Vector a) -{-# INLINE span #-} -span = G.span - --- | /O(n)/ Split the vector into the longest prefix of elements that do not --- satisfy the predicate and the rest without copying. -break :: (a -> Bool) -> Vector a -> (Vector a, Vector a) -{-# INLINE break #-} -break = G.break - --- Searching --- --------- - -infix 4 `elem` --- | /O(n)/ Check if the vector contains an element -elem :: Eq a => a -> Vector a -> Bool -{-# INLINE elem #-} -elem = G.elem - -infix 4 `notElem` --- | /O(n)/ Check if the vector does not contain an element (inverse of 'elem') -notElem :: Eq a => a -> Vector a -> Bool -{-# INLINE notElem #-} -notElem = G.notElem - --- | /O(n)/ Yield 'Just' the first element matching the predicate or 'Nothing' --- if no such element exists. -find :: (a -> Bool) -> Vector a -> Maybe a -{-# INLINE find #-} -find = G.find - --- | /O(n)/ Yield 'Just' the index of the first element matching the predicate --- or 'Nothing' if no such element exists. -findIndex :: (a -> Bool) -> Vector a -> Maybe Int -{-# INLINE findIndex #-} -findIndex = G.findIndex - --- | /O(n)/ Yield the indices of elements satisfying the predicate in ascending --- order. -findIndices :: (a -> Bool) -> Vector a -> Vector Int -{-# INLINE findIndices #-} -findIndices = G.findIndices - --- | /O(n)/ Yield 'Just' the index of the first occurence of the given element or --- 'Nothing' if the vector does not contain the element. This is a specialised --- version of 'findIndex'. -elemIndex :: Eq a => a -> Vector a -> Maybe Int -{-# INLINE elemIndex #-} -elemIndex = G.elemIndex - --- | /O(n)/ Yield the indices of all occurences of the given element in --- ascending order. This is a specialised version of 'findIndices'. -elemIndices :: Eq a => a -> Vector a -> Vector Int -{-# INLINE elemIndices #-} -elemIndices = G.elemIndices - --- Folding --- ------- - --- | /O(n)/ Left fold -foldl :: (a -> b -> a) -> a -> Vector b -> a -{-# INLINE foldl #-} -foldl = G.foldl - --- | /O(n)/ Left fold on non-empty vectors -foldl1 :: (a -> a -> a) -> Vector a -> a -{-# INLINE foldl1 #-} -foldl1 = G.foldl1 - --- | /O(n)/ Left fold with strict accumulator -foldl' :: (a -> b -> a) -> a -> Vector b -> a -{-# INLINE foldl' #-} -foldl' = G.foldl' - --- | /O(n)/ Left fold on non-empty vectors with strict accumulator -foldl1' :: (a -> a -> a) -> Vector a -> a -{-# INLINE foldl1' #-} -foldl1' = G.foldl1' - --- | /O(n)/ Right fold -foldr :: (a -> b -> b) -> b -> Vector a -> b -{-# INLINE foldr #-} -foldr = G.foldr - --- | /O(n)/ Right fold on non-empty vectors -foldr1 :: (a -> a -> a) -> Vector a -> a -{-# INLINE foldr1 #-} -foldr1 = G.foldr1 - --- | /O(n)/ Right fold with a strict accumulator -foldr' :: (a -> b -> b) -> b -> Vector a -> b -{-# INLINE foldr' #-} -foldr' = G.foldr' - --- | /O(n)/ Right fold on non-empty vectors with strict accumulator -foldr1' :: (a -> a -> a) -> Vector a -> a -{-# INLINE foldr1' #-} -foldr1' = G.foldr1' - --- | /O(n)/ Left fold (function applied to each element and its index) -ifoldl :: (a -> Int -> b -> a) -> a -> Vector b -> a -{-# INLINE ifoldl #-} -ifoldl = G.ifoldl - --- | /O(n)/ Left fold with strict accumulator (function applied to each element --- and its index) -ifoldl' :: (a -> Int -> b -> a) -> a -> Vector b -> a -{-# INLINE ifoldl' #-} -ifoldl' = G.ifoldl' - --- | /O(n)/ Right fold (function applied to each element and its index) -ifoldr :: (Int -> a -> b -> b) -> b -> Vector a -> b -{-# INLINE ifoldr #-} -ifoldr = G.ifoldr - --- | /O(n)/ Right fold with strict accumulator (function applied to each --- element and its index) -ifoldr' :: (Int -> a -> b -> b) -> b -> Vector a -> b -{-# INLINE ifoldr' #-} -ifoldr' = G.ifoldr' - --- Specialised folds --- ----------------- - --- | /O(n)/ Check if all elements satisfy the predicate. -all :: (a -> Bool) -> Vector a -> Bool -{-# INLINE all #-} -all = G.all - --- | /O(n)/ Check if any element satisfies the predicate. -any :: (a -> Bool) -> Vector a -> Bool -{-# INLINE any #-} -any = G.any - --- | /O(n)/ Check if all elements are 'True' -and :: Vector Bool -> Bool -{-# INLINE and #-} -and = G.and - --- | /O(n)/ Check if any element is 'True' -or :: Vector Bool -> Bool -{-# INLINE or #-} -or = G.or - --- | /O(n)/ Compute the sum of the elements -sum :: Num a => Vector a -> a -{-# INLINE sum #-} -sum = G.sum - --- | /O(n)/ Compute the produce of the elements -product :: Num a => Vector a -> a -{-# INLINE product #-} -product = G.product - --- | /O(n)/ Yield the maximum element of the vector. The vector may not be --- empty. -maximum :: Ord a => Vector a -> a -{-# INLINE maximum #-} -maximum = G.maximum - --- | /O(n)/ Yield the maximum element of the vector according to the given --- comparison function. The vector may not be empty. -maximumBy :: (a -> a -> Ordering) -> Vector a -> a -{-# INLINE maximumBy #-} -maximumBy = G.maximumBy - --- | /O(n)/ Yield the minimum element of the vector. The vector may not be --- empty. -minimum :: Ord a => Vector a -> a -{-# INLINE minimum #-} -minimum = G.minimum - --- | /O(n)/ Yield the minimum element of the vector according to the given --- comparison function. The vector may not be empty. -minimumBy :: (a -> a -> Ordering) -> Vector a -> a -{-# INLINE minimumBy #-} -minimumBy = G.minimumBy - --- | /O(n)/ Yield the index of the maximum element of the vector. The vector --- may not be empty. -maxIndex :: Ord a => Vector a -> Int -{-# INLINE maxIndex #-} -maxIndex = G.maxIndex - --- | /O(n)/ Yield the index of the maximum element of the vector according to --- the given comparison function. The vector may not be empty. -maxIndexBy :: (a -> a -> Ordering) -> Vector a -> Int -{-# INLINE maxIndexBy #-} -maxIndexBy = G.maxIndexBy - --- | /O(n)/ Yield the index of the minimum element of the vector. The vector --- may not be empty. -minIndex :: Ord a => Vector a -> Int -{-# INLINE minIndex #-} -minIndex = G.minIndex - --- | /O(n)/ Yield the index of the minimum element of the vector according to --- the given comparison function. The vector may not be empty. -minIndexBy :: (a -> a -> Ordering) -> Vector a -> Int -{-# INLINE minIndexBy #-} -minIndexBy = G.minIndexBy - --- Monadic folds --- ------------- - --- | /O(n)/ Monadic fold -foldM :: Monad m => (a -> b -> m a) -> a -> Vector b -> m a -{-# INLINE foldM #-} -foldM = G.foldM - --- | /O(n)/ Monadic fold (action applied to each element and its index) -ifoldM :: Monad m => (a -> Int -> b -> m a) -> a -> Vector b -> m a -{-# INLINE ifoldM #-} -ifoldM = G.ifoldM - --- | /O(n)/ Monadic fold over non-empty vectors -fold1M :: Monad m => (a -> a -> m a) -> Vector a -> m a -{-# INLINE fold1M #-} -fold1M = G.fold1M - --- | /O(n)/ Monadic fold with strict accumulator -foldM' :: Monad m => (a -> b -> m a) -> a -> Vector b -> m a -{-# INLINE foldM' #-} -foldM' = G.foldM' - --- | /O(n)/ Monadic fold with strict accumulator (action applied to each --- element and its index) -ifoldM' :: Monad m => (a -> Int -> b -> m a) -> a -> Vector b -> m a -{-# INLINE ifoldM' #-} -ifoldM' = G.ifoldM' - --- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator -fold1M' :: Monad m => (a -> a -> m a) -> Vector a -> m a -{-# INLINE fold1M' #-} -fold1M' = G.fold1M' - --- | /O(n)/ Monadic fold that discards the result -foldM_ :: Monad m => (a -> b -> m a) -> a -> Vector b -> m () -{-# INLINE foldM_ #-} -foldM_ = G.foldM_ - --- | /O(n)/ Monadic fold that discards the result (action applied to each --- element and its index) -ifoldM_ :: Monad m => (a -> Int -> b -> m a) -> a -> Vector b -> m () -{-# INLINE ifoldM_ #-} -ifoldM_ = G.ifoldM_ - --- | /O(n)/ Monadic fold over non-empty vectors that discards the result -fold1M_ :: Monad m => (a -> a -> m a) -> Vector a -> m () -{-# INLINE fold1M_ #-} -fold1M_ = G.fold1M_ - --- | /O(n)/ Monadic fold with strict accumulator that discards the result -foldM'_ :: Monad m => (a -> b -> m a) -> a -> Vector b -> m () -{-# INLINE foldM'_ #-} -foldM'_ = G.foldM'_ - --- | /O(n)/ Monadic fold with strict accumulator that discards the result --- (action applied to each element and its index) -ifoldM'_ :: Monad m => (a -> Int -> b -> m a) -> a -> Vector b -> m () -{-# INLINE ifoldM'_ #-} -ifoldM'_ = G.ifoldM'_ - --- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator --- that discards the result -fold1M'_ :: Monad m => (a -> a -> m a) -> Vector a -> m () -{-# INLINE fold1M'_ #-} -fold1M'_ = G.fold1M'_ - --- Monadic sequencing --- ------------------ - --- | Evaluate each action and collect the results -sequence :: Monad m => Vector (m a) -> m (Vector a) -{-# INLINE sequence #-} -sequence = G.sequence - --- | Evaluate each action and discard the results -sequence_ :: Monad m => Vector (m a) -> m () -{-# INLINE sequence_ #-} -sequence_ = G.sequence_ - --- Prefix sums (scans) --- ------------------- - --- | /O(n)/ Prescan --- --- @ --- prescanl f z = 'init' . 'scanl' f z --- @ --- --- Example: @prescanl (+) 0 \<1,2,3,4\> = \<0,1,3,6\>@ --- -prescanl :: (a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE prescanl #-} -prescanl = G.prescanl - --- | /O(n)/ Prescan with strict accumulator -prescanl' :: (a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE prescanl' #-} -prescanl' = G.prescanl' - --- | /O(n)/ Scan --- --- @ --- postscanl f z = 'tail' . 'scanl' f z --- @ --- --- Example: @postscanl (+) 0 \<1,2,3,4\> = \<1,3,6,10\>@ --- -postscanl :: (a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE postscanl #-} -postscanl = G.postscanl - --- | /O(n)/ Scan with strict accumulator -postscanl' :: (a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE postscanl' #-} -postscanl' = G.postscanl' - --- | /O(n)/ Haskell-style scan --- --- > scanl f z <x1,...,xn> = <y1,...,y(n+1)> --- > where y1 = z --- > yi = f y(i-1) x(i-1) --- --- Example: @scanl (+) 0 \<1,2,3,4\> = \<0,1,3,6,10\>@ --- -scanl :: (a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE scanl #-} -scanl = G.scanl - --- | /O(n)/ Haskell-style scan with strict accumulator -scanl' :: (a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE scanl' #-} -scanl' = G.scanl' - --- | /O(n)/ Scan over a vector with its index -iscanl :: (Int -> a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE iscanl #-} -iscanl = G.iscanl - --- | /O(n)/ Scan over a vector (strictly) with its index -iscanl' :: (Int -> a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE iscanl' #-} -iscanl' = G.iscanl' - --- | /O(n)/ Scan over a non-empty vector --- --- > scanl f <x1,...,xn> = <y1,...,yn> --- > where y1 = x1 --- > yi = f y(i-1) xi --- -scanl1 :: (a -> a -> a) -> Vector a -> Vector a -{-# INLINE scanl1 #-} -scanl1 = G.scanl1 - --- | /O(n)/ Scan over a non-empty vector with a strict accumulator -scanl1' :: (a -> a -> a) -> Vector a -> Vector a -{-# INLINE scanl1' #-} -scanl1' = G.scanl1' - --- | /O(n)/ Right-to-left prescan --- --- @ --- prescanr f z = 'reverse' . 'prescanl' (flip f) z . 'reverse' --- @ --- -prescanr :: (a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE prescanr #-} -prescanr = G.prescanr - --- | /O(n)/ Right-to-left prescan with strict accumulator -prescanr' :: (a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE prescanr' #-} -prescanr' = G.prescanr' - --- | /O(n)/ Right-to-left scan -postscanr :: (a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE postscanr #-} -postscanr = G.postscanr - --- | /O(n)/ Right-to-left scan with strict accumulator -postscanr' :: (a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE postscanr' #-} -postscanr' = G.postscanr' - --- | /O(n)/ Right-to-left Haskell-style scan -scanr :: (a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE scanr #-} -scanr = G.scanr - --- | /O(n)/ Right-to-left Haskell-style scan with strict accumulator -scanr' :: (a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE scanr' #-} -scanr' = G.scanr' - --- | /O(n)/ Right-to-left scan over a vector with its index -iscanr :: (Int -> a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE iscanr #-} -iscanr = G.iscanr - --- | /O(n)/ Right-to-left scan over a vector (strictly) with its index -iscanr' :: (Int -> a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE iscanr' #-} -iscanr' = G.iscanr' - --- | /O(n)/ Right-to-left scan over a non-empty vector -scanr1 :: (a -> a -> a) -> Vector a -> Vector a -{-# INLINE scanr1 #-} -scanr1 = G.scanr1 - --- | /O(n)/ Right-to-left scan over a non-empty vector with a strict --- accumulator -scanr1' :: (a -> a -> a) -> Vector a -> Vector a -{-# INLINE scanr1' #-} -scanr1' = G.scanr1' - --- Conversions - Lists --- ------------------------ - --- | /O(n)/ Convert a vector to a list -toList :: Vector a -> [a] -{-# INLINE toList #-} -toList = G.toList - --- | /O(n)/ Convert a list to a vector -fromList :: [a] -> Vector a -{-# INLINE fromList #-} -fromList = G.fromList - --- | /O(n)/ Convert the first @n@ elements of a list to a vector --- --- @ --- fromListN n xs = 'fromList' ('take' n xs) --- @ -fromListN :: Int -> [a] -> Vector a -{-# INLINE fromListN #-} -fromListN = G.fromListN - --- Conversions - Mutable vectors --- ----------------------------- - --- | /O(1)/ Unsafe convert a mutable vector to an immutable one without --- copying. The mutable vector may not be used after this operation. -unsafeFreeze :: PrimMonad m => MVector (PrimState m) a -> m (Vector a) -{-# INLINE unsafeFreeze #-} -unsafeFreeze = G.unsafeFreeze - --- | /O(1)/ Unsafely convert an immutable vector to a mutable one without --- copying. The immutable vector may not be used after this operation. -unsafeThaw :: PrimMonad m => Vector a -> m (MVector (PrimState m) a) -{-# INLINE unsafeThaw #-} -unsafeThaw = G.unsafeThaw - --- | /O(n)/ Yield a mutable copy of the immutable vector. -thaw :: PrimMonad m => Vector a -> m (MVector (PrimState m) a) -{-# INLINE thaw #-} -thaw = G.thaw - --- | /O(n)/ Yield an immutable copy of the mutable vector. -freeze :: PrimMonad m => MVector (PrimState m) a -> m (Vector a) -{-# INLINE freeze #-} -freeze = G.freeze - --- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must --- have the same length. This is not checked. -unsafeCopy :: PrimMonad m => MVector (PrimState m) a -> Vector a -> m () -{-# INLINE unsafeCopy #-} -unsafeCopy = G.unsafeCopy - --- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must --- have the same length. -copy :: PrimMonad m => MVector (PrimState m) a -> Vector a -> m () -{-# INLINE copy #-} -copy = G.copy diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Bundle.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Bundle.hs deleted file mode 100644 index 6b6b6236d7cb..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Bundle.hs +++ /dev/null @@ -1,655 +0,0 @@ -{-# LANGUAGE CPP, FlexibleInstances, Rank2Types, BangPatterns #-} - --- | --- Module : Data.Vector.Fusion.Bundle --- Copyright : (c) Roman Leshchinskiy 2008-2010 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Stability : experimental --- Portability : non-portable --- --- Bundles for stream fusion --- - -module Data.Vector.Fusion.Bundle ( - -- * Types - Step(..), Chunk(..), Bundle, MBundle, - - -- * In-place markers - inplace, - - -- * Size hints - size, sized, - - -- * Length information - length, null, - - -- * Construction - empty, singleton, cons, snoc, replicate, generate, (++), - - -- * Accessing individual elements - head, last, (!!), (!?), - - -- * Substreams - slice, init, tail, take, drop, - - -- * Mapping - map, concatMap, flatten, unbox, - - -- * Zipping - indexed, indexedR, - zipWith, zipWith3, zipWith4, zipWith5, zipWith6, - zip, zip3, zip4, zip5, zip6, - - -- * Filtering - filter, takeWhile, dropWhile, - - -- * Searching - elem, notElem, find, findIndex, - - -- * Folding - foldl, foldl1, foldl', foldl1', foldr, foldr1, - - -- * Specialised folds - and, or, - - -- * Unfolding - unfoldr, unfoldrN, iterateN, - - -- * Scans - prescanl, prescanl', - postscanl, postscanl', - scanl, scanl', - scanl1, scanl1', - - -- * Enumerations - enumFromStepN, enumFromTo, enumFromThenTo, - - -- * Conversions - toList, fromList, fromListN, unsafeFromList, lift, - fromVector, reVector, fromVectors, concatVectors, - - -- * Monadic combinators - mapM, mapM_, zipWithM, zipWithM_, filterM, foldM, fold1M, foldM', fold1M', - - eq, cmp, eqBy, cmpBy -) where - -import Data.Vector.Generic.Base ( Vector ) -import Data.Vector.Fusion.Bundle.Size -import Data.Vector.Fusion.Util -import Data.Vector.Fusion.Stream.Monadic ( Stream(..), Step(..) ) -import Data.Vector.Fusion.Bundle.Monadic ( Chunk(..) ) -import qualified Data.Vector.Fusion.Bundle.Monadic as M -import qualified Data.Vector.Fusion.Stream.Monadic as S - -import Prelude hiding ( length, null, - replicate, (++), - head, last, (!!), - init, tail, take, drop, - map, concatMap, - zipWith, zipWith3, zip, zip3, - filter, takeWhile, dropWhile, - elem, notElem, - foldl, foldl1, foldr, foldr1, - and, or, - scanl, scanl1, - enumFromTo, enumFromThenTo, - mapM, mapM_ ) - -#if MIN_VERSION_base(4,9,0) -import Data.Functor.Classes (Eq1 (..), Ord1 (..)) -#endif - -import GHC.Base ( build ) - --- Data.Vector.Internal.Check is unused -#define NOT_VECTOR_MODULE -#include "vector.h" - --- | The type of pure streams -type Bundle = M.Bundle Id - --- | Alternative name for monadic streams -type MBundle = M.Bundle - -inplace :: (forall m. Monad m => S.Stream m a -> S.Stream m b) - -> (Size -> Size) -> Bundle v a -> Bundle v b -{-# INLINE_FUSED inplace #-} -inplace f g b = b `seq` M.fromStream (f (M.elements b)) (g (M.size b)) - -{-# RULES - -"inplace/inplace [Vector]" - forall (f1 :: forall m. Monad m => S.Stream m a -> S.Stream m a) - (f2 :: forall m. Monad m => S.Stream m a -> S.Stream m a) - g1 g2 s. - inplace f1 g1 (inplace f2 g2 s) = inplace (f1 . f2) (g1 . g2) s #-} - - - --- | Convert a pure stream to a monadic stream -lift :: Monad m => Bundle v a -> M.Bundle m v a -{-# INLINE_FUSED lift #-} -lift (M.Bundle (Stream step s) (Stream vstep t) v sz) - = M.Bundle (Stream (return . unId . step) s) - (Stream (return . unId . vstep) t) v sz - --- | 'Size' hint of a 'Bundle' -size :: Bundle v a -> Size -{-# INLINE size #-} -size = M.size - --- | Attach a 'Size' hint to a 'Bundle' -sized :: Bundle v a -> Size -> Bundle v a -{-# INLINE sized #-} -sized = M.sized - --- Length --- ------ - --- | Length of a 'Bundle' -length :: Bundle v a -> Int -{-# INLINE length #-} -length = unId . M.length - --- | Check if a 'Bundle' is empty -null :: Bundle v a -> Bool -{-# INLINE null #-} -null = unId . M.null - --- Construction --- ------------ - --- | Empty 'Bundle' -empty :: Bundle v a -{-# INLINE empty #-} -empty = M.empty - --- | Singleton 'Bundle' -singleton :: a -> Bundle v a -{-# INLINE singleton #-} -singleton = M.singleton - --- | Replicate a value to a given length -replicate :: Int -> a -> Bundle v a -{-# INLINE replicate #-} -replicate = M.replicate - --- | Generate a stream from its indices -generate :: Int -> (Int -> a) -> Bundle v a -{-# INLINE generate #-} -generate = M.generate - --- | Prepend an element -cons :: a -> Bundle v a -> Bundle v a -{-# INLINE cons #-} -cons = M.cons - --- | Append an element -snoc :: Bundle v a -> a -> Bundle v a -{-# INLINE snoc #-} -snoc = M.snoc - -infixr 5 ++ --- | Concatenate two 'Bundle's -(++) :: Bundle v a -> Bundle v a -> Bundle v a -{-# INLINE (++) #-} -(++) = (M.++) - --- Accessing elements --- ------------------ - --- | First element of the 'Bundle' or error if empty -head :: Bundle v a -> a -{-# INLINE head #-} -head = unId . M.head - --- | Last element of the 'Bundle' or error if empty -last :: Bundle v a -> a -{-# INLINE last #-} -last = unId . M.last - -infixl 9 !! --- | Element at the given position -(!!) :: Bundle v a -> Int -> a -{-# INLINE (!!) #-} -s !! i = unId (s M.!! i) - -infixl 9 !? --- | Element at the given position or 'Nothing' if out of bounds -(!?) :: Bundle v a -> Int -> Maybe a -{-# INLINE (!?) #-} -s !? i = unId (s M.!? i) - --- Substreams --- ---------- - --- | Extract a substream of the given length starting at the given position. -slice :: Int -- ^ starting index - -> Int -- ^ length - -> Bundle v a - -> Bundle v a -{-# INLINE slice #-} -slice = M.slice - --- | All but the last element -init :: Bundle v a -> Bundle v a -{-# INLINE init #-} -init = M.init - --- | All but the first element -tail :: Bundle v a -> Bundle v a -{-# INLINE tail #-} -tail = M.tail - --- | The first @n@ elements -take :: Int -> Bundle v a -> Bundle v a -{-# INLINE take #-} -take = M.take - --- | All but the first @n@ elements -drop :: Int -> Bundle v a -> Bundle v a -{-# INLINE drop #-} -drop = M.drop - --- Mapping --- --------------- - --- | Map a function over a 'Bundle' -map :: (a -> b) -> Bundle v a -> Bundle v b -{-# INLINE map #-} -map = M.map - -unbox :: Bundle v (Box a) -> Bundle v a -{-# INLINE unbox #-} -unbox = M.unbox - -concatMap :: (a -> Bundle v b) -> Bundle v a -> Bundle v b -{-# INLINE concatMap #-} -concatMap = M.concatMap - --- Zipping --- ------- - --- | Pair each element in a 'Bundle' with its index -indexed :: Bundle v a -> Bundle v (Int,a) -{-# INLINE indexed #-} -indexed = M.indexed - --- | Pair each element in a 'Bundle' with its index, starting from the right --- and counting down -indexedR :: Int -> Bundle v a -> Bundle v (Int,a) -{-# INLINE_FUSED indexedR #-} -indexedR = M.indexedR - --- | Zip two 'Bundle's with the given function -zipWith :: (a -> b -> c) -> Bundle v a -> Bundle v b -> Bundle v c -{-# INLINE zipWith #-} -zipWith = M.zipWith - --- | Zip three 'Bundle's with the given function -zipWith3 :: (a -> b -> c -> d) -> Bundle v a -> Bundle v b -> Bundle v c -> Bundle v d -{-# INLINE zipWith3 #-} -zipWith3 = M.zipWith3 - -zipWith4 :: (a -> b -> c -> d -> e) - -> Bundle v a -> Bundle v b -> Bundle v c -> Bundle v d - -> Bundle v e -{-# INLINE zipWith4 #-} -zipWith4 = M.zipWith4 - -zipWith5 :: (a -> b -> c -> d -> e -> f) - -> Bundle v a -> Bundle v b -> Bundle v c -> Bundle v d - -> Bundle v e -> Bundle v f -{-# INLINE zipWith5 #-} -zipWith5 = M.zipWith5 - -zipWith6 :: (a -> b -> c -> d -> e -> f -> g) - -> Bundle v a -> Bundle v b -> Bundle v c -> Bundle v d - -> Bundle v e -> Bundle v f -> Bundle v g -{-# INLINE zipWith6 #-} -zipWith6 = M.zipWith6 - -zip :: Bundle v a -> Bundle v b -> Bundle v (a,b) -{-# INLINE zip #-} -zip = M.zip - -zip3 :: Bundle v a -> Bundle v b -> Bundle v c -> Bundle v (a,b,c) -{-# INLINE zip3 #-} -zip3 = M.zip3 - -zip4 :: Bundle v a -> Bundle v b -> Bundle v c -> Bundle v d - -> Bundle v (a,b,c,d) -{-# INLINE zip4 #-} -zip4 = M.zip4 - -zip5 :: Bundle v a -> Bundle v b -> Bundle v c -> Bundle v d - -> Bundle v e -> Bundle v (a,b,c,d,e) -{-# INLINE zip5 #-} -zip5 = M.zip5 - -zip6 :: Bundle v a -> Bundle v b -> Bundle v c -> Bundle v d - -> Bundle v e -> Bundle v f -> Bundle v (a,b,c,d,e,f) -{-# INLINE zip6 #-} -zip6 = M.zip6 - --- Filtering --- --------- - --- | Drop elements which do not satisfy the predicate -filter :: (a -> Bool) -> Bundle v a -> Bundle v a -{-# INLINE filter #-} -filter = M.filter - --- | Longest prefix of elements that satisfy the predicate -takeWhile :: (a -> Bool) -> Bundle v a -> Bundle v a -{-# INLINE takeWhile #-} -takeWhile = M.takeWhile - --- | Drop the longest prefix of elements that satisfy the predicate -dropWhile :: (a -> Bool) -> Bundle v a -> Bundle v a -{-# INLINE dropWhile #-} -dropWhile = M.dropWhile - --- Searching --- --------- - -infix 4 `elem` --- | Check whether the 'Bundle' contains an element -elem :: Eq a => a -> Bundle v a -> Bool -{-# INLINE elem #-} -elem x = unId . M.elem x - -infix 4 `notElem` --- | Inverse of `elem` -notElem :: Eq a => a -> Bundle v a -> Bool -{-# INLINE notElem #-} -notElem x = unId . M.notElem x - --- | Yield 'Just' the first element matching the predicate or 'Nothing' if no --- such element exists. -find :: (a -> Bool) -> Bundle v a -> Maybe a -{-# INLINE find #-} -find f = unId . M.find f - --- | Yield 'Just' the index of the first element matching the predicate or --- 'Nothing' if no such element exists. -findIndex :: (a -> Bool) -> Bundle v a -> Maybe Int -{-# INLINE findIndex #-} -findIndex f = unId . M.findIndex f - --- Folding --- ------- - --- | Left fold -foldl :: (a -> b -> a) -> a -> Bundle v b -> a -{-# INLINE foldl #-} -foldl f z = unId . M.foldl f z - --- | Left fold on non-empty 'Bundle's -foldl1 :: (a -> a -> a) -> Bundle v a -> a -{-# INLINE foldl1 #-} -foldl1 f = unId . M.foldl1 f - --- | Left fold with strict accumulator -foldl' :: (a -> b -> a) -> a -> Bundle v b -> a -{-# INLINE foldl' #-} -foldl' f z = unId . M.foldl' f z - --- | Left fold on non-empty 'Bundle's with strict accumulator -foldl1' :: (a -> a -> a) -> Bundle v a -> a -{-# INLINE foldl1' #-} -foldl1' f = unId . M.foldl1' f - --- | Right fold -foldr :: (a -> b -> b) -> b -> Bundle v a -> b -{-# INLINE foldr #-} -foldr f z = unId . M.foldr f z - --- | Right fold on non-empty 'Bundle's -foldr1 :: (a -> a -> a) -> Bundle v a -> a -{-# INLINE foldr1 #-} -foldr1 f = unId . M.foldr1 f - --- Specialised folds --- ----------------- - -and :: Bundle v Bool -> Bool -{-# INLINE and #-} -and = unId . M.and - -or :: Bundle v Bool -> Bool -{-# INLINE or #-} -or = unId . M.or - --- Unfolding --- --------- - --- | Unfold -unfoldr :: (s -> Maybe (a, s)) -> s -> Bundle v a -{-# INLINE unfoldr #-} -unfoldr = M.unfoldr - --- | Unfold at most @n@ elements -unfoldrN :: Int -> (s -> Maybe (a, s)) -> s -> Bundle v a -{-# INLINE unfoldrN #-} -unfoldrN = M.unfoldrN - --- | Apply function n-1 times to value. Zeroth element is original value. -iterateN :: Int -> (a -> a) -> a -> Bundle v a -{-# INLINE iterateN #-} -iterateN = M.iterateN - --- Scans --- ----- - --- | Prefix scan -prescanl :: (a -> b -> a) -> a -> Bundle v b -> Bundle v a -{-# INLINE prescanl #-} -prescanl = M.prescanl - --- | Prefix scan with strict accumulator -prescanl' :: (a -> b -> a) -> a -> Bundle v b -> Bundle v a -{-# INLINE prescanl' #-} -prescanl' = M.prescanl' - --- | Suffix scan -postscanl :: (a -> b -> a) -> a -> Bundle v b -> Bundle v a -{-# INLINE postscanl #-} -postscanl = M.postscanl - --- | Suffix scan with strict accumulator -postscanl' :: (a -> b -> a) -> a -> Bundle v b -> Bundle v a -{-# INLINE postscanl' #-} -postscanl' = M.postscanl' - --- | Haskell-style scan -scanl :: (a -> b -> a) -> a -> Bundle v b -> Bundle v a -{-# INLINE scanl #-} -scanl = M.scanl - --- | Haskell-style scan with strict accumulator -scanl' :: (a -> b -> a) -> a -> Bundle v b -> Bundle v a -{-# INLINE scanl' #-} -scanl' = M.scanl' - --- | Scan over a non-empty 'Bundle' -scanl1 :: (a -> a -> a) -> Bundle v a -> Bundle v a -{-# INLINE scanl1 #-} -scanl1 = M.scanl1 - --- | Scan over a non-empty 'Bundle' with a strict accumulator -scanl1' :: (a -> a -> a) -> Bundle v a -> Bundle v a -{-# INLINE scanl1' #-} -scanl1' = M.scanl1' - - --- Comparisons --- ----------- - --- | Check if two 'Bundle's are equal -eq :: (Eq a) => Bundle v a -> Bundle v a -> Bool -{-# INLINE eq #-} -eq = eqBy (==) - -eqBy :: (a -> b -> Bool) -> Bundle v a -> Bundle v b -> Bool -{-# INLINE eqBy #-} -eqBy e x y = unId (M.eqBy e x y) - --- | Lexicographically compare two 'Bundle's -cmp :: (Ord a) => Bundle v a -> Bundle v a -> Ordering -{-# INLINE cmp #-} -cmp = cmpBy compare - -cmpBy :: (a -> b -> Ordering) -> Bundle v a -> Bundle v b -> Ordering -{-# INLINE cmpBy #-} -cmpBy c x y = unId (M.cmpBy c x y) - -instance Eq a => Eq (M.Bundle Id v a) where - {-# INLINE (==) #-} - (==) = eq - -instance Ord a => Ord (M.Bundle Id v a) where - {-# INLINE compare #-} - compare = cmp - -#if MIN_VERSION_base(4,9,0) -instance Eq1 (M.Bundle Id v) where - {-# INLINE liftEq #-} - liftEq = eqBy - -instance Ord1 (M.Bundle Id v) where - {-# INLINE liftCompare #-} - liftCompare = cmpBy -#endif - --- Monadic combinators --- ------------------- - --- | Apply a monadic action to each element of the stream, producing a monadic --- stream of results -mapM :: Monad m => (a -> m b) -> Bundle v a -> M.Bundle m v b -{-# INLINE mapM #-} -mapM f = M.mapM f . lift - --- | Apply a monadic action to each element of the stream -mapM_ :: Monad m => (a -> m b) -> Bundle v a -> m () -{-# INLINE mapM_ #-} -mapM_ f = M.mapM_ f . lift - -zipWithM :: Monad m => (a -> b -> m c) -> Bundle v a -> Bundle v b -> M.Bundle m v c -{-# INLINE zipWithM #-} -zipWithM f as bs = M.zipWithM f (lift as) (lift bs) - -zipWithM_ :: Monad m => (a -> b -> m c) -> Bundle v a -> Bundle v b -> m () -{-# INLINE zipWithM_ #-} -zipWithM_ f as bs = M.zipWithM_ f (lift as) (lift bs) - --- | Yield a monadic stream of elements that satisfy the monadic predicate -filterM :: Monad m => (a -> m Bool) -> Bundle v a -> M.Bundle m v a -{-# INLINE filterM #-} -filterM f = M.filterM f . lift - --- | Monadic fold -foldM :: Monad m => (a -> b -> m a) -> a -> Bundle v b -> m a -{-# INLINE foldM #-} -foldM m z = M.foldM m z . lift - --- | Monadic fold over non-empty stream -fold1M :: Monad m => (a -> a -> m a) -> Bundle v a -> m a -{-# INLINE fold1M #-} -fold1M m = M.fold1M m . lift - --- | Monadic fold with strict accumulator -foldM' :: Monad m => (a -> b -> m a) -> a -> Bundle v b -> m a -{-# INLINE foldM' #-} -foldM' m z = M.foldM' m z . lift - --- | Monad fold over non-empty stream with strict accumulator -fold1M' :: Monad m => (a -> a -> m a) -> Bundle v a -> m a -{-# INLINE fold1M' #-} -fold1M' m = M.fold1M' m . lift - --- Enumerations --- ------------ - --- | Yield a 'Bundle' of the given length containing the values @x@, @x+y@, --- @x+y+y@ etc. -enumFromStepN :: Num a => a -> a -> Int -> Bundle v a -{-# INLINE enumFromStepN #-} -enumFromStepN = M.enumFromStepN - --- | Enumerate values --- --- /WARNING:/ This operations can be very inefficient. If at all possible, use --- 'enumFromStepN' instead. -enumFromTo :: Enum a => a -> a -> Bundle v a -{-# INLINE enumFromTo #-} -enumFromTo = M.enumFromTo - --- | Enumerate values with a given step. --- --- /WARNING:/ This operations is very inefficient. If at all possible, use --- 'enumFromStepN' instead. -enumFromThenTo :: Enum a => a -> a -> a -> Bundle v a -{-# INLINE enumFromThenTo #-} -enumFromThenTo = M.enumFromThenTo - --- Conversions --- ----------- - --- | Convert a 'Bundle' to a list -toList :: Bundle v a -> [a] -{-# INLINE toList #-} --- toList s = unId (M.toList s) -toList s = build (\c n -> toListFB c n s) - --- This supports foldr/build list fusion that GHC implements -toListFB :: (a -> b -> b) -> b -> Bundle v a -> b -{-# INLINE [0] toListFB #-} -toListFB c n M.Bundle{M.sElems = Stream step t} = go t - where - go s = case unId (step s) of - Yield x s' -> x `c` go s' - Skip s' -> go s' - Done -> n - --- | Create a 'Bundle' from a list -fromList :: [a] -> Bundle v a -{-# INLINE fromList #-} -fromList = M.fromList - --- | Create a 'Bundle' from the first @n@ elements of a list --- --- > fromListN n xs = fromList (take n xs) -fromListN :: Int -> [a] -> Bundle v a -{-# INLINE fromListN #-} -fromListN = M.fromListN - -unsafeFromList :: Size -> [a] -> Bundle v a -{-# INLINE unsafeFromList #-} -unsafeFromList = M.unsafeFromList - -fromVector :: Vector v a => v a -> Bundle v a -{-# INLINE fromVector #-} -fromVector = M.fromVector - -reVector :: Bundle u a -> Bundle v a -{-# INLINE reVector #-} -reVector = M.reVector - -fromVectors :: Vector v a => [v a] -> Bundle v a -{-# INLINE fromVectors #-} -fromVectors = M.fromVectors - -concatVectors :: Vector v a => Bundle u (v a) -> Bundle v a -{-# INLINE concatVectors #-} -concatVectors = M.concatVectors - --- | Create a 'Bundle' of values from a 'Bundle' of streamable things -flatten :: (a -> s) -> (s -> Step s b) -> Size -> Bundle v a -> Bundle v b -{-# INLINE_FUSED flatten #-} -flatten mk istep sz = M.flatten (return . mk) (return . istep) sz . lift - diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Bundle/Monadic.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Bundle/Monadic.hs deleted file mode 100644 index 46f4a165f88d..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Bundle/Monadic.hs +++ /dev/null @@ -1,1106 +0,0 @@ -{-# LANGUAGE CPP, ExistentialQuantification, MultiParamTypeClasses, FlexibleInstances, Rank2Types, BangPatterns, KindSignatures, GADTs, ScopedTypeVariables #-} - --- | --- Module : Data.Vector.Fusion.Bundle.Monadic --- Copyright : (c) Roman Leshchinskiy 2008-2010 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Stability : experimental --- Portability : non-portable --- --- Monadic bundles. --- - -module Data.Vector.Fusion.Bundle.Monadic ( - Bundle(..), Chunk(..), - - -- * Size hints - size, sized, - - -- * Length - length, null, - - -- * Construction - empty, singleton, cons, snoc, replicate, replicateM, generate, generateM, (++), - - -- * Accessing elements - head, last, (!!), (!?), - - -- * Substreams - slice, init, tail, take, drop, - - -- * Mapping - map, mapM, mapM_, trans, unbox, concatMap, flatten, - - -- * Zipping - indexed, indexedR, zipWithM_, - zipWithM, zipWith3M, zipWith4M, zipWith5M, zipWith6M, - zipWith, zipWith3, zipWith4, zipWith5, zipWith6, - zip, zip3, zip4, zip5, zip6, - - -- * Comparisons - eqBy, cmpBy, - - -- * Filtering - filter, filterM, takeWhile, takeWhileM, dropWhile, dropWhileM, - - -- * Searching - elem, notElem, find, findM, findIndex, findIndexM, - - -- * Folding - foldl, foldlM, foldl1, foldl1M, foldM, fold1M, - foldl', foldlM', foldl1', foldl1M', foldM', fold1M', - foldr, foldrM, foldr1, foldr1M, - - -- * Specialised folds - and, or, concatMapM, - - -- * Unfolding - unfoldr, unfoldrM, - unfoldrN, unfoldrNM, - iterateN, iterateNM, - - -- * Scans - prescanl, prescanlM, prescanl', prescanlM', - postscanl, postscanlM, postscanl', postscanlM', - scanl, scanlM, scanl', scanlM', - scanl1, scanl1M, scanl1', scanl1M', - - -- * Enumerations - enumFromStepN, enumFromTo, enumFromThenTo, - - -- * Conversions - toList, fromList, fromListN, unsafeFromList, - fromVector, reVector, fromVectors, concatVectors, - fromStream, chunks, elements -) where - -import Data.Vector.Generic.Base -import qualified Data.Vector.Generic.Mutable.Base as M -import Data.Vector.Fusion.Bundle.Size -import Data.Vector.Fusion.Util ( Box(..), delay_inline ) -import Data.Vector.Fusion.Stream.Monadic ( Stream(..), Step(..) ) -import qualified Data.Vector.Fusion.Stream.Monadic as S -import Control.Monad.Primitive - -import qualified Data.List as List -import Data.Char ( ord ) -import GHC.Base ( unsafeChr ) -import Control.Monad ( liftM ) -import Prelude hiding ( length, null, - replicate, (++), - head, last, (!!), - init, tail, take, drop, - map, mapM, mapM_, concatMap, - zipWith, zipWith3, zip, zip3, - filter, takeWhile, dropWhile, - elem, notElem, - foldl, foldl1, foldr, foldr1, - and, or, - scanl, scanl1, - enumFromTo, enumFromThenTo ) - -import Data.Int ( Int8, Int16, Int32 ) -import Data.Word ( Word8, Word16, Word32, Word64 ) - -#if !MIN_VERSION_base(4,8,0) -import Data.Word ( Word ) -#endif - -#include "vector.h" -#include "MachDeps.h" - -#if WORD_SIZE_IN_BITS > 32 -import Data.Int ( Int64 ) -#endif - -data Chunk v a = Chunk Int (forall m. (PrimMonad m, Vector v a) => Mutable v (PrimState m) a -> m ()) - --- | Monadic streams -data Bundle m v a = Bundle { sElems :: Stream m a - , sChunks :: Stream m (Chunk v a) - , sVector :: Maybe (v a) - , sSize :: Size - } - -fromStream :: Monad m => Stream m a -> Size -> Bundle m v a -{-# INLINE fromStream #-} -fromStream (Stream step t) sz = Bundle (Stream step t) (Stream step' t) Nothing sz - where - step' s = do r <- step s - return $ fmap (\x -> Chunk 1 (\v -> M.basicUnsafeWrite v 0 x)) r - -chunks :: Bundle m v a -> Stream m (Chunk v a) -{-# INLINE chunks #-} -chunks = sChunks - -elements :: Bundle m v a -> Stream m a -{-# INLINE elements #-} -elements = sElems - --- | 'Size' hint of a 'Bundle' -size :: Bundle m v a -> Size -{-# INLINE size #-} -size = sSize - --- | Attach a 'Size' hint to a 'Bundle' -sized :: Bundle m v a -> Size -> Bundle m v a -{-# INLINE_FUSED sized #-} -sized s sz = s { sSize = sz } - --- Length --- ------ - --- | Length of a 'Bundle' -length :: Monad m => Bundle m v a -> m Int -{-# INLINE_FUSED length #-} -length Bundle{sSize = Exact n} = return n -length Bundle{sChunks = s} = S.foldl' (\n (Chunk k _) -> n+k) 0 s - --- | Check if a 'Bundle' is empty -null :: Monad m => Bundle m v a -> m Bool -{-# INLINE_FUSED null #-} -null Bundle{sSize = Exact n} = return (n == 0) -null Bundle{sChunks = s} = S.foldr (\(Chunk n _) z -> n == 0 && z) True s - --- Construction --- ------------ - --- | Empty 'Bundle' -empty :: Monad m => Bundle m v a -{-# INLINE_FUSED empty #-} -empty = fromStream S.empty (Exact 0) - --- | Singleton 'Bundle' -singleton :: Monad m => a -> Bundle m v a -{-# INLINE_FUSED singleton #-} -singleton x = fromStream (S.singleton x) (Exact 1) - --- | Replicate a value to a given length -replicate :: Monad m => Int -> a -> Bundle m v a -{-# INLINE_FUSED replicate #-} -replicate n x = Bundle (S.replicate n x) - (S.singleton $ Chunk len (\v -> M.basicSet v x)) - Nothing - (Exact len) - where - len = delay_inline max n 0 - --- | Yield a 'Bundle' of values obtained by performing the monadic action the --- given number of times -replicateM :: Monad m => Int -> m a -> Bundle m v a -{-# INLINE_FUSED replicateM #-} --- NOTE: We delay inlining max here because GHC will create a join point for --- the call to newArray# otherwise which is not really nice. -replicateM n p = fromStream (S.replicateM n p) (Exact (delay_inline max n 0)) - -generate :: Monad m => Int -> (Int -> a) -> Bundle m v a -{-# INLINE generate #-} -generate n f = generateM n (return . f) - --- | Generate a stream from its indices -generateM :: Monad m => Int -> (Int -> m a) -> Bundle m v a -{-# INLINE_FUSED generateM #-} -generateM n f = fromStream (S.generateM n f) (Exact (delay_inline max n 0)) - --- | Prepend an element -cons :: Monad m => a -> Bundle m v a -> Bundle m v a -{-# INLINE cons #-} -cons x s = singleton x ++ s - --- | Append an element -snoc :: Monad m => Bundle m v a -> a -> Bundle m v a -{-# INLINE snoc #-} -snoc s x = s ++ singleton x - -infixr 5 ++ --- | Concatenate two 'Bundle's -(++) :: Monad m => Bundle m v a -> Bundle m v a -> Bundle m v a -{-# INLINE_FUSED (++) #-} -Bundle sa ta _ na ++ Bundle sb tb _ nb = Bundle (sa S.++ sb) (ta S.++ tb) Nothing (na + nb) - --- Accessing elements --- ------------------ - --- | First element of the 'Bundle' or error if empty -head :: Monad m => Bundle m v a -> m a -{-# INLINE_FUSED head #-} -head = S.head . sElems - --- | Last element of the 'Bundle' or error if empty -last :: Monad m => Bundle m v a -> m a -{-# INLINE_FUSED last #-} -last = S.last . sElems - -infixl 9 !! --- | Element at the given position -(!!) :: Monad m => Bundle m v a -> Int -> m a -{-# INLINE (!!) #-} -b !! i = sElems b S.!! i - -infixl 9 !? --- | Element at the given position or 'Nothing' if out of bounds -(!?) :: Monad m => Bundle m v a -> Int -> m (Maybe a) -{-# INLINE (!?) #-} -b !? i = sElems b S.!? i - --- Substreams --- ---------- - --- | Extract a substream of the given length starting at the given position. -slice :: Monad m => Int -- ^ starting index - -> Int -- ^ length - -> Bundle m v a - -> Bundle m v a -{-# INLINE slice #-} -slice i n s = take n (drop i s) - --- | All but the last element -init :: Monad m => Bundle m v a -> Bundle m v a -{-# INLINE_FUSED init #-} -init Bundle{sElems = s, sSize = sz} = fromStream (S.init s) (sz-1) - --- | All but the first element -tail :: Monad m => Bundle m v a -> Bundle m v a -{-# INLINE_FUSED tail #-} -tail Bundle{sElems = s, sSize = sz} = fromStream (S.tail s) (sz-1) - --- | The first @n@ elements -take :: Monad m => Int -> Bundle m v a -> Bundle m v a -{-# INLINE_FUSED take #-} -take n Bundle{sElems = s, sSize = sz} = fromStream (S.take n s) (smaller (Exact n) sz) - --- | All but the first @n@ elements -drop :: Monad m => Int -> Bundle m v a -> Bundle m v a -{-# INLINE_FUSED drop #-} -drop n Bundle{sElems = s, sSize = sz} = - fromStream (S.drop n s) (clampedSubtract sz (Exact n)) - --- Mapping --- ------- - -instance Monad m => Functor (Bundle m v) where - {-# INLINE fmap #-} - fmap = map - --- | Map a function over a 'Bundle' -map :: Monad m => (a -> b) -> Bundle m v a -> Bundle m v b -{-# INLINE map #-} -map f = mapM (return . f) - --- | Map a monadic function over a 'Bundle' -mapM :: Monad m => (a -> m b) -> Bundle m v a -> Bundle m v b -{-# INLINE_FUSED mapM #-} -mapM f Bundle{sElems = s, sSize = n} = fromStream (S.mapM f s) n - --- | Execute a monadic action for each element of the 'Bundle' -mapM_ :: Monad m => (a -> m b) -> Bundle m v a -> m () -{-# INLINE_FUSED mapM_ #-} -mapM_ m = S.mapM_ m . sElems - --- | Transform a 'Bundle' to use a different monad -trans :: (Monad m, Monad m') => (forall z. m z -> m' z) - -> Bundle m v a -> Bundle m' v a -{-# INLINE_FUSED trans #-} -trans f Bundle{sElems = s, sChunks = cs, sVector = v, sSize = n} - = Bundle { sElems = S.trans f s, sChunks = S.trans f cs, sVector = v, sSize = n } - -unbox :: Monad m => Bundle m v (Box a) -> Bundle m v a -{-# INLINE_FUSED unbox #-} -unbox Bundle{sElems = s, sSize = n} = fromStream (S.unbox s) n - --- Zipping --- ------- - --- | Pair each element in a 'Bundle' with its index -indexed :: Monad m => Bundle m v a -> Bundle m v (Int,a) -{-# INLINE_FUSED indexed #-} -indexed Bundle{sElems = s, sSize = n} = fromStream (S.indexed s) n - --- | Pair each element in a 'Bundle' with its index, starting from the right --- and counting down -indexedR :: Monad m => Int -> Bundle m v a -> Bundle m v (Int,a) -{-# INLINE_FUSED indexedR #-} -indexedR m Bundle{sElems = s, sSize = n} = fromStream (S.indexedR m s) n - --- | Zip two 'Bundle's with the given monadic function -zipWithM :: Monad m => (a -> b -> m c) -> Bundle m v a -> Bundle m v b -> Bundle m v c -{-# INLINE_FUSED zipWithM #-} -zipWithM f Bundle{sElems = sa, sSize = na} - Bundle{sElems = sb, sSize = nb} = fromStream (S.zipWithM f sa sb) (smaller na nb) - --- FIXME: This might expose an opportunity for inplace execution. -{-# RULES - -"zipWithM xs xs [Vector.Bundle]" forall f xs. - zipWithM f xs xs = mapM (\x -> f x x) xs #-} - - -zipWithM_ :: Monad m => (a -> b -> m c) -> Bundle m v a -> Bundle m v b -> m () -{-# INLINE zipWithM_ #-} -zipWithM_ f sa sb = S.zipWithM_ f (sElems sa) (sElems sb) - -zipWith3M :: Monad m => (a -> b -> c -> m d) -> Bundle m v a -> Bundle m v b -> Bundle m v c -> Bundle m v d -{-# INLINE_FUSED zipWith3M #-} -zipWith3M f Bundle{sElems = sa, sSize = na} - Bundle{sElems = sb, sSize = nb} - Bundle{sElems = sc, sSize = nc} - = fromStream (S.zipWith3M f sa sb sc) (smaller na (smaller nb nc)) - -zipWith4M :: Monad m => (a -> b -> c -> d -> m e) - -> Bundle m v a -> Bundle m v b -> Bundle m v c -> Bundle m v d - -> Bundle m v e -{-# INLINE zipWith4M #-} -zipWith4M f sa sb sc sd - = zipWithM (\(a,b) (c,d) -> f a b c d) (zip sa sb) (zip sc sd) - -zipWith5M :: Monad m => (a -> b -> c -> d -> e -> m f) - -> Bundle m v a -> Bundle m v b -> Bundle m v c -> Bundle m v d - -> Bundle m v e -> Bundle m v f -{-# INLINE zipWith5M #-} -zipWith5M f sa sb sc sd se - = zipWithM (\(a,b,c) (d,e) -> f a b c d e) (zip3 sa sb sc) (zip sd se) - -zipWith6M :: Monad m => (a -> b -> c -> d -> e -> f -> m g) - -> Bundle m v a -> Bundle m v b -> Bundle m v c -> Bundle m v d - -> Bundle m v e -> Bundle m v f -> Bundle m v g -{-# INLINE zipWith6M #-} -zipWith6M fn sa sb sc sd se sf - = zipWithM (\(a,b,c) (d,e,f) -> fn a b c d e f) (zip3 sa sb sc) - (zip3 sd se sf) - -zipWith :: Monad m => (a -> b -> c) -> Bundle m v a -> Bundle m v b -> Bundle m v c -{-# INLINE zipWith #-} -zipWith f = zipWithM (\a b -> return (f a b)) - -zipWith3 :: Monad m => (a -> b -> c -> d) - -> Bundle m v a -> Bundle m v b -> Bundle m v c -> Bundle m v d -{-# INLINE zipWith3 #-} -zipWith3 f = zipWith3M (\a b c -> return (f a b c)) - -zipWith4 :: Monad m => (a -> b -> c -> d -> e) - -> Bundle m v a -> Bundle m v b -> Bundle m v c -> Bundle m v d - -> Bundle m v e -{-# INLINE zipWith4 #-} -zipWith4 f = zipWith4M (\a b c d -> return (f a b c d)) - -zipWith5 :: Monad m => (a -> b -> c -> d -> e -> f) - -> Bundle m v a -> Bundle m v b -> Bundle m v c -> Bundle m v d - -> Bundle m v e -> Bundle m v f -{-# INLINE zipWith5 #-} -zipWith5 f = zipWith5M (\a b c d e -> return (f a b c d e)) - -zipWith6 :: Monad m => (a -> b -> c -> d -> e -> f -> g) - -> Bundle m v a -> Bundle m v b -> Bundle m v c -> Bundle m v d - -> Bundle m v e -> Bundle m v f -> Bundle m v g -{-# INLINE zipWith6 #-} -zipWith6 fn = zipWith6M (\a b c d e f -> return (fn a b c d e f)) - -zip :: Monad m => Bundle m v a -> Bundle m v b -> Bundle m v (a,b) -{-# INLINE zip #-} -zip = zipWith (,) - -zip3 :: Monad m => Bundle m v a -> Bundle m v b -> Bundle m v c -> Bundle m v (a,b,c) -{-# INLINE zip3 #-} -zip3 = zipWith3 (,,) - -zip4 :: Monad m => Bundle m v a -> Bundle m v b -> Bundle m v c -> Bundle m v d - -> Bundle m v (a,b,c,d) -{-# INLINE zip4 #-} -zip4 = zipWith4 (,,,) - -zip5 :: Monad m => Bundle m v a -> Bundle m v b -> Bundle m v c -> Bundle m v d - -> Bundle m v e -> Bundle m v (a,b,c,d,e) -{-# INLINE zip5 #-} -zip5 = zipWith5 (,,,,) - -zip6 :: Monad m => Bundle m v a -> Bundle m v b -> Bundle m v c -> Bundle m v d - -> Bundle m v e -> Bundle m v f -> Bundle m v (a,b,c,d,e,f) -{-# INLINE zip6 #-} -zip6 = zipWith6 (,,,,,) - --- Comparisons --- ----------- - --- | Check if two 'Bundle's are equal -eqBy :: (Monad m) => (a -> b -> Bool) -> Bundle m v a -> Bundle m v b -> m Bool -{-# INLINE_FUSED eqBy #-} -eqBy eq x y = S.eqBy eq (sElems x) (sElems y) - --- | Lexicographically compare two 'Bundle's -cmpBy :: (Monad m) => (a -> b -> Ordering) -> Bundle m v a -> Bundle m v b -> m Ordering -{-# INLINE_FUSED cmpBy #-} -cmpBy cmp x y = S.cmpBy cmp (sElems x) (sElems y) - --- Filtering --- --------- - --- | Drop elements which do not satisfy the predicate -filter :: Monad m => (a -> Bool) -> Bundle m v a -> Bundle m v a -{-# INLINE filter #-} -filter f = filterM (return . f) - --- | Drop elements which do not satisfy the monadic predicate -filterM :: Monad m => (a -> m Bool) -> Bundle m v a -> Bundle m v a -{-# INLINE_FUSED filterM #-} -filterM f Bundle{sElems = s, sSize = n} = fromStream (S.filterM f s) (toMax n) - --- | Longest prefix of elements that satisfy the predicate -takeWhile :: Monad m => (a -> Bool) -> Bundle m v a -> Bundle m v a -{-# INLINE takeWhile #-} -takeWhile f = takeWhileM (return . f) - --- | Longest prefix of elements that satisfy the monadic predicate -takeWhileM :: Monad m => (a -> m Bool) -> Bundle m v a -> Bundle m v a -{-# INLINE_FUSED takeWhileM #-} -takeWhileM f Bundle{sElems = s, sSize = n} = fromStream (S.takeWhileM f s) (toMax n) - --- | Drop the longest prefix of elements that satisfy the predicate -dropWhile :: Monad m => (a -> Bool) -> Bundle m v a -> Bundle m v a -{-# INLINE dropWhile #-} -dropWhile f = dropWhileM (return . f) - --- | Drop the longest prefix of elements that satisfy the monadic predicate -dropWhileM :: Monad m => (a -> m Bool) -> Bundle m v a -> Bundle m v a -{-# INLINE_FUSED dropWhileM #-} -dropWhileM f Bundle{sElems = s, sSize = n} = fromStream (S.dropWhileM f s) (toMax n) - --- Searching --- --------- - -infix 4 `elem` --- | Check whether the 'Bundle' contains an element -elem :: (Monad m, Eq a) => a -> Bundle m v a -> m Bool -{-# INLINE_FUSED elem #-} -elem x = S.elem x . sElems - -infix 4 `notElem` --- | Inverse of `elem` -notElem :: (Monad m, Eq a) => a -> Bundle m v a -> m Bool -{-# INLINE notElem #-} -notElem x = S.notElem x . sElems - --- | Yield 'Just' the first element that satisfies the predicate or 'Nothing' --- if no such element exists. -find :: Monad m => (a -> Bool) -> Bundle m v a -> m (Maybe a) -{-# INLINE find #-} -find f = findM (return . f) - --- | Yield 'Just' the first element that satisfies the monadic predicate or --- 'Nothing' if no such element exists. -findM :: Monad m => (a -> m Bool) -> Bundle m v a -> m (Maybe a) -{-# INLINE_FUSED findM #-} -findM f = S.findM f . sElems - --- | Yield 'Just' the index of the first element that satisfies the predicate --- or 'Nothing' if no such element exists. -findIndex :: Monad m => (a -> Bool) -> Bundle m v a -> m (Maybe Int) -{-# INLINE_FUSED findIndex #-} -findIndex f = findIndexM (return . f) - --- | Yield 'Just' the index of the first element that satisfies the monadic --- predicate or 'Nothing' if no such element exists. -findIndexM :: Monad m => (a -> m Bool) -> Bundle m v a -> m (Maybe Int) -{-# INLINE_FUSED findIndexM #-} -findIndexM f = S.findIndexM f . sElems - --- Folding --- ------- - --- | Left fold -foldl :: Monad m => (a -> b -> a) -> a -> Bundle m v b -> m a -{-# INLINE foldl #-} -foldl f = foldlM (\a b -> return (f a b)) - --- | Left fold with a monadic operator -foldlM :: Monad m => (a -> b -> m a) -> a -> Bundle m v b -> m a -{-# INLINE_FUSED foldlM #-} -foldlM m z = S.foldlM m z . sElems - --- | Same as 'foldlM' -foldM :: Monad m => (a -> b -> m a) -> a -> Bundle m v b -> m a -{-# INLINE foldM #-} -foldM = foldlM - --- | Left fold over a non-empty 'Bundle' -foldl1 :: Monad m => (a -> a -> a) -> Bundle m v a -> m a -{-# INLINE foldl1 #-} -foldl1 f = foldl1M (\a b -> return (f a b)) - --- | Left fold over a non-empty 'Bundle' with a monadic operator -foldl1M :: Monad m => (a -> a -> m a) -> Bundle m v a -> m a -{-# INLINE_FUSED foldl1M #-} -foldl1M f = S.foldl1M f . sElems - --- | Same as 'foldl1M' -fold1M :: Monad m => (a -> a -> m a) -> Bundle m v a -> m a -{-# INLINE fold1M #-} -fold1M = foldl1M - --- | Left fold with a strict accumulator -foldl' :: Monad m => (a -> b -> a) -> a -> Bundle m v b -> m a -{-# INLINE foldl' #-} -foldl' f = foldlM' (\a b -> return (f a b)) - --- | Left fold with a strict accumulator and a monadic operator -foldlM' :: Monad m => (a -> b -> m a) -> a -> Bundle m v b -> m a -{-# INLINE_FUSED foldlM' #-} -foldlM' m z = S.foldlM' m z . sElems - --- | Same as 'foldlM'' -foldM' :: Monad m => (a -> b -> m a) -> a -> Bundle m v b -> m a -{-# INLINE foldM' #-} -foldM' = foldlM' - --- | Left fold over a non-empty 'Bundle' with a strict accumulator -foldl1' :: Monad m => (a -> a -> a) -> Bundle m v a -> m a -{-# INLINE foldl1' #-} -foldl1' f = foldl1M' (\a b -> return (f a b)) - --- | Left fold over a non-empty 'Bundle' with a strict accumulator and a --- monadic operator -foldl1M' :: Monad m => (a -> a -> m a) -> Bundle m v a -> m a -{-# INLINE_FUSED foldl1M' #-} -foldl1M' f = S.foldl1M' f . sElems - --- | Same as 'foldl1M'' -fold1M' :: Monad m => (a -> a -> m a) -> Bundle m v a -> m a -{-# INLINE fold1M' #-} -fold1M' = foldl1M' - --- | Right fold -foldr :: Monad m => (a -> b -> b) -> b -> Bundle m v a -> m b -{-# INLINE foldr #-} -foldr f = foldrM (\a b -> return (f a b)) - --- | Right fold with a monadic operator -foldrM :: Monad m => (a -> b -> m b) -> b -> Bundle m v a -> m b -{-# INLINE_FUSED foldrM #-} -foldrM f z = S.foldrM f z . sElems - --- | Right fold over a non-empty stream -foldr1 :: Monad m => (a -> a -> a) -> Bundle m v a -> m a -{-# INLINE foldr1 #-} -foldr1 f = foldr1M (\a b -> return (f a b)) - --- | Right fold over a non-empty stream with a monadic operator -foldr1M :: Monad m => (a -> a -> m a) -> Bundle m v a -> m a -{-# INLINE_FUSED foldr1M #-} -foldr1M f = S.foldr1M f . sElems - --- Specialised folds --- ----------------- - -and :: Monad m => Bundle m v Bool -> m Bool -{-# INLINE_FUSED and #-} -and = S.and . sElems - -or :: Monad m => Bundle m v Bool -> m Bool -{-# INLINE_FUSED or #-} -or = S.or . sElems - -concatMap :: Monad m => (a -> Bundle m v b) -> Bundle m v a -> Bundle m v b -{-# INLINE concatMap #-} -concatMap f = concatMapM (return . f) - -concatMapM :: Monad m => (a -> m (Bundle m v b)) -> Bundle m v a -> Bundle m v b -{-# INLINE_FUSED concatMapM #-} -concatMapM f Bundle{sElems = s} = fromStream (S.concatMapM (liftM sElems . f) s) Unknown - --- | Create a 'Bundle' of values from a 'Bundle' of streamable things -flatten :: Monad m => (a -> m s) -> (s -> m (Step s b)) -> Size - -> Bundle m v a -> Bundle m v b -{-# INLINE_FUSED flatten #-} -flatten mk istep sz Bundle{sElems = s} = fromStream (S.flatten mk istep s) sz - --- Unfolding --- --------- - --- | Unfold -unfoldr :: Monad m => (s -> Maybe (a, s)) -> s -> Bundle m u a -{-# INLINE_FUSED unfoldr #-} -unfoldr f = unfoldrM (return . f) - --- | Unfold with a monadic function -unfoldrM :: Monad m => (s -> m (Maybe (a, s))) -> s -> Bundle m u a -{-# INLINE_FUSED unfoldrM #-} -unfoldrM f s = fromStream (S.unfoldrM f s) Unknown - --- | Unfold at most @n@ elements -unfoldrN :: Monad m => Int -> (s -> Maybe (a, s)) -> s -> Bundle m u a -{-# INLINE_FUSED unfoldrN #-} -unfoldrN n f = unfoldrNM n (return . f) - --- | Unfold at most @n@ elements with a monadic functions -unfoldrNM :: Monad m => Int -> (s -> m (Maybe (a, s))) -> s -> Bundle m u a -{-# INLINE_FUSED unfoldrNM #-} -unfoldrNM n f s = fromStream (S.unfoldrNM n f s) (Max (delay_inline max n 0)) - --- | Apply monadic function n times to value. Zeroth element is original value. -iterateNM :: Monad m => Int -> (a -> m a) -> a -> Bundle m u a -{-# INLINE_FUSED iterateNM #-} -iterateNM n f x0 = fromStream (S.iterateNM n f x0) (Exact (delay_inline max n 0)) - --- | Apply function n times to value. Zeroth element is original value. -iterateN :: Monad m => Int -> (a -> a) -> a -> Bundle m u a -{-# INLINE_FUSED iterateN #-} -iterateN n f x0 = iterateNM n (return . f) x0 - --- Scans --- ----- - --- | Prefix scan -prescanl :: Monad m => (a -> b -> a) -> a -> Bundle m v b -> Bundle m v a -{-# INLINE prescanl #-} -prescanl f = prescanlM (\a b -> return (f a b)) - --- | Prefix scan with a monadic operator -prescanlM :: Monad m => (a -> b -> m a) -> a -> Bundle m v b -> Bundle m v a -{-# INLINE_FUSED prescanlM #-} -prescanlM f z Bundle{sElems = s, sSize = sz} = fromStream (S.prescanlM f z s) sz - --- | Prefix scan with strict accumulator -prescanl' :: Monad m => (a -> b -> a) -> a -> Bundle m v b -> Bundle m v a -{-# INLINE prescanl' #-} -prescanl' f = prescanlM' (\a b -> return (f a b)) - --- | Prefix scan with strict accumulator and a monadic operator -prescanlM' :: Monad m => (a -> b -> m a) -> a -> Bundle m v b -> Bundle m v a -{-# INLINE_FUSED prescanlM' #-} -prescanlM' f z Bundle{sElems = s, sSize = sz} = fromStream (S.prescanlM' f z s) sz - --- | Suffix scan -postscanl :: Monad m => (a -> b -> a) -> a -> Bundle m v b -> Bundle m v a -{-# INLINE postscanl #-} -postscanl f = postscanlM (\a b -> return (f a b)) - --- | Suffix scan with a monadic operator -postscanlM :: Monad m => (a -> b -> m a) -> a -> Bundle m v b -> Bundle m v a -{-# INLINE_FUSED postscanlM #-} -postscanlM f z Bundle{sElems = s, sSize = sz} = fromStream (S.postscanlM f z s) sz - --- | Suffix scan with strict accumulator -postscanl' :: Monad m => (a -> b -> a) -> a -> Bundle m v b -> Bundle m v a -{-# INLINE postscanl' #-} -postscanl' f = postscanlM' (\a b -> return (f a b)) - --- | Suffix scan with strict acccumulator and a monadic operator -postscanlM' :: Monad m => (a -> b -> m a) -> a -> Bundle m v b -> Bundle m v a -{-# INLINE_FUSED postscanlM' #-} -postscanlM' f z Bundle{sElems = s, sSize = sz} = fromStream (S.postscanlM' f z s) sz - --- | Haskell-style scan -scanl :: Monad m => (a -> b -> a) -> a -> Bundle m v b -> Bundle m v a -{-# INLINE scanl #-} -scanl f = scanlM (\a b -> return (f a b)) - --- | Haskell-style scan with a monadic operator -scanlM :: Monad m => (a -> b -> m a) -> a -> Bundle m v b -> Bundle m v a -{-# INLINE scanlM #-} -scanlM f z s = z `cons` postscanlM f z s - --- | Haskell-style scan with strict accumulator -scanl' :: Monad m => (a -> b -> a) -> a -> Bundle m v b -> Bundle m v a -{-# INLINE scanl' #-} -scanl' f = scanlM' (\a b -> return (f a b)) - --- | Haskell-style scan with strict accumulator and a monadic operator -scanlM' :: Monad m => (a -> b -> m a) -> a -> Bundle m v b -> Bundle m v a -{-# INLINE scanlM' #-} -scanlM' f z s = z `seq` (z `cons` postscanlM f z s) - --- | Scan over a non-empty 'Bundle' -scanl1 :: Monad m => (a -> a -> a) -> Bundle m v a -> Bundle m v a -{-# INLINE scanl1 #-} -scanl1 f = scanl1M (\x y -> return (f x y)) - --- | Scan over a non-empty 'Bundle' with a monadic operator -scanl1M :: Monad m => (a -> a -> m a) -> Bundle m v a -> Bundle m v a -{-# INLINE_FUSED scanl1M #-} -scanl1M f Bundle{sElems = s, sSize = sz} = fromStream (S.scanl1M f s) sz - --- | Scan over a non-empty 'Bundle' with a strict accumulator -scanl1' :: Monad m => (a -> a -> a) -> Bundle m v a -> Bundle m v a -{-# INLINE scanl1' #-} -scanl1' f = scanl1M' (\x y -> return (f x y)) - --- | Scan over a non-empty 'Bundle' with a strict accumulator and a monadic --- operator -scanl1M' :: Monad m => (a -> a -> m a) -> Bundle m v a -> Bundle m v a -{-# INLINE_FUSED scanl1M' #-} -scanl1M' f Bundle{sElems = s, sSize = sz} = fromStream (S.scanl1M' f s) sz - --- Enumerations --- ------------ - --- The Enum class is broken for this, there just doesn't seem to be a --- way to implement this generically. We have to specialise for as many types --- as we can but this doesn't help in polymorphic loops. - --- | Yield a 'Bundle' of the given length containing the values @x@, @x+y@, --- @x+y+y@ etc. -enumFromStepN :: (Num a, Monad m) => a -> a -> Int -> Bundle m v a -{-# INLINE_FUSED enumFromStepN #-} -enumFromStepN x y n = fromStream (S.enumFromStepN x y n) (Exact (delay_inline max n 0)) - --- | Enumerate values --- --- /WARNING:/ This operation can be very inefficient. If at all possible, use --- 'enumFromStepN' instead. -enumFromTo :: (Enum a, Monad m) => a -> a -> Bundle m v a -{-# INLINE_FUSED enumFromTo #-} -enumFromTo x y = fromList [x .. y] - --- NOTE: We use (x+1) instead of (succ x) below because the latter checks for --- overflow which can't happen here. - --- FIXME: add "too large" test for Int -enumFromTo_small :: (Integral a, Monad m) => a -> a -> Bundle m v a -{-# INLINE_FUSED enumFromTo_small #-} -enumFromTo_small x y = x `seq` y `seq` fromStream (Stream step x) (Exact n) - where - n = delay_inline max (fromIntegral y - fromIntegral x + 1) 0 - - {-# INLINE_INNER step #-} - step z | z <= y = return $ Yield z (z+1) - | otherwise = return $ Done - -{-# RULES - -"enumFromTo<Int8> [Bundle]" - enumFromTo = enumFromTo_small :: Monad m => Int8 -> Int8 -> Bundle m v Int8 - -"enumFromTo<Int16> [Bundle]" - enumFromTo = enumFromTo_small :: Monad m => Int16 -> Int16 -> Bundle m v Int16 - -"enumFromTo<Word8> [Bundle]" - enumFromTo = enumFromTo_small :: Monad m => Word8 -> Word8 -> Bundle m v Word8 - -"enumFromTo<Word16> [Bundle]" - enumFromTo = enumFromTo_small :: Monad m => Word16 -> Word16 -> Bundle m v Word16 #-} - - - -#if WORD_SIZE_IN_BITS > 32 - -{-# RULES - -"enumFromTo<Int32> [Bundle]" - enumFromTo = enumFromTo_small :: Monad m => Int32 -> Int32 -> Bundle m v Int32 - -"enumFromTo<Word32> [Bundle]" - enumFromTo = enumFromTo_small :: Monad m => Word32 -> Word32 -> Bundle m v Word32 #-} - -#endif - --- NOTE: We could implement a generic "too large" test: --- --- len x y | x > y = 0 --- | n > 0 && n <= fromIntegral (maxBound :: Int) = fromIntegral n --- | otherwise = error --- where --- n = y-x+1 --- --- Alas, GHC won't eliminate unnecessary comparisons (such as n >= 0 for --- unsigned types). See http://hackage.haskell.org/trac/ghc/ticket/3744 --- - -enumFromTo_int :: forall m v. Monad m => Int -> Int -> Bundle m v Int -{-# INLINE_FUSED enumFromTo_int #-} -enumFromTo_int x y = x `seq` y `seq` fromStream (Stream step x) (Exact (len x y)) - where - {-# INLINE [0] len #-} - len :: Int -> Int -> Int - len u v | u > v = 0 - | otherwise = BOUNDS_CHECK(check) "enumFromTo" "vector too large" - (n > 0) - $ n - where - n = v-u+1 - - {-# INLINE_INNER step #-} - step z | z <= y = return $ Yield z (z+1) - | otherwise = return $ Done - -enumFromTo_intlike :: (Integral a, Monad m) => a -> a -> Bundle m v a -{-# INLINE_FUSED enumFromTo_intlike #-} -enumFromTo_intlike x y = x `seq` y `seq` fromStream (Stream step x) (Exact (len x y)) - where - {-# INLINE [0] len #-} - len u v | u > v = 0 - | otherwise = BOUNDS_CHECK(check) "enumFromTo" "vector too large" - (n > 0) - $ fromIntegral n - where - n = v-u+1 - - {-# INLINE_INNER step #-} - step z | z <= y = return $ Yield z (z+1) - | otherwise = return $ Done - -{-# RULES - -"enumFromTo<Int> [Bundle]" - enumFromTo = enumFromTo_int :: Monad m => Int -> Int -> Bundle m v Int - -#if WORD_SIZE_IN_BITS > 32 - -"enumFromTo<Int64> [Bundle]" - enumFromTo = enumFromTo_intlike :: Monad m => Int64 -> Int64 -> Bundle m v Int64 #-} - -#else - -"enumFromTo<Int32> [Bundle]" - enumFromTo = enumFromTo_intlike :: Monad m => Int32 -> Int32 -> Bundle m v Int32 #-} - -#endif - - - -enumFromTo_big_word :: (Integral a, Monad m) => a -> a -> Bundle m v a -{-# INLINE_FUSED enumFromTo_big_word #-} -enumFromTo_big_word x y = x `seq` y `seq` fromStream (Stream step x) (Exact (len x y)) - where - {-# INLINE [0] len #-} - len u v | u > v = 0 - | otherwise = BOUNDS_CHECK(check) "enumFromTo" "vector too large" - (n < fromIntegral (maxBound :: Int)) - $ fromIntegral (n+1) - where - n = v-u - - {-# INLINE_INNER step #-} - step z | z <= y = return $ Yield z (z+1) - | otherwise = return $ Done - -{-# RULES - -"enumFromTo<Word> [Bundle]" - enumFromTo = enumFromTo_big_word :: Monad m => Word -> Word -> Bundle m v Word - -"enumFromTo<Word64> [Bundle]" - enumFromTo = enumFromTo_big_word - :: Monad m => Word64 -> Word64 -> Bundle m v Word64 - -#if WORD_SIZE_IN_BITS == 32 - -"enumFromTo<Word32> [Bundle]" - enumFromTo = enumFromTo_big_word - :: Monad m => Word32 -> Word32 -> Bundle m v Word32 - -#endif - -"enumFromTo<Integer> [Bundle]" - enumFromTo = enumFromTo_big_word - :: Monad m => Integer -> Integer -> Bundle m v Integer #-} - - -#if WORD_SIZE_IN_BITS > 32 - --- FIXME: the "too large" test is totally wrong -enumFromTo_big_int :: (Integral a, Monad m) => a -> a -> Bundle m v a -{-# INLINE_FUSED enumFromTo_big_int #-} -enumFromTo_big_int x y = x `seq` y `seq` fromStream (Stream step x) (Exact (len x y)) - where - {-# INLINE [0] len #-} - len u v | u > v = 0 - | otherwise = BOUNDS_CHECK(check) "enumFromTo" "vector too large" - (n > 0 && n <= fromIntegral (maxBound :: Int)) - $ fromIntegral n - where - n = v-u+1 - - {-# INLINE_INNER step #-} - step z | z <= y = return $ Yield z (z+1) - | otherwise = return $ Done - - -{-# RULES - -"enumFromTo<Int64> [Bundle]" - enumFromTo = enumFromTo_big_int :: Monad m => Int64 -> Int64 -> Bundle m v Int64 #-} - - - -#endif - -enumFromTo_char :: Monad m => Char -> Char -> Bundle m v Char -{-# INLINE_FUSED enumFromTo_char #-} -enumFromTo_char x y = x `seq` y `seq` fromStream (Stream step xn) (Exact n) - where - xn = ord x - yn = ord y - - n = delay_inline max 0 (yn - xn + 1) - - {-# INLINE_INNER step #-} - step zn | zn <= yn = return $ Yield (unsafeChr zn) (zn+1) - | otherwise = return $ Done - -{-# RULES - -"enumFromTo<Char> [Bundle]" - enumFromTo = enumFromTo_char #-} - - - ------------------------------------------------------------------------- - --- Specialise enumFromTo for Float and Double. --- Also, try to do something about pairs? - -enumFromTo_double :: (Monad m, Ord a, RealFrac a) => a -> a -> Bundle m v a -{-# INLINE_FUSED enumFromTo_double #-} -enumFromTo_double n m = n `seq` m `seq` fromStream (Stream step n) (Max (len n lim)) - where - lim = m + 1/2 -- important to float out - - {-# INLINE [0] len #-} - len x y | x > y = 0 - | otherwise = BOUNDS_CHECK(check) "enumFromTo" "vector too large" - (l > 0) - $ fromIntegral l - where - l :: Integer - l = truncate (y-x)+2 - - {-# INLINE_INNER step #-} - step x | x <= lim = return $ Yield x (x+1) - | otherwise = return $ Done - -{-# RULES - -"enumFromTo<Double> [Bundle]" - enumFromTo = enumFromTo_double :: Monad m => Double -> Double -> Bundle m v Double - -"enumFromTo<Float> [Bundle]" - enumFromTo = enumFromTo_double :: Monad m => Float -> Float -> Bundle m v Float #-} - - - ------------------------------------------------------------------------- - --- | Enumerate values with a given step. --- --- /WARNING:/ This operation is very inefficient. If at all possible, use --- 'enumFromStepN' instead. -enumFromThenTo :: (Enum a, Monad m) => a -> a -> a -> Bundle m v a -{-# INLINE_FUSED enumFromThenTo #-} -enumFromThenTo x y z = fromList [x, y .. z] - --- FIXME: Specialise enumFromThenTo. - --- Conversions --- ----------- - --- | Convert a 'Bundle' to a list -toList :: Monad m => Bundle m v a -> m [a] -{-# INLINE toList #-} -toList = foldr (:) [] - --- | Convert a list to a 'Bundle' -fromList :: Monad m => [a] -> Bundle m v a -{-# INLINE fromList #-} -fromList xs = unsafeFromList Unknown xs - --- | Convert the first @n@ elements of a list to a 'Bundle' -fromListN :: Monad m => Int -> [a] -> Bundle m v a -{-# INLINE_FUSED fromListN #-} -fromListN n xs = fromStream (S.fromListN n xs) (Max (delay_inline max n 0)) - --- | Convert a list to a 'Bundle' with the given 'Size' hint. -unsafeFromList :: Monad m => Size -> [a] -> Bundle m v a -{-# INLINE_FUSED unsafeFromList #-} -unsafeFromList sz xs = fromStream (S.fromList xs) sz - -fromVector :: (Monad m, Vector v a) => v a -> Bundle m v a -{-# INLINE_FUSED fromVector #-} -fromVector v = v `seq` n `seq` Bundle (Stream step 0) - (Stream vstep True) - (Just v) - (Exact n) - where - n = basicLength v - - {-# INLINE step #-} - step i | i >= n = return Done - | otherwise = case basicUnsafeIndexM v i of - Box x -> return $ Yield x (i+1) - - - {-# INLINE vstep #-} - vstep True = return (Yield (Chunk (basicLength v) (\mv -> basicUnsafeCopy mv v)) False) - vstep False = return Done - -fromVectors :: forall m v a. (Monad m, Vector v a) => [v a] -> Bundle m v a -{-# INLINE_FUSED fromVectors #-} -fromVectors us = Bundle (Stream pstep (Left us)) - (Stream vstep us) - Nothing - (Exact n) - where - n = List.foldl' (\k v -> k + basicLength v) 0 us - - pstep (Left []) = return Done - pstep (Left (v:vs)) = basicLength v `seq` return (Skip (Right (v,0,vs))) - - pstep (Right (v,i,vs)) - | i >= basicLength v = return $ Skip (Left vs) - | otherwise = case basicUnsafeIndexM v i of - Box x -> return $ Yield x (Right (v,i+1,vs)) - - -- FIXME: work around bug in GHC 7.6.1 - vstep :: [v a] -> m (Step [v a] (Chunk v a)) - vstep [] = return Done - vstep (v:vs) = return $ Yield (Chunk (basicLength v) - (\mv -> INTERNAL_CHECK(check) "concatVectors" "length mismatch" - (M.basicLength mv == basicLength v) - $ basicUnsafeCopy mv v)) vs - - -concatVectors :: (Monad m, Vector v a) => Bundle m u (v a) -> Bundle m v a -{-# INLINE_FUSED concatVectors #-} -concatVectors Bundle{sElems = Stream step t} - = Bundle (Stream pstep (Left t)) - (Stream vstep t) - Nothing - Unknown - where - pstep (Left s) = do - r <- step s - case r of - Yield v s' -> basicLength v `seq` return (Skip (Right (v,0,s'))) - Skip s' -> return (Skip (Left s')) - Done -> return Done - - pstep (Right (v,i,s)) - | i >= basicLength v = return (Skip (Left s)) - | otherwise = case basicUnsafeIndexM v i of - Box x -> return (Yield x (Right (v,i+1,s))) - - - vstep s = do - r <- step s - case r of - Yield v s' -> return (Yield (Chunk (basicLength v) - (\mv -> INTERNAL_CHECK(check) "concatVectors" "length mismatch" - (M.basicLength mv == basicLength v) - $ basicUnsafeCopy mv v)) s') - Skip s' -> return (Skip s') - Done -> return Done - -reVector :: Monad m => Bundle m u a -> Bundle m v a -{-# INLINE_FUSED reVector #-} -reVector Bundle{sElems = s, sSize = n} = fromStream s n - -{-# RULES - -"reVector [Vector]" - reVector = id - -"reVector/reVector [Vector]" forall s. - reVector (reVector s) = s #-} - - - diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Bundle/Size.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Bundle/Size.hs deleted file mode 100644 index e90cf373202d..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Bundle/Size.hs +++ /dev/null @@ -1,121 +0,0 @@ --- | --- Module : Data.Vector.Fusion.Bundle.Size --- Copyright : (c) Roman Leshchinskiy 2008-2010 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Stability : experimental --- Portability : portable --- --- Size hints for streams. --- - -module Data.Vector.Fusion.Bundle.Size ( - Size(..), clampedSubtract, smaller, larger, toMax, upperBound, lowerBound -) where - -import Data.Vector.Fusion.Util ( delay_inline ) - --- | Size hint -data Size = Exact Int -- ^ Exact size - | Max Int -- ^ Upper bound on the size - | Unknown -- ^ Unknown size - deriving( Eq, Show ) - -instance Num Size where - Exact m + Exact n = checkedAdd Exact m n - Exact m + Max n = checkedAdd Max m n - - Max m + Exact n = checkedAdd Max m n - Max m + Max n = checkedAdd Max m n - - _ + _ = Unknown - - - Exact m - Exact n = checkedSubtract Exact m n - Exact m - Max _ = Max m - - Max m - Exact n = checkedSubtract Max m n - Max m - Max _ = Max m - Max m - Unknown = Max m - - _ - _ = Unknown - - - fromInteger n = Exact (fromInteger n) - - (*) = error "vector: internal error * for Bundle.size isn't defined" - abs = error "vector: internal error abs for Bundle.size isn't defined" - signum = error "vector: internal error signum for Bundle.size isn't defined" - -{-# INLINE checkedAdd #-} -checkedAdd :: (Int -> Size) -> Int -> Int -> Size -checkedAdd con m n - -- Note: we assume m and n are >= 0. - | r < m || r < n = - error $ "Data.Vector.Fusion.Bundle.Size.checkedAdd: overflow: " ++ show r - | otherwise = con r - where - r = m + n - -{-# INLINE checkedSubtract #-} -checkedSubtract :: (Int -> Size) -> Int -> Int -> Size -checkedSubtract con m n - | r < 0 = - error $ "Data.Vector.Fusion.Bundle.Size.checkedSubtract: underflow: " ++ show r - | otherwise = con r - where - r = m - n - --- | Subtract two sizes with clamping to 0, for drop-like things -{-# INLINE clampedSubtract #-} -clampedSubtract :: Size -> Size -> Size -clampedSubtract (Exact m) (Exact n) = Exact (max 0 (m - n)) -clampedSubtract (Max m) (Exact n) - | m <= n = Exact 0 - | otherwise = Max (m - n) -clampedSubtract (Exact m) (Max _) = Max m -clampedSubtract (Max m) (Max _) = Max m -clampedSubtract _ _ = Unknown - --- | Minimum of two size hints -smaller :: Size -> Size -> Size -{-# INLINE smaller #-} -smaller (Exact m) (Exact n) = Exact (delay_inline min m n) -smaller (Exact m) (Max n) = Max (delay_inline min m n) -smaller (Exact m) Unknown = Max m -smaller (Max m) (Exact n) = Max (delay_inline min m n) -smaller (Max m) (Max n) = Max (delay_inline min m n) -smaller (Max m) Unknown = Max m -smaller Unknown (Exact n) = Max n -smaller Unknown (Max n) = Max n -smaller Unknown Unknown = Unknown - --- | Maximum of two size hints -larger :: Size -> Size -> Size -{-# INLINE larger #-} -larger (Exact m) (Exact n) = Exact (delay_inline max m n) -larger (Exact m) (Max n) | m >= n = Exact m - | otherwise = Max n -larger (Max m) (Exact n) | n >= m = Exact n - | otherwise = Max m -larger (Max m) (Max n) = Max (delay_inline max m n) -larger _ _ = Unknown - --- | Convert a size hint to an upper bound -toMax :: Size -> Size -toMax (Exact n) = Max n -toMax (Max n) = Max n -toMax Unknown = Unknown - --- | Compute the minimum size from a size hint -lowerBound :: Size -> Int -lowerBound (Exact n) = n -lowerBound _ = 0 - --- | Compute the maximum size from a size hint if possible -upperBound :: Size -> Maybe Int -upperBound (Exact n) = Just n -upperBound (Max n) = Just n -upperBound Unknown = Nothing - diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Stream/Monadic.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Stream/Monadic.hs deleted file mode 100644 index cca002ca6f74..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Stream/Monadic.hs +++ /dev/null @@ -1,1639 +0,0 @@ -{-# LANGUAGE CPP, ExistentialQuantification, MultiParamTypeClasses, FlexibleInstances, Rank2Types, BangPatterns, KindSignatures, GADTs, ScopedTypeVariables #-} - --- | --- Module : Data.Vector.Fusion.Stream.Monadic --- Copyright : (c) Roman Leshchinskiy 2008-2010 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Stability : experimental --- Portability : non-portable --- --- Monadic stream combinators. --- - -module Data.Vector.Fusion.Stream.Monadic ( - Stream(..), Step(..), SPEC(..), - - -- * Length - length, null, - - -- * Construction - empty, singleton, cons, snoc, replicate, replicateM, generate, generateM, (++), - - -- * Accessing elements - head, last, (!!), (!?), - - -- * Substreams - slice, init, tail, take, drop, - - -- * Mapping - map, mapM, mapM_, trans, unbox, concatMap, flatten, - - -- * Zipping - indexed, indexedR, zipWithM_, - zipWithM, zipWith3M, zipWith4M, zipWith5M, zipWith6M, - zipWith, zipWith3, zipWith4, zipWith5, zipWith6, - zip, zip3, zip4, zip5, zip6, - - -- * Comparisons - eqBy, cmpBy, - - -- * Filtering - filter, filterM, uniq, mapMaybe, takeWhile, takeWhileM, dropWhile, dropWhileM, - - -- * Searching - elem, notElem, find, findM, findIndex, findIndexM, - - -- * Folding - foldl, foldlM, foldl1, foldl1M, foldM, fold1M, - foldl', foldlM', foldl1', foldl1M', foldM', fold1M', - foldr, foldrM, foldr1, foldr1M, - - -- * Specialised folds - and, or, concatMapM, - - -- * Unfolding - unfoldr, unfoldrM, - unfoldrN, unfoldrNM, - iterateN, iterateNM, - - -- * Scans - prescanl, prescanlM, prescanl', prescanlM', - postscanl, postscanlM, postscanl', postscanlM', - scanl, scanlM, scanl', scanlM', - scanl1, scanl1M, scanl1', scanl1M', - - -- * Enumerations - enumFromStepN, enumFromTo, enumFromThenTo, - - -- * Conversions - toList, fromList, fromListN -) where - -import Data.Vector.Fusion.Util ( Box(..) ) - -import Data.Char ( ord ) -import GHC.Base ( unsafeChr ) -import Control.Monad ( liftM ) -import Prelude hiding ( length, null, - replicate, (++), - head, last, (!!), - init, tail, take, drop, - map, mapM, mapM_, concatMap, - zipWith, zipWith3, zip, zip3, - filter, takeWhile, dropWhile, - elem, notElem, - foldl, foldl1, foldr, foldr1, - and, or, - scanl, scanl1, - enumFromTo, enumFromThenTo ) - -import Data.Int ( Int8, Int16, Int32 ) -import Data.Word ( Word8, Word16, Word32, Word64 ) - -#if !MIN_VERSION_base(4,8,0) -import Data.Word ( Word8, Word16, Word32, Word, Word64 ) -#endif - -#if __GLASGOW_HASKELL__ >= 708 -import GHC.Types ( SPEC(..) ) -#elif __GLASGOW_HASKELL__ >= 700 -import GHC.Exts ( SpecConstrAnnotation(..) ) -#endif - -#include "vector.h" -#include "MachDeps.h" - -#if WORD_SIZE_IN_BITS > 32 -import Data.Int ( Int64 ) -#endif - -#if __GLASGOW_HASKELL__ < 708 -data SPEC = SPEC | SPEC2 -#if __GLASGOW_HASKELL__ >= 700 -{-# ANN type SPEC ForceSpecConstr #-} -#endif -#endif - -emptyStream :: String -{-# NOINLINE emptyStream #-} -emptyStream = "empty stream" - -#define EMPTY_STREAM (\state -> ERROR state emptyStream) - --- | Result of taking a single step in a stream -data Step s a where - Yield :: a -> s -> Step s a - Skip :: s -> Step s a - Done :: Step s a - -instance Functor (Step s) where - {-# INLINE fmap #-} - fmap f (Yield x s) = Yield (f x) s - fmap _ (Skip s) = Skip s - fmap _ Done = Done - --- | Monadic streams -data Stream m a = forall s. Stream (s -> m (Step s a)) s - --- Length --- ------ - --- | Length of a 'Stream' -length :: Monad m => Stream m a -> m Int -{-# INLINE_FUSED length #-} -length = foldl' (\n _ -> n+1) 0 - --- | Check if a 'Stream' is empty -null :: Monad m => Stream m a -> m Bool -{-# INLINE_FUSED null #-} -null (Stream step t) = null_loop t - where - null_loop s = do - r <- step s - case r of - Yield _ _ -> return False - Skip s' -> null_loop s' - Done -> return True - --- Construction --- ------------ - --- | Empty 'Stream' -empty :: Monad m => Stream m a -{-# INLINE_FUSED empty #-} -empty = Stream (const (return Done)) () - --- | Singleton 'Stream' -singleton :: Monad m => a -> Stream m a -{-# INLINE_FUSED singleton #-} -singleton x = Stream (return . step) True - where - {-# INLINE_INNER step #-} - step True = Yield x False - step False = Done - --- | Replicate a value to a given length -replicate :: Monad m => Int -> a -> Stream m a -{-# INLINE_FUSED replicate #-} -replicate n x = replicateM n (return x) - --- | Yield a 'Stream' of values obtained by performing the monadic action the --- given number of times -replicateM :: Monad m => Int -> m a -> Stream m a -{-# INLINE_FUSED replicateM #-} -replicateM n p = Stream step n - where - {-# INLINE_INNER step #-} - step i | i <= 0 = return Done - | otherwise = do { x <- p; return $ Yield x (i-1) } - -generate :: Monad m => Int -> (Int -> a) -> Stream m a -{-# INLINE generate #-} -generate n f = generateM n (return . f) - --- | Generate a stream from its indices -generateM :: Monad m => Int -> (Int -> m a) -> Stream m a -{-# INLINE_FUSED generateM #-} -generateM n f = n `seq` Stream step 0 - where - {-# INLINE_INNER step #-} - step i | i < n = do - x <- f i - return $ Yield x (i+1) - | otherwise = return Done - --- | Prepend an element -cons :: Monad m => a -> Stream m a -> Stream m a -{-# INLINE cons #-} -cons x s = singleton x ++ s - --- | Append an element -snoc :: Monad m => Stream m a -> a -> Stream m a -{-# INLINE snoc #-} -snoc s x = s ++ singleton x - -infixr 5 ++ --- | Concatenate two 'Stream's -(++) :: Monad m => Stream m a -> Stream m a -> Stream m a -{-# INLINE_FUSED (++) #-} -Stream stepa ta ++ Stream stepb tb = Stream step (Left ta) - where - {-# INLINE_INNER step #-} - step (Left sa) = do - r <- stepa sa - case r of - Yield x sa' -> return $ Yield x (Left sa') - Skip sa' -> return $ Skip (Left sa') - Done -> return $ Skip (Right tb) - step (Right sb) = do - r <- stepb sb - case r of - Yield x sb' -> return $ Yield x (Right sb') - Skip sb' -> return $ Skip (Right sb') - Done -> return $ Done - --- Accessing elements --- ------------------ - --- | First element of the 'Stream' or error if empty -head :: Monad m => Stream m a -> m a -{-# INLINE_FUSED head #-} -head (Stream step t) = head_loop SPEC t - where - head_loop !_ s - = do - r <- step s - case r of - Yield x _ -> return x - Skip s' -> head_loop SPEC s' - Done -> EMPTY_STREAM "head" - - - --- | Last element of the 'Stream' or error if empty -last :: Monad m => Stream m a -> m a -{-# INLINE_FUSED last #-} -last (Stream step t) = last_loop0 SPEC t - where - last_loop0 !_ s - = do - r <- step s - case r of - Yield x s' -> last_loop1 SPEC x s' - Skip s' -> last_loop0 SPEC s' - Done -> EMPTY_STREAM "last" - - last_loop1 !_ x s - = do - r <- step s - case r of - Yield y s' -> last_loop1 SPEC y s' - Skip s' -> last_loop1 SPEC x s' - Done -> return x - -infixl 9 !! --- | Element at the given position -(!!) :: Monad m => Stream m a -> Int -> m a -{-# INLINE (!!) #-} -Stream step t !! j | j < 0 = ERROR "!!" "negative index" - | otherwise = index_loop SPEC t j - where - index_loop !_ s i - = i `seq` - do - r <- step s - case r of - Yield x s' | i == 0 -> return x - | otherwise -> index_loop SPEC s' (i-1) - Skip s' -> index_loop SPEC s' i - Done -> EMPTY_STREAM "!!" - -infixl 9 !? --- | Element at the given position or 'Nothing' if out of bounds -(!?) :: Monad m => Stream m a -> Int -> m (Maybe a) -{-# INLINE (!?) #-} -Stream step t !? j = index_loop SPEC t j - where - index_loop !_ s i - = i `seq` - do - r <- step s - case r of - Yield x s' | i == 0 -> return (Just x) - | otherwise -> index_loop SPEC s' (i-1) - Skip s' -> index_loop SPEC s' i - Done -> return Nothing - --- Substreams --- ---------- - --- | Extract a substream of the given length starting at the given position. -slice :: Monad m => Int -- ^ starting index - -> Int -- ^ length - -> Stream m a - -> Stream m a -{-# INLINE slice #-} -slice i n s = take n (drop i s) - --- | All but the last element -init :: Monad m => Stream m a -> Stream m a -{-# INLINE_FUSED init #-} -init (Stream step t) = Stream step' (Nothing, t) - where - {-# INLINE_INNER step' #-} - step' (Nothing, s) = liftM (\r -> - case r of - Yield x s' -> Skip (Just x, s') - Skip s' -> Skip (Nothing, s') - Done -> EMPTY_STREAM "init" - ) (step s) - - step' (Just x, s) = liftM (\r -> - case r of - Yield y s' -> Yield x (Just y, s') - Skip s' -> Skip (Just x, s') - Done -> Done - ) (step s) - --- | All but the first element -tail :: Monad m => Stream m a -> Stream m a -{-# INLINE_FUSED tail #-} -tail (Stream step t) = Stream step' (Left t) - where - {-# INLINE_INNER step' #-} - step' (Left s) = liftM (\r -> - case r of - Yield _ s' -> Skip (Right s') - Skip s' -> Skip (Left s') - Done -> EMPTY_STREAM "tail" - ) (step s) - - step' (Right s) = liftM (\r -> - case r of - Yield x s' -> Yield x (Right s') - Skip s' -> Skip (Right s') - Done -> Done - ) (step s) - --- | The first @n@ elements -take :: Monad m => Int -> Stream m a -> Stream m a -{-# INLINE_FUSED take #-} -take n (Stream step t) = n `seq` Stream step' (t, 0) - where - {-# INLINE_INNER step' #-} - step' (s, i) | i < n = liftM (\r -> - case r of - Yield x s' -> Yield x (s', i+1) - Skip s' -> Skip (s', i) - Done -> Done - ) (step s) - step' (_, _) = return Done - --- | All but the first @n@ elements -drop :: Monad m => Int -> Stream m a -> Stream m a -{-# INLINE_FUSED drop #-} -drop n (Stream step t) = Stream step' (t, Just n) - where - {-# INLINE_INNER step' #-} - step' (s, Just i) | i > 0 = liftM (\r -> - case r of - Yield _ s' -> Skip (s', Just (i-1)) - Skip s' -> Skip (s', Just i) - Done -> Done - ) (step s) - | otherwise = return $ Skip (s, Nothing) - - step' (s, Nothing) = liftM (\r -> - case r of - Yield x s' -> Yield x (s', Nothing) - Skip s' -> Skip (s', Nothing) - Done -> Done - ) (step s) - --- Mapping --- ------- - -instance Monad m => Functor (Stream m) where - {-# INLINE fmap #-} - fmap = map - --- | Map a function over a 'Stream' -map :: Monad m => (a -> b) -> Stream m a -> Stream m b -{-# INLINE map #-} -map f = mapM (return . f) - - --- | Map a monadic function over a 'Stream' -mapM :: Monad m => (a -> m b) -> Stream m a -> Stream m b -{-# INLINE_FUSED mapM #-} -mapM f (Stream step t) = Stream step' t - where - {-# INLINE_INNER step' #-} - step' s = do - r <- step s - case r of - Yield x s' -> liftM (`Yield` s') (f x) - Skip s' -> return (Skip s') - Done -> return Done - -consume :: Monad m => Stream m a -> m () -{-# INLINE_FUSED consume #-} -consume (Stream step t) = consume_loop SPEC t - where - consume_loop !_ s - = do - r <- step s - case r of - Yield _ s' -> consume_loop SPEC s' - Skip s' -> consume_loop SPEC s' - Done -> return () - --- | Execute a monadic action for each element of the 'Stream' -mapM_ :: Monad m => (a -> m b) -> Stream m a -> m () -{-# INLINE_FUSED mapM_ #-} -mapM_ m = consume . mapM m - --- | Transform a 'Stream' to use a different monad -trans :: (Monad m, Monad m') - => (forall z. m z -> m' z) -> Stream m a -> Stream m' a -{-# INLINE_FUSED trans #-} -trans f (Stream step s) = Stream (f . step) s - -unbox :: Monad m => Stream m (Box a) -> Stream m a -{-# INLINE_FUSED unbox #-} -unbox (Stream step t) = Stream step' t - where - {-# INLINE_INNER step' #-} - step' s = do - r <- step s - case r of - Yield (Box x) s' -> return $ Yield x s' - Skip s' -> return $ Skip s' - Done -> return $ Done - --- Zipping --- ------- - --- | Pair each element in a 'Stream' with its index -indexed :: Monad m => Stream m a -> Stream m (Int,a) -{-# INLINE_FUSED indexed #-} -indexed (Stream step t) = Stream step' (t,0) - where - {-# INLINE_INNER step' #-} - step' (s,i) = i `seq` - do - r <- step s - case r of - Yield x s' -> return $ Yield (i,x) (s', i+1) - Skip s' -> return $ Skip (s', i) - Done -> return Done - --- | Pair each element in a 'Stream' with its index, starting from the right --- and counting down -indexedR :: Monad m => Int -> Stream m a -> Stream m (Int,a) -{-# INLINE_FUSED indexedR #-} -indexedR m (Stream step t) = Stream step' (t,m) - where - {-# INLINE_INNER step' #-} - step' (s,i) = i `seq` - do - r <- step s - case r of - Yield x s' -> let i' = i-1 - in - return $ Yield (i',x) (s', i') - Skip s' -> return $ Skip (s', i) - Done -> return Done - --- | Zip two 'Stream's with the given monadic function -zipWithM :: Monad m => (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c -{-# INLINE_FUSED zipWithM #-} -zipWithM f (Stream stepa ta) (Stream stepb tb) = Stream step (ta, tb, Nothing) - where - {-# INLINE_INNER step #-} - step (sa, sb, Nothing) = liftM (\r -> - case r of - Yield x sa' -> Skip (sa', sb, Just x) - Skip sa' -> Skip (sa', sb, Nothing) - Done -> Done - ) (stepa sa) - - step (sa, sb, Just x) = do - r <- stepb sb - case r of - Yield y sb' -> - do - z <- f x y - return $ Yield z (sa, sb', Nothing) - Skip sb' -> return $ Skip (sa, sb', Just x) - Done -> return $ Done - --- FIXME: This might expose an opportunity for inplace execution. -{-# RULES - -"zipWithM xs xs [Vector.Stream]" forall f xs. - zipWithM f xs xs = mapM (\x -> f x x) xs #-} - - -zipWithM_ :: Monad m => (a -> b -> m c) -> Stream m a -> Stream m b -> m () -{-# INLINE zipWithM_ #-} -zipWithM_ f sa sb = consume (zipWithM f sa sb) - -zipWith3M :: Monad m => (a -> b -> c -> m d) -> Stream m a -> Stream m b -> Stream m c -> Stream m d -{-# INLINE_FUSED zipWith3M #-} -zipWith3M f (Stream stepa ta) - (Stream stepb tb) - (Stream stepc tc) = Stream step (ta, tb, tc, Nothing) - where - {-# INLINE_INNER step #-} - step (sa, sb, sc, Nothing) = do - r <- stepa sa - return $ case r of - Yield x sa' -> Skip (sa', sb, sc, Just (x, Nothing)) - Skip sa' -> Skip (sa', sb, sc, Nothing) - Done -> Done - - step (sa, sb, sc, Just (x, Nothing)) = do - r <- stepb sb - return $ case r of - Yield y sb' -> Skip (sa, sb', sc, Just (x, Just y)) - Skip sb' -> Skip (sa, sb', sc, Just (x, Nothing)) - Done -> Done - - step (sa, sb, sc, Just (x, Just y)) = do - r <- stepc sc - case r of - Yield z sc' -> f x y z >>= (\res -> return $ Yield res (sa, sb, sc', Nothing)) - Skip sc' -> return $ Skip (sa, sb, sc', Just (x, Just y)) - Done -> return $ Done - -zipWith4M :: Monad m => (a -> b -> c -> d -> m e) - -> Stream m a -> Stream m b -> Stream m c -> Stream m d - -> Stream m e -{-# INLINE zipWith4M #-} -zipWith4M f sa sb sc sd - = zipWithM (\(a,b) (c,d) -> f a b c d) (zip sa sb) (zip sc sd) - -zipWith5M :: Monad m => (a -> b -> c -> d -> e -> m f) - -> Stream m a -> Stream m b -> Stream m c -> Stream m d - -> Stream m e -> Stream m f -{-# INLINE zipWith5M #-} -zipWith5M f sa sb sc sd se - = zipWithM (\(a,b,c) (d,e) -> f a b c d e) (zip3 sa sb sc) (zip sd se) - -zipWith6M :: Monad m => (a -> b -> c -> d -> e -> f -> m g) - -> Stream m a -> Stream m b -> Stream m c -> Stream m d - -> Stream m e -> Stream m f -> Stream m g -{-# INLINE zipWith6M #-} -zipWith6M fn sa sb sc sd se sf - = zipWithM (\(a,b,c) (d,e,f) -> fn a b c d e f) (zip3 sa sb sc) - (zip3 sd se sf) - -zipWith :: Monad m => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c -{-# INLINE zipWith #-} -zipWith f = zipWithM (\a b -> return (f a b)) - -zipWith3 :: Monad m => (a -> b -> c -> d) - -> Stream m a -> Stream m b -> Stream m c -> Stream m d -{-# INLINE zipWith3 #-} -zipWith3 f = zipWith3M (\a b c -> return (f a b c)) - -zipWith4 :: Monad m => (a -> b -> c -> d -> e) - -> Stream m a -> Stream m b -> Stream m c -> Stream m d - -> Stream m e -{-# INLINE zipWith4 #-} -zipWith4 f = zipWith4M (\a b c d -> return (f a b c d)) - -zipWith5 :: Monad m => (a -> b -> c -> d -> e -> f) - -> Stream m a -> Stream m b -> Stream m c -> Stream m d - -> Stream m e -> Stream m f -{-# INLINE zipWith5 #-} -zipWith5 f = zipWith5M (\a b c d e -> return (f a b c d e)) - -zipWith6 :: Monad m => (a -> b -> c -> d -> e -> f -> g) - -> Stream m a -> Stream m b -> Stream m c -> Stream m d - -> Stream m e -> Stream m f -> Stream m g -{-# INLINE zipWith6 #-} -zipWith6 fn = zipWith6M (\a b c d e f -> return (fn a b c d e f)) - -zip :: Monad m => Stream m a -> Stream m b -> Stream m (a,b) -{-# INLINE zip #-} -zip = zipWith (,) - -zip3 :: Monad m => Stream m a -> Stream m b -> Stream m c -> Stream m (a,b,c) -{-# INLINE zip3 #-} -zip3 = zipWith3 (,,) - -zip4 :: Monad m => Stream m a -> Stream m b -> Stream m c -> Stream m d - -> Stream m (a,b,c,d) -{-# INLINE zip4 #-} -zip4 = zipWith4 (,,,) - -zip5 :: Monad m => Stream m a -> Stream m b -> Stream m c -> Stream m d - -> Stream m e -> Stream m (a,b,c,d,e) -{-# INLINE zip5 #-} -zip5 = zipWith5 (,,,,) - -zip6 :: Monad m => Stream m a -> Stream m b -> Stream m c -> Stream m d - -> Stream m e -> Stream m f -> Stream m (a,b,c,d,e,f) -{-# INLINE zip6 #-} -zip6 = zipWith6 (,,,,,) - --- Comparisons --- ----------- - --- | Check if two 'Stream's are equal -eqBy :: (Monad m) => (a -> b -> Bool) -> Stream m a -> Stream m b -> m Bool -{-# INLINE_FUSED eqBy #-} -eqBy eq (Stream step1 t1) (Stream step2 t2) = eq_loop0 SPEC t1 t2 - where - eq_loop0 !_ s1 s2 = do - r <- step1 s1 - case r of - Yield x s1' -> eq_loop1 SPEC x s1' s2 - Skip s1' -> eq_loop0 SPEC s1' s2 - Done -> eq_null s2 - - eq_loop1 !_ x s1 s2 = do - r <- step2 s2 - case r of - Yield y s2' - | eq x y -> eq_loop0 SPEC s1 s2' - | otherwise -> return False - Skip s2' -> eq_loop1 SPEC x s1 s2' - Done -> return False - - eq_null s2 = do - r <- step2 s2 - case r of - Yield _ _ -> return False - Skip s2' -> eq_null s2' - Done -> return True - --- | Lexicographically compare two 'Stream's -cmpBy :: (Monad m) => (a -> b -> Ordering) -> Stream m a -> Stream m b -> m Ordering -{-# INLINE_FUSED cmpBy #-} -cmpBy cmp (Stream step1 t1) (Stream step2 t2) = cmp_loop0 SPEC t1 t2 - where - cmp_loop0 !_ s1 s2 = do - r <- step1 s1 - case r of - Yield x s1' -> cmp_loop1 SPEC x s1' s2 - Skip s1' -> cmp_loop0 SPEC s1' s2 - Done -> cmp_null s2 - - cmp_loop1 !_ x s1 s2 = do - r <- step2 s2 - case r of - Yield y s2' -> case x `cmp` y of - EQ -> cmp_loop0 SPEC s1 s2' - c -> return c - Skip s2' -> cmp_loop1 SPEC x s1 s2' - Done -> return GT - - cmp_null s2 = do - r <- step2 s2 - case r of - Yield _ _ -> return LT - Skip s2' -> cmp_null s2' - Done -> return EQ - --- Filtering --- --------- - --- | Drop elements which do not satisfy the predicate -filter :: Monad m => (a -> Bool) -> Stream m a -> Stream m a -{-# INLINE filter #-} -filter f = filterM (return . f) - -mapMaybe :: Monad m => (a -> Maybe b) -> Stream m a -> Stream m b -{-# INLINE_FUSED mapMaybe #-} -mapMaybe f (Stream step t) = Stream step' t - where - {-# INLINE_INNER step' #-} - step' s = do - r <- step s - case r of - Yield x s' -> do - return $ case f x of - Nothing -> Skip s' - Just b' -> Yield b' s' - Skip s' -> return $ Skip s' - Done -> return $ Done - --- | Drop elements which do not satisfy the monadic predicate -filterM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a -{-# INLINE_FUSED filterM #-} -filterM f (Stream step t) = Stream step' t - where - {-# INLINE_INNER step' #-} - step' s = do - r <- step s - case r of - Yield x s' -> do - b <- f x - return $ if b then Yield x s' - else Skip s' - Skip s' -> return $ Skip s' - Done -> return $ Done - --- | Drop repeated adjacent elements. -uniq :: (Eq a, Monad m) => Stream m a -> Stream m a -{-# INLINE_FUSED uniq #-} -uniq (Stream step st) = Stream step' (Nothing,st) - where - {-# INLINE_INNER step' #-} - step' (Nothing, s) = do r <- step s - case r of - Yield x s' -> return $ Yield x (Just x , s') - Skip s' -> return $ Skip (Nothing, s') - Done -> return Done - step' (Just x0, s) = do r <- step s - case r of - Yield x s' | x == x0 -> return $ Skip (Just x0, s') - | otherwise -> return $ Yield x (Just x , s') - Skip s' -> return $ Skip (Just x0, s') - Done -> return Done - --- | Longest prefix of elements that satisfy the predicate -takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a -{-# INLINE takeWhile #-} -takeWhile f = takeWhileM (return . f) - --- | Longest prefix of elements that satisfy the monadic predicate -takeWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a -{-# INLINE_FUSED takeWhileM #-} -takeWhileM f (Stream step t) = Stream step' t - where - {-# INLINE_INNER step' #-} - step' s = do - r <- step s - case r of - Yield x s' -> do - b <- f x - return $ if b then Yield x s' else Done - Skip s' -> return $ Skip s' - Done -> return $ Done - --- | Drop the longest prefix of elements that satisfy the predicate -dropWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a -{-# INLINE dropWhile #-} -dropWhile f = dropWhileM (return . f) - -data DropWhile s a = DropWhile_Drop s | DropWhile_Yield a s | DropWhile_Next s - --- | Drop the longest prefix of elements that satisfy the monadic predicate -dropWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a -{-# INLINE_FUSED dropWhileM #-} -dropWhileM f (Stream step t) = Stream step' (DropWhile_Drop t) - where - -- NOTE: we jump through hoops here to have only one Yield; local data - -- declarations would be nice! - - {-# INLINE_INNER step' #-} - step' (DropWhile_Drop s) - = do - r <- step s - case r of - Yield x s' -> do - b <- f x - return $ if b then Skip (DropWhile_Drop s') - else Skip (DropWhile_Yield x s') - Skip s' -> return $ Skip (DropWhile_Drop s') - Done -> return $ Done - - step' (DropWhile_Yield x s) = return $ Yield x (DropWhile_Next s) - - step' (DropWhile_Next s) - = liftM (\r -> - case r of - Yield x s' -> Skip (DropWhile_Yield x s') - Skip s' -> Skip (DropWhile_Next s') - Done -> Done - ) (step s) - --- Searching --- --------- - -infix 4 `elem` --- | Check whether the 'Stream' contains an element -elem :: (Monad m, Eq a) => a -> Stream m a -> m Bool -{-# INLINE_FUSED elem #-} -elem x (Stream step t) = elem_loop SPEC t - where - elem_loop !_ s - = do - r <- step s - case r of - Yield y s' | x == y -> return True - | otherwise -> elem_loop SPEC s' - Skip s' -> elem_loop SPEC s' - Done -> return False - -infix 4 `notElem` --- | Inverse of `elem` -notElem :: (Monad m, Eq a) => a -> Stream m a -> m Bool -{-# INLINE notElem #-} -notElem x s = liftM not (elem x s) - --- | Yield 'Just' the first element that satisfies the predicate or 'Nothing' --- if no such element exists. -find :: Monad m => (a -> Bool) -> Stream m a -> m (Maybe a) -{-# INLINE find #-} -find f = findM (return . f) - --- | Yield 'Just' the first element that satisfies the monadic predicate or --- 'Nothing' if no such element exists. -findM :: Monad m => (a -> m Bool) -> Stream m a -> m (Maybe a) -{-# INLINE_FUSED findM #-} -findM f (Stream step t) = find_loop SPEC t - where - find_loop !_ s - = do - r <- step s - case r of - Yield x s' -> do - b <- f x - if b then return $ Just x - else find_loop SPEC s' - Skip s' -> find_loop SPEC s' - Done -> return Nothing - --- | Yield 'Just' the index of the first element that satisfies the predicate --- or 'Nothing' if no such element exists. -findIndex :: Monad m => (a -> Bool) -> Stream m a -> m (Maybe Int) -{-# INLINE_FUSED findIndex #-} -findIndex f = findIndexM (return . f) - --- | Yield 'Just' the index of the first element that satisfies the monadic --- predicate or 'Nothing' if no such element exists. -findIndexM :: Monad m => (a -> m Bool) -> Stream m a -> m (Maybe Int) -{-# INLINE_FUSED findIndexM #-} -findIndexM f (Stream step t) = findIndex_loop SPEC t 0 - where - findIndex_loop !_ s i - = do - r <- step s - case r of - Yield x s' -> do - b <- f x - if b then return $ Just i - else findIndex_loop SPEC s' (i+1) - Skip s' -> findIndex_loop SPEC s' i - Done -> return Nothing - --- Folding --- ------- - --- | Left fold -foldl :: Monad m => (a -> b -> a) -> a -> Stream m b -> m a -{-# INLINE foldl #-} -foldl f = foldlM (\a b -> return (f a b)) - --- | Left fold with a monadic operator -foldlM :: Monad m => (a -> b -> m a) -> a -> Stream m b -> m a -{-# INLINE_FUSED foldlM #-} -foldlM m w (Stream step t) = foldlM_loop SPEC w t - where - foldlM_loop !_ z s - = do - r <- step s - case r of - Yield x s' -> do { z' <- m z x; foldlM_loop SPEC z' s' } - Skip s' -> foldlM_loop SPEC z s' - Done -> return z - --- | Same as 'foldlM' -foldM :: Monad m => (a -> b -> m a) -> a -> Stream m b -> m a -{-# INLINE foldM #-} -foldM = foldlM - --- | Left fold over a non-empty 'Stream' -foldl1 :: Monad m => (a -> a -> a) -> Stream m a -> m a -{-# INLINE foldl1 #-} -foldl1 f = foldl1M (\a b -> return (f a b)) - --- | Left fold over a non-empty 'Stream' with a monadic operator -foldl1M :: Monad m => (a -> a -> m a) -> Stream m a -> m a -{-# INLINE_FUSED foldl1M #-} -foldl1M f (Stream step t) = foldl1M_loop SPEC t - where - foldl1M_loop !_ s - = do - r <- step s - case r of - Yield x s' -> foldlM f x (Stream step s') - Skip s' -> foldl1M_loop SPEC s' - Done -> EMPTY_STREAM "foldl1M" - --- | Same as 'foldl1M' -fold1M :: Monad m => (a -> a -> m a) -> Stream m a -> m a -{-# INLINE fold1M #-} -fold1M = foldl1M - --- | Left fold with a strict accumulator -foldl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> m a -{-# INLINE foldl' #-} -foldl' f = foldlM' (\a b -> return (f a b)) - --- | Left fold with a strict accumulator and a monadic operator -foldlM' :: Monad m => (a -> b -> m a) -> a -> Stream m b -> m a -{-# INLINE_FUSED foldlM' #-} -foldlM' m w (Stream step t) = foldlM'_loop SPEC w t - where - foldlM'_loop !_ z s - = z `seq` - do - r <- step s - case r of - Yield x s' -> do { z' <- m z x; foldlM'_loop SPEC z' s' } - Skip s' -> foldlM'_loop SPEC z s' - Done -> return z - --- | Same as 'foldlM'' -foldM' :: Monad m => (a -> b -> m a) -> a -> Stream m b -> m a -{-# INLINE foldM' #-} -foldM' = foldlM' - --- | Left fold over a non-empty 'Stream' with a strict accumulator -foldl1' :: Monad m => (a -> a -> a) -> Stream m a -> m a -{-# INLINE foldl1' #-} -foldl1' f = foldl1M' (\a b -> return (f a b)) - --- | Left fold over a non-empty 'Stream' with a strict accumulator and a --- monadic operator -foldl1M' :: Monad m => (a -> a -> m a) -> Stream m a -> m a -{-# INLINE_FUSED foldl1M' #-} -foldl1M' f (Stream step t) = foldl1M'_loop SPEC t - where - foldl1M'_loop !_ s - = do - r <- step s - case r of - Yield x s' -> foldlM' f x (Stream step s') - Skip s' -> foldl1M'_loop SPEC s' - Done -> EMPTY_STREAM "foldl1M'" - --- | Same as 'foldl1M'' -fold1M' :: Monad m => (a -> a -> m a) -> Stream m a -> m a -{-# INLINE fold1M' #-} -fold1M' = foldl1M' - --- | Right fold -foldr :: Monad m => (a -> b -> b) -> b -> Stream m a -> m b -{-# INLINE foldr #-} -foldr f = foldrM (\a b -> return (f a b)) - --- | Right fold with a monadic operator -foldrM :: Monad m => (a -> b -> m b) -> b -> Stream m a -> m b -{-# INLINE_FUSED foldrM #-} -foldrM f z (Stream step t) = foldrM_loop SPEC t - where - foldrM_loop !_ s - = do - r <- step s - case r of - Yield x s' -> f x =<< foldrM_loop SPEC s' - Skip s' -> foldrM_loop SPEC s' - Done -> return z - --- | Right fold over a non-empty stream -foldr1 :: Monad m => (a -> a -> a) -> Stream m a -> m a -{-# INLINE foldr1 #-} -foldr1 f = foldr1M (\a b -> return (f a b)) - --- | Right fold over a non-empty stream with a monadic operator -foldr1M :: Monad m => (a -> a -> m a) -> Stream m a -> m a -{-# INLINE_FUSED foldr1M #-} -foldr1M f (Stream step t) = foldr1M_loop0 SPEC t - where - foldr1M_loop0 !_ s - = do - r <- step s - case r of - Yield x s' -> foldr1M_loop1 SPEC x s' - Skip s' -> foldr1M_loop0 SPEC s' - Done -> EMPTY_STREAM "foldr1M" - - foldr1M_loop1 !_ x s - = do - r <- step s - case r of - Yield y s' -> f x =<< foldr1M_loop1 SPEC y s' - Skip s' -> foldr1M_loop1 SPEC x s' - Done -> return x - --- Specialised folds --- ----------------- - -and :: Monad m => Stream m Bool -> m Bool -{-# INLINE_FUSED and #-} -and (Stream step t) = and_loop SPEC t - where - and_loop !_ s - = do - r <- step s - case r of - Yield False _ -> return False - Yield True s' -> and_loop SPEC s' - Skip s' -> and_loop SPEC s' - Done -> return True - -or :: Monad m => Stream m Bool -> m Bool -{-# INLINE_FUSED or #-} -or (Stream step t) = or_loop SPEC t - where - or_loop !_ s - = do - r <- step s - case r of - Yield False s' -> or_loop SPEC s' - Yield True _ -> return True - Skip s' -> or_loop SPEC s' - Done -> return False - -concatMap :: Monad m => (a -> Stream m b) -> Stream m a -> Stream m b -{-# INLINE concatMap #-} -concatMap f = concatMapM (return . f) - -concatMapM :: Monad m => (a -> m (Stream m b)) -> Stream m a -> Stream m b -{-# INLINE_FUSED concatMapM #-} -concatMapM f (Stream step t) = Stream concatMap_go (Left t) - where - concatMap_go (Left s) = do - r <- step s - case r of - Yield a s' -> do - b_stream <- f a - return $ Skip (Right (b_stream, s')) - Skip s' -> return $ Skip (Left s') - Done -> return Done - concatMap_go (Right (Stream inner_step inner_s, s)) = do - r <- inner_step inner_s - case r of - Yield b inner_s' -> return $ Yield b (Right (Stream inner_step inner_s', s)) - Skip inner_s' -> return $ Skip (Right (Stream inner_step inner_s', s)) - Done -> return $ Skip (Left s) - --- | Create a 'Stream' of values from a 'Stream' of streamable things -flatten :: Monad m => (a -> m s) -> (s -> m (Step s b)) -> Stream m a -> Stream m b -{-# INLINE_FUSED flatten #-} -flatten mk istep (Stream ostep u) = Stream step (Left u) - where - {-# INLINE_INNER step #-} - step (Left t) = do - r <- ostep t - case r of - Yield a t' -> do - s <- mk a - s `seq` return (Skip (Right (s,t'))) - Skip t' -> return $ Skip (Left t') - Done -> return $ Done - - - step (Right (s,t)) = do - r <- istep s - case r of - Yield x s' -> return $ Yield x (Right (s',t)) - Skip s' -> return $ Skip (Right (s',t)) - Done -> return $ Skip (Left t) - --- Unfolding --- --------- - --- | Unfold -unfoldr :: Monad m => (s -> Maybe (a, s)) -> s -> Stream m a -{-# INLINE_FUSED unfoldr #-} -unfoldr f = unfoldrM (return . f) - --- | Unfold with a monadic function -unfoldrM :: Monad m => (s -> m (Maybe (a, s))) -> s -> Stream m a -{-# INLINE_FUSED unfoldrM #-} -unfoldrM f t = Stream step t - where - {-# INLINE_INNER step #-} - step s = liftM (\r -> - case r of - Just (x, s') -> Yield x s' - Nothing -> Done - ) (f s) - -unfoldrN :: Monad m => Int -> (s -> Maybe (a, s)) -> s -> Stream m a -{-# INLINE_FUSED unfoldrN #-} -unfoldrN n f = unfoldrNM n (return . f) - --- | Unfold at most @n@ elements with a monadic functions -unfoldrNM :: Monad m => Int -> (s -> m (Maybe (a, s))) -> s -> Stream m a -{-# INLINE_FUSED unfoldrNM #-} -unfoldrNM m f t = Stream step (t,m) - where - {-# INLINE_INNER step #-} - step (s,n) | n <= 0 = return Done - | otherwise = liftM (\r -> - case r of - Just (x,s') -> Yield x (s',n-1) - Nothing -> Done - ) (f s) - --- | Apply monadic function n times to value. Zeroth element is original value. -iterateNM :: Monad m => Int -> (a -> m a) -> a -> Stream m a -{-# INLINE_FUSED iterateNM #-} -iterateNM n f x0 = Stream step (x0,n) - where - {-# INLINE_INNER step #-} - step (x,i) | i <= 0 = return Done - | i == n = return $ Yield x (x,i-1) - | otherwise = do a <- f x - return $ Yield a (a,i-1) - --- | Apply function n times to value. Zeroth element is original value. -iterateN :: Monad m => Int -> (a -> a) -> a -> Stream m a -{-# INLINE_FUSED iterateN #-} -iterateN n f x0 = iterateNM n (return . f) x0 - --- Scans --- ----- - --- | Prefix scan -prescanl :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a -{-# INLINE prescanl #-} -prescanl f = prescanlM (\a b -> return (f a b)) - --- | Prefix scan with a monadic operator -prescanlM :: Monad m => (a -> b -> m a) -> a -> Stream m b -> Stream m a -{-# INLINE_FUSED prescanlM #-} -prescanlM f w (Stream step t) = Stream step' (t,w) - where - {-# INLINE_INNER step' #-} - step' (s,x) = do - r <- step s - case r of - Yield y s' -> do - z <- f x y - return $ Yield x (s', z) - Skip s' -> return $ Skip (s', x) - Done -> return Done - --- | Prefix scan with strict accumulator -prescanl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a -{-# INLINE prescanl' #-} -prescanl' f = prescanlM' (\a b -> return (f a b)) - --- | Prefix scan with strict accumulator and a monadic operator -prescanlM' :: Monad m => (a -> b -> m a) -> a -> Stream m b -> Stream m a -{-# INLINE_FUSED prescanlM' #-} -prescanlM' f w (Stream step t) = Stream step' (t,w) - where - {-# INLINE_INNER step' #-} - step' (s,x) = x `seq` - do - r <- step s - case r of - Yield y s' -> do - z <- f x y - return $ Yield x (s', z) - Skip s' -> return $ Skip (s', x) - Done -> return Done - --- | Suffix scan -postscanl :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a -{-# INLINE postscanl #-} -postscanl f = postscanlM (\a b -> return (f a b)) - --- | Suffix scan with a monadic operator -postscanlM :: Monad m => (a -> b -> m a) -> a -> Stream m b -> Stream m a -{-# INLINE_FUSED postscanlM #-} -postscanlM f w (Stream step t) = Stream step' (t,w) - where - {-# INLINE_INNER step' #-} - step' (s,x) = do - r <- step s - case r of - Yield y s' -> do - z <- f x y - return $ Yield z (s',z) - Skip s' -> return $ Skip (s',x) - Done -> return Done - --- | Suffix scan with strict accumulator -postscanl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a -{-# INLINE postscanl' #-} -postscanl' f = postscanlM' (\a b -> return (f a b)) - --- | Suffix scan with strict acccumulator and a monadic operator -postscanlM' :: Monad m => (a -> b -> m a) -> a -> Stream m b -> Stream m a -{-# INLINE_FUSED postscanlM' #-} -postscanlM' f w (Stream step t) = w `seq` Stream step' (t,w) - where - {-# INLINE_INNER step' #-} - step' (s,x) = x `seq` - do - r <- step s - case r of - Yield y s' -> do - z <- f x y - z `seq` return (Yield z (s',z)) - Skip s' -> return $ Skip (s',x) - Done -> return Done - --- | Haskell-style scan -scanl :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a -{-# INLINE scanl #-} -scanl f = scanlM (\a b -> return (f a b)) - --- | Haskell-style scan with a monadic operator -scanlM :: Monad m => (a -> b -> m a) -> a -> Stream m b -> Stream m a -{-# INLINE scanlM #-} -scanlM f z s = z `cons` postscanlM f z s - --- | Haskell-style scan with strict accumulator -scanl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a -{-# INLINE scanl' #-} -scanl' f = scanlM' (\a b -> return (f a b)) - --- | Haskell-style scan with strict accumulator and a monadic operator -scanlM' :: Monad m => (a -> b -> m a) -> a -> Stream m b -> Stream m a -{-# INLINE scanlM' #-} -scanlM' f z s = z `seq` (z `cons` postscanlM f z s) - --- | Scan over a non-empty 'Stream' -scanl1 :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a -{-# INLINE scanl1 #-} -scanl1 f = scanl1M (\x y -> return (f x y)) - --- | Scan over a non-empty 'Stream' with a monadic operator -scanl1M :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a -{-# INLINE_FUSED scanl1M #-} -scanl1M f (Stream step t) = Stream step' (t, Nothing) - where - {-# INLINE_INNER step' #-} - step' (s, Nothing) = do - r <- step s - case r of - Yield x s' -> return $ Yield x (s', Just x) - Skip s' -> return $ Skip (s', Nothing) - Done -> EMPTY_STREAM "scanl1M" - - step' (s, Just x) = do - r <- step s - case r of - Yield y s' -> do - z <- f x y - return $ Yield z (s', Just z) - Skip s' -> return $ Skip (s', Just x) - Done -> return Done - --- | Scan over a non-empty 'Stream' with a strict accumulator -scanl1' :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a -{-# INLINE scanl1' #-} -scanl1' f = scanl1M' (\x y -> return (f x y)) - --- | Scan over a non-empty 'Stream' with a strict accumulator and a monadic --- operator -scanl1M' :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a -{-# INLINE_FUSED scanl1M' #-} -scanl1M' f (Stream step t) = Stream step' (t, Nothing) - where - {-# INLINE_INNER step' #-} - step' (s, Nothing) = do - r <- step s - case r of - Yield x s' -> x `seq` return (Yield x (s', Just x)) - Skip s' -> return $ Skip (s', Nothing) - Done -> EMPTY_STREAM "scanl1M" - - step' (s, Just x) = x `seq` - do - r <- step s - case r of - Yield y s' -> do - z <- f x y - z `seq` return (Yield z (s', Just z)) - Skip s' -> return $ Skip (s', Just x) - Done -> return Done - --- Enumerations --- ------------ - --- The Enum class is broken for this, there just doesn't seem to be a --- way to implement this generically. We have to specialise for as many types --- as we can but this doesn't help in polymorphic loops. - --- | Yield a 'Stream' of the given length containing the values @x@, @x+y@, --- @x+y+y@ etc. -enumFromStepN :: (Num a, Monad m) => a -> a -> Int -> Stream m a -{-# INLINE_FUSED enumFromStepN #-} -enumFromStepN x y n = x `seq` y `seq` n `seq` Stream step (x,n) - where - {-# INLINE_INNER step #-} - step (w,m) | m > 0 = return $ Yield w (w+y,m-1) - | otherwise = return $ Done - --- | Enumerate values --- --- /WARNING:/ This operation can be very inefficient. If at all possible, use --- 'enumFromStepN' instead. -enumFromTo :: (Enum a, Monad m) => a -> a -> Stream m a -{-# INLINE_FUSED enumFromTo #-} -enumFromTo x y = fromList [x .. y] - --- NOTE: We use (x+1) instead of (succ x) below because the latter checks for --- overflow which can't happen here. - --- FIXME: add "too large" test for Int -enumFromTo_small :: (Integral a, Monad m) => a -> a -> Stream m a -{-# INLINE_FUSED enumFromTo_small #-} -enumFromTo_small x y = x `seq` y `seq` Stream step x - where - {-# INLINE_INNER step #-} - step w | w <= y = return $ Yield w (w+1) - | otherwise = return $ Done - -{-# RULES - -"enumFromTo<Int8> [Stream]" - enumFromTo = enumFromTo_small :: Monad m => Int8 -> Int8 -> Stream m Int8 - -"enumFromTo<Int16> [Stream]" - enumFromTo = enumFromTo_small :: Monad m => Int16 -> Int16 -> Stream m Int16 - -"enumFromTo<Word8> [Stream]" - enumFromTo = enumFromTo_small :: Monad m => Word8 -> Word8 -> Stream m Word8 - -"enumFromTo<Word16> [Stream]" - enumFromTo = enumFromTo_small :: Monad m => Word16 -> Word16 -> Stream m Word16 #-} - - -#if WORD_SIZE_IN_BITS > 32 - -{-# RULES - -"enumFromTo<Int32> [Stream]" - enumFromTo = enumFromTo_small :: Monad m => Int32 -> Int32 -> Stream m Int32 - -"enumFromTo<Word32> [Stream]" - enumFromTo = enumFromTo_small :: Monad m => Word32 -> Word32 -> Stream m Word32 #-} - - -#endif - --- NOTE: We could implement a generic "too large" test: --- --- len x y | x > y = 0 --- | n > 0 && n <= fromIntegral (maxBound :: Int) = fromIntegral n --- | otherwise = error --- where --- n = y-x+1 --- --- Alas, GHC won't eliminate unnecessary comparisons (such as n >= 0 for --- unsigned types). See http://hackage.haskell.org/trac/ghc/ticket/3744 --- - -enumFromTo_int :: forall m. Monad m => Int -> Int -> Stream m Int -{-# INLINE_FUSED enumFromTo_int #-} -enumFromTo_int x y = x `seq` y `seq` Stream step x - where - -- {-# INLINE [0] len #-} - -- len :: Int -> Int -> Int - -- len u v | u > v = 0 - -- | otherwise = BOUNDS_CHECK(check) "enumFromTo" "vector too large" - -- (n > 0) - -- $ n - -- where - -- n = v-u+1 - - {-# INLINE_INNER step #-} - step z | z <= y = return $ Yield z (z+1) - | otherwise = return $ Done - -enumFromTo_intlike :: (Integral a, Monad m) => a -> a -> Stream m a -{-# INLINE_FUSED enumFromTo_intlike #-} -enumFromTo_intlike x y = x `seq` y `seq` Stream step x - where - {-# INLINE_INNER step #-} - step z | z <= y = return $ Yield z (z+1) - | otherwise = return $ Done - -{-# RULES - -"enumFromTo<Int> [Stream]" - enumFromTo = enumFromTo_int :: Monad m => Int -> Int -> Stream m Int - -#if WORD_SIZE_IN_BITS > 32 - -"enumFromTo<Int64> [Stream]" - enumFromTo = enumFromTo_intlike :: Monad m => Int64 -> Int64 -> Stream m Int64 #-} - -#else - -"enumFromTo<Int32> [Stream]" - enumFromTo = enumFromTo_intlike :: Monad m => Int32 -> Int32 -> Stream m Int32 #-} - -#endif - -enumFromTo_big_word :: (Integral a, Monad m) => a -> a -> Stream m a -{-# INLINE_FUSED enumFromTo_big_word #-} -enumFromTo_big_word x y = x `seq` y `seq` Stream step x - where - {-# INLINE_INNER step #-} - step z | z <= y = return $ Yield z (z+1) - | otherwise = return $ Done - -{-# RULES - -"enumFromTo<Word> [Stream]" - enumFromTo = enumFromTo_big_word :: Monad m => Word -> Word -> Stream m Word - -"enumFromTo<Word64> [Stream]" - enumFromTo = enumFromTo_big_word - :: Monad m => Word64 -> Word64 -> Stream m Word64 - -#if WORD_SIZE_IN_BITS == 32 - -"enumFromTo<Word32> [Stream]" - enumFromTo = enumFromTo_big_word - :: Monad m => Word32 -> Word32 -> Stream m Word32 - -#endif - -"enumFromTo<Integer> [Stream]" - enumFromTo = enumFromTo_big_word - :: Monad m => Integer -> Integer -> Stream m Integer #-} - - - -#if WORD_SIZE_IN_BITS > 32 - --- FIXME: the "too large" test is totally wrong -enumFromTo_big_int :: (Integral a, Monad m) => a -> a -> Stream m a -{-# INLINE_FUSED enumFromTo_big_int #-} -enumFromTo_big_int x y = x `seq` y `seq` Stream step x - where - {-# INLINE_INNER step #-} - step z | z <= y = return $ Yield z (z+1) - | otherwise = return $ Done - -{-# RULES - -"enumFromTo<Int64> [Stream]" - enumFromTo = enumFromTo_big_int :: Monad m => Int64 -> Int64 -> Stream m Int64 #-} - - - -#endif - -enumFromTo_char :: Monad m => Char -> Char -> Stream m Char -{-# INLINE_FUSED enumFromTo_char #-} -enumFromTo_char x y = x `seq` y `seq` Stream step xn - where - xn = ord x - yn = ord y - - {-# INLINE_INNER step #-} - step zn | zn <= yn = return $ Yield (unsafeChr zn) (zn+1) - | otherwise = return $ Done - -{-# RULES - -"enumFromTo<Char> [Stream]" - enumFromTo = enumFromTo_char #-} - - - ------------------------------------------------------------------------- - --- Specialise enumFromTo for Float and Double. --- Also, try to do something about pairs? - -enumFromTo_double :: (Monad m, Ord a, RealFrac a) => a -> a -> Stream m a -{-# INLINE_FUSED enumFromTo_double #-} -enumFromTo_double n m = n `seq` m `seq` Stream step n - where - lim = m + 1/2 -- important to float out - - {-# INLINE_INNER step #-} - step x | x <= lim = return $ Yield x (x+1) - | otherwise = return $ Done - -{-# RULES - -"enumFromTo<Double> [Stream]" - enumFromTo = enumFromTo_double :: Monad m => Double -> Double -> Stream m Double - -"enumFromTo<Float> [Stream]" - enumFromTo = enumFromTo_double :: Monad m => Float -> Float -> Stream m Float #-} - - - ------------------------------------------------------------------------- - --- | Enumerate values with a given step. --- --- /WARNING:/ This operation is very inefficient. If at all possible, use --- 'enumFromStepN' instead. -enumFromThenTo :: (Enum a, Monad m) => a -> a -> a -> Stream m a -{-# INLINE_FUSED enumFromThenTo #-} -enumFromThenTo x y z = fromList [x, y .. z] - --- FIXME: Specialise enumFromThenTo. - --- Conversions --- ----------- - --- | Convert a 'Stream' to a list -toList :: Monad m => Stream m a -> m [a] -{-# INLINE toList #-} -toList = foldr (:) [] - --- | Convert a list to a 'Stream' -fromList :: Monad m => [a] -> Stream m a -{-# INLINE fromList #-} -fromList zs = Stream step zs - where - step (x:xs) = return (Yield x xs) - step [] = return Done - --- | Convert the first @n@ elements of a list to a 'Bundle' -fromListN :: Monad m => Int -> [a] -> Stream m a -{-# INLINE_FUSED fromListN #-} -fromListN m zs = Stream step (zs,m) - where - {-# INLINE_INNER step #-} - step (_, n) | n <= 0 = return Done - step (x:xs,n) = return (Yield x (xs,n-1)) - step ([],_) = return Done - -{- -fromVector :: (Monad m, Vector v a) => v a -> Stream m a -{-# INLINE_FUSED fromVector #-} -fromVector v = v `seq` n `seq` Stream (Unf step 0) - (Unf vstep True) - (Just v) - (Exact n) - where - n = basicLength v - - {-# INLINE step #-} - step i | i >= n = return Done - | otherwise = case basicUnsafeIndexM v i of - Box x -> return $ Yield x (i+1) - - - {-# INLINE vstep #-} - vstep True = return (Yield (Chunk (basicLength v) (\mv -> basicUnsafeCopy mv v)) False) - vstep False = return Done - -fromVectors :: forall m a. (Monad m, Vector v a) => [v a] -> Stream m a -{-# INLINE_FUSED fromVectors #-} -fromVectors vs = Stream (Unf pstep (Left vs)) - (Unf vstep vs) - Nothing - (Exact n) - where - n = List.foldl' (\k v -> k + basicLength v) 0 vs - - pstep (Left []) = return Done - pstep (Left (v:vs)) = basicLength v `seq` return (Skip (Right (v,0,vs))) - - pstep (Right (v,i,vs)) - | i >= basicLength v = return $ Skip (Left vs) - | otherwise = case basicUnsafeIndexM v i of - Box x -> return $ Yield x (Right (v,i+1,vs)) - - -- FIXME: work around bug in GHC 7.6.1 - vstep :: [v a] -> m (Step [v a] (Chunk v a)) - vstep [] = return Done - vstep (v:vs) = return $ Yield (Chunk (basicLength v) - (\mv -> INTERNAL_CHECK(check) "concatVectors" "length mismatch" - (M.basicLength mv == basicLength v) - $ basicUnsafeCopy mv v)) vs - - -concatVectors :: (Monad m, Vector v a) => Stream m (v a) -> Stream m a -{-# INLINE_FUSED concatVectors #-} -concatVectors (Stream step s} - = Stream (Unf pstep (Left s)) - (Unf vstep s) - Nothing - Unknown - where - pstep (Left s) = do - r <- step s - case r of - Yield v s' -> basicLength v `seq` return (Skip (Right (v,0,s'))) - Skip s' -> return (Skip (Left s')) - Done -> return Done - - pstep (Right (v,i,s)) - | i >= basicLength v = return (Skip (Left s)) - | otherwise = case basicUnsafeIndexM v i of - Box x -> return (Yield x (Right (v,i+1,s))) - - - vstep s = do - r <- step s - case r of - Yield v s' -> return (Yield (Chunk (basicLength v) - (\mv -> INTERNAL_CHECK(check) "concatVectors" "length mismatch" - (M.basicLength mv == basicLength v) - $ basicUnsafeCopy mv v)) s') - Skip s' -> return (Skip s') - Done -> return Done - -reVector :: Monad m => Stream m a -> Stream m a -{-# INLINE_FUSED reVector #-} -reVector (Stream step s, sSize = n} = Stream step s n - -{-# RULES - -"reVector [Vector]" - reVector = id - -"reVector/reVector [Vector]" forall s. - reVector (reVector s) = s #-} - - --} - diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Util.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Util.hs deleted file mode 100644 index 855bf5ddd40d..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Util.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Data.Vector.Fusion.Util --- Copyright : (c) Roman Leshchinskiy 2009 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Stability : experimental --- Portability : portable --- --- Fusion-related utility types --- - -module Data.Vector.Fusion.Util ( - Id(..), Box(..), - - delay_inline, delayed_min -) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (Applicative(..)) -#endif - --- | Identity monad -newtype Id a = Id { unId :: a } - -instance Functor Id where - fmap f (Id x) = Id (f x) - -instance Applicative Id where - pure = Id - Id f <*> Id x = Id (f x) - -instance Monad Id where - return = pure - Id x >>= f = f x - --- | Box monad -data Box a = Box { unBox :: a } - -instance Functor Box where - fmap f (Box x) = Box (f x) - -instance Applicative Box where - pure = Box - Box f <*> Box x = Box (f x) - -instance Monad Box where - return = pure - Box x >>= f = f x - --- | Delay inlining a function until late in the game (simplifier phase 0). -delay_inline :: (a -> b) -> a -> b -{-# INLINE [0] delay_inline #-} -delay_inline f = f - --- | `min` inlined in phase 0 -delayed_min :: Int -> Int -> Int -{-# INLINE [0] delayed_min #-} -delayed_min m n = min m n diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic.hs deleted file mode 100644 index 066c07fd3d1d..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic.hs +++ /dev/null @@ -1,2206 +0,0 @@ -{-# LANGUAGE CPP, Rank2Types, MultiParamTypeClasses, FlexibleContexts, - TypeFamilies, ScopedTypeVariables, BangPatterns #-} --- | --- Module : Data.Vector.Generic --- Copyright : (c) Roman Leshchinskiy 2008-2010 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Stability : experimental --- Portability : non-portable --- --- Generic interface to pure vectors. --- - -module Data.Vector.Generic ( - -- * Immutable vectors - Vector(..), Mutable, - - -- * Accessors - - -- ** Length information - length, null, - - -- ** Indexing - (!), (!?), head, last, - unsafeIndex, unsafeHead, unsafeLast, - - -- ** Monadic indexing - indexM, headM, lastM, - unsafeIndexM, unsafeHeadM, unsafeLastM, - - -- ** Extracting subvectors (slicing) - slice, init, tail, take, drop, splitAt, - unsafeSlice, unsafeInit, unsafeTail, unsafeTake, unsafeDrop, - - -- * Construction - - -- ** Initialisation - empty, singleton, replicate, generate, iterateN, - - -- ** Monadic initialisation - replicateM, generateM, iterateNM, create, createT, - - -- ** Unfolding - unfoldr, unfoldrN, - unfoldrM, unfoldrNM, - constructN, constructrN, - - -- ** Enumeration - enumFromN, enumFromStepN, enumFromTo, enumFromThenTo, - - -- ** Concatenation - cons, snoc, (++), concat, concatNE, - - -- ** Restricting memory usage - force, - - -- * Modifying vectors - - -- ** Bulk updates - (//), update, update_, - unsafeUpd, unsafeUpdate, unsafeUpdate_, - - -- ** Accumulations - accum, accumulate, accumulate_, - unsafeAccum, unsafeAccumulate, unsafeAccumulate_, - - -- ** Permutations - reverse, backpermute, unsafeBackpermute, - - -- ** Safe destructive updates - modify, - - -- * Elementwise operations - - -- ** Indexing - indexed, - - -- ** Mapping - map, imap, concatMap, - - -- ** Monadic mapping - mapM, imapM, mapM_, imapM_, forM, forM_, - - -- ** Zipping - zipWith, zipWith3, zipWith4, zipWith5, zipWith6, - izipWith, izipWith3, izipWith4, izipWith5, izipWith6, - zip, zip3, zip4, zip5, zip6, - - -- ** Monadic zipping - zipWithM, izipWithM, zipWithM_, izipWithM_, - - -- ** Unzipping - unzip, unzip3, unzip4, unzip5, unzip6, - - -- * Working with predicates - - -- ** Filtering - filter, ifilter, uniq, - mapMaybe, imapMaybe, - filterM, - takeWhile, dropWhile, - - -- ** Partitioning - partition, unstablePartition, span, break, - - -- ** Searching - elem, notElem, find, findIndex, findIndices, elemIndex, elemIndices, - - -- * Folding - foldl, foldl1, foldl', foldl1', foldr, foldr1, foldr', foldr1', - ifoldl, ifoldl', ifoldr, ifoldr', - - -- ** Specialised folds - all, any, and, or, - sum, product, - maximum, maximumBy, minimum, minimumBy, - minIndex, minIndexBy, maxIndex, maxIndexBy, - - -- ** Monadic folds - foldM, ifoldM, foldM', ifoldM', - fold1M, fold1M', foldM_, ifoldM_, - foldM'_, ifoldM'_, fold1M_, fold1M'_, - - -- ** Monadic sequencing - sequence, sequence_, - - -- * Prefix sums (scans) - prescanl, prescanl', - postscanl, postscanl', - scanl, scanl', scanl1, scanl1', - iscanl, iscanl', - prescanr, prescanr', - postscanr, postscanr', - scanr, scanr', scanr1, scanr1', - iscanr, iscanr', - - -- * Conversions - - -- ** Lists - toList, fromList, fromListN, - - -- ** Different vector types - convert, - - -- ** Mutable vectors - freeze, thaw, copy, unsafeFreeze, unsafeThaw, unsafeCopy, - - -- * Fusion support - - -- ** Conversion to/from Bundles - stream, unstream, streamR, unstreamR, - - -- ** Recycling support - new, clone, - - -- * Utilities - - -- ** Comparisons - eq, cmp, - eqBy, cmpBy, - - -- ** Show and Read - showsPrec, readPrec, - liftShowsPrec, liftReadsPrec, - - -- ** @Data@ and @Typeable@ - gfoldl, dataCast, mkType -) where - -import Data.Vector.Generic.Base - -import qualified Data.Vector.Generic.Mutable as M - -import qualified Data.Vector.Generic.New as New -import Data.Vector.Generic.New ( New ) - -import qualified Data.Vector.Fusion.Bundle as Bundle -import Data.Vector.Fusion.Bundle ( Bundle, MBundle, lift, inplace ) -import qualified Data.Vector.Fusion.Bundle.Monadic as MBundle -import Data.Vector.Fusion.Stream.Monadic ( Stream ) -import qualified Data.Vector.Fusion.Stream.Monadic as S -import Data.Vector.Fusion.Bundle.Size -import Data.Vector.Fusion.Util - -import Control.Monad.ST ( ST, runST ) -import Control.Monad.Primitive -import Prelude hiding ( length, null, - replicate, (++), concat, - head, last, - init, tail, take, drop, splitAt, reverse, - map, concat, concatMap, - zipWith, zipWith3, zip, zip3, unzip, unzip3, - filter, takeWhile, dropWhile, span, break, - elem, notElem, - foldl, foldl1, foldr, foldr1, - all, any, and, or, sum, product, maximum, minimum, - scanl, scanl1, scanr, scanr1, - enumFromTo, enumFromThenTo, - mapM, mapM_, sequence, sequence_, - showsPrec ) - -import qualified Text.Read as Read -import qualified Data.List.NonEmpty as NonEmpty - -#if __GLASGOW_HASKELL__ >= 707 -import Data.Typeable ( Typeable, gcast1 ) -#else -import Data.Typeable ( Typeable1, gcast1 ) -#endif - -#include "vector.h" - -import Data.Data ( Data, DataType ) -#if MIN_VERSION_base(4,2,0) -import Data.Data ( mkNoRepType ) -#else -import Data.Data ( mkNorepType ) -mkNoRepType :: String -> DataType -mkNoRepType = mkNorepType -#endif - -import qualified Data.Traversable as T (Traversable(mapM)) - --- Length information --- ------------------ - --- | /O(1)/ Yield the length of the vector -length :: Vector v a => v a -> Int -{-# INLINE length #-} -length = Bundle.length . stream' - --- | /O(1)/ Test whether a vector is empty -null :: Vector v a => v a -> Bool -{-# INLINE null #-} -null = Bundle.null . stream - --- Indexing --- -------- - -infixl 9 ! --- | O(1) Indexing -(!) :: Vector v a => v a -> Int -> a -{-# INLINE_FUSED (!) #-} -(!) v i = BOUNDS_CHECK(checkIndex) "(!)" i (length v) - $ unId (basicUnsafeIndexM v i) - -infixl 9 !? --- | O(1) Safe indexing -(!?) :: Vector v a => v a -> Int -> Maybe a -{-# INLINE_FUSED (!?) #-} -v !? i | i < 0 || i >= length v = Nothing - | otherwise = Just $ unsafeIndex v i - --- | /O(1)/ First element -head :: Vector v a => v a -> a -{-# INLINE_FUSED head #-} -head v = v ! 0 - --- | /O(1)/ Last element -last :: Vector v a => v a -> a -{-# INLINE_FUSED last #-} -last v = v ! (length v - 1) - --- | /O(1)/ Unsafe indexing without bounds checking -unsafeIndex :: Vector v a => v a -> Int -> a -{-# INLINE_FUSED unsafeIndex #-} -unsafeIndex v i = UNSAFE_CHECK(checkIndex) "unsafeIndex" i (length v) - $ unId (basicUnsafeIndexM v i) - --- | /O(1)/ First element without checking if the vector is empty -unsafeHead :: Vector v a => v a -> a -{-# INLINE_FUSED unsafeHead #-} -unsafeHead v = unsafeIndex v 0 - --- | /O(1)/ Last element without checking if the vector is empty -unsafeLast :: Vector v a => v a -> a -{-# INLINE_FUSED unsafeLast #-} -unsafeLast v = unsafeIndex v (length v - 1) - -{-# RULES - -"(!)/unstream [Vector]" forall i s. - new (New.unstream s) ! i = s Bundle.!! i - -"(!?)/unstream [Vector]" forall i s. - new (New.unstream s) !? i = s Bundle.!? i - -"head/unstream [Vector]" forall s. - head (new (New.unstream s)) = Bundle.head s - -"last/unstream [Vector]" forall s. - last (new (New.unstream s)) = Bundle.last s - -"unsafeIndex/unstream [Vector]" forall i s. - unsafeIndex (new (New.unstream s)) i = s Bundle.!! i - -"unsafeHead/unstream [Vector]" forall s. - unsafeHead (new (New.unstream s)) = Bundle.head s - -"unsafeLast/unstream [Vector]" forall s. - unsafeLast (new (New.unstream s)) = Bundle.last s #-} - - - --- Monadic indexing --- ---------------- - --- | /O(1)/ Indexing in a monad. --- --- The monad allows operations to be strict in the vector when necessary. --- Suppose vector copying is implemented like this: --- --- > copy mv v = ... write mv i (v ! i) ... --- --- For lazy vectors, @v ! i@ would not be evaluated which means that @mv@ --- would unnecessarily retain a reference to @v@ in each element written. --- --- With 'indexM', copying can be implemented like this instead: --- --- > copy mv v = ... do --- > x <- indexM v i --- > write mv i x --- --- Here, no references to @v@ are retained because indexing (but /not/ the --- elements) is evaluated eagerly. --- -indexM :: (Vector v a, Monad m) => v a -> Int -> m a -{-# INLINE_FUSED indexM #-} -indexM v i = BOUNDS_CHECK(checkIndex) "indexM" i (length v) - $ basicUnsafeIndexM v i - --- | /O(1)/ First element of a vector in a monad. See 'indexM' for an --- explanation of why this is useful. -headM :: (Vector v a, Monad m) => v a -> m a -{-# INLINE_FUSED headM #-} -headM v = indexM v 0 - --- | /O(1)/ Last element of a vector in a monad. See 'indexM' for an --- explanation of why this is useful. -lastM :: (Vector v a, Monad m) => v a -> m a -{-# INLINE_FUSED lastM #-} -lastM v = indexM v (length v - 1) - --- | /O(1)/ Indexing in a monad without bounds checks. See 'indexM' for an --- explanation of why this is useful. -unsafeIndexM :: (Vector v a, Monad m) => v a -> Int -> m a -{-# INLINE_FUSED unsafeIndexM #-} -unsafeIndexM v i = UNSAFE_CHECK(checkIndex) "unsafeIndexM" i (length v) - $ basicUnsafeIndexM v i - --- | /O(1)/ First element in a monad without checking for empty vectors. --- See 'indexM' for an explanation of why this is useful. -unsafeHeadM :: (Vector v a, Monad m) => v a -> m a -{-# INLINE_FUSED unsafeHeadM #-} -unsafeHeadM v = unsafeIndexM v 0 - --- | /O(1)/ Last element in a monad without checking for empty vectors. --- See 'indexM' for an explanation of why this is useful. -unsafeLastM :: (Vector v a, Monad m) => v a -> m a -{-# INLINE_FUSED unsafeLastM #-} -unsafeLastM v = unsafeIndexM v (length v - 1) - -{-# RULES - -"indexM/unstream [Vector]" forall s i. - indexM (new (New.unstream s)) i = lift s MBundle.!! i - -"headM/unstream [Vector]" forall s. - headM (new (New.unstream s)) = MBundle.head (lift s) - -"lastM/unstream [Vector]" forall s. - lastM (new (New.unstream s)) = MBundle.last (lift s) - -"unsafeIndexM/unstream [Vector]" forall s i. - unsafeIndexM (new (New.unstream s)) i = lift s MBundle.!! i - -"unsafeHeadM/unstream [Vector]" forall s. - unsafeHeadM (new (New.unstream s)) = MBundle.head (lift s) - -"unsafeLastM/unstream [Vector]" forall s. - unsafeLastM (new (New.unstream s)) = MBundle.last (lift s) #-} - - - --- Extracting subvectors (slicing) --- ------------------------------- - --- | /O(1)/ Yield a slice of the vector without copying it. The vector must --- contain at least @i+n@ elements. -slice :: Vector v a => Int -- ^ @i@ starting index - -> Int -- ^ @n@ length - -> v a - -> v a -{-# INLINE_FUSED slice #-} -slice i n v = BOUNDS_CHECK(checkSlice) "slice" i n (length v) - $ basicUnsafeSlice i n v - --- | /O(1)/ Yield all but the last element without copying. The vector may not --- be empty. -init :: Vector v a => v a -> v a -{-# INLINE_FUSED init #-} -init v = slice 0 (length v - 1) v - --- | /O(1)/ Yield all but the first element without copying. The vector may not --- be empty. -tail :: Vector v a => v a -> v a -{-# INLINE_FUSED tail #-} -tail v = slice 1 (length v - 1) v - --- | /O(1)/ Yield the first @n@ elements without copying. The vector may --- contain less than @n@ elements in which case it is returned unchanged. -take :: Vector v a => Int -> v a -> v a -{-# INLINE_FUSED take #-} -take n v = unsafeSlice 0 (delay_inline min n' (length v)) v - where n' = max n 0 - --- | /O(1)/ Yield all but the first @n@ elements without copying. The vector may --- contain less than @n@ elements in which case an empty vector is returned. -drop :: Vector v a => Int -> v a -> v a -{-# INLINE_FUSED drop #-} -drop n v = unsafeSlice (delay_inline min n' len) - (delay_inline max 0 (len - n')) v - where n' = max n 0 - len = length v - --- | /O(1)/ Yield the first @n@ elements paired with the remainder without copying. --- --- Note that @'splitAt' n v@ is equivalent to @('take' n v, 'drop' n v)@ --- but slightly more efficient. -{-# INLINE_FUSED splitAt #-} -splitAt :: Vector v a => Int -> v a -> (v a, v a) -splitAt n v = ( unsafeSlice 0 m v - , unsafeSlice m (delay_inline max 0 (len - n')) v - ) - where - m = delay_inline min n' len - n' = max n 0 - len = length v - --- | /O(1)/ Yield a slice of the vector without copying. The vector must --- contain at least @i+n@ elements but this is not checked. -unsafeSlice :: Vector v a => Int -- ^ @i@ starting index - -> Int -- ^ @n@ length - -> v a - -> v a -{-# INLINE_FUSED unsafeSlice #-} -unsafeSlice i n v = UNSAFE_CHECK(checkSlice) "unsafeSlice" i n (length v) - $ basicUnsafeSlice i n v - --- | /O(1)/ Yield all but the last element without copying. The vector may not --- be empty but this is not checked. -unsafeInit :: Vector v a => v a -> v a -{-# INLINE_FUSED unsafeInit #-} -unsafeInit v = unsafeSlice 0 (length v - 1) v - --- | /O(1)/ Yield all but the first element without copying. The vector may not --- be empty but this is not checked. -unsafeTail :: Vector v a => v a -> v a -{-# INLINE_FUSED unsafeTail #-} -unsafeTail v = unsafeSlice 1 (length v - 1) v - --- | /O(1)/ Yield the first @n@ elements without copying. The vector must --- contain at least @n@ elements but this is not checked. -unsafeTake :: Vector v a => Int -> v a -> v a -{-# INLINE unsafeTake #-} -unsafeTake n v = unsafeSlice 0 n v - --- | /O(1)/ Yield all but the first @n@ elements without copying. The vector --- must contain at least @n@ elements but this is not checked. -unsafeDrop :: Vector v a => Int -> v a -> v a -{-# INLINE unsafeDrop #-} -unsafeDrop n v = unsafeSlice n (length v - n) v - -{-# RULES - -"slice/new [Vector]" forall i n p. - slice i n (new p) = new (New.slice i n p) - -"init/new [Vector]" forall p. - init (new p) = new (New.init p) - -"tail/new [Vector]" forall p. - tail (new p) = new (New.tail p) - -"take/new [Vector]" forall n p. - take n (new p) = new (New.take n p) - -"drop/new [Vector]" forall n p. - drop n (new p) = new (New.drop n p) - -"unsafeSlice/new [Vector]" forall i n p. - unsafeSlice i n (new p) = new (New.unsafeSlice i n p) - -"unsafeInit/new [Vector]" forall p. - unsafeInit (new p) = new (New.unsafeInit p) - -"unsafeTail/new [Vector]" forall p. - unsafeTail (new p) = new (New.unsafeTail p) #-} - - - --- Initialisation --- -------------- - --- | /O(1)/ Empty vector -empty :: Vector v a => v a -{-# INLINE empty #-} -empty = unstream Bundle.empty - --- | /O(1)/ Vector with exactly one element -singleton :: forall v a. Vector v a => a -> v a -{-# INLINE singleton #-} -singleton x = elemseq (undefined :: v a) x - $ unstream (Bundle.singleton x) - --- | /O(n)/ Vector of the given length with the same value in each position -replicate :: forall v a. Vector v a => Int -> a -> v a -{-# INLINE replicate #-} -replicate n x = elemseq (undefined :: v a) x - $ unstream - $ Bundle.replicate n x - --- | /O(n)/ Construct a vector of the given length by applying the function to --- each index -generate :: Vector v a => Int -> (Int -> a) -> v a -{-# INLINE generate #-} -generate n f = unstream (Bundle.generate n f) - --- | /O(n)/ Apply function n times to value. Zeroth element is original value. -iterateN :: Vector v a => Int -> (a -> a) -> a -> v a -{-# INLINE iterateN #-} -iterateN n f x = unstream (Bundle.iterateN n f x) - --- Unfolding --- --------- - --- | /O(n)/ Construct a vector by repeatedly applying the generator function --- to a seed. The generator function yields 'Just' the next element and the --- new seed or 'Nothing' if there are no more elements. --- --- > unfoldr (\n -> if n == 0 then Nothing else Just (n,n-1)) 10 --- > = <10,9,8,7,6,5,4,3,2,1> -unfoldr :: Vector v a => (b -> Maybe (a, b)) -> b -> v a -{-# INLINE unfoldr #-} -unfoldr f = unstream . Bundle.unfoldr f - --- | /O(n)/ Construct a vector with at most @n@ elements by repeatedly applying --- the generator function to a seed. The generator function yields 'Just' the --- next element and the new seed or 'Nothing' if there are no more elements. --- --- > unfoldrN 3 (\n -> Just (n,n-1)) 10 = <10,9,8> -unfoldrN :: Vector v a => Int -> (b -> Maybe (a, b)) -> b -> v a -{-# INLINE unfoldrN #-} -unfoldrN n f = unstream . Bundle.unfoldrN n f - --- | /O(n)/ Construct a vector by repeatedly applying the monadic --- generator function to a seed. The generator function yields 'Just' --- the next element and the new seed or 'Nothing' if there are no more --- elements. -unfoldrM :: (Monad m, Vector v a) => (b -> m (Maybe (a, b))) -> b -> m (v a) -{-# INLINE unfoldrM #-} -unfoldrM f = unstreamM . MBundle.unfoldrM f - --- | /O(n)/ Construct a vector by repeatedly applying the monadic --- generator function to a seed. The generator function yields 'Just' --- the next element and the new seed or 'Nothing' if there are no more --- elements. -unfoldrNM :: (Monad m, Vector v a) => Int -> (b -> m (Maybe (a, b))) -> b -> m (v a) -{-# INLINE unfoldrNM #-} -unfoldrNM n f = unstreamM . MBundle.unfoldrNM n f - --- | /O(n)/ Construct a vector with @n@ elements by repeatedly applying the --- generator function to the already constructed part of the vector. --- --- > constructN 3 f = let a = f <> ; b = f <a> ; c = f <a,b> in f <a,b,c> --- -constructN :: forall v a. Vector v a => Int -> (v a -> a) -> v a -{-# INLINE constructN #-} --- NOTE: We *CANNOT* wrap this in New and then fuse because the elements --- might contain references to the immutable vector! -constructN !n f = runST ( - do - v <- M.new n - v' <- unsafeFreeze v - fill v' 0 - ) - where - fill :: forall s. v a -> Int -> ST s (v a) - fill !v i | i < n = let x = f (unsafeTake i v) - in - elemseq v x $ - do - v' <- unsafeThaw v - M.unsafeWrite v' i x - v'' <- unsafeFreeze v' - fill v'' (i+1) - - fill v _ = return v - --- | /O(n)/ Construct a vector with @n@ elements from right to left by --- repeatedly applying the generator function to the already constructed part --- of the vector. --- --- > constructrN 3 f = let a = f <> ; b = f<a> ; c = f <b,a> in f <c,b,a> --- -constructrN :: forall v a. Vector v a => Int -> (v a -> a) -> v a -{-# INLINE constructrN #-} --- NOTE: We *CANNOT* wrap this in New and then fuse because the elements --- might contain references to the immutable vector! -constructrN !n f = runST ( - do - v <- n `seq` M.new n - v' <- unsafeFreeze v - fill v' 0 - ) - where - fill :: forall s. v a -> Int -> ST s (v a) - fill !v i | i < n = let x = f (unsafeSlice (n-i) i v) - in - elemseq v x $ - do - v' <- unsafeThaw v - M.unsafeWrite v' (n-i-1) x - v'' <- unsafeFreeze v' - fill v'' (i+1) - - fill v _ = return v - - --- Enumeration --- ----------- - --- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+1@ --- etc. This operation is usually more efficient than 'enumFromTo'. --- --- > enumFromN 5 3 = <5,6,7> -enumFromN :: (Vector v a, Num a) => a -> Int -> v a -{-# INLINE enumFromN #-} -enumFromN x n = enumFromStepN x 1 n - --- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+y@, --- @x+y+y@ etc. This operations is usually more efficient than 'enumFromThenTo'. --- --- > enumFromStepN 1 0.1 5 = <1,1.1,1.2,1.3,1.4> -enumFromStepN :: forall v a. (Vector v a, Num a) => a -> a -> Int -> v a -{-# INLINE enumFromStepN #-} -enumFromStepN x y n = elemseq (undefined :: v a) x - $ elemseq (undefined :: v a) y - $ unstream - $ Bundle.enumFromStepN x y n - --- | /O(n)/ Enumerate values from @x@ to @y@. --- --- /WARNING:/ This operation can be very inefficient. If at all possible, use --- 'enumFromN' instead. -enumFromTo :: (Vector v a, Enum a) => a -> a -> v a -{-# INLINE enumFromTo #-} -enumFromTo x y = unstream (Bundle.enumFromTo x y) - --- | /O(n)/ Enumerate values from @x@ to @y@ with a specific step @z@. --- --- /WARNING:/ This operation can be very inefficient. If at all possible, use --- 'enumFromStepN' instead. -enumFromThenTo :: (Vector v a, Enum a) => a -> a -> a -> v a -{-# INLINE enumFromThenTo #-} -enumFromThenTo x y z = unstream (Bundle.enumFromThenTo x y z) - --- Concatenation --- ------------- - --- | /O(n)/ Prepend an element -cons :: forall v a. Vector v a => a -> v a -> v a -{-# INLINE cons #-} -cons x v = elemseq (undefined :: v a) x - $ unstream - $ Bundle.cons x - $ stream v - --- | /O(n)/ Append an element -snoc :: forall v a. Vector v a => v a -> a -> v a -{-# INLINE snoc #-} -snoc v x = elemseq (undefined :: v a) x - $ unstream - $ Bundle.snoc (stream v) x - -infixr 5 ++ --- | /O(m+n)/ Concatenate two vectors -(++) :: Vector v a => v a -> v a -> v a -{-# INLINE (++) #-} -v ++ w = unstream (stream v Bundle.++ stream w) - --- | /O(n)/ Concatenate all vectors in the list -concat :: Vector v a => [v a] -> v a -{-# INLINE concat #-} -concat = unstream . Bundle.fromVectors -{- -concat vs = unstream (Bundle.flatten mk step (Exact n) (Bundle.fromList vs)) - where - n = List.foldl' (\k v -> k + length v) 0 vs - - {-# INLINE_INNER step #-} - step (v,i,k) - | i < k = case unsafeIndexM v i of - Box x -> Bundle.Yield x (v,i+1,k) - | otherwise = Bundle.Done - - {-# INLINE mk #-} - mk v = let k = length v - in - k `seq` (v,0,k) --} - --- | /O(n)/ Concatenate all vectors in the non-empty list -concatNE :: Vector v a => NonEmpty.NonEmpty (v a) -> v a -concatNE = concat . NonEmpty.toList - --- Monadic initialisation --- ---------------------- - --- | /O(n)/ Execute the monadic action the given number of times and store the --- results in a vector. -replicateM :: (Monad m, Vector v a) => Int -> m a -> m (v a) -{-# INLINE replicateM #-} -replicateM n m = unstreamM (MBundle.replicateM n m) - --- | /O(n)/ Construct a vector of the given length by applying the monadic --- action to each index -generateM :: (Monad m, Vector v a) => Int -> (Int -> m a) -> m (v a) -{-# INLINE generateM #-} -generateM n f = unstreamM (MBundle.generateM n f) - --- | /O(n)/ Apply monadic function n times to value. Zeroth element is original value. -iterateNM :: (Monad m, Vector v a) => Int -> (a -> m a) -> a -> m (v a) -{-# INLINE iterateNM #-} -iterateNM n f x = unstreamM (MBundle.iterateNM n f x) - --- | Execute the monadic action and freeze the resulting vector. --- --- @ --- create (do { v \<- 'M.new' 2; 'M.write' v 0 \'a\'; 'M.write' v 1 \'b\'; return v }) = \<'a','b'\> --- @ -create :: Vector v a => (forall s. ST s (Mutable v s a)) -> v a -{-# INLINE create #-} -create p = new (New.create p) - --- | Execute the monadic action and freeze the resulting vectors. -createT - :: (T.Traversable f, Vector v a) - => (forall s. ST s (f (Mutable v s a))) -> f (v a) -{-# INLINE createT #-} -createT p = runST (p >>= T.mapM unsafeFreeze) - --- Restricting memory usage --- ------------------------ - --- | /O(n)/ Yield the argument but force it not to retain any extra memory, --- possibly by copying it. --- --- This is especially useful when dealing with slices. For example: --- --- > force (slice 0 2 <huge vector>) --- --- Here, the slice retains a reference to the huge vector. Forcing it creates --- a copy of just the elements that belong to the slice and allows the huge --- vector to be garbage collected. -force :: Vector v a => v a -> v a --- FIXME: we probably ought to inline this later as the rules still might fire --- otherwise -{-# INLINE_FUSED force #-} -force v = new (clone v) - --- Bulk updates --- ------------ - --- | /O(m+n)/ For each pair @(i,a)@ from the list, replace the vector --- element at position @i@ by @a@. --- --- > <5,9,2,7> // [(2,1),(0,3),(2,8)] = <3,9,8,7> --- -(//) :: Vector v a => v a -- ^ initial vector (of length @m@) - -> [(Int, a)] -- ^ list of index/value pairs (of length @n@) - -> v a -{-# INLINE (//) #-} -v // us = update_stream v (Bundle.fromList us) - --- | /O(m+n)/ For each pair @(i,a)@ from the vector of index/value pairs, --- replace the vector element at position @i@ by @a@. --- --- > update <5,9,2,7> <(2,1),(0,3),(2,8)> = <3,9,8,7> --- -update :: (Vector v a, Vector v (Int, a)) - => v a -- ^ initial vector (of length @m@) - -> v (Int, a) -- ^ vector of index/value pairs (of length @n@) - -> v a -{-# INLINE update #-} -update v w = update_stream v (stream w) - --- | /O(m+min(n1,n2))/ For each index @i@ from the index vector and the --- corresponding value @a@ from the value vector, replace the element of the --- initial vector at position @i@ by @a@. --- --- > update_ <5,9,2,7> <2,0,2> <1,3,8> = <3,9,8,7> --- --- This function is useful for instances of 'Vector' that cannot store pairs. --- Otherwise, 'update' is probably more convenient. --- --- @ --- update_ xs is ys = 'update' xs ('zip' is ys) --- @ -update_ :: (Vector v a, Vector v Int) - => v a -- ^ initial vector (of length @m@) - -> v Int -- ^ index vector (of length @n1@) - -> v a -- ^ value vector (of length @n2@) - -> v a -{-# INLINE update_ #-} -update_ v is w = update_stream v (Bundle.zipWith (,) (stream is) (stream w)) - -update_stream :: Vector v a => v a -> Bundle u (Int,a) -> v a -{-# INLINE update_stream #-} -update_stream = modifyWithBundle M.update - --- | Same as ('//') but without bounds checking. -unsafeUpd :: Vector v a => v a -> [(Int, a)] -> v a -{-# INLINE unsafeUpd #-} -unsafeUpd v us = unsafeUpdate_stream v (Bundle.fromList us) - --- | Same as 'update' but without bounds checking. -unsafeUpdate :: (Vector v a, Vector v (Int, a)) => v a -> v (Int, a) -> v a -{-# INLINE unsafeUpdate #-} -unsafeUpdate v w = unsafeUpdate_stream v (stream w) - --- | Same as 'update_' but without bounds checking. -unsafeUpdate_ :: (Vector v a, Vector v Int) => v a -> v Int -> v a -> v a -{-# INLINE unsafeUpdate_ #-} -unsafeUpdate_ v is w - = unsafeUpdate_stream v (Bundle.zipWith (,) (stream is) (stream w)) - -unsafeUpdate_stream :: Vector v a => v a -> Bundle u (Int,a) -> v a -{-# INLINE unsafeUpdate_stream #-} -unsafeUpdate_stream = modifyWithBundle M.unsafeUpdate - --- Accumulations --- ------------- - --- | /O(m+n)/ For each pair @(i,b)@ from the list, replace the vector element --- @a@ at position @i@ by @f a b@. --- --- > accum (+) <5,9,2> [(2,4),(1,6),(0,3),(1,7)] = <5+3, 9+6+7, 2+4> -accum :: Vector v a - => (a -> b -> a) -- ^ accumulating function @f@ - -> v a -- ^ initial vector (of length @m@) - -> [(Int,b)] -- ^ list of index/value pairs (of length @n@) - -> v a -{-# INLINE accum #-} -accum f v us = accum_stream f v (Bundle.fromList us) - --- | /O(m+n)/ For each pair @(i,b)@ from the vector of pairs, replace the vector --- element @a@ at position @i@ by @f a b@. --- --- > accumulate (+) <5,9,2> <(2,4),(1,6),(0,3),(1,7)> = <5+3, 9+6+7, 2+4> -accumulate :: (Vector v a, Vector v (Int, b)) - => (a -> b -> a) -- ^ accumulating function @f@ - -> v a -- ^ initial vector (of length @m@) - -> v (Int,b) -- ^ vector of index/value pairs (of length @n@) - -> v a -{-# INLINE accumulate #-} -accumulate f v us = accum_stream f v (stream us) - --- | /O(m+min(n1,n2))/ For each index @i@ from the index vector and the --- corresponding value @b@ from the the value vector, --- replace the element of the initial vector at --- position @i@ by @f a b@. --- --- > accumulate_ (+) <5,9,2> <2,1,0,1> <4,6,3,7> = <5+3, 9+6+7, 2+4> --- --- This function is useful for instances of 'Vector' that cannot store pairs. --- Otherwise, 'accumulate' is probably more convenient: --- --- @ --- accumulate_ f as is bs = 'accumulate' f as ('zip' is bs) --- @ -accumulate_ :: (Vector v a, Vector v Int, Vector v b) - => (a -> b -> a) -- ^ accumulating function @f@ - -> v a -- ^ initial vector (of length @m@) - -> v Int -- ^ index vector (of length @n1@) - -> v b -- ^ value vector (of length @n2@) - -> v a -{-# INLINE accumulate_ #-} -accumulate_ f v is xs = accum_stream f v (Bundle.zipWith (,) (stream is) - (stream xs)) - - -accum_stream :: Vector v a => (a -> b -> a) -> v a -> Bundle u (Int,b) -> v a -{-# INLINE accum_stream #-} -accum_stream f = modifyWithBundle (M.accum f) - --- | Same as 'accum' but without bounds checking. -unsafeAccum :: Vector v a => (a -> b -> a) -> v a -> [(Int,b)] -> v a -{-# INLINE unsafeAccum #-} -unsafeAccum f v us = unsafeAccum_stream f v (Bundle.fromList us) - --- | Same as 'accumulate' but without bounds checking. -unsafeAccumulate :: (Vector v a, Vector v (Int, b)) - => (a -> b -> a) -> v a -> v (Int,b) -> v a -{-# INLINE unsafeAccumulate #-} -unsafeAccumulate f v us = unsafeAccum_stream f v (stream us) - --- | Same as 'accumulate_' but without bounds checking. -unsafeAccumulate_ :: (Vector v a, Vector v Int, Vector v b) - => (a -> b -> a) -> v a -> v Int -> v b -> v a -{-# INLINE unsafeAccumulate_ #-} -unsafeAccumulate_ f v is xs - = unsafeAccum_stream f v (Bundle.zipWith (,) (stream is) (stream xs)) - -unsafeAccum_stream - :: Vector v a => (a -> b -> a) -> v a -> Bundle u (Int,b) -> v a -{-# INLINE unsafeAccum_stream #-} -unsafeAccum_stream f = modifyWithBundle (M.unsafeAccum f) - --- Permutations --- ------------ - --- | /O(n)/ Reverse a vector -reverse :: (Vector v a) => v a -> v a -{-# INLINE reverse #-} --- FIXME: make this fuse better, add support for recycling -reverse = unstream . streamR - --- | /O(n)/ Yield the vector obtained by replacing each element @i@ of the --- index vector by @xs'!'i@. This is equivalent to @'map' (xs'!') is@ but is --- often much more efficient. --- --- > backpermute <a,b,c,d> <0,3,2,3,1,0> = <a,d,c,d,b,a> -backpermute :: (Vector v a, Vector v Int) - => v a -- ^ @xs@ value vector - -> v Int -- ^ @is@ index vector (of length @n@) - -> v a -{-# INLINE backpermute #-} --- This somewhat non-intuitive definition ensures that the resulting vector --- does not retain references to the original one even if it is lazy in its --- elements. This would not be the case if we simply used map (v!) -backpermute v is = seq v - $ seq n - $ unstream - $ Bundle.unbox - $ Bundle.map index - $ stream is - where - n = length v - - {-# INLINE index #-} - -- NOTE: we do it this way to avoid triggering LiberateCase on n in - -- polymorphic code - index i = BOUNDS_CHECK(checkIndex) "backpermute" i n - $ basicUnsafeIndexM v i - --- | Same as 'backpermute' but without bounds checking. -unsafeBackpermute :: (Vector v a, Vector v Int) => v a -> v Int -> v a -{-# INLINE unsafeBackpermute #-} -unsafeBackpermute v is = seq v - $ seq n - $ unstream - $ Bundle.unbox - $ Bundle.map index - $ stream is - where - n = length v - - {-# INLINE index #-} - -- NOTE: we do it this way to avoid triggering LiberateCase on n in - -- polymorphic code - index i = UNSAFE_CHECK(checkIndex) "unsafeBackpermute" i n - $ basicUnsafeIndexM v i - --- Safe destructive updates --- ------------------------ - --- | Apply a destructive operation to a vector. The operation will be --- performed in place if it is safe to do so and will modify a copy of the --- vector otherwise. --- --- @ --- modify (\\v -> 'M.write' v 0 \'x\') ('replicate' 3 \'a\') = \<\'x\',\'a\',\'a\'\> --- @ -modify :: Vector v a => (forall s. Mutable v s a -> ST s ()) -> v a -> v a -{-# INLINE modify #-} -modify p = new . New.modify p . clone - --- We have to make sure that this is strict in the stream but we can't seq on --- it while fusion is happening. Hence this ugliness. -modifyWithBundle :: Vector v a - => (forall s. Mutable v s a -> Bundle u b -> ST s ()) - -> v a -> Bundle u b -> v a -{-# INLINE modifyWithBundle #-} -modifyWithBundle p v s = new (New.modifyWithBundle p (clone v) s) - --- Indexing --- -------- - --- | /O(n)/ Pair each element in a vector with its index -indexed :: (Vector v a, Vector v (Int,a)) => v a -> v (Int,a) -{-# INLINE indexed #-} -indexed = unstream . Bundle.indexed . stream - --- Mapping --- ------- - --- | /O(n)/ Map a function over a vector -map :: (Vector v a, Vector v b) => (a -> b) -> v a -> v b -{-# INLINE map #-} -map f = unstream . inplace (S.map f) id . stream - --- | /O(n)/ Apply a function to every element of a vector and its index -imap :: (Vector v a, Vector v b) => (Int -> a -> b) -> v a -> v b -{-# INLINE imap #-} -imap f = unstream . inplace (S.map (uncurry f) . S.indexed) id - . stream - --- | Map a function over a vector and concatenate the results. -concatMap :: (Vector v a, Vector v b) => (a -> v b) -> v a -> v b -{-# INLINE concatMap #-} --- NOTE: We can't fuse concatMap anyway so don't pretend we do. --- This seems to be slightly slower --- concatMap f = concat . Bundle.toList . Bundle.map f . stream - --- Slowest --- concatMap f = unstream . Bundle.concatMap (stream . f) . stream - --- Used to be fastest -{- -concatMap f = unstream - . Bundle.flatten mk step Unknown - . stream - where - {-# INLINE_INNER step #-} - step (v,i,k) - | i < k = case unsafeIndexM v i of - Box x -> Bundle.Yield x (v,i+1,k) - | otherwise = Bundle.Done - - {-# INLINE mk #-} - mk x = let v = f x - k = length v - in - k `seq` (v,0,k) --} - --- This seems to be fastest now -concatMap f = unstream - . Bundle.concatVectors - . Bundle.map f - . stream - --- Monadic mapping --- --------------- - --- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a --- vector of results -mapM :: (Monad m, Vector v a, Vector v b) => (a -> m b) -> v a -> m (v b) -{-# INLINE mapM #-} -mapM f = unstreamM . Bundle.mapM f . stream - --- | /O(n)/ Apply the monadic action to every element of a vector and its --- index, yielding a vector of results -imapM :: (Monad m, Vector v a, Vector v b) - => (Int -> a -> m b) -> v a -> m (v b) -imapM f = unstreamM . Bundle.mapM (uncurry f) . Bundle.indexed . stream - --- | /O(n)/ Apply the monadic action to all elements of a vector and ignore the --- results -mapM_ :: (Monad m, Vector v a) => (a -> m b) -> v a -> m () -{-# INLINE mapM_ #-} -mapM_ f = Bundle.mapM_ f . stream - --- | /O(n)/ Apply the monadic action to every element of a vector and its --- index, ignoring the results -imapM_ :: (Monad m, Vector v a) => (Int -> a -> m b) -> v a -> m () -{-# INLINE imapM_ #-} -imapM_ f = Bundle.mapM_ (uncurry f) . Bundle.indexed . stream - --- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a --- vector of results. Equivalent to @flip 'mapM'@. -forM :: (Monad m, Vector v a, Vector v b) => v a -> (a -> m b) -> m (v b) -{-# INLINE forM #-} -forM as f = mapM f as - --- | /O(n)/ Apply the monadic action to all elements of a vector and ignore the --- results. Equivalent to @flip 'mapM_'@. -forM_ :: (Monad m, Vector v a) => v a -> (a -> m b) -> m () -{-# INLINE forM_ #-} -forM_ as f = mapM_ f as - --- Zipping --- ------- - --- | /O(min(m,n))/ Zip two vectors with the given function. -zipWith :: (Vector v a, Vector v b, Vector v c) - => (a -> b -> c) -> v a -> v b -> v c -{-# INLINE zipWith #-} -zipWith f = \xs ys -> unstream (Bundle.zipWith f (stream xs) (stream ys)) - --- | Zip three vectors with the given function. -zipWith3 :: (Vector v a, Vector v b, Vector v c, Vector v d) - => (a -> b -> c -> d) -> v a -> v b -> v c -> v d -{-# INLINE zipWith3 #-} -zipWith3 f = \as bs cs -> unstream (Bundle.zipWith3 f (stream as) - (stream bs) - (stream cs)) - -zipWith4 :: (Vector v a, Vector v b, Vector v c, Vector v d, Vector v e) - => (a -> b -> c -> d -> e) -> v a -> v b -> v c -> v d -> v e -{-# INLINE zipWith4 #-} -zipWith4 f = \as bs cs ds -> - unstream (Bundle.zipWith4 f (stream as) - (stream bs) - (stream cs) - (stream ds)) - -zipWith5 :: (Vector v a, Vector v b, Vector v c, Vector v d, Vector v e, - Vector v f) - => (a -> b -> c -> d -> e -> f) -> v a -> v b -> v c -> v d -> v e - -> v f -{-# INLINE zipWith5 #-} -zipWith5 f = \as bs cs ds es -> - unstream (Bundle.zipWith5 f (stream as) - (stream bs) - (stream cs) - (stream ds) - (stream es)) - -zipWith6 :: (Vector v a, Vector v b, Vector v c, Vector v d, Vector v e, - Vector v f, Vector v g) - => (a -> b -> c -> d -> e -> f -> g) - -> v a -> v b -> v c -> v d -> v e -> v f -> v g -{-# INLINE zipWith6 #-} -zipWith6 f = \as bs cs ds es fs -> - unstream (Bundle.zipWith6 f (stream as) - (stream bs) - (stream cs) - (stream ds) - (stream es) - (stream fs)) - --- | /O(min(m,n))/ Zip two vectors with a function that also takes the --- elements' indices. -izipWith :: (Vector v a, Vector v b, Vector v c) - => (Int -> a -> b -> c) -> v a -> v b -> v c -{-# INLINE izipWith #-} -izipWith f = \xs ys -> - unstream (Bundle.zipWith (uncurry f) (Bundle.indexed (stream xs)) - (stream ys)) - -izipWith3 :: (Vector v a, Vector v b, Vector v c, Vector v d) - => (Int -> a -> b -> c -> d) -> v a -> v b -> v c -> v d -{-# INLINE izipWith3 #-} -izipWith3 f = \as bs cs -> - unstream (Bundle.zipWith3 (uncurry f) (Bundle.indexed (stream as)) - (stream bs) - (stream cs)) - -izipWith4 :: (Vector v a, Vector v b, Vector v c, Vector v d, Vector v e) - => (Int -> a -> b -> c -> d -> e) -> v a -> v b -> v c -> v d -> v e -{-# INLINE izipWith4 #-} -izipWith4 f = \as bs cs ds -> - unstream (Bundle.zipWith4 (uncurry f) (Bundle.indexed (stream as)) - (stream bs) - (stream cs) - (stream ds)) - -izipWith5 :: (Vector v a, Vector v b, Vector v c, Vector v d, Vector v e, - Vector v f) - => (Int -> a -> b -> c -> d -> e -> f) -> v a -> v b -> v c -> v d - -> v e -> v f -{-# INLINE izipWith5 #-} -izipWith5 f = \as bs cs ds es -> - unstream (Bundle.zipWith5 (uncurry f) (Bundle.indexed (stream as)) - (stream bs) - (stream cs) - (stream ds) - (stream es)) - -izipWith6 :: (Vector v a, Vector v b, Vector v c, Vector v d, Vector v e, - Vector v f, Vector v g) - => (Int -> a -> b -> c -> d -> e -> f -> g) - -> v a -> v b -> v c -> v d -> v e -> v f -> v g -{-# INLINE izipWith6 #-} -izipWith6 f = \as bs cs ds es fs -> - unstream (Bundle.zipWith6 (uncurry f) (Bundle.indexed (stream as)) - (stream bs) - (stream cs) - (stream ds) - (stream es) - (stream fs)) - --- | /O(min(m,n))/ Zip two vectors -zip :: (Vector v a, Vector v b, Vector v (a,b)) => v a -> v b -> v (a, b) -{-# INLINE zip #-} -zip = zipWith (,) - -zip3 :: (Vector v a, Vector v b, Vector v c, Vector v (a, b, c)) - => v a -> v b -> v c -> v (a, b, c) -{-# INLINE zip3 #-} -zip3 = zipWith3 (,,) - -zip4 :: (Vector v a, Vector v b, Vector v c, Vector v d, Vector v (a, b, c, d)) - => v a -> v b -> v c -> v d -> v (a, b, c, d) -{-# INLINE zip4 #-} -zip4 = zipWith4 (,,,) - -zip5 :: (Vector v a, Vector v b, Vector v c, Vector v d, Vector v e, - Vector v (a, b, c, d, e)) - => v a -> v b -> v c -> v d -> v e -> v (a, b, c, d, e) -{-# INLINE zip5 #-} -zip5 = zipWith5 (,,,,) - -zip6 :: (Vector v a, Vector v b, Vector v c, Vector v d, Vector v e, - Vector v f, Vector v (a, b, c, d, e, f)) - => v a -> v b -> v c -> v d -> v e -> v f -> v (a, b, c, d, e, f) -{-# INLINE zip6 #-} -zip6 = zipWith6 (,,,,,) - --- Monadic zipping --- --------------- - --- | /O(min(m,n))/ Zip the two vectors with the monadic action and yield a --- vector of results -zipWithM :: (Monad m, Vector v a, Vector v b, Vector v c) - => (a -> b -> m c) -> v a -> v b -> m (v c) --- FIXME: specialise for ST and IO? -{-# INLINE zipWithM #-} -zipWithM f = \as bs -> unstreamM $ Bundle.zipWithM f (stream as) (stream bs) - --- | /O(min(m,n))/ Zip the two vectors with a monadic action that also takes --- the element index and yield a vector of results -izipWithM :: (Monad m, Vector v a, Vector v b, Vector v c) - => (Int -> a -> b -> m c) -> v a -> v b -> m (v c) -{-# INLINE izipWithM #-} -izipWithM m as bs = unstreamM . Bundle.zipWithM (uncurry m) - (Bundle.indexed (stream as)) - $ stream bs - --- | /O(min(m,n))/ Zip the two vectors with the monadic action and ignore the --- results -zipWithM_ :: (Monad m, Vector v a, Vector v b) - => (a -> b -> m c) -> v a -> v b -> m () -{-# INLINE zipWithM_ #-} -zipWithM_ f = \as bs -> Bundle.zipWithM_ f (stream as) (stream bs) - --- | /O(min(m,n))/ Zip the two vectors with a monadic action that also takes --- the element index and ignore the results -izipWithM_ :: (Monad m, Vector v a, Vector v b) - => (Int -> a -> b -> m c) -> v a -> v b -> m () -{-# INLINE izipWithM_ #-} -izipWithM_ m as bs = Bundle.zipWithM_ (uncurry m) - (Bundle.indexed (stream as)) - $ stream bs - --- Unzipping --- --------- - --- | /O(min(m,n))/ Unzip a vector of pairs. -unzip :: (Vector v a, Vector v b, Vector v (a,b)) => v (a, b) -> (v a, v b) -{-# INLINE unzip #-} -unzip xs = (map fst xs, map snd xs) - -unzip3 :: (Vector v a, Vector v b, Vector v c, Vector v (a, b, c)) - => v (a, b, c) -> (v a, v b, v c) -{-# INLINE unzip3 #-} -unzip3 xs = (map (\(a, _, _) -> a) xs, - map (\(_, b, _) -> b) xs, - map (\(_, _, c) -> c) xs) - -unzip4 :: (Vector v a, Vector v b, Vector v c, Vector v d, - Vector v (a, b, c, d)) - => v (a, b, c, d) -> (v a, v b, v c, v d) -{-# INLINE unzip4 #-} -unzip4 xs = (map (\(a, _, _, _) -> a) xs, - map (\(_, b, _, _) -> b) xs, - map (\(_, _, c, _) -> c) xs, - map (\(_, _, _, d) -> d) xs) - -unzip5 :: (Vector v a, Vector v b, Vector v c, Vector v d, Vector v e, - Vector v (a, b, c, d, e)) - => v (a, b, c, d, e) -> (v a, v b, v c, v d, v e) -{-# INLINE unzip5 #-} -unzip5 xs = (map (\(a, _, _, _, _) -> a) xs, - map (\(_, b, _, _, _) -> b) xs, - map (\(_, _, c, _, _) -> c) xs, - map (\(_, _, _, d, _) -> d) xs, - map (\(_, _, _, _, e) -> e) xs) - -unzip6 :: (Vector v a, Vector v b, Vector v c, Vector v d, Vector v e, - Vector v f, Vector v (a, b, c, d, e, f)) - => v (a, b, c, d, e, f) -> (v a, v b, v c, v d, v e, v f) -{-# INLINE unzip6 #-} -unzip6 xs = (map (\(a, _, _, _, _, _) -> a) xs, - map (\(_, b, _, _, _, _) -> b) xs, - map (\(_, _, c, _, _, _) -> c) xs, - map (\(_, _, _, d, _, _) -> d) xs, - map (\(_, _, _, _, e, _) -> e) xs, - map (\(_, _, _, _, _, f) -> f) xs) - --- Filtering --- --------- - --- | /O(n)/ Drop elements that do not satisfy the predicate -filter :: Vector v a => (a -> Bool) -> v a -> v a -{-# INLINE filter #-} -filter f = unstream . inplace (S.filter f) toMax . stream - --- | /O(n)/ Drop elements that do not satisfy the predicate which is applied to --- values and their indices -ifilter :: Vector v a => (Int -> a -> Bool) -> v a -> v a -{-# INLINE ifilter #-} -ifilter f = unstream - . inplace (S.map snd . S.filter (uncurry f) . S.indexed) toMax - . stream - --- | /O(n)/ Drop repeated adjacent elements. -uniq :: (Vector v a, Eq a) => v a -> v a -{-# INLINE uniq #-} -uniq = unstream . inplace S.uniq toMax . stream - --- | /O(n)/ Drop elements when predicate returns Nothing -mapMaybe :: (Vector v a, Vector v b) => (a -> Maybe b) -> v a -> v b -{-# INLINE mapMaybe #-} -mapMaybe f = unstream . inplace (S.mapMaybe f) toMax . stream - --- | /O(n)/ Drop elements when predicate, applied to index and value, returns Nothing -imapMaybe :: (Vector v a, Vector v b) => (Int -> a -> Maybe b) -> v a -> v b -{-# INLINE imapMaybe #-} -imapMaybe f = unstream - . inplace (S.mapMaybe (uncurry f) . S.indexed) toMax - . stream - - --- | /O(n)/ Drop elements that do not satisfy the monadic predicate -filterM :: (Monad m, Vector v a) => (a -> m Bool) -> v a -> m (v a) -{-# INLINE filterM #-} -filterM f = unstreamM . Bundle.filterM f . stream - --- | /O(n)/ Yield the longest prefix of elements satisfying the predicate --- without copying. -takeWhile :: Vector v a => (a -> Bool) -> v a -> v a -{-# INLINE takeWhile #-} -takeWhile f = unstream . Bundle.takeWhile f . stream - --- | /O(n)/ Drop the longest prefix of elements that satisfy the predicate --- without copying. -dropWhile :: Vector v a => (a -> Bool) -> v a -> v a -{-# INLINE dropWhile #-} -dropWhile f = unstream . Bundle.dropWhile f . stream - --- Parititioning --- ------------- - --- | /O(n)/ Split the vector in two parts, the first one containing those --- elements that satisfy the predicate and the second one those that don't. The --- relative order of the elements is preserved at the cost of a sometimes --- reduced performance compared to 'unstablePartition'. -partition :: Vector v a => (a -> Bool) -> v a -> (v a, v a) -{-# INLINE partition #-} -partition f = partition_stream f . stream - --- FIXME: Make this inplace-fusible (look at how stable_partition is --- implemented in C++) - -partition_stream :: Vector v a => (a -> Bool) -> Bundle u a -> (v a, v a) -{-# INLINE_FUSED partition_stream #-} -partition_stream f s = s `seq` runST ( - do - (mv1,mv2) <- M.partitionBundle f s - v1 <- unsafeFreeze mv1 - v2 <- unsafeFreeze mv2 - return (v1,v2)) - --- | /O(n)/ Split the vector in two parts, the first one containing those --- elements that satisfy the predicate and the second one those that don't. --- The order of the elements is not preserved but the operation is often --- faster than 'partition'. -unstablePartition :: Vector v a => (a -> Bool) -> v a -> (v a, v a) -{-# INLINE unstablePartition #-} -unstablePartition f = unstablePartition_stream f . stream - -unstablePartition_stream - :: Vector v a => (a -> Bool) -> Bundle u a -> (v a, v a) -{-# INLINE_FUSED unstablePartition_stream #-} -unstablePartition_stream f s = s `seq` runST ( - do - (mv1,mv2) <- M.unstablePartitionBundle f s - v1 <- unsafeFreeze mv1 - v2 <- unsafeFreeze mv2 - return (v1,v2)) - -unstablePartition_new :: Vector v a => (a -> Bool) -> New v a -> (v a, v a) -{-# INLINE_FUSED unstablePartition_new #-} -unstablePartition_new f (New.New p) = runST ( - do - mv <- p - i <- M.unstablePartition f mv - v <- unsafeFreeze mv - return (unsafeTake i v, unsafeDrop i v)) - -{-# RULES - -"unstablePartition" forall f p. - unstablePartition_stream f (stream (new p)) - = unstablePartition_new f p #-} - - - - --- FIXME: make span and break fusible - --- | /O(n)/ Split the vector into the longest prefix of elements that satisfy --- the predicate and the rest without copying. -span :: Vector v a => (a -> Bool) -> v a -> (v a, v a) -{-# INLINE span #-} -span f = break (not . f) - --- | /O(n)/ Split the vector into the longest prefix of elements that do not --- satisfy the predicate and the rest without copying. -break :: Vector v a => (a -> Bool) -> v a -> (v a, v a) -{-# INLINE break #-} -break f xs = case findIndex f xs of - Just i -> (unsafeSlice 0 i xs, unsafeSlice i (length xs - i) xs) - Nothing -> (xs, empty) - - --- Searching --- --------- - -infix 4 `elem` --- | /O(n)/ Check if the vector contains an element -elem :: (Vector v a, Eq a) => a -> v a -> Bool -{-# INLINE elem #-} -elem x = Bundle.elem x . stream - -infix 4 `notElem` --- | /O(n)/ Check if the vector does not contain an element (inverse of 'elem') -notElem :: (Vector v a, Eq a) => a -> v a -> Bool -{-# INLINE notElem #-} -notElem x = Bundle.notElem x . stream - --- | /O(n)/ Yield 'Just' the first element matching the predicate or 'Nothing' --- if no such element exists. -find :: Vector v a => (a -> Bool) -> v a -> Maybe a -{-# INLINE find #-} -find f = Bundle.find f . stream - --- | /O(n)/ Yield 'Just' the index of the first element matching the predicate --- or 'Nothing' if no such element exists. -findIndex :: Vector v a => (a -> Bool) -> v a -> Maybe Int -{-# INLINE findIndex #-} -findIndex f = Bundle.findIndex f . stream - --- | /O(n)/ Yield the indices of elements satisfying the predicate in ascending --- order. -findIndices :: (Vector v a, Vector v Int) => (a -> Bool) -> v a -> v Int -{-# INLINE findIndices #-} -findIndices f = unstream - . inplace (S.map fst . S.filter (f . snd) . S.indexed) toMax - . stream - --- | /O(n)/ Yield 'Just' the index of the first occurence of the given element or --- 'Nothing' if the vector does not contain the element. This is a specialised --- version of 'findIndex'. -elemIndex :: (Vector v a, Eq a) => a -> v a -> Maybe Int -{-# INLINE elemIndex #-} -elemIndex x = findIndex (x==) - --- | /O(n)/ Yield the indices of all occurences of the given element in --- ascending order. This is a specialised version of 'findIndices'. -elemIndices :: (Vector v a, Vector v Int, Eq a) => a -> v a -> v Int -{-# INLINE elemIndices #-} -elemIndices x = findIndices (x==) - --- Folding --- ------- - --- | /O(n)/ Left fold -foldl :: Vector v b => (a -> b -> a) -> a -> v b -> a -{-# INLINE foldl #-} -foldl f z = Bundle.foldl f z . stream - --- | /O(n)/ Left fold on non-empty vectors -foldl1 :: Vector v a => (a -> a -> a) -> v a -> a -{-# INLINE foldl1 #-} -foldl1 f = Bundle.foldl1 f . stream - --- | /O(n)/ Left fold with strict accumulator -foldl' :: Vector v b => (a -> b -> a) -> a -> v b -> a -{-# INLINE foldl' #-} -foldl' f z = Bundle.foldl' f z . stream - --- | /O(n)/ Left fold on non-empty vectors with strict accumulator -foldl1' :: Vector v a => (a -> a -> a) -> v a -> a -{-# INLINE foldl1' #-} -foldl1' f = Bundle.foldl1' f . stream - --- | /O(n)/ Right fold -foldr :: Vector v a => (a -> b -> b) -> b -> v a -> b -{-# INLINE foldr #-} -foldr f z = Bundle.foldr f z . stream - --- | /O(n)/ Right fold on non-empty vectors -foldr1 :: Vector v a => (a -> a -> a) -> v a -> a -{-# INLINE foldr1 #-} -foldr1 f = Bundle.foldr1 f . stream - --- | /O(n)/ Right fold with a strict accumulator -foldr' :: Vector v a => (a -> b -> b) -> b -> v a -> b -{-# INLINE foldr' #-} -foldr' f z = Bundle.foldl' (flip f) z . streamR - --- | /O(n)/ Right fold on non-empty vectors with strict accumulator -foldr1' :: Vector v a => (a -> a -> a) -> v a -> a -{-# INLINE foldr1' #-} -foldr1' f = Bundle.foldl1' (flip f) . streamR - --- | /O(n)/ Left fold (function applied to each element and its index) -ifoldl :: Vector v b => (a -> Int -> b -> a) -> a -> v b -> a -{-# INLINE ifoldl #-} -ifoldl f z = Bundle.foldl (uncurry . f) z . Bundle.indexed . stream - --- | /O(n)/ Left fold with strict accumulator (function applied to each element --- and its index) -ifoldl' :: Vector v b => (a -> Int -> b -> a) -> a -> v b -> a -{-# INLINE ifoldl' #-} -ifoldl' f z = Bundle.foldl' (uncurry . f) z . Bundle.indexed . stream - --- | /O(n)/ Right fold (function applied to each element and its index) -ifoldr :: Vector v a => (Int -> a -> b -> b) -> b -> v a -> b -{-# INLINE ifoldr #-} -ifoldr f z = Bundle.foldr (uncurry f) z . Bundle.indexed . stream - --- | /O(n)/ Right fold with strict accumulator (function applied to each --- element and its index) -ifoldr' :: Vector v a => (Int -> a -> b -> b) -> b -> v a -> b -{-# INLINE ifoldr' #-} -ifoldr' f z xs = Bundle.foldl' (flip (uncurry f)) z - $ Bundle.indexedR (length xs) $ streamR xs - --- Specialised folds --- ----------------- - --- | /O(n)/ Check if all elements satisfy the predicate. -all :: Vector v a => (a -> Bool) -> v a -> Bool -{-# INLINE all #-} -all f = Bundle.and . Bundle.map f . stream - --- | /O(n)/ Check if any element satisfies the predicate. -any :: Vector v a => (a -> Bool) -> v a -> Bool -{-# INLINE any #-} -any f = Bundle.or . Bundle.map f . stream - --- | /O(n)/ Check if all elements are 'True' -and :: Vector v Bool => v Bool -> Bool -{-# INLINE and #-} -and = Bundle.and . stream - --- | /O(n)/ Check if any element is 'True' -or :: Vector v Bool => v Bool -> Bool -{-# INLINE or #-} -or = Bundle.or . stream - --- | /O(n)/ Compute the sum of the elements -sum :: (Vector v a, Num a) => v a -> a -{-# INLINE sum #-} -sum = Bundle.foldl' (+) 0 . stream - --- | /O(n)/ Compute the produce of the elements -product :: (Vector v a, Num a) => v a -> a -{-# INLINE product #-} -product = Bundle.foldl' (*) 1 . stream - --- | /O(n)/ Yield the maximum element of the vector. The vector may not be --- empty. -maximum :: (Vector v a, Ord a) => v a -> a -{-# INLINE maximum #-} -maximum = Bundle.foldl1' max . stream - --- | /O(n)/ Yield the maximum element of the vector according to the given --- comparison function. The vector may not be empty. -maximumBy :: Vector v a => (a -> a -> Ordering) -> v a -> a -{-# INLINE maximumBy #-} -maximumBy cmpr = Bundle.foldl1' maxBy . stream - where - {-# INLINE maxBy #-} - maxBy x y = case cmpr x y of - LT -> y - _ -> x - --- | /O(n)/ Yield the minimum element of the vector. The vector may not be --- empty. -minimum :: (Vector v a, Ord a) => v a -> a -{-# INLINE minimum #-} -minimum = Bundle.foldl1' min . stream - --- | /O(n)/ Yield the minimum element of the vector according to the given --- comparison function. The vector may not be empty. -minimumBy :: Vector v a => (a -> a -> Ordering) -> v a -> a -{-# INLINE minimumBy #-} -minimumBy cmpr = Bundle.foldl1' minBy . stream - where - {-# INLINE minBy #-} - minBy x y = case cmpr x y of - GT -> y - _ -> x - --- | /O(n)/ Yield the index of the maximum element of the vector. The vector --- may not be empty. -maxIndex :: (Vector v a, Ord a) => v a -> Int -{-# INLINE maxIndex #-} -maxIndex = maxIndexBy compare - --- | /O(n)/ Yield the index of the maximum element of the vector according to --- the given comparison function. The vector may not be empty. -maxIndexBy :: Vector v a => (a -> a -> Ordering) -> v a -> Int -{-# INLINE maxIndexBy #-} -maxIndexBy cmpr = fst . Bundle.foldl1' imax . Bundle.indexed . stream - where - imax (i,x) (j,y) = i `seq` j `seq` - case cmpr x y of - LT -> (j,y) - _ -> (i,x) - --- | /O(n)/ Yield the index of the minimum element of the vector. The vector --- may not be empty. -minIndex :: (Vector v a, Ord a) => v a -> Int -{-# INLINE minIndex #-} -minIndex = minIndexBy compare - --- | /O(n)/ Yield the index of the minimum element of the vector according to --- the given comparison function. The vector may not be empty. -minIndexBy :: Vector v a => (a -> a -> Ordering) -> v a -> Int -{-# INLINE minIndexBy #-} -minIndexBy cmpr = fst . Bundle.foldl1' imin . Bundle.indexed . stream - where - imin (i,x) (j,y) = i `seq` j `seq` - case cmpr x y of - GT -> (j,y) - _ -> (i,x) - --- Monadic folds --- ------------- - --- | /O(n)/ Monadic fold -foldM :: (Monad m, Vector v b) => (a -> b -> m a) -> a -> v b -> m a -{-# INLINE foldM #-} -foldM m z = Bundle.foldM m z . stream - --- | /O(n)/ Monadic fold (action applied to each element and its index) -ifoldM :: (Monad m, Vector v b) => (a -> Int -> b -> m a) -> a -> v b -> m a -{-# INLINE ifoldM #-} -ifoldM m z = Bundle.foldM (uncurry . m) z . Bundle.indexed . stream - --- | /O(n)/ Monadic fold over non-empty vectors -fold1M :: (Monad m, Vector v a) => (a -> a -> m a) -> v a -> m a -{-# INLINE fold1M #-} -fold1M m = Bundle.fold1M m . stream - --- | /O(n)/ Monadic fold with strict accumulator -foldM' :: (Monad m, Vector v b) => (a -> b -> m a) -> a -> v b -> m a -{-# INLINE foldM' #-} -foldM' m z = Bundle.foldM' m z . stream - --- | /O(n)/ Monadic fold with strict accumulator (action applied to each --- element and its index) -ifoldM' :: (Monad m, Vector v b) => (a -> Int -> b -> m a) -> a -> v b -> m a -{-# INLINE ifoldM' #-} -ifoldM' m z = Bundle.foldM' (uncurry . m) z . Bundle.indexed . stream - --- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator -fold1M' :: (Monad m, Vector v a) => (a -> a -> m a) -> v a -> m a -{-# INLINE fold1M' #-} -fold1M' m = Bundle.fold1M' m . stream - -discard :: Monad m => m a -> m () -{-# INLINE discard #-} -discard m = m >> return () - --- | /O(n)/ Monadic fold that discards the result -foldM_ :: (Monad m, Vector v b) => (a -> b -> m a) -> a -> v b -> m () -{-# INLINE foldM_ #-} -foldM_ m z = discard . Bundle.foldM m z . stream - --- | /O(n)/ Monadic fold that discards the result (action applied to --- each element and its index) -ifoldM_ :: (Monad m, Vector v b) => (a -> Int -> b -> m a) -> a -> v b -> m () -{-# INLINE ifoldM_ #-} -ifoldM_ m z = discard . Bundle.foldM (uncurry . m) z . Bundle.indexed . stream - --- | /O(n)/ Monadic fold over non-empty vectors that discards the result -fold1M_ :: (Monad m, Vector v a) => (a -> a -> m a) -> v a -> m () -{-# INLINE fold1M_ #-} -fold1M_ m = discard . Bundle.fold1M m . stream - --- | /O(n)/ Monadic fold with strict accumulator that discards the result -foldM'_ :: (Monad m, Vector v b) => (a -> b -> m a) -> a -> v b -> m () -{-# INLINE foldM'_ #-} -foldM'_ m z = discard . Bundle.foldM' m z . stream - --- | /O(n)/ Monadic fold with strict accumulator that discards the result --- (action applied to each element and its index) -ifoldM'_ :: (Monad m, Vector v b) => (a -> Int -> b -> m a) -> a -> v b -> m () -{-# INLINE ifoldM'_ #-} -ifoldM'_ m z = discard . Bundle.foldM' (uncurry . m) z . Bundle.indexed . stream - --- | /O(n)/ Monad fold over non-empty vectors with strict accumulator --- that discards the result -fold1M'_ :: (Monad m, Vector v a) => (a -> a -> m a) -> v a -> m () -{-# INLINE fold1M'_ #-} -fold1M'_ m = discard . Bundle.fold1M' m . stream - --- Monadic sequencing --- ------------------ - --- | Evaluate each action and collect the results -sequence :: (Monad m, Vector v a, Vector v (m a)) => v (m a) -> m (v a) -{-# INLINE sequence #-} -sequence = mapM id - --- | Evaluate each action and discard the results -sequence_ :: (Monad m, Vector v (m a)) => v (m a) -> m () -{-# INLINE sequence_ #-} -sequence_ = mapM_ id - --- Prefix sums (scans) --- ------------------- - --- | /O(n)/ Prescan --- --- @ --- prescanl f z = 'init' . 'scanl' f z --- @ --- --- Example: @prescanl (+) 0 \<1,2,3,4\> = \<0,1,3,6\>@ --- -prescanl :: (Vector v a, Vector v b) => (a -> b -> a) -> a -> v b -> v a -{-# INLINE prescanl #-} -prescanl f z = unstream . inplace (S.prescanl f z) id . stream - --- | /O(n)/ Prescan with strict accumulator -prescanl' :: (Vector v a, Vector v b) => (a -> b -> a) -> a -> v b -> v a -{-# INLINE prescanl' #-} -prescanl' f z = unstream . inplace (S.prescanl' f z) id . stream - --- | /O(n)/ Scan --- --- @ --- postscanl f z = 'tail' . 'scanl' f z --- @ --- --- Example: @postscanl (+) 0 \<1,2,3,4\> = \<1,3,6,10\>@ --- -postscanl :: (Vector v a, Vector v b) => (a -> b -> a) -> a -> v b -> v a -{-# INLINE postscanl #-} -postscanl f z = unstream . inplace (S.postscanl f z) id . stream - --- | /O(n)/ Scan with strict accumulator -postscanl' :: (Vector v a, Vector v b) => (a -> b -> a) -> a -> v b -> v a -{-# INLINE postscanl' #-} -postscanl' f z = unstream . inplace (S.postscanl' f z) id . stream - --- | /O(n)/ Haskell-style scan --- --- > scanl f z <x1,...,xn> = <y1,...,y(n+1)> --- > where y1 = z --- > yi = f y(i-1) x(i-1) --- --- Example: @scanl (+) 0 \<1,2,3,4\> = \<0,1,3,6,10\>@ --- -scanl :: (Vector v a, Vector v b) => (a -> b -> a) -> a -> v b -> v a -{-# INLINE scanl #-} -scanl f z = unstream . Bundle.scanl f z . stream - --- | /O(n)/ Haskell-style scan with strict accumulator -scanl' :: (Vector v a, Vector v b) => (a -> b -> a) -> a -> v b -> v a -{-# INLINE scanl' #-} -scanl' f z = unstream . Bundle.scanl' f z . stream - --- | /O(n)/ Scan over a vector with its index -iscanl :: (Vector v a, Vector v b) => (Int -> a -> b -> a) -> a -> v b -> v a -{-# INLINE iscanl #-} -iscanl f z = - unstream - . inplace (S.scanl (\a (i, b) -> f i a b) z . S.indexed) (+1) - . stream - --- | /O(n)/ Scan over a vector (strictly) with its index -iscanl' :: (Vector v a, Vector v b) => (Int -> a -> b -> a) -> a -> v b -> v a -{-# INLINE iscanl' #-} -iscanl' f z = - unstream - . inplace (S.scanl' (\a (i, b) -> f i a b) z . S.indexed) (+1) - . stream - - --- | /O(n)/ Scan over a non-empty vector --- --- > scanl f <x1,...,xn> = <y1,...,yn> --- > where y1 = x1 --- > yi = f y(i-1) xi --- -scanl1 :: Vector v a => (a -> a -> a) -> v a -> v a -{-# INLINE scanl1 #-} -scanl1 f = unstream . inplace (S.scanl1 f) id . stream - --- | /O(n)/ Scan over a non-empty vector with a strict accumulator -scanl1' :: Vector v a => (a -> a -> a) -> v a -> v a -{-# INLINE scanl1' #-} -scanl1' f = unstream . inplace (S.scanl1' f) id . stream - --- | /O(n)/ Right-to-left prescan --- --- @ --- prescanr f z = 'reverse' . 'prescanl' (flip f) z . 'reverse' --- @ --- -prescanr :: (Vector v a, Vector v b) => (a -> b -> b) -> b -> v a -> v b -{-# INLINE prescanr #-} -prescanr f z = unstreamR . inplace (S.prescanl (flip f) z) id . streamR - --- | /O(n)/ Right-to-left prescan with strict accumulator -prescanr' :: (Vector v a, Vector v b) => (a -> b -> b) -> b -> v a -> v b -{-# INLINE prescanr' #-} -prescanr' f z = unstreamR . inplace (S.prescanl' (flip f) z) id . streamR - --- | /O(n)/ Right-to-left scan -postscanr :: (Vector v a, Vector v b) => (a -> b -> b) -> b -> v a -> v b -{-# INLINE postscanr #-} -postscanr f z = unstreamR . inplace (S.postscanl (flip f) z) id . streamR - --- | /O(n)/ Right-to-left scan with strict accumulator -postscanr' :: (Vector v a, Vector v b) => (a -> b -> b) -> b -> v a -> v b -{-# INLINE postscanr' #-} -postscanr' f z = unstreamR . inplace (S.postscanl' (flip f) z) id . streamR - --- | /O(n)/ Right-to-left Haskell-style scan -scanr :: (Vector v a, Vector v b) => (a -> b -> b) -> b -> v a -> v b -{-# INLINE scanr #-} -scanr f z = unstreamR . Bundle.scanl (flip f) z . streamR - --- | /O(n)/ Right-to-left Haskell-style scan with strict accumulator -scanr' :: (Vector v a, Vector v b) => (a -> b -> b) -> b -> v a -> v b -{-# INLINE scanr' #-} -scanr' f z = unstreamR . Bundle.scanl' (flip f) z . streamR - --- | /O(n)/ Right-to-left scan over a vector with its index -iscanr :: (Vector v a, Vector v b) => (Int -> a -> b -> b) -> b -> v a -> v b -{-# INLINE iscanr #-} -iscanr f z v = - unstreamR - . inplace (S.scanl (flip $ uncurry f) z . S.indexedR n) (+1) - . streamR - $ v - where n = length v - --- | /O(n)/ Right-to-left scan over a vector (strictly) with its index -iscanr' :: (Vector v a, Vector v b) => (Int -> a -> b -> b) -> b -> v a -> v b -{-# INLINE iscanr' #-} -iscanr' f z v = - unstreamR - . inplace (S.scanl' (flip $ uncurry f) z . S.indexedR n) (+1) - . streamR - $ v - where n = length v - --- | /O(n)/ Right-to-left scan over a non-empty vector -scanr1 :: Vector v a => (a -> a -> a) -> v a -> v a -{-# INLINE scanr1 #-} -scanr1 f = unstreamR . inplace (S.scanl1 (flip f)) id . streamR - --- | /O(n)/ Right-to-left scan over a non-empty vector with a strict --- accumulator -scanr1' :: Vector v a => (a -> a -> a) -> v a -> v a -{-# INLINE scanr1' #-} -scanr1' f = unstreamR . inplace (S.scanl1' (flip f)) id . streamR - --- Conversions - Lists --- ------------------------ - --- | /O(n)/ Convert a vector to a list -toList :: Vector v a => v a -> [a] -{-# INLINE toList #-} -toList = Bundle.toList . stream - --- | /O(n)/ Convert a list to a vector -fromList :: Vector v a => [a] -> v a -{-# INLINE fromList #-} -fromList = unstream . Bundle.fromList - --- | /O(n)/ Convert the first @n@ elements of a list to a vector --- --- @ --- fromListN n xs = 'fromList' ('take' n xs) --- @ -fromListN :: Vector v a => Int -> [a] -> v a -{-# INLINE fromListN #-} -fromListN n = unstream . Bundle.fromListN n - --- Conversions - Immutable vectors --- ------------------------------- - --- | /O(n)/ Convert different vector types -convert :: (Vector v a, Vector w a) => v a -> w a -{-# INLINE convert #-} -convert = unstream . Bundle.reVector . stream - --- Conversions - Mutable vectors --- ----------------------------- - --- | /O(1)/ Unsafe convert a mutable vector to an immutable one without --- copying. The mutable vector may not be used after this operation. -unsafeFreeze - :: (PrimMonad m, Vector v a) => Mutable v (PrimState m) a -> m (v a) -{-# INLINE unsafeFreeze #-} -unsafeFreeze = basicUnsafeFreeze - --- | /O(n)/ Yield an immutable copy of the mutable vector. -freeze :: (PrimMonad m, Vector v a) => Mutable v (PrimState m) a -> m (v a) -{-# INLINE freeze #-} -freeze mv = unsafeFreeze =<< M.clone mv - --- | /O(1)/ Unsafely convert an immutable vector to a mutable one without --- copying. The immutable vector may not be used after this operation. -unsafeThaw :: (PrimMonad m, Vector v a) => v a -> m (Mutable v (PrimState m) a) -{-# INLINE_FUSED unsafeThaw #-} -unsafeThaw = basicUnsafeThaw - --- | /O(n)/ Yield a mutable copy of the immutable vector. -thaw :: (PrimMonad m, Vector v a) => v a -> m (Mutable v (PrimState m) a) -{-# INLINE_FUSED thaw #-} -thaw v = do - mv <- M.unsafeNew (length v) - unsafeCopy mv v - return mv - -{-# RULES - -"unsafeThaw/new [Vector]" forall p. - unsafeThaw (new p) = New.runPrim p - -"thaw/new [Vector]" forall p. - thaw (new p) = New.runPrim p #-} - - - -{- --- | /O(n)/ Yield a mutable vector containing copies of each vector in the --- list. -thawMany :: (PrimMonad m, Vector v a) => [v a] -> m (Mutable v (PrimState m) a) -{-# INLINE_FUSED thawMany #-} --- FIXME: add rule for (stream (new (New.create (thawMany vs)))) --- NOTE: We don't try to consume the list lazily as this wouldn't significantly --- change the space requirements anyway. -thawMany vs = do - mv <- M.new n - thaw_loop mv vs - return mv - where - n = List.foldl' (\k v -> k + length v) 0 vs - - thaw_loop mv [] = mv `seq` return () - thaw_loop mv (v:vs) - = do - let n = length v - unsafeCopy (M.unsafeTake n mv) v - thaw_loop (M.unsafeDrop n mv) vs --} - --- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must --- have the same length. -copy - :: (PrimMonad m, Vector v a) => Mutable v (PrimState m) a -> v a -> m () -{-# INLINE copy #-} -copy dst src = BOUNDS_CHECK(check) "copy" "length mismatch" - (M.length dst == length src) - $ unsafeCopy dst src - --- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must --- have the same length. This is not checked. -unsafeCopy - :: (PrimMonad m, Vector v a) => Mutable v (PrimState m) a -> v a -> m () -{-# INLINE unsafeCopy #-} -unsafeCopy dst src = UNSAFE_CHECK(check) "unsafeCopy" "length mismatch" - (M.length dst == length src) - $ (dst `seq` src `seq` basicUnsafeCopy dst src) - --- Conversions to/from Bundles --- --------------------------- - --- | /O(1)/ Convert a vector to a 'Bundle' -stream :: Vector v a => v a -> Bundle v a -{-# INLINE_FUSED stream #-} -stream v = stream' v - --- Same as 'stream', but can be used to avoid having a cycle in the dependency --- graph of functions, which forces GHC to create a loop breaker. -stream' :: Vector v a => v a -> Bundle v a -{-# INLINE stream' #-} -stream' v = Bundle.fromVector v - -{- -stream v = v `seq` n `seq` (Bundle.unfoldr get 0 `Bundle.sized` Exact n) - where - n = length v - - -- NOTE: the False case comes first in Core so making it the recursive one - -- makes the code easier to read - {-# INLINE get #-} - get i | i >= n = Nothing - | otherwise = case basicUnsafeIndexM v i of Box x -> Just (x, i+1) --} - --- | /O(n)/ Construct a vector from a 'Bundle' -unstream :: Vector v a => Bundle v a -> v a -{-# INLINE unstream #-} -unstream s = new (New.unstream s) - -{-# RULES - -"stream/unstream [Vector]" forall s. - stream (new (New.unstream s)) = s - -"New.unstream/stream [Vector]" forall v. - New.unstream (stream v) = clone v - -"clone/new [Vector]" forall p. - clone (new p) = p - -"inplace [Vector]" - forall (f :: forall m. Monad m => Stream m a -> Stream m a) g m. - New.unstream (inplace f g (stream (new m))) = New.transform f g m - -"uninplace [Vector]" - forall (f :: forall m. Monad m => Stream m a -> Stream m a) g m. - stream (new (New.transform f g m)) = inplace f g (stream (new m)) #-} - - - --- | /O(1)/ Convert a vector to a 'Bundle', proceeding from right to left -streamR :: Vector v a => v a -> Bundle u a -{-# INLINE_FUSED streamR #-} -streamR v = v `seq` n `seq` (Bundle.unfoldr get n `Bundle.sized` Exact n) - where - n = length v - - {-# INLINE get #-} - get 0 = Nothing - get i = let i' = i-1 - in - case basicUnsafeIndexM v i' of Box x -> Just (x, i') - --- | /O(n)/ Construct a vector from a 'Bundle', proceeding from right to left -unstreamR :: Vector v a => Bundle v a -> v a -{-# INLINE unstreamR #-} -unstreamR s = new (New.unstreamR s) - -{-# RULES - -"streamR/unstreamR [Vector]" forall s. - streamR (new (New.unstreamR s)) = s - -"New.unstreamR/streamR/new [Vector]" forall p. - New.unstreamR (streamR (new p)) = p - -"New.unstream/streamR/new [Vector]" forall p. - New.unstream (streamR (new p)) = New.modify M.reverse p - -"New.unstreamR/stream/new [Vector]" forall p. - New.unstreamR (stream (new p)) = New.modify M.reverse p - -"inplace right [Vector]" - forall (f :: forall m. Monad m => Stream m a -> Stream m a) g m. - New.unstreamR (inplace f g (streamR (new m))) = New.transformR f g m - -"uninplace right [Vector]" - forall (f :: forall m. Monad m => Stream m a -> Stream m a) g m. - streamR (new (New.transformR f g m)) = inplace f g (streamR (new m)) #-} - - - -unstreamM :: (Monad m, Vector v a) => MBundle m u a -> m (v a) -{-# INLINE_FUSED unstreamM #-} -unstreamM s = do - xs <- MBundle.toList s - return $ unstream $ Bundle.unsafeFromList (MBundle.size s) xs - -unstreamPrimM :: (PrimMonad m, Vector v a) => MBundle m u a -> m (v a) -{-# INLINE_FUSED unstreamPrimM #-} -unstreamPrimM s = M.munstream s >>= unsafeFreeze - --- FIXME: the next two functions are only necessary for the specialisations -unstreamPrimM_IO :: Vector v a => MBundle IO u a -> IO (v a) -{-# INLINE unstreamPrimM_IO #-} -unstreamPrimM_IO = unstreamPrimM - -unstreamPrimM_ST :: Vector v a => MBundle (ST s) u a -> ST s (v a) -{-# INLINE unstreamPrimM_ST #-} -unstreamPrimM_ST = unstreamPrimM - -{-# RULES - -"unstreamM[IO]" unstreamM = unstreamPrimM_IO -"unstreamM[ST]" unstreamM = unstreamPrimM_ST #-} - - - - --- Recycling support --- ----------------- - --- | Construct a vector from a monadic initialiser. -new :: Vector v a => New v a -> v a -{-# INLINE_FUSED new #-} -new m = m `seq` runST (unsafeFreeze =<< New.run m) - --- | Convert a vector to an initialiser which, when run, produces a copy of --- the vector. -clone :: Vector v a => v a -> New v a -{-# INLINE_FUSED clone #-} -clone v = v `seq` New.create ( - do - mv <- M.new (length v) - unsafeCopy mv v - return mv) - --- Comparisons --- ----------- - --- | /O(n)/ Check if two vectors are equal. All 'Vector' instances are also --- instances of 'Eq' and it is usually more appropriate to use those. This --- function is primarily intended for implementing 'Eq' instances for new --- vector types. -eq :: (Vector v a, Eq a) => v a -> v a -> Bool -{-# INLINE eq #-} -xs `eq` ys = stream xs == stream ys - --- | /O(n)/ -eqBy :: (Vector v a, Vector v b) => (a -> b -> Bool) -> v a -> v b -> Bool -{-# INLINE eqBy #-} -eqBy e xs ys = Bundle.eqBy e (stream xs) (stream ys) - --- | /O(n)/ Compare two vectors lexicographically. All 'Vector' instances are --- also instances of 'Ord' and it is usually more appropriate to use those. This --- function is primarily intended for implementing 'Ord' instances for new --- vector types. -cmp :: (Vector v a, Ord a) => v a -> v a -> Ordering -{-# INLINE cmp #-} -cmp xs ys = compare (stream xs) (stream ys) - --- | /O(n)/ -cmpBy :: (Vector v a, Vector v b) => (a -> b -> Ordering) -> v a -> v b -> Ordering -cmpBy c xs ys = Bundle.cmpBy c (stream xs) (stream ys) - --- Show --- ---- - --- | Generic definition of 'Prelude.showsPrec' -showsPrec :: (Vector v a, Show a) => Int -> v a -> ShowS -{-# INLINE showsPrec #-} -showsPrec _ = shows . toList - -liftShowsPrec :: (Vector v a) => (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> v a -> ShowS -{-# INLINE liftShowsPrec #-} -liftShowsPrec _ s _ = s . toList - --- | Generic definition of 'Text.Read.readPrec' -readPrec :: (Vector v a, Read a) => Read.ReadPrec (v a) -{-# INLINE readPrec #-} -readPrec = do - xs <- Read.readPrec - return (fromList xs) - --- | /Note:/ uses 'ReadS' -liftReadsPrec :: (Vector v a) => (Int -> Read.ReadS a) -> ReadS [a] -> Int -> Read.ReadS (v a) -liftReadsPrec _ r _ s = [ (fromList v, s') | (v, s') <- r s ] - --- Data and Typeable --- ----------------- - --- | Generic definion of 'Data.Data.gfoldl' that views a 'Vector' as a --- list. -gfoldl :: (Vector v a, Data a) - => (forall d b. Data d => c (d -> b) -> d -> c b) - -> (forall g. g -> c g) - -> v a - -> c (v a) -{-# INLINE gfoldl #-} -gfoldl f z v = z fromList `f` toList v - -mkType :: String -> DataType -{-# INLINE mkType #-} -mkType = mkNoRepType - -#if __GLASGOW_HASKELL__ >= 707 -dataCast :: (Vector v a, Data a, Typeable v, Typeable t) -#else -dataCast :: (Vector v a, Data a, Typeable1 v, Typeable1 t) -#endif - => (forall d. Data d => c (t d)) -> Maybe (c (v a)) -{-# INLINE dataCast #-} -dataCast f = gcast1 f diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/Base.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/Base.hs deleted file mode 100644 index a760329c599f..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/Base.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# LANGUAGE Rank2Types, MultiParamTypeClasses, FlexibleContexts, - TypeFamilies, ScopedTypeVariables, BangPatterns #-} -{-# OPTIONS_HADDOCK hide #-} - --- | --- Module : Data.Vector.Generic.Base --- Copyright : (c) Roman Leshchinskiy 2008-2010 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Stability : experimental --- Portability : non-portable --- --- Class of pure vectors --- - -module Data.Vector.Generic.Base ( - Vector(..), Mutable -) where - -import Data.Vector.Generic.Mutable.Base ( MVector ) -import qualified Data.Vector.Generic.Mutable.Base as M - -import Control.Monad.Primitive - --- | @Mutable v s a@ is the mutable version of the pure vector type @v a@ with --- the state token @s@ --- -type family Mutable (v :: * -> *) :: * -> * -> * - --- | Class of immutable vectors. Every immutable vector is associated with its --- mutable version through the 'Mutable' type family. Methods of this class --- should not be used directly. Instead, "Data.Vector.Generic" and other --- Data.Vector modules provide safe and fusible wrappers. --- --- Minimum complete implementation: --- --- * 'basicUnsafeFreeze' --- --- * 'basicUnsafeThaw' --- --- * 'basicLength' --- --- * 'basicUnsafeSlice' --- --- * 'basicUnsafeIndexM' --- -class MVector (Mutable v) a => Vector v a where - -- | /Assumed complexity: O(1)/ - -- - -- Unsafely convert a mutable vector to its immutable version - -- without copying. The mutable vector may not be used after - -- this operation. - basicUnsafeFreeze :: PrimMonad m => Mutable v (PrimState m) a -> m (v a) - - -- | /Assumed complexity: O(1)/ - -- - -- Unsafely convert an immutable vector to its mutable version without - -- copying. The immutable vector may not be used after this operation. - basicUnsafeThaw :: PrimMonad m => v a -> m (Mutable v (PrimState m) a) - - -- | /Assumed complexity: O(1)/ - -- - -- Yield the length of the vector. - basicLength :: v a -> Int - - -- | /Assumed complexity: O(1)/ - -- - -- Yield a slice of the vector without copying it. No range checks are - -- performed. - basicUnsafeSlice :: Int -- ^ starting index - -> Int -- ^ length - -> v a -> v a - - -- | /Assumed complexity: O(1)/ - -- - -- Yield the element at the given position in a monad. No range checks are - -- performed. - -- - -- The monad allows us to be strict in the vector if we want. Suppose we had - -- - -- > unsafeIndex :: v a -> Int -> a - -- - -- instead. Now, if we wanted to copy a vector, we'd do something like - -- - -- > copy mv v ... = ... unsafeWrite mv i (unsafeIndex v i) ... - -- - -- For lazy vectors, the indexing would not be evaluated which means that we - -- would retain a reference to the original vector in each element we write. - -- This is not what we want! - -- - -- With 'basicUnsafeIndexM', we can do - -- - -- > copy mv v ... = ... case basicUnsafeIndexM v i of - -- > Box x -> unsafeWrite mv i x ... - -- - -- which does not have this problem because indexing (but not the returned - -- element!) is evaluated immediately. - -- - basicUnsafeIndexM :: Monad m => v a -> Int -> m a - - -- | /Assumed complexity: O(n)/ - -- - -- Copy an immutable vector into a mutable one. The two vectors must have - -- the same length but this is not checked. - -- - -- Instances of 'Vector' should redefine this method if they wish to support - -- an efficient block copy operation. - -- - -- Default definition: copying basic on 'basicUnsafeIndexM' and - -- 'basicUnsafeWrite'. - basicUnsafeCopy :: PrimMonad m => Mutable v (PrimState m) a -> v a -> m () - - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy !dst !src = do_copy 0 - where - !n = basicLength src - - do_copy i | i < n = do - x <- basicUnsafeIndexM src i - M.basicUnsafeWrite dst i x - do_copy (i+1) - | otherwise = return () - - -- | Evaluate @a@ as far as storing it in a vector would and yield @b@. - -- The @v a@ argument only fixes the type and is not touched. The method is - -- only used for optimisation purposes. Thus, it is safe for instances of - -- 'Vector' to evaluate @a@ less than it would be when stored in a vector - -- although this might result in suboptimal code. - -- - -- > elemseq v x y = (singleton x `asTypeOf` v) `seq` y - -- - -- Default defintion: @a@ is not evaluated at all - -- - elemseq :: v a -> a -> b -> b - - {-# INLINE elemseq #-} - elemseq _ = \_ x -> x - - diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/Mutable.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/Mutable.hs deleted file mode 100644 index 89bebf360765..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/Mutable.hs +++ /dev/null @@ -1,1034 +0,0 @@ -{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleContexts, BangPatterns, TypeFamilies, ScopedTypeVariables #-} --- | --- Module : Data.Vector.Generic.Mutable --- Copyright : (c) Roman Leshchinskiy 2008-2010 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Stability : experimental --- Portability : non-portable --- --- Generic interface to mutable vectors --- - -module Data.Vector.Generic.Mutable ( - -- * Class of mutable vector types - MVector(..), - - -- * Accessors - - -- ** Length information - length, null, - - -- ** Extracting subvectors - slice, init, tail, take, drop, splitAt, - unsafeSlice, unsafeInit, unsafeTail, unsafeTake, unsafeDrop, - - -- ** Overlapping - overlaps, - - -- * Construction - - -- ** Initialisation - new, unsafeNew, replicate, replicateM, clone, - - -- ** Growing - grow, unsafeGrow, - growFront, unsafeGrowFront, - - -- ** Restricting memory usage - clear, - - -- * Accessing individual elements - read, write, modify, swap, exchange, - unsafeRead, unsafeWrite, unsafeModify, unsafeSwap, unsafeExchange, - - -- * Modifying vectors - nextPermutation, - - -- ** Filling and copying - set, copy, move, unsafeCopy, unsafeMove, - - -- * Internal operations - mstream, mstreamR, - unstream, unstreamR, vunstream, - munstream, munstreamR, - transform, transformR, - fill, fillR, - unsafeAccum, accum, unsafeUpdate, update, reverse, - unstablePartition, unstablePartitionBundle, partitionBundle -) where - -import Data.Vector.Generic.Mutable.Base -import qualified Data.Vector.Generic.Base as V - -import qualified Data.Vector.Fusion.Bundle as Bundle -import Data.Vector.Fusion.Bundle ( Bundle, MBundle, Chunk(..) ) -import qualified Data.Vector.Fusion.Bundle.Monadic as MBundle -import Data.Vector.Fusion.Stream.Monadic ( Stream ) -import qualified Data.Vector.Fusion.Stream.Monadic as Stream -import Data.Vector.Fusion.Bundle.Size -import Data.Vector.Fusion.Util ( delay_inline ) - -import Control.Monad.Primitive ( PrimMonad, PrimState ) - -import Prelude hiding ( length, null, replicate, reverse, map, read, - take, drop, splitAt, init, tail ) - -#include "vector.h" - -{- -type family Immutable (v :: * -> * -> *) :: * -> * - --- | Class of mutable vectors parametrised with a primitive state token. --- -class MBundle.Pointer u a => MVector v a where - -- | Length of the mutable vector. This method should not be - -- called directly, use 'length' instead. - basicLength :: v s a -> Int - - -- | Yield a part of the mutable vector without copying it. This method - -- should not be called directly, use 'unsafeSlice' instead. - basicUnsafeSlice :: Int -- ^ starting index - -> Int -- ^ length of the slice - -> v s a - -> v s a - - -- Check whether two vectors overlap. This method should not be - -- called directly, use 'overlaps' instead. - basicOverlaps :: v s a -> v s a -> Bool - - -- | Create a mutable vector of the given length. This method should not be - -- called directly, use 'unsafeNew' instead. - basicUnsafeNew :: PrimMonad m => Int -> m (v (PrimState m) a) - - -- | Create a mutable vector of the given length and fill it with an - -- initial value. This method should not be called directly, use - -- 'replicate' instead. - basicUnsafeReplicate :: PrimMonad m => Int -> a -> m (v (PrimState m) a) - - -- | Yield the element at the given position. This method should not be - -- called directly, use 'unsafeRead' instead. - basicUnsafeRead :: PrimMonad m => v (PrimState m) a -> Int -> m a - - -- | Replace the element at the given position. This method should not be - -- called directly, use 'unsafeWrite' instead. - basicUnsafeWrite :: PrimMonad m => v (PrimState m) a -> Int -> a -> m () - - -- | Reset all elements of the vector to some undefined value, clearing all - -- references to external objects. This is usually a noop for unboxed - -- vectors. This method should not be called directly, use 'clear' instead. - basicClear :: PrimMonad m => v (PrimState m) a -> m () - - -- | Set all elements of the vector to the given value. This method should - -- not be called directly, use 'set' instead. - basicSet :: PrimMonad m => v (PrimState m) a -> a -> m () - - basicUnsafeCopyPointer :: PrimMonad m => v (PrimState m) a - -> Immutable v a - -> m () - - -- | Copy a vector. The two vectors may not overlap. This method should not - -- be called directly, use 'unsafeCopy' instead. - basicUnsafeCopy :: PrimMonad m => v (PrimState m) a -- ^ target - -> v (PrimState m) a -- ^ source - -> m () - - -- | Move the contents of a vector. The two vectors may overlap. This method - -- should not be called directly, use 'unsafeMove' instead. - basicUnsafeMove :: PrimMonad m => v (PrimState m) a -- ^ target - -> v (PrimState m) a -- ^ source - -> m () - - -- | Grow a vector by the given number of elements. This method should not be - -- called directly, use 'unsafeGrow' instead. - basicUnsafeGrow :: PrimMonad m => v (PrimState m) a -> Int - -> m (v (PrimState m) a) - - {-# INLINE basicUnsafeReplicate #-} - basicUnsafeReplicate n x - = do - v <- basicUnsafeNew n - basicSet v x - return v - - {-# INLINE basicClear #-} - basicClear _ = return () - - {-# INLINE basicSet #-} - basicSet !v x - | n == 0 = return () - | otherwise = do - basicUnsafeWrite v 0 x - do_set 1 - where - !n = basicLength v - - do_set i | 2*i < n = do basicUnsafeCopy (basicUnsafeSlice i i v) - (basicUnsafeSlice 0 i v) - do_set (2*i) - | otherwise = basicUnsafeCopy (basicUnsafeSlice i (n-i) v) - (basicUnsafeSlice 0 (n-i) v) - - {-# INLINE basicUnsafeCopyPointer #-} - basicUnsafeCopyPointer !dst !src = do_copy 0 src - where - do_copy !i p | Just (x,q) <- MBundle.pget p = do - basicUnsafeWrite dst i x - do_copy (i+1) q - | otherwise = return () - - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy !dst !src = do_copy 0 - where - !n = basicLength src - - do_copy i | i < n = do - x <- basicUnsafeRead src i - basicUnsafeWrite dst i x - do_copy (i+1) - | otherwise = return () - - {-# INLINE basicUnsafeMove #-} - basicUnsafeMove !dst !src - | basicOverlaps dst src = do - srcCopy <- clone src - basicUnsafeCopy dst srcCopy - | otherwise = basicUnsafeCopy dst src - - {-# INLINE basicUnsafeGrow #-} - basicUnsafeGrow v by - = do - v' <- basicUnsafeNew (n+by) - basicUnsafeCopy (basicUnsafeSlice 0 n v') v - return v' - where - n = basicLength v --} - --- ------------------ --- Internal functions --- ------------------ - -unsafeAppend1 :: (PrimMonad m, MVector v a) - => v (PrimState m) a -> Int -> a -> m (v (PrimState m) a) -{-# INLINE_INNER unsafeAppend1 #-} - -- NOTE: The case distinction has to be on the outside because - -- GHC creates a join point for the unsafeWrite even when everything - -- is inlined. This is bad because with the join point, v isn't getting - -- unboxed. -unsafeAppend1 v i x - | i < length v = do - unsafeWrite v i x - return v - | otherwise = do - v' <- enlarge v - INTERNAL_CHECK(checkIndex) "unsafeAppend1" i (length v') - $ unsafeWrite v' i x - return v' - -unsafePrepend1 :: (PrimMonad m, MVector v a) - => v (PrimState m) a -> Int -> a -> m (v (PrimState m) a, Int) -{-# INLINE_INNER unsafePrepend1 #-} -unsafePrepend1 v i x - | i /= 0 = do - let i' = i-1 - unsafeWrite v i' x - return (v, i') - | otherwise = do - (v', j) <- enlargeFront v - let i' = j-1 - INTERNAL_CHECK(checkIndex) "unsafePrepend1" i' (length v') - $ unsafeWrite v' i' x - return (v', i') - -mstream :: (PrimMonad m, MVector v a) => v (PrimState m) a -> Stream m a -{-# INLINE mstream #-} -mstream v = v `seq` n `seq` (Stream.unfoldrM get 0) - where - n = length v - - {-# INLINE_INNER get #-} - get i | i < n = do x <- unsafeRead v i - return $ Just (x, i+1) - | otherwise = return $ Nothing - -fill :: (PrimMonad m, MVector v a) - => v (PrimState m) a -> Stream m a -> m (v (PrimState m) a) -{-# INLINE fill #-} -fill v s = v `seq` do - n' <- Stream.foldM put 0 s - return $ unsafeSlice 0 n' v - where - {-# INLINE_INNER put #-} - put i x = do - INTERNAL_CHECK(checkIndex) "fill" i (length v) - $ unsafeWrite v i x - return (i+1) - -transform - :: (PrimMonad m, MVector v a) - => (Stream m a -> Stream m a) -> v (PrimState m) a -> m (v (PrimState m) a) -{-# INLINE_FUSED transform #-} -transform f v = fill v (f (mstream v)) - -mstreamR :: (PrimMonad m, MVector v a) => v (PrimState m) a -> Stream m a -{-# INLINE mstreamR #-} -mstreamR v = v `seq` n `seq` (Stream.unfoldrM get n) - where - n = length v - - {-# INLINE_INNER get #-} - get i | j >= 0 = do x <- unsafeRead v j - return $ Just (x,j) - | otherwise = return Nothing - where - j = i-1 - -fillR :: (PrimMonad m, MVector v a) - => v (PrimState m) a -> Stream m a -> m (v (PrimState m) a) -{-# INLINE fillR #-} -fillR v s = v `seq` do - i <- Stream.foldM put n s - return $ unsafeSlice i (n-i) v - where - n = length v - - {-# INLINE_INNER put #-} - put i x = do - unsafeWrite v j x - return j - where - j = i-1 - -transformR - :: (PrimMonad m, MVector v a) - => (Stream m a -> Stream m a) -> v (PrimState m) a -> m (v (PrimState m) a) -{-# INLINE_FUSED transformR #-} -transformR f v = fillR v (f (mstreamR v)) - --- | Create a new mutable vector and fill it with elements from the 'Bundle'. --- The vector will grow exponentially if the maximum size of the 'Bundle' is --- unknown. -unstream :: (PrimMonad m, MVector v a) - => Bundle u a -> m (v (PrimState m) a) --- NOTE: replace INLINE_FUSED by INLINE? (also in unstreamR) -{-# INLINE_FUSED unstream #-} -unstream s = munstream (Bundle.lift s) - --- | Create a new mutable vector and fill it with elements from the monadic --- stream. The vector will grow exponentially if the maximum size of the stream --- is unknown. -munstream :: (PrimMonad m, MVector v a) - => MBundle m u a -> m (v (PrimState m) a) -{-# INLINE_FUSED munstream #-} -munstream s = case upperBound (MBundle.size s) of - Just n -> munstreamMax s n - Nothing -> munstreamUnknown s - --- FIXME: I can't think of how to prevent GHC from floating out --- unstreamUnknown. That is bad because SpecConstr then generates two --- specialisations: one for when it is called from unstream (it doesn't know --- the shape of the vector) and one for when the vector has grown. To see the --- problem simply compile this: --- --- fromList = Data.Vector.Unboxed.unstream . Bundle.fromList --- --- I'm not sure this still applies (19/04/2010) - -munstreamMax :: (PrimMonad m, MVector v a) - => MBundle m u a -> Int -> m (v (PrimState m) a) -{-# INLINE munstreamMax #-} -munstreamMax s n - = do - v <- INTERNAL_CHECK(checkLength) "munstreamMax" n - $ unsafeNew n - let put i x = do - INTERNAL_CHECK(checkIndex) "munstreamMax" i n - $ unsafeWrite v i x - return (i+1) - n' <- MBundle.foldM' put 0 s - return $ INTERNAL_CHECK(checkSlice) "munstreamMax" 0 n' n - $ unsafeSlice 0 n' v - -munstreamUnknown :: (PrimMonad m, MVector v a) - => MBundle m u a -> m (v (PrimState m) a) -{-# INLINE munstreamUnknown #-} -munstreamUnknown s - = do - v <- unsafeNew 0 - (v', n) <- MBundle.foldM put (v, 0) s - return $ INTERNAL_CHECK(checkSlice) "munstreamUnknown" 0 n (length v') - $ unsafeSlice 0 n v' - where - {-# INLINE_INNER put #-} - put (v,i) x = do - v' <- unsafeAppend1 v i x - return (v',i+1) - - - - - - - --- | Create a new mutable vector and fill it with elements from the 'Bundle'. --- The vector will grow exponentially if the maximum size of the 'Bundle' is --- unknown. -vunstream :: (PrimMonad m, V.Vector v a) - => Bundle v a -> m (V.Mutable v (PrimState m) a) --- NOTE: replace INLINE_FUSED by INLINE? (also in unstreamR) -{-# INLINE_FUSED vunstream #-} -vunstream s = vmunstream (Bundle.lift s) - --- | Create a new mutable vector and fill it with elements from the monadic --- stream. The vector will grow exponentially if the maximum size of the stream --- is unknown. -vmunstream :: (PrimMonad m, V.Vector v a) - => MBundle m v a -> m (V.Mutable v (PrimState m) a) -{-# INLINE_FUSED vmunstream #-} -vmunstream s = case upperBound (MBundle.size s) of - Just n -> vmunstreamMax s n - Nothing -> vmunstreamUnknown s - --- FIXME: I can't think of how to prevent GHC from floating out --- unstreamUnknown. That is bad because SpecConstr then generates two --- specialisations: one for when it is called from unstream (it doesn't know --- the shape of the vector) and one for when the vector has grown. To see the --- problem simply compile this: --- --- fromList = Data.Vector.Unboxed.unstream . Bundle.fromList --- --- I'm not sure this still applies (19/04/2010) - -vmunstreamMax :: (PrimMonad m, V.Vector v a) - => MBundle m v a -> Int -> m (V.Mutable v (PrimState m) a) -{-# INLINE vmunstreamMax #-} -vmunstreamMax s n - = do - v <- INTERNAL_CHECK(checkLength) "munstreamMax" n - $ unsafeNew n - let {-# INLINE_INNER copyChunk #-} - copyChunk i (Chunk m f) = - INTERNAL_CHECK(checkSlice) "munstreamMax.copyChunk" i m (length v) $ do - f (basicUnsafeSlice i m v) - return (i+m) - - n' <- Stream.foldlM' copyChunk 0 (MBundle.chunks s) - return $ INTERNAL_CHECK(checkSlice) "munstreamMax" 0 n' n - $ unsafeSlice 0 n' v - -vmunstreamUnknown :: (PrimMonad m, V.Vector v a) - => MBundle m v a -> m (V.Mutable v (PrimState m) a) -{-# INLINE vmunstreamUnknown #-} -vmunstreamUnknown s - = do - v <- unsafeNew 0 - (v', n) <- Stream.foldlM copyChunk (v,0) (MBundle.chunks s) - return $ INTERNAL_CHECK(checkSlice) "munstreamUnknown" 0 n (length v') - $ unsafeSlice 0 n v' - where - {-# INLINE_INNER copyChunk #-} - copyChunk (v,i) (Chunk n f) - = do - let j = i+n - v' <- if basicLength v < j - then unsafeGrow v (delay_inline max (enlarge_delta v) (j - basicLength v)) - else return v - INTERNAL_CHECK(checkSlice) "munstreamUnknown.copyChunk" i n (length v') - $ f (basicUnsafeSlice i n v') - return (v',j) - - - - --- | Create a new mutable vector and fill it with elements from the 'Bundle' --- from right to left. The vector will grow exponentially if the maximum size --- of the 'Bundle' is unknown. -unstreamR :: (PrimMonad m, MVector v a) - => Bundle u a -> m (v (PrimState m) a) --- NOTE: replace INLINE_FUSED by INLINE? (also in unstream) -{-# INLINE_FUSED unstreamR #-} -unstreamR s = munstreamR (Bundle.lift s) - --- | Create a new mutable vector and fill it with elements from the monadic --- stream from right to left. The vector will grow exponentially if the maximum --- size of the stream is unknown. -munstreamR :: (PrimMonad m, MVector v a) - => MBundle m u a -> m (v (PrimState m) a) -{-# INLINE_FUSED munstreamR #-} -munstreamR s = case upperBound (MBundle.size s) of - Just n -> munstreamRMax s n - Nothing -> munstreamRUnknown s - -munstreamRMax :: (PrimMonad m, MVector v a) - => MBundle m u a -> Int -> m (v (PrimState m) a) -{-# INLINE munstreamRMax #-} -munstreamRMax s n - = do - v <- INTERNAL_CHECK(checkLength) "munstreamRMax" n - $ unsafeNew n - let put i x = do - let i' = i-1 - INTERNAL_CHECK(checkIndex) "munstreamRMax" i' n - $ unsafeWrite v i' x - return i' - i <- MBundle.foldM' put n s - return $ INTERNAL_CHECK(checkSlice) "munstreamRMax" i (n-i) n - $ unsafeSlice i (n-i) v - -munstreamRUnknown :: (PrimMonad m, MVector v a) - => MBundle m u a -> m (v (PrimState m) a) -{-# INLINE munstreamRUnknown #-} -munstreamRUnknown s - = do - v <- unsafeNew 0 - (v', i) <- MBundle.foldM put (v, 0) s - let n = length v' - return $ INTERNAL_CHECK(checkSlice) "unstreamRUnknown" i (n-i) n - $ unsafeSlice i (n-i) v' - where - {-# INLINE_INNER put #-} - put (v,i) x = unsafePrepend1 v i x - --- Length --- ------ - --- | Length of the mutable vector. -length :: MVector v a => v s a -> Int -{-# INLINE length #-} -length = basicLength - --- | Check whether the vector is empty -null :: MVector v a => v s a -> Bool -{-# INLINE null #-} -null v = length v == 0 - --- Extracting subvectors --- --------------------- - --- | Yield a part of the mutable vector without copying it. -slice :: MVector v a => Int -> Int -> v s a -> v s a -{-# INLINE slice #-} -slice i n v = BOUNDS_CHECK(checkSlice) "slice" i n (length v) - $ unsafeSlice i n v - -take :: MVector v a => Int -> v s a -> v s a -{-# INLINE take #-} -take n v = unsafeSlice 0 (min (max n 0) (length v)) v - -drop :: MVector v a => Int -> v s a -> v s a -{-# INLINE drop #-} -drop n v = unsafeSlice (min m n') (max 0 (m - n')) v - where - n' = max n 0 - m = length v - -{-# INLINE splitAt #-} -splitAt :: MVector v a => Int -> v s a -> (v s a, v s a) -splitAt n v = ( unsafeSlice 0 m v - , unsafeSlice m (max 0 (len - n')) v - ) - where - m = min n' len - n' = max n 0 - len = length v - -init :: MVector v a => v s a -> v s a -{-# INLINE init #-} -init v = slice 0 (length v - 1) v - -tail :: MVector v a => v s a -> v s a -{-# INLINE tail #-} -tail v = slice 1 (length v - 1) v - --- | Yield a part of the mutable vector without copying it. No bounds checks --- are performed. -unsafeSlice :: MVector v a => Int -- ^ starting index - -> Int -- ^ length of the slice - -> v s a - -> v s a -{-# INLINE unsafeSlice #-} -unsafeSlice i n v = UNSAFE_CHECK(checkSlice) "unsafeSlice" i n (length v) - $ basicUnsafeSlice i n v - -unsafeInit :: MVector v a => v s a -> v s a -{-# INLINE unsafeInit #-} -unsafeInit v = unsafeSlice 0 (length v - 1) v - -unsafeTail :: MVector v a => v s a -> v s a -{-# INLINE unsafeTail #-} -unsafeTail v = unsafeSlice 1 (length v - 1) v - -unsafeTake :: MVector v a => Int -> v s a -> v s a -{-# INLINE unsafeTake #-} -unsafeTake n v = unsafeSlice 0 n v - -unsafeDrop :: MVector v a => Int -> v s a -> v s a -{-# INLINE unsafeDrop #-} -unsafeDrop n v = unsafeSlice n (length v - n) v - --- Overlapping --- ----------- - --- | Check whether two vectors overlap. -overlaps :: MVector v a => v s a -> v s a -> Bool -{-# INLINE overlaps #-} -overlaps = basicOverlaps - --- Initialisation --- -------------- - --- | Create a mutable vector of the given length. -new :: (PrimMonad m, MVector v a) => Int -> m (v (PrimState m) a) -{-# INLINE new #-} -new n = BOUNDS_CHECK(checkLength) "new" n - $ unsafeNew n >>= \v -> basicInitialize v >> return v - --- | Create a mutable vector of the given length. The memory is not initialized. -unsafeNew :: (PrimMonad m, MVector v a) => Int -> m (v (PrimState m) a) -{-# INLINE unsafeNew #-} -unsafeNew n = UNSAFE_CHECK(checkLength) "unsafeNew" n - $ basicUnsafeNew n - --- | Create a mutable vector of the given length (0 if the length is negative) --- and fill it with an initial value. -replicate :: (PrimMonad m, MVector v a) => Int -> a -> m (v (PrimState m) a) -{-# INLINE replicate #-} -replicate n x = basicUnsafeReplicate (delay_inline max 0 n) x - --- | Create a mutable vector of the given length (0 if the length is negative) --- and fill it with values produced by repeatedly executing the monadic action. -replicateM :: (PrimMonad m, MVector v a) => Int -> m a -> m (v (PrimState m) a) -{-# INLINE replicateM #-} -replicateM n m = munstream (MBundle.replicateM n m) - --- | Create a copy of a mutable vector. -clone :: (PrimMonad m, MVector v a) => v (PrimState m) a -> m (v (PrimState m) a) -{-# INLINE clone #-} -clone v = do - v' <- unsafeNew (length v) - unsafeCopy v' v - return v' - --- Growing --- ------- - --- | Grow a vector by the given number of elements. The number must be --- positive. -grow :: (PrimMonad m, MVector v a) - => v (PrimState m) a -> Int -> m (v (PrimState m) a) -{-# INLINE grow #-} -grow v by = BOUNDS_CHECK(checkLength) "grow" by - $ do vnew <- unsafeGrow v by - basicInitialize $ basicUnsafeSlice (length v) by vnew - return vnew - -growFront :: (PrimMonad m, MVector v a) - => v (PrimState m) a -> Int -> m (v (PrimState m) a) -{-# INLINE growFront #-} -growFront v by = BOUNDS_CHECK(checkLength) "growFront" by - $ do vnew <- unsafeGrowFront v by - basicInitialize $ basicUnsafeSlice 0 by vnew - return vnew - -enlarge_delta :: MVector v a => v s a -> Int -enlarge_delta v = max (length v) 1 - --- | Grow a vector logarithmically -enlarge :: (PrimMonad m, MVector v a) - => v (PrimState m) a -> m (v (PrimState m) a) -{-# INLINE enlarge #-} -enlarge v = do vnew <- unsafeGrow v by - basicInitialize $ basicUnsafeSlice (length v) by vnew - return vnew - where - by = enlarge_delta v - -enlargeFront :: (PrimMonad m, MVector v a) - => v (PrimState m) a -> m (v (PrimState m) a, Int) -{-# INLINE enlargeFront #-} -enlargeFront v = do - v' <- unsafeGrowFront v by - basicInitialize $ basicUnsafeSlice 0 by v' - return (v', by) - where - by = enlarge_delta v - --- | Grow a vector by the given number of elements. The number must be --- positive but this is not checked. -unsafeGrow :: (PrimMonad m, MVector v a) - => v (PrimState m) a -> Int -> m (v (PrimState m) a) -{-# INLINE unsafeGrow #-} -unsafeGrow v n = UNSAFE_CHECK(checkLength) "unsafeGrow" n - $ basicUnsafeGrow v n - -unsafeGrowFront :: (PrimMonad m, MVector v a) - => v (PrimState m) a -> Int -> m (v (PrimState m) a) -{-# INLINE unsafeGrowFront #-} -unsafeGrowFront v by = UNSAFE_CHECK(checkLength) "unsafeGrowFront" by - $ do - let n = length v - v' <- basicUnsafeNew (by+n) - basicUnsafeCopy (basicUnsafeSlice by n v') v - return v' - --- Restricting memory usage --- ------------------------ - --- | Reset all elements of the vector to some undefined value, clearing all --- references to external objects. This is usually a noop for unboxed vectors. -clear :: (PrimMonad m, MVector v a) => v (PrimState m) a -> m () -{-# INLINE clear #-} -clear = basicClear - --- Accessing individual elements --- ----------------------------- - --- | Yield the element at the given position. -read :: (PrimMonad m, MVector v a) => v (PrimState m) a -> Int -> m a -{-# INLINE read #-} -read v i = BOUNDS_CHECK(checkIndex) "read" i (length v) - $ unsafeRead v i - --- | Replace the element at the given position. -write :: (PrimMonad m, MVector v a) => v (PrimState m) a -> Int -> a -> m () -{-# INLINE write #-} -write v i x = BOUNDS_CHECK(checkIndex) "write" i (length v) - $ unsafeWrite v i x - --- | Modify the element at the given position. -modify :: (PrimMonad m, MVector v a) => v (PrimState m) a -> (a -> a) -> Int -> m () -{-# INLINE modify #-} -modify v f i = BOUNDS_CHECK(checkIndex) "modify" i (length v) - $ unsafeModify v f i - --- | Swap the elements at the given positions. -swap :: (PrimMonad m, MVector v a) => v (PrimState m) a -> Int -> Int -> m () -{-# INLINE swap #-} -swap v i j = BOUNDS_CHECK(checkIndex) "swap" i (length v) - $ BOUNDS_CHECK(checkIndex) "swap" j (length v) - $ unsafeSwap v i j - --- | Replace the element at the give position and return the old element. -exchange :: (PrimMonad m, MVector v a) => v (PrimState m) a -> Int -> a -> m a -{-# INLINE exchange #-} -exchange v i x = BOUNDS_CHECK(checkIndex) "exchange" i (length v) - $ unsafeExchange v i x - --- | Yield the element at the given position. No bounds checks are performed. -unsafeRead :: (PrimMonad m, MVector v a) => v (PrimState m) a -> Int -> m a -{-# INLINE unsafeRead #-} -unsafeRead v i = UNSAFE_CHECK(checkIndex) "unsafeRead" i (length v) - $ basicUnsafeRead v i - --- | Replace the element at the given position. No bounds checks are performed. -unsafeWrite :: (PrimMonad m, MVector v a) - => v (PrimState m) a -> Int -> a -> m () -{-# INLINE unsafeWrite #-} -unsafeWrite v i x = UNSAFE_CHECK(checkIndex) "unsafeWrite" i (length v) - $ basicUnsafeWrite v i x - --- | Modify the element at the given position. No bounds checks are performed. -unsafeModify :: (PrimMonad m, MVector v a) => v (PrimState m) a -> (a -> a) -> Int -> m () -{-# INLINE unsafeModify #-} -unsafeModify v f i = UNSAFE_CHECK(checkIndex) "unsafeModify" i (length v) - $ basicUnsafeRead v i >>= \x -> - basicUnsafeWrite v i (f x) - --- | Swap the elements at the given positions. No bounds checks are performed. -unsafeSwap :: (PrimMonad m, MVector v a) - => v (PrimState m) a -> Int -> Int -> m () -{-# INLINE unsafeSwap #-} -unsafeSwap v i j = UNSAFE_CHECK(checkIndex) "unsafeSwap" i (length v) - $ UNSAFE_CHECK(checkIndex) "unsafeSwap" j (length v) - $ do - x <- unsafeRead v i - y <- unsafeRead v j - unsafeWrite v i y - unsafeWrite v j x - --- | Replace the element at the give position and return the old element. No --- bounds checks are performed. -unsafeExchange :: (PrimMonad m, MVector v a) - => v (PrimState m) a -> Int -> a -> m a -{-# INLINE unsafeExchange #-} -unsafeExchange v i x = UNSAFE_CHECK(checkIndex) "unsafeExchange" i (length v) - $ do - y <- unsafeRead v i - unsafeWrite v i x - return y - --- Filling and copying --- ------------------- - --- | Set all elements of the vector to the given value. -set :: (PrimMonad m, MVector v a) => v (PrimState m) a -> a -> m () -{-# INLINE set #-} -set = basicSet - --- | Copy a vector. The two vectors must have the same length and may not --- overlap. -copy :: (PrimMonad m, MVector v a) => v (PrimState m) a -- ^ target - -> v (PrimState m) a -- ^ source - -> m () -{-# INLINE copy #-} -copy dst src = BOUNDS_CHECK(check) "copy" "overlapping vectors" - (not (dst `overlaps` src)) - $ BOUNDS_CHECK(check) "copy" "length mismatch" - (length dst == length src) - $ unsafeCopy dst src - --- | Move the contents of a vector. The two vectors must have the same --- length. --- --- If the vectors do not overlap, then this is equivalent to 'copy'. --- Otherwise, the copying is performed as if the source vector were --- copied to a temporary vector and then the temporary vector was copied --- to the target vector. -move :: (PrimMonad m, MVector v a) - => v (PrimState m) a -> v (PrimState m) a -> m () -{-# INLINE move #-} -move dst src = BOUNDS_CHECK(check) "move" "length mismatch" - (length dst == length src) - $ unsafeMove dst src - --- | Copy a vector. The two vectors must have the same length and may not --- overlap. This is not checked. -unsafeCopy :: (PrimMonad m, MVector v a) => v (PrimState m) a -- ^ target - -> v (PrimState m) a -- ^ source - -> m () -{-# INLINE unsafeCopy #-} -unsafeCopy dst src = UNSAFE_CHECK(check) "unsafeCopy" "length mismatch" - (length dst == length src) - $ UNSAFE_CHECK(check) "unsafeCopy" "overlapping vectors" - (not (dst `overlaps` src)) - $ (dst `seq` src `seq` basicUnsafeCopy dst src) - --- | Move the contents of a vector. The two vectors must have the same --- length, but this is not checked. --- --- If the vectors do not overlap, then this is equivalent to 'unsafeCopy'. --- Otherwise, the copying is performed as if the source vector were --- copied to a temporary vector and then the temporary vector was copied --- to the target vector. -unsafeMove :: (PrimMonad m, MVector v a) => v (PrimState m) a -- ^ target - -> v (PrimState m) a -- ^ source - -> m () -{-# INLINE unsafeMove #-} -unsafeMove dst src = UNSAFE_CHECK(check) "unsafeMove" "length mismatch" - (length dst == length src) - $ (dst `seq` src `seq` basicUnsafeMove dst src) - --- Permutations --- ------------ - -accum :: (PrimMonad m, MVector v a) - => (a -> b -> a) -> v (PrimState m) a -> Bundle u (Int, b) -> m () -{-# INLINE accum #-} -accum f !v s = Bundle.mapM_ upd s - where - {-# INLINE_INNER upd #-} - upd (i,b) = do - a <- BOUNDS_CHECK(checkIndex) "accum" i n - $ unsafeRead v i - unsafeWrite v i (f a b) - - !n = length v - -update :: (PrimMonad m, MVector v a) - => v (PrimState m) a -> Bundle u (Int, a) -> m () -{-# INLINE update #-} -update !v s = Bundle.mapM_ upd s - where - {-# INLINE_INNER upd #-} - upd (i,b) = BOUNDS_CHECK(checkIndex) "update" i n - $ unsafeWrite v i b - - !n = length v - -unsafeAccum :: (PrimMonad m, MVector v a) - => (a -> b -> a) -> v (PrimState m) a -> Bundle u (Int, b) -> m () -{-# INLINE unsafeAccum #-} -unsafeAccum f !v s = Bundle.mapM_ upd s - where - {-# INLINE_INNER upd #-} - upd (i,b) = do - a <- UNSAFE_CHECK(checkIndex) "accum" i n - $ unsafeRead v i - unsafeWrite v i (f a b) - - !n = length v - -unsafeUpdate :: (PrimMonad m, MVector v a) - => v (PrimState m) a -> Bundle u (Int, a) -> m () -{-# INLINE unsafeUpdate #-} -unsafeUpdate !v s = Bundle.mapM_ upd s - where - {-# INLINE_INNER upd #-} - upd (i,b) = UNSAFE_CHECK(checkIndex) "accum" i n - $ unsafeWrite v i b - - !n = length v - -reverse :: (PrimMonad m, MVector v a) => v (PrimState m) a -> m () -{-# INLINE reverse #-} -reverse !v = reverse_loop 0 (length v - 1) - where - reverse_loop i j | i < j = do - unsafeSwap v i j - reverse_loop (i + 1) (j - 1) - reverse_loop _ _ = return () - -unstablePartition :: forall m v a. (PrimMonad m, MVector v a) - => (a -> Bool) -> v (PrimState m) a -> m Int -{-# INLINE unstablePartition #-} -unstablePartition f !v = from_left 0 (length v) - where - -- NOTE: GHC 6.10.4 panics without the signatures on from_left and - -- from_right - from_left :: Int -> Int -> m Int - from_left i j - | i == j = return i - | otherwise = do - x <- unsafeRead v i - if f x - then from_left (i+1) j - else from_right i (j-1) - - from_right :: Int -> Int -> m Int - from_right i j - | i == j = return i - | otherwise = do - x <- unsafeRead v j - if f x - then do - y <- unsafeRead v i - unsafeWrite v i x - unsafeWrite v j y - from_left (i+1) j - else from_right i (j-1) - -unstablePartitionBundle :: (PrimMonad m, MVector v a) - => (a -> Bool) -> Bundle u a -> m (v (PrimState m) a, v (PrimState m) a) -{-# INLINE unstablePartitionBundle #-} -unstablePartitionBundle f s - = case upperBound (Bundle.size s) of - Just n -> unstablePartitionMax f s n - Nothing -> partitionUnknown f s - -unstablePartitionMax :: (PrimMonad m, MVector v a) - => (a -> Bool) -> Bundle u a -> Int - -> m (v (PrimState m) a, v (PrimState m) a) -{-# INLINE unstablePartitionMax #-} -unstablePartitionMax f s n - = do - v <- INTERNAL_CHECK(checkLength) "unstablePartitionMax" n - $ unsafeNew n - let {-# INLINE_INNER put #-} - put (i, j) x - | f x = do - unsafeWrite v i x - return (i+1, j) - | otherwise = do - unsafeWrite v (j-1) x - return (i, j-1) - - (i,j) <- Bundle.foldM' put (0, n) s - return (unsafeSlice 0 i v, unsafeSlice j (n-j) v) - -partitionBundle :: (PrimMonad m, MVector v a) - => (a -> Bool) -> Bundle u a -> m (v (PrimState m) a, v (PrimState m) a) -{-# INLINE partitionBundle #-} -partitionBundle f s - = case upperBound (Bundle.size s) of - Just n -> partitionMax f s n - Nothing -> partitionUnknown f s - -partitionMax :: (PrimMonad m, MVector v a) - => (a -> Bool) -> Bundle u a -> Int -> m (v (PrimState m) a, v (PrimState m) a) -{-# INLINE partitionMax #-} -partitionMax f s n - = do - v <- INTERNAL_CHECK(checkLength) "unstablePartitionMax" n - $ unsafeNew n - - let {-# INLINE_INNER put #-} - put (i,j) x - | f x = do - unsafeWrite v i x - return (i+1,j) - - | otherwise = let j' = j-1 in - do - unsafeWrite v j' x - return (i,j') - - (i,j) <- Bundle.foldM' put (0,n) s - INTERNAL_CHECK(check) "partitionMax" "invalid indices" (i <= j) - $ return () - let l = unsafeSlice 0 i v - r = unsafeSlice j (n-j) v - reverse r - return (l,r) - -partitionUnknown :: (PrimMonad m, MVector v a) - => (a -> Bool) -> Bundle u a -> m (v (PrimState m) a, v (PrimState m) a) -{-# INLINE partitionUnknown #-} -partitionUnknown f s - = do - v1 <- unsafeNew 0 - v2 <- unsafeNew 0 - (v1', n1, v2', n2) <- Bundle.foldM' put (v1, 0, v2, 0) s - INTERNAL_CHECK(checkSlice) "partitionUnknown" 0 n1 (length v1') - $ INTERNAL_CHECK(checkSlice) "partitionUnknown" 0 n2 (length v2') - $ return (unsafeSlice 0 n1 v1', unsafeSlice 0 n2 v2') - where - -- NOTE: The case distinction has to be on the outside because - -- GHC creates a join point for the unsafeWrite even when everything - -- is inlined. This is bad because with the join point, v isn't getting - -- unboxed. - {-# INLINE_INNER put #-} - put (v1, i1, v2, i2) x - | f x = do - v1' <- unsafeAppend1 v1 i1 x - return (v1', i1+1, v2, i2) - | otherwise = do - v2' <- unsafeAppend1 v2 i2 x - return (v1, i1, v2', i2+1) - -{- -http://en.wikipedia.org/wiki/Permutation#Algorithms_to_generate_permutations - -The following algorithm generates the next permutation lexicographically after -a given permutation. It changes the given permutation in-place. - -1. Find the largest index k such that a[k] < a[k + 1]. If no such index exists, - the permutation is the last permutation. -2. Find the largest index l greater than k such that a[k] < a[l]. -3. Swap the value of a[k] with that of a[l]. -4. Reverse the sequence from a[k + 1] up to and including the final element a[n] --} - --- | Compute the next (lexicographically) permutation of given vector in-place. --- Returns False when input is the last permtuation -nextPermutation :: (PrimMonad m,Ord e,MVector v e) => v (PrimState m) e -> m Bool -nextPermutation v - | dim < 2 = return False - | otherwise = do - val <- unsafeRead v 0 - (k,l) <- loop val (-1) 0 val 1 - if k < 0 - then return False - else unsafeSwap v k l >> - reverse (unsafeSlice (k+1) (dim-k-1) v) >> - return True - where loop !kval !k !l !prev !i - | i == dim = return (k,l) - | otherwise = do - cur <- unsafeRead v i - -- TODO: make tuple unboxed - let (kval',k') = if prev < cur then (prev,i-1) else (kval,k) - l' = if kval' < cur then i else l - loop kval' k' l' cur (i+1) - dim = length v diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/Mutable/Base.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/Mutable/Base.hs deleted file mode 100644 index ce931eec9b41..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/Mutable/Base.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE CPP, MultiParamTypeClasses, BangPatterns, TypeFamilies #-} --- | --- Module : Data.Vector.Generic.Mutable.Base --- Copyright : (c) Roman Leshchinskiy 2008-2011 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Stability : experimental --- Portability : non-portable --- --- Class of mutable vectors --- - -module Data.Vector.Generic.Mutable.Base ( - MVector(..) -) where - -import Control.Monad.Primitive ( PrimMonad, PrimState ) - --- Data.Vector.Internal.Check is unused -#define NOT_VECTOR_MODULE -#include "vector.h" - --- | Class of mutable vectors parametrised with a primitive state token. --- -class MVector v a where - -- | Length of the mutable vector. This method should not be - -- called directly, use 'length' instead. - basicLength :: v s a -> Int - - -- | Yield a part of the mutable vector without copying it. This method - -- should not be called directly, use 'unsafeSlice' instead. - basicUnsafeSlice :: Int -- ^ starting index - -> Int -- ^ length of the slice - -> v s a - -> v s a - - -- | Check whether two vectors overlap. This method should not be - -- called directly, use 'overlaps' instead. - basicOverlaps :: v s a -> v s a -> Bool - - -- | Create a mutable vector of the given length. This method should not be - -- called directly, use 'unsafeNew' instead. - basicUnsafeNew :: PrimMonad m => Int -> m (v (PrimState m) a) - - -- | Initialize a vector to a standard value. This is intended to be called as - -- part of the safe new operation (and similar operations), to properly blank - -- the newly allocated memory if necessary. - -- - -- Vectors that are necessarily initialized as part of creation may implement - -- this as a no-op. - basicInitialize :: PrimMonad m => v (PrimState m) a -> m () - - -- | Create a mutable vector of the given length and fill it with an - -- initial value. This method should not be called directly, use - -- 'replicate' instead. - basicUnsafeReplicate :: PrimMonad m => Int -> a -> m (v (PrimState m) a) - - -- | Yield the element at the given position. This method should not be - -- called directly, use 'unsafeRead' instead. - basicUnsafeRead :: PrimMonad m => v (PrimState m) a -> Int -> m a - - -- | Replace the element at the given position. This method should not be - -- called directly, use 'unsafeWrite' instead. - basicUnsafeWrite :: PrimMonad m => v (PrimState m) a -> Int -> a -> m () - - -- | Reset all elements of the vector to some undefined value, clearing all - -- references to external objects. This is usually a noop for unboxed - -- vectors. This method should not be called directly, use 'clear' instead. - basicClear :: PrimMonad m => v (PrimState m) a -> m () - - -- | Set all elements of the vector to the given value. This method should - -- not be called directly, use 'set' instead. - basicSet :: PrimMonad m => v (PrimState m) a -> a -> m () - - -- | Copy a vector. The two vectors may not overlap. This method should not - -- be called directly, use 'unsafeCopy' instead. - basicUnsafeCopy :: PrimMonad m => v (PrimState m) a -- ^ target - -> v (PrimState m) a -- ^ source - -> m () - - -- | Move the contents of a vector. The two vectors may overlap. This method - -- should not be called directly, use 'unsafeMove' instead. - basicUnsafeMove :: PrimMonad m => v (PrimState m) a -- ^ target - -> v (PrimState m) a -- ^ source - -> m () - - -- | Grow a vector by the given number of elements. This method should not be - -- called directly, use 'unsafeGrow' instead. - basicUnsafeGrow :: PrimMonad m => v (PrimState m) a -> Int - -> m (v (PrimState m) a) - - {-# INLINE basicUnsafeReplicate #-} - basicUnsafeReplicate n x - = do - v <- basicUnsafeNew n - basicSet v x - return v - - {-# INLINE basicClear #-} - basicClear _ = return () - - {-# INLINE basicSet #-} - basicSet !v x - | n == 0 = return () - | otherwise = do - basicUnsafeWrite v 0 x - do_set 1 - where - !n = basicLength v - - do_set i | 2*i < n = do basicUnsafeCopy (basicUnsafeSlice i i v) - (basicUnsafeSlice 0 i v) - do_set (2*i) - | otherwise = basicUnsafeCopy (basicUnsafeSlice i (n-i) v) - (basicUnsafeSlice 0 (n-i) v) - - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy !dst !src = do_copy 0 - where - !n = basicLength src - - do_copy i | i < n = do - x <- basicUnsafeRead src i - basicUnsafeWrite dst i x - do_copy (i+1) - | otherwise = return () - - {-# INLINE basicUnsafeMove #-} - basicUnsafeMove !dst !src - | basicOverlaps dst src = do - srcCopy <- basicUnsafeNew (basicLength src) - basicUnsafeCopy srcCopy src - basicUnsafeCopy dst srcCopy - | otherwise = basicUnsafeCopy dst src - - {-# INLINE basicUnsafeGrow #-} - basicUnsafeGrow v by - = do - v' <- basicUnsafeNew (n+by) - basicUnsafeCopy (basicUnsafeSlice 0 n v') v - return v' - where - n = basicLength v - diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/New.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/New.hs deleted file mode 100644 index e94ce19e1669..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/New.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# LANGUAGE CPP, Rank2Types, FlexibleContexts, MultiParamTypeClasses #-} - --- | --- Module : Data.Vector.Generic.New --- Copyright : (c) Roman Leshchinskiy 2008-2010 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Stability : experimental --- Portability : non-portable --- --- Purely functional interface to initialisation of mutable vectors --- - -module Data.Vector.Generic.New ( - New(..), create, run, runPrim, apply, modify, modifyWithBundle, - unstream, transform, unstreamR, transformR, - slice, init, tail, take, drop, - unsafeSlice, unsafeInit, unsafeTail -) where - -import qualified Data.Vector.Generic.Mutable as MVector - -import Data.Vector.Generic.Base ( Vector, Mutable ) - -import Data.Vector.Fusion.Bundle ( Bundle ) -import qualified Data.Vector.Fusion.Bundle as Bundle -import Data.Vector.Fusion.Stream.Monadic ( Stream ) -import Data.Vector.Fusion.Bundle.Size - -import Control.Monad.Primitive -import Control.Monad.ST ( ST ) -import Control.Monad ( liftM ) -import Prelude hiding ( init, tail, take, drop, reverse, map, filter ) - --- Data.Vector.Internal.Check is unused -#define NOT_VECTOR_MODULE -#include "vector.h" - -data New v a = New (forall s. ST s (Mutable v s a)) - -create :: (forall s. ST s (Mutable v s a)) -> New v a -{-# INLINE create #-} -create p = New p - -run :: New v a -> ST s (Mutable v s a) -{-# INLINE run #-} -run (New p) = p - -runPrim :: PrimMonad m => New v a -> m (Mutable v (PrimState m) a) -{-# INLINE runPrim #-} -runPrim (New p) = primToPrim p - -apply :: (forall s. Mutable v s a -> Mutable v s a) -> New v a -> New v a -{-# INLINE apply #-} -apply f (New p) = New (liftM f p) - -modify :: (forall s. Mutable v s a -> ST s ()) -> New v a -> New v a -{-# INLINE modify #-} -modify f (New p) = New (do { v <- p; f v; return v }) - -modifyWithBundle :: (forall s. Mutable v s a -> Bundle u b -> ST s ()) - -> New v a -> Bundle u b -> New v a -{-# INLINE_FUSED modifyWithBundle #-} -modifyWithBundle f (New p) s = s `seq` New (do { v <- p; f v s; return v }) - -unstream :: Vector v a => Bundle v a -> New v a -{-# INLINE_FUSED unstream #-} -unstream s = s `seq` New (MVector.vunstream s) - -transform - :: Vector v a => (forall m. Monad m => Stream m a -> Stream m a) - -> (Size -> Size) -> New v a -> New v a -{-# INLINE_FUSED transform #-} -transform f _ (New p) = New (MVector.transform f =<< p) - -{-# RULES - -"transform/transform [New]" - forall (f1 :: forall m. Monad m => Stream m a -> Stream m a) - (f2 :: forall m. Monad m => Stream m a -> Stream m a) - g1 g2 p . - transform f1 g1 (transform f2 g2 p) = transform (f1 . f2) (g1 . g2) p - -"transform/unstream [New]" - forall (f :: forall m. Monad m => Stream m a -> Stream m a) - g s. - transform f g (unstream s) = unstream (Bundle.inplace f g s) #-} - - - - -unstreamR :: Vector v a => Bundle v a -> New v a -{-# INLINE_FUSED unstreamR #-} -unstreamR s = s `seq` New (MVector.unstreamR s) - -transformR - :: Vector v a => (forall m. Monad m => Stream m a -> Stream m a) - -> (Size -> Size) -> New v a -> New v a -{-# INLINE_FUSED transformR #-} -transformR f _ (New p) = New (MVector.transformR f =<< p) - -{-# RULES - -"transformR/transformR [New]" - forall (f1 :: forall m. Monad m => Stream m a -> Stream m a) - (f2 :: forall m. Monad m => Stream m a -> Stream m a) - g1 g2 - p . - transformR f1 g1 (transformR f2 g2 p) = transformR (f1 . f2) (g1 . g2) p - -"transformR/unstreamR [New]" - forall (f :: forall m. Monad m => Stream m a -> Stream m a) - g s. - transformR f g (unstreamR s) = unstreamR (Bundle.inplace f g s) #-} - - - -slice :: Vector v a => Int -> Int -> New v a -> New v a -{-# INLINE_FUSED slice #-} -slice i n m = apply (MVector.slice i n) m - -init :: Vector v a => New v a -> New v a -{-# INLINE_FUSED init #-} -init m = apply MVector.init m - -tail :: Vector v a => New v a -> New v a -{-# INLINE_FUSED tail #-} -tail m = apply MVector.tail m - -take :: Vector v a => Int -> New v a -> New v a -{-# INLINE_FUSED take #-} -take n m = apply (MVector.take n) m - -drop :: Vector v a => Int -> New v a -> New v a -{-# INLINE_FUSED drop #-} -drop n m = apply (MVector.drop n) m - -unsafeSlice :: Vector v a => Int -> Int -> New v a -> New v a -{-# INLINE_FUSED unsafeSlice #-} -unsafeSlice i n m = apply (MVector.unsafeSlice i n) m - -unsafeInit :: Vector v a => New v a -> New v a -{-# INLINE_FUSED unsafeInit #-} -unsafeInit m = apply MVector.unsafeInit m - -unsafeTail :: Vector v a => New v a -> New v a -{-# INLINE_FUSED unsafeTail #-} -unsafeTail m = apply MVector.unsafeTail m - -{-# RULES - -"slice/unstream [New]" forall i n s. - slice i n (unstream s) = unstream (Bundle.slice i n s) - -"init/unstream [New]" forall s. - init (unstream s) = unstream (Bundle.init s) - -"tail/unstream [New]" forall s. - tail (unstream s) = unstream (Bundle.tail s) - -"take/unstream [New]" forall n s. - take n (unstream s) = unstream (Bundle.take n s) - -"drop/unstream [New]" forall n s. - drop n (unstream s) = unstream (Bundle.drop n s) - -"unsafeSlice/unstream [New]" forall i n s. - unsafeSlice i n (unstream s) = unstream (Bundle.slice i n s) - -"unsafeInit/unstream [New]" forall s. - unsafeInit (unstream s) = unstream (Bundle.init s) - -"unsafeTail/unstream [New]" forall s. - unsafeTail (unstream s) = unstream (Bundle.tail s) #-} - - - diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Internal/Check.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Internal/Check.hs deleted file mode 100644 index 4a4ef80fe172..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Internal/Check.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | --- Module : Data.Vector.Internal.Check --- Copyright : (c) Roman Leshchinskiy 2009 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Stability : experimental --- Portability : non-portable --- --- Bounds checking infrastructure --- - -{-# LANGUAGE MagicHash #-} - -module Data.Vector.Internal.Check ( - Checks(..), doChecks, - - error, internalError, - check, checkIndex, checkLength, checkSlice -) where - -import GHC.Base( Int(..) ) -import GHC.Prim( Int# ) -import Prelude hiding( error, (&&), (||), not ) -import qualified Prelude as P - --- NOTE: This is a workaround for GHC's weird behaviour where it doesn't inline --- these functions into unfoldings which makes the intermediate code size --- explode. See http://hackage.haskell.org/trac/ghc/ticket/5539. -infixr 2 || -infixr 3 && - -not :: Bool -> Bool -{-# INLINE not #-} -not True = False -not False = True - -(&&) :: Bool -> Bool -> Bool -{-# INLINE (&&) #-} -False && _ = False -True && x = x - -(||) :: Bool -> Bool -> Bool -{-# INLINE (||) #-} -True || _ = True -False || x = x - - -data Checks = Bounds | Unsafe | Internal deriving( Eq ) - -doBoundsChecks :: Bool -#ifdef VECTOR_BOUNDS_CHECKS -doBoundsChecks = True -#else -doBoundsChecks = False -#endif - -doUnsafeChecks :: Bool -#ifdef VECTOR_UNSAFE_CHECKS -doUnsafeChecks = True -#else -doUnsafeChecks = False -#endif - -doInternalChecks :: Bool -#ifdef VECTOR_INTERNAL_CHECKS -doInternalChecks = True -#else -doInternalChecks = False -#endif - - -doChecks :: Checks -> Bool -{-# INLINE doChecks #-} -doChecks Bounds = doBoundsChecks -doChecks Unsafe = doUnsafeChecks -doChecks Internal = doInternalChecks - -error_msg :: String -> Int -> String -> String -> String -error_msg file line loc msg = file ++ ":" ++ show line ++ " (" ++ loc ++ "): " ++ msg - -error :: String -> Int -> String -> String -> a -{-# NOINLINE error #-} -error file line loc msg - = P.error $ error_msg file line loc msg - -internalError :: String -> Int -> String -> String -> a -{-# NOINLINE internalError #-} -internalError file line loc msg - = P.error $ unlines - ["*** Internal error in package vector ***" - ,"*** Please submit a bug report at http://trac.haskell.org/vector" - ,error_msg file line loc msg] - - -checkError :: String -> Int -> Checks -> String -> String -> a -{-# NOINLINE checkError #-} -checkError file line kind loc msg - = case kind of - Internal -> internalError file line loc msg - _ -> error file line loc msg - -check :: String -> Int -> Checks -> String -> String -> Bool -> a -> a -{-# INLINE check #-} -check file line kind loc msg cond x - | not (doChecks kind) || cond = x - | otherwise = checkError file line kind loc msg - -checkIndex_msg :: Int -> Int -> String -{-# INLINE checkIndex_msg #-} -checkIndex_msg (I# i#) (I# n#) = checkIndex_msg# i# n# - -checkIndex_msg# :: Int# -> Int# -> String -{-# NOINLINE checkIndex_msg# #-} -checkIndex_msg# i# n# = "index out of bounds " ++ show (I# i#, I# n#) - -checkIndex :: String -> Int -> Checks -> String -> Int -> Int -> a -> a -{-# INLINE checkIndex #-} -checkIndex file line kind loc i n x - = check file line kind loc (checkIndex_msg i n) (i >= 0 && i<n) x - - -checkLength_msg :: Int -> String -{-# INLINE checkLength_msg #-} -checkLength_msg (I# n#) = checkLength_msg# n# - -checkLength_msg# :: Int# -> String -{-# NOINLINE checkLength_msg# #-} -checkLength_msg# n# = "negative length " ++ show (I# n#) - -checkLength :: String -> Int -> Checks -> String -> Int -> a -> a -{-# INLINE checkLength #-} -checkLength file line kind loc n x - = check file line kind loc (checkLength_msg n) (n >= 0) x - - -checkSlice_msg :: Int -> Int -> Int -> String -{-# INLINE checkSlice_msg #-} -checkSlice_msg (I# i#) (I# m#) (I# n#) = checkSlice_msg# i# m# n# - -checkSlice_msg# :: Int# -> Int# -> Int# -> String -{-# NOINLINE checkSlice_msg# #-} -checkSlice_msg# i# m# n# = "invalid slice " ++ show (I# i#, I# m#, I# n#) - -checkSlice :: String -> Int -> Checks -> String -> Int -> Int -> Int -> a -> a -{-# INLINE checkSlice #-} -checkSlice file line kind loc i m n x - = check file line kind loc (checkSlice_msg i m n) - (i >= 0 && m >= 0 && i+m <= n) x - diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Mutable.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Mutable.hs deleted file mode 100644 index ba701afb6a19..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Mutable.hs +++ /dev/null @@ -1,416 +0,0 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, MultiParamTypeClasses, FlexibleInstances, BangPatterns, TypeFamilies #-} - --- | --- Module : Data.Vector.Mutable --- Copyright : (c) Roman Leshchinskiy 2008-2010 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Stability : experimental --- Portability : non-portable --- --- Mutable boxed vectors. --- - -module Data.Vector.Mutable ( - -- * Mutable boxed vectors - MVector(..), IOVector, STVector, - - -- * Accessors - - -- ** Length information - length, null, - - -- ** Extracting subvectors - slice, init, tail, take, drop, splitAt, - unsafeSlice, unsafeInit, unsafeTail, unsafeTake, unsafeDrop, - - -- ** Overlapping - overlaps, - - -- * Construction - - -- ** Initialisation - new, unsafeNew, replicate, replicateM, clone, - - -- ** Growing - grow, unsafeGrow, - - -- ** Restricting memory usage - clear, - - -- * Accessing individual elements - read, write, modify, swap, - unsafeRead, unsafeWrite, unsafeModify, unsafeSwap, - - -- * Modifying vectors - nextPermutation, - - -- ** Filling and copying - set, copy, move, unsafeCopy, unsafeMove -) where - -import Control.Monad (when) -import qualified Data.Vector.Generic.Mutable as G -import Data.Primitive.Array -import Control.Monad.Primitive - -import Prelude hiding ( length, null, replicate, reverse, read, - take, drop, splitAt, init, tail ) - -import Data.Typeable ( Typeable ) - -#include "vector.h" - --- | Mutable boxed vectors keyed on the monad they live in ('IO' or @'ST' s@). -data MVector s a = MVector {-# UNPACK #-} !Int - {-# UNPACK #-} !Int - {-# UNPACK #-} !(MutableArray s a) - deriving ( Typeable ) - -type IOVector = MVector RealWorld -type STVector s = MVector s - --- NOTE: This seems unsafe, see http://trac.haskell.org/vector/ticket/54 -{- -instance NFData a => NFData (MVector s a) where - rnf (MVector i n arr) = unsafeInlineST $ force i - where - force !ix | ix < n = do x <- readArray arr ix - rnf x `seq` force (ix+1) - | otherwise = return () --} - -instance G.MVector MVector a where - {-# INLINE basicLength #-} - basicLength (MVector _ n _) = n - - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice j m (MVector i _ arr) = MVector (i+j) m arr - - {-# INLINE basicOverlaps #-} - basicOverlaps (MVector i m arr1) (MVector j n arr2) - = sameMutableArray arr1 arr2 - && (between i j (j+n) || between j i (i+m)) - where - between x y z = x >= y && x < z - - {-# INLINE basicUnsafeNew #-} - basicUnsafeNew n - = do - arr <- newArray n uninitialised - return (MVector 0 n arr) - - {-# INLINE basicInitialize #-} - -- initialization is unnecessary for boxed vectors - basicInitialize _ = return () - - {-# INLINE basicUnsafeReplicate #-} - basicUnsafeReplicate n x - = do - arr <- newArray n x - return (MVector 0 n arr) - - {-# INLINE basicUnsafeRead #-} - basicUnsafeRead (MVector i _ arr) j = readArray arr (i+j) - - {-# INLINE basicUnsafeWrite #-} - basicUnsafeWrite (MVector i _ arr) j x = writeArray arr (i+j) x - - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy (MVector i n dst) (MVector j _ src) - = copyMutableArray dst i src j n - - basicUnsafeMove dst@(MVector iDst n arrDst) src@(MVector iSrc _ arrSrc) - = case n of - 0 -> return () - 1 -> readArray arrSrc iSrc >>= writeArray arrDst iDst - 2 -> do - x <- readArray arrSrc iSrc - y <- readArray arrSrc (iSrc + 1) - writeArray arrDst iDst x - writeArray arrDst (iDst + 1) y - _ - | overlaps dst src - -> case compare iDst iSrc of - LT -> moveBackwards arrDst iDst iSrc n - EQ -> return () - GT | (iDst - iSrc) * 2 < n - -> moveForwardsLargeOverlap arrDst iDst iSrc n - | otherwise - -> moveForwardsSmallOverlap arrDst iDst iSrc n - | otherwise -> G.basicUnsafeCopy dst src - - {-# INLINE basicClear #-} - basicClear v = G.set v uninitialised - -{-# INLINE moveBackwards #-} -moveBackwards :: PrimMonad m => MutableArray (PrimState m) a -> Int -> Int -> Int -> m () -moveBackwards !arr !dstOff !srcOff !len = - INTERNAL_CHECK(check) "moveBackwards" "not a backwards move" (dstOff < srcOff) - $ loopM len $ \ i -> readArray arr (srcOff + i) >>= writeArray arr (dstOff + i) - -{-# INLINE moveForwardsSmallOverlap #-} --- Performs a move when dstOff > srcOff, optimized for when the overlap of the intervals is small. -moveForwardsSmallOverlap :: PrimMonad m => MutableArray (PrimState m) a -> Int -> Int -> Int -> m () -moveForwardsSmallOverlap !arr !dstOff !srcOff !len = - INTERNAL_CHECK(check) "moveForwardsSmallOverlap" "not a forward move" (dstOff > srcOff) - $ do - tmp <- newArray overlap uninitialised - loopM overlap $ \ i -> readArray arr (dstOff + i) >>= writeArray tmp i - loopM nonOverlap $ \ i -> readArray arr (srcOff + i) >>= writeArray arr (dstOff + i) - loopM overlap $ \ i -> readArray tmp i >>= writeArray arr (dstOff + nonOverlap + i) - where nonOverlap = dstOff - srcOff; overlap = len - nonOverlap - --- Performs a move when dstOff > srcOff, optimized for when the overlap of the intervals is large. -moveForwardsLargeOverlap :: PrimMonad m => MutableArray (PrimState m) a -> Int -> Int -> Int -> m () -moveForwardsLargeOverlap !arr !dstOff !srcOff !len = - INTERNAL_CHECK(check) "moveForwardsLargeOverlap" "not a forward move" (dstOff > srcOff) - $ do - queue <- newArray nonOverlap uninitialised - loopM nonOverlap $ \ i -> readArray arr (srcOff + i) >>= writeArray queue i - let mov !i !qTop = when (i < dstOff + len) $ do - x <- readArray arr i - y <- readArray queue qTop - writeArray arr i y - writeArray queue qTop x - mov (i+1) (if qTop + 1 >= nonOverlap then 0 else qTop + 1) - mov dstOff 0 - where nonOverlap = dstOff - srcOff - -{-# INLINE loopM #-} -loopM :: Monad m => Int -> (Int -> m a) -> m () -loopM !n k = let - go i = when (i < n) (k i >> go (i+1)) - in go 0 - -uninitialised :: a -uninitialised = error "Data.Vector.Mutable: uninitialised element" - --- Length information --- ------------------ - --- | Length of the mutable vector. -length :: MVector s a -> Int -{-# INLINE length #-} -length = G.length - --- | Check whether the vector is empty -null :: MVector s a -> Bool -{-# INLINE null #-} -null = G.null - --- Extracting subvectors --- --------------------- - --- | Yield a part of the mutable vector without copying it. -slice :: Int -> Int -> MVector s a -> MVector s a -{-# INLINE slice #-} -slice = G.slice - -take :: Int -> MVector s a -> MVector s a -{-# INLINE take #-} -take = G.take - -drop :: Int -> MVector s a -> MVector s a -{-# INLINE drop #-} -drop = G.drop - -{-# INLINE splitAt #-} -splitAt :: Int -> MVector s a -> (MVector s a, MVector s a) -splitAt = G.splitAt - -init :: MVector s a -> MVector s a -{-# INLINE init #-} -init = G.init - -tail :: MVector s a -> MVector s a -{-# INLINE tail #-} -tail = G.tail - --- | Yield a part of the mutable vector without copying it. No bounds checks --- are performed. -unsafeSlice :: Int -- ^ starting index - -> Int -- ^ length of the slice - -> MVector s a - -> MVector s a -{-# INLINE unsafeSlice #-} -unsafeSlice = G.unsafeSlice - -unsafeTake :: Int -> MVector s a -> MVector s a -{-# INLINE unsafeTake #-} -unsafeTake = G.unsafeTake - -unsafeDrop :: Int -> MVector s a -> MVector s a -{-# INLINE unsafeDrop #-} -unsafeDrop = G.unsafeDrop - -unsafeInit :: MVector s a -> MVector s a -{-# INLINE unsafeInit #-} -unsafeInit = G.unsafeInit - -unsafeTail :: MVector s a -> MVector s a -{-# INLINE unsafeTail #-} -unsafeTail = G.unsafeTail - --- Overlapping --- ----------- - --- | Check whether two vectors overlap. -overlaps :: MVector s a -> MVector s a -> Bool -{-# INLINE overlaps #-} -overlaps = G.overlaps - --- Initialisation --- -------------- - --- | Create a mutable vector of the given length. -new :: PrimMonad m => Int -> m (MVector (PrimState m) a) -{-# INLINE new #-} -new = G.new - --- | Create a mutable vector of the given length. The memory is not initialized. -unsafeNew :: PrimMonad m => Int -> m (MVector (PrimState m) a) -{-# INLINE unsafeNew #-} -unsafeNew = G.unsafeNew - --- | Create a mutable vector of the given length (0 if the length is negative) --- and fill it with an initial value. -replicate :: PrimMonad m => Int -> a -> m (MVector (PrimState m) a) -{-# INLINE replicate #-} -replicate = G.replicate - --- | Create a mutable vector of the given length (0 if the length is negative) --- and fill it with values produced by repeatedly executing the monadic action. -replicateM :: PrimMonad m => Int -> m a -> m (MVector (PrimState m) a) -{-# INLINE replicateM #-} -replicateM = G.replicateM - --- | Create a copy of a mutable vector. -clone :: PrimMonad m => MVector (PrimState m) a -> m (MVector (PrimState m) a) -{-# INLINE clone #-} -clone = G.clone - --- Growing --- ------- - --- | Grow a vector by the given number of elements. The number must be --- positive. -grow :: PrimMonad m - => MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a) -{-# INLINE grow #-} -grow = G.grow - --- | Grow a vector by the given number of elements. The number must be --- positive but this is not checked. -unsafeGrow :: PrimMonad m - => MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a) -{-# INLINE unsafeGrow #-} -unsafeGrow = G.unsafeGrow - --- Restricting memory usage --- ------------------------ - --- | Reset all elements of the vector to some undefined value, clearing all --- references to external objects. This is usually a noop for unboxed vectors. -clear :: PrimMonad m => MVector (PrimState m) a -> m () -{-# INLINE clear #-} -clear = G.clear - --- Accessing individual elements --- ----------------------------- - --- | Yield the element at the given position. -read :: PrimMonad m => MVector (PrimState m) a -> Int -> m a -{-# INLINE read #-} -read = G.read - --- | Replace the element at the given position. -write :: PrimMonad m => MVector (PrimState m) a -> Int -> a -> m () -{-# INLINE write #-} -write = G.write - --- | Modify the element at the given position. -modify :: PrimMonad m => MVector (PrimState m) a -> (a -> a) -> Int -> m () -{-# INLINE modify #-} -modify = G.modify - --- | Swap the elements at the given positions. -swap :: PrimMonad m => MVector (PrimState m) a -> Int -> Int -> m () -{-# INLINE swap #-} -swap = G.swap - - --- | Yield the element at the given position. No bounds checks are performed. -unsafeRead :: PrimMonad m => MVector (PrimState m) a -> Int -> m a -{-# INLINE unsafeRead #-} -unsafeRead = G.unsafeRead - --- | Replace the element at the given position. No bounds checks are performed. -unsafeWrite :: PrimMonad m => MVector (PrimState m) a -> Int -> a -> m () -{-# INLINE unsafeWrite #-} -unsafeWrite = G.unsafeWrite - --- | Modify the element at the given position. No bounds checks are performed. -unsafeModify :: PrimMonad m => MVector (PrimState m) a -> (a -> a) -> Int -> m () -{-# INLINE unsafeModify #-} -unsafeModify = G.unsafeModify - --- | Swap the elements at the given positions. No bounds checks are performed. -unsafeSwap :: PrimMonad m => MVector (PrimState m) a -> Int -> Int -> m () -{-# INLINE unsafeSwap #-} -unsafeSwap = G.unsafeSwap - --- Filling and copying --- ------------------- - --- | Set all elements of the vector to the given value. -set :: PrimMonad m => MVector (PrimState m) a -> a -> m () -{-# INLINE set #-} -set = G.set - --- | Copy a vector. The two vectors must have the same length and may not --- overlap. -copy :: PrimMonad m - => MVector (PrimState m) a -> MVector (PrimState m) a -> m () -{-# INLINE copy #-} -copy = G.copy - --- | Copy a vector. The two vectors must have the same length and may not --- overlap. This is not checked. -unsafeCopy :: PrimMonad m => MVector (PrimState m) a -- ^ target - -> MVector (PrimState m) a -- ^ source - -> m () -{-# INLINE unsafeCopy #-} -unsafeCopy = G.unsafeCopy - --- | Move the contents of a vector. The two vectors must have the same --- length. --- --- If the vectors do not overlap, then this is equivalent to 'copy'. --- Otherwise, the copying is performed as if the source vector were --- copied to a temporary vector and then the temporary vector was copied --- to the target vector. -move :: PrimMonad m - => MVector (PrimState m) a -> MVector (PrimState m) a -> m () -{-# INLINE move #-} -move = G.move - --- | Move the contents of a vector. The two vectors must have the same --- length, but this is not checked. --- --- If the vectors do not overlap, then this is equivalent to 'unsafeCopy'. --- Otherwise, the copying is performed as if the source vector were --- copied to a temporary vector and then the temporary vector was copied --- to the target vector. -unsafeMove :: PrimMonad m => MVector (PrimState m) a -- ^ target - -> MVector (PrimState m) a -- ^ source - -> m () -{-# INLINE unsafeMove #-} -unsafeMove = G.unsafeMove - --- | Compute the next (lexicographically) permutation of given vector in-place. --- Returns False when input is the last permtuation -nextPermutation :: (PrimMonad m,Ord e) => MVector (PrimState m) e -> m Bool -{-# INLINE nextPermutation #-} -nextPermutation = G.nextPermutation diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Primitive.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Primitive.hs deleted file mode 100644 index ba18f9ba957f..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Primitive.hs +++ /dev/null @@ -1,1393 +0,0 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, ScopedTypeVariables, Rank2Types #-} - --- | --- Module : Data.Vector.Primitive --- Copyright : (c) Roman Leshchinskiy 2008-2010 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Stability : experimental --- Portability : non-portable --- --- Unboxed vectors of primitive types. The use of this module is not --- recommended except in very special cases. Adaptive unboxed vectors defined --- in "Data.Vector.Unboxed" are significantly more flexible at no performance --- cost. --- - -module Data.Vector.Primitive ( - -- * Primitive vectors - Vector(..), MVector(..), Prim, - - -- * Accessors - - -- ** Length information - length, null, - - -- ** Indexing - (!), (!?), head, last, - unsafeIndex, unsafeHead, unsafeLast, - - -- ** Monadic indexing - indexM, headM, lastM, - unsafeIndexM, unsafeHeadM, unsafeLastM, - - -- ** Extracting subvectors (slicing) - slice, init, tail, take, drop, splitAt, - unsafeSlice, unsafeInit, unsafeTail, unsafeTake, unsafeDrop, - - -- * Construction - - -- ** Initialisation - empty, singleton, replicate, generate, iterateN, - - -- ** Monadic initialisation - replicateM, generateM, iterateNM, create, createT, - - -- ** Unfolding - unfoldr, unfoldrN, - unfoldrM, unfoldrNM, - constructN, constructrN, - - -- ** Enumeration - enumFromN, enumFromStepN, enumFromTo, enumFromThenTo, - - -- ** Concatenation - cons, snoc, (++), concat, - - -- ** Restricting memory usage - force, - - -- * Modifying vectors - - -- ** Bulk updates - (//), update_, - unsafeUpd, unsafeUpdate_, - - -- ** Accumulations - accum, accumulate_, - unsafeAccum, unsafeAccumulate_, - - -- ** Permutations - reverse, backpermute, unsafeBackpermute, - - -- ** Safe destructive updates - modify, - - -- * Elementwise operations - - -- ** Mapping - map, imap, concatMap, - - -- ** Monadic mapping - mapM, mapM_, forM, forM_, - - -- ** Zipping - zipWith, zipWith3, zipWith4, zipWith5, zipWith6, - izipWith, izipWith3, izipWith4, izipWith5, izipWith6, - - -- ** Monadic zipping - zipWithM, zipWithM_, - - -- * Working with predicates - - -- ** Filtering - filter, ifilter, uniq, - mapMaybe, imapMaybe, - filterM, - takeWhile, dropWhile, - - -- ** Partitioning - partition, unstablePartition, span, break, - - -- ** Searching - elem, notElem, find, findIndex, findIndices, elemIndex, elemIndices, - - -- * Folding - foldl, foldl1, foldl', foldl1', foldr, foldr1, foldr', foldr1', - ifoldl, ifoldl', ifoldr, ifoldr', - - -- ** Specialised folds - all, any, - sum, product, - maximum, maximumBy, minimum, minimumBy, - minIndex, minIndexBy, maxIndex, maxIndexBy, - - -- ** Monadic folds - foldM, foldM', fold1M, fold1M', - foldM_, foldM'_, fold1M_, fold1M'_, - - -- * Prefix sums (scans) - prescanl, prescanl', - postscanl, postscanl', - scanl, scanl', scanl1, scanl1', - prescanr, prescanr', - postscanr, postscanr', - scanr, scanr', scanr1, scanr1', - - -- * Conversions - - -- ** Lists - toList, fromList, fromListN, - - -- ** Other vector types - G.convert, - - -- ** Mutable vectors - freeze, thaw, copy, unsafeFreeze, unsafeThaw, unsafeCopy -) where - -import qualified Data.Vector.Generic as G -import Data.Vector.Primitive.Mutable ( MVector(..) ) -import qualified Data.Vector.Fusion.Bundle as Bundle -import Data.Primitive.ByteArray -import Data.Primitive ( Prim, sizeOf ) - -import Control.DeepSeq ( NFData(rnf) ) - -import Control.Monad ( liftM ) -import Control.Monad.ST ( ST ) -import Control.Monad.Primitive - -import Prelude hiding ( length, null, - replicate, (++), concat, - head, last, - init, tail, take, drop, splitAt, reverse, - map, concatMap, - zipWith, zipWith3, zip, zip3, unzip, unzip3, - filter, takeWhile, dropWhile, span, break, - elem, notElem, - foldl, foldl1, foldr, foldr1, - all, any, sum, product, minimum, maximum, - scanl, scanl1, scanr, scanr1, - enumFromTo, enumFromThenTo, - mapM, mapM_ ) - -import Data.Typeable ( Typeable ) -import Data.Data ( Data(..) ) -import Text.Read ( Read(..), readListPrecDefault ) -import Data.Semigroup ( Semigroup(..) ) - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid ( Monoid(..) ) -import Data.Traversable ( Traversable ) -#endif - -#if __GLASGOW_HASKELL__ >= 708 -import qualified GHC.Exts as Exts -#endif - --- | Unboxed vectors of primitive types -data Vector a = Vector {-# UNPACK #-} !Int - {-# UNPACK #-} !Int - {-# UNPACK #-} !ByteArray -- ^ offset, length, underlying byte array - deriving ( Typeable ) - -instance NFData (Vector a) where - rnf (Vector _ _ _) = () - -instance (Show a, Prim a) => Show (Vector a) where - showsPrec = G.showsPrec - -instance (Read a, Prim a) => Read (Vector a) where - readPrec = G.readPrec - readListPrec = readListPrecDefault - -instance (Data a, Prim a) => Data (Vector a) where - gfoldl = G.gfoldl - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = G.mkType "Data.Vector.Primitive.Vector" - dataCast1 = G.dataCast - - -type instance G.Mutable Vector = MVector - -instance Prim a => G.Vector Vector a where - {-# INLINE basicUnsafeFreeze #-} - basicUnsafeFreeze (MVector i n marr) - = Vector i n `liftM` unsafeFreezeByteArray marr - - {-# INLINE basicUnsafeThaw #-} - basicUnsafeThaw (Vector i n arr) - = MVector i n `liftM` unsafeThawByteArray arr - - {-# INLINE basicLength #-} - basicLength (Vector _ n _) = n - - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice j n (Vector i _ arr) = Vector (i+j) n arr - - {-# INLINE basicUnsafeIndexM #-} - basicUnsafeIndexM (Vector i _ arr) j = return $! indexByteArray arr (i+j) - - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy (MVector i n dst) (Vector j _ src) - = copyByteArray dst (i*sz) src (j*sz) (n*sz) - where - sz = sizeOf (undefined :: a) - - {-# INLINE elemseq #-} - elemseq _ = seq - --- See http://trac.haskell.org/vector/ticket/12 -instance (Prim a, Eq a) => Eq (Vector a) where - {-# INLINE (==) #-} - xs == ys = Bundle.eq (G.stream xs) (G.stream ys) - - {-# INLINE (/=) #-} - xs /= ys = not (Bundle.eq (G.stream xs) (G.stream ys)) - --- See http://trac.haskell.org/vector/ticket/12 -instance (Prim a, Ord a) => Ord (Vector a) where - {-# INLINE compare #-} - compare xs ys = Bundle.cmp (G.stream xs) (G.stream ys) - - {-# INLINE (<) #-} - xs < ys = Bundle.cmp (G.stream xs) (G.stream ys) == LT - - {-# INLINE (<=) #-} - xs <= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= GT - - {-# INLINE (>) #-} - xs > ys = Bundle.cmp (G.stream xs) (G.stream ys) == GT - - {-# INLINE (>=) #-} - xs >= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= LT - -instance Prim a => Semigroup (Vector a) where - {-# INLINE (<>) #-} - (<>) = (++) - - {-# INLINE sconcat #-} - sconcat = G.concatNE - -instance Prim a => Monoid (Vector a) where - {-# INLINE mempty #-} - mempty = empty - - {-# INLINE mappend #-} - mappend = (++) - - {-# INLINE mconcat #-} - mconcat = concat - -#if __GLASGOW_HASKELL__ >= 708 - -instance Prim a => Exts.IsList (Vector a) where - type Item (Vector a) = a - fromList = fromList - fromListN = fromListN - toList = toList - -#endif --- Length --- ------ - --- | /O(1)/ Yield the length of the vector -length :: Prim a => Vector a -> Int -{-# INLINE length #-} -length = G.length - --- | /O(1)/ Test whether a vector is empty -null :: Prim a => Vector a -> Bool -{-# INLINE null #-} -null = G.null - --- Indexing --- -------- - --- | O(1) Indexing -(!) :: Prim a => Vector a -> Int -> a -{-# INLINE (!) #-} -(!) = (G.!) - --- | O(1) Safe indexing -(!?) :: Prim a => Vector a -> Int -> Maybe a -{-# INLINE (!?) #-} -(!?) = (G.!?) - --- | /O(1)/ First element -head :: Prim a => Vector a -> a -{-# INLINE head #-} -head = G.head - --- | /O(1)/ Last element -last :: Prim a => Vector a -> a -{-# INLINE last #-} -last = G.last - --- | /O(1)/ Unsafe indexing without bounds checking -unsafeIndex :: Prim a => Vector a -> Int -> a -{-# INLINE unsafeIndex #-} -unsafeIndex = G.unsafeIndex - --- | /O(1)/ First element without checking if the vector is empty -unsafeHead :: Prim a => Vector a -> a -{-# INLINE unsafeHead #-} -unsafeHead = G.unsafeHead - --- | /O(1)/ Last element without checking if the vector is empty -unsafeLast :: Prim a => Vector a -> a -{-# INLINE unsafeLast #-} -unsafeLast = G.unsafeLast - --- Monadic indexing --- ---------------- - --- | /O(1)/ Indexing in a monad. --- --- The monad allows operations to be strict in the vector when necessary. --- Suppose vector copying is implemented like this: --- --- > copy mv v = ... write mv i (v ! i) ... --- --- For lazy vectors, @v ! i@ would not be evaluated which means that @mv@ --- would unnecessarily retain a reference to @v@ in each element written. --- --- With 'indexM', copying can be implemented like this instead: --- --- > copy mv v = ... do --- > x <- indexM v i --- > write mv i x --- --- Here, no references to @v@ are retained because indexing (but /not/ the --- elements) is evaluated eagerly. --- -indexM :: (Prim a, Monad m) => Vector a -> Int -> m a -{-# INLINE indexM #-} -indexM = G.indexM - --- | /O(1)/ First element of a vector in a monad. See 'indexM' for an --- explanation of why this is useful. -headM :: (Prim a, Monad m) => Vector a -> m a -{-# INLINE headM #-} -headM = G.headM - --- | /O(1)/ Last element of a vector in a monad. See 'indexM' for an --- explanation of why this is useful. -lastM :: (Prim a, Monad m) => Vector a -> m a -{-# INLINE lastM #-} -lastM = G.lastM - --- | /O(1)/ Indexing in a monad without bounds checks. See 'indexM' for an --- explanation of why this is useful. -unsafeIndexM :: (Prim a, Monad m) => Vector a -> Int -> m a -{-# INLINE unsafeIndexM #-} -unsafeIndexM = G.unsafeIndexM - --- | /O(1)/ First element in a monad without checking for empty vectors. --- See 'indexM' for an explanation of why this is useful. -unsafeHeadM :: (Prim a, Monad m) => Vector a -> m a -{-# INLINE unsafeHeadM #-} -unsafeHeadM = G.unsafeHeadM - --- | /O(1)/ Last element in a monad without checking for empty vectors. --- See 'indexM' for an explanation of why this is useful. -unsafeLastM :: (Prim a, Monad m) => Vector a -> m a -{-# INLINE unsafeLastM #-} -unsafeLastM = G.unsafeLastM - --- Extracting subvectors (slicing) --- ------------------------------- - --- | /O(1)/ Yield a slice of the vector without copying it. The vector must --- contain at least @i+n@ elements. -slice :: Prim a - => Int -- ^ @i@ starting index - -> Int -- ^ @n@ length - -> Vector a - -> Vector a -{-# INLINE slice #-} -slice = G.slice - --- | /O(1)/ Yield all but the last element without copying. The vector may not --- be empty. -init :: Prim a => Vector a -> Vector a -{-# INLINE init #-} -init = G.init - --- | /O(1)/ Yield all but the first element without copying. The vector may not --- be empty. -tail :: Prim a => Vector a -> Vector a -{-# INLINE tail #-} -tail = G.tail - --- | /O(1)/ Yield at the first @n@ elements without copying. The vector may --- contain less than @n@ elements in which case it is returned unchanged. -take :: Prim a => Int -> Vector a -> Vector a -{-# INLINE take #-} -take = G.take - --- | /O(1)/ Yield all but the first @n@ elements without copying. The vector may --- contain less than @n@ elements in which case an empty vector is returned. -drop :: Prim a => Int -> Vector a -> Vector a -{-# INLINE drop #-} -drop = G.drop - --- | /O(1)/ Yield the first @n@ elements paired with the remainder without copying. --- --- Note that @'splitAt' n v@ is equivalent to @('take' n v, 'drop' n v)@ --- but slightly more efficient. -{-# INLINE splitAt #-} -splitAt :: Prim a => Int -> Vector a -> (Vector a, Vector a) -splitAt = G.splitAt - --- | /O(1)/ Yield a slice of the vector without copying. The vector must --- contain at least @i+n@ elements but this is not checked. -unsafeSlice :: Prim a => Int -- ^ @i@ starting index - -> Int -- ^ @n@ length - -> Vector a - -> Vector a -{-# INLINE unsafeSlice #-} -unsafeSlice = G.unsafeSlice - --- | /O(1)/ Yield all but the last element without copying. The vector may not --- be empty but this is not checked. -unsafeInit :: Prim a => Vector a -> Vector a -{-# INLINE unsafeInit #-} -unsafeInit = G.unsafeInit - --- | /O(1)/ Yield all but the first element without copying. The vector may not --- be empty but this is not checked. -unsafeTail :: Prim a => Vector a -> Vector a -{-# INLINE unsafeTail #-} -unsafeTail = G.unsafeTail - --- | /O(1)/ Yield the first @n@ elements without copying. The vector must --- contain at least @n@ elements but this is not checked. -unsafeTake :: Prim a => Int -> Vector a -> Vector a -{-# INLINE unsafeTake #-} -unsafeTake = G.unsafeTake - --- | /O(1)/ Yield all but the first @n@ elements without copying. The vector --- must contain at least @n@ elements but this is not checked. -unsafeDrop :: Prim a => Int -> Vector a -> Vector a -{-# INLINE unsafeDrop #-} -unsafeDrop = G.unsafeDrop - --- Initialisation --- -------------- - --- | /O(1)/ Empty vector -empty :: Prim a => Vector a -{-# INLINE empty #-} -empty = G.empty - --- | /O(1)/ Vector with exactly one element -singleton :: Prim a => a -> Vector a -{-# INLINE singleton #-} -singleton = G.singleton - --- | /O(n)/ Vector of the given length with the same value in each position -replicate :: Prim a => Int -> a -> Vector a -{-# INLINE replicate #-} -replicate = G.replicate - --- | /O(n)/ Construct a vector of the given length by applying the function to --- each index -generate :: Prim a => Int -> (Int -> a) -> Vector a -{-# INLINE generate #-} -generate = G.generate - --- | /O(n)/ Apply function n times to value. Zeroth element is original value. -iterateN :: Prim a => Int -> (a -> a) -> a -> Vector a -{-# INLINE iterateN #-} -iterateN = G.iterateN - --- Unfolding --- --------- - --- | /O(n)/ Construct a vector by repeatedly applying the generator function --- to a seed. The generator function yields 'Just' the next element and the --- new seed or 'Nothing' if there are no more elements. --- --- > unfoldr (\n -> if n == 0 then Nothing else Just (n,n-1)) 10 --- > = <10,9,8,7,6,5,4,3,2,1> -unfoldr :: Prim a => (b -> Maybe (a, b)) -> b -> Vector a -{-# INLINE unfoldr #-} -unfoldr = G.unfoldr - --- | /O(n)/ Construct a vector with at most @n@ elements by repeatedly applying --- the generator function to a seed. The generator function yields 'Just' the --- next element and the new seed or 'Nothing' if there are no more elements. --- --- > unfoldrN 3 (\n -> Just (n,n-1)) 10 = <10,9,8> -unfoldrN :: Prim a => Int -> (b -> Maybe (a, b)) -> b -> Vector a -{-# INLINE unfoldrN #-} -unfoldrN = G.unfoldrN - --- | /O(n)/ Construct a vector by repeatedly applying the monadic --- generator function to a seed. The generator function yields 'Just' --- the next element and the new seed or 'Nothing' if there are no more --- elements. -unfoldrM :: (Monad m, Prim a) => (b -> m (Maybe (a, b))) -> b -> m (Vector a) -{-# INLINE unfoldrM #-} -unfoldrM = G.unfoldrM - --- | /O(n)/ Construct a vector by repeatedly applying the monadic --- generator function to a seed. The generator function yields 'Just' --- the next element and the new seed or 'Nothing' if there are no more --- elements. -unfoldrNM :: (Monad m, Prim a) => Int -> (b -> m (Maybe (a, b))) -> b -> m (Vector a) -{-# INLINE unfoldrNM #-} -unfoldrNM = G.unfoldrNM - --- | /O(n)/ Construct a vector with @n@ elements by repeatedly applying the --- generator function to the already constructed part of the vector. --- --- > constructN 3 f = let a = f <> ; b = f <a> ; c = f <a,b> in f <a,b,c> --- -constructN :: Prim a => Int -> (Vector a -> a) -> Vector a -{-# INLINE constructN #-} -constructN = G.constructN - --- | /O(n)/ Construct a vector with @n@ elements from right to left by --- repeatedly applying the generator function to the already constructed part --- of the vector. --- --- > constructrN 3 f = let a = f <> ; b = f<a> ; c = f <b,a> in f <c,b,a> --- -constructrN :: Prim a => Int -> (Vector a -> a) -> Vector a -{-# INLINE constructrN #-} -constructrN = G.constructrN - --- Enumeration --- ----------- - --- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+1@ --- etc. This operation is usually more efficient than 'enumFromTo'. --- --- > enumFromN 5 3 = <5,6,7> -enumFromN :: (Prim a, Num a) => a -> Int -> Vector a -{-# INLINE enumFromN #-} -enumFromN = G.enumFromN - --- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+y@, --- @x+y+y@ etc. This operations is usually more efficient than 'enumFromThenTo'. --- --- > enumFromStepN 1 0.1 5 = <1,1.1,1.2,1.3,1.4> -enumFromStepN :: (Prim a, Num a) => a -> a -> Int -> Vector a -{-# INLINE enumFromStepN #-} -enumFromStepN = G.enumFromStepN - --- | /O(n)/ Enumerate values from @x@ to @y@. --- --- /WARNING:/ This operation can be very inefficient. If at all possible, use --- 'enumFromN' instead. -enumFromTo :: (Prim a, Enum a) => a -> a -> Vector a -{-# INLINE enumFromTo #-} -enumFromTo = G.enumFromTo - --- | /O(n)/ Enumerate values from @x@ to @y@ with a specific step @z@. --- --- /WARNING:/ This operation can be very inefficient. If at all possible, use --- 'enumFromStepN' instead. -enumFromThenTo :: (Prim a, Enum a) => a -> a -> a -> Vector a -{-# INLINE enumFromThenTo #-} -enumFromThenTo = G.enumFromThenTo - --- Concatenation --- ------------- - --- | /O(n)/ Prepend an element -cons :: Prim a => a -> Vector a -> Vector a -{-# INLINE cons #-} -cons = G.cons - --- | /O(n)/ Append an element -snoc :: Prim a => Vector a -> a -> Vector a -{-# INLINE snoc #-} -snoc = G.snoc - -infixr 5 ++ --- | /O(m+n)/ Concatenate two vectors -(++) :: Prim a => Vector a -> Vector a -> Vector a -{-# INLINE (++) #-} -(++) = (G.++) - --- | /O(n)/ Concatenate all vectors in the list -concat :: Prim a => [Vector a] -> Vector a -{-# INLINE concat #-} -concat = G.concat - --- Monadic initialisation --- ---------------------- - --- | /O(n)/ Execute the monadic action the given number of times and store the --- results in a vector. -replicateM :: (Monad m, Prim a) => Int -> m a -> m (Vector a) -{-# INLINE replicateM #-} -replicateM = G.replicateM - --- | /O(n)/ Construct a vector of the given length by applying the monadic --- action to each index -generateM :: (Monad m, Prim a) => Int -> (Int -> m a) -> m (Vector a) -{-# INLINE generateM #-} -generateM = G.generateM - --- | /O(n)/ Apply monadic function n times to value. Zeroth element is original value. -iterateNM :: (Monad m, Prim a) => Int -> (a -> m a) -> a -> m (Vector a) -{-# INLINE iterateNM #-} -iterateNM = G.iterateNM - --- | Execute the monadic action and freeze the resulting vector. --- --- @ --- create (do { v \<- new 2; write v 0 \'a\'; write v 1 \'b\'; return v }) = \<'a','b'\> --- @ -create :: Prim a => (forall s. ST s (MVector s a)) -> Vector a -{-# INLINE create #-} --- NOTE: eta-expanded due to http://hackage.haskell.org/trac/ghc/ticket/4120 -create p = G.create p - --- | Execute the monadic action and freeze the resulting vectors. -createT :: (Traversable f, Prim a) => (forall s. ST s (f (MVector s a))) -> f (Vector a) -{-# INLINE createT #-} -createT p = G.createT p - --- Restricting memory usage --- ------------------------ - --- | /O(n)/ Yield the argument but force it not to retain any extra memory, --- possibly by copying it. --- --- This is especially useful when dealing with slices. For example: --- --- > force (slice 0 2 <huge vector>) --- --- Here, the slice retains a reference to the huge vector. Forcing it creates --- a copy of just the elements that belong to the slice and allows the huge --- vector to be garbage collected. -force :: Prim a => Vector a -> Vector a -{-# INLINE force #-} -force = G.force - --- Bulk updates --- ------------ - --- | /O(m+n)/ For each pair @(i,a)@ from the list, replace the vector --- element at position @i@ by @a@. --- --- > <5,9,2,7> // [(2,1),(0,3),(2,8)] = <3,9,8,7> --- -(//) :: Prim a => Vector a -- ^ initial vector (of length @m@) - -> [(Int, a)] -- ^ list of index/value pairs (of length @n@) - -> Vector a -{-# INLINE (//) #-} -(//) = (G.//) - --- | /O(m+min(n1,n2))/ For each index @i@ from the index vector and the --- corresponding value @a@ from the value vector, replace the element of the --- initial vector at position @i@ by @a@. --- --- > update_ <5,9,2,7> <2,0,2> <1,3,8> = <3,9,8,7> --- -update_ :: Prim a - => Vector a -- ^ initial vector (of length @m@) - -> Vector Int -- ^ index vector (of length @n1@) - -> Vector a -- ^ value vector (of length @n2@) - -> Vector a -{-# INLINE update_ #-} -update_ = G.update_ - --- | Same as ('//') but without bounds checking. -unsafeUpd :: Prim a => Vector a -> [(Int, a)] -> Vector a -{-# INLINE unsafeUpd #-} -unsafeUpd = G.unsafeUpd - --- | Same as 'update_' but without bounds checking. -unsafeUpdate_ :: Prim a => Vector a -> Vector Int -> Vector a -> Vector a -{-# INLINE unsafeUpdate_ #-} -unsafeUpdate_ = G.unsafeUpdate_ - --- Accumulations --- ------------- - --- | /O(m+n)/ For each pair @(i,b)@ from the list, replace the vector element --- @a@ at position @i@ by @f a b@. --- --- > accum (+) <5,9,2> [(2,4),(1,6),(0,3),(1,7)] = <5+3, 9+6+7, 2+4> -accum :: Prim a - => (a -> b -> a) -- ^ accumulating function @f@ - -> Vector a -- ^ initial vector (of length @m@) - -> [(Int,b)] -- ^ list of index/value pairs (of length @n@) - -> Vector a -{-# INLINE accum #-} -accum = G.accum - --- | /O(m+min(n1,n2))/ For each index @i@ from the index vector and the --- corresponding value @b@ from the the value vector, --- replace the element of the initial vector at --- position @i@ by @f a b@. --- --- > accumulate_ (+) <5,9,2> <2,1,0,1> <4,6,3,7> = <5+3, 9+6+7, 2+4> --- -accumulate_ :: (Prim a, Prim b) - => (a -> b -> a) -- ^ accumulating function @f@ - -> Vector a -- ^ initial vector (of length @m@) - -> Vector Int -- ^ index vector (of length @n1@) - -> Vector b -- ^ value vector (of length @n2@) - -> Vector a -{-# INLINE accumulate_ #-} -accumulate_ = G.accumulate_ - --- | Same as 'accum' but without bounds checking. -unsafeAccum :: Prim a => (a -> b -> a) -> Vector a -> [(Int,b)] -> Vector a -{-# INLINE unsafeAccum #-} -unsafeAccum = G.unsafeAccum - --- | Same as 'accumulate_' but without bounds checking. -unsafeAccumulate_ :: (Prim a, Prim b) => - (a -> b -> a) -> Vector a -> Vector Int -> Vector b -> Vector a -{-# INLINE unsafeAccumulate_ #-} -unsafeAccumulate_ = G.unsafeAccumulate_ - --- Permutations --- ------------ - --- | /O(n)/ Reverse a vector -reverse :: Prim a => Vector a -> Vector a -{-# INLINE reverse #-} -reverse = G.reverse - --- | /O(n)/ Yield the vector obtained by replacing each element @i@ of the --- index vector by @xs'!'i@. This is equivalent to @'map' (xs'!') is@ but is --- often much more efficient. --- --- > backpermute <a,b,c,d> <0,3,2,3,1,0> = <a,d,c,d,b,a> -backpermute :: Prim a => Vector a -> Vector Int -> Vector a -{-# INLINE backpermute #-} -backpermute = G.backpermute - --- | Same as 'backpermute' but without bounds checking. -unsafeBackpermute :: Prim a => Vector a -> Vector Int -> Vector a -{-# INLINE unsafeBackpermute #-} -unsafeBackpermute = G.unsafeBackpermute - --- Safe destructive updates --- ------------------------ - --- | Apply a destructive operation to a vector. The operation will be --- performed in place if it is safe to do so and will modify a copy of the --- vector otherwise. --- --- @ --- modify (\\v -> write v 0 \'x\') ('replicate' 3 \'a\') = \<\'x\',\'a\',\'a\'\> --- @ -modify :: Prim a => (forall s. MVector s a -> ST s ()) -> Vector a -> Vector a -{-# INLINE modify #-} -modify p = G.modify p - --- Mapping --- ------- - --- | /O(n)/ Map a function over a vector -map :: (Prim a, Prim b) => (a -> b) -> Vector a -> Vector b -{-# INLINE map #-} -map = G.map - --- | /O(n)/ Apply a function to every element of a vector and its index -imap :: (Prim a, Prim b) => (Int -> a -> b) -> Vector a -> Vector b -{-# INLINE imap #-} -imap = G.imap - --- | Map a function over a vector and concatenate the results. -concatMap :: (Prim a, Prim b) => (a -> Vector b) -> Vector a -> Vector b -{-# INLINE concatMap #-} -concatMap = G.concatMap - --- Monadic mapping --- --------------- - --- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a --- vector of results -mapM :: (Monad m, Prim a, Prim b) => (a -> m b) -> Vector a -> m (Vector b) -{-# INLINE mapM #-} -mapM = G.mapM - --- | /O(n)/ Apply the monadic action to all elements of a vector and ignore the --- results -mapM_ :: (Monad m, Prim a) => (a -> m b) -> Vector a -> m () -{-# INLINE mapM_ #-} -mapM_ = G.mapM_ - --- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a --- vector of results. Equivalent to @flip 'mapM'@. -forM :: (Monad m, Prim a, Prim b) => Vector a -> (a -> m b) -> m (Vector b) -{-# INLINE forM #-} -forM = G.forM - --- | /O(n)/ Apply the monadic action to all elements of a vector and ignore the --- results. Equivalent to @flip 'mapM_'@. -forM_ :: (Monad m, Prim a) => Vector a -> (a -> m b) -> m () -{-# INLINE forM_ #-} -forM_ = G.forM_ - --- Zipping --- ------- - --- | /O(min(m,n))/ Zip two vectors with the given function. -zipWith :: (Prim a, Prim b, Prim c) - => (a -> b -> c) -> Vector a -> Vector b -> Vector c -{-# INLINE zipWith #-} -zipWith = G.zipWith - --- | Zip three vectors with the given function. -zipWith3 :: (Prim a, Prim b, Prim c, Prim d) - => (a -> b -> c -> d) -> Vector a -> Vector b -> Vector c -> Vector d -{-# INLINE zipWith3 #-} -zipWith3 = G.zipWith3 - -zipWith4 :: (Prim a, Prim b, Prim c, Prim d, Prim e) - => (a -> b -> c -> d -> e) - -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e -{-# INLINE zipWith4 #-} -zipWith4 = G.zipWith4 - -zipWith5 :: (Prim a, Prim b, Prim c, Prim d, Prim e, - Prim f) - => (a -> b -> c -> d -> e -> f) - -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e - -> Vector f -{-# INLINE zipWith5 #-} -zipWith5 = G.zipWith5 - -zipWith6 :: (Prim a, Prim b, Prim c, Prim d, Prim e, - Prim f, Prim g) - => (a -> b -> c -> d -> e -> f -> g) - -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e - -> Vector f -> Vector g -{-# INLINE zipWith6 #-} -zipWith6 = G.zipWith6 - --- | /O(min(m,n))/ Zip two vectors with a function that also takes the --- elements' indices. -izipWith :: (Prim a, Prim b, Prim c) - => (Int -> a -> b -> c) -> Vector a -> Vector b -> Vector c -{-# INLINE izipWith #-} -izipWith = G.izipWith - --- | Zip three vectors and their indices with the given function. -izipWith3 :: (Prim a, Prim b, Prim c, Prim d) - => (Int -> a -> b -> c -> d) - -> Vector a -> Vector b -> Vector c -> Vector d -{-# INLINE izipWith3 #-} -izipWith3 = G.izipWith3 - -izipWith4 :: (Prim a, Prim b, Prim c, Prim d, Prim e) - => (Int -> a -> b -> c -> d -> e) - -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e -{-# INLINE izipWith4 #-} -izipWith4 = G.izipWith4 - -izipWith5 :: (Prim a, Prim b, Prim c, Prim d, Prim e, - Prim f) - => (Int -> a -> b -> c -> d -> e -> f) - -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e - -> Vector f -{-# INLINE izipWith5 #-} -izipWith5 = G.izipWith5 - -izipWith6 :: (Prim a, Prim b, Prim c, Prim d, Prim e, - Prim f, Prim g) - => (Int -> a -> b -> c -> d -> e -> f -> g) - -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e - -> Vector f -> Vector g -{-# INLINE izipWith6 #-} -izipWith6 = G.izipWith6 - --- Monadic zipping --- --------------- - --- | /O(min(m,n))/ Zip the two vectors with the monadic action and yield a --- vector of results -zipWithM :: (Monad m, Prim a, Prim b, Prim c) - => (a -> b -> m c) -> Vector a -> Vector b -> m (Vector c) -{-# INLINE zipWithM #-} -zipWithM = G.zipWithM - --- | /O(min(m,n))/ Zip the two vectors with the monadic action and ignore the --- results -zipWithM_ :: (Monad m, Prim a, Prim b) - => (a -> b -> m c) -> Vector a -> Vector b -> m () -{-# INLINE zipWithM_ #-} -zipWithM_ = G.zipWithM_ - --- Filtering --- --------- - --- | /O(n)/ Drop elements that do not satisfy the predicate -filter :: Prim a => (a -> Bool) -> Vector a -> Vector a -{-# INLINE filter #-} -filter = G.filter - --- | /O(n)/ Drop elements that do not satisfy the predicate which is applied to --- values and their indices -ifilter :: Prim a => (Int -> a -> Bool) -> Vector a -> Vector a -{-# INLINE ifilter #-} -ifilter = G.ifilter - --- | /O(n)/ Drop repeated adjacent elements. -uniq :: (Prim a, Eq a) => Vector a -> Vector a -{-# INLINE uniq #-} -uniq = G.uniq - --- | /O(n)/ Drop elements when predicate returns Nothing -mapMaybe :: (Prim a, Prim b) => (a -> Maybe b) -> Vector a -> Vector b -{-# INLINE mapMaybe #-} -mapMaybe = G.mapMaybe - --- | /O(n)/ Drop elements when predicate, applied to index and value, returns Nothing -imapMaybe :: (Prim a, Prim b) => (Int -> a -> Maybe b) -> Vector a -> Vector b -{-# INLINE imapMaybe #-} -imapMaybe = G.imapMaybe - --- | /O(n)/ Drop elements that do not satisfy the monadic predicate -filterM :: (Monad m, Prim a) => (a -> m Bool) -> Vector a -> m (Vector a) -{-# INLINE filterM #-} -filterM = G.filterM - --- | /O(n)/ Yield the longest prefix of elements satisfying the predicate --- without copying. -takeWhile :: Prim a => (a -> Bool) -> Vector a -> Vector a -{-# INLINE takeWhile #-} -takeWhile = G.takeWhile - --- | /O(n)/ Drop the longest prefix of elements that satisfy the predicate --- without copying. -dropWhile :: Prim a => (a -> Bool) -> Vector a -> Vector a -{-# INLINE dropWhile #-} -dropWhile = G.dropWhile - --- Parititioning --- ------------- - --- | /O(n)/ Split the vector in two parts, the first one containing those --- elements that satisfy the predicate and the second one those that don't. The --- relative order of the elements is preserved at the cost of a sometimes --- reduced performance compared to 'unstablePartition'. -partition :: Prim a => (a -> Bool) -> Vector a -> (Vector a, Vector a) -{-# INLINE partition #-} -partition = G.partition - --- | /O(n)/ Split the vector in two parts, the first one containing those --- elements that satisfy the predicate and the second one those that don't. --- The order of the elements is not preserved but the operation is often --- faster than 'partition'. -unstablePartition :: Prim a => (a -> Bool) -> Vector a -> (Vector a, Vector a) -{-# INLINE unstablePartition #-} -unstablePartition = G.unstablePartition - --- | /O(n)/ Split the vector into the longest prefix of elements that satisfy --- the predicate and the rest without copying. -span :: Prim a => (a -> Bool) -> Vector a -> (Vector a, Vector a) -{-# INLINE span #-} -span = G.span - --- | /O(n)/ Split the vector into the longest prefix of elements that do not --- satisfy the predicate and the rest without copying. -break :: Prim a => (a -> Bool) -> Vector a -> (Vector a, Vector a) -{-# INLINE break #-} -break = G.break - --- Searching --- --------- - -infix 4 `elem` --- | /O(n)/ Check if the vector contains an element -elem :: (Prim a, Eq a) => a -> Vector a -> Bool -{-# INLINE elem #-} -elem = G.elem - -infix 4 `notElem` --- | /O(n)/ Check if the vector does not contain an element (inverse of 'elem') -notElem :: (Prim a, Eq a) => a -> Vector a -> Bool -{-# INLINE notElem #-} -notElem = G.notElem - --- | /O(n)/ Yield 'Just' the first element matching the predicate or 'Nothing' --- if no such element exists. -find :: Prim a => (a -> Bool) -> Vector a -> Maybe a -{-# INLINE find #-} -find = G.find - --- | /O(n)/ Yield 'Just' the index of the first element matching the predicate --- or 'Nothing' if no such element exists. -findIndex :: Prim a => (a -> Bool) -> Vector a -> Maybe Int -{-# INLINE findIndex #-} -findIndex = G.findIndex - --- | /O(n)/ Yield the indices of elements satisfying the predicate in ascending --- order. -findIndices :: Prim a => (a -> Bool) -> Vector a -> Vector Int -{-# INLINE findIndices #-} -findIndices = G.findIndices - --- | /O(n)/ Yield 'Just' the index of the first occurence of the given element or --- 'Nothing' if the vector does not contain the element. This is a specialised --- version of 'findIndex'. -elemIndex :: (Prim a, Eq a) => a -> Vector a -> Maybe Int -{-# INLINE elemIndex #-} -elemIndex = G.elemIndex - --- | /O(n)/ Yield the indices of all occurences of the given element in --- ascending order. This is a specialised version of 'findIndices'. -elemIndices :: (Prim a, Eq a) => a -> Vector a -> Vector Int -{-# INLINE elemIndices #-} -elemIndices = G.elemIndices - --- Folding --- ------- - --- | /O(n)/ Left fold -foldl :: Prim b => (a -> b -> a) -> a -> Vector b -> a -{-# INLINE foldl #-} -foldl = G.foldl - --- | /O(n)/ Left fold on non-empty vectors -foldl1 :: Prim a => (a -> a -> a) -> Vector a -> a -{-# INLINE foldl1 #-} -foldl1 = G.foldl1 - --- | /O(n)/ Left fold with strict accumulator -foldl' :: Prim b => (a -> b -> a) -> a -> Vector b -> a -{-# INLINE foldl' #-} -foldl' = G.foldl' - --- | /O(n)/ Left fold on non-empty vectors with strict accumulator -foldl1' :: Prim a => (a -> a -> a) -> Vector a -> a -{-# INLINE foldl1' #-} -foldl1' = G.foldl1' - --- | /O(n)/ Right fold -foldr :: Prim a => (a -> b -> b) -> b -> Vector a -> b -{-# INLINE foldr #-} -foldr = G.foldr - --- | /O(n)/ Right fold on non-empty vectors -foldr1 :: Prim a => (a -> a -> a) -> Vector a -> a -{-# INLINE foldr1 #-} -foldr1 = G.foldr1 - --- | /O(n)/ Right fold with a strict accumulator -foldr' :: Prim a => (a -> b -> b) -> b -> Vector a -> b -{-# INLINE foldr' #-} -foldr' = G.foldr' - --- | /O(n)/ Right fold on non-empty vectors with strict accumulator -foldr1' :: Prim a => (a -> a -> a) -> Vector a -> a -{-# INLINE foldr1' #-} -foldr1' = G.foldr1' - --- | /O(n)/ Left fold (function applied to each element and its index) -ifoldl :: Prim b => (a -> Int -> b -> a) -> a -> Vector b -> a -{-# INLINE ifoldl #-} -ifoldl = G.ifoldl - --- | /O(n)/ Left fold with strict accumulator (function applied to each element --- and its index) -ifoldl' :: Prim b => (a -> Int -> b -> a) -> a -> Vector b -> a -{-# INLINE ifoldl' #-} -ifoldl' = G.ifoldl' - --- | /O(n)/ Right fold (function applied to each element and its index) -ifoldr :: Prim a => (Int -> a -> b -> b) -> b -> Vector a -> b -{-# INLINE ifoldr #-} -ifoldr = G.ifoldr - --- | /O(n)/ Right fold with strict accumulator (function applied to each --- element and its index) -ifoldr' :: Prim a => (Int -> a -> b -> b) -> b -> Vector a -> b -{-# INLINE ifoldr' #-} -ifoldr' = G.ifoldr' - --- Specialised folds --- ----------------- - --- | /O(n)/ Check if all elements satisfy the predicate. -all :: Prim a => (a -> Bool) -> Vector a -> Bool -{-# INLINE all #-} -all = G.all - --- | /O(n)/ Check if any element satisfies the predicate. -any :: Prim a => (a -> Bool) -> Vector a -> Bool -{-# INLINE any #-} -any = G.any - --- | /O(n)/ Compute the sum of the elements -sum :: (Prim a, Num a) => Vector a -> a -{-# INLINE sum #-} -sum = G.sum - --- | /O(n)/ Compute the produce of the elements -product :: (Prim a, Num a) => Vector a -> a -{-# INLINE product #-} -product = G.product - --- | /O(n)/ Yield the maximum element of the vector. The vector may not be --- empty. -maximum :: (Prim a, Ord a) => Vector a -> a -{-# INLINE maximum #-} -maximum = G.maximum - --- | /O(n)/ Yield the maximum element of the vector according to the given --- comparison function. The vector may not be empty. -maximumBy :: Prim a => (a -> a -> Ordering) -> Vector a -> a -{-# INLINE maximumBy #-} -maximumBy = G.maximumBy - --- | /O(n)/ Yield the minimum element of the vector. The vector may not be --- empty. -minimum :: (Prim a, Ord a) => Vector a -> a -{-# INLINE minimum #-} -minimum = G.minimum - --- | /O(n)/ Yield the minimum element of the vector according to the given --- comparison function. The vector may not be empty. -minimumBy :: Prim a => (a -> a -> Ordering) -> Vector a -> a -{-# INLINE minimumBy #-} -minimumBy = G.minimumBy - --- | /O(n)/ Yield the index of the maximum element of the vector. The vector --- may not be empty. -maxIndex :: (Prim a, Ord a) => Vector a -> Int -{-# INLINE maxIndex #-} -maxIndex = G.maxIndex - --- | /O(n)/ Yield the index of the maximum element of the vector according to --- the given comparison function. The vector may not be empty. -maxIndexBy :: Prim a => (a -> a -> Ordering) -> Vector a -> Int -{-# INLINE maxIndexBy #-} -maxIndexBy = G.maxIndexBy - --- | /O(n)/ Yield the index of the minimum element of the vector. The vector --- may not be empty. -minIndex :: (Prim a, Ord a) => Vector a -> Int -{-# INLINE minIndex #-} -minIndex = G.minIndex - --- | /O(n)/ Yield the index of the minimum element of the vector according to --- the given comparison function. The vector may not be empty. -minIndexBy :: Prim a => (a -> a -> Ordering) -> Vector a -> Int -{-# INLINE minIndexBy #-} -minIndexBy = G.minIndexBy - --- Monadic folds --- ------------- - --- | /O(n)/ Monadic fold -foldM :: (Monad m, Prim b) => (a -> b -> m a) -> a -> Vector b -> m a -{-# INLINE foldM #-} -foldM = G.foldM - --- | /O(n)/ Monadic fold over non-empty vectors -fold1M :: (Monad m, Prim a) => (a -> a -> m a) -> Vector a -> m a -{-# INLINE fold1M #-} -fold1M = G.fold1M - --- | /O(n)/ Monadic fold with strict accumulator -foldM' :: (Monad m, Prim b) => (a -> b -> m a) -> a -> Vector b -> m a -{-# INLINE foldM' #-} -foldM' = G.foldM' - --- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator -fold1M' :: (Monad m, Prim a) => (a -> a -> m a) -> Vector a -> m a -{-# INLINE fold1M' #-} -fold1M' = G.fold1M' - --- | /O(n)/ Monadic fold that discards the result -foldM_ :: (Monad m, Prim b) => (a -> b -> m a) -> a -> Vector b -> m () -{-# INLINE foldM_ #-} -foldM_ = G.foldM_ - --- | /O(n)/ Monadic fold over non-empty vectors that discards the result -fold1M_ :: (Monad m, Prim a) => (a -> a -> m a) -> Vector a -> m () -{-# INLINE fold1M_ #-} -fold1M_ = G.fold1M_ - --- | /O(n)/ Monadic fold with strict accumulator that discards the result -foldM'_ :: (Monad m, Prim b) => (a -> b -> m a) -> a -> Vector b -> m () -{-# INLINE foldM'_ #-} -foldM'_ = G.foldM'_ - --- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator --- that discards the result -fold1M'_ :: (Monad m, Prim a) => (a -> a -> m a) -> Vector a -> m () -{-# INLINE fold1M'_ #-} -fold1M'_ = G.fold1M'_ - --- Prefix sums (scans) --- ------------------- - --- | /O(n)/ Prescan --- --- @ --- prescanl f z = 'init' . 'scanl' f z --- @ --- --- Example: @prescanl (+) 0 \<1,2,3,4\> = \<0,1,3,6\>@ --- -prescanl :: (Prim a, Prim b) => (a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE prescanl #-} -prescanl = G.prescanl - --- | /O(n)/ Prescan with strict accumulator -prescanl' :: (Prim a, Prim b) => (a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE prescanl' #-} -prescanl' = G.prescanl' - --- | /O(n)/ Scan --- --- @ --- postscanl f z = 'tail' . 'scanl' f z --- @ --- --- Example: @postscanl (+) 0 \<1,2,3,4\> = \<1,3,6,10\>@ --- -postscanl :: (Prim a, Prim b) => (a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE postscanl #-} -postscanl = G.postscanl - --- | /O(n)/ Scan with strict accumulator -postscanl' :: (Prim a, Prim b) => (a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE postscanl' #-} -postscanl' = G.postscanl' - --- | /O(n)/ Haskell-style scan --- --- > scanl f z <x1,...,xn> = <y1,...,y(n+1)> --- > where y1 = z --- > yi = f y(i-1) x(i-1) --- --- Example: @scanl (+) 0 \<1,2,3,4\> = \<0,1,3,6,10\>@ --- -scanl :: (Prim a, Prim b) => (a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE scanl #-} -scanl = G.scanl - --- | /O(n)/ Haskell-style scan with strict accumulator -scanl' :: (Prim a, Prim b) => (a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE scanl' #-} -scanl' = G.scanl' - --- | /O(n)/ Scan over a non-empty vector --- --- > scanl f <x1,...,xn> = <y1,...,yn> --- > where y1 = x1 --- > yi = f y(i-1) xi --- -scanl1 :: Prim a => (a -> a -> a) -> Vector a -> Vector a -{-# INLINE scanl1 #-} -scanl1 = G.scanl1 - --- | /O(n)/ Scan over a non-empty vector with a strict accumulator -scanl1' :: Prim a => (a -> a -> a) -> Vector a -> Vector a -{-# INLINE scanl1' #-} -scanl1' = G.scanl1' - --- | /O(n)/ Right-to-left prescan --- --- @ --- prescanr f z = 'reverse' . 'prescanl' (flip f) z . 'reverse' --- @ --- -prescanr :: (Prim a, Prim b) => (a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE prescanr #-} -prescanr = G.prescanr - --- | /O(n)/ Right-to-left prescan with strict accumulator -prescanr' :: (Prim a, Prim b) => (a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE prescanr' #-} -prescanr' = G.prescanr' - --- | /O(n)/ Right-to-left scan -postscanr :: (Prim a, Prim b) => (a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE postscanr #-} -postscanr = G.postscanr - --- | /O(n)/ Right-to-left scan with strict accumulator -postscanr' :: (Prim a, Prim b) => (a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE postscanr' #-} -postscanr' = G.postscanr' - --- | /O(n)/ Right-to-left Haskell-style scan -scanr :: (Prim a, Prim b) => (a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE scanr #-} -scanr = G.scanr - --- | /O(n)/ Right-to-left Haskell-style scan with strict accumulator -scanr' :: (Prim a, Prim b) => (a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE scanr' #-} -scanr' = G.scanr' - --- | /O(n)/ Right-to-left scan over a non-empty vector -scanr1 :: Prim a => (a -> a -> a) -> Vector a -> Vector a -{-# INLINE scanr1 #-} -scanr1 = G.scanr1 - --- | /O(n)/ Right-to-left scan over a non-empty vector with a strict --- accumulator -scanr1' :: Prim a => (a -> a -> a) -> Vector a -> Vector a -{-# INLINE scanr1' #-} -scanr1' = G.scanr1' - --- Conversions - Lists --- ------------------------ - --- | /O(n)/ Convert a vector to a list -toList :: Prim a => Vector a -> [a] -{-# INLINE toList #-} -toList = G.toList - --- | /O(n)/ Convert a list to a vector -fromList :: Prim a => [a] -> Vector a -{-# INLINE fromList #-} -fromList = G.fromList - --- | /O(n)/ Convert the first @n@ elements of a list to a vector --- --- @ --- fromListN n xs = 'fromList' ('take' n xs) --- @ -fromListN :: Prim a => Int -> [a] -> Vector a -{-# INLINE fromListN #-} -fromListN = G.fromListN - --- Conversions - Mutable vectors --- ----------------------------- - --- | /O(1)/ Unsafe convert a mutable vector to an immutable one without --- copying. The mutable vector may not be used after this operation. -unsafeFreeze :: (Prim a, PrimMonad m) => MVector (PrimState m) a -> m (Vector a) -{-# INLINE unsafeFreeze #-} -unsafeFreeze = G.unsafeFreeze - --- | /O(1)/ Unsafely convert an immutable vector to a mutable one without --- copying. The immutable vector may not be used after this operation. -unsafeThaw :: (Prim a, PrimMonad m) => Vector a -> m (MVector (PrimState m) a) -{-# INLINE unsafeThaw #-} -unsafeThaw = G.unsafeThaw - --- | /O(n)/ Yield a mutable copy of the immutable vector. -thaw :: (Prim a, PrimMonad m) => Vector a -> m (MVector (PrimState m) a) -{-# INLINE thaw #-} -thaw = G.thaw - --- | /O(n)/ Yield an immutable copy of the mutable vector. -freeze :: (Prim a, PrimMonad m) => MVector (PrimState m) a -> m (Vector a) -{-# INLINE freeze #-} -freeze = G.freeze - --- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must --- have the same length. This is not checked. -unsafeCopy - :: (Prim a, PrimMonad m) => MVector (PrimState m) a -> Vector a -> m () -{-# INLINE unsafeCopy #-} -unsafeCopy = G.unsafeCopy - --- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must --- have the same length. -copy :: (Prim a, PrimMonad m) => MVector (PrimState m) a -> Vector a -> m () -{-# INLINE copy #-} -copy = G.copy diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Primitive/Mutable.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Primitive/Mutable.hs deleted file mode 100644 index 33aca812e208..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Primitive/Mutable.hs +++ /dev/null @@ -1,366 +0,0 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, MultiParamTypeClasses, FlexibleInstances, ScopedTypeVariables #-} - --- | --- Module : Data.Vector.Primitive.Mutable --- Copyright : (c) Roman Leshchinskiy 2008-2010 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Stability : experimental --- Portability : non-portable --- --- Mutable primitive vectors. --- - -module Data.Vector.Primitive.Mutable ( - -- * Mutable vectors of primitive types - MVector(..), IOVector, STVector, Prim, - - -- * Accessors - - -- ** Length information - length, null, - - -- ** Extracting subvectors - slice, init, tail, take, drop, splitAt, - unsafeSlice, unsafeInit, unsafeTail, unsafeTake, unsafeDrop, - - -- ** Overlapping - overlaps, - - -- * Construction - - -- ** Initialisation - new, unsafeNew, replicate, replicateM, clone, - - -- ** Growing - grow, unsafeGrow, - - -- ** Restricting memory usage - clear, - - -- * Accessing individual elements - read, write, modify, swap, - unsafeRead, unsafeWrite, unsafeModify, unsafeSwap, - - -- * Modifying vectors - nextPermutation, - - -- ** Filling and copying - set, copy, move, unsafeCopy, unsafeMove -) where - -import qualified Data.Vector.Generic.Mutable as G -import Data.Primitive.ByteArray -import Data.Primitive ( Prim, sizeOf ) -import Data.Word ( Word8 ) -import Control.Monad.Primitive -import Control.Monad ( liftM ) - -import Control.DeepSeq ( NFData(rnf) ) - -import Prelude hiding ( length, null, replicate, reverse, map, read, - take, drop, splitAt, init, tail ) - -import Data.Typeable ( Typeable ) - --- Data.Vector.Internal.Check is unnecessary -#define NOT_VECTOR_MODULE -#include "vector.h" - --- | Mutable vectors of primitive types. -data MVector s a = MVector {-# UNPACK #-} !Int - {-# UNPACK #-} !Int - {-# UNPACK #-} !(MutableByteArray s) -- ^ offset, length, underlying mutable byte array - deriving ( Typeable ) - -type IOVector = MVector RealWorld -type STVector s = MVector s - -instance NFData (MVector s a) where - rnf (MVector _ _ _) = () - -instance Prim a => G.MVector MVector a where - basicLength (MVector _ n _) = n - basicUnsafeSlice j m (MVector i _ arr) - = MVector (i+j) m arr - - {-# INLINE basicOverlaps #-} - basicOverlaps (MVector i m arr1) (MVector j n arr2) - = sameMutableByteArray arr1 arr2 - && (between i j (j+n) || between j i (i+m)) - where - between x y z = x >= y && x < z - - {-# INLINE basicUnsafeNew #-} - basicUnsafeNew n - | n < 0 = error $ "Primitive.basicUnsafeNew: negative length: " ++ show n - | n > mx = error $ "Primitive.basicUnsafeNew: length to large: " ++ show n - | otherwise = MVector 0 n `liftM` newByteArray (n * size) - where - size = sizeOf (undefined :: a) - mx = maxBound `div` size :: Int - - {-# INLINE basicInitialize #-} - basicInitialize (MVector off n v) = - setByteArray v (off * size) (n * size) (0 :: Word8) - where - size = sizeOf (undefined :: a) - - - {-# INLINE basicUnsafeRead #-} - basicUnsafeRead (MVector i _ arr) j = readByteArray arr (i+j) - - {-# INLINE basicUnsafeWrite #-} - basicUnsafeWrite (MVector i _ arr) j x = writeByteArray arr (i+j) x - - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy (MVector i n dst) (MVector j _ src) - = copyMutableByteArray dst (i*sz) src (j*sz) (n*sz) - where - sz = sizeOf (undefined :: a) - - {-# INLINE basicUnsafeMove #-} - basicUnsafeMove (MVector i n dst) (MVector j _ src) - = moveByteArray dst (i*sz) src (j*sz) (n * sz) - where - sz = sizeOf (undefined :: a) - - {-# INLINE basicSet #-} - basicSet (MVector i n arr) x = setByteArray arr i n x - --- Length information --- ------------------ - --- | Length of the mutable vector. -length :: Prim a => MVector s a -> Int -{-# INLINE length #-} -length = G.length - --- | Check whether the vector is empty -null :: Prim a => MVector s a -> Bool -{-# INLINE null #-} -null = G.null - --- Extracting subvectors --- --------------------- - --- | Yield a part of the mutable vector without copying it. -slice :: Prim a => Int -> Int -> MVector s a -> MVector s a -{-# INLINE slice #-} -slice = G.slice - -take :: Prim a => Int -> MVector s a -> MVector s a -{-# INLINE take #-} -take = G.take - -drop :: Prim a => Int -> MVector s a -> MVector s a -{-# INLINE drop #-} -drop = G.drop - -splitAt :: Prim a => Int -> MVector s a -> (MVector s a, MVector s a) -{-# INLINE splitAt #-} -splitAt = G.splitAt - -init :: Prim a => MVector s a -> MVector s a -{-# INLINE init #-} -init = G.init - -tail :: Prim a => MVector s a -> MVector s a -{-# INLINE tail #-} -tail = G.tail - --- | Yield a part of the mutable vector without copying it. No bounds checks --- are performed. -unsafeSlice :: Prim a - => Int -- ^ starting index - -> Int -- ^ length of the slice - -> MVector s a - -> MVector s a -{-# INLINE unsafeSlice #-} -unsafeSlice = G.unsafeSlice - -unsafeTake :: Prim a => Int -> MVector s a -> MVector s a -{-# INLINE unsafeTake #-} -unsafeTake = G.unsafeTake - -unsafeDrop :: Prim a => Int -> MVector s a -> MVector s a -{-# INLINE unsafeDrop #-} -unsafeDrop = G.unsafeDrop - -unsafeInit :: Prim a => MVector s a -> MVector s a -{-# INLINE unsafeInit #-} -unsafeInit = G.unsafeInit - -unsafeTail :: Prim a => MVector s a -> MVector s a -{-# INLINE unsafeTail #-} -unsafeTail = G.unsafeTail - --- Overlapping --- ----------- - --- | Check whether two vectors overlap. -overlaps :: Prim a => MVector s a -> MVector s a -> Bool -{-# INLINE overlaps #-} -overlaps = G.overlaps - --- Initialisation --- -------------- - --- | Create a mutable vector of the given length. -new :: (PrimMonad m, Prim a) => Int -> m (MVector (PrimState m) a) -{-# INLINE new #-} -new = G.new - --- | Create a mutable vector of the given length. The memory is not initialized. -unsafeNew :: (PrimMonad m, Prim a) => Int -> m (MVector (PrimState m) a) -{-# INLINE unsafeNew #-} -unsafeNew = G.unsafeNew - --- | Create a mutable vector of the given length (0 if the length is negative) --- and fill it with an initial value. -replicate :: (PrimMonad m, Prim a) => Int -> a -> m (MVector (PrimState m) a) -{-# INLINE replicate #-} -replicate = G.replicate - --- | Create a mutable vector of the given length (0 if the length is negative) --- and fill it with values produced by repeatedly executing the monadic action. -replicateM :: (PrimMonad m, Prim a) => Int -> m a -> m (MVector (PrimState m) a) -{-# INLINE replicateM #-} -replicateM = G.replicateM - --- | Create a copy of a mutable vector. -clone :: (PrimMonad m, Prim a) - => MVector (PrimState m) a -> m (MVector (PrimState m) a) -{-# INLINE clone #-} -clone = G.clone - --- Growing --- ------- - --- | Grow a vector by the given number of elements. The number must be --- positive. -grow :: (PrimMonad m, Prim a) - => MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a) -{-# INLINE grow #-} -grow = G.grow - --- | Grow a vector by the given number of elements. The number must be --- positive but this is not checked. -unsafeGrow :: (PrimMonad m, Prim a) - => MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a) -{-# INLINE unsafeGrow #-} -unsafeGrow = G.unsafeGrow - --- Restricting memory usage --- ------------------------ - --- | Reset all elements of the vector to some undefined value, clearing all --- references to external objects. This is usually a noop for unboxed vectors. -clear :: (PrimMonad m, Prim a) => MVector (PrimState m) a -> m () -{-# INLINE clear #-} -clear = G.clear - --- Accessing individual elements --- ----------------------------- - --- | Yield the element at the given position. -read :: (PrimMonad m, Prim a) => MVector (PrimState m) a -> Int -> m a -{-# INLINE read #-} -read = G.read - --- | Replace the element at the given position. -write :: (PrimMonad m, Prim a) => MVector (PrimState m) a -> Int -> a -> m () -{-# INLINE write #-} -write = G.write - --- | Modify the element at the given position. -modify :: (PrimMonad m, Prim a) => MVector (PrimState m) a -> (a -> a) -> Int -> m () -{-# INLINE modify #-} -modify = G.modify - --- | Swap the elements at the given positions. -swap :: (PrimMonad m, Prim a) => MVector (PrimState m) a -> Int -> Int -> m () -{-# INLINE swap #-} -swap = G.swap - - --- | Yield the element at the given position. No bounds checks are performed. -unsafeRead :: (PrimMonad m, Prim a) => MVector (PrimState m) a -> Int -> m a -{-# INLINE unsafeRead #-} -unsafeRead = G.unsafeRead - --- | Replace the element at the given position. No bounds checks are performed. -unsafeWrite - :: (PrimMonad m, Prim a) => MVector (PrimState m) a -> Int -> a -> m () -{-# INLINE unsafeWrite #-} -unsafeWrite = G.unsafeWrite - --- | Modify the element at the given position. No bounds checks are performed. -unsafeModify :: (PrimMonad m, Prim a) => MVector (PrimState m) a -> (a -> a) -> Int -> m () -{-# INLINE unsafeModify #-} -unsafeModify = G.unsafeModify - --- | Swap the elements at the given positions. No bounds checks are performed. -unsafeSwap - :: (PrimMonad m, Prim a) => MVector (PrimState m) a -> Int -> Int -> m () -{-# INLINE unsafeSwap #-} -unsafeSwap = G.unsafeSwap - --- Filling and copying --- ------------------- - --- | Set all elements of the vector to the given value. -set :: (PrimMonad m, Prim a) => MVector (PrimState m) a -> a -> m () -{-# INLINE set #-} -set = G.set - --- | Copy a vector. The two vectors must have the same length and may not --- overlap. -copy :: (PrimMonad m, Prim a) - => MVector (PrimState m) a -- ^ target - -> MVector (PrimState m) a -- ^ source - -> m () -{-# INLINE copy #-} -copy = G.copy - --- | Copy a vector. The two vectors must have the same length and may not --- overlap. This is not checked. -unsafeCopy :: (PrimMonad m, Prim a) - => MVector (PrimState m) a -- ^ target - -> MVector (PrimState m) a -- ^ source - -> m () -{-# INLINE unsafeCopy #-} -unsafeCopy = G.unsafeCopy - --- | Move the contents of a vector. The two vectors must have the same --- length. --- --- If the vectors do not overlap, then this is equivalent to 'copy'. --- Otherwise, the copying is performed as if the source vector were --- copied to a temporary vector and then the temporary vector was copied --- to the target vector. -move :: (PrimMonad m, Prim a) - => MVector (PrimState m) a -> MVector (PrimState m) a -> m () -{-# INLINE move #-} -move = G.move - --- | Move the contents of a vector. The two vectors must have the same --- length, but this is not checked. --- --- If the vectors do not overlap, then this is equivalent to 'unsafeCopy'. --- Otherwise, the copying is performed as if the source vector were --- copied to a temporary vector and then the temporary vector was copied --- to the target vector. -unsafeMove :: (PrimMonad m, Prim a) - => MVector (PrimState m) a -- ^ target - -> MVector (PrimState m) a -- ^ source - -> m () -{-# INLINE unsafeMove #-} -unsafeMove = G.unsafeMove - --- | Compute the next (lexicographically) permutation of given vector in-place. --- Returns False when input is the last permtuation -nextPermutation :: (PrimMonad m,Ord e,Prim e) => MVector (PrimState m) e -> m Bool -{-# INLINE nextPermutation #-} -nextPermutation = G.nextPermutation diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Storable.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Storable.hs deleted file mode 100644 index 30c9a4615c60..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Storable.hs +++ /dev/null @@ -1,1489 +0,0 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, MultiParamTypeClasses, FlexibleInstances, TypeFamilies, Rank2Types, ScopedTypeVariables #-} - --- | --- Module : Data.Vector.Storable --- Copyright : (c) Roman Leshchinskiy 2009-2010 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Stability : experimental --- Portability : non-portable --- --- 'Storable'-based vectors. --- - -module Data.Vector.Storable ( - -- * Storable vectors - Vector, MVector(..), Storable, - - -- * Accessors - - -- ** Length information - length, null, - - -- ** Indexing - (!), (!?), head, last, - unsafeIndex, unsafeHead, unsafeLast, - - -- ** Monadic indexing - indexM, headM, lastM, - unsafeIndexM, unsafeHeadM, unsafeLastM, - - -- ** Extracting subvectors (slicing) - slice, init, tail, take, drop, splitAt, - unsafeSlice, unsafeInit, unsafeTail, unsafeTake, unsafeDrop, - - -- * Construction - - -- ** Initialisation - empty, singleton, replicate, generate, iterateN, - - -- ** Monadic initialisation - replicateM, generateM, iterateNM, create, createT, - - -- ** Unfolding - unfoldr, unfoldrN, - unfoldrM, unfoldrNM, - constructN, constructrN, - - -- ** Enumeration - enumFromN, enumFromStepN, enumFromTo, enumFromThenTo, - - -- ** Concatenation - cons, snoc, (++), concat, - - -- ** Restricting memory usage - force, - - -- * Modifying vectors - - -- ** Bulk updates - (//), update_, - unsafeUpd, unsafeUpdate_, - - -- ** Accumulations - accum, accumulate_, - unsafeAccum, unsafeAccumulate_, - - -- ** Permutations - reverse, backpermute, unsafeBackpermute, - - -- ** Safe destructive updates - modify, - - -- * Elementwise operations - - -- ** Mapping - map, imap, concatMap, - - -- ** Monadic mapping - mapM, mapM_, forM, forM_, - - -- ** Zipping - zipWith, zipWith3, zipWith4, zipWith5, zipWith6, - izipWith, izipWith3, izipWith4, izipWith5, izipWith6, - - -- ** Monadic zipping - zipWithM, zipWithM_, - - -- * Working with predicates - - -- ** Filtering - filter, ifilter, uniq, - mapMaybe, imapMaybe, - filterM, - takeWhile, dropWhile, - - -- ** Partitioning - partition, unstablePartition, span, break, - - -- ** Searching - elem, notElem, find, findIndex, findIndices, elemIndex, elemIndices, - - -- * Folding - foldl, foldl1, foldl', foldl1', foldr, foldr1, foldr', foldr1', - ifoldl, ifoldl', ifoldr, ifoldr', - - -- ** Specialised folds - all, any, and, or, - sum, product, - maximum, maximumBy, minimum, minimumBy, - minIndex, minIndexBy, maxIndex, maxIndexBy, - - -- ** Monadic folds - foldM, foldM', fold1M, fold1M', - foldM_, foldM'_, fold1M_, fold1M'_, - - -- * Prefix sums (scans) - prescanl, prescanl', - postscanl, postscanl', - scanl, scanl', scanl1, scanl1', - prescanr, prescanr', - postscanr, postscanr', - scanr, scanr', scanr1, scanr1', - - -- * Conversions - - -- ** Lists - toList, fromList, fromListN, - - -- ** Other vector types - G.convert, unsafeCast, - - -- ** Mutable vectors - freeze, thaw, copy, unsafeFreeze, unsafeThaw, unsafeCopy, - - -- * Raw pointers - unsafeFromForeignPtr, unsafeFromForeignPtr0, - unsafeToForeignPtr, unsafeToForeignPtr0, - unsafeWith -) where - -import qualified Data.Vector.Generic as G -import Data.Vector.Storable.Mutable ( MVector(..) ) -import Data.Vector.Storable.Internal -import qualified Data.Vector.Fusion.Bundle as Bundle - -import Foreign.Storable -import Foreign.ForeignPtr -import Foreign.Ptr -import Foreign.Marshal.Array ( advancePtr, copyArray ) - -import Control.DeepSeq ( NFData(rnf) ) - -import Control.Monad.ST ( ST ) -import Control.Monad.Primitive - -import Prelude hiding ( length, null, - replicate, (++), concat, - head, last, - init, tail, take, drop, splitAt, reverse, - map, concatMap, - zipWith, zipWith3, zip, zip3, unzip, unzip3, - filter, takeWhile, dropWhile, span, break, - elem, notElem, - foldl, foldl1, foldr, foldr1, - all, any, and, or, sum, product, minimum, maximum, - scanl, scanl1, scanr, scanr1, - enumFromTo, enumFromThenTo, - mapM, mapM_ ) - -import Data.Typeable ( Typeable ) -import Data.Data ( Data(..) ) -import Text.Read ( Read(..), readListPrecDefault ) -import Data.Semigroup ( Semigroup(..) ) - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid ( Monoid(..) ) -import Data.Traversable ( Traversable ) -#endif - -#if __GLASGOW_HASKELL__ >= 708 -import qualified GHC.Exts as Exts -#endif - --- Data.Vector.Internal.Check is unused -#define NOT_VECTOR_MODULE -#include "vector.h" - --- | 'Storable'-based vectors -data Vector a = Vector {-# UNPACK #-} !Int - {-# UNPACK #-} !(ForeignPtr a) - deriving ( Typeable ) - -instance NFData (Vector a) where - rnf (Vector _ _) = () - -instance (Show a, Storable a) => Show (Vector a) where - showsPrec = G.showsPrec - -instance (Read a, Storable a) => Read (Vector a) where - readPrec = G.readPrec - readListPrec = readListPrecDefault - -instance (Data a, Storable a) => Data (Vector a) where - gfoldl = G.gfoldl - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = G.mkType "Data.Vector.Storable.Vector" - dataCast1 = G.dataCast - -type instance G.Mutable Vector = MVector - -instance Storable a => G.Vector Vector a where - {-# INLINE basicUnsafeFreeze #-} - basicUnsafeFreeze (MVector n fp) = return $ Vector n fp - - {-# INLINE basicUnsafeThaw #-} - basicUnsafeThaw (Vector n fp) = return $ MVector n fp - - {-# INLINE basicLength #-} - basicLength (Vector n _) = n - - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice i n (Vector _ fp) = Vector n (updPtr (`advancePtr` i) fp) - - {-# INLINE basicUnsafeIndexM #-} - basicUnsafeIndexM (Vector _ fp) i = return - . unsafeInlineIO - $ withForeignPtr fp $ \p -> - peekElemOff p i - - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy (MVector n fp) (Vector _ fq) - = unsafePrimToPrim - $ withForeignPtr fp $ \p -> - withForeignPtr fq $ \q -> - copyArray p q n - - {-# INLINE elemseq #-} - elemseq _ = seq - --- See http://trac.haskell.org/vector/ticket/12 -instance (Storable a, Eq a) => Eq (Vector a) where - {-# INLINE (==) #-} - xs == ys = Bundle.eq (G.stream xs) (G.stream ys) - - {-# INLINE (/=) #-} - xs /= ys = not (Bundle.eq (G.stream xs) (G.stream ys)) - --- See http://trac.haskell.org/vector/ticket/12 -instance (Storable a, Ord a) => Ord (Vector a) where - {-# INLINE compare #-} - compare xs ys = Bundle.cmp (G.stream xs) (G.stream ys) - - {-# INLINE (<) #-} - xs < ys = Bundle.cmp (G.stream xs) (G.stream ys) == LT - - {-# INLINE (<=) #-} - xs <= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= GT - - {-# INLINE (>) #-} - xs > ys = Bundle.cmp (G.stream xs) (G.stream ys) == GT - - {-# INLINE (>=) #-} - xs >= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= LT - -instance Storable a => Semigroup (Vector a) where - {-# INLINE (<>) #-} - (<>) = (++) - - {-# INLINE sconcat #-} - sconcat = G.concatNE - -instance Storable a => Monoid (Vector a) where - {-# INLINE mempty #-} - mempty = empty - - {-# INLINE mappend #-} - mappend = (++) - - {-# INLINE mconcat #-} - mconcat = concat - -#if __GLASGOW_HASKELL__ >= 708 - -instance Storable a => Exts.IsList (Vector a) where - type Item (Vector a) = a - fromList = fromList - fromListN = fromListN - toList = toList - -#endif - --- Length --- ------ - --- | /O(1)/ Yield the length of the vector -length :: Storable a => Vector a -> Int -{-# INLINE length #-} -length = G.length - --- | /O(1)/ Test whether a vector is empty -null :: Storable a => Vector a -> Bool -{-# INLINE null #-} -null = G.null - --- Indexing --- -------- - --- | O(1) Indexing -(!) :: Storable a => Vector a -> Int -> a -{-# INLINE (!) #-} -(!) = (G.!) - --- | O(1) Safe indexing -(!?) :: Storable a => Vector a -> Int -> Maybe a -{-# INLINE (!?) #-} -(!?) = (G.!?) - --- | /O(1)/ First element -head :: Storable a => Vector a -> a -{-# INLINE head #-} -head = G.head - --- | /O(1)/ Last element -last :: Storable a => Vector a -> a -{-# INLINE last #-} -last = G.last - --- | /O(1)/ Unsafe indexing without bounds checking -unsafeIndex :: Storable a => Vector a -> Int -> a -{-# INLINE unsafeIndex #-} -unsafeIndex = G.unsafeIndex - --- | /O(1)/ First element without checking if the vector is empty -unsafeHead :: Storable a => Vector a -> a -{-# INLINE unsafeHead #-} -unsafeHead = G.unsafeHead - --- | /O(1)/ Last element without checking if the vector is empty -unsafeLast :: Storable a => Vector a -> a -{-# INLINE unsafeLast #-} -unsafeLast = G.unsafeLast - --- Monadic indexing --- ---------------- - --- | /O(1)/ Indexing in a monad. --- --- The monad allows operations to be strict in the vector when necessary. --- Suppose vector copying is implemented like this: --- --- > copy mv v = ... write mv i (v ! i) ... --- --- For lazy vectors, @v ! i@ would not be evaluated which means that @mv@ --- would unnecessarily retain a reference to @v@ in each element written. --- --- With 'indexM', copying can be implemented like this instead: --- --- > copy mv v = ... do --- > x <- indexM v i --- > write mv i x --- --- Here, no references to @v@ are retained because indexing (but /not/ the --- elements) is evaluated eagerly. --- -indexM :: (Storable a, Monad m) => Vector a -> Int -> m a -{-# INLINE indexM #-} -indexM = G.indexM - --- | /O(1)/ First element of a vector in a monad. See 'indexM' for an --- explanation of why this is useful. -headM :: (Storable a, Monad m) => Vector a -> m a -{-# INLINE headM #-} -headM = G.headM - --- | /O(1)/ Last element of a vector in a monad. See 'indexM' for an --- explanation of why this is useful. -lastM :: (Storable a, Monad m) => Vector a -> m a -{-# INLINE lastM #-} -lastM = G.lastM - --- | /O(1)/ Indexing in a monad without bounds checks. See 'indexM' for an --- explanation of why this is useful. -unsafeIndexM :: (Storable a, Monad m) => Vector a -> Int -> m a -{-# INLINE unsafeIndexM #-} -unsafeIndexM = G.unsafeIndexM - --- | /O(1)/ First element in a monad without checking for empty vectors. --- See 'indexM' for an explanation of why this is useful. -unsafeHeadM :: (Storable a, Monad m) => Vector a -> m a -{-# INLINE unsafeHeadM #-} -unsafeHeadM = G.unsafeHeadM - --- | /O(1)/ Last element in a monad without checking for empty vectors. --- See 'indexM' for an explanation of why this is useful. -unsafeLastM :: (Storable a, Monad m) => Vector a -> m a -{-# INLINE unsafeLastM #-} -unsafeLastM = G.unsafeLastM - --- Extracting subvectors (slicing) --- ------------------------------- - --- | /O(1)/ Yield a slice of the vector without copying it. The vector must --- contain at least @i+n@ elements. -slice :: Storable a - => Int -- ^ @i@ starting index - -> Int -- ^ @n@ length - -> Vector a - -> Vector a -{-# INLINE slice #-} -slice = G.slice - --- | /O(1)/ Yield all but the last element without copying. The vector may not --- be empty. -init :: Storable a => Vector a -> Vector a -{-# INLINE init #-} -init = G.init - --- | /O(1)/ Yield all but the first element without copying. The vector may not --- be empty. -tail :: Storable a => Vector a -> Vector a -{-# INLINE tail #-} -tail = G.tail - --- | /O(1)/ Yield at the first @n@ elements without copying. The vector may --- contain less than @n@ elements in which case it is returned unchanged. -take :: Storable a => Int -> Vector a -> Vector a -{-# INLINE take #-} -take = G.take - --- | /O(1)/ Yield all but the first @n@ elements without copying. The vector may --- contain less than @n@ elements in which case an empty vector is returned. -drop :: Storable a => Int -> Vector a -> Vector a -{-# INLINE drop #-} -drop = G.drop - --- | /O(1)/ Yield the first @n@ elements paired with the remainder without copying. --- --- Note that @'splitAt' n v@ is equivalent to @('take' n v, 'drop' n v)@ --- but slightly more efficient. -{-# INLINE splitAt #-} -splitAt :: Storable a => Int -> Vector a -> (Vector a, Vector a) -splitAt = G.splitAt - --- | /O(1)/ Yield a slice of the vector without copying. The vector must --- contain at least @i+n@ elements but this is not checked. -unsafeSlice :: Storable a => Int -- ^ @i@ starting index - -> Int -- ^ @n@ length - -> Vector a - -> Vector a -{-# INLINE unsafeSlice #-} -unsafeSlice = G.unsafeSlice - --- | /O(1)/ Yield all but the last element without copying. The vector may not --- be empty but this is not checked. -unsafeInit :: Storable a => Vector a -> Vector a -{-# INLINE unsafeInit #-} -unsafeInit = G.unsafeInit - --- | /O(1)/ Yield all but the first element without copying. The vector may not --- be empty but this is not checked. -unsafeTail :: Storable a => Vector a -> Vector a -{-# INLINE unsafeTail #-} -unsafeTail = G.unsafeTail - --- | /O(1)/ Yield the first @n@ elements without copying. The vector must --- contain at least @n@ elements but this is not checked. -unsafeTake :: Storable a => Int -> Vector a -> Vector a -{-# INLINE unsafeTake #-} -unsafeTake = G.unsafeTake - --- | /O(1)/ Yield all but the first @n@ elements without copying. The vector --- must contain at least @n@ elements but this is not checked. -unsafeDrop :: Storable a => Int -> Vector a -> Vector a -{-# INLINE unsafeDrop #-} -unsafeDrop = G.unsafeDrop - --- Initialisation --- -------------- - --- | /O(1)/ Empty vector -empty :: Storable a => Vector a -{-# INLINE empty #-} -empty = G.empty - --- | /O(1)/ Vector with exactly one element -singleton :: Storable a => a -> Vector a -{-# INLINE singleton #-} -singleton = G.singleton - --- | /O(n)/ Vector of the given length with the same value in each position -replicate :: Storable a => Int -> a -> Vector a -{-# INLINE replicate #-} -replicate = G.replicate - --- | /O(n)/ Construct a vector of the given length by applying the function to --- each index -generate :: Storable a => Int -> (Int -> a) -> Vector a -{-# INLINE generate #-} -generate = G.generate - --- | /O(n)/ Apply function n times to value. Zeroth element is original value. -iterateN :: Storable a => Int -> (a -> a) -> a -> Vector a -{-# INLINE iterateN #-} -iterateN = G.iterateN - --- Unfolding --- --------- - --- | /O(n)/ Construct a vector by repeatedly applying the generator function --- to a seed. The generator function yields 'Just' the next element and the --- new seed or 'Nothing' if there are no more elements. --- --- > unfoldr (\n -> if n == 0 then Nothing else Just (n,n-1)) 10 --- > = <10,9,8,7,6,5,4,3,2,1> -unfoldr :: Storable a => (b -> Maybe (a, b)) -> b -> Vector a -{-# INLINE unfoldr #-} -unfoldr = G.unfoldr - --- | /O(n)/ Construct a vector with at most @n@ elements by repeatedly applying --- the generator function to a seed. The generator function yields 'Just' the --- next element and the new seed or 'Nothing' if there are no more elements. --- --- > unfoldrN 3 (\n -> Just (n,n-1)) 10 = <10,9,8> -unfoldrN :: Storable a => Int -> (b -> Maybe (a, b)) -> b -> Vector a -{-# INLINE unfoldrN #-} -unfoldrN = G.unfoldrN - --- | /O(n)/ Construct a vector by repeatedly applying the monadic --- generator function to a seed. The generator function yields 'Just' --- the next element and the new seed or 'Nothing' if there are no more --- elements. -unfoldrM :: (Monad m, Storable a) => (b -> m (Maybe (a, b))) -> b -> m (Vector a) -{-# INLINE unfoldrM #-} -unfoldrM = G.unfoldrM - --- | /O(n)/ Construct a vector by repeatedly applying the monadic --- generator function to a seed. The generator function yields 'Just' --- the next element and the new seed or 'Nothing' if there are no more --- elements. -unfoldrNM :: (Monad m, Storable a) => Int -> (b -> m (Maybe (a, b))) -> b -> m (Vector a) -{-# INLINE unfoldrNM #-} -unfoldrNM = G.unfoldrNM - --- | /O(n)/ Construct a vector with @n@ elements by repeatedly applying the --- generator function to the already constructed part of the vector. --- --- > constructN 3 f = let a = f <> ; b = f <a> ; c = f <a,b> in f <a,b,c> --- -constructN :: Storable a => Int -> (Vector a -> a) -> Vector a -{-# INLINE constructN #-} -constructN = G.constructN - --- | /O(n)/ Construct a vector with @n@ elements from right to left by --- repeatedly applying the generator function to the already constructed part --- of the vector. --- --- > constructrN 3 f = let a = f <> ; b = f<a> ; c = f <b,a> in f <c,b,a> --- -constructrN :: Storable a => Int -> (Vector a -> a) -> Vector a -{-# INLINE constructrN #-} -constructrN = G.constructrN - --- Enumeration --- ----------- - --- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+1@ --- etc. This operation is usually more efficient than 'enumFromTo'. --- --- > enumFromN 5 3 = <5,6,7> -enumFromN :: (Storable a, Num a) => a -> Int -> Vector a -{-# INLINE enumFromN #-} -enumFromN = G.enumFromN - --- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+y@, --- @x+y+y@ etc. This operations is usually more efficient than 'enumFromThenTo'. --- --- > enumFromStepN 1 0.1 5 = <1,1.1,1.2,1.3,1.4> -enumFromStepN :: (Storable a, Num a) => a -> a -> Int -> Vector a -{-# INLINE enumFromStepN #-} -enumFromStepN = G.enumFromStepN - --- | /O(n)/ Enumerate values from @x@ to @y@. --- --- /WARNING:/ This operation can be very inefficient. If at all possible, use --- 'enumFromN' instead. -enumFromTo :: (Storable a, Enum a) => a -> a -> Vector a -{-# INLINE enumFromTo #-} -enumFromTo = G.enumFromTo - --- | /O(n)/ Enumerate values from @x@ to @y@ with a specific step @z@. --- --- /WARNING:/ This operation can be very inefficient. If at all possible, use --- 'enumFromStepN' instead. -enumFromThenTo :: (Storable a, Enum a) => a -> a -> a -> Vector a -{-# INLINE enumFromThenTo #-} -enumFromThenTo = G.enumFromThenTo - --- Concatenation --- ------------- - --- | /O(n)/ Prepend an element -cons :: Storable a => a -> Vector a -> Vector a -{-# INLINE cons #-} -cons = G.cons - --- | /O(n)/ Append an element -snoc :: Storable a => Vector a -> a -> Vector a -{-# INLINE snoc #-} -snoc = G.snoc - -infixr 5 ++ --- | /O(m+n)/ Concatenate two vectors -(++) :: Storable a => Vector a -> Vector a -> Vector a -{-# INLINE (++) #-} -(++) = (G.++) - --- | /O(n)/ Concatenate all vectors in the list -concat :: Storable a => [Vector a] -> Vector a -{-# INLINE concat #-} -concat = G.concat - --- Monadic initialisation --- ---------------------- - --- | /O(n)/ Execute the monadic action the given number of times and store the --- results in a vector. -replicateM :: (Monad m, Storable a) => Int -> m a -> m (Vector a) -{-# INLINE replicateM #-} -replicateM = G.replicateM - --- | /O(n)/ Construct a vector of the given length by applying the monadic --- action to each index -generateM :: (Monad m, Storable a) => Int -> (Int -> m a) -> m (Vector a) -{-# INLINE generateM #-} -generateM = G.generateM - --- | /O(n)/ Apply monadic function n times to value. Zeroth element is original value. -iterateNM :: (Monad m, Storable a) => Int -> (a -> m a) -> a -> m (Vector a) -{-# INLINE iterateNM #-} -iterateNM = G.iterateNM - --- | Execute the monadic action and freeze the resulting vector. --- --- @ --- create (do { v \<- new 2; write v 0 \'a\'; write v 1 \'b\'; return v }) = \<'a','b'\> --- @ -create :: Storable a => (forall s. ST s (MVector s a)) -> Vector a -{-# INLINE create #-} --- NOTE: eta-expanded due to http://hackage.haskell.org/trac/ghc/ticket/4120 -create p = G.create p - --- | Execute the monadic action and freeze the resulting vectors. -createT :: (Traversable f, Storable a) => (forall s. ST s (f (MVector s a))) -> f (Vector a) -{-# INLINE createT #-} -createT p = G.createT p - --- Restricting memory usage --- ------------------------ - --- | /O(n)/ Yield the argument but force it not to retain any extra memory, --- possibly by copying it. --- --- This is especially useful when dealing with slices. For example: --- --- > force (slice 0 2 <huge vector>) --- --- Here, the slice retains a reference to the huge vector. Forcing it creates --- a copy of just the elements that belong to the slice and allows the huge --- vector to be garbage collected. -force :: Storable a => Vector a -> Vector a -{-# INLINE force #-} -force = G.force - --- Bulk updates --- ------------ - --- | /O(m+n)/ For each pair @(i,a)@ from the list, replace the vector --- element at position @i@ by @a@. --- --- > <5,9,2,7> // [(2,1),(0,3),(2,8)] = <3,9,8,7> --- -(//) :: Storable a => Vector a -- ^ initial vector (of length @m@) - -> [(Int, a)] -- ^ list of index/value pairs (of length @n@) - -> Vector a -{-# INLINE (//) #-} -(//) = (G.//) - --- | /O(m+min(n1,n2))/ For each index @i@ from the index vector and the --- corresponding value @a@ from the value vector, replace the element of the --- initial vector at position @i@ by @a@. --- --- > update_ <5,9,2,7> <2,0,2> <1,3,8> = <3,9,8,7> --- -update_ :: Storable a - => Vector a -- ^ initial vector (of length @m@) - -> Vector Int -- ^ index vector (of length @n1@) - -> Vector a -- ^ value vector (of length @n2@) - -> Vector a -{-# INLINE update_ #-} -update_ = G.update_ - --- | Same as ('//') but without bounds checking. -unsafeUpd :: Storable a => Vector a -> [(Int, a)] -> Vector a -{-# INLINE unsafeUpd #-} -unsafeUpd = G.unsafeUpd - --- | Same as 'update_' but without bounds checking. -unsafeUpdate_ :: Storable a => Vector a -> Vector Int -> Vector a -> Vector a -{-# INLINE unsafeUpdate_ #-} -unsafeUpdate_ = G.unsafeUpdate_ - --- Accumulations --- ------------- - --- | /O(m+n)/ For each pair @(i,b)@ from the list, replace the vector element --- @a@ at position @i@ by @f a b@. --- --- > accum (+) <5,9,2> [(2,4),(1,6),(0,3),(1,7)] = <5+3, 9+6+7, 2+4> -accum :: Storable a - => (a -> b -> a) -- ^ accumulating function @f@ - -> Vector a -- ^ initial vector (of length @m@) - -> [(Int,b)] -- ^ list of index/value pairs (of length @n@) - -> Vector a -{-# INLINE accum #-} -accum = G.accum - --- | /O(m+min(n1,n2))/ For each index @i@ from the index vector and the --- corresponding value @b@ from the the value vector, --- replace the element of the initial vector at --- position @i@ by @f a b@. --- --- > accumulate_ (+) <5,9,2> <2,1,0,1> <4,6,3,7> = <5+3, 9+6+7, 2+4> --- -accumulate_ :: (Storable a, Storable b) - => (a -> b -> a) -- ^ accumulating function @f@ - -> Vector a -- ^ initial vector (of length @m@) - -> Vector Int -- ^ index vector (of length @n1@) - -> Vector b -- ^ value vector (of length @n2@) - -> Vector a -{-# INLINE accumulate_ #-} -accumulate_ = G.accumulate_ - --- | Same as 'accum' but without bounds checking. -unsafeAccum :: Storable a => (a -> b -> a) -> Vector a -> [(Int,b)] -> Vector a -{-# INLINE unsafeAccum #-} -unsafeAccum = G.unsafeAccum - --- | Same as 'accumulate_' but without bounds checking. -unsafeAccumulate_ :: (Storable a, Storable b) => - (a -> b -> a) -> Vector a -> Vector Int -> Vector b -> Vector a -{-# INLINE unsafeAccumulate_ #-} -unsafeAccumulate_ = G.unsafeAccumulate_ - --- Permutations --- ------------ - --- | /O(n)/ Reverse a vector -reverse :: Storable a => Vector a -> Vector a -{-# INLINE reverse #-} -reverse = G.reverse - --- | /O(n)/ Yield the vector obtained by replacing each element @i@ of the --- index vector by @xs'!'i@. This is equivalent to @'map' (xs'!') is@ but is --- often much more efficient. --- --- > backpermute <a,b,c,d> <0,3,2,3,1,0> = <a,d,c,d,b,a> -backpermute :: Storable a => Vector a -> Vector Int -> Vector a -{-# INLINE backpermute #-} -backpermute = G.backpermute - --- | Same as 'backpermute' but without bounds checking. -unsafeBackpermute :: Storable a => Vector a -> Vector Int -> Vector a -{-# INLINE unsafeBackpermute #-} -unsafeBackpermute = G.unsafeBackpermute - --- Safe destructive updates --- ------------------------ - --- | Apply a destructive operation to a vector. The operation will be --- performed in place if it is safe to do so and will modify a copy of the --- vector otherwise. --- --- @ --- modify (\\v -> write v 0 \'x\') ('replicate' 3 \'a\') = \<\'x\',\'a\',\'a\'\> --- @ -modify :: Storable a => (forall s. MVector s a -> ST s ()) -> Vector a -> Vector a -{-# INLINE modify #-} -modify p = G.modify p - --- Mapping --- ------- - --- | /O(n)/ Map a function over a vector -map :: (Storable a, Storable b) => (a -> b) -> Vector a -> Vector b -{-# INLINE map #-} -map = G.map - --- | /O(n)/ Apply a function to every element of a vector and its index -imap :: (Storable a, Storable b) => (Int -> a -> b) -> Vector a -> Vector b -{-# INLINE imap #-} -imap = G.imap - --- | Map a function over a vector and concatenate the results. -concatMap :: (Storable a, Storable b) => (a -> Vector b) -> Vector a -> Vector b -{-# INLINE concatMap #-} -concatMap = G.concatMap - --- Monadic mapping --- --------------- - --- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a --- vector of results -mapM :: (Monad m, Storable a, Storable b) => (a -> m b) -> Vector a -> m (Vector b) -{-# INLINE mapM #-} -mapM = G.mapM - --- | /O(n)/ Apply the monadic action to all elements of a vector and ignore the --- results -mapM_ :: (Monad m, Storable a) => (a -> m b) -> Vector a -> m () -{-# INLINE mapM_ #-} -mapM_ = G.mapM_ - --- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a --- vector of results. Equivalent to @flip 'mapM'@. -forM :: (Monad m, Storable a, Storable b) => Vector a -> (a -> m b) -> m (Vector b) -{-# INLINE forM #-} -forM = G.forM - --- | /O(n)/ Apply the monadic action to all elements of a vector and ignore the --- results. Equivalent to @flip 'mapM_'@. -forM_ :: (Monad m, Storable a) => Vector a -> (a -> m b) -> m () -{-# INLINE forM_ #-} -forM_ = G.forM_ - --- Zipping --- ------- - --- | /O(min(m,n))/ Zip two vectors with the given function. -zipWith :: (Storable a, Storable b, Storable c) - => (a -> b -> c) -> Vector a -> Vector b -> Vector c -{-# INLINE zipWith #-} -zipWith = G.zipWith - --- | Zip three vectors with the given function. -zipWith3 :: (Storable a, Storable b, Storable c, Storable d) - => (a -> b -> c -> d) -> Vector a -> Vector b -> Vector c -> Vector d -{-# INLINE zipWith3 #-} -zipWith3 = G.zipWith3 - -zipWith4 :: (Storable a, Storable b, Storable c, Storable d, Storable e) - => (a -> b -> c -> d -> e) - -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e -{-# INLINE zipWith4 #-} -zipWith4 = G.zipWith4 - -zipWith5 :: (Storable a, Storable b, Storable c, Storable d, Storable e, - Storable f) - => (a -> b -> c -> d -> e -> f) - -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e - -> Vector f -{-# INLINE zipWith5 #-} -zipWith5 = G.zipWith5 - -zipWith6 :: (Storable a, Storable b, Storable c, Storable d, Storable e, - Storable f, Storable g) - => (a -> b -> c -> d -> e -> f -> g) - -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e - -> Vector f -> Vector g -{-# INLINE zipWith6 #-} -zipWith6 = G.zipWith6 - --- | /O(min(m,n))/ Zip two vectors with a function that also takes the --- elements' indices. -izipWith :: (Storable a, Storable b, Storable c) - => (Int -> a -> b -> c) -> Vector a -> Vector b -> Vector c -{-# INLINE izipWith #-} -izipWith = G.izipWith - --- | Zip three vectors and their indices with the given function. -izipWith3 :: (Storable a, Storable b, Storable c, Storable d) - => (Int -> a -> b -> c -> d) - -> Vector a -> Vector b -> Vector c -> Vector d -{-# INLINE izipWith3 #-} -izipWith3 = G.izipWith3 - -izipWith4 :: (Storable a, Storable b, Storable c, Storable d, Storable e) - => (Int -> a -> b -> c -> d -> e) - -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e -{-# INLINE izipWith4 #-} -izipWith4 = G.izipWith4 - -izipWith5 :: (Storable a, Storable b, Storable c, Storable d, Storable e, - Storable f) - => (Int -> a -> b -> c -> d -> e -> f) - -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e - -> Vector f -{-# INLINE izipWith5 #-} -izipWith5 = G.izipWith5 - -izipWith6 :: (Storable a, Storable b, Storable c, Storable d, Storable e, - Storable f, Storable g) - => (Int -> a -> b -> c -> d -> e -> f -> g) - -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e - -> Vector f -> Vector g -{-# INLINE izipWith6 #-} -izipWith6 = G.izipWith6 - --- Monadic zipping --- --------------- - --- | /O(min(m,n))/ Zip the two vectors with the monadic action and yield a --- vector of results -zipWithM :: (Monad m, Storable a, Storable b, Storable c) - => (a -> b -> m c) -> Vector a -> Vector b -> m (Vector c) -{-# INLINE zipWithM #-} -zipWithM = G.zipWithM - --- | /O(min(m,n))/ Zip the two vectors with the monadic action and ignore the --- results -zipWithM_ :: (Monad m, Storable a, Storable b) - => (a -> b -> m c) -> Vector a -> Vector b -> m () -{-# INLINE zipWithM_ #-} -zipWithM_ = G.zipWithM_ - --- Filtering --- --------- - --- | /O(n)/ Drop elements that do not satisfy the predicate -filter :: Storable a => (a -> Bool) -> Vector a -> Vector a -{-# INLINE filter #-} -filter = G.filter - --- | /O(n)/ Drop elements that do not satisfy the predicate which is applied to --- values and their indices -ifilter :: Storable a => (Int -> a -> Bool) -> Vector a -> Vector a -{-# INLINE ifilter #-} -ifilter = G.ifilter - --- | /O(n)/ Drop repeated adjacent elements. -uniq :: (Storable a, Eq a) => Vector a -> Vector a -{-# INLINE uniq #-} -uniq = G.uniq - --- | /O(n)/ Drop elements when predicate returns Nothing -mapMaybe :: (Storable a, Storable b) => (a -> Maybe b) -> Vector a -> Vector b -{-# INLINE mapMaybe #-} -mapMaybe = G.mapMaybe - --- | /O(n)/ Drop elements when predicate, applied to index and value, returns Nothing -imapMaybe :: (Storable a, Storable b) => (Int -> a -> Maybe b) -> Vector a -> Vector b -{-# INLINE imapMaybe #-} -imapMaybe = G.imapMaybe - --- | /O(n)/ Drop elements that do not satisfy the monadic predicate -filterM :: (Monad m, Storable a) => (a -> m Bool) -> Vector a -> m (Vector a) -{-# INLINE filterM #-} -filterM = G.filterM - --- | /O(n)/ Yield the longest prefix of elements satisfying the predicate --- without copying. -takeWhile :: Storable a => (a -> Bool) -> Vector a -> Vector a -{-# INLINE takeWhile #-} -takeWhile = G.takeWhile - --- | /O(n)/ Drop the longest prefix of elements that satisfy the predicate --- without copying. -dropWhile :: Storable a => (a -> Bool) -> Vector a -> Vector a -{-# INLINE dropWhile #-} -dropWhile = G.dropWhile - --- Parititioning --- ------------- - --- | /O(n)/ Split the vector in two parts, the first one containing those --- elements that satisfy the predicate and the second one those that don't. The --- relative order of the elements is preserved at the cost of a sometimes --- reduced performance compared to 'unstablePartition'. -partition :: Storable a => (a -> Bool) -> Vector a -> (Vector a, Vector a) -{-# INLINE partition #-} -partition = G.partition - --- | /O(n)/ Split the vector in two parts, the first one containing those --- elements that satisfy the predicate and the second one those that don't. --- The order of the elements is not preserved but the operation is often --- faster than 'partition'. -unstablePartition :: Storable a => (a -> Bool) -> Vector a -> (Vector a, Vector a) -{-# INLINE unstablePartition #-} -unstablePartition = G.unstablePartition - --- | /O(n)/ Split the vector into the longest prefix of elements that satisfy --- the predicate and the rest without copying. -span :: Storable a => (a -> Bool) -> Vector a -> (Vector a, Vector a) -{-# INLINE span #-} -span = G.span - --- | /O(n)/ Split the vector into the longest prefix of elements that do not --- satisfy the predicate and the rest without copying. -break :: Storable a => (a -> Bool) -> Vector a -> (Vector a, Vector a) -{-# INLINE break #-} -break = G.break - --- Searching --- --------- - -infix 4 `elem` --- | /O(n)/ Check if the vector contains an element -elem :: (Storable a, Eq a) => a -> Vector a -> Bool -{-# INLINE elem #-} -elem = G.elem - -infix 4 `notElem` --- | /O(n)/ Check if the vector does not contain an element (inverse of 'elem') -notElem :: (Storable a, Eq a) => a -> Vector a -> Bool -{-# INLINE notElem #-} -notElem = G.notElem - --- | /O(n)/ Yield 'Just' the first element matching the predicate or 'Nothing' --- if no such element exists. -find :: Storable a => (a -> Bool) -> Vector a -> Maybe a -{-# INLINE find #-} -find = G.find - --- | /O(n)/ Yield 'Just' the index of the first element matching the predicate --- or 'Nothing' if no such element exists. -findIndex :: Storable a => (a -> Bool) -> Vector a -> Maybe Int -{-# INLINE findIndex #-} -findIndex = G.findIndex - --- | /O(n)/ Yield the indices of elements satisfying the predicate in ascending --- order. -findIndices :: Storable a => (a -> Bool) -> Vector a -> Vector Int -{-# INLINE findIndices #-} -findIndices = G.findIndices - --- | /O(n)/ Yield 'Just' the index of the first occurence of the given element or --- 'Nothing' if the vector does not contain the element. This is a specialised --- version of 'findIndex'. -elemIndex :: (Storable a, Eq a) => a -> Vector a -> Maybe Int -{-# INLINE elemIndex #-} -elemIndex = G.elemIndex - --- | /O(n)/ Yield the indices of all occurences of the given element in --- ascending order. This is a specialised version of 'findIndices'. -elemIndices :: (Storable a, Eq a) => a -> Vector a -> Vector Int -{-# INLINE elemIndices #-} -elemIndices = G.elemIndices - --- Folding --- ------- - --- | /O(n)/ Left fold -foldl :: Storable b => (a -> b -> a) -> a -> Vector b -> a -{-# INLINE foldl #-} -foldl = G.foldl - --- | /O(n)/ Left fold on non-empty vectors -foldl1 :: Storable a => (a -> a -> a) -> Vector a -> a -{-# INLINE foldl1 #-} -foldl1 = G.foldl1 - --- | /O(n)/ Left fold with strict accumulator -foldl' :: Storable b => (a -> b -> a) -> a -> Vector b -> a -{-# INLINE foldl' #-} -foldl' = G.foldl' - --- | /O(n)/ Left fold on non-empty vectors with strict accumulator -foldl1' :: Storable a => (a -> a -> a) -> Vector a -> a -{-# INLINE foldl1' #-} -foldl1' = G.foldl1' - --- | /O(n)/ Right fold -foldr :: Storable a => (a -> b -> b) -> b -> Vector a -> b -{-# INLINE foldr #-} -foldr = G.foldr - --- | /O(n)/ Right fold on non-empty vectors -foldr1 :: Storable a => (a -> a -> a) -> Vector a -> a -{-# INLINE foldr1 #-} -foldr1 = G.foldr1 - --- | /O(n)/ Right fold with a strict accumulator -foldr' :: Storable a => (a -> b -> b) -> b -> Vector a -> b -{-# INLINE foldr' #-} -foldr' = G.foldr' - --- | /O(n)/ Right fold on non-empty vectors with strict accumulator -foldr1' :: Storable a => (a -> a -> a) -> Vector a -> a -{-# INLINE foldr1' #-} -foldr1' = G.foldr1' - --- | /O(n)/ Left fold (function applied to each element and its index) -ifoldl :: Storable b => (a -> Int -> b -> a) -> a -> Vector b -> a -{-# INLINE ifoldl #-} -ifoldl = G.ifoldl - --- | /O(n)/ Left fold with strict accumulator (function applied to each element --- and its index) -ifoldl' :: Storable b => (a -> Int -> b -> a) -> a -> Vector b -> a -{-# INLINE ifoldl' #-} -ifoldl' = G.ifoldl' - --- | /O(n)/ Right fold (function applied to each element and its index) -ifoldr :: Storable a => (Int -> a -> b -> b) -> b -> Vector a -> b -{-# INLINE ifoldr #-} -ifoldr = G.ifoldr - --- | /O(n)/ Right fold with strict accumulator (function applied to each --- element and its index) -ifoldr' :: Storable a => (Int -> a -> b -> b) -> b -> Vector a -> b -{-# INLINE ifoldr' #-} -ifoldr' = G.ifoldr' - --- Specialised folds --- ----------------- - --- | /O(n)/ Check if all elements satisfy the predicate. -all :: Storable a => (a -> Bool) -> Vector a -> Bool -{-# INLINE all #-} -all = G.all - --- | /O(n)/ Check if any element satisfies the predicate. -any :: Storable a => (a -> Bool) -> Vector a -> Bool -{-# INLINE any #-} -any = G.any - --- | /O(n)/ Check if all elements are 'True' -and :: Vector Bool -> Bool -{-# INLINE and #-} -and = G.and - --- | /O(n)/ Check if any element is 'True' -or :: Vector Bool -> Bool -{-# INLINE or #-} -or = G.or - --- | /O(n)/ Compute the sum of the elements -sum :: (Storable a, Num a) => Vector a -> a -{-# INLINE sum #-} -sum = G.sum - --- | /O(n)/ Compute the produce of the elements -product :: (Storable a, Num a) => Vector a -> a -{-# INLINE product #-} -product = G.product - --- | /O(n)/ Yield the maximum element of the vector. The vector may not be --- empty. -maximum :: (Storable a, Ord a) => Vector a -> a -{-# INLINE maximum #-} -maximum = G.maximum - --- | /O(n)/ Yield the maximum element of the vector according to the given --- comparison function. The vector may not be empty. -maximumBy :: Storable a => (a -> a -> Ordering) -> Vector a -> a -{-# INLINE maximumBy #-} -maximumBy = G.maximumBy - --- | /O(n)/ Yield the minimum element of the vector. The vector may not be --- empty. -minimum :: (Storable a, Ord a) => Vector a -> a -{-# INLINE minimum #-} -minimum = G.minimum - --- | /O(n)/ Yield the minimum element of the vector according to the given --- comparison function. The vector may not be empty. -minimumBy :: Storable a => (a -> a -> Ordering) -> Vector a -> a -{-# INLINE minimumBy #-} -minimumBy = G.minimumBy - --- | /O(n)/ Yield the index of the maximum element of the vector. The vector --- may not be empty. -maxIndex :: (Storable a, Ord a) => Vector a -> Int -{-# INLINE maxIndex #-} -maxIndex = G.maxIndex - --- | /O(n)/ Yield the index of the maximum element of the vector according to --- the given comparison function. The vector may not be empty. -maxIndexBy :: Storable a => (a -> a -> Ordering) -> Vector a -> Int -{-# INLINE maxIndexBy #-} -maxIndexBy = G.maxIndexBy - --- | /O(n)/ Yield the index of the minimum element of the vector. The vector --- may not be empty. -minIndex :: (Storable a, Ord a) => Vector a -> Int -{-# INLINE minIndex #-} -minIndex = G.minIndex - --- | /O(n)/ Yield the index of the minimum element of the vector according to --- the given comparison function. The vector may not be empty. -minIndexBy :: Storable a => (a -> a -> Ordering) -> Vector a -> Int -{-# INLINE minIndexBy #-} -minIndexBy = G.minIndexBy - --- Monadic folds --- ------------- - --- | /O(n)/ Monadic fold -foldM :: (Monad m, Storable b) => (a -> b -> m a) -> a -> Vector b -> m a -{-# INLINE foldM #-} -foldM = G.foldM - --- | /O(n)/ Monadic fold over non-empty vectors -fold1M :: (Monad m, Storable a) => (a -> a -> m a) -> Vector a -> m a -{-# INLINE fold1M #-} -fold1M = G.fold1M - --- | /O(n)/ Monadic fold with strict accumulator -foldM' :: (Monad m, Storable b) => (a -> b -> m a) -> a -> Vector b -> m a -{-# INLINE foldM' #-} -foldM' = G.foldM' - --- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator -fold1M' :: (Monad m, Storable a) => (a -> a -> m a) -> Vector a -> m a -{-# INLINE fold1M' #-} -fold1M' = G.fold1M' - --- | /O(n)/ Monadic fold that discards the result -foldM_ :: (Monad m, Storable b) => (a -> b -> m a) -> a -> Vector b -> m () -{-# INLINE foldM_ #-} -foldM_ = G.foldM_ - --- | /O(n)/ Monadic fold over non-empty vectors that discards the result -fold1M_ :: (Monad m, Storable a) => (a -> a -> m a) -> Vector a -> m () -{-# INLINE fold1M_ #-} -fold1M_ = G.fold1M_ - --- | /O(n)/ Monadic fold with strict accumulator that discards the result -foldM'_ :: (Monad m, Storable b) => (a -> b -> m a) -> a -> Vector b -> m () -{-# INLINE foldM'_ #-} -foldM'_ = G.foldM'_ - --- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator --- that discards the result -fold1M'_ :: (Monad m, Storable a) => (a -> a -> m a) -> Vector a -> m () -{-# INLINE fold1M'_ #-} -fold1M'_ = G.fold1M'_ - --- Prefix sums (scans) --- ------------------- - --- | /O(n)/ Prescan --- --- @ --- prescanl f z = 'init' . 'scanl' f z --- @ --- --- Example: @prescanl (+) 0 \<1,2,3,4\> = \<0,1,3,6\>@ --- -prescanl :: (Storable a, Storable b) => (a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE prescanl #-} -prescanl = G.prescanl - --- | /O(n)/ Prescan with strict accumulator -prescanl' :: (Storable a, Storable b) => (a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE prescanl' #-} -prescanl' = G.prescanl' - --- | /O(n)/ Scan --- --- @ --- postscanl f z = 'tail' . 'scanl' f z --- @ --- --- Example: @postscanl (+) 0 \<1,2,3,4\> = \<1,3,6,10\>@ --- -postscanl :: (Storable a, Storable b) => (a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE postscanl #-} -postscanl = G.postscanl - --- | /O(n)/ Scan with strict accumulator -postscanl' :: (Storable a, Storable b) => (a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE postscanl' #-} -postscanl' = G.postscanl' - --- | /O(n)/ Haskell-style scan --- --- > scanl f z <x1,...,xn> = <y1,...,y(n+1)> --- > where y1 = z --- > yi = f y(i-1) x(i-1) --- --- Example: @scanl (+) 0 \<1,2,3,4\> = \<0,1,3,6,10\>@ --- -scanl :: (Storable a, Storable b) => (a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE scanl #-} -scanl = G.scanl - --- | /O(n)/ Haskell-style scan with strict accumulator -scanl' :: (Storable a, Storable b) => (a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE scanl' #-} -scanl' = G.scanl' - --- | /O(n)/ Scan over a non-empty vector --- --- > scanl f <x1,...,xn> = <y1,...,yn> --- > where y1 = x1 --- > yi = f y(i-1) xi --- -scanl1 :: Storable a => (a -> a -> a) -> Vector a -> Vector a -{-# INLINE scanl1 #-} -scanl1 = G.scanl1 - --- | /O(n)/ Scan over a non-empty vector with a strict accumulator -scanl1' :: Storable a => (a -> a -> a) -> Vector a -> Vector a -{-# INLINE scanl1' #-} -scanl1' = G.scanl1' - --- | /O(n)/ Right-to-left prescan --- --- @ --- prescanr f z = 'reverse' . 'prescanl' (flip f) z . 'reverse' --- @ --- -prescanr :: (Storable a, Storable b) => (a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE prescanr #-} -prescanr = G.prescanr - --- | /O(n)/ Right-to-left prescan with strict accumulator -prescanr' :: (Storable a, Storable b) => (a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE prescanr' #-} -prescanr' = G.prescanr' - --- | /O(n)/ Right-to-left scan -postscanr :: (Storable a, Storable b) => (a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE postscanr #-} -postscanr = G.postscanr - --- | /O(n)/ Right-to-left scan with strict accumulator -postscanr' :: (Storable a, Storable b) => (a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE postscanr' #-} -postscanr' = G.postscanr' - --- | /O(n)/ Right-to-left Haskell-style scan -scanr :: (Storable a, Storable b) => (a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE scanr #-} -scanr = G.scanr - --- | /O(n)/ Right-to-left Haskell-style scan with strict accumulator -scanr' :: (Storable a, Storable b) => (a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE scanr' #-} -scanr' = G.scanr' - --- | /O(n)/ Right-to-left scan over a non-empty vector -scanr1 :: Storable a => (a -> a -> a) -> Vector a -> Vector a -{-# INLINE scanr1 #-} -scanr1 = G.scanr1 - --- | /O(n)/ Right-to-left scan over a non-empty vector with a strict --- accumulator -scanr1' :: Storable a => (a -> a -> a) -> Vector a -> Vector a -{-# INLINE scanr1' #-} -scanr1' = G.scanr1' - --- Conversions - Lists --- ------------------------ - --- | /O(n)/ Convert a vector to a list -toList :: Storable a => Vector a -> [a] -{-# INLINE toList #-} -toList = G.toList - --- | /O(n)/ Convert a list to a vector -fromList :: Storable a => [a] -> Vector a -{-# INLINE fromList #-} -fromList = G.fromList - --- | /O(n)/ Convert the first @n@ elements of a list to a vector --- --- @ --- fromListN n xs = 'fromList' ('take' n xs) --- @ -fromListN :: Storable a => Int -> [a] -> Vector a -{-# INLINE fromListN #-} -fromListN = G.fromListN - --- Conversions - Unsafe casts --- -------------------------- - --- | /O(1)/ Unsafely cast a vector from one element type to another. --- The operation just changes the type of the underlying pointer and does not --- modify the elements. --- --- The resulting vector contains as many elements as can fit into the --- underlying memory block. --- -unsafeCast :: forall a b. (Storable a, Storable b) => Vector a -> Vector b -{-# INLINE unsafeCast #-} -unsafeCast (Vector n fp) - = Vector ((n * sizeOf (undefined :: a)) `div` sizeOf (undefined :: b)) - (castForeignPtr fp) - - --- Conversions - Mutable vectors --- ----------------------------- - --- | /O(1)/ Unsafe convert a mutable vector to an immutable one without --- copying. The mutable vector may not be used after this operation. -unsafeFreeze - :: (Storable a, PrimMonad m) => MVector (PrimState m) a -> m (Vector a) -{-# INLINE unsafeFreeze #-} -unsafeFreeze = G.unsafeFreeze - --- | /O(1)/ Unsafely convert an immutable vector to a mutable one without --- copying. The immutable vector may not be used after this operation. -unsafeThaw - :: (Storable a, PrimMonad m) => Vector a -> m (MVector (PrimState m) a) -{-# INLINE unsafeThaw #-} -unsafeThaw = G.unsafeThaw - --- | /O(n)/ Yield a mutable copy of the immutable vector. -thaw :: (Storable a, PrimMonad m) => Vector a -> m (MVector (PrimState m) a) -{-# INLINE thaw #-} -thaw = G.thaw - --- | /O(n)/ Yield an immutable copy of the mutable vector. -freeze :: (Storable a, PrimMonad m) => MVector (PrimState m) a -> m (Vector a) -{-# INLINE freeze #-} -freeze = G.freeze - --- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must --- have the same length. This is not checked. -unsafeCopy - :: (Storable a, PrimMonad m) => MVector (PrimState m) a -> Vector a -> m () -{-# INLINE unsafeCopy #-} -unsafeCopy = G.unsafeCopy - --- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must --- have the same length. -copy :: (Storable a, PrimMonad m) => MVector (PrimState m) a -> Vector a -> m () -{-# INLINE copy #-} -copy = G.copy - --- Conversions - Raw pointers --- -------------------------- - --- | /O(1)/ Create a vector from a 'ForeignPtr' with an offset and a length. --- --- The data may not be modified through the 'ForeignPtr' afterwards. --- --- If your offset is 0 it is more efficient to use 'unsafeFromForeignPtr0'. -unsafeFromForeignPtr :: Storable a - => ForeignPtr a -- ^ pointer - -> Int -- ^ offset - -> Int -- ^ length - -> Vector a -{-# INLINE_FUSED unsafeFromForeignPtr #-} -unsafeFromForeignPtr fp i n = unsafeFromForeignPtr0 fp' n - where - fp' = updPtr (`advancePtr` i) fp - -{-# RULES -"unsafeFromForeignPtr fp 0 n -> unsafeFromForeignPtr0 fp n " forall fp n. - unsafeFromForeignPtr fp 0 n = unsafeFromForeignPtr0 fp n #-} - - --- | /O(1)/ Create a vector from a 'ForeignPtr' and a length. --- --- It is assumed the pointer points directly to the data (no offset). --- Use `unsafeFromForeignPtr` if you need to specify an offset. --- --- The data may not be modified through the 'ForeignPtr' afterwards. -unsafeFromForeignPtr0 :: Storable a - => ForeignPtr a -- ^ pointer - -> Int -- ^ length - -> Vector a -{-# INLINE unsafeFromForeignPtr0 #-} -unsafeFromForeignPtr0 fp n = Vector n fp - --- | /O(1)/ Yield the underlying 'ForeignPtr' together with the offset to the --- data and its length. The data may not be modified through the 'ForeignPtr'. -unsafeToForeignPtr :: Storable a => Vector a -> (ForeignPtr a, Int, Int) -{-# INLINE unsafeToForeignPtr #-} -unsafeToForeignPtr (Vector n fp) = (fp, 0, n) - --- | /O(1)/ Yield the underlying 'ForeignPtr' together with its length. --- --- You can assume the pointer points directly to the data (no offset). --- --- The data may not be modified through the 'ForeignPtr'. -unsafeToForeignPtr0 :: Storable a => Vector a -> (ForeignPtr a, Int) -{-# INLINE unsafeToForeignPtr0 #-} -unsafeToForeignPtr0 (Vector n fp) = (fp, n) - --- | Pass a pointer to the vector's data to the IO action. The data may not be --- modified through the 'Ptr. -unsafeWith :: Storable a => Vector a -> (Ptr a -> IO b) -> IO b -{-# INLINE unsafeWith #-} -unsafeWith (Vector _ fp) = withForeignPtr fp diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Storable/Internal.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Storable/Internal.hs deleted file mode 100644 index 69a46d84215b..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Storable/Internal.hs +++ /dev/null @@ -1,33 +0,0 @@ --- | --- Module : Data.Vector.Storable.Internal --- Copyright : (c) Roman Leshchinskiy 2009-2010 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Stability : experimental --- Portability : non-portable --- --- Ugly internal utility functions for implementing 'Storable'-based vectors. --- - -module Data.Vector.Storable.Internal ( - getPtr, setPtr, updPtr -) where - -import Foreign.ForeignPtr -import Foreign.Ptr -import GHC.ForeignPtr ( ForeignPtr(..) ) -import GHC.Ptr ( Ptr(..) ) - -getPtr :: ForeignPtr a -> Ptr a -{-# INLINE getPtr #-} -getPtr (ForeignPtr addr _) = Ptr addr - -setPtr :: ForeignPtr a -> Ptr a -> ForeignPtr a -{-# INLINE setPtr #-} -setPtr (ForeignPtr _ c) (Ptr addr) = ForeignPtr addr c - -updPtr :: (Ptr a -> Ptr a) -> ForeignPtr a -> ForeignPtr a -{-# INLINE updPtr #-} -updPtr f (ForeignPtr p c) = case f (Ptr p) of { Ptr q -> ForeignPtr q c } - diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Storable/Mutable.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Storable/Mutable.hs deleted file mode 100644 index 29eb2fbfa31e..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Storable/Mutable.hs +++ /dev/null @@ -1,543 +0,0 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, MagicHash, MultiParamTypeClasses, ScopedTypeVariables #-} - --- | --- Module : Data.Vector.Storable.Mutable --- Copyright : (c) Roman Leshchinskiy 2009-2010 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Stability : experimental --- Portability : non-portable --- --- Mutable vectors based on Storable. --- - -module Data.Vector.Storable.Mutable( - -- * Mutable vectors of 'Storable' types - MVector(..), IOVector, STVector, Storable, - - -- * Accessors - - -- ** Length information - length, null, - - -- ** Extracting subvectors - slice, init, tail, take, drop, splitAt, - unsafeSlice, unsafeInit, unsafeTail, unsafeTake, unsafeDrop, - - -- ** Overlapping - overlaps, - - -- * Construction - - -- ** Initialisation - new, unsafeNew, replicate, replicateM, clone, - - -- ** Growing - grow, unsafeGrow, - - -- ** Restricting memory usage - clear, - - -- * Accessing individual elements - read, write, modify, swap, - unsafeRead, unsafeWrite, unsafeModify, unsafeSwap, - - -- * Modifying vectors - - -- ** Filling and copying - set, copy, move, unsafeCopy, unsafeMove, - - -- * Unsafe conversions - unsafeCast, - - -- * Raw pointers - unsafeFromForeignPtr, unsafeFromForeignPtr0, - unsafeToForeignPtr, unsafeToForeignPtr0, - unsafeWith -) where - -import Control.DeepSeq ( NFData(rnf) ) - -import qualified Data.Vector.Generic.Mutable as G -import Data.Vector.Storable.Internal - -import Foreign.Storable -import Foreign.ForeignPtr - -#if __GLASGOW_HASKELL__ >= 706 -import GHC.ForeignPtr (mallocPlainForeignPtrAlignedBytes) -#elif __GLASGOW_HASKELL__ >= 700 -import Data.Primitive.ByteArray (MutableByteArray(..), newAlignedPinnedByteArray, - unsafeFreezeByteArray) -import GHC.Prim (byteArrayContents#, unsafeCoerce#) -import GHC.ForeignPtr -#endif - -import Foreign.Ptr -import Foreign.Marshal.Array ( advancePtr, copyArray, moveArray ) - -import Control.Monad.Primitive -import Data.Primitive.Addr -import Data.Primitive.Types (Prim) - -import GHC.Word (Word8, Word16, Word32, Word64) -import GHC.Ptr (Ptr(..)) - -import Prelude hiding ( length, null, replicate, reverse, map, read, - take, drop, splitAt, init, tail ) - -import Data.Typeable ( Typeable ) - --- Data.Vector.Internal.Check is not needed -#define NOT_VECTOR_MODULE -#include "vector.h" - --- | Mutable 'Storable'-based vectors -data MVector s a = MVector {-# UNPACK #-} !Int - {-# UNPACK #-} !(ForeignPtr a) - deriving ( Typeable ) - -type IOVector = MVector RealWorld -type STVector s = MVector s - -instance NFData (MVector s a) where - rnf (MVector _ _) = () - -instance Storable a => G.MVector MVector a where - {-# INLINE basicLength #-} - basicLength (MVector n _) = n - - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice j m (MVector _ fp) = MVector m (updPtr (`advancePtr` j) fp) - - -- FIXME: this relies on non-portable pointer comparisons - {-# INLINE basicOverlaps #-} - basicOverlaps (MVector m fp) (MVector n fq) - = between p q (q `advancePtr` n) || between q p (p `advancePtr` m) - where - between x y z = x >= y && x < z - p = getPtr fp - q = getPtr fq - - {-# INLINE basicUnsafeNew #-} - basicUnsafeNew n - | n < 0 = error $ "Storable.basicUnsafeNew: negative length: " ++ show n - | n > mx = error $ "Storable.basicUnsafeNew: length too large: " ++ show n - | otherwise = unsafePrimToPrim $ do - fp <- mallocVector n - return $ MVector n fp - where - size = sizeOf (undefined :: a) - mx = maxBound `quot` size :: Int - - {-# INLINE basicInitialize #-} - basicInitialize = storableZero - - {-# INLINE basicUnsafeRead #-} - basicUnsafeRead (MVector _ fp) i - = unsafePrimToPrim - $ withForeignPtr fp (`peekElemOff` i) - - {-# INLINE basicUnsafeWrite #-} - basicUnsafeWrite (MVector _ fp) i x - = unsafePrimToPrim - $ withForeignPtr fp $ \p -> pokeElemOff p i x - - {-# INLINE basicSet #-} - basicSet = storableSet - - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy (MVector n fp) (MVector _ fq) - = unsafePrimToPrim - $ withForeignPtr fp $ \p -> - withForeignPtr fq $ \q -> - copyArray p q n - - {-# INLINE basicUnsafeMove #-} - basicUnsafeMove (MVector n fp) (MVector _ fq) - = unsafePrimToPrim - $ withForeignPtr fp $ \p -> - withForeignPtr fq $ \q -> - moveArray p q n - -storableZero :: forall a m. (Storable a, PrimMonad m) => MVector (PrimState m) a -> m () -{-# INLINE storableZero #-} -storableZero (MVector n fp) = unsafePrimToPrim . withForeignPtr fp $ \(Ptr p) -> do - let q = Addr p - setAddr q byteSize (0 :: Word8) - where - x :: a - x = undefined - - byteSize :: Int - byteSize = n * sizeOf x - -storableSet :: (Storable a, PrimMonad m) => MVector (PrimState m) a -> a -> m () -{-# INLINE storableSet #-} -storableSet (MVector n fp) x - | n == 0 = return () - | otherwise = unsafePrimToPrim $ - case sizeOf x of - 1 -> storableSetAsPrim n fp x (undefined :: Word8) - 2 -> storableSetAsPrim n fp x (undefined :: Word16) - 4 -> storableSetAsPrim n fp x (undefined :: Word32) - 8 -> storableSetAsPrim n fp x (undefined :: Word64) - _ -> withForeignPtr fp $ \p -> do - poke p x - - let do_set i - | 2*i < n = do - copyArray (p `advancePtr` i) p i - do_set (2*i) - | otherwise = copyArray (p `advancePtr` i) p (n-i) - - do_set 1 - -storableSetAsPrim - :: (Storable a, Prim b) => Int -> ForeignPtr a -> a -> b -> IO () -{-# INLINE [0] storableSetAsPrim #-} -storableSetAsPrim n fp x y = withForeignPtr fp $ \(Ptr p) -> do - poke (Ptr p) x - let q = Addr p - w <- readOffAddr q 0 - setAddr (q `plusAddr` sizeOf x) (n-1) (w `asTypeOf` y) - -{-# INLINE mallocVector #-} -mallocVector :: Storable a => Int -> IO (ForeignPtr a) -mallocVector = -#if __GLASGOW_HASKELL__ >= 706 - doMalloc undefined - where - doMalloc :: Storable b => b -> Int -> IO (ForeignPtr b) - doMalloc dummy size = - mallocPlainForeignPtrAlignedBytes (size * sizeOf dummy) (alignment dummy) -#elif __GLASGOW_HASKELL__ >= 700 - doMalloc undefined - where - doMalloc :: Storable b => b -> Int -> IO (ForeignPtr b) - doMalloc dummy size = do - arr@(MutableByteArray arr#) <- newAlignedPinnedByteArray arrSize arrAlign - newConcForeignPtr - (Ptr (byteArrayContents# (unsafeCoerce# arr#))) - -- Keep reference to mutable byte array until whole ForeignPtr goes out - -- of scope. - (touch arr) - where - arrSize = size * sizeOf dummy - arrAlign = alignment dummy -#else - mallocForeignPtrArray -#endif - --- Length information --- ------------------ - --- | Length of the mutable vector. -length :: Storable a => MVector s a -> Int -{-# INLINE length #-} -length = G.length - --- | Check whether the vector is empty -null :: Storable a => MVector s a -> Bool -{-# INLINE null #-} -null = G.null - --- Extracting subvectors --- --------------------- - --- | Yield a part of the mutable vector without copying it. -slice :: Storable a => Int -> Int -> MVector s a -> MVector s a -{-# INLINE slice #-} -slice = G.slice - -take :: Storable a => Int -> MVector s a -> MVector s a -{-# INLINE take #-} -take = G.take - -drop :: Storable a => Int -> MVector s a -> MVector s a -{-# INLINE drop #-} -drop = G.drop - -splitAt :: Storable a => Int -> MVector s a -> (MVector s a, MVector s a) -{-# INLINE splitAt #-} -splitAt = G.splitAt - -init :: Storable a => MVector s a -> MVector s a -{-# INLINE init #-} -init = G.init - -tail :: Storable a => MVector s a -> MVector s a -{-# INLINE tail #-} -tail = G.tail - --- | Yield a part of the mutable vector without copying it. No bounds checks --- are performed. -unsafeSlice :: Storable a - => Int -- ^ starting index - -> Int -- ^ length of the slice - -> MVector s a - -> MVector s a -{-# INLINE unsafeSlice #-} -unsafeSlice = G.unsafeSlice - -unsafeTake :: Storable a => Int -> MVector s a -> MVector s a -{-# INLINE unsafeTake #-} -unsafeTake = G.unsafeTake - -unsafeDrop :: Storable a => Int -> MVector s a -> MVector s a -{-# INLINE unsafeDrop #-} -unsafeDrop = G.unsafeDrop - -unsafeInit :: Storable a => MVector s a -> MVector s a -{-# INLINE unsafeInit #-} -unsafeInit = G.unsafeInit - -unsafeTail :: Storable a => MVector s a -> MVector s a -{-# INLINE unsafeTail #-} -unsafeTail = G.unsafeTail - --- Overlapping --- ----------- - --- | Check whether two vectors overlap. -overlaps :: Storable a => MVector s a -> MVector s a -> Bool -{-# INLINE overlaps #-} -overlaps = G.overlaps - --- Initialisation --- -------------- - --- | Create a mutable vector of the given length. -new :: (PrimMonad m, Storable a) => Int -> m (MVector (PrimState m) a) -{-# INLINE new #-} -new = G.new - --- | Create a mutable vector of the given length. The memory is not initialized. -unsafeNew :: (PrimMonad m, Storable a) => Int -> m (MVector (PrimState m) a) -{-# INLINE unsafeNew #-} -unsafeNew = G.unsafeNew - --- | Create a mutable vector of the given length (0 if the length is negative) --- and fill it with an initial value. -replicate :: (PrimMonad m, Storable a) => Int -> a -> m (MVector (PrimState m) a) -{-# INLINE replicate #-} -replicate = G.replicate - --- | Create a mutable vector of the given length (0 if the length is negative) --- and fill it with values produced by repeatedly executing the monadic action. -replicateM :: (PrimMonad m, Storable a) => Int -> m a -> m (MVector (PrimState m) a) -{-# INLINE replicateM #-} -replicateM = G.replicateM - --- | Create a copy of a mutable vector. -clone :: (PrimMonad m, Storable a) - => MVector (PrimState m) a -> m (MVector (PrimState m) a) -{-# INLINE clone #-} -clone = G.clone - --- Growing --- ------- - --- | Grow a vector by the given number of elements. The number must be --- positive. -grow :: (PrimMonad m, Storable a) - => MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a) -{-# INLINE grow #-} -grow = G.grow - --- | Grow a vector by the given number of elements. The number must be --- positive but this is not checked. -unsafeGrow :: (PrimMonad m, Storable a) - => MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a) -{-# INLINE unsafeGrow #-} -unsafeGrow = G.unsafeGrow - --- Restricting memory usage --- ------------------------ - --- | Reset all elements of the vector to some undefined value, clearing all --- references to external objects. This is usually a noop for unboxed vectors. -clear :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> m () -{-# INLINE clear #-} -clear = G.clear - --- Accessing individual elements --- ----------------------------- - --- | Yield the element at the given position. -read :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> Int -> m a -{-# INLINE read #-} -read = G.read - --- | Replace the element at the given position. -write - :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> Int -> a -> m () -{-# INLINE write #-} -write = G.write - --- | Modify the element at the given position. -modify :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> (a -> a) -> Int -> m () -{-# INLINE modify #-} -modify = G.modify - --- | Swap the elements at the given positions. -swap - :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> Int -> Int -> m () -{-# INLINE swap #-} -swap = G.swap - - --- | Yield the element at the given position. No bounds checks are performed. -unsafeRead :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> Int -> m a -{-# INLINE unsafeRead #-} -unsafeRead = G.unsafeRead - --- | Replace the element at the given position. No bounds checks are performed. -unsafeWrite - :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> Int -> a -> m () -{-# INLINE unsafeWrite #-} -unsafeWrite = G.unsafeWrite - --- | Modify the element at the given position. No bounds checks are performed. -unsafeModify :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> (a -> a) -> Int -> m () -{-# INLINE unsafeModify #-} -unsafeModify = G.unsafeModify - --- | Swap the elements at the given positions. No bounds checks are performed. -unsafeSwap - :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> Int -> Int -> m () -{-# INLINE unsafeSwap #-} -unsafeSwap = G.unsafeSwap - --- Filling and copying --- ------------------- - --- | Set all elements of the vector to the given value. -set :: (PrimMonad m, Storable a) => MVector (PrimState m) a -> a -> m () -{-# INLINE set #-} -set = G.set - --- | Copy a vector. The two vectors must have the same length and may not --- overlap. -copy :: (PrimMonad m, Storable a) - => MVector (PrimState m) a -- ^ target - -> MVector (PrimState m) a -- ^ source - -> m () -{-# INLINE copy #-} -copy = G.copy - --- | Copy a vector. The two vectors must have the same length and may not --- overlap. This is not checked. -unsafeCopy :: (PrimMonad m, Storable a) - => MVector (PrimState m) a -- ^ target - -> MVector (PrimState m) a -- ^ source - -> m () -{-# INLINE unsafeCopy #-} -unsafeCopy = G.unsafeCopy - --- | Move the contents of a vector. The two vectors must have the same --- length. --- --- If the vectors do not overlap, then this is equivalent to 'copy'. --- Otherwise, the copying is performed as if the source vector were --- copied to a temporary vector and then the temporary vector was copied --- to the target vector. -move :: (PrimMonad m, Storable a) - => MVector (PrimState m) a -> MVector (PrimState m) a -> m () -{-# INLINE move #-} -move = G.move - --- | Move the contents of a vector. The two vectors must have the same --- length, but this is not checked. --- --- If the vectors do not overlap, then this is equivalent to 'unsafeCopy'. --- Otherwise, the copying is performed as if the source vector were --- copied to a temporary vector and then the temporary vector was copied --- to the target vector. -unsafeMove :: (PrimMonad m, Storable a) - => MVector (PrimState m) a -- ^ target - -> MVector (PrimState m) a -- ^ source - -> m () -{-# INLINE unsafeMove #-} -unsafeMove = G.unsafeMove - --- Unsafe conversions --- ------------------ - --- | /O(1)/ Unsafely cast a mutable vector from one element type to another. --- The operation just changes the type of the underlying pointer and does not --- modify the elements. --- --- The resulting vector contains as many elements as can fit into the --- underlying memory block. --- -unsafeCast :: forall a b s. - (Storable a, Storable b) => MVector s a -> MVector s b -{-# INLINE unsafeCast #-} -unsafeCast (MVector n fp) - = MVector ((n * sizeOf (undefined :: a)) `div` sizeOf (undefined :: b)) - (castForeignPtr fp) - --- Raw pointers --- ------------ - --- | Create a mutable vector from a 'ForeignPtr' with an offset and a length. --- --- Modifying data through the 'ForeignPtr' afterwards is unsafe if the vector --- could have been frozen before the modification. --- --- If your offset is 0 it is more efficient to use 'unsafeFromForeignPtr0'. -unsafeFromForeignPtr :: Storable a - => ForeignPtr a -- ^ pointer - -> Int -- ^ offset - -> Int -- ^ length - -> MVector s a -{-# INLINE_FUSED unsafeFromForeignPtr #-} -unsafeFromForeignPtr fp i n = unsafeFromForeignPtr0 fp' n - where - fp' = updPtr (`advancePtr` i) fp - -{-# RULES -"unsafeFromForeignPtr fp 0 n -> unsafeFromForeignPtr0 fp n " forall fp n. - unsafeFromForeignPtr fp 0 n = unsafeFromForeignPtr0 fp n #-} - - --- | /O(1)/ Create a mutable vector from a 'ForeignPtr' and a length. --- --- It is assumed the pointer points directly to the data (no offset). --- Use `unsafeFromForeignPtr` if you need to specify an offset. --- --- Modifying data through the 'ForeignPtr' afterwards is unsafe if the vector --- could have been frozen before the modification. -unsafeFromForeignPtr0 :: Storable a - => ForeignPtr a -- ^ pointer - -> Int -- ^ length - -> MVector s a -{-# INLINE unsafeFromForeignPtr0 #-} -unsafeFromForeignPtr0 fp n = MVector n fp - --- | Yield the underlying 'ForeignPtr' together with the offset to the data --- and its length. Modifying the data through the 'ForeignPtr' is --- unsafe if the vector could have frozen before the modification. -unsafeToForeignPtr :: Storable a => MVector s a -> (ForeignPtr a, Int, Int) -{-# INLINE unsafeToForeignPtr #-} -unsafeToForeignPtr (MVector n fp) = (fp, 0, n) - --- | /O(1)/ Yield the underlying 'ForeignPtr' together with its length. --- --- You can assume the pointer points directly to the data (no offset). --- --- Modifying the data through the 'ForeignPtr' is unsafe if the vector could --- have frozen before the modification. -unsafeToForeignPtr0 :: Storable a => MVector s a -> (ForeignPtr a, Int) -{-# INLINE unsafeToForeignPtr0 #-} -unsafeToForeignPtr0 (MVector n fp) = (fp, n) - --- | Pass a pointer to the vector's data to the IO action. Modifying data --- through the pointer is unsafe if the vector could have been frozen before --- the modification. -unsafeWith :: Storable a => IOVector a -> (Ptr a -> IO b) -> IO b -{-# INLINE unsafeWith #-} -unsafeWith (MVector _ fp) = withForeignPtr fp - diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Unboxed.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Unboxed.hs deleted file mode 100644 index 72dd109fb3b4..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Unboxed.hs +++ /dev/null @@ -1,1488 +0,0 @@ -{-# LANGUAGE CPP, Rank2Types, TypeFamilies #-} - --- | --- Module : Data.Vector.Unboxed --- Copyright : (c) Roman Leshchinskiy 2009-2010 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Stability : experimental --- Portability : non-portable --- --- Adaptive unboxed vectors. The implementation is based on type families --- and picks an efficient, specialised representation for every element type. --- In particular, unboxed vectors of pairs are represented as pairs of unboxed --- vectors. --- --- Implementing unboxed vectors for new data types can be very easy. Here is --- how the library does this for 'Complex' by simply wrapping vectors of --- pairs. --- --- @ --- newtype instance 'MVector' s ('Complex' a) = MV_Complex ('MVector' s (a,a)) --- newtype instance 'Vector' ('Complex' a) = V_Complex ('Vector' (a,a)) --- --- instance ('RealFloat' a, 'Unbox' a) => 'Data.Vector.Generic.Mutable.MVector' 'MVector' ('Complex' a) where --- {-\# INLINE basicLength \#-} --- basicLength (MV_Complex v) = 'Data.Vector.Generic.Mutable.basicLength' v --- ... --- --- instance ('RealFloat' a, 'Unbox' a) => Data.Vector.Generic.Vector 'Vector' ('Complex' a) where --- {-\# INLINE basicLength \#-} --- basicLength (V_Complex v) = Data.Vector.Generic.basicLength v --- ... --- --- instance ('RealFloat' a, 'Unbox' a) => 'Unbox' ('Complex' a) --- @ - -module Data.Vector.Unboxed ( - -- * Unboxed vectors - Vector, MVector(..), Unbox, - - -- * Accessors - - -- ** Length information - length, null, - - -- ** Indexing - (!), (!?), head, last, - unsafeIndex, unsafeHead, unsafeLast, - - -- ** Monadic indexing - indexM, headM, lastM, - unsafeIndexM, unsafeHeadM, unsafeLastM, - - -- ** Extracting subvectors (slicing) - slice, init, tail, take, drop, splitAt, - unsafeSlice, unsafeInit, unsafeTail, unsafeTake, unsafeDrop, - - -- * Construction - - -- ** Initialisation - empty, singleton, replicate, generate, iterateN, - - -- ** Monadic initialisation - replicateM, generateM, iterateNM, create, createT, - - -- ** Unfolding - unfoldr, unfoldrN, - unfoldrM, unfoldrNM, - constructN, constructrN, - - -- ** Enumeration - enumFromN, enumFromStepN, enumFromTo, enumFromThenTo, - - -- ** Concatenation - cons, snoc, (++), concat, - - -- ** Restricting memory usage - force, - - -- * Modifying vectors - - -- ** Bulk updates - (//), update, update_, - unsafeUpd, unsafeUpdate, unsafeUpdate_, - - -- ** Accumulations - accum, accumulate, accumulate_, - unsafeAccum, unsafeAccumulate, unsafeAccumulate_, - - -- ** Permutations - reverse, backpermute, unsafeBackpermute, - - -- ** Safe destructive updates - modify, - - -- * Elementwise operations - - -- ** Indexing - indexed, - - -- ** Mapping - map, imap, concatMap, - - -- ** Monadic mapping - mapM, imapM, mapM_, imapM_, forM, forM_, - - -- ** Zipping - zipWith, zipWith3, zipWith4, zipWith5, zipWith6, - izipWith, izipWith3, izipWith4, izipWith5, izipWith6, - zip, zip3, zip4, zip5, zip6, - - -- ** Monadic zipping - zipWithM, izipWithM, zipWithM_, izipWithM_, - - -- ** Unzipping - unzip, unzip3, unzip4, unzip5, unzip6, - - -- * Working with predicates - - -- ** Filtering - filter, ifilter, uniq, - mapMaybe, imapMaybe, - filterM, - takeWhile, dropWhile, - - -- ** Partitioning - partition, unstablePartition, span, break, - - -- ** Searching - elem, notElem, find, findIndex, findIndices, elemIndex, elemIndices, - - -- * Folding - foldl, foldl1, foldl', foldl1', foldr, foldr1, foldr', foldr1', - ifoldl, ifoldl', ifoldr, ifoldr', - - -- ** Specialised folds - all, any, and, or, - sum, product, - maximum, maximumBy, minimum, minimumBy, - minIndex, minIndexBy, maxIndex, maxIndexBy, - - -- ** Monadic folds - foldM, ifoldM, foldM', ifoldM', - fold1M, fold1M', foldM_, ifoldM_, - foldM'_, ifoldM'_, fold1M_, fold1M'_, - - -- * Prefix sums (scans) - prescanl, prescanl', - postscanl, postscanl', - scanl, scanl', scanl1, scanl1', - prescanr, prescanr', - postscanr, postscanr', - scanr, scanr', scanr1, scanr1', - - -- * Conversions - - -- ** Lists - toList, fromList, fromListN, - - -- ** Other vector types - G.convert, - - -- ** Mutable vectors - freeze, thaw, copy, unsafeFreeze, unsafeThaw, unsafeCopy -) where - -import Data.Vector.Unboxed.Base -import qualified Data.Vector.Generic as G -import qualified Data.Vector.Fusion.Bundle as Bundle -import Data.Vector.Fusion.Util ( delayed_min ) - -import Control.Monad.ST ( ST ) -import Control.Monad.Primitive - -import Prelude hiding ( length, null, - replicate, (++), concat, - head, last, - init, tail, take, drop, splitAt, reverse, - map, concatMap, - zipWith, zipWith3, zip, zip3, unzip, unzip3, - filter, takeWhile, dropWhile, span, break, - elem, notElem, - foldl, foldl1, foldr, foldr1, - all, any, and, or, sum, product, minimum, maximum, - scanl, scanl1, scanr, scanr1, - enumFromTo, enumFromThenTo, - mapM, mapM_ ) - -import Text.Read ( Read(..), readListPrecDefault ) -import Data.Semigroup ( Semigroup(..) ) - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid ( Monoid(..) ) -import Data.Traversable ( Traversable ) -#endif - -#if __GLASGOW_HASKELL__ >= 708 -import qualified GHC.Exts as Exts (IsList(..)) -#endif - -#define NOT_VECTOR_MODULE -#include "vector.h" - --- See http://trac.haskell.org/vector/ticket/12 -instance (Unbox a, Eq a) => Eq (Vector a) where - {-# INLINE (==) #-} - xs == ys = Bundle.eq (G.stream xs) (G.stream ys) - - {-# INLINE (/=) #-} - xs /= ys = not (Bundle.eq (G.stream xs) (G.stream ys)) - --- See http://trac.haskell.org/vector/ticket/12 -instance (Unbox a, Ord a) => Ord (Vector a) where - {-# INLINE compare #-} - compare xs ys = Bundle.cmp (G.stream xs) (G.stream ys) - - {-# INLINE (<) #-} - xs < ys = Bundle.cmp (G.stream xs) (G.stream ys) == LT - - {-# INLINE (<=) #-} - xs <= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= GT - - {-# INLINE (>) #-} - xs > ys = Bundle.cmp (G.stream xs) (G.stream ys) == GT - - {-# INLINE (>=) #-} - xs >= ys = Bundle.cmp (G.stream xs) (G.stream ys) /= LT - -instance Unbox a => Semigroup (Vector a) where - {-# INLINE (<>) #-} - (<>) = (++) - - {-# INLINE sconcat #-} - sconcat = G.concatNE - -instance Unbox a => Monoid (Vector a) where - {-# INLINE mempty #-} - mempty = empty - - {-# INLINE mappend #-} - mappend = (++) - - {-# INLINE mconcat #-} - mconcat = concat - -instance (Show a, Unbox a) => Show (Vector a) where - showsPrec = G.showsPrec - -instance (Read a, Unbox a) => Read (Vector a) where - readPrec = G.readPrec - readListPrec = readListPrecDefault - -#if __GLASGOW_HASKELL__ >= 708 - -instance (Unbox e) => Exts.IsList (Vector e) where - type Item (Vector e) = e - fromList = fromList - fromListN = fromListN - toList = toList - -#endif - --- Length information --- ------------------ - --- | /O(1)/ Yield the length of the vector -length :: Unbox a => Vector a -> Int -{-# INLINE length #-} -length = G.length - --- | /O(1)/ Test whether a vector is empty -null :: Unbox a => Vector a -> Bool -{-# INLINE null #-} -null = G.null - --- Indexing --- -------- - --- | O(1) Indexing -(!) :: Unbox a => Vector a -> Int -> a -{-# INLINE (!) #-} -(!) = (G.!) - --- | O(1) Safe indexing -(!?) :: Unbox a => Vector a -> Int -> Maybe a -{-# INLINE (!?) #-} -(!?) = (G.!?) - --- | /O(1)/ First element -head :: Unbox a => Vector a -> a -{-# INLINE head #-} -head = G.head - --- | /O(1)/ Last element -last :: Unbox a => Vector a -> a -{-# INLINE last #-} -last = G.last - --- | /O(1)/ Unsafe indexing without bounds checking -unsafeIndex :: Unbox a => Vector a -> Int -> a -{-# INLINE unsafeIndex #-} -unsafeIndex = G.unsafeIndex - --- | /O(1)/ First element without checking if the vector is empty -unsafeHead :: Unbox a => Vector a -> a -{-# INLINE unsafeHead #-} -unsafeHead = G.unsafeHead - --- | /O(1)/ Last element without checking if the vector is empty -unsafeLast :: Unbox a => Vector a -> a -{-# INLINE unsafeLast #-} -unsafeLast = G.unsafeLast - --- Monadic indexing --- ---------------- - --- | /O(1)/ Indexing in a monad. --- --- The monad allows operations to be strict in the vector when necessary. --- Suppose vector copying is implemented like this: --- --- > copy mv v = ... write mv i (v ! i) ... --- --- For lazy vectors, @v ! i@ would not be evaluated which means that @mv@ --- would unnecessarily retain a reference to @v@ in each element written. --- --- With 'indexM', copying can be implemented like this instead: --- --- > copy mv v = ... do --- > x <- indexM v i --- > write mv i x --- --- Here, no references to @v@ are retained because indexing (but /not/ the --- elements) is evaluated eagerly. --- -indexM :: (Unbox a, Monad m) => Vector a -> Int -> m a -{-# INLINE indexM #-} -indexM = G.indexM - --- | /O(1)/ First element of a vector in a monad. See 'indexM' for an --- explanation of why this is useful. -headM :: (Unbox a, Monad m) => Vector a -> m a -{-# INLINE headM #-} -headM = G.headM - --- | /O(1)/ Last element of a vector in a monad. See 'indexM' for an --- explanation of why this is useful. -lastM :: (Unbox a, Monad m) => Vector a -> m a -{-# INLINE lastM #-} -lastM = G.lastM - --- | /O(1)/ Indexing in a monad without bounds checks. See 'indexM' for an --- explanation of why this is useful. -unsafeIndexM :: (Unbox a, Monad m) => Vector a -> Int -> m a -{-# INLINE unsafeIndexM #-} -unsafeIndexM = G.unsafeIndexM - --- | /O(1)/ First element in a monad without checking for empty vectors. --- See 'indexM' for an explanation of why this is useful. -unsafeHeadM :: (Unbox a, Monad m) => Vector a -> m a -{-# INLINE unsafeHeadM #-} -unsafeHeadM = G.unsafeHeadM - --- | /O(1)/ Last element in a monad without checking for empty vectors. --- See 'indexM' for an explanation of why this is useful. -unsafeLastM :: (Unbox a, Monad m) => Vector a -> m a -{-# INLINE unsafeLastM #-} -unsafeLastM = G.unsafeLastM - --- Extracting subvectors (slicing) --- ------------------------------- - --- | /O(1)/ Yield a slice of the vector without copying it. The vector must --- contain at least @i+n@ elements. -slice :: Unbox a => Int -- ^ @i@ starting index - -> Int -- ^ @n@ length - -> Vector a - -> Vector a -{-# INLINE slice #-} -slice = G.slice - --- | /O(1)/ Yield all but the last element without copying. The vector may not --- be empty. -init :: Unbox a => Vector a -> Vector a -{-# INLINE init #-} -init = G.init - --- | /O(1)/ Yield all but the first element without copying. The vector may not --- be empty. -tail :: Unbox a => Vector a -> Vector a -{-# INLINE tail #-} -tail = G.tail - --- | /O(1)/ Yield at the first @n@ elements without copying. The vector may --- contain less than @n@ elements in which case it is returned unchanged. -take :: Unbox a => Int -> Vector a -> Vector a -{-# INLINE take #-} -take = G.take - --- | /O(1)/ Yield all but the first @n@ elements without copying. The vector may --- contain less than @n@ elements in which case an empty vector is returned. -drop :: Unbox a => Int -> Vector a -> Vector a -{-# INLINE drop #-} -drop = G.drop - --- | /O(1)/ Yield the first @n@ elements paired with the remainder without copying. --- --- Note that @'splitAt' n v@ is equivalent to @('take' n v, 'drop' n v)@ --- but slightly more efficient. -{-# INLINE splitAt #-} -splitAt :: Unbox a => Int -> Vector a -> (Vector a, Vector a) -splitAt = G.splitAt - --- | /O(1)/ Yield a slice of the vector without copying. The vector must --- contain at least @i+n@ elements but this is not checked. -unsafeSlice :: Unbox a => Int -- ^ @i@ starting index - -> Int -- ^ @n@ length - -> Vector a - -> Vector a -{-# INLINE unsafeSlice #-} -unsafeSlice = G.unsafeSlice - --- | /O(1)/ Yield all but the last element without copying. The vector may not --- be empty but this is not checked. -unsafeInit :: Unbox a => Vector a -> Vector a -{-# INLINE unsafeInit #-} -unsafeInit = G.unsafeInit - --- | /O(1)/ Yield all but the first element without copying. The vector may not --- be empty but this is not checked. -unsafeTail :: Unbox a => Vector a -> Vector a -{-# INLINE unsafeTail #-} -unsafeTail = G.unsafeTail - --- | /O(1)/ Yield the first @n@ elements without copying. The vector must --- contain at least @n@ elements but this is not checked. -unsafeTake :: Unbox a => Int -> Vector a -> Vector a -{-# INLINE unsafeTake #-} -unsafeTake = G.unsafeTake - --- | /O(1)/ Yield all but the first @n@ elements without copying. The vector --- must contain at least @n@ elements but this is not checked. -unsafeDrop :: Unbox a => Int -> Vector a -> Vector a -{-# INLINE unsafeDrop #-} -unsafeDrop = G.unsafeDrop - --- Initialisation --- -------------- - --- | /O(1)/ Empty vector -empty :: Unbox a => Vector a -{-# INLINE empty #-} -empty = G.empty - --- | /O(1)/ Vector with exactly one element -singleton :: Unbox a => a -> Vector a -{-# INLINE singleton #-} -singleton = G.singleton - --- | /O(n)/ Vector of the given length with the same value in each position -replicate :: Unbox a => Int -> a -> Vector a -{-# INLINE replicate #-} -replicate = G.replicate - --- | /O(n)/ Construct a vector of the given length by applying the function to --- each index -generate :: Unbox a => Int -> (Int -> a) -> Vector a -{-# INLINE generate #-} -generate = G.generate - --- | /O(n)/ Apply function n times to value. Zeroth element is original value. -iterateN :: Unbox a => Int -> (a -> a) -> a -> Vector a -{-# INLINE iterateN #-} -iterateN = G.iterateN - --- Unfolding --- --------- - --- | /O(n)/ Construct a vector by repeatedly applying the generator function --- to a seed. The generator function yields 'Just' the next element and the --- new seed or 'Nothing' if there are no more elements. --- --- > unfoldr (\n -> if n == 0 then Nothing else Just (n,n-1)) 10 --- > = <10,9,8,7,6,5,4,3,2,1> -unfoldr :: Unbox a => (b -> Maybe (a, b)) -> b -> Vector a -{-# INLINE unfoldr #-} -unfoldr = G.unfoldr - --- | /O(n)/ Construct a vector with at most @n@ elements by repeatedly applying --- the generator function to a seed. The generator function yields 'Just' the --- next element and the new seed or 'Nothing' if there are no more elements. --- --- > unfoldrN 3 (\n -> Just (n,n-1)) 10 = <10,9,8> -unfoldrN :: Unbox a => Int -> (b -> Maybe (a, b)) -> b -> Vector a -{-# INLINE unfoldrN #-} -unfoldrN = G.unfoldrN - --- | /O(n)/ Construct a vector by repeatedly applying the monadic --- generator function to a seed. The generator function yields 'Just' --- the next element and the new seed or 'Nothing' if there are no more --- elements. -unfoldrM :: (Monad m, Unbox a) => (b -> m (Maybe (a, b))) -> b -> m (Vector a) -{-# INLINE unfoldrM #-} -unfoldrM = G.unfoldrM - --- | /O(n)/ Construct a vector by repeatedly applying the monadic --- generator function to a seed. The generator function yields 'Just' --- the next element and the new seed or 'Nothing' if there are no more --- elements. -unfoldrNM :: (Monad m, Unbox a) => Int -> (b -> m (Maybe (a, b))) -> b -> m (Vector a) -{-# INLINE unfoldrNM #-} -unfoldrNM = G.unfoldrNM - --- | /O(n)/ Construct a vector with @n@ elements by repeatedly applying the --- generator function to the already constructed part of the vector. --- --- > constructN 3 f = let a = f <> ; b = f <a> ; c = f <a,b> in f <a,b,c> --- -constructN :: Unbox a => Int -> (Vector a -> a) -> Vector a -{-# INLINE constructN #-} -constructN = G.constructN - --- | /O(n)/ Construct a vector with @n@ elements from right to left by --- repeatedly applying the generator function to the already constructed part --- of the vector. --- --- > constructrN 3 f = let a = f <> ; b = f<a> ; c = f <b,a> in f <c,b,a> --- -constructrN :: Unbox a => Int -> (Vector a -> a) -> Vector a -{-# INLINE constructrN #-} -constructrN = G.constructrN - --- Enumeration --- ----------- - --- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+1@ --- etc. This operation is usually more efficient than 'enumFromTo'. --- --- > enumFromN 5 3 = <5,6,7> -enumFromN :: (Unbox a, Num a) => a -> Int -> Vector a -{-# INLINE enumFromN #-} -enumFromN = G.enumFromN - --- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+y@, --- @x+y+y@ etc. This operations is usually more efficient than 'enumFromThenTo'. --- --- > enumFromStepN 1 0.1 5 = <1,1.1,1.2,1.3,1.4> -enumFromStepN :: (Unbox a, Num a) => a -> a -> Int -> Vector a -{-# INLINE enumFromStepN #-} -enumFromStepN = G.enumFromStepN - --- | /O(n)/ Enumerate values from @x@ to @y@. --- --- /WARNING:/ This operation can be very inefficient. If at all possible, use --- 'enumFromN' instead. -enumFromTo :: (Unbox a, Enum a) => a -> a -> Vector a -{-# INLINE enumFromTo #-} -enumFromTo = G.enumFromTo - --- | /O(n)/ Enumerate values from @x@ to @y@ with a specific step @z@. --- --- /WARNING:/ This operation can be very inefficient. If at all possible, use --- 'enumFromStepN' instead. -enumFromThenTo :: (Unbox a, Enum a) => a -> a -> a -> Vector a -{-# INLINE enumFromThenTo #-} -enumFromThenTo = G.enumFromThenTo - --- Concatenation --- ------------- - --- | /O(n)/ Prepend an element -cons :: Unbox a => a -> Vector a -> Vector a -{-# INLINE cons #-} -cons = G.cons - --- | /O(n)/ Append an element -snoc :: Unbox a => Vector a -> a -> Vector a -{-# INLINE snoc #-} -snoc = G.snoc - -infixr 5 ++ --- | /O(m+n)/ Concatenate two vectors -(++) :: Unbox a => Vector a -> Vector a -> Vector a -{-# INLINE (++) #-} -(++) = (G.++) - --- | /O(n)/ Concatenate all vectors in the list -concat :: Unbox a => [Vector a] -> Vector a -{-# INLINE concat #-} -concat = G.concat - --- Monadic initialisation --- ---------------------- - --- | /O(n)/ Execute the monadic action the given number of times and store the --- results in a vector. -replicateM :: (Monad m, Unbox a) => Int -> m a -> m (Vector a) -{-# INLINE replicateM #-} -replicateM = G.replicateM - --- | /O(n)/ Construct a vector of the given length by applying the monadic --- action to each index -generateM :: (Monad m, Unbox a) => Int -> (Int -> m a) -> m (Vector a) -{-# INLINE generateM #-} -generateM = G.generateM - --- | /O(n)/ Apply monadic function n times to value. Zeroth element is original value. -iterateNM :: (Monad m, Unbox a) => Int -> (a -> m a) -> a -> m (Vector a) -{-# INLINE iterateNM #-} -iterateNM = G.iterateNM - --- | Execute the monadic action and freeze the resulting vector. --- --- @ --- create (do { v \<- new 2; write v 0 \'a\'; write v 1 \'b\'; return v }) = \<'a','b'\> --- @ -create :: Unbox a => (forall s. ST s (MVector s a)) -> Vector a -{-# INLINE create #-} --- NOTE: eta-expanded due to http://hackage.haskell.org/trac/ghc/ticket/4120 -create p = G.create p - --- | Execute the monadic action and freeze the resulting vectors. -createT :: (Traversable f, Unbox a) => (forall s. ST s (f (MVector s a))) -> f (Vector a) -{-# INLINE createT #-} -createT p = G.createT p - --- Restricting memory usage --- ------------------------ - --- | /O(n)/ Yield the argument but force it not to retain any extra memory, --- possibly by copying it. --- --- This is especially useful when dealing with slices. For example: --- --- > force (slice 0 2 <huge vector>) --- --- Here, the slice retains a reference to the huge vector. Forcing it creates --- a copy of just the elements that belong to the slice and allows the huge --- vector to be garbage collected. -force :: Unbox a => Vector a -> Vector a -{-# INLINE force #-} -force = G.force - --- Bulk updates --- ------------ - --- | /O(m+n)/ For each pair @(i,a)@ from the list, replace the vector --- element at position @i@ by @a@. --- --- > <5,9,2,7> // [(2,1),(0,3),(2,8)] = <3,9,8,7> --- -(//) :: Unbox a => Vector a -- ^ initial vector (of length @m@) - -> [(Int, a)] -- ^ list of index/value pairs (of length @n@) - -> Vector a -{-# INLINE (//) #-} -(//) = (G.//) - --- | /O(m+n)/ For each pair @(i,a)@ from the vector of index/value pairs, --- replace the vector element at position @i@ by @a@. --- --- > update <5,9,2,7> <(2,1),(0,3),(2,8)> = <3,9,8,7> --- -update :: Unbox a - => Vector a -- ^ initial vector (of length @m@) - -> Vector (Int, a) -- ^ vector of index/value pairs (of length @n@) - -> Vector a -{-# INLINE update #-} -update = G.update - --- | /O(m+min(n1,n2))/ For each index @i@ from the index vector and the --- corresponding value @a@ from the value vector, replace the element of the --- initial vector at position @i@ by @a@. --- --- > update_ <5,9,2,7> <2,0,2> <1,3,8> = <3,9,8,7> --- --- The function 'update' provides the same functionality and is usually more --- convenient. --- --- @ --- update_ xs is ys = 'update' xs ('zip' is ys) --- @ -update_ :: Unbox a - => Vector a -- ^ initial vector (of length @m@) - -> Vector Int -- ^ index vector (of length @n1@) - -> Vector a -- ^ value vector (of length @n2@) - -> Vector a -{-# INLINE update_ #-} -update_ = G.update_ - --- | Same as ('//') but without bounds checking. -unsafeUpd :: Unbox a => Vector a -> [(Int, a)] -> Vector a -{-# INLINE unsafeUpd #-} -unsafeUpd = G.unsafeUpd - --- | Same as 'update' but without bounds checking. -unsafeUpdate :: Unbox a => Vector a -> Vector (Int, a) -> Vector a -{-# INLINE unsafeUpdate #-} -unsafeUpdate = G.unsafeUpdate - --- | Same as 'update_' but without bounds checking. -unsafeUpdate_ :: Unbox a => Vector a -> Vector Int -> Vector a -> Vector a -{-# INLINE unsafeUpdate_ #-} -unsafeUpdate_ = G.unsafeUpdate_ - --- Accumulations --- ------------- - --- | /O(m+n)/ For each pair @(i,b)@ from the list, replace the vector element --- @a@ at position @i@ by @f a b@. --- --- > accum (+) <5,9,2> [(2,4),(1,6),(0,3),(1,7)] = <5+3, 9+6+7, 2+4> -accum :: Unbox a - => (a -> b -> a) -- ^ accumulating function @f@ - -> Vector a -- ^ initial vector (of length @m@) - -> [(Int,b)] -- ^ list of index/value pairs (of length @n@) - -> Vector a -{-# INLINE accum #-} -accum = G.accum - --- | /O(m+n)/ For each pair @(i,b)@ from the vector of pairs, replace the vector --- element @a@ at position @i@ by @f a b@. --- --- > accumulate (+) <5,9,2> <(2,4),(1,6),(0,3),(1,7)> = <5+3, 9+6+7, 2+4> -accumulate :: (Unbox a, Unbox b) - => (a -> b -> a) -- ^ accumulating function @f@ - -> Vector a -- ^ initial vector (of length @m@) - -> Vector (Int,b) -- ^ vector of index/value pairs (of length @n@) - -> Vector a -{-# INLINE accumulate #-} -accumulate = G.accumulate - --- | /O(m+min(n1,n2))/ For each index @i@ from the index vector and the --- corresponding value @b@ from the the value vector, --- replace the element of the initial vector at --- position @i@ by @f a b@. --- --- > accumulate_ (+) <5,9,2> <2,1,0,1> <4,6,3,7> = <5+3, 9+6+7, 2+4> --- --- The function 'accumulate' provides the same functionality and is usually more --- convenient. --- --- @ --- accumulate_ f as is bs = 'accumulate' f as ('zip' is bs) --- @ -accumulate_ :: (Unbox a, Unbox b) - => (a -> b -> a) -- ^ accumulating function @f@ - -> Vector a -- ^ initial vector (of length @m@) - -> Vector Int -- ^ index vector (of length @n1@) - -> Vector b -- ^ value vector (of length @n2@) - -> Vector a -{-# INLINE accumulate_ #-} -accumulate_ = G.accumulate_ - --- | Same as 'accum' but without bounds checking. -unsafeAccum :: Unbox a => (a -> b -> a) -> Vector a -> [(Int,b)] -> Vector a -{-# INLINE unsafeAccum #-} -unsafeAccum = G.unsafeAccum - --- | Same as 'accumulate' but without bounds checking. -unsafeAccumulate :: (Unbox a, Unbox b) - => (a -> b -> a) -> Vector a -> Vector (Int,b) -> Vector a -{-# INLINE unsafeAccumulate #-} -unsafeAccumulate = G.unsafeAccumulate - --- | Same as 'accumulate_' but without bounds checking. -unsafeAccumulate_ :: (Unbox a, Unbox b) => - (a -> b -> a) -> Vector a -> Vector Int -> Vector b -> Vector a -{-# INLINE unsafeAccumulate_ #-} -unsafeAccumulate_ = G.unsafeAccumulate_ - --- Permutations --- ------------ - --- | /O(n)/ Reverse a vector -reverse :: Unbox a => Vector a -> Vector a -{-# INLINE reverse #-} -reverse = G.reverse - --- | /O(n)/ Yield the vector obtained by replacing each element @i@ of the --- index vector by @xs'!'i@. This is equivalent to @'map' (xs'!') is@ but is --- often much more efficient. --- --- > backpermute <a,b,c,d> <0,3,2,3,1,0> = <a,d,c,d,b,a> -backpermute :: Unbox a => Vector a -> Vector Int -> Vector a -{-# INLINE backpermute #-} -backpermute = G.backpermute - --- | Same as 'backpermute' but without bounds checking. -unsafeBackpermute :: Unbox a => Vector a -> Vector Int -> Vector a -{-# INLINE unsafeBackpermute #-} -unsafeBackpermute = G.unsafeBackpermute - --- Safe destructive updates --- ------------------------ - --- | Apply a destructive operation to a vector. The operation will be --- performed in place if it is safe to do so and will modify a copy of the --- vector otherwise. --- --- @ --- modify (\\v -> write v 0 \'x\') ('replicate' 3 \'a\') = \<\'x\',\'a\',\'a\'\> --- @ -modify :: Unbox a => (forall s. MVector s a -> ST s ()) -> Vector a -> Vector a -{-# INLINE modify #-} -modify p = G.modify p - --- Indexing --- -------- - --- | /O(n)/ Pair each element in a vector with its index -indexed :: Unbox a => Vector a -> Vector (Int,a) -{-# INLINE indexed #-} -indexed = G.indexed - --- Mapping --- ------- - --- | /O(n)/ Map a function over a vector -map :: (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b -{-# INLINE map #-} -map = G.map - --- | /O(n)/ Apply a function to every element of a vector and its index -imap :: (Unbox a, Unbox b) => (Int -> a -> b) -> Vector a -> Vector b -{-# INLINE imap #-} -imap = G.imap - --- | Map a function over a vector and concatenate the results. -concatMap :: (Unbox a, Unbox b) => (a -> Vector b) -> Vector a -> Vector b -{-# INLINE concatMap #-} -concatMap = G.concatMap - --- Monadic mapping --- --------------- - --- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a --- vector of results -mapM :: (Monad m, Unbox a, Unbox b) => (a -> m b) -> Vector a -> m (Vector b) -{-# INLINE mapM #-} -mapM = G.mapM - --- | /O(n)/ Apply the monadic action to every element of a vector and its --- index, yielding a vector of results -imapM :: (Monad m, Unbox a, Unbox b) - => (Int -> a -> m b) -> Vector a -> m (Vector b) -{-# INLINE imapM #-} -imapM = G.imapM - --- | /O(n)/ Apply the monadic action to all elements of a vector and ignore the --- results -mapM_ :: (Monad m, Unbox a) => (a -> m b) -> Vector a -> m () -{-# INLINE mapM_ #-} -mapM_ = G.mapM_ - --- | /O(n)/ Apply the monadic action to every element of a vector and its --- index, ignoring the results -imapM_ :: (Monad m, Unbox a) => (Int -> a -> m b) -> Vector a -> m () -{-# INLINE imapM_ #-} -imapM_ = G.imapM_ - --- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a --- vector of results. Equivalent to @flip 'mapM'@. -forM :: (Monad m, Unbox a, Unbox b) => Vector a -> (a -> m b) -> m (Vector b) -{-# INLINE forM #-} -forM = G.forM - --- | /O(n)/ Apply the monadic action to all elements of a vector and ignore the --- results. Equivalent to @flip 'mapM_'@. -forM_ :: (Monad m, Unbox a) => Vector a -> (a -> m b) -> m () -{-# INLINE forM_ #-} -forM_ = G.forM_ - --- Zipping --- ------- - --- | /O(min(m,n))/ Zip two vectors with the given function. -zipWith :: (Unbox a, Unbox b, Unbox c) - => (a -> b -> c) -> Vector a -> Vector b -> Vector c -{-# INLINE zipWith #-} -zipWith = G.zipWith - --- | Zip three vectors with the given function. -zipWith3 :: (Unbox a, Unbox b, Unbox c, Unbox d) - => (a -> b -> c -> d) -> Vector a -> Vector b -> Vector c -> Vector d -{-# INLINE zipWith3 #-} -zipWith3 = G.zipWith3 - -zipWith4 :: (Unbox a, Unbox b, Unbox c, Unbox d, Unbox e) - => (a -> b -> c -> d -> e) - -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e -{-# INLINE zipWith4 #-} -zipWith4 = G.zipWith4 - -zipWith5 :: (Unbox a, Unbox b, Unbox c, Unbox d, Unbox e, Unbox f) - => (a -> b -> c -> d -> e -> f) - -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e - -> Vector f -{-# INLINE zipWith5 #-} -zipWith5 = G.zipWith5 - -zipWith6 :: (Unbox a, Unbox b, Unbox c, Unbox d, Unbox e, Unbox f, Unbox g) - => (a -> b -> c -> d -> e -> f -> g) - -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e - -> Vector f -> Vector g -{-# INLINE zipWith6 #-} -zipWith6 = G.zipWith6 - --- | /O(min(m,n))/ Zip two vectors with a function that also takes the --- elements' indices. -izipWith :: (Unbox a, Unbox b, Unbox c) - => (Int -> a -> b -> c) -> Vector a -> Vector b -> Vector c -{-# INLINE izipWith #-} -izipWith = G.izipWith - --- | Zip three vectors and their indices with the given function. -izipWith3 :: (Unbox a, Unbox b, Unbox c, Unbox d) - => (Int -> a -> b -> c -> d) - -> Vector a -> Vector b -> Vector c -> Vector d -{-# INLINE izipWith3 #-} -izipWith3 = G.izipWith3 - -izipWith4 :: (Unbox a, Unbox b, Unbox c, Unbox d, Unbox e) - => (Int -> a -> b -> c -> d -> e) - -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e -{-# INLINE izipWith4 #-} -izipWith4 = G.izipWith4 - -izipWith5 :: (Unbox a, Unbox b, Unbox c, Unbox d, Unbox e, Unbox f) - => (Int -> a -> b -> c -> d -> e -> f) - -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e - -> Vector f -{-# INLINE izipWith5 #-} -izipWith5 = G.izipWith5 - -izipWith6 :: (Unbox a, Unbox b, Unbox c, Unbox d, Unbox e, Unbox f, Unbox g) - => (Int -> a -> b -> c -> d -> e -> f -> g) - -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e - -> Vector f -> Vector g -{-# INLINE izipWith6 #-} -izipWith6 = G.izipWith6 - --- Monadic zipping --- --------------- - --- | /O(min(m,n))/ Zip the two vectors with the monadic action and yield a --- vector of results -zipWithM :: (Monad m, Unbox a, Unbox b, Unbox c) - => (a -> b -> m c) -> Vector a -> Vector b -> m (Vector c) -{-# INLINE zipWithM #-} -zipWithM = G.zipWithM - --- | /O(min(m,n))/ Zip the two vectors with a monadic action that also takes --- the element index and yield a vector of results -izipWithM :: (Monad m, Unbox a, Unbox b, Unbox c) - => (Int -> a -> b -> m c) -> Vector a -> Vector b -> m (Vector c) -{-# INLINE izipWithM #-} -izipWithM = G.izipWithM - --- | /O(min(m,n))/ Zip the two vectors with the monadic action and ignore the --- results -zipWithM_ :: (Monad m, Unbox a, Unbox b) - => (a -> b -> m c) -> Vector a -> Vector b -> m () -{-# INLINE zipWithM_ #-} -zipWithM_ = G.zipWithM_ - --- | /O(min(m,n))/ Zip the two vectors with a monadic action that also takes --- the element index and ignore the results -izipWithM_ :: (Monad m, Unbox a, Unbox b) - => (Int -> a -> b -> m c) -> Vector a -> Vector b -> m () -{-# INLINE izipWithM_ #-} -izipWithM_ = G.izipWithM_ - --- Filtering --- --------- - --- | /O(n)/ Drop elements that do not satisfy the predicate -filter :: Unbox a => (a -> Bool) -> Vector a -> Vector a -{-# INLINE filter #-} -filter = G.filter - --- | /O(n)/ Drop repeated adjacent elements. -uniq :: (Unbox a, Eq a) => Vector a -> Vector a -{-# INLINE uniq #-} -uniq = G.uniq - --- | /O(n)/ Drop elements that do not satisfy the predicate which is applied to --- values and their indices -ifilter :: Unbox a => (Int -> a -> Bool) -> Vector a -> Vector a -{-# INLINE ifilter #-} -ifilter = G.ifilter - --- | /O(n)/ Drop elements when predicate returns Nothing -mapMaybe :: (Unbox a, Unbox b) => (a -> Maybe b) -> Vector a -> Vector b -{-# INLINE mapMaybe #-} -mapMaybe = G.mapMaybe - --- | /O(n)/ Drop elements when predicate, applied to index and value, returns Nothing -imapMaybe :: (Unbox a, Unbox b) => (Int -> a -> Maybe b) -> Vector a -> Vector b -{-# INLINE imapMaybe #-} -imapMaybe = G.imapMaybe - --- | /O(n)/ Drop elements that do not satisfy the monadic predicate -filterM :: (Monad m, Unbox a) => (a -> m Bool) -> Vector a -> m (Vector a) -{-# INLINE filterM #-} -filterM = G.filterM - --- | /O(n)/ Yield the longest prefix of elements satisfying the predicate --- without copying. -takeWhile :: Unbox a => (a -> Bool) -> Vector a -> Vector a -{-# INLINE takeWhile #-} -takeWhile = G.takeWhile - --- | /O(n)/ Drop the longest prefix of elements that satisfy the predicate --- without copying. -dropWhile :: Unbox a => (a -> Bool) -> Vector a -> Vector a -{-# INLINE dropWhile #-} -dropWhile = G.dropWhile - --- Parititioning --- ------------- - --- | /O(n)/ Split the vector in two parts, the first one containing those --- elements that satisfy the predicate and the second one those that don't. The --- relative order of the elements is preserved at the cost of a sometimes --- reduced performance compared to 'unstablePartition'. -partition :: Unbox a => (a -> Bool) -> Vector a -> (Vector a, Vector a) -{-# INLINE partition #-} -partition = G.partition - --- | /O(n)/ Split the vector in two parts, the first one containing those --- elements that satisfy the predicate and the second one those that don't. --- The order of the elements is not preserved but the operation is often --- faster than 'partition'. -unstablePartition :: Unbox a => (a -> Bool) -> Vector a -> (Vector a, Vector a) -{-# INLINE unstablePartition #-} -unstablePartition = G.unstablePartition - --- | /O(n)/ Split the vector into the longest prefix of elements that satisfy --- the predicate and the rest without copying. -span :: Unbox a => (a -> Bool) -> Vector a -> (Vector a, Vector a) -{-# INLINE span #-} -span = G.span - --- | /O(n)/ Split the vector into the longest prefix of elements that do not --- satisfy the predicate and the rest without copying. -break :: Unbox a => (a -> Bool) -> Vector a -> (Vector a, Vector a) -{-# INLINE break #-} -break = G.break - --- Searching --- --------- - -infix 4 `elem` --- | /O(n)/ Check if the vector contains an element -elem :: (Unbox a, Eq a) => a -> Vector a -> Bool -{-# INLINE elem #-} -elem = G.elem - -infix 4 `notElem` --- | /O(n)/ Check if the vector does not contain an element (inverse of 'elem') -notElem :: (Unbox a, Eq a) => a -> Vector a -> Bool -{-# INLINE notElem #-} -notElem = G.notElem - --- | /O(n)/ Yield 'Just' the first element matching the predicate or 'Nothing' --- if no such element exists. -find :: Unbox a => (a -> Bool) -> Vector a -> Maybe a -{-# INLINE find #-} -find = G.find - --- | /O(n)/ Yield 'Just' the index of the first element matching the predicate --- or 'Nothing' if no such element exists. -findIndex :: Unbox a => (a -> Bool) -> Vector a -> Maybe Int -{-# INLINE findIndex #-} -findIndex = G.findIndex - --- | /O(n)/ Yield the indices of elements satisfying the predicate in ascending --- order. -findIndices :: Unbox a => (a -> Bool) -> Vector a -> Vector Int -{-# INLINE findIndices #-} -findIndices = G.findIndices - --- | /O(n)/ Yield 'Just' the index of the first occurence of the given element or --- 'Nothing' if the vector does not contain the element. This is a specialised --- version of 'findIndex'. -elemIndex :: (Unbox a, Eq a) => a -> Vector a -> Maybe Int -{-# INLINE elemIndex #-} -elemIndex = G.elemIndex - --- | /O(n)/ Yield the indices of all occurences of the given element in --- ascending order. This is a specialised version of 'findIndices'. -elemIndices :: (Unbox a, Eq a) => a -> Vector a -> Vector Int -{-# INLINE elemIndices #-} -elemIndices = G.elemIndices - --- Folding --- ------- - --- | /O(n)/ Left fold -foldl :: Unbox b => (a -> b -> a) -> a -> Vector b -> a -{-# INLINE foldl #-} -foldl = G.foldl - --- | /O(n)/ Left fold on non-empty vectors -foldl1 :: Unbox a => (a -> a -> a) -> Vector a -> a -{-# INLINE foldl1 #-} -foldl1 = G.foldl1 - --- | /O(n)/ Left fold with strict accumulator -foldl' :: Unbox b => (a -> b -> a) -> a -> Vector b -> a -{-# INLINE foldl' #-} -foldl' = G.foldl' - --- | /O(n)/ Left fold on non-empty vectors with strict accumulator -foldl1' :: Unbox a => (a -> a -> a) -> Vector a -> a -{-# INLINE foldl1' #-} -foldl1' = G.foldl1' - --- | /O(n)/ Right fold -foldr :: Unbox a => (a -> b -> b) -> b -> Vector a -> b -{-# INLINE foldr #-} -foldr = G.foldr - --- | /O(n)/ Right fold on non-empty vectors -foldr1 :: Unbox a => (a -> a -> a) -> Vector a -> a -{-# INLINE foldr1 #-} -foldr1 = G.foldr1 - --- | /O(n)/ Right fold with a strict accumulator -foldr' :: Unbox a => (a -> b -> b) -> b -> Vector a -> b -{-# INLINE foldr' #-} -foldr' = G.foldr' - --- | /O(n)/ Right fold on non-empty vectors with strict accumulator -foldr1' :: Unbox a => (a -> a -> a) -> Vector a -> a -{-# INLINE foldr1' #-} -foldr1' = G.foldr1' - --- | /O(n)/ Left fold (function applied to each element and its index) -ifoldl :: Unbox b => (a -> Int -> b -> a) -> a -> Vector b -> a -{-# INLINE ifoldl #-} -ifoldl = G.ifoldl - --- | /O(n)/ Left fold with strict accumulator (function applied to each element --- and its index) -ifoldl' :: Unbox b => (a -> Int -> b -> a) -> a -> Vector b -> a -{-# INLINE ifoldl' #-} -ifoldl' = G.ifoldl' - --- | /O(n)/ Right fold (function applied to each element and its index) -ifoldr :: Unbox a => (Int -> a -> b -> b) -> b -> Vector a -> b -{-# INLINE ifoldr #-} -ifoldr = G.ifoldr - --- | /O(n)/ Right fold with strict accumulator (function applied to each --- element and its index) -ifoldr' :: Unbox a => (Int -> a -> b -> b) -> b -> Vector a -> b -{-# INLINE ifoldr' #-} -ifoldr' = G.ifoldr' - --- Specialised folds --- ----------------- - --- | /O(n)/ Check if all elements satisfy the predicate. -all :: Unbox a => (a -> Bool) -> Vector a -> Bool -{-# INLINE all #-} -all = G.all - --- | /O(n)/ Check if any element satisfies the predicate. -any :: Unbox a => (a -> Bool) -> Vector a -> Bool -{-# INLINE any #-} -any = G.any - --- | /O(n)/ Check if all elements are 'True' -and :: Vector Bool -> Bool -{-# INLINE and #-} -and = G.and - --- | /O(n)/ Check if any element is 'True' -or :: Vector Bool -> Bool -{-# INLINE or #-} -or = G.or - --- | /O(n)/ Compute the sum of the elements -sum :: (Unbox a, Num a) => Vector a -> a -{-# INLINE sum #-} -sum = G.sum - --- | /O(n)/ Compute the produce of the elements -product :: (Unbox a, Num a) => Vector a -> a -{-# INLINE product #-} -product = G.product - --- | /O(n)/ Yield the maximum element of the vector. The vector may not be --- empty. -maximum :: (Unbox a, Ord a) => Vector a -> a -{-# INLINE maximum #-} -maximum = G.maximum - --- | /O(n)/ Yield the maximum element of the vector according to the given --- comparison function. The vector may not be empty. -maximumBy :: Unbox a => (a -> a -> Ordering) -> Vector a -> a -{-# INLINE maximumBy #-} -maximumBy = G.maximumBy - --- | /O(n)/ Yield the minimum element of the vector. The vector may not be --- empty. -minimum :: (Unbox a, Ord a) => Vector a -> a -{-# INLINE minimum #-} -minimum = G.minimum - --- | /O(n)/ Yield the minimum element of the vector according to the given --- comparison function. The vector may not be empty. -minimumBy :: Unbox a => (a -> a -> Ordering) -> Vector a -> a -{-# INLINE minimumBy #-} -minimumBy = G.minimumBy - --- | /O(n)/ Yield the index of the maximum element of the vector. The vector --- may not be empty. -maxIndex :: (Unbox a, Ord a) => Vector a -> Int -{-# INLINE maxIndex #-} -maxIndex = G.maxIndex - --- | /O(n)/ Yield the index of the maximum element of the vector according to --- the given comparison function. The vector may not be empty. -maxIndexBy :: Unbox a => (a -> a -> Ordering) -> Vector a -> Int -{-# INLINE maxIndexBy #-} -maxIndexBy = G.maxIndexBy - --- | /O(n)/ Yield the index of the minimum element of the vector. The vector --- may not be empty. -minIndex :: (Unbox a, Ord a) => Vector a -> Int -{-# INLINE minIndex #-} -minIndex = G.minIndex - --- | /O(n)/ Yield the index of the minimum element of the vector according to --- the given comparison function. The vector may not be empty. -minIndexBy :: Unbox a => (a -> a -> Ordering) -> Vector a -> Int -{-# INLINE minIndexBy #-} -minIndexBy = G.minIndexBy - --- Monadic folds --- ------------- - --- | /O(n)/ Monadic fold -foldM :: (Monad m, Unbox b) => (a -> b -> m a) -> a -> Vector b -> m a -{-# INLINE foldM #-} -foldM = G.foldM - --- | /O(n)/ Monadic fold (action applied to each element and its index) -ifoldM :: (Monad m, Unbox b) => (a -> Int -> b -> m a) -> a -> Vector b -> m a -{-# INLINE ifoldM #-} -ifoldM = G.ifoldM - --- | /O(n)/ Monadic fold over non-empty vectors -fold1M :: (Monad m, Unbox a) => (a -> a -> m a) -> Vector a -> m a -{-# INLINE fold1M #-} -fold1M = G.fold1M - --- | /O(n)/ Monadic fold with strict accumulator -foldM' :: (Monad m, Unbox b) => (a -> b -> m a) -> a -> Vector b -> m a -{-# INLINE foldM' #-} -foldM' = G.foldM' - --- | /O(n)/ Monadic fold with strict accumulator (action applied to each --- element and its index) -ifoldM' :: (Monad m, Unbox b) => (a -> Int -> b -> m a) -> a -> Vector b -> m a -{-# INLINE ifoldM' #-} -ifoldM' = G.ifoldM' - --- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator -fold1M' :: (Monad m, Unbox a) => (a -> a -> m a) -> Vector a -> m a -{-# INLINE fold1M' #-} -fold1M' = G.fold1M' - --- | /O(n)/ Monadic fold that discards the result -foldM_ :: (Monad m, Unbox b) => (a -> b -> m a) -> a -> Vector b -> m () -{-# INLINE foldM_ #-} -foldM_ = G.foldM_ - --- | /O(n)/ Monadic fold that discards the result (action applied to each --- element and its index) -ifoldM_ :: (Monad m, Unbox b) => (a -> Int -> b -> m a) -> a -> Vector b -> m () -{-# INLINE ifoldM_ #-} -ifoldM_ = G.ifoldM_ - --- | /O(n)/ Monadic fold over non-empty vectors that discards the result -fold1M_ :: (Monad m, Unbox a) => (a -> a -> m a) -> Vector a -> m () -{-# INLINE fold1M_ #-} -fold1M_ = G.fold1M_ - --- | /O(n)/ Monadic fold with strict accumulator that discards the result -foldM'_ :: (Monad m, Unbox b) => (a -> b -> m a) -> a -> Vector b -> m () -{-# INLINE foldM'_ #-} -foldM'_ = G.foldM'_ - --- | /O(n)/ Monadic fold with strict accumulator that discards the result --- (action applied to each element and its index) -ifoldM'_ :: (Monad m, Unbox b) - => (a -> Int -> b -> m a) -> a -> Vector b -> m () -{-# INLINE ifoldM'_ #-} -ifoldM'_ = G.ifoldM'_ - --- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator --- that discards the result -fold1M'_ :: (Monad m, Unbox a) => (a -> a -> m a) -> Vector a -> m () -{-# INLINE fold1M'_ #-} -fold1M'_ = G.fold1M'_ - --- Prefix sums (scans) --- ------------------- - --- | /O(n)/ Prescan --- --- @ --- prescanl f z = 'init' . 'scanl' f z --- @ --- --- Example: @prescanl (+) 0 \<1,2,3,4\> = \<0,1,3,6\>@ --- -prescanl :: (Unbox a, Unbox b) => (a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE prescanl #-} -prescanl = G.prescanl - --- | /O(n)/ Prescan with strict accumulator -prescanl' :: (Unbox a, Unbox b) => (a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE prescanl' #-} -prescanl' = G.prescanl' - --- | /O(n)/ Scan --- --- @ --- postscanl f z = 'tail' . 'scanl' f z --- @ --- --- Example: @postscanl (+) 0 \<1,2,3,4\> = \<1,3,6,10\>@ --- -postscanl :: (Unbox a, Unbox b) => (a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE postscanl #-} -postscanl = G.postscanl - --- | /O(n)/ Scan with strict accumulator -postscanl' :: (Unbox a, Unbox b) => (a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE postscanl' #-} -postscanl' = G.postscanl' - --- | /O(n)/ Haskell-style scan --- --- > scanl f z <x1,...,xn> = <y1,...,y(n+1)> --- > where y1 = z --- > yi = f y(i-1) x(i-1) --- --- Example: @scanl (+) 0 \<1,2,3,4\> = \<0,1,3,6,10\>@ --- -scanl :: (Unbox a, Unbox b) => (a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE scanl #-} -scanl = G.scanl - --- | /O(n)/ Haskell-style scan with strict accumulator -scanl' :: (Unbox a, Unbox b) => (a -> b -> a) -> a -> Vector b -> Vector a -{-# INLINE scanl' #-} -scanl' = G.scanl' - --- | /O(n)/ Scan over a non-empty vector --- --- > scanl f <x1,...,xn> = <y1,...,yn> --- > where y1 = x1 --- > yi = f y(i-1) xi --- -scanl1 :: Unbox a => (a -> a -> a) -> Vector a -> Vector a -{-# INLINE scanl1 #-} -scanl1 = G.scanl1 - --- | /O(n)/ Scan over a non-empty vector with a strict accumulator -scanl1' :: Unbox a => (a -> a -> a) -> Vector a -> Vector a -{-# INLINE scanl1' #-} -scanl1' = G.scanl1' - --- | /O(n)/ Right-to-left prescan --- --- @ --- prescanr f z = 'reverse' . 'prescanl' (flip f) z . 'reverse' --- @ --- -prescanr :: (Unbox a, Unbox b) => (a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE prescanr #-} -prescanr = G.prescanr - --- | /O(n)/ Right-to-left prescan with strict accumulator -prescanr' :: (Unbox a, Unbox b) => (a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE prescanr' #-} -prescanr' = G.prescanr' - --- | /O(n)/ Right-to-left scan -postscanr :: (Unbox a, Unbox b) => (a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE postscanr #-} -postscanr = G.postscanr - --- | /O(n)/ Right-to-left scan with strict accumulator -postscanr' :: (Unbox a, Unbox b) => (a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE postscanr' #-} -postscanr' = G.postscanr' - --- | /O(n)/ Right-to-left Haskell-style scan -scanr :: (Unbox a, Unbox b) => (a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE scanr #-} -scanr = G.scanr - --- | /O(n)/ Right-to-left Haskell-style scan with strict accumulator -scanr' :: (Unbox a, Unbox b) => (a -> b -> b) -> b -> Vector a -> Vector b -{-# INLINE scanr' #-} -scanr' = G.scanr' - --- | /O(n)/ Right-to-left scan over a non-empty vector -scanr1 :: Unbox a => (a -> a -> a) -> Vector a -> Vector a -{-# INLINE scanr1 #-} -scanr1 = G.scanr1 - --- | /O(n)/ Right-to-left scan over a non-empty vector with a strict --- accumulator -scanr1' :: Unbox a => (a -> a -> a) -> Vector a -> Vector a -{-# INLINE scanr1' #-} -scanr1' = G.scanr1' - --- Conversions - Lists --- ------------------------ - --- | /O(n)/ Convert a vector to a list -toList :: Unbox a => Vector a -> [a] -{-# INLINE toList #-} -toList = G.toList - --- | /O(n)/ Convert a list to a vector -fromList :: Unbox a => [a] -> Vector a -{-# INLINE fromList #-} -fromList = G.fromList - --- | /O(n)/ Convert the first @n@ elements of a list to a vector --- --- @ --- fromListN n xs = 'fromList' ('take' n xs) --- @ -fromListN :: Unbox a => Int -> [a] -> Vector a -{-# INLINE fromListN #-} -fromListN = G.fromListN - --- Conversions - Mutable vectors --- ----------------------------- - --- | /O(1)/ Unsafe convert a mutable vector to an immutable one without --- copying. The mutable vector may not be used after this operation. -unsafeFreeze :: (Unbox a, PrimMonad m) => MVector (PrimState m) a -> m (Vector a) -{-# INLINE unsafeFreeze #-} -unsafeFreeze = G.unsafeFreeze - --- | /O(1)/ Unsafely convert an immutable vector to a mutable one without --- copying. The immutable vector may not be used after this operation. -unsafeThaw :: (Unbox a, PrimMonad m) => Vector a -> m (MVector (PrimState m) a) -{-# INLINE unsafeThaw #-} -unsafeThaw = G.unsafeThaw - --- | /O(n)/ Yield a mutable copy of the immutable vector. -thaw :: (Unbox a, PrimMonad m) => Vector a -> m (MVector (PrimState m) a) -{-# INLINE thaw #-} -thaw = G.thaw - --- | /O(n)/ Yield an immutable copy of the mutable vector. -freeze :: (Unbox a, PrimMonad m) => MVector (PrimState m) a -> m (Vector a) -{-# INLINE freeze #-} -freeze = G.freeze - --- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must --- have the same length. This is not checked. -unsafeCopy - :: (Unbox a, PrimMonad m) => MVector (PrimState m) a -> Vector a -> m () -{-# INLINE unsafeCopy #-} -unsafeCopy = G.unsafeCopy - --- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must --- have the same length. -copy :: (Unbox a, PrimMonad m) => MVector (PrimState m) a -> Vector a -> m () -{-# INLINE copy #-} -copy = G.copy - - -#define DEFINE_IMMUTABLE -#include "unbox-tuple-instances" diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Unboxed/Base.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Unboxed/Base.hs deleted file mode 100644 index a88795c5b4bc..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Unboxed/Base.hs +++ /dev/null @@ -1,408 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, MultiParamTypeClasses, TypeFamilies, FlexibleContexts #-} -#if __GLASGOW_HASKELL__ >= 707 -{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} -#endif -{-# OPTIONS_HADDOCK hide #-} - --- | --- Module : Data.Vector.Unboxed.Base --- Copyright : (c) Roman Leshchinskiy 2009-2010 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Stability : experimental --- Portability : non-portable --- --- Adaptive unboxed vectors: basic implementation --- - -module Data.Vector.Unboxed.Base ( - MVector(..), IOVector, STVector, Vector(..), Unbox -) where - -import qualified Data.Vector.Generic as G -import qualified Data.Vector.Generic.Mutable as M - -import qualified Data.Vector.Primitive as P - -import Control.DeepSeq ( NFData(rnf) ) - -import Control.Monad.Primitive -import Control.Monad ( liftM ) - -import Data.Word ( Word8, Word16, Word32, Word64 ) -import Data.Int ( Int8, Int16, Int32, Int64 ) -import Data.Complex - -#if !MIN_VERSION_base(4,8,0) -import Data.Word ( Word ) -#endif - -#if __GLASGOW_HASKELL__ >= 707 -import Data.Typeable ( Typeable ) -#else -import Data.Typeable ( Typeable1(..), Typeable2(..), mkTyConApp, - mkTyCon3 - ) -#endif - -import Data.Data ( Data(..) ) - --- Data.Vector.Internal.Check is unused -#define NOT_VECTOR_MODULE -#include "vector.h" - -data family MVector s a -data family Vector a - -type IOVector = MVector RealWorld -type STVector s = MVector s - -type instance G.Mutable Vector = MVector - -class (G.Vector Vector a, M.MVector MVector a) => Unbox a - -instance NFData (Vector a) where rnf !_ = () -instance NFData (MVector s a) where rnf !_ = () - --- ----------------- --- Data and Typeable --- ----------------- -#if __GLASGOW_HASKELL__ >= 707 -deriving instance Typeable Vector -deriving instance Typeable MVector -#else -vectorTyCon = mkTyCon3 "vector" - -instance Typeable1 Vector where - typeOf1 _ = mkTyConApp (vectorTyCon "Data.Vector.Unboxed" "Vector") [] - -instance Typeable2 MVector where - typeOf2 _ = mkTyConApp (vectorTyCon "Data.Vector.Unboxed.Mutable" "MVector") [] -#endif - -instance (Data a, Unbox a) => Data (Vector a) where - gfoldl = G.gfoldl - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = G.mkType "Data.Vector.Unboxed.Vector" - dataCast1 = G.dataCast - --- ---- --- Unit --- ---- - -newtype instance MVector s () = MV_Unit Int -newtype instance Vector () = V_Unit Int - -instance Unbox () - -instance M.MVector MVector () where - {-# INLINE basicLength #-} - {-# INLINE basicUnsafeSlice #-} - {-# INLINE basicOverlaps #-} - {-# INLINE basicUnsafeNew #-} - {-# INLINE basicInitialize #-} - {-# INLINE basicUnsafeRead #-} - {-# INLINE basicUnsafeWrite #-} - {-# INLINE basicClear #-} - {-# INLINE basicSet #-} - {-# INLINE basicUnsafeCopy #-} - {-# INLINE basicUnsafeGrow #-} - - basicLength (MV_Unit n) = n - - basicUnsafeSlice _ m (MV_Unit _) = MV_Unit m - - basicOverlaps _ _ = False - - basicUnsafeNew n = return (MV_Unit n) - - -- Nothing to initialize - basicInitialize _ = return () - - basicUnsafeRead (MV_Unit _) _ = return () - - basicUnsafeWrite (MV_Unit _) _ () = return () - - basicClear _ = return () - - basicSet (MV_Unit _) () = return () - - basicUnsafeCopy (MV_Unit _) (MV_Unit _) = return () - - basicUnsafeGrow (MV_Unit n) m = return $ MV_Unit (n+m) - -instance G.Vector Vector () where - {-# INLINE basicUnsafeFreeze #-} - basicUnsafeFreeze (MV_Unit n) = return $ V_Unit n - - {-# INLINE basicUnsafeThaw #-} - basicUnsafeThaw (V_Unit n) = return $ MV_Unit n - - {-# INLINE basicLength #-} - basicLength (V_Unit n) = n - - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice _ m (V_Unit _) = V_Unit m - - {-# INLINE basicUnsafeIndexM #-} - basicUnsafeIndexM (V_Unit _) _ = return () - - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy (MV_Unit _) (V_Unit _) = return () - - {-# INLINE elemseq #-} - elemseq _ = seq - - --- --------------- --- Primitive types --- --------------- - -#define primMVector(ty,con) \ -instance M.MVector MVector ty where { \ - {-# INLINE basicLength #-} \ -; {-# INLINE basicUnsafeSlice #-} \ -; {-# INLINE basicOverlaps #-} \ -; {-# INLINE basicUnsafeNew #-} \ -; {-# INLINE basicInitialize #-} \ -; {-# INLINE basicUnsafeReplicate #-} \ -; {-# INLINE basicUnsafeRead #-} \ -; {-# INLINE basicUnsafeWrite #-} \ -; {-# INLINE basicClear #-} \ -; {-# INLINE basicSet #-} \ -; {-# INLINE basicUnsafeCopy #-} \ -; {-# INLINE basicUnsafeGrow #-} \ -; basicLength (con v) = M.basicLength v \ -; basicUnsafeSlice i n (con v) = con $ M.basicUnsafeSlice i n v \ -; basicOverlaps (con v1) (con v2) = M.basicOverlaps v1 v2 \ -; basicUnsafeNew n = con `liftM` M.basicUnsafeNew n \ -; basicInitialize (con v) = M.basicInitialize v \ -; basicUnsafeReplicate n x = con `liftM` M.basicUnsafeReplicate n x \ -; basicUnsafeRead (con v) i = M.basicUnsafeRead v i \ -; basicUnsafeWrite (con v) i x = M.basicUnsafeWrite v i x \ -; basicClear (con v) = M.basicClear v \ -; basicSet (con v) x = M.basicSet v x \ -; basicUnsafeCopy (con v1) (con v2) = M.basicUnsafeCopy v1 v2 \ -; basicUnsafeMove (con v1) (con v2) = M.basicUnsafeMove v1 v2 \ -; basicUnsafeGrow (con v) n = con `liftM` M.basicUnsafeGrow v n } - -#define primVector(ty,con,mcon) \ -instance G.Vector Vector ty where { \ - {-# INLINE basicUnsafeFreeze #-} \ -; {-# INLINE basicUnsafeThaw #-} \ -; {-# INLINE basicLength #-} \ -; {-# INLINE basicUnsafeSlice #-} \ -; {-# INLINE basicUnsafeIndexM #-} \ -; {-# INLINE elemseq #-} \ -; basicUnsafeFreeze (mcon v) = con `liftM` G.basicUnsafeFreeze v \ -; basicUnsafeThaw (con v) = mcon `liftM` G.basicUnsafeThaw v \ -; basicLength (con v) = G.basicLength v \ -; basicUnsafeSlice i n (con v) = con $ G.basicUnsafeSlice i n v \ -; basicUnsafeIndexM (con v) i = G.basicUnsafeIndexM v i \ -; basicUnsafeCopy (mcon mv) (con v) = G.basicUnsafeCopy mv v \ -; elemseq _ = seq } - -newtype instance MVector s Int = MV_Int (P.MVector s Int) -newtype instance Vector Int = V_Int (P.Vector Int) -instance Unbox Int -primMVector(Int, MV_Int) -primVector(Int, V_Int, MV_Int) - -newtype instance MVector s Int8 = MV_Int8 (P.MVector s Int8) -newtype instance Vector Int8 = V_Int8 (P.Vector Int8) -instance Unbox Int8 -primMVector(Int8, MV_Int8) -primVector(Int8, V_Int8, MV_Int8) - -newtype instance MVector s Int16 = MV_Int16 (P.MVector s Int16) -newtype instance Vector Int16 = V_Int16 (P.Vector Int16) -instance Unbox Int16 -primMVector(Int16, MV_Int16) -primVector(Int16, V_Int16, MV_Int16) - -newtype instance MVector s Int32 = MV_Int32 (P.MVector s Int32) -newtype instance Vector Int32 = V_Int32 (P.Vector Int32) -instance Unbox Int32 -primMVector(Int32, MV_Int32) -primVector(Int32, V_Int32, MV_Int32) - -newtype instance MVector s Int64 = MV_Int64 (P.MVector s Int64) -newtype instance Vector Int64 = V_Int64 (P.Vector Int64) -instance Unbox Int64 -primMVector(Int64, MV_Int64) -primVector(Int64, V_Int64, MV_Int64) - - -newtype instance MVector s Word = MV_Word (P.MVector s Word) -newtype instance Vector Word = V_Word (P.Vector Word) -instance Unbox Word -primMVector(Word, MV_Word) -primVector(Word, V_Word, MV_Word) - -newtype instance MVector s Word8 = MV_Word8 (P.MVector s Word8) -newtype instance Vector Word8 = V_Word8 (P.Vector Word8) -instance Unbox Word8 -primMVector(Word8, MV_Word8) -primVector(Word8, V_Word8, MV_Word8) - -newtype instance MVector s Word16 = MV_Word16 (P.MVector s Word16) -newtype instance Vector Word16 = V_Word16 (P.Vector Word16) -instance Unbox Word16 -primMVector(Word16, MV_Word16) -primVector(Word16, V_Word16, MV_Word16) - -newtype instance MVector s Word32 = MV_Word32 (P.MVector s Word32) -newtype instance Vector Word32 = V_Word32 (P.Vector Word32) -instance Unbox Word32 -primMVector(Word32, MV_Word32) -primVector(Word32, V_Word32, MV_Word32) - -newtype instance MVector s Word64 = MV_Word64 (P.MVector s Word64) -newtype instance Vector Word64 = V_Word64 (P.Vector Word64) -instance Unbox Word64 -primMVector(Word64, MV_Word64) -primVector(Word64, V_Word64, MV_Word64) - - -newtype instance MVector s Float = MV_Float (P.MVector s Float) -newtype instance Vector Float = V_Float (P.Vector Float) -instance Unbox Float -primMVector(Float, MV_Float) -primVector(Float, V_Float, MV_Float) - -newtype instance MVector s Double = MV_Double (P.MVector s Double) -newtype instance Vector Double = V_Double (P.Vector Double) -instance Unbox Double -primMVector(Double, MV_Double) -primVector(Double, V_Double, MV_Double) - - -newtype instance MVector s Char = MV_Char (P.MVector s Char) -newtype instance Vector Char = V_Char (P.Vector Char) -instance Unbox Char -primMVector(Char, MV_Char) -primVector(Char, V_Char, MV_Char) - --- ---- --- Bool --- ---- - -fromBool :: Bool -> Word8 -{-# INLINE fromBool #-} -fromBool True = 1 -fromBool False = 0 - -toBool :: Word8 -> Bool -{-# INLINE toBool #-} -toBool 0 = False -toBool _ = True - -newtype instance MVector s Bool = MV_Bool (P.MVector s Word8) -newtype instance Vector Bool = V_Bool (P.Vector Word8) - -instance Unbox Bool - -instance M.MVector MVector Bool where - {-# INLINE basicLength #-} - {-# INLINE basicUnsafeSlice #-} - {-# INLINE basicOverlaps #-} - {-# INLINE basicUnsafeNew #-} - {-# INLINE basicInitialize #-} - {-# INLINE basicUnsafeReplicate #-} - {-# INLINE basicUnsafeRead #-} - {-# INLINE basicUnsafeWrite #-} - {-# INLINE basicClear #-} - {-# INLINE basicSet #-} - {-# INLINE basicUnsafeCopy #-} - {-# INLINE basicUnsafeGrow #-} - basicLength (MV_Bool v) = M.basicLength v - basicUnsafeSlice i n (MV_Bool v) = MV_Bool $ M.basicUnsafeSlice i n v - basicOverlaps (MV_Bool v1) (MV_Bool v2) = M.basicOverlaps v1 v2 - basicUnsafeNew n = MV_Bool `liftM` M.basicUnsafeNew n - basicInitialize (MV_Bool v) = M.basicInitialize v - basicUnsafeReplicate n x = MV_Bool `liftM` M.basicUnsafeReplicate n (fromBool x) - basicUnsafeRead (MV_Bool v) i = toBool `liftM` M.basicUnsafeRead v i - basicUnsafeWrite (MV_Bool v) i x = M.basicUnsafeWrite v i (fromBool x) - basicClear (MV_Bool v) = M.basicClear v - basicSet (MV_Bool v) x = M.basicSet v (fromBool x) - basicUnsafeCopy (MV_Bool v1) (MV_Bool v2) = M.basicUnsafeCopy v1 v2 - basicUnsafeMove (MV_Bool v1) (MV_Bool v2) = M.basicUnsafeMove v1 v2 - basicUnsafeGrow (MV_Bool v) n = MV_Bool `liftM` M.basicUnsafeGrow v n - -instance G.Vector Vector Bool where - {-# INLINE basicUnsafeFreeze #-} - {-# INLINE basicUnsafeThaw #-} - {-# INLINE basicLength #-} - {-# INLINE basicUnsafeSlice #-} - {-# INLINE basicUnsafeIndexM #-} - {-# INLINE elemseq #-} - basicUnsafeFreeze (MV_Bool v) = V_Bool `liftM` G.basicUnsafeFreeze v - basicUnsafeThaw (V_Bool v) = MV_Bool `liftM` G.basicUnsafeThaw v - basicLength (V_Bool v) = G.basicLength v - basicUnsafeSlice i n (V_Bool v) = V_Bool $ G.basicUnsafeSlice i n v - basicUnsafeIndexM (V_Bool v) i = toBool `liftM` G.basicUnsafeIndexM v i - basicUnsafeCopy (MV_Bool mv) (V_Bool v) = G.basicUnsafeCopy mv v - elemseq _ = seq - --- ------- --- Complex --- ------- - -newtype instance MVector s (Complex a) = MV_Complex (MVector s (a,a)) -newtype instance Vector (Complex a) = V_Complex (Vector (a,a)) - -instance (Unbox a) => Unbox (Complex a) - -instance (Unbox a) => M.MVector MVector (Complex a) where - {-# INLINE basicLength #-} - {-# INLINE basicUnsafeSlice #-} - {-# INLINE basicOverlaps #-} - {-# INLINE basicUnsafeNew #-} - {-# INLINE basicInitialize #-} - {-# INLINE basicUnsafeReplicate #-} - {-# INLINE basicUnsafeRead #-} - {-# INLINE basicUnsafeWrite #-} - {-# INLINE basicClear #-} - {-# INLINE basicSet #-} - {-# INLINE basicUnsafeCopy #-} - {-# INLINE basicUnsafeGrow #-} - basicLength (MV_Complex v) = M.basicLength v - basicUnsafeSlice i n (MV_Complex v) = MV_Complex $ M.basicUnsafeSlice i n v - basicOverlaps (MV_Complex v1) (MV_Complex v2) = M.basicOverlaps v1 v2 - basicUnsafeNew n = MV_Complex `liftM` M.basicUnsafeNew n - basicInitialize (MV_Complex v) = M.basicInitialize v - basicUnsafeReplicate n (x :+ y) = MV_Complex `liftM` M.basicUnsafeReplicate n (x,y) - basicUnsafeRead (MV_Complex v) i = uncurry (:+) `liftM` M.basicUnsafeRead v i - basicUnsafeWrite (MV_Complex v) i (x :+ y) = M.basicUnsafeWrite v i (x,y) - basicClear (MV_Complex v) = M.basicClear v - basicSet (MV_Complex v) (x :+ y) = M.basicSet v (x,y) - basicUnsafeCopy (MV_Complex v1) (MV_Complex v2) = M.basicUnsafeCopy v1 v2 - basicUnsafeMove (MV_Complex v1) (MV_Complex v2) = M.basicUnsafeMove v1 v2 - basicUnsafeGrow (MV_Complex v) n = MV_Complex `liftM` M.basicUnsafeGrow v n - -instance (Unbox a) => G.Vector Vector (Complex a) where - {-# INLINE basicUnsafeFreeze #-} - {-# INLINE basicUnsafeThaw #-} - {-# INLINE basicLength #-} - {-# INLINE basicUnsafeSlice #-} - {-# INLINE basicUnsafeIndexM #-} - {-# INLINE elemseq #-} - basicUnsafeFreeze (MV_Complex v) = V_Complex `liftM` G.basicUnsafeFreeze v - basicUnsafeThaw (V_Complex v) = MV_Complex `liftM` G.basicUnsafeThaw v - basicLength (V_Complex v) = G.basicLength v - basicUnsafeSlice i n (V_Complex v) = V_Complex $ G.basicUnsafeSlice i n v - basicUnsafeIndexM (V_Complex v) i - = uncurry (:+) `liftM` G.basicUnsafeIndexM v i - basicUnsafeCopy (MV_Complex mv) (V_Complex v) - = G.basicUnsafeCopy mv v - elemseq _ (x :+ y) z = G.elemseq (undefined :: Vector a) x - $ G.elemseq (undefined :: Vector a) y z - --- ------ --- Tuples --- ------ - -#define DEFINE_INSTANCES -#include "unbox-tuple-instances" diff --git a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Unboxed/Mutable.hs b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Unboxed/Mutable.hs deleted file mode 100644 index cb82acea8f87..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Unboxed/Mutable.hs +++ /dev/null @@ -1,307 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | --- Module : Data.Vector.Unboxed.Mutable --- Copyright : (c) Roman Leshchinskiy 2009-2010 --- License : BSD-style --- --- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> --- Stability : experimental --- Portability : non-portable --- --- Mutable adaptive unboxed vectors --- - -module Data.Vector.Unboxed.Mutable ( - -- * Mutable vectors of primitive types - MVector(..), IOVector, STVector, Unbox, - - -- * Accessors - - -- ** Length information - length, null, - - -- ** Extracting subvectors - slice, init, tail, take, drop, splitAt, - unsafeSlice, unsafeInit, unsafeTail, unsafeTake, unsafeDrop, - - -- ** Overlapping - overlaps, - - -- * Construction - - -- ** Initialisation - new, unsafeNew, replicate, replicateM, clone, - - -- ** Growing - grow, unsafeGrow, - - -- ** Restricting memory usage - clear, - - -- * Zipping and unzipping - zip, zip3, zip4, zip5, zip6, - unzip, unzip3, unzip4, unzip5, unzip6, - - -- * Accessing individual elements - read, write, modify, swap, - unsafeRead, unsafeWrite, unsafeModify, unsafeSwap, - - -- * Modifying vectors - nextPermutation, - - -- ** Filling and copying - set, copy, move, unsafeCopy, unsafeMove -) where - -import Data.Vector.Unboxed.Base -import qualified Data.Vector.Generic.Mutable as G -import Data.Vector.Fusion.Util ( delayed_min ) -import Control.Monad.Primitive - -import Prelude hiding ( length, null, replicate, reverse, map, read, - take, drop, splitAt, init, tail, - zip, zip3, unzip, unzip3 ) - --- don't import an unused Data.Vector.Internal.Check -#define NOT_VECTOR_MODULE -#include "vector.h" - --- Length information --- ------------------ - --- | Length of the mutable vector. -length :: Unbox a => MVector s a -> Int -{-# INLINE length #-} -length = G.length - --- | Check whether the vector is empty -null :: Unbox a => MVector s a -> Bool -{-# INLINE null #-} -null = G.null - --- Extracting subvectors --- --------------------- - --- | Yield a part of the mutable vector without copying it. -slice :: Unbox a => Int -> Int -> MVector s a -> MVector s a -{-# INLINE slice #-} -slice = G.slice - -take :: Unbox a => Int -> MVector s a -> MVector s a -{-# INLINE take #-} -take = G.take - -drop :: Unbox a => Int -> MVector s a -> MVector s a -{-# INLINE drop #-} -drop = G.drop - -splitAt :: Unbox a => Int -> MVector s a -> (MVector s a, MVector s a) -{-# INLINE splitAt #-} -splitAt = G.splitAt - -init :: Unbox a => MVector s a -> MVector s a -{-# INLINE init #-} -init = G.init - -tail :: Unbox a => MVector s a -> MVector s a -{-# INLINE tail #-} -tail = G.tail - --- | Yield a part of the mutable vector without copying it. No bounds checks --- are performed. -unsafeSlice :: Unbox a - => Int -- ^ starting index - -> Int -- ^ length of the slice - -> MVector s a - -> MVector s a -{-# INLINE unsafeSlice #-} -unsafeSlice = G.unsafeSlice - -unsafeTake :: Unbox a => Int -> MVector s a -> MVector s a -{-# INLINE unsafeTake #-} -unsafeTake = G.unsafeTake - -unsafeDrop :: Unbox a => Int -> MVector s a -> MVector s a -{-# INLINE unsafeDrop #-} -unsafeDrop = G.unsafeDrop - -unsafeInit :: Unbox a => MVector s a -> MVector s a -{-# INLINE unsafeInit #-} -unsafeInit = G.unsafeInit - -unsafeTail :: Unbox a => MVector s a -> MVector s a -{-# INLINE unsafeTail #-} -unsafeTail = G.unsafeTail - --- Overlapping --- ----------- - --- | Check whether two vectors overlap. -overlaps :: Unbox a => MVector s a -> MVector s a -> Bool -{-# INLINE overlaps #-} -overlaps = G.overlaps - --- Initialisation --- -------------- - --- | Create a mutable vector of the given length. -new :: (PrimMonad m, Unbox a) => Int -> m (MVector (PrimState m) a) -{-# INLINE new #-} -new = G.new - --- | Create a mutable vector of the given length. The memory is not initialized. -unsafeNew :: (PrimMonad m, Unbox a) => Int -> m (MVector (PrimState m) a) -{-# INLINE unsafeNew #-} -unsafeNew = G.unsafeNew - --- | Create a mutable vector of the given length (0 if the length is negative) --- and fill it with an initial value. -replicate :: (PrimMonad m, Unbox a) => Int -> a -> m (MVector (PrimState m) a) -{-# INLINE replicate #-} -replicate = G.replicate - --- | Create a mutable vector of the given length (0 if the length is negative) --- and fill it with values produced by repeatedly executing the monadic action. -replicateM :: (PrimMonad m, Unbox a) => Int -> m a -> m (MVector (PrimState m) a) -{-# INLINE replicateM #-} -replicateM = G.replicateM - --- | Create a copy of a mutable vector. -clone :: (PrimMonad m, Unbox a) - => MVector (PrimState m) a -> m (MVector (PrimState m) a) -{-# INLINE clone #-} -clone = G.clone - --- Growing --- ------- - --- | Grow a vector by the given number of elements. The number must be --- positive. -grow :: (PrimMonad m, Unbox a) - => MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a) -{-# INLINE grow #-} -grow = G.grow - --- | Grow a vector by the given number of elements. The number must be --- positive but this is not checked. -unsafeGrow :: (PrimMonad m, Unbox a) - => MVector (PrimState m) a -> Int -> m (MVector (PrimState m) a) -{-# INLINE unsafeGrow #-} -unsafeGrow = G.unsafeGrow - --- Restricting memory usage --- ------------------------ - --- | Reset all elements of the vector to some undefined value, clearing all --- references to external objects. This is usually a noop for unboxed vectors. -clear :: (PrimMonad m, Unbox a) => MVector (PrimState m) a -> m () -{-# INLINE clear #-} -clear = G.clear - --- Accessing individual elements --- ----------------------------- - --- | Yield the element at the given position. -read :: (PrimMonad m, Unbox a) => MVector (PrimState m) a -> Int -> m a -{-# INLINE read #-} -read = G.read - --- | Replace the element at the given position. -write :: (PrimMonad m, Unbox a) => MVector (PrimState m) a -> Int -> a -> m () -{-# INLINE write #-} -write = G.write - --- | Modify the element at the given position. -modify :: (PrimMonad m, Unbox a) => MVector (PrimState m) a -> (a -> a) -> Int -> m () -{-# INLINE modify #-} -modify = G.modify - --- | Swap the elements at the given positions. -swap :: (PrimMonad m, Unbox a) => MVector (PrimState m) a -> Int -> Int -> m () -{-# INLINE swap #-} -swap = G.swap - - --- | Yield the element at the given position. No bounds checks are performed. -unsafeRead :: (PrimMonad m, Unbox a) => MVector (PrimState m) a -> Int -> m a -{-# INLINE unsafeRead #-} -unsafeRead = G.unsafeRead - --- | Replace the element at the given position. No bounds checks are performed. -unsafeWrite - :: (PrimMonad m, Unbox a) => MVector (PrimState m) a -> Int -> a -> m () -{-# INLINE unsafeWrite #-} -unsafeWrite = G.unsafeWrite - --- | Modify the element at the given position. No bounds checks are performed. -unsafeModify :: (PrimMonad m, Unbox a) => MVector (PrimState m) a -> (a -> a) -> Int -> m () -{-# INLINE unsafeModify #-} -unsafeModify = G.unsafeModify - --- | Swap the elements at the given positions. No bounds checks are performed. -unsafeSwap - :: (PrimMonad m, Unbox a) => MVector (PrimState m) a -> Int -> Int -> m () -{-# INLINE unsafeSwap #-} -unsafeSwap = G.unsafeSwap - --- Filling and copying --- ------------------- - --- | Set all elements of the vector to the given value. -set :: (PrimMonad m, Unbox a) => MVector (PrimState m) a -> a -> m () -{-# INLINE set #-} -set = G.set - --- | Copy a vector. The two vectors must have the same length and may not --- overlap. -copy :: (PrimMonad m, Unbox a) - => MVector (PrimState m) a -- ^ target - -> MVector (PrimState m) a -- ^ source - -> m () -{-# INLINE copy #-} -copy = G.copy - --- | Copy a vector. The two vectors must have the same length and may not --- overlap. This is not checked. -unsafeCopy :: (PrimMonad m, Unbox a) - => MVector (PrimState m) a -- ^ target - -> MVector (PrimState m) a -- ^ source - -> m () -{-# INLINE unsafeCopy #-} -unsafeCopy = G.unsafeCopy - --- | Move the contents of a vector. The two vectors must have the same --- length. --- --- If the vectors do not overlap, then this is equivalent to 'copy'. --- Otherwise, the copying is performed as if the source vector were --- copied to a temporary vector and then the temporary vector was copied --- to the target vector. -move :: (PrimMonad m, Unbox a) - => MVector (PrimState m) a -> MVector (PrimState m) a -> m () -{-# INLINE move #-} -move = G.move - --- | Move the contents of a vector. The two vectors must have the same --- length, but this is not checked. --- --- If the vectors do not overlap, then this is equivalent to 'unsafeCopy'. --- Otherwise, the copying is performed as if the source vector were --- copied to a temporary vector and then the temporary vector was copied --- to the target vector. -unsafeMove :: (PrimMonad m, Unbox a) - => MVector (PrimState m) a -- ^ target - -> MVector (PrimState m) a -- ^ source - -> m () -{-# INLINE unsafeMove #-} -unsafeMove = G.unsafeMove - --- | Compute the next (lexicographically) permutation of given vector in-place. --- Returns False when input is the last permtuation -nextPermutation :: (PrimMonad m,Ord e,Unbox e) => MVector (PrimState m) e -> m Bool -{-# INLINE nextPermutation #-} -nextPermutation = G.nextPermutation - -#define DEFINE_MUTABLE -#include "unbox-tuple-instances" diff --git a/third_party/bazel/rules_haskell/examples/vector/LICENSE b/third_party/bazel/rules_haskell/examples/vector/LICENSE deleted file mode 100644 index cafa68efb33e..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright (c) 2008-2012, Roman Leshchinskiy -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -- Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. - -- Redistributions in binary form must reproduce the above copyright notice, -this list of conditions and the following disclaimer in the documentation -and/or other materials provided with the distribution. - -- Neither name of the University nor the names of its contributors may be -used to endorse or promote products derived from this software without -specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF -GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, -INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH -DAMAGE. - diff --git a/third_party/bazel/rules_haskell/examples/vector/README.md b/third_party/bazel/rules_haskell/examples/vector/README.md deleted file mode 100644 index 079dbd0b6b93..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/README.md +++ /dev/null @@ -1,6 +0,0 @@ -The `vector` package [](https://travis-ci.org/haskell/vector) -==================== - -An efficient implementation of Int-indexed arrays (both mutable and immutable), with a powerful loop optimisation framework. - -See [`vector` on Hackage](http://hackage.haskell.org/package/vector) for more information. diff --git a/third_party/bazel/rules_haskell/examples/vector/Setup.hs b/third_party/bazel/rules_haskell/examples/vector/Setup.hs deleted file mode 100644 index 200a2e51d0b4..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/AwShCC.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/AwShCC.hs deleted file mode 100644 index 404e289fae15..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/AwShCC.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# OPTIONS -fno-spec-constr-count #-} -module Algo.AwShCC (awshcc) where - -import Data.Vector.Unboxed as V - -awshcc :: (Int, Vector Int, Vector Int) -> Vector Int -{-# NOINLINE awshcc #-} -awshcc (n, es1, es2) = concomp ds es1' es2' - where - ds = V.enumFromTo 0 (n-1) V.++ V.enumFromTo 0 (n-1) - es1' = es1 V.++ es2 - es2' = es2 V.++ es1 - - starCheck ds = V.backpermute st' gs - where - gs = V.backpermute ds ds - st = V.zipWith (==) ds gs - st' = V.update st . V.filter (not . snd) - $ V.zip gs st - - concomp ds es1 es2 - | V.and (starCheck ds'') = ds'' - | otherwise = concomp (V.backpermute ds'' ds'') es1 es2 - where - ds' = V.update ds - . V.map (\(di, dj, gi) -> (di, dj)) - . V.filter (\(di, dj, gi) -> gi == di && di > dj) - $ V.zip3 (V.backpermute ds es1) - (V.backpermute ds es2) - (V.backpermute ds (V.backpermute ds es1)) - - ds'' = V.update ds' - . V.map (\(di, dj, st) -> (di, dj)) - . V.filter (\(di, dj, st) -> st && di /= dj) - $ V.zip3 (V.backpermute ds' es1) - (V.backpermute ds' es2) - (V.backpermute (starCheck ds') es1) - diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/HybCC.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/HybCC.hs deleted file mode 100644 index 876d08f75b62..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/HybCC.hs +++ /dev/null @@ -1,42 +0,0 @@ -module Algo.HybCC (hybcc) where - -import Data.Vector.Unboxed as V - -hybcc :: (Int, Vector Int, Vector Int) -> Vector Int -{-# NOINLINE hybcc #-} -hybcc (n, e1, e2) = concomp (V.zip e1 e2) n - where - concomp es n - | V.null es = V.enumFromTo 0 (n-1) - | otherwise = V.backpermute ins ins - where - p = shortcut_all - $ V.update (V.enumFromTo 0 (n-1)) es - - (es',i) = compress p es - r = concomp es' (V.length i) - ins = V.update_ p i - $ V.backpermute i r - - enumerate bs = V.prescanl' (+) 0 $ V.map (\b -> if b then 1 else 0) bs - - pack_index bs = V.map fst - . V.filter snd - $ V.zip (V.enumFromTo 0 (V.length bs - 1)) bs - - shortcut_all p | p == pp = pp - | otherwise = shortcut_all pp - where - pp = V.backpermute p p - - compress p es = (new_es, pack_index roots) - where - (e1,e2) = V.unzip es - es' = V.map (\(x,y) -> if x > y then (y,x) else (x,y)) - . V.filter (\(x,y) -> x /= y) - $ V.zip (V.backpermute p e1) (V.backpermute p e2) - - roots = V.zipWith (==) p (V.enumFromTo 0 (V.length p - 1)) - labels = enumerate roots - (e1',e2') = V.unzip es' - new_es = V.zip (V.backpermute labels e1') (V.backpermute labels e2') diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Leaffix.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Leaffix.hs deleted file mode 100644 index 40ec517556fe..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Leaffix.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Algo.Leaffix where - -import Data.Vector.Unboxed as V - -leaffix :: (Vector Int, Vector Int) -> Vector Int -{-# NOINLINE leaffix #-} -leaffix (ls,rs) - = leaffix (V.replicate (V.length ls) 1) ls rs - where - leaffix xs ls rs - = let zs = V.replicate (V.length ls * 2) 0 - vs = V.update_ zs ls xs - sums = V.prescanl' (+) 0 vs - in - V.zipWith (-) (V.backpermute sums ls) (V.backpermute sums rs) - diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/ListRank.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/ListRank.hs deleted file mode 100644 index 933bd8eb2ec9..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/ListRank.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Algo.ListRank -where - -import Data.Vector.Unboxed as V - -listRank :: Int -> Vector Int -{-# NOINLINE listRank #-} -listRank n = pointer_jump xs val - where - xs = 0 `V.cons` V.enumFromTo 0 (n-2) - - val = V.zipWith (\i j -> if i == j then 0 else 1) - xs (V.enumFromTo 0 (n-1)) - - pointer_jump pt val - | npt == pt = val - | otherwise = pointer_jump npt nval - where - npt = V.backpermute pt pt - nval = V.zipWith (+) val (V.backpermute val pt) - diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Quickhull.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Quickhull.hs deleted file mode 100644 index 694bea3097a3..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Quickhull.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Algo.Quickhull (quickhull) where - -import Data.Vector.Unboxed as V - -quickhull :: (Vector Double, Vector Double) -> (Vector Double, Vector Double) -{-# NOINLINE quickhull #-} -quickhull (xs, ys) = xs' `seq` ys' `seq` (xs',ys') - where - (xs',ys') = V.unzip - $ hsplit points pmin pmax V.++ hsplit points pmax pmin - - imin = V.minIndex xs - imax = V.maxIndex xs - - points = V.zip xs ys - pmin = points V.! imin - pmax = points V.! imax - - - hsplit points p1 p2 - | V.length packed < 2 = p1 `V.cons` packed - | otherwise = hsplit packed p1 pm V.++ hsplit packed pm p2 - where - cs = V.map (\p -> cross p p1 p2) points - packed = V.map fst - $ V.filter (\t -> snd t > 0) - $ V.zip points cs - - pm = points V.! V.maxIndex cs - - cross (x,y) (x1,y1) (x2,y2) = (x1-x)*(y2-y) - (y1-y)*(x2-x) - diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Rootfix.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Rootfix.hs deleted file mode 100644 index 1b112a801a5e..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Rootfix.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Algo.Rootfix where - -import Data.Vector.Unboxed as V - -rootfix :: (V.Vector Int, V.Vector Int) -> V.Vector Int -{-# NOINLINE rootfix #-} -rootfix (ls, rs) = rootfix (V.replicate (V.length ls) 1) ls rs - where - rootfix xs ls rs - = let zs = V.replicate (V.length ls * 2) 0 - vs = V.update_ (V.update_ zs ls xs) rs (V.map negate xs) - sums = V.prescanl' (+) 0 vs - in - V.backpermute sums ls - diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Spectral.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Spectral.hs deleted file mode 100644 index 811c58269e84..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Spectral.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Algo.Spectral ( spectral ) where - -import Data.Vector.Unboxed as V - -import Data.Bits - -spectral :: Vector Double -> Vector Double -{-# NOINLINE spectral #-} -spectral us = us `seq` V.map row (V.enumFromTo 0 (n-1)) - where - n = V.length us - - row i = i `seq` V.sum (V.imap (\j u -> eval_A i j * u) us) - - eval_A i j = 1 / fromIntegral r - where - r = u + (i+1) - u = t `shiftR` 1 - t = n * (n+1) - n = i+j - diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Tridiag.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Tridiag.hs deleted file mode 100644 index 7668deace132..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Tridiag.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Algo.Tridiag ( tridiag ) where - -import Data.Vector.Unboxed as V - -tridiag :: (Vector Double, Vector Double, Vector Double, Vector Double) - -> Vector Double -{-# NOINLINE tridiag #-} -tridiag (as,bs,cs,ds) = V.prescanr' (\(c,d) x' -> d - c*x') 0 - $ V.prescanl' modify (0,0) - $ V.zip (V.zip as bs) (V.zip cs ds) - where - modify (c',d') ((a,b),(c,d)) = - let id = 1 / (b - c'*a) - in - id `seq` (c*id, (d-d'*a)*id) - diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/LICENSE b/third_party/bazel/rules_haskell/examples/vector/benchmarks/LICENSE deleted file mode 100644 index fc213a6ffbfe..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/benchmarks/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright (c) 2008-2009, Roman Leshchinskiy -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -- Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. - -- Redistributions in binary form must reproduce the above copyright notice, -this list of conditions and the following disclaimer in the documentation -and/or other materials provided with the distribution. - -- Neither name of the University nor the names of its contributors may be -used to endorse or promote products derived from this software without -specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF -GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, -INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH -DAMAGE. - diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Main.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Main.hs deleted file mode 100644 index 65bd297a7552..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Main.hs +++ /dev/null @@ -1,46 +0,0 @@ -module Main where - -import Criterion.Main - -import Algo.ListRank (listRank) -import Algo.Rootfix (rootfix) -import Algo.Leaffix (leaffix) -import Algo.AwShCC (awshcc) -import Algo.HybCC (hybcc) -import Algo.Quickhull (quickhull) -import Algo.Spectral ( spectral ) -import Algo.Tridiag ( tridiag ) - -import TestData.ParenTree ( parenTree ) -import TestData.Graph ( randomGraph ) -import TestData.Random ( randomVector ) - -import Data.Vector.Unboxed ( Vector ) - -size :: Int -size = 100000 - -main = lparens `seq` rparens `seq` - nodes `seq` edges1 `seq` edges2 `seq` - do - as <- randomVector size :: IO (Vector Double) - bs <- randomVector size :: IO (Vector Double) - cs <- randomVector size :: IO (Vector Double) - ds <- randomVector size :: IO (Vector Double) - sp <- randomVector (floor $ sqrt $ fromIntegral size) - :: IO (Vector Double) - as `seq` bs `seq` cs `seq` ds `seq` sp `seq` - defaultMain [ bench "listRank" $ whnf listRank size - , bench "rootfix" $ whnf rootfix (lparens, rparens) - , bench "leaffix" $ whnf leaffix (lparens, rparens) - , bench "awshcc" $ whnf awshcc (nodes, edges1, edges2) - , bench "hybcc" $ whnf hybcc (nodes, edges1, edges2) - , bench "quickhull" $ whnf quickhull (as,bs) - , bench "spectral" $ whnf spectral sp - , bench "tridiag" $ whnf tridiag (as,bs,cs,ds) - ] - where - (lparens, rparens) = parenTree size - (nodes, edges1, edges2) = randomGraph size - - diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Setup.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Setup.hs deleted file mode 100644 index 200a2e51d0b4..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/benchmarks/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/TestData/Graph.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/TestData/Graph.hs deleted file mode 100644 index 8b8ca837b890..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/benchmarks/TestData/Graph.hs +++ /dev/null @@ -1,45 +0,0 @@ -module TestData.Graph ( randomGraph ) -where - -import System.Random.MWC -import qualified Data.Array.ST as STA -import qualified Data.Vector.Unboxed as V - -import Control.Monad.ST ( ST, runST ) - -randomGraph :: Int -> (Int, V.Vector Int, V.Vector Int) -randomGraph e - = runST ( - do - g <- create - arr <- STA.newArray (0,n-1) [] :: ST s (STA.STArray s Int [Int]) - addRandomEdges n g arr e - xs <- STA.getAssocs arr - let (as,bs) = unzip [(i,j) | (i,js) <- xs, j <- js ] - return (n, V.fromListN (length as) as, V.fromListN (length bs) bs) - ) - where - n = e `div` 10 - -addRandomEdges :: Int -> Gen s -> STA.STArray s Int [Int] -> Int -> ST s () -addRandomEdges n g arr = fill - where - fill 0 = return () - fill e - = do - m <- random_index - n <- random_index - let lo = min m n - hi = max m n - ns <- STA.readArray arr lo - if lo == hi || hi `elem` ns - then fill e - else do - STA.writeArray arr lo (hi:ns) - fill (e-1) - - random_index = do - x <- uniform g - let i = floor ((x::Double) * toEnum n) - if i == n then return 0 else return i - diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/TestData/ParenTree.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/TestData/ParenTree.hs deleted file mode 100644 index 4aeb750954a9..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/benchmarks/TestData/ParenTree.hs +++ /dev/null @@ -1,20 +0,0 @@ -module TestData.ParenTree where - -import qualified Data.Vector.Unboxed as V - -parenTree :: Int -> (V.Vector Int, V.Vector Int) -parenTree n = case go ([],[]) 0 (if even n then n else n+1) of - (ls,rs) -> (V.fromListN (length ls) (reverse ls), - V.fromListN (length rs) (reverse rs)) - where - go (ls,rs) i j = case j-i of - 0 -> (ls,rs) - 2 -> (ls',rs') - d -> let k = ((d-2) `div` 4) * 2 - in - go (go (ls',rs') (i+1) (i+1+k)) (i+1+k) (j-1) - where - ls' = i:ls - rs' = j-1:rs - - diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/TestData/Random.hs b/third_party/bazel/rules_haskell/examples/vector/benchmarks/TestData/Random.hs deleted file mode 100644 index f9b741fb97ae..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/benchmarks/TestData/Random.hs +++ /dev/null @@ -1,16 +0,0 @@ -module TestData.Random ( randomVector ) where - -import qualified Data.Vector.Unboxed as V - -import System.Random.MWC -import Control.Monad.ST ( runST ) - -randomVector :: (Variate a, V.Unbox a) => Int -> IO (V.Vector a) -randomVector n = withSystemRandom $ \g -> - do - xs <- sequence $ replicate n $ uniform g - io (return $ V.fromListN n xs) - where - io :: IO a -> IO a - io = id - diff --git a/third_party/bazel/rules_haskell/examples/vector/benchmarks/vector-benchmarks.cabal b/third_party/bazel/rules_haskell/examples/vector/benchmarks/vector-benchmarks.cabal deleted file mode 100644 index 3e825c0fa4e6..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/benchmarks/vector-benchmarks.cabal +++ /dev/null @@ -1,37 +0,0 @@ -Name: vector-benchmarks -Version: 0.10.9 -License: BSD3 -License-File: LICENSE -Author: Roman Leshchinskiy <rl@cse.unsw.edu.au> -Maintainer: Roman Leshchinskiy <rl@cse.unsw.edu.au> -Copyright: (c) Roman Leshchinskiy 2010-2012 -Cabal-Version: >= 1.2 -Build-Type: Simple - -Executable algorithms - Main-Is: Main.hs - - Build-Depends: base >= 2 && < 5, array, - criterion >= 0.5 && < 0.7, - mwc-random >= 0.5 && < 0.13, - vector == 0.10.9 - - if impl(ghc<6.13) - Ghc-Options: -finline-if-enough-args -fno-method-sharing - - Ghc-Options: -O2 - - Other-Modules: - Algo.ListRank - Algo.Rootfix - Algo.Leaffix - Algo.AwShCC - Algo.HybCC - Algo.Quickhull - Algo.Spectral - Algo.Tridiag - - TestData.ParenTree - TestData.Graph - TestData.Random - diff --git a/third_party/bazel/rules_haskell/examples/vector/changelog b/third_party/bazel/rules_haskell/examples/vector/changelog deleted file mode 100644 index 3d824b74d123..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/changelog +++ /dev/null @@ -1,75 +0,0 @@ -Changes in version 0.12.0.1 - - * Make sure `length` can be inlined - * Include modules that test-suites depend on in other-modules - -Changes in version 0.12.0.0 - - * Documentation fixes/additions - * New functions: createT, iscanl/r, iterateNM, unfoldrM, uniq - * New instances for various vector types: Semigroup, MonadZip - * Made `Storable` vectors respect memory alignment - * Changed some macros to ConstraintKinds - - Dropped compatibility with old GHCs to support this - * Add `Eq1`, `Ord1`, `Show1`, and `Read1` `Vector` instances, and related - helper functions. - * Relax context for `Unbox (Complex a)`. - -Changes in version 0.11.0.0 - - * Define `Applicative` instances for `Data.Vector.Fusion.Util.{Box,Id}` - * Define non-bottom `fail` for `instance Monad Vector` - * New generalized stream fusion framework - * Various safety fixes - - Various overflows due to vector size have been eliminated - - Memory is initialized on creation of unboxed vectors - * Changes to SPEC usage to allow building under more conditions - -Changes in version 0.10.12.3 - - * Allow building with `primtive-0.6` - -Changes in version 0.10.12.2 - - * Add support for `deepseq-1.4.0.0` - -Changes in version 0.10.12.1 - - * Fixed compilation on non-head GHCs - -Changes in version 0.10.12.0 - - * Export MVector constructor from Data.Vector.Primitive to match Vector's - (which was already exported). - - * Fix building on GHC 7.9 by adding Applicative instances for Id and Box - -Changes in version 0.10.11.0 - - * Support OverloadedLists for boxed Vector in GHC >= 7.8 - -Changes in version 0.10.10.0 - - * Minor version bump to rectify PVP violation occured in 0.10.9.3 release - -Changes in version 0.10.9.3 (deprecated) - - * Add support for OverloadedLists in GHC >= 7.8 - -Changes in version 0.10.9.2 - - * Fix compilation with GHC 7.9 - -Changes in version 0.10.9.1 - - * Implement poly-kinded Typeable - -Changes in version 0.10.0.1 - - * Require `primitive` to include workaround for a GHC array copying bug - -Changes in version 0.10 - - * `NFData` instances - * More efficient block fills - * Safe Haskell support removed diff --git a/third_party/bazel/rules_haskell/examples/vector/include/vector.h b/third_party/bazel/rules_haskell/examples/vector/include/vector.h deleted file mode 100644 index 1568bb290633..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/include/vector.h +++ /dev/null @@ -1,20 +0,0 @@ -#define PHASE_FUSED [1] -#define PHASE_INNER [0] - -#define INLINE_FUSED INLINE PHASE_FUSED -#define INLINE_INNER INLINE PHASE_INNER - -#ifndef NOT_VECTOR_MODULE -import qualified Data.Vector.Internal.Check as Ck -#endif - -#define ERROR (Ck.error __FILE__ __LINE__) -#define INTERNAL_ERROR (Ck.internalError __FILE__ __LINE__) - -#define CHECK(f) (Ck.f __FILE__ __LINE__) -#define BOUNDS_CHECK(f) (CHECK(f) Ck.Bounds) -#define UNSAFE_CHECK(f) (CHECK(f) Ck.Unsafe) -#define INTERNAL_CHECK(f) (CHECK(f) Ck.Internal) - -#define PHASE_STREAM Please use "PHASE_FUSED" instead -#define INLINE_STREAM Please use "INLINE_FUSED" instead diff --git a/third_party/bazel/rules_haskell/examples/vector/internal/GenUnboxTuple.hs b/third_party/bazel/rules_haskell/examples/vector/internal/GenUnboxTuple.hs deleted file mode 100644 index 8debff23a975..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/internal/GenUnboxTuple.hs +++ /dev/null @@ -1,239 +0,0 @@ -{-# LANGUAGE ParallelListComp #-} -module Main where - -import Text.PrettyPrint - -import System.Environment ( getArgs ) - -main = do - [s] <- getArgs - let n = read s - mapM_ (putStrLn . render . generate) [2..n] - -generate :: Int -> Doc -generate n = - vcat [ text "#ifdef DEFINE_INSTANCES" - , data_instance "MVector s" "MV" - , data_instance "Vector" "V" - , class_instance "Unbox" - , class_instance "M.MVector MVector" <+> text "where" - , nest 2 $ vcat $ map method methods_MVector - , class_instance "G.Vector Vector" <+> text "where" - , nest 2 $ vcat $ map method methods_Vector - , text "#endif" - , text "#ifdef DEFINE_MUTABLE" - , define_zip "MVector s" "MV" - , define_unzip "MVector s" "MV" - , text "#endif" - , text "#ifdef DEFINE_IMMUTABLE" - , define_zip "Vector" "V" - , define_zip_rule - , define_unzip "Vector" "V" - , text "#endif" - ] - - where - vars = map (\c -> text ['_',c]) $ take n ['a'..] - varss = map (<> char 's') vars - tuple xs = parens $ hsep $ punctuate comma xs - vtuple xs = parens $ sep $ punctuate comma xs - con s = text s <> char '_' <> int n - var c = text ('_' : c : "_") - - data_instance ty c - = hang (hsep [text "data instance", text ty, tuple vars]) - 4 - (hsep [char '=', con c, text "{-# UNPACK #-} !Int" - , vcat $ map (\v -> char '!' <> parens (text ty <+> v)) vars]) - - class_instance cls - = text "instance" <+> vtuple [text "Unbox" <+> v | v <- vars] - <+> text "=>" <+> text cls <+> tuple vars - - - define_zip ty c - = sep [text "-- | /O(1)/ Zip" <+> int n <+> text "vectors" - ,name <+> text "::" - <+> vtuple [text "Unbox" <+> v | v <- vars] - <+> text "=>" - <+> sep (punctuate (text " ->") [text ty <+> v | v <- vars]) - <+> text "->" - <+> text ty <+> tuple vars - ,text "{-# INLINE_FUSED" <+> name <+> text "#-}" - ,name <+> sep varss - <+> text "=" - <+> con c - <+> text "len" - <+> sep [parens $ text "unsafeSlice" - <+> char '0' - <+> text "len" - <+> vs | vs <- varss] - ,nest 2 $ hang (text "where") - 2 - $ text "len =" - <+> sep (punctuate (text " `delayed_min`") - [text "length" <+> vs | vs <- varss]) - ] - where - name | n == 2 = text "zip" - | otherwise = text "zip" <> int n - - define_zip_rule - = hang (text "{-# RULES" <+> text "\"stream/" <> name "zip" - <> text " [Vector.Unboxed]\" forall" <+> sep varss <+> char '.') - 2 $ - text "G.stream" <+> parens (name "zip" <+> sep varss) - <+> char '=' - <+> text "Bundle." <> name "zipWith" <+> tuple (replicate n empty) - <+> sep [parens $ text "G.stream" <+> vs | vs <- varss] - $$ text "#-}" - where - name s | n == 2 = text s - | otherwise = text s <> int n - - - define_unzip ty c - = sep [text "-- | /O(1)/ Unzip" <+> int n <+> text "vectors" - ,name <+> text "::" - <+> vtuple [text "Unbox" <+> v | v <- vars] - <+> text "=>" - <+> text ty <+> tuple vars - <+> text "->" <+> vtuple [text ty <+> v | v <- vars] - ,text "{-# INLINE" <+> name <+> text "#-}" - ,name <+> pat c <+> text "=" - <+> vtuple varss - ] - where - name | n == 2 = text "unzip" - | otherwise = text "unzip" <> int n - - pat c = parens $ con c <+> var 'n' <+> sep varss - patn c n = parens $ con c <+> (var 'n' <> int n) - <+> sep [v <> int n | v <- varss] - - qM s = text "M." <> text s - qG s = text "G." <> text s - - gen_length c _ = (pat c, var 'n') - - gen_unsafeSlice mod c rec - = (var 'i' <+> var 'm' <+> pat c, - con c <+> var 'm' - <+> vcat [parens - $ text mod <> char '.' <> text rec - <+> var 'i' <+> var 'm' <+> vs - | vs <- varss]) - - - gen_overlaps rec = (patn "MV" 1 <+> patn "MV" 2, - vcat $ r : [text "||" <+> r | r <- rs]) - where - r : rs = [qM rec <+> v <> char '1' <+> v <> char '2' | v <- varss] - - gen_unsafeNew rec - = (var 'n', - mk_do [v <+> text "<-" <+> qM rec <+> var 'n' | v <- varss] - $ text "return $" <+> con "MV" <+> var 'n' <+> sep varss) - - gen_unsafeReplicate rec - = (var 'n' <+> tuple vars, - mk_do [vs <+> text "<-" <+> qM rec <+> var 'n' <+> v - | v <- vars | vs <- varss] - $ text "return $" <+> con "MV" <+> var 'n' <+> sep varss) - - gen_unsafeRead rec - = (pat "MV" <+> var 'i', - mk_do [v <+> text "<-" <+> qM rec <+> vs <+> var 'i' | v <- vars - | vs <- varss] - $ text "return" <+> tuple vars) - - gen_unsafeWrite rec - = (pat "MV" <+> var 'i' <+> tuple vars, - mk_do [qM rec <+> vs <+> var 'i' <+> v | v <- vars | vs <- varss] - empty) - - gen_clear rec - = (pat "MV", mk_do [qM rec <+> vs | vs <- varss] empty) - - gen_set rec - = (pat "MV" <+> tuple vars, - mk_do [qM rec <+> vs <+> v | vs <- varss | v <- vars] empty) - - gen_unsafeCopy c q rec - = (patn "MV" 1 <+> patn c 2, - mk_do [q rec <+> vs <> char '1' <+> vs <> char '2' | vs <- varss] - empty) - - gen_unsafeMove rec - = (patn "MV" 1 <+> patn "MV" 2, - mk_do [qM rec <+> vs <> char '1' <+> vs <> char '2' | vs <- varss] - empty) - - gen_unsafeGrow rec - = (pat "MV" <+> var 'm', - mk_do [vs <> char '\'' <+> text "<-" - <+> qM rec <+> vs <+> var 'm' | vs <- varss] - $ text "return $" <+> con "MV" - <+> parens (var 'm' <> char '+' <> var 'n') - <+> sep (map (<> char '\'') varss)) - - gen_initialize rec - = (pat "MV", mk_do [qM rec <+> vs | vs <- varss] empty) - - gen_unsafeFreeze rec - = (pat "MV", - mk_do [vs <> char '\'' <+> text "<-" <+> qG rec <+> vs | vs <- varss] - $ text "return $" <+> con "V" <+> var 'n' - <+> sep [vs <> char '\'' | vs <- varss]) - - gen_unsafeThaw rec - = (pat "V", - mk_do [vs <> char '\'' <+> text "<-" <+> qG rec <+> vs | vs <- varss] - $ text "return $" <+> con "MV" <+> var 'n' - <+> sep [vs <> char '\'' | vs <- varss]) - - gen_basicUnsafeIndexM rec - = (pat "V" <+> var 'i', - mk_do [v <+> text "<-" <+> qG rec <+> vs <+> var 'i' - | vs <- varss | v <- vars] - $ text "return" <+> tuple vars) - - gen_elemseq rec - = (char '_' <+> tuple vars, - vcat $ r : [char '.' <+> r | r <- rs]) - where - r : rs = [qG rec <+> parens (text "undefined :: Vector" <+> v) - <+> v | v <- vars] - - mk_do cmds ret = hang (text "do") - 2 - $ vcat $ cmds ++ [ret] - - method (s, f) = case f s of - (p,e) -> text "{-# INLINE" <+> text s <+> text " #-}" - $$ hang (text s <+> p) - 4 - (char '=' <+> e) - - - methods_MVector = [("basicLength", gen_length "MV") - ,("basicUnsafeSlice", gen_unsafeSlice "M" "MV") - ,("basicOverlaps", gen_overlaps) - ,("basicUnsafeNew", gen_unsafeNew) - ,("basicUnsafeReplicate", gen_unsafeReplicate) - ,("basicUnsafeRead", gen_unsafeRead) - ,("basicUnsafeWrite", gen_unsafeWrite) - ,("basicClear", gen_clear) - ,("basicSet", gen_set) - ,("basicUnsafeCopy", gen_unsafeCopy "MV" qM) - ,("basicUnsafeMove", gen_unsafeMove) - ,("basicUnsafeGrow", gen_unsafeGrow) - ,("basicInitialize", gen_initialize)] - - methods_Vector = [("basicUnsafeFreeze", gen_unsafeFreeze) - ,("basicUnsafeThaw", gen_unsafeThaw) - ,("basicLength", gen_length "V") - ,("basicUnsafeSlice", gen_unsafeSlice "G" "V") - ,("basicUnsafeIndexM", gen_basicUnsafeIndexM) - ,("basicUnsafeCopy", gen_unsafeCopy "V" qG) - ,("elemseq", gen_elemseq)] diff --git a/third_party/bazel/rules_haskell/examples/vector/internal/unbox-tuple-instances b/third_party/bazel/rules_haskell/examples/vector/internal/unbox-tuple-instances deleted file mode 100644 index 6fb88d4a4047..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/internal/unbox-tuple-instances +++ /dev/null @@ -1,1134 +0,0 @@ -#ifdef DEFINE_INSTANCES -data instance MVector s (a, b) - = MV_2 {-# UNPACK #-} !Int !(MVector s a) - !(MVector s b) -data instance Vector (a, b) - = V_2 {-# UNPACK #-} !Int !(Vector a) - !(Vector b) -instance (Unbox a, Unbox b) => Unbox (a, b) -instance (Unbox a, Unbox b) => M.MVector MVector (a, b) where - {-# INLINE basicLength #-} - basicLength (MV_2 n_ _ _) = n_ - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice i_ m_ (MV_2 _ as bs) - = MV_2 m_ (M.basicUnsafeSlice i_ m_ as) - (M.basicUnsafeSlice i_ m_ bs) - {-# INLINE basicOverlaps #-} - basicOverlaps (MV_2 _ as1 bs1) (MV_2 _ as2 bs2) - = M.basicOverlaps as1 as2 - || M.basicOverlaps bs1 bs2 - {-# INLINE basicUnsafeNew #-} - basicUnsafeNew n_ - = do - as <- M.basicUnsafeNew n_ - bs <- M.basicUnsafeNew n_ - return $ MV_2 n_ as bs - {-# INLINE basicInitialize #-} - basicInitialize (MV_2 _ as bs) - = do - M.basicInitialize as - M.basicInitialize bs - {-# INLINE basicUnsafeReplicate #-} - basicUnsafeReplicate n_ (a, b) - = do - as <- M.basicUnsafeReplicate n_ a - bs <- M.basicUnsafeReplicate n_ b - return $ MV_2 n_ as bs - {-# INLINE basicUnsafeRead #-} - basicUnsafeRead (MV_2 _ as bs) i_ - = do - a <- M.basicUnsafeRead as i_ - b <- M.basicUnsafeRead bs i_ - return (a, b) - {-# INLINE basicUnsafeWrite #-} - basicUnsafeWrite (MV_2 _ as bs) i_ (a, b) - = do - M.basicUnsafeWrite as i_ a - M.basicUnsafeWrite bs i_ b - {-# INLINE basicClear #-} - basicClear (MV_2 _ as bs) - = do - M.basicClear as - M.basicClear bs - {-# INLINE basicSet #-} - basicSet (MV_2 _ as bs) (a, b) - = do - M.basicSet as a - M.basicSet bs b - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy (MV_2 _ as1 bs1) (MV_2 _ as2 bs2) - = do - M.basicUnsafeCopy as1 as2 - M.basicUnsafeCopy bs1 bs2 - {-# INLINE basicUnsafeMove #-} - basicUnsafeMove (MV_2 _ as1 bs1) (MV_2 _ as2 bs2) - = do - M.basicUnsafeMove as1 as2 - M.basicUnsafeMove bs1 bs2 - {-# INLINE basicUnsafeGrow #-} - basicUnsafeGrow (MV_2 n_ as bs) m_ - = do - as' <- M.basicUnsafeGrow as m_ - bs' <- M.basicUnsafeGrow bs m_ - return $ MV_2 (m_+n_) as' bs' -instance (Unbox a, Unbox b) => G.Vector Vector (a, b) where - {-# INLINE basicUnsafeFreeze #-} - basicUnsafeFreeze (MV_2 n_ as bs) - = do - as' <- G.basicUnsafeFreeze as - bs' <- G.basicUnsafeFreeze bs - return $ V_2 n_ as' bs' - {-# INLINE basicUnsafeThaw #-} - basicUnsafeThaw (V_2 n_ as bs) - = do - as' <- G.basicUnsafeThaw as - bs' <- G.basicUnsafeThaw bs - return $ MV_2 n_ as' bs' - {-# INLINE basicLength #-} - basicLength (V_2 n_ _ _) = n_ - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice i_ m_ (V_2 _ as bs) - = V_2 m_ (G.basicUnsafeSlice i_ m_ as) - (G.basicUnsafeSlice i_ m_ bs) - {-# INLINE basicUnsafeIndexM #-} - basicUnsafeIndexM (V_2 _ as bs) i_ - = do - a <- G.basicUnsafeIndexM as i_ - b <- G.basicUnsafeIndexM bs i_ - return (a, b) - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy (MV_2 _ as1 bs1) (V_2 _ as2 bs2) - = do - G.basicUnsafeCopy as1 as2 - G.basicUnsafeCopy bs1 bs2 - {-# INLINE elemseq #-} - elemseq _ (a, b) - = G.elemseq (undefined :: Vector a) a - . G.elemseq (undefined :: Vector b) b -#endif -#ifdef DEFINE_MUTABLE --- | /O(1)/ Zip 2 vectors -zip :: (Unbox a, Unbox b) => MVector s a -> - MVector s b -> MVector s (a, b) -{-# INLINE_FUSED zip #-} -zip as bs = MV_2 len (unsafeSlice 0 len as) (unsafeSlice 0 len bs) - where len = length as `delayed_min` length bs --- | /O(1)/ Unzip 2 vectors -unzip :: (Unbox a, Unbox b) => MVector s (a, b) -> (MVector s a, - MVector s b) -{-# INLINE unzip #-} -unzip (MV_2 _ as bs) = (as, bs) -#endif -#ifdef DEFINE_IMMUTABLE --- | /O(1)/ Zip 2 vectors -zip :: (Unbox a, Unbox b) => Vector a -> Vector b -> Vector (a, b) -{-# INLINE_FUSED zip #-} -zip as bs = V_2 len (unsafeSlice 0 len as) (unsafeSlice 0 len bs) - where len = length as `delayed_min` length bs -{-# RULES "stream/zip [Vector.Unboxed]" forall as bs . - G.stream (zip as bs) = Bundle.zipWith (,) (G.stream as) - (G.stream bs) #-} - --- | /O(1)/ Unzip 2 vectors -unzip :: (Unbox a, Unbox b) => Vector (a, b) -> (Vector a, - Vector b) -{-# INLINE unzip #-} -unzip (V_2 _ as bs) = (as, bs) -#endif -#ifdef DEFINE_INSTANCES -data instance MVector s (a, b, c) - = MV_3 {-# UNPACK #-} !Int !(MVector s a) - !(MVector s b) - !(MVector s c) -data instance Vector (a, b, c) - = V_3 {-# UNPACK #-} !Int !(Vector a) - !(Vector b) - !(Vector c) -instance (Unbox a, Unbox b, Unbox c) => Unbox (a, b, c) -instance (Unbox a, - Unbox b, - Unbox c) => M.MVector MVector (a, b, c) where - {-# INLINE basicLength #-} - basicLength (MV_3 n_ _ _ _) = n_ - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice i_ m_ (MV_3 _ as bs cs) - = MV_3 m_ (M.basicUnsafeSlice i_ m_ as) - (M.basicUnsafeSlice i_ m_ bs) - (M.basicUnsafeSlice i_ m_ cs) - {-# INLINE basicOverlaps #-} - basicOverlaps (MV_3 _ as1 bs1 cs1) (MV_3 _ as2 bs2 cs2) - = M.basicOverlaps as1 as2 - || M.basicOverlaps bs1 bs2 - || M.basicOverlaps cs1 cs2 - {-# INLINE basicUnsafeNew #-} - basicUnsafeNew n_ - = do - as <- M.basicUnsafeNew n_ - bs <- M.basicUnsafeNew n_ - cs <- M.basicUnsafeNew n_ - return $ MV_3 n_ as bs cs - {-# INLINE basicInitialize #-} - basicInitialize (MV_3 _ as bs cs) - = do - M.basicInitialize as - M.basicInitialize bs - M.basicInitialize cs - {-# INLINE basicUnsafeReplicate #-} - basicUnsafeReplicate n_ (a, b, c) - = do - as <- M.basicUnsafeReplicate n_ a - bs <- M.basicUnsafeReplicate n_ b - cs <- M.basicUnsafeReplicate n_ c - return $ MV_3 n_ as bs cs - {-# INLINE basicUnsafeRead #-} - basicUnsafeRead (MV_3 _ as bs cs) i_ - = do - a <- M.basicUnsafeRead as i_ - b <- M.basicUnsafeRead bs i_ - c <- M.basicUnsafeRead cs i_ - return (a, b, c) - {-# INLINE basicUnsafeWrite #-} - basicUnsafeWrite (MV_3 _ as bs cs) i_ (a, b, c) - = do - M.basicUnsafeWrite as i_ a - M.basicUnsafeWrite bs i_ b - M.basicUnsafeWrite cs i_ c - {-# INLINE basicClear #-} - basicClear (MV_3 _ as bs cs) - = do - M.basicClear as - M.basicClear bs - M.basicClear cs - {-# INLINE basicSet #-} - basicSet (MV_3 _ as bs cs) (a, b, c) - = do - M.basicSet as a - M.basicSet bs b - M.basicSet cs c - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy (MV_3 _ as1 bs1 cs1) (MV_3 _ as2 bs2 cs2) - = do - M.basicUnsafeCopy as1 as2 - M.basicUnsafeCopy bs1 bs2 - M.basicUnsafeCopy cs1 cs2 - {-# INLINE basicUnsafeMove #-} - basicUnsafeMove (MV_3 _ as1 bs1 cs1) (MV_3 _ as2 bs2 cs2) - = do - M.basicUnsafeMove as1 as2 - M.basicUnsafeMove bs1 bs2 - M.basicUnsafeMove cs1 cs2 - {-# INLINE basicUnsafeGrow #-} - basicUnsafeGrow (MV_3 n_ as bs cs) m_ - = do - as' <- M.basicUnsafeGrow as m_ - bs' <- M.basicUnsafeGrow bs m_ - cs' <- M.basicUnsafeGrow cs m_ - return $ MV_3 (m_+n_) as' bs' cs' -instance (Unbox a, - Unbox b, - Unbox c) => G.Vector Vector (a, b, c) where - {-# INLINE basicUnsafeFreeze #-} - basicUnsafeFreeze (MV_3 n_ as bs cs) - = do - as' <- G.basicUnsafeFreeze as - bs' <- G.basicUnsafeFreeze bs - cs' <- G.basicUnsafeFreeze cs - return $ V_3 n_ as' bs' cs' - {-# INLINE basicUnsafeThaw #-} - basicUnsafeThaw (V_3 n_ as bs cs) - = do - as' <- G.basicUnsafeThaw as - bs' <- G.basicUnsafeThaw bs - cs' <- G.basicUnsafeThaw cs - return $ MV_3 n_ as' bs' cs' - {-# INLINE basicLength #-} - basicLength (V_3 n_ _ _ _) = n_ - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice i_ m_ (V_3 _ as bs cs) - = V_3 m_ (G.basicUnsafeSlice i_ m_ as) - (G.basicUnsafeSlice i_ m_ bs) - (G.basicUnsafeSlice i_ m_ cs) - {-# INLINE basicUnsafeIndexM #-} - basicUnsafeIndexM (V_3 _ as bs cs) i_ - = do - a <- G.basicUnsafeIndexM as i_ - b <- G.basicUnsafeIndexM bs i_ - c <- G.basicUnsafeIndexM cs i_ - return (a, b, c) - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy (MV_3 _ as1 bs1 cs1) (V_3 _ as2 bs2 cs2) - = do - G.basicUnsafeCopy as1 as2 - G.basicUnsafeCopy bs1 bs2 - G.basicUnsafeCopy cs1 cs2 - {-# INLINE elemseq #-} - elemseq _ (a, b, c) - = G.elemseq (undefined :: Vector a) a - . G.elemseq (undefined :: Vector b) b - . G.elemseq (undefined :: Vector c) c -#endif -#ifdef DEFINE_MUTABLE --- | /O(1)/ Zip 3 vectors -zip3 :: (Unbox a, Unbox b, Unbox c) => MVector s a -> - MVector s b -> - MVector s c -> MVector s (a, b, c) -{-# INLINE_FUSED zip3 #-} -zip3 as bs cs = MV_3 len (unsafeSlice 0 len as) - (unsafeSlice 0 len bs) - (unsafeSlice 0 len cs) - where - len = length as `delayed_min` length bs `delayed_min` length cs --- | /O(1)/ Unzip 3 vectors -unzip3 :: (Unbox a, - Unbox b, - Unbox c) => MVector s (a, b, c) -> (MVector s a, - MVector s b, - MVector s c) -{-# INLINE unzip3 #-} -unzip3 (MV_3 _ as bs cs) = (as, bs, cs) -#endif -#ifdef DEFINE_IMMUTABLE --- | /O(1)/ Zip 3 vectors -zip3 :: (Unbox a, Unbox b, Unbox c) => Vector a -> - Vector b -> - Vector c -> Vector (a, b, c) -{-# INLINE_FUSED zip3 #-} -zip3 as bs cs = V_3 len (unsafeSlice 0 len as) - (unsafeSlice 0 len bs) - (unsafeSlice 0 len cs) - where - len = length as `delayed_min` length bs `delayed_min` length cs -{-# RULES "stream/zip3 [Vector.Unboxed]" forall as bs cs . - G.stream (zip3 as bs cs) = Bundle.zipWith3 (, ,) (G.stream as) - (G.stream bs) - (G.stream cs) #-} - --- | /O(1)/ Unzip 3 vectors -unzip3 :: (Unbox a, - Unbox b, - Unbox c) => Vector (a, b, c) -> (Vector a, Vector b, Vector c) -{-# INLINE unzip3 #-} -unzip3 (V_3 _ as bs cs) = (as, bs, cs) -#endif -#ifdef DEFINE_INSTANCES -data instance MVector s (a, b, c, d) - = MV_4 {-# UNPACK #-} !Int !(MVector s a) - !(MVector s b) - !(MVector s c) - !(MVector s d) -data instance Vector (a, b, c, d) - = V_4 {-# UNPACK #-} !Int !(Vector a) - !(Vector b) - !(Vector c) - !(Vector d) -instance (Unbox a, Unbox b, Unbox c, Unbox d) => Unbox (a, b, c, d) -instance (Unbox a, - Unbox b, - Unbox c, - Unbox d) => M.MVector MVector (a, b, c, d) where - {-# INLINE basicLength #-} - basicLength (MV_4 n_ _ _ _ _) = n_ - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice i_ m_ (MV_4 _ as bs cs ds) - = MV_4 m_ (M.basicUnsafeSlice i_ m_ as) - (M.basicUnsafeSlice i_ m_ bs) - (M.basicUnsafeSlice i_ m_ cs) - (M.basicUnsafeSlice i_ m_ ds) - {-# INLINE basicOverlaps #-} - basicOverlaps (MV_4 _ as1 bs1 cs1 ds1) (MV_4 _ as2 bs2 cs2 ds2) - = M.basicOverlaps as1 as2 - || M.basicOverlaps bs1 bs2 - || M.basicOverlaps cs1 cs2 - || M.basicOverlaps ds1 ds2 - {-# INLINE basicUnsafeNew #-} - basicUnsafeNew n_ - = do - as <- M.basicUnsafeNew n_ - bs <- M.basicUnsafeNew n_ - cs <- M.basicUnsafeNew n_ - ds <- M.basicUnsafeNew n_ - return $ MV_4 n_ as bs cs ds - {-# INLINE basicInitialize #-} - basicInitialize (MV_4 _ as bs cs ds) - = do - M.basicInitialize as - M.basicInitialize bs - M.basicInitialize cs - M.basicInitialize ds - {-# INLINE basicUnsafeReplicate #-} - basicUnsafeReplicate n_ (a, b, c, d) - = do - as <- M.basicUnsafeReplicate n_ a - bs <- M.basicUnsafeReplicate n_ b - cs <- M.basicUnsafeReplicate n_ c - ds <- M.basicUnsafeReplicate n_ d - return $ MV_4 n_ as bs cs ds - {-# INLINE basicUnsafeRead #-} - basicUnsafeRead (MV_4 _ as bs cs ds) i_ - = do - a <- M.basicUnsafeRead as i_ - b <- M.basicUnsafeRead bs i_ - c <- M.basicUnsafeRead cs i_ - d <- M.basicUnsafeRead ds i_ - return (a, b, c, d) - {-# INLINE basicUnsafeWrite #-} - basicUnsafeWrite (MV_4 _ as bs cs ds) i_ (a, b, c, d) - = do - M.basicUnsafeWrite as i_ a - M.basicUnsafeWrite bs i_ b - M.basicUnsafeWrite cs i_ c - M.basicUnsafeWrite ds i_ d - {-# INLINE basicClear #-} - basicClear (MV_4 _ as bs cs ds) - = do - M.basicClear as - M.basicClear bs - M.basicClear cs - M.basicClear ds - {-# INLINE basicSet #-} - basicSet (MV_4 _ as bs cs ds) (a, b, c, d) - = do - M.basicSet as a - M.basicSet bs b - M.basicSet cs c - M.basicSet ds d - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy (MV_4 _ as1 bs1 cs1 ds1) (MV_4 _ as2 - bs2 - cs2 - ds2) - = do - M.basicUnsafeCopy as1 as2 - M.basicUnsafeCopy bs1 bs2 - M.basicUnsafeCopy cs1 cs2 - M.basicUnsafeCopy ds1 ds2 - {-# INLINE basicUnsafeMove #-} - basicUnsafeMove (MV_4 _ as1 bs1 cs1 ds1) (MV_4 _ as2 - bs2 - cs2 - ds2) - = do - M.basicUnsafeMove as1 as2 - M.basicUnsafeMove bs1 bs2 - M.basicUnsafeMove cs1 cs2 - M.basicUnsafeMove ds1 ds2 - {-# INLINE basicUnsafeGrow #-} - basicUnsafeGrow (MV_4 n_ as bs cs ds) m_ - = do - as' <- M.basicUnsafeGrow as m_ - bs' <- M.basicUnsafeGrow bs m_ - cs' <- M.basicUnsafeGrow cs m_ - ds' <- M.basicUnsafeGrow ds m_ - return $ MV_4 (m_+n_) as' bs' cs' ds' -instance (Unbox a, - Unbox b, - Unbox c, - Unbox d) => G.Vector Vector (a, b, c, d) where - {-# INLINE basicUnsafeFreeze #-} - basicUnsafeFreeze (MV_4 n_ as bs cs ds) - = do - as' <- G.basicUnsafeFreeze as - bs' <- G.basicUnsafeFreeze bs - cs' <- G.basicUnsafeFreeze cs - ds' <- G.basicUnsafeFreeze ds - return $ V_4 n_ as' bs' cs' ds' - {-# INLINE basicUnsafeThaw #-} - basicUnsafeThaw (V_4 n_ as bs cs ds) - = do - as' <- G.basicUnsafeThaw as - bs' <- G.basicUnsafeThaw bs - cs' <- G.basicUnsafeThaw cs - ds' <- G.basicUnsafeThaw ds - return $ MV_4 n_ as' bs' cs' ds' - {-# INLINE basicLength #-} - basicLength (V_4 n_ _ _ _ _) = n_ - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice i_ m_ (V_4 _ as bs cs ds) - = V_4 m_ (G.basicUnsafeSlice i_ m_ as) - (G.basicUnsafeSlice i_ m_ bs) - (G.basicUnsafeSlice i_ m_ cs) - (G.basicUnsafeSlice i_ m_ ds) - {-# INLINE basicUnsafeIndexM #-} - basicUnsafeIndexM (V_4 _ as bs cs ds) i_ - = do - a <- G.basicUnsafeIndexM as i_ - b <- G.basicUnsafeIndexM bs i_ - c <- G.basicUnsafeIndexM cs i_ - d <- G.basicUnsafeIndexM ds i_ - return (a, b, c, d) - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy (MV_4 _ as1 bs1 cs1 ds1) (V_4 _ as2 - bs2 - cs2 - ds2) - = do - G.basicUnsafeCopy as1 as2 - G.basicUnsafeCopy bs1 bs2 - G.basicUnsafeCopy cs1 cs2 - G.basicUnsafeCopy ds1 ds2 - {-# INLINE elemseq #-} - elemseq _ (a, b, c, d) - = G.elemseq (undefined :: Vector a) a - . G.elemseq (undefined :: Vector b) b - . G.elemseq (undefined :: Vector c) c - . G.elemseq (undefined :: Vector d) d -#endif -#ifdef DEFINE_MUTABLE --- | /O(1)/ Zip 4 vectors -zip4 :: (Unbox a, Unbox b, Unbox c, Unbox d) => MVector s a -> - MVector s b -> - MVector s c -> - MVector s d -> MVector s (a, b, c, d) -{-# INLINE_FUSED zip4 #-} -zip4 as bs cs ds = MV_4 len (unsafeSlice 0 len as) - (unsafeSlice 0 len bs) - (unsafeSlice 0 len cs) - (unsafeSlice 0 len ds) - where - len = length as `delayed_min` - length bs `delayed_min` - length cs `delayed_min` - length ds --- | /O(1)/ Unzip 4 vectors -unzip4 :: (Unbox a, - Unbox b, - Unbox c, - Unbox d) => MVector s (a, b, c, d) -> (MVector s a, - MVector s b, - MVector s c, - MVector s d) -{-# INLINE unzip4 #-} -unzip4 (MV_4 _ as bs cs ds) = (as, bs, cs, ds) -#endif -#ifdef DEFINE_IMMUTABLE --- | /O(1)/ Zip 4 vectors -zip4 :: (Unbox a, Unbox b, Unbox c, Unbox d) => Vector a -> - Vector b -> - Vector c -> - Vector d -> Vector (a, b, c, d) -{-# INLINE_FUSED zip4 #-} -zip4 as bs cs ds = V_4 len (unsafeSlice 0 len as) - (unsafeSlice 0 len bs) - (unsafeSlice 0 len cs) - (unsafeSlice 0 len ds) - where - len = length as `delayed_min` - length bs `delayed_min` - length cs `delayed_min` - length ds -{-# RULES "stream/zip4 [Vector.Unboxed]" forall as bs cs ds . - G.stream (zip4 as bs cs ds) = Bundle.zipWith4 (, , ,) (G.stream as) - (G.stream bs) - (G.stream cs) - (G.stream ds) #-} - --- | /O(1)/ Unzip 4 vectors -unzip4 :: (Unbox a, - Unbox b, - Unbox c, - Unbox d) => Vector (a, b, c, d) -> (Vector a, - Vector b, - Vector c, - Vector d) -{-# INLINE unzip4 #-} -unzip4 (V_4 _ as bs cs ds) = (as, bs, cs, ds) -#endif -#ifdef DEFINE_INSTANCES -data instance MVector s (a, b, c, d, e) - = MV_5 {-# UNPACK #-} !Int !(MVector s a) - !(MVector s b) - !(MVector s c) - !(MVector s d) - !(MVector s e) -data instance Vector (a, b, c, d, e) - = V_5 {-# UNPACK #-} !Int !(Vector a) - !(Vector b) - !(Vector c) - !(Vector d) - !(Vector e) -instance (Unbox a, - Unbox b, - Unbox c, - Unbox d, - Unbox e) => Unbox (a, b, c, d, e) -instance (Unbox a, - Unbox b, - Unbox c, - Unbox d, - Unbox e) => M.MVector MVector (a, b, c, d, e) where - {-# INLINE basicLength #-} - basicLength (MV_5 n_ _ _ _ _ _) = n_ - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice i_ m_ (MV_5 _ as bs cs ds es) - = MV_5 m_ (M.basicUnsafeSlice i_ m_ as) - (M.basicUnsafeSlice i_ m_ bs) - (M.basicUnsafeSlice i_ m_ cs) - (M.basicUnsafeSlice i_ m_ ds) - (M.basicUnsafeSlice i_ m_ es) - {-# INLINE basicOverlaps #-} - basicOverlaps (MV_5 _ as1 bs1 cs1 ds1 es1) (MV_5 _ as2 - bs2 - cs2 - ds2 - es2) - = M.basicOverlaps as1 as2 - || M.basicOverlaps bs1 bs2 - || M.basicOverlaps cs1 cs2 - || M.basicOverlaps ds1 ds2 - || M.basicOverlaps es1 es2 - {-# INLINE basicUnsafeNew #-} - basicUnsafeNew n_ - = do - as <- M.basicUnsafeNew n_ - bs <- M.basicUnsafeNew n_ - cs <- M.basicUnsafeNew n_ - ds <- M.basicUnsafeNew n_ - es <- M.basicUnsafeNew n_ - return $ MV_5 n_ as bs cs ds es - {-# INLINE basicInitialize #-} - basicInitialize (MV_5 _ as bs cs ds es) - = do - M.basicInitialize as - M.basicInitialize bs - M.basicInitialize cs - M.basicInitialize ds - M.basicInitialize es - {-# INLINE basicUnsafeReplicate #-} - basicUnsafeReplicate n_ (a, b, c, d, e) - = do - as <- M.basicUnsafeReplicate n_ a - bs <- M.basicUnsafeReplicate n_ b - cs <- M.basicUnsafeReplicate n_ c - ds <- M.basicUnsafeReplicate n_ d - es <- M.basicUnsafeReplicate n_ e - return $ MV_5 n_ as bs cs ds es - {-# INLINE basicUnsafeRead #-} - basicUnsafeRead (MV_5 _ as bs cs ds es) i_ - = do - a <- M.basicUnsafeRead as i_ - b <- M.basicUnsafeRead bs i_ - c <- M.basicUnsafeRead cs i_ - d <- M.basicUnsafeRead ds i_ - e <- M.basicUnsafeRead es i_ - return (a, b, c, d, e) - {-# INLINE basicUnsafeWrite #-} - basicUnsafeWrite (MV_5 _ as bs cs ds es) i_ (a, b, c, d, e) - = do - M.basicUnsafeWrite as i_ a - M.basicUnsafeWrite bs i_ b - M.basicUnsafeWrite cs i_ c - M.basicUnsafeWrite ds i_ d - M.basicUnsafeWrite es i_ e - {-# INLINE basicClear #-} - basicClear (MV_5 _ as bs cs ds es) - = do - M.basicClear as - M.basicClear bs - M.basicClear cs - M.basicClear ds - M.basicClear es - {-# INLINE basicSet #-} - basicSet (MV_5 _ as bs cs ds es) (a, b, c, d, e) - = do - M.basicSet as a - M.basicSet bs b - M.basicSet cs c - M.basicSet ds d - M.basicSet es e - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy (MV_5 _ as1 bs1 cs1 ds1 es1) (MV_5 _ as2 - bs2 - cs2 - ds2 - es2) - = do - M.basicUnsafeCopy as1 as2 - M.basicUnsafeCopy bs1 bs2 - M.basicUnsafeCopy cs1 cs2 - M.basicUnsafeCopy ds1 ds2 - M.basicUnsafeCopy es1 es2 - {-# INLINE basicUnsafeMove #-} - basicUnsafeMove (MV_5 _ as1 bs1 cs1 ds1 es1) (MV_5 _ as2 - bs2 - cs2 - ds2 - es2) - = do - M.basicUnsafeMove as1 as2 - M.basicUnsafeMove bs1 bs2 - M.basicUnsafeMove cs1 cs2 - M.basicUnsafeMove ds1 ds2 - M.basicUnsafeMove es1 es2 - {-# INLINE basicUnsafeGrow #-} - basicUnsafeGrow (MV_5 n_ as bs cs ds es) m_ - = do - as' <- M.basicUnsafeGrow as m_ - bs' <- M.basicUnsafeGrow bs m_ - cs' <- M.basicUnsafeGrow cs m_ - ds' <- M.basicUnsafeGrow ds m_ - es' <- M.basicUnsafeGrow es m_ - return $ MV_5 (m_+n_) as' bs' cs' ds' es' -instance (Unbox a, - Unbox b, - Unbox c, - Unbox d, - Unbox e) => G.Vector Vector (a, b, c, d, e) where - {-# INLINE basicUnsafeFreeze #-} - basicUnsafeFreeze (MV_5 n_ as bs cs ds es) - = do - as' <- G.basicUnsafeFreeze as - bs' <- G.basicUnsafeFreeze bs - cs' <- G.basicUnsafeFreeze cs - ds' <- G.basicUnsafeFreeze ds - es' <- G.basicUnsafeFreeze es - return $ V_5 n_ as' bs' cs' ds' es' - {-# INLINE basicUnsafeThaw #-} - basicUnsafeThaw (V_5 n_ as bs cs ds es) - = do - as' <- G.basicUnsafeThaw as - bs' <- G.basicUnsafeThaw bs - cs' <- G.basicUnsafeThaw cs - ds' <- G.basicUnsafeThaw ds - es' <- G.basicUnsafeThaw es - return $ MV_5 n_ as' bs' cs' ds' es' - {-# INLINE basicLength #-} - basicLength (V_5 n_ _ _ _ _ _) = n_ - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice i_ m_ (V_5 _ as bs cs ds es) - = V_5 m_ (G.basicUnsafeSlice i_ m_ as) - (G.basicUnsafeSlice i_ m_ bs) - (G.basicUnsafeSlice i_ m_ cs) - (G.basicUnsafeSlice i_ m_ ds) - (G.basicUnsafeSlice i_ m_ es) - {-# INLINE basicUnsafeIndexM #-} - basicUnsafeIndexM (V_5 _ as bs cs ds es) i_ - = do - a <- G.basicUnsafeIndexM as i_ - b <- G.basicUnsafeIndexM bs i_ - c <- G.basicUnsafeIndexM cs i_ - d <- G.basicUnsafeIndexM ds i_ - e <- G.basicUnsafeIndexM es i_ - return (a, b, c, d, e) - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy (MV_5 _ as1 bs1 cs1 ds1 es1) (V_5 _ as2 - bs2 - cs2 - ds2 - es2) - = do - G.basicUnsafeCopy as1 as2 - G.basicUnsafeCopy bs1 bs2 - G.basicUnsafeCopy cs1 cs2 - G.basicUnsafeCopy ds1 ds2 - G.basicUnsafeCopy es1 es2 - {-# INLINE elemseq #-} - elemseq _ (a, b, c, d, e) - = G.elemseq (undefined :: Vector a) a - . G.elemseq (undefined :: Vector b) b - . G.elemseq (undefined :: Vector c) c - . G.elemseq (undefined :: Vector d) d - . G.elemseq (undefined :: Vector e) e -#endif -#ifdef DEFINE_MUTABLE --- | /O(1)/ Zip 5 vectors -zip5 :: (Unbox a, - Unbox b, - Unbox c, - Unbox d, - Unbox e) => MVector s a -> - MVector s b -> - MVector s c -> - MVector s d -> - MVector s e -> MVector s (a, b, c, d, e) -{-# INLINE_FUSED zip5 #-} -zip5 as bs cs ds es = MV_5 len (unsafeSlice 0 len as) - (unsafeSlice 0 len bs) - (unsafeSlice 0 len cs) - (unsafeSlice 0 len ds) - (unsafeSlice 0 len es) - where - len = length as `delayed_min` - length bs `delayed_min` - length cs `delayed_min` - length ds `delayed_min` - length es --- | /O(1)/ Unzip 5 vectors -unzip5 :: (Unbox a, - Unbox b, - Unbox c, - Unbox d, - Unbox e) => MVector s (a, b, c, d, e) -> (MVector s a, - MVector s b, - MVector s c, - MVector s d, - MVector s e) -{-# INLINE unzip5 #-} -unzip5 (MV_5 _ as bs cs ds es) = (as, bs, cs, ds, es) -#endif -#ifdef DEFINE_IMMUTABLE --- | /O(1)/ Zip 5 vectors -zip5 :: (Unbox a, - Unbox b, - Unbox c, - Unbox d, - Unbox e) => Vector a -> - Vector b -> - Vector c -> - Vector d -> - Vector e -> Vector (a, b, c, d, e) -{-# INLINE_FUSED zip5 #-} -zip5 as bs cs ds es = V_5 len (unsafeSlice 0 len as) - (unsafeSlice 0 len bs) - (unsafeSlice 0 len cs) - (unsafeSlice 0 len ds) - (unsafeSlice 0 len es) - where - len = length as `delayed_min` - length bs `delayed_min` - length cs `delayed_min` - length ds `delayed_min` - length es -{-# RULES "stream/zip5 [Vector.Unboxed]" forall as bs cs ds es . - G.stream (zip5 as - bs - cs - ds - es) = Bundle.zipWith5 (, , , ,) (G.stream as) - (G.stream bs) - (G.stream cs) - (G.stream ds) - (G.stream es) #-} - --- | /O(1)/ Unzip 5 vectors -unzip5 :: (Unbox a, - Unbox b, - Unbox c, - Unbox d, - Unbox e) => Vector (a, b, c, d, e) -> (Vector a, - Vector b, - Vector c, - Vector d, - Vector e) -{-# INLINE unzip5 #-} -unzip5 (V_5 _ as bs cs ds es) = (as, bs, cs, ds, es) -#endif -#ifdef DEFINE_INSTANCES -data instance MVector s (a, b, c, d, e, f) - = MV_6 {-# UNPACK #-} !Int !(MVector s a) - !(MVector s b) - !(MVector s c) - !(MVector s d) - !(MVector s e) - !(MVector s f) -data instance Vector (a, b, c, d, e, f) - = V_6 {-# UNPACK #-} !Int !(Vector a) - !(Vector b) - !(Vector c) - !(Vector d) - !(Vector e) - !(Vector f) -instance (Unbox a, - Unbox b, - Unbox c, - Unbox d, - Unbox e, - Unbox f) => Unbox (a, b, c, d, e, f) -instance (Unbox a, - Unbox b, - Unbox c, - Unbox d, - Unbox e, - Unbox f) => M.MVector MVector (a, b, c, d, e, f) where - {-# INLINE basicLength #-} - basicLength (MV_6 n_ _ _ _ _ _ _) = n_ - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice i_ m_ (MV_6 _ as bs cs ds es fs) - = MV_6 m_ (M.basicUnsafeSlice i_ m_ as) - (M.basicUnsafeSlice i_ m_ bs) - (M.basicUnsafeSlice i_ m_ cs) - (M.basicUnsafeSlice i_ m_ ds) - (M.basicUnsafeSlice i_ m_ es) - (M.basicUnsafeSlice i_ m_ fs) - {-# INLINE basicOverlaps #-} - basicOverlaps (MV_6 _ as1 bs1 cs1 ds1 es1 fs1) (MV_6 _ as2 - bs2 - cs2 - ds2 - es2 - fs2) - = M.basicOverlaps as1 as2 - || M.basicOverlaps bs1 bs2 - || M.basicOverlaps cs1 cs2 - || M.basicOverlaps ds1 ds2 - || M.basicOverlaps es1 es2 - || M.basicOverlaps fs1 fs2 - {-# INLINE basicUnsafeNew #-} - basicUnsafeNew n_ - = do - as <- M.basicUnsafeNew n_ - bs <- M.basicUnsafeNew n_ - cs <- M.basicUnsafeNew n_ - ds <- M.basicUnsafeNew n_ - es <- M.basicUnsafeNew n_ - fs <- M.basicUnsafeNew n_ - return $ MV_6 n_ as bs cs ds es fs - {-# INLINE basicInitialize #-} - basicInitialize (MV_6 _ as bs cs ds es fs) - = do - M.basicInitialize as - M.basicInitialize bs - M.basicInitialize cs - M.basicInitialize ds - M.basicInitialize es - M.basicInitialize fs - {-# INLINE basicUnsafeReplicate #-} - basicUnsafeReplicate n_ (a, b, c, d, e, f) - = do - as <- M.basicUnsafeReplicate n_ a - bs <- M.basicUnsafeReplicate n_ b - cs <- M.basicUnsafeReplicate n_ c - ds <- M.basicUnsafeReplicate n_ d - es <- M.basicUnsafeReplicate n_ e - fs <- M.basicUnsafeReplicate n_ f - return $ MV_6 n_ as bs cs ds es fs - {-# INLINE basicUnsafeRead #-} - basicUnsafeRead (MV_6 _ as bs cs ds es fs) i_ - = do - a <- M.basicUnsafeRead as i_ - b <- M.basicUnsafeRead bs i_ - c <- M.basicUnsafeRead cs i_ - d <- M.basicUnsafeRead ds i_ - e <- M.basicUnsafeRead es i_ - f <- M.basicUnsafeRead fs i_ - return (a, b, c, d, e, f) - {-# INLINE basicUnsafeWrite #-} - basicUnsafeWrite (MV_6 _ as bs cs ds es fs) i_ (a, b, c, d, e, f) - = do - M.basicUnsafeWrite as i_ a - M.basicUnsafeWrite bs i_ b - M.basicUnsafeWrite cs i_ c - M.basicUnsafeWrite ds i_ d - M.basicUnsafeWrite es i_ e - M.basicUnsafeWrite fs i_ f - {-# INLINE basicClear #-} - basicClear (MV_6 _ as bs cs ds es fs) - = do - M.basicClear as - M.basicClear bs - M.basicClear cs - M.basicClear ds - M.basicClear es - M.basicClear fs - {-# INLINE basicSet #-} - basicSet (MV_6 _ as bs cs ds es fs) (a, b, c, d, e, f) - = do - M.basicSet as a - M.basicSet bs b - M.basicSet cs c - M.basicSet ds d - M.basicSet es e - M.basicSet fs f - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy (MV_6 _ as1 bs1 cs1 ds1 es1 fs1) (MV_6 _ as2 - bs2 - cs2 - ds2 - es2 - fs2) - = do - M.basicUnsafeCopy as1 as2 - M.basicUnsafeCopy bs1 bs2 - M.basicUnsafeCopy cs1 cs2 - M.basicUnsafeCopy ds1 ds2 - M.basicUnsafeCopy es1 es2 - M.basicUnsafeCopy fs1 fs2 - {-# INLINE basicUnsafeMove #-} - basicUnsafeMove (MV_6 _ as1 bs1 cs1 ds1 es1 fs1) (MV_6 _ as2 - bs2 - cs2 - ds2 - es2 - fs2) - = do - M.basicUnsafeMove as1 as2 - M.basicUnsafeMove bs1 bs2 - M.basicUnsafeMove cs1 cs2 - M.basicUnsafeMove ds1 ds2 - M.basicUnsafeMove es1 es2 - M.basicUnsafeMove fs1 fs2 - {-# INLINE basicUnsafeGrow #-} - basicUnsafeGrow (MV_6 n_ as bs cs ds es fs) m_ - = do - as' <- M.basicUnsafeGrow as m_ - bs' <- M.basicUnsafeGrow bs m_ - cs' <- M.basicUnsafeGrow cs m_ - ds' <- M.basicUnsafeGrow ds m_ - es' <- M.basicUnsafeGrow es m_ - fs' <- M.basicUnsafeGrow fs m_ - return $ MV_6 (m_+n_) as' bs' cs' ds' es' fs' -instance (Unbox a, - Unbox b, - Unbox c, - Unbox d, - Unbox e, - Unbox f) => G.Vector Vector (a, b, c, d, e, f) where - {-# INLINE basicUnsafeFreeze #-} - basicUnsafeFreeze (MV_6 n_ as bs cs ds es fs) - = do - as' <- G.basicUnsafeFreeze as - bs' <- G.basicUnsafeFreeze bs - cs' <- G.basicUnsafeFreeze cs - ds' <- G.basicUnsafeFreeze ds - es' <- G.basicUnsafeFreeze es - fs' <- G.basicUnsafeFreeze fs - return $ V_6 n_ as' bs' cs' ds' es' fs' - {-# INLINE basicUnsafeThaw #-} - basicUnsafeThaw (V_6 n_ as bs cs ds es fs) - = do - as' <- G.basicUnsafeThaw as - bs' <- G.basicUnsafeThaw bs - cs' <- G.basicUnsafeThaw cs - ds' <- G.basicUnsafeThaw ds - es' <- G.basicUnsafeThaw es - fs' <- G.basicUnsafeThaw fs - return $ MV_6 n_ as' bs' cs' ds' es' fs' - {-# INLINE basicLength #-} - basicLength (V_6 n_ _ _ _ _ _ _) = n_ - {-# INLINE basicUnsafeSlice #-} - basicUnsafeSlice i_ m_ (V_6 _ as bs cs ds es fs) - = V_6 m_ (G.basicUnsafeSlice i_ m_ as) - (G.basicUnsafeSlice i_ m_ bs) - (G.basicUnsafeSlice i_ m_ cs) - (G.basicUnsafeSlice i_ m_ ds) - (G.basicUnsafeSlice i_ m_ es) - (G.basicUnsafeSlice i_ m_ fs) - {-# INLINE basicUnsafeIndexM #-} - basicUnsafeIndexM (V_6 _ as bs cs ds es fs) i_ - = do - a <- G.basicUnsafeIndexM as i_ - b <- G.basicUnsafeIndexM bs i_ - c <- G.basicUnsafeIndexM cs i_ - d <- G.basicUnsafeIndexM ds i_ - e <- G.basicUnsafeIndexM es i_ - f <- G.basicUnsafeIndexM fs i_ - return (a, b, c, d, e, f) - {-# INLINE basicUnsafeCopy #-} - basicUnsafeCopy (MV_6 _ as1 bs1 cs1 ds1 es1 fs1) (V_6 _ as2 - bs2 - cs2 - ds2 - es2 - fs2) - = do - G.basicUnsafeCopy as1 as2 - G.basicUnsafeCopy bs1 bs2 - G.basicUnsafeCopy cs1 cs2 - G.basicUnsafeCopy ds1 ds2 - G.basicUnsafeCopy es1 es2 - G.basicUnsafeCopy fs1 fs2 - {-# INLINE elemseq #-} - elemseq _ (a, b, c, d, e, f) - = G.elemseq (undefined :: Vector a) a - . G.elemseq (undefined :: Vector b) b - . G.elemseq (undefined :: Vector c) c - . G.elemseq (undefined :: Vector d) d - . G.elemseq (undefined :: Vector e) e - . G.elemseq (undefined :: Vector f) f -#endif -#ifdef DEFINE_MUTABLE --- | /O(1)/ Zip 6 vectors -zip6 :: (Unbox a, - Unbox b, - Unbox c, - Unbox d, - Unbox e, - Unbox f) => MVector s a -> - MVector s b -> - MVector s c -> - MVector s d -> - MVector s e -> - MVector s f -> MVector s (a, b, c, d, e, f) -{-# INLINE_FUSED zip6 #-} -zip6 as bs cs ds es fs = MV_6 len (unsafeSlice 0 len as) - (unsafeSlice 0 len bs) - (unsafeSlice 0 len cs) - (unsafeSlice 0 len ds) - (unsafeSlice 0 len es) - (unsafeSlice 0 len fs) - where - len = length as `delayed_min` - length bs `delayed_min` - length cs `delayed_min` - length ds `delayed_min` - length es `delayed_min` - length fs --- | /O(1)/ Unzip 6 vectors -unzip6 :: (Unbox a, - Unbox b, - Unbox c, - Unbox d, - Unbox e, - Unbox f) => MVector s (a, b, c, d, e, f) -> (MVector s a, - MVector s b, - MVector s c, - MVector s d, - MVector s e, - MVector s f) -{-# INLINE unzip6 #-} -unzip6 (MV_6 _ as bs cs ds es fs) = (as, bs, cs, ds, es, fs) -#endif -#ifdef DEFINE_IMMUTABLE --- | /O(1)/ Zip 6 vectors -zip6 :: (Unbox a, - Unbox b, - Unbox c, - Unbox d, - Unbox e, - Unbox f) => Vector a -> - Vector b -> - Vector c -> - Vector d -> - Vector e -> - Vector f -> Vector (a, b, c, d, e, f) -{-# INLINE_FUSED zip6 #-} -zip6 as bs cs ds es fs = V_6 len (unsafeSlice 0 len as) - (unsafeSlice 0 len bs) - (unsafeSlice 0 len cs) - (unsafeSlice 0 len ds) - (unsafeSlice 0 len es) - (unsafeSlice 0 len fs) - where - len = length as `delayed_min` - length bs `delayed_min` - length cs `delayed_min` - length ds `delayed_min` - length es `delayed_min` - length fs -{-# RULES "stream/zip6 [Vector.Unboxed]" forall as bs cs ds es fs . - G.stream (zip6 as - bs - cs - ds - es - fs) = Bundle.zipWith6 (, , , , ,) (G.stream as) - (G.stream bs) - (G.stream cs) - (G.stream ds) - (G.stream es) - (G.stream fs) #-} - --- | /O(1)/ Unzip 6 vectors -unzip6 :: (Unbox a, - Unbox b, - Unbox c, - Unbox d, - Unbox e, - Unbox f) => Vector (a, b, c, d, e, f) -> (Vector a, - Vector b, - Vector c, - Vector d, - Vector e, - Vector f) -{-# INLINE unzip6 #-} -unzip6 (V_6 _ as bs cs ds es fs) = (as, bs, cs, ds, es, fs) -#endif diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/Boilerplater.hs b/third_party/bazel/rules_haskell/examples/vector/tests/Boilerplater.hs deleted file mode 100644 index 5506209ebc01..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/tests/Boilerplater.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Boilerplater where - -import Test.Framework.Providers.QuickCheck2 - -import Language.Haskell.TH - - -testProperties :: [Name] -> Q Exp -testProperties nms = fmap ListE $ sequence [[| testProperty $(stringE prop_name) $(varE nm) |] - | nm <- nms - , Just prop_name <- [stripPrefix_maybe "prop_" (nameBase nm)]] - --- This nice clean solution doesn't quite work since I need to use lexically-scoped type --- variables, which aren't supported by Template Haskell. Argh! --- testProperties :: Q [Dec] -> Q Exp --- testProperties mdecs = do --- decs <- mdecs --- property_exprs <- sequence [[| testProperty "$prop_name" $(return $ VarE nm) |] --- | FunD nm _clauses <- decs --- , Just prop_name <- [stripPrefix_maybe "prop_" (nameBase nm)]] --- return $ LetE decs (ListE property_exprs) - -stripPrefix_maybe :: String -> String -> Maybe String -stripPrefix_maybe prefix what - | what_start == prefix = Just what_end - | otherwise = Nothing - where (what_start, what_end) = splitAt (length prefix) what diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/LICENSE b/third_party/bazel/rules_haskell/examples/vector/tests/LICENSE deleted file mode 100644 index 43c0cee637be..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/tests/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright (c) 2009, Max Bolingbroke and Roman Leshchinskiy -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -- Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. - -- Redistributions in binary form must reproduce the above copyright notice, -this list of conditions and the following disclaimer in the documentation -and/or other materials provided with the distribution. - -- Neither name of the University nor the names of its contributors may be -used to endorse or promote products derived from this software without -specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF -GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, -INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH -DAMAGE. - diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/Main.hs b/third_party/bazel/rules_haskell/examples/vector/tests/Main.hs deleted file mode 100644 index 6642888323fd..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/tests/Main.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Main (main) where - -import qualified Tests.Vector -import qualified Tests.Vector.UnitTests -import qualified Tests.Bundle -import qualified Tests.Move - -import Test.Framework (defaultMain) - -main :: IO () -main = defaultMain $ Tests.Bundle.tests - ++ Tests.Vector.tests - ++ Tests.Vector.UnitTests.tests - ++ Tests.Move.tests - diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/Setup.hs b/third_party/bazel/rules_haskell/examples/vector/tests/Setup.hs deleted file mode 100644 index 200a2e51d0b4..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/tests/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Bundle.hs b/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Bundle.hs deleted file mode 100644 index 09368a199971..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Bundle.hs +++ /dev/null @@ -1,163 +0,0 @@ -module Tests.Bundle ( tests ) where - -import Boilerplater -import Utilities - -import qualified Data.Vector.Fusion.Bundle as S - -import Test.QuickCheck - -import Test.Framework -import Test.Framework.Providers.QuickCheck2 - -import Text.Show.Functions () -import Data.List (foldl', foldl1', unfoldr, find, findIndex) -import System.Random (Random) - -#define COMMON_CONTEXT(a) \ - VANILLA_CONTEXT(a) - -#define VANILLA_CONTEXT(a) \ - Eq a, Show a, Arbitrary a, CoArbitrary a, TestData a, Model a ~ a, EqTest a ~ Property - -testSanity :: forall v a. (COMMON_CONTEXT(a)) => S.Bundle v a -> [Test] -testSanity _ = [ - testProperty "fromList.toList == id" prop_fromList_toList, - testProperty "toList.fromList == id" prop_toList_fromList - ] - where - prop_fromList_toList :: P (S.Bundle v a -> S.Bundle v a) - = (S.fromList . S.toList) `eq` id - prop_toList_fromList :: P ([a] -> [a]) - = (S.toList . (S.fromList :: [a] -> S.Bundle v a)) `eq` id - -testPolymorphicFunctions :: forall v a. (COMMON_CONTEXT(a)) => S.Bundle v a -> [Test] -testPolymorphicFunctions _ = $(testProperties [ - 'prop_eq, - - 'prop_length, 'prop_null, - - 'prop_empty, 'prop_singleton, 'prop_replicate, - 'prop_cons, 'prop_snoc, 'prop_append, - - 'prop_head, 'prop_last, 'prop_index, - - 'prop_extract, 'prop_init, 'prop_tail, 'prop_take, 'prop_drop, - - 'prop_map, 'prop_zipWith, 'prop_zipWith3, - 'prop_filter, 'prop_takeWhile, 'prop_dropWhile, - - 'prop_elem, 'prop_notElem, - 'prop_find, 'prop_findIndex, - - 'prop_foldl, 'prop_foldl1, 'prop_foldl', 'prop_foldl1', - 'prop_foldr, 'prop_foldr1, - - 'prop_prescanl, 'prop_prescanl', - 'prop_postscanl, 'prop_postscanl', - 'prop_scanl, 'prop_scanl', 'prop_scanl1, 'prop_scanl1', - - 'prop_concatMap, - 'prop_unfoldr - ]) - where - -- Prelude - prop_eq :: P (S.Bundle v a -> S.Bundle v a -> Bool) = (==) `eq` (==) - - prop_length :: P (S.Bundle v a -> Int) = S.length `eq` length - prop_null :: P (S.Bundle v a -> Bool) = S.null `eq` null - prop_empty :: P (S.Bundle v a) = S.empty `eq` [] - prop_singleton :: P (a -> S.Bundle v a) = S.singleton `eq` singleton - prop_replicate :: P (Int -> a -> S.Bundle v a) - = (\n _ -> n < 1000) ===> S.replicate `eq` replicate - prop_cons :: P (a -> S.Bundle v a -> S.Bundle v a) = S.cons `eq` (:) - prop_snoc :: P (S.Bundle v a -> a -> S.Bundle v a) = S.snoc `eq` snoc - prop_append :: P (S.Bundle v a -> S.Bundle v a -> S.Bundle v a) = (S.++) `eq` (++) - - prop_head :: P (S.Bundle v a -> a) = not . S.null ===> S.head `eq` head - prop_last :: P (S.Bundle v a -> a) = not . S.null ===> S.last `eq` last - prop_index = \xs -> - not (S.null xs) ==> - forAll (choose (0, S.length xs-1)) $ \i -> - unP prop xs i - where - prop :: P (S.Bundle v a -> Int -> a) = (S.!!) `eq` (!!) - - prop_extract = \xs -> - forAll (choose (0, S.length xs)) $ \i -> - forAll (choose (0, S.length xs - i)) $ \n -> - unP prop i n xs - where - prop :: P (Int -> Int -> S.Bundle v a -> S.Bundle v a) = S.slice `eq` slice - - prop_tail :: P (S.Bundle v a -> S.Bundle v a) = not . S.null ===> S.tail `eq` tail - prop_init :: P (S.Bundle v a -> S.Bundle v a) = not . S.null ===> S.init `eq` init - prop_take :: P (Int -> S.Bundle v a -> S.Bundle v a) = S.take `eq` take - prop_drop :: P (Int -> S.Bundle v a -> S.Bundle v a) = S.drop `eq` drop - - prop_map :: P ((a -> a) -> S.Bundle v a -> S.Bundle v a) = S.map `eq` map - prop_zipWith :: P ((a -> a -> a) -> S.Bundle v a -> S.Bundle v a -> S.Bundle v a) = S.zipWith `eq` zipWith - prop_zipWith3 :: P ((a -> a -> a -> a) -> S.Bundle v a -> S.Bundle v a -> S.Bundle v a -> S.Bundle v a) - = S.zipWith3 `eq` zipWith3 - - prop_filter :: P ((a -> Bool) -> S.Bundle v a -> S.Bundle v a) = S.filter `eq` filter - prop_takeWhile :: P ((a -> Bool) -> S.Bundle v a -> S.Bundle v a) = S.takeWhile `eq` takeWhile - prop_dropWhile :: P ((a -> Bool) -> S.Bundle v a -> S.Bundle v a) = S.dropWhile `eq` dropWhile - - prop_elem :: P (a -> S.Bundle v a -> Bool) = S.elem `eq` elem - prop_notElem :: P (a -> S.Bundle v a -> Bool) = S.notElem `eq` notElem - prop_find :: P ((a -> Bool) -> S.Bundle v a -> Maybe a) = S.find `eq` find - prop_findIndex :: P ((a -> Bool) -> S.Bundle v a -> Maybe Int) - = S.findIndex `eq` findIndex - - prop_foldl :: P ((a -> a -> a) -> a -> S.Bundle v a -> a) = S.foldl `eq` foldl - prop_foldl1 :: P ((a -> a -> a) -> S.Bundle v a -> a) = notNullS2 ===> - S.foldl1 `eq` foldl1 - prop_foldl' :: P ((a -> a -> a) -> a -> S.Bundle v a -> a) = S.foldl' `eq` foldl' - prop_foldl1' :: P ((a -> a -> a) -> S.Bundle v a -> a) = notNullS2 ===> - S.foldl1' `eq` foldl1' - prop_foldr :: P ((a -> a -> a) -> a -> S.Bundle v a -> a) = S.foldr `eq` foldr - prop_foldr1 :: P ((a -> a -> a) -> S.Bundle v a -> a) = notNullS2 ===> - S.foldr1 `eq` foldr1 - - prop_prescanl :: P ((a -> a -> a) -> a -> S.Bundle v a -> S.Bundle v a) - = S.prescanl `eq` prescanl - prop_prescanl' :: P ((a -> a -> a) -> a -> S.Bundle v a -> S.Bundle v a) - = S.prescanl' `eq` prescanl - prop_postscanl :: P ((a -> a -> a) -> a -> S.Bundle v a -> S.Bundle v a) - = S.postscanl `eq` postscanl - prop_postscanl' :: P ((a -> a -> a) -> a -> S.Bundle v a -> S.Bundle v a) - = S.postscanl' `eq` postscanl - prop_scanl :: P ((a -> a -> a) -> a -> S.Bundle v a -> S.Bundle v a) - = S.scanl `eq` scanl - prop_scanl' :: P ((a -> a -> a) -> a -> S.Bundle v a -> S.Bundle v a) - = S.scanl' `eq` scanl - prop_scanl1 :: P ((a -> a -> a) -> S.Bundle v a -> S.Bundle v a) = notNullS2 ===> - S.scanl1 `eq` scanl1 - prop_scanl1' :: P ((a -> a -> a) -> S.Bundle v a -> S.Bundle v a) = notNullS2 ===> - S.scanl1' `eq` scanl1 - - prop_concatMap = forAll arbitrary $ \xs -> - forAll (sized (\n -> resize (n `div` S.length xs) arbitrary)) $ \f -> unP prop f xs - where - prop :: P ((a -> S.Bundle v a) -> S.Bundle v a -> S.Bundle v a) = S.concatMap `eq` concatMap - - limitUnfolds f (theirs, ours) | ours >= 0 - , Just (out, theirs') <- f theirs = Just (out, (theirs', ours - 1)) - | otherwise = Nothing - prop_unfoldr :: P (Int -> (Int -> Maybe (a,Int)) -> Int -> S.Bundle v a) - = (\n f a -> S.unfoldr (limitUnfolds f) (a, n)) - `eq` (\n f a -> unfoldr (limitUnfolds f) (a, n)) - -testBoolFunctions :: forall v. S.Bundle v Bool -> [Test] -testBoolFunctions _ = $(testProperties ['prop_and, 'prop_or ]) - where - prop_and :: P (S.Bundle v Bool -> Bool) = S.and `eq` and - prop_or :: P (S.Bundle v Bool -> Bool) = S.or `eq` or - -testBundleFunctions = testSanity (undefined :: S.Bundle v Int) - ++ testPolymorphicFunctions (undefined :: S.Bundle v Int) - ++ testBoolFunctions (undefined :: S.Bundle v Bool) - -tests = [ testGroup "Data.Vector.Fusion.Bundle" testBundleFunctions ] - diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Move.hs b/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Move.hs deleted file mode 100644 index 60ea8d334600..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Move.hs +++ /dev/null @@ -1,49 +0,0 @@ -module Tests.Move (tests) where - -import Test.QuickCheck -import Test.Framework.Providers.QuickCheck2 -import Test.QuickCheck.Property (Property(..)) - -import Utilities () - -import Control.Monad (replicateM) -import Control.Monad.ST (runST) -import Data.List (sort,permutations) - -import qualified Data.Vector.Generic as G -import qualified Data.Vector.Generic.Mutable as M - -import qualified Data.Vector as V -import qualified Data.Vector.Primitive as P -import qualified Data.Vector.Storable as S -import qualified Data.Vector.Unboxed as U - -basicMove :: G.Vector v a => v a -> Int -> Int -> Int -> v a -basicMove v dstOff srcOff len - | len > 0 = G.modify (\ mv -> G.copy (M.slice dstOff len mv) (G.slice srcOff len v)) v - | otherwise = v - -testMove :: (G.Vector v a, Show (v a), Eq (v a)) => v a -> Property -testMove v = G.length v > 0 ==> (MkProperty $ do - dstOff <- choose (0, G.length v - 1) - srcOff <- choose (0, G.length v - 1) - len <- choose (1, G.length v - max dstOff srcOff) - expected <- return $ basicMove v dstOff srcOff len - actual <- return $ G.modify (\ mv -> M.move (M.slice dstOff len mv) (M.slice srcOff len mv)) v - unProperty $ counterexample ("Move: " ++ show (v, dstOff, srcOff, len)) (expected == actual)) - -checkPermutations :: Int -> Bool -checkPermutations n = runST $ do - vec <- U.thaw (U.fromList [1..n]) - res <- replicateM (product [1..n]) $ M.nextPermutation vec >> U.freeze vec >>= return . U.toList - return $! ([1..n] : res) == sort (permutations [1..n]) ++ [[n,n-1..1]] - -testPermutations :: Bool -testPermutations = all checkPermutations [1..7] - -tests = - [testProperty "Data.Vector.Mutable (Move)" (testMove :: V.Vector Int -> Property), - testProperty "Data.Vector.Primitive.Mutable (Move)" (testMove :: P.Vector Int -> Property), - testProperty "Data.Vector.Unboxed.Mutable (Move)" (testMove :: U.Vector Int -> Property), - testProperty "Data.Vector.Storable.Mutable (Move)" (testMove :: S.Vector Int -> Property), - testProperty "Data.Vector.Generic.Mutable (nextPermutation)" testPermutations] diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Vector.hs b/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Vector.hs deleted file mode 100644 index 46569d909549..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Vector.hs +++ /dev/null @@ -1,706 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -module Tests.Vector (tests) where - -import Boilerplater -import Utilities as Util - -import Data.Functor.Identity -import qualified Data.Traversable as T (Traversable(..)) -import Data.Foldable (Foldable(foldMap)) - -import qualified Data.Vector.Generic as V -import qualified Data.Vector -import qualified Data.Vector.Primitive -import qualified Data.Vector.Storable -import qualified Data.Vector.Unboxed -import qualified Data.Vector.Fusion.Bundle as S - -import Test.QuickCheck - -import Test.Framework -import Test.Framework.Providers.QuickCheck2 - -import Text.Show.Functions () -import Data.List -import Data.Monoid -import qualified Control.Applicative as Applicative -import System.Random (Random) - -import Data.Functor.Identity -import Control.Monad.Trans.Writer - -import Control.Monad.Zip - -type CommonContext a v = (VanillaContext a, VectorContext a v) -type VanillaContext a = ( Eq a , Show a, Arbitrary a, CoArbitrary a - , TestData a, Model a ~ a, EqTest a ~ Property) -type VectorContext a v = ( Eq (v a), Show (v a), Arbitrary (v a), CoArbitrary (v a) - , TestData (v a), Model (v a) ~ [a], EqTest (v a) ~ Property, V.Vector v a) - --- TODO: implement Vector equivalents of list functions for some of the commented out properties - --- TODO: test and implement some of these other Prelude functions: --- mapM * --- mapM_ * --- sequence --- sequence_ --- sum * --- product * --- scanl * --- scanl1 * --- scanr * --- scanr1 * --- lookup * --- lines --- words --- unlines --- unwords --- NB: this is an exhaustive list of all Prelude list functions that make sense for vectors. --- Ones with *s are the most plausible candidates. - --- TODO: add tests for the other extra functions --- IVector exports still needing tests: --- copy, --- slice, --- (//), update, bpermute, --- prescanl, prescanl', --- new, --- unsafeSlice, unsafeIndex, --- vlength, vnew - --- TODO: test non-IVector stuff? - -#if !MIN_VERSION_base(4,7,0) -instance Foldable ((,) a) where - foldMap f (_, b) = f b - -instance T.Traversable ((,) a) where - traverse f (a, b) = fmap ((,) a) $ f b -#endif - -testSanity :: forall a v. (CommonContext a v) => v a -> [Test] -testSanity _ = [ - testProperty "fromList.toList == id" prop_fromList_toList, - testProperty "toList.fromList == id" prop_toList_fromList, - testProperty "unstream.stream == id" prop_unstream_stream, - testProperty "stream.unstream == id" prop_stream_unstream - ] - where - prop_fromList_toList (v :: v a) = (V.fromList . V.toList) v == v - prop_toList_fromList (l :: [a]) = ((V.toList :: v a -> [a]) . V.fromList) l == l - prop_unstream_stream (v :: v a) = (V.unstream . V.stream) v == v - prop_stream_unstream (s :: S.Bundle v a) = ((V.stream :: v a -> S.Bundle v a) . V.unstream) s == s - -testPolymorphicFunctions :: forall a v. (CommonContext a v, VectorContext Int v) => v a -> [Test] -testPolymorphicFunctions _ = $(testProperties [ - 'prop_eq, - - -- Length information - 'prop_length, 'prop_null, - - -- Indexing (FIXME) - 'prop_index, 'prop_safeIndex, 'prop_head, 'prop_last, - 'prop_unsafeIndex, 'prop_unsafeHead, 'prop_unsafeLast, - - -- Monadic indexing (FIXME) - {- 'prop_indexM, 'prop_headM, 'prop_lastM, - 'prop_unsafeIndexM, 'prop_unsafeHeadM, 'prop_unsafeLastM, -} - - -- Subvectors (FIXME) - 'prop_slice, 'prop_init, 'prop_tail, 'prop_take, 'prop_drop, - 'prop_splitAt, - {- 'prop_unsafeSlice, 'prop_unsafeInit, 'prop_unsafeTail, - 'prop_unsafeTake, 'prop_unsafeDrop, -} - - -- Initialisation (FIXME) - 'prop_empty, 'prop_singleton, 'prop_replicate, - 'prop_generate, 'prop_iterateN, 'prop_iterateNM, - - -- Monadic initialisation (FIXME) - 'prop_createT, - {- 'prop_replicateM, 'prop_generateM, 'prop_create, -} - - -- Unfolding - 'prop_unfoldr, 'prop_unfoldrN, 'prop_unfoldrM, 'prop_unfoldrNM, - 'prop_constructN, 'prop_constructrN, - - -- Enumeration? (FIXME?) - - -- Concatenation (FIXME) - 'prop_cons, 'prop_snoc, 'prop_append, - 'prop_concat, - - -- Restricting memory usage - 'prop_force, - - - -- Bulk updates (FIXME) - 'prop_upd, - {- 'prop_update, 'prop_update_, - 'prop_unsafeUpd, 'prop_unsafeUpdate, 'prop_unsafeUpdate_, -} - - -- Accumulations (FIXME) - 'prop_accum, - {- 'prop_accumulate, 'prop_accumulate_, - 'prop_unsafeAccum, 'prop_unsafeAccumulate, 'prop_unsafeAccumulate_, -} - - -- Permutations - 'prop_reverse, 'prop_backpermute, - {- 'prop_unsafeBackpermute, -} - - -- Elementwise indexing - {- 'prop_indexed, -} - - -- Mapping - 'prop_map, 'prop_imap, 'prop_concatMap, - - -- Monadic mapping - {- 'prop_mapM, 'prop_mapM_, 'prop_forM, 'prop_forM_, -} - 'prop_imapM, 'prop_imapM_, - - -- Zipping - 'prop_zipWith, 'prop_zipWith3, {- ... -} - 'prop_izipWith, 'prop_izipWith3, {- ... -} - 'prop_izipWithM, 'prop_izipWithM_, - {- 'prop_zip, ... -} - - -- Monadic zipping - {- 'prop_zipWithM, 'prop_zipWithM_, -} - - -- Unzipping - {- 'prop_unzip, ... -} - - -- Filtering - 'prop_filter, 'prop_ifilter, {- prop_filterM, -} - 'prop_uniq, - 'prop_mapMaybe, 'prop_imapMaybe, - 'prop_takeWhile, 'prop_dropWhile, - - -- Paritioning - 'prop_partition, {- 'prop_unstablePartition, -} - 'prop_span, 'prop_break, - - -- Searching - 'prop_elem, 'prop_notElem, - 'prop_find, 'prop_findIndex, 'prop_findIndices, - 'prop_elemIndex, 'prop_elemIndices, - - -- Folding - 'prop_foldl, 'prop_foldl1, 'prop_foldl', 'prop_foldl1', - 'prop_foldr, 'prop_foldr1, 'prop_foldr', 'prop_foldr1', - 'prop_ifoldl, 'prop_ifoldl', 'prop_ifoldr, 'prop_ifoldr', - 'prop_ifoldM, 'prop_ifoldM', 'prop_ifoldM_, 'prop_ifoldM'_, - - -- Specialised folds - 'prop_all, 'prop_any, - {- 'prop_maximumBy, 'prop_minimumBy, - 'prop_maxIndexBy, 'prop_minIndexBy, -} - - -- Monadic folds - {- ... -} - - -- Monadic sequencing - {- ... -} - - -- Scans - 'prop_prescanl, 'prop_prescanl', - 'prop_postscanl, 'prop_postscanl', - 'prop_scanl, 'prop_scanl', 'prop_scanl1, 'prop_scanl1', - 'prop_iscanl, 'prop_iscanl', - - 'prop_prescanr, 'prop_prescanr', - 'prop_postscanr, 'prop_postscanr', - 'prop_scanr, 'prop_scanr', 'prop_scanr1, 'prop_scanr1', - 'prop_iscanr, 'prop_iscanr' - ]) - where - -- Prelude - prop_eq :: P (v a -> v a -> Bool) = (==) `eq` (==) - - prop_length :: P (v a -> Int) = V.length `eq` length - prop_null :: P (v a -> Bool) = V.null `eq` null - - prop_empty :: P (v a) = V.empty `eq` [] - prop_singleton :: P (a -> v a) = V.singleton `eq` singleton - prop_replicate :: P (Int -> a -> v a) - = (\n _ -> n < 1000) ===> V.replicate `eq` replicate - prop_cons :: P (a -> v a -> v a) = V.cons `eq` (:) - prop_snoc :: P (v a -> a -> v a) = V.snoc `eq` snoc - prop_append :: P (v a -> v a -> v a) = (V.++) `eq` (++) - prop_concat :: P ([v a] -> v a) = V.concat `eq` concat - prop_force :: P (v a -> v a) = V.force `eq` id - prop_generate :: P (Int -> (Int -> a) -> v a) - = (\n _ -> n < 1000) ===> V.generate `eq` Util.generate - prop_iterateN :: P (Int -> (a -> a) -> a -> v a) - = (\n _ _ -> n < 1000) ===> V.iterateN `eq` (\n f -> take n . iterate f) - prop_iterateNM :: P (Int -> (a -> Writer [Int] a) -> a -> Writer [Int] (v a)) - = (\n _ _ -> n < 1000) ===> V.iterateNM `eq` Util.iterateNM - prop_createT :: P ((a, v a) -> (a, v a)) - prop_createT = (\v -> V.createT (T.mapM V.thaw v)) `eq` id - - prop_head :: P (v a -> a) = not . V.null ===> V.head `eq` head - prop_last :: P (v a -> a) = not . V.null ===> V.last `eq` last - prop_index = \xs -> - not (V.null xs) ==> - forAll (choose (0, V.length xs-1)) $ \i -> - unP prop xs i - where - prop :: P (v a -> Int -> a) = (V.!) `eq` (!!) - prop_safeIndex :: P (v a -> Int -> Maybe a) = (V.!?) `eq` fn - where - fn xs i = case drop i xs of - x:_ | i >= 0 -> Just x - _ -> Nothing - prop_unsafeHead :: P (v a -> a) = not . V.null ===> V.unsafeHead `eq` head - prop_unsafeLast :: P (v a -> a) = not . V.null ===> V.unsafeLast `eq` last - prop_unsafeIndex = \xs -> - not (V.null xs) ==> - forAll (choose (0, V.length xs-1)) $ \i -> - unP prop xs i - where - prop :: P (v a -> Int -> a) = V.unsafeIndex `eq` (!!) - - prop_slice = \xs -> - forAll (choose (0, V.length xs)) $ \i -> - forAll (choose (0, V.length xs - i)) $ \n -> - unP prop i n xs - where - prop :: P (Int -> Int -> v a -> v a) = V.slice `eq` slice - - prop_tail :: P (v a -> v a) = not . V.null ===> V.tail `eq` tail - prop_init :: P (v a -> v a) = not . V.null ===> V.init `eq` init - prop_take :: P (Int -> v a -> v a) = V.take `eq` take - prop_drop :: P (Int -> v a -> v a) = V.drop `eq` drop - prop_splitAt :: P (Int -> v a -> (v a, v a)) = V.splitAt `eq` splitAt - - prop_accum = \f xs -> - forAll (index_value_pairs (V.length xs)) $ \ps -> - unP prop f xs ps - where - prop :: P ((a -> a -> a) -> v a -> [(Int,a)] -> v a) - = V.accum `eq` accum - - prop_upd = \xs -> - forAll (index_value_pairs (V.length xs)) $ \ps -> - unP prop xs ps - where - prop :: P (v a -> [(Int,a)] -> v a) = (V.//) `eq` (//) - - prop_backpermute = \xs -> - forAll (indices (V.length xs)) $ \is -> - unP prop xs (V.fromList is) - where - prop :: P (v a -> v Int -> v a) = V.backpermute `eq` backpermute - - prop_reverse :: P (v a -> v a) = V.reverse `eq` reverse - - prop_map :: P ((a -> a) -> v a -> v a) = V.map `eq` map - prop_zipWith :: P ((a -> a -> a) -> v a -> v a -> v a) = V.zipWith `eq` zipWith - prop_zipWith3 :: P ((a -> a -> a -> a) -> v a -> v a -> v a -> v a) - = V.zipWith3 `eq` zipWith3 - prop_imap :: P ((Int -> a -> a) -> v a -> v a) = V.imap `eq` imap - prop_imapM :: P ((Int -> a -> Identity a) -> v a -> Identity (v a)) - = V.imapM `eq` imapM - prop_imapM_ :: P ((Int -> a -> Writer [a] ()) -> v a -> Writer [a] ()) - = V.imapM_ `eq` imapM_ - prop_izipWith :: P ((Int -> a -> a -> a) -> v a -> v a -> v a) = V.izipWith `eq` izipWith - prop_izipWithM :: P ((Int -> a -> a -> Identity a) -> v a -> v a -> Identity (v a)) - = V.izipWithM `eq` izipWithM - prop_izipWithM_ :: P ((Int -> a -> a -> Writer [a] ()) -> v a -> v a -> Writer [a] ()) - = V.izipWithM_ `eq` izipWithM_ - prop_izipWith3 :: P ((Int -> a -> a -> a -> a) -> v a -> v a -> v a -> v a) - = V.izipWith3 `eq` izipWith3 - - prop_filter :: P ((a -> Bool) -> v a -> v a) = V.filter `eq` filter - prop_ifilter :: P ((Int -> a -> Bool) -> v a -> v a) = V.ifilter `eq` ifilter - prop_mapMaybe :: P ((a -> Maybe a) -> v a -> v a) = V.mapMaybe `eq` mapMaybe - prop_imapMaybe :: P ((Int -> a -> Maybe a) -> v a -> v a) = V.imapMaybe `eq` imapMaybe - prop_takeWhile :: P ((a -> Bool) -> v a -> v a) = V.takeWhile `eq` takeWhile - prop_dropWhile :: P ((a -> Bool) -> v a -> v a) = V.dropWhile `eq` dropWhile - prop_partition :: P ((a -> Bool) -> v a -> (v a, v a)) - = V.partition `eq` partition - prop_span :: P ((a -> Bool) -> v a -> (v a, v a)) = V.span `eq` span - prop_break :: P ((a -> Bool) -> v a -> (v a, v a)) = V.break `eq` break - - prop_elem :: P (a -> v a -> Bool) = V.elem `eq` elem - prop_notElem :: P (a -> v a -> Bool) = V.notElem `eq` notElem - prop_find :: P ((a -> Bool) -> v a -> Maybe a) = V.find `eq` find - prop_findIndex :: P ((a -> Bool) -> v a -> Maybe Int) - = V.findIndex `eq` findIndex - prop_findIndices :: P ((a -> Bool) -> v a -> v Int) - = V.findIndices `eq` findIndices - prop_elemIndex :: P (a -> v a -> Maybe Int) = V.elemIndex `eq` elemIndex - prop_elemIndices :: P (a -> v a -> v Int) = V.elemIndices `eq` elemIndices - - prop_foldl :: P ((a -> a -> a) -> a -> v a -> a) = V.foldl `eq` foldl - prop_foldl1 :: P ((a -> a -> a) -> v a -> a) = notNull2 ===> - V.foldl1 `eq` foldl1 - prop_foldl' :: P ((a -> a -> a) -> a -> v a -> a) = V.foldl' `eq` foldl' - prop_foldl1' :: P ((a -> a -> a) -> v a -> a) = notNull2 ===> - V.foldl1' `eq` foldl1' - prop_foldr :: P ((a -> a -> a) -> a -> v a -> a) = V.foldr `eq` foldr - prop_foldr1 :: P ((a -> a -> a) -> v a -> a) = notNull2 ===> - V.foldr1 `eq` foldr1 - prop_foldr' :: P ((a -> a -> a) -> a -> v a -> a) = V.foldr' `eq` foldr - prop_foldr1' :: P ((a -> a -> a) -> v a -> a) = notNull2 ===> - V.foldr1' `eq` foldr1 - prop_ifoldl :: P ((a -> Int -> a -> a) -> a -> v a -> a) - = V.ifoldl `eq` ifoldl - prop_ifoldl' :: P ((a -> Int -> a -> a) -> a -> v a -> a) - = V.ifoldl' `eq` ifoldl - prop_ifoldr :: P ((Int -> a -> a -> a) -> a -> v a -> a) - = V.ifoldr `eq` ifoldr - prop_ifoldr' :: P ((Int -> a -> a -> a) -> a -> v a -> a) - = V.ifoldr' `eq` ifoldr - prop_ifoldM :: P ((a -> Int -> a -> Identity a) -> a -> v a -> Identity a) - = V.ifoldM `eq` ifoldM - prop_ifoldM' :: P ((a -> Int -> a -> Identity a) -> a -> v a -> Identity a) - = V.ifoldM' `eq` ifoldM - prop_ifoldM_ :: P ((() -> Int -> a -> Writer [a] ()) -> () -> v a -> Writer [a] ()) - = V.ifoldM_ `eq` ifoldM_ - prop_ifoldM'_ :: P ((() -> Int -> a -> Writer [a] ()) -> () -> v a -> Writer [a] ()) - = V.ifoldM'_ `eq` ifoldM_ - - prop_all :: P ((a -> Bool) -> v a -> Bool) = V.all `eq` all - prop_any :: P ((a -> Bool) -> v a -> Bool) = V.any `eq` any - - prop_prescanl :: P ((a -> a -> a) -> a -> v a -> v a) - = V.prescanl `eq` prescanl - prop_prescanl' :: P ((a -> a -> a) -> a -> v a -> v a) - = V.prescanl' `eq` prescanl - prop_postscanl :: P ((a -> a -> a) -> a -> v a -> v a) - = V.postscanl `eq` postscanl - prop_postscanl' :: P ((a -> a -> a) -> a -> v a -> v a) - = V.postscanl' `eq` postscanl - prop_scanl :: P ((a -> a -> a) -> a -> v a -> v a) - = V.scanl `eq` scanl - prop_scanl' :: P ((a -> a -> a) -> a -> v a -> v a) - = V.scanl' `eq` scanl - prop_scanl1 :: P ((a -> a -> a) -> v a -> v a) = notNull2 ===> - V.scanl1 `eq` scanl1 - prop_scanl1' :: P ((a -> a -> a) -> v a -> v a) = notNull2 ===> - V.scanl1' `eq` scanl1 - prop_iscanl :: P ((Int -> a -> a -> a) -> a -> v a -> v a) - = V.iscanl `eq` iscanl - prop_iscanl' :: P ((Int -> a -> a -> a) -> a -> v a -> v a) - = V.iscanl' `eq` iscanl - - prop_prescanr :: P ((a -> a -> a) -> a -> v a -> v a) - = V.prescanr `eq` prescanr - prop_prescanr' :: P ((a -> a -> a) -> a -> v a -> v a) - = V.prescanr' `eq` prescanr - prop_postscanr :: P ((a -> a -> a) -> a -> v a -> v a) - = V.postscanr `eq` postscanr - prop_postscanr' :: P ((a -> a -> a) -> a -> v a -> v a) - = V.postscanr' `eq` postscanr - prop_scanr :: P ((a -> a -> a) -> a -> v a -> v a) - = V.scanr `eq` scanr - prop_scanr' :: P ((a -> a -> a) -> a -> v a -> v a) - = V.scanr' `eq` scanr - prop_iscanr :: P ((Int -> a -> a -> a) -> a -> v a -> v a) - = V.iscanr `eq` iscanr - prop_iscanr' :: P ((Int -> a -> a -> a) -> a -> v a -> v a) - = V.iscanr' `eq` iscanr - prop_scanr1 :: P ((a -> a -> a) -> v a -> v a) = notNull2 ===> - V.scanr1 `eq` scanr1 - prop_scanr1' :: P ((a -> a -> a) -> v a -> v a) = notNull2 ===> - V.scanr1' `eq` scanr1 - - prop_concatMap = forAll arbitrary $ \xs -> - forAll (sized (\n -> resize (n `div` V.length xs) arbitrary)) $ \f -> unP prop f xs - where - prop :: P ((a -> v a) -> v a -> v a) = V.concatMap `eq` concatMap - - prop_uniq :: P (v a -> v a) - = V.uniq `eq` (map head . group) - --prop_span = (V.span :: (a -> Bool) -> v a -> (v a, v a)) `eq2` span - --prop_break = (V.break :: (a -> Bool) -> v a -> (v a, v a)) `eq2` break - --prop_splitAt = (V.splitAt :: Int -> v a -> (v a, v a)) `eq2` splitAt - --prop_all = (V.all :: (a -> Bool) -> v a -> Bool) `eq2` all - --prop_any = (V.any :: (a -> Bool) -> v a -> Bool) `eq2` any - - -- Data.List - --prop_findIndices = V.findIndices `eq2` (findIndices :: (a -> Bool) -> v a -> v Int) - --prop_isPrefixOf = V.isPrefixOf `eq2` (isPrefixOf :: v a -> v a -> Bool) - --prop_elemIndex = V.elemIndex `eq2` (elemIndex :: a -> v a -> Maybe Int) - --prop_elemIndices = V.elemIndices `eq2` (elemIndices :: a -> v a -> v Int) - -- - --prop_mapAccumL = eq3 - -- (V.mapAccumL :: (X -> W -> (X,W)) -> X -> B -> (X, B)) - -- ( mapAccumL :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W])) - -- - --prop_mapAccumR = eq3 - -- (V.mapAccumR :: (X -> W -> (X,W)) -> X -> B -> (X, B)) - -- ( mapAccumR :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W])) - - -- Because the vectors are strict, we need to be totally sure that the unfold eventually terminates. This - -- is achieved by injecting our own bit of state into the unfold - the maximum number of unfolds allowed. - limitUnfolds f (theirs, ours) - | ours > 0 - , Just (out, theirs') <- f theirs = Just (out, (theirs', ours - 1)) - | otherwise = Nothing - limitUnfoldsM f (theirs, ours) - | ours > 0 = do r <- f theirs - return $ (\(a,b) -> (a,(b,ours - 1))) `fmap` r - | otherwise = return Nothing - - - prop_unfoldr :: P (Int -> (Int -> Maybe (a,Int)) -> Int -> v a) - = (\n f a -> V.unfoldr (limitUnfolds f) (a, n)) - `eq` (\n f a -> unfoldr (limitUnfolds f) (a, n)) - prop_unfoldrN :: P (Int -> (Int -> Maybe (a,Int)) -> Int -> v a) - = V.unfoldrN `eq` (\n f a -> unfoldr (limitUnfolds f) (a, n)) - prop_unfoldrM :: P (Int -> (Int -> Writer [Int] (Maybe (a,Int))) -> Int -> Writer [Int] (v a)) - = (\n f a -> V.unfoldrM (limitUnfoldsM f) (a,n)) - `eq` (\n f a -> Util.unfoldrM (limitUnfoldsM f) (a, n)) - prop_unfoldrNM :: P (Int -> (Int -> Writer [Int] (Maybe (a,Int))) -> Int -> Writer [Int] (v a)) - = V.unfoldrNM `eq` (\n f a -> Util.unfoldrM (limitUnfoldsM f) (a, n)) - - prop_constructN = \f -> forAll (choose (0,20)) $ \n -> unP prop n f - where - prop :: P (Int -> (v a -> a) -> v a) = V.constructN `eq` constructN [] - - constructN xs 0 _ = xs - constructN xs n f = constructN (xs ++ [f xs]) (n-1) f - - prop_constructrN = \f -> forAll (choose (0,20)) $ \n -> unP prop n f - where - prop :: P (Int -> (v a -> a) -> v a) = V.constructrN `eq` constructrN [] - - constructrN xs 0 _ = xs - constructrN xs n f = constructrN (f xs : xs) (n-1) f - -testTuplyFunctions:: forall a v. (CommonContext a v, VectorContext (a, a) v, VectorContext (a, a, a) v) => v a -> [Test] -testTuplyFunctions _ = $(testProperties [ 'prop_zip, 'prop_zip3 - , 'prop_unzip, 'prop_unzip3 - , 'prop_mzip, 'prop_munzip - ]) - where - prop_zip :: P (v a -> v a -> v (a, a)) = V.zip `eq` zip - prop_zip3 :: P (v a -> v a -> v a -> v (a, a, a)) = V.zip3 `eq` zip3 - prop_unzip :: P (v (a, a) -> (v a, v a)) = V.unzip `eq` unzip - prop_unzip3 :: P (v (a, a, a) -> (v a, v a, v a)) = V.unzip3 `eq` unzip3 - prop_mzip :: P (Data.Vector.Vector a -> Data.Vector.Vector a -> Data.Vector.Vector (a, a)) - = mzip `eq` zip - prop_munzip :: P (Data.Vector.Vector (a, a) -> (Data.Vector.Vector a, Data.Vector.Vector a)) - = munzip `eq` unzip - -testOrdFunctions :: forall a v. (CommonContext a v, Ord a, Ord (v a)) => v a -> [Test] -testOrdFunctions _ = $(testProperties - ['prop_compare, - 'prop_maximum, 'prop_minimum, - 'prop_minIndex, 'prop_maxIndex ]) - where - prop_compare :: P (v a -> v a -> Ordering) = compare `eq` compare - prop_maximum :: P (v a -> a) = not . V.null ===> V.maximum `eq` maximum - prop_minimum :: P (v a -> a) = not . V.null ===> V.minimum `eq` minimum - prop_minIndex :: P (v a -> Int) = not . V.null ===> V.minIndex `eq` minIndex - prop_maxIndex :: P (v a -> Int) = not . V.null ===> V.maxIndex `eq` maxIndex - -testEnumFunctions :: forall a v. (CommonContext a v, Enum a, Ord a, Num a, Random a) => v a -> [Test] -testEnumFunctions _ = $(testProperties - [ 'prop_enumFromN, 'prop_enumFromThenN, - 'prop_enumFromTo, 'prop_enumFromThenTo]) - where - prop_enumFromN :: P (a -> Int -> v a) - = (\_ n -> n < 1000) - ===> V.enumFromN `eq` (\x n -> take n $ scanl (+) x $ repeat 1) - - prop_enumFromThenN :: P (a -> a -> Int -> v a) - = (\_ _ n -> n < 1000) - ===> V.enumFromStepN `eq` (\x y n -> take n $ scanl (+) x $ repeat y) - - prop_enumFromTo = \m -> - forAll (choose (-2,100)) $ \n -> - unP prop m (m+n) - where - prop :: P (a -> a -> v a) = V.enumFromTo `eq` enumFromTo - - prop_enumFromThenTo = \i j -> - j /= i ==> - forAll (choose (ks i j)) $ \k -> - unP prop i j k - where - prop :: P (a -> a -> a -> v a) = V.enumFromThenTo `eq` enumFromThenTo - - ks i j | j < i = (i-d*100, i+d*2) - | otherwise = (i-d*2, i+d*100) - where - d = abs (j-i) - -testMonoidFunctions :: forall a v. (CommonContext a v, Monoid (v a)) => v a -> [Test] -testMonoidFunctions _ = $(testProperties - [ 'prop_mempty, 'prop_mappend, 'prop_mconcat ]) - where - prop_mempty :: P (v a) = mempty `eq` mempty - prop_mappend :: P (v a -> v a -> v a) = mappend `eq` mappend - prop_mconcat :: P ([v a] -> v a) = mconcat `eq` mconcat - -testFunctorFunctions :: forall a v. (CommonContext a v, Functor v) => v a -> [Test] -testFunctorFunctions _ = $(testProperties - [ 'prop_fmap ]) - where - prop_fmap :: P ((a -> a) -> v a -> v a) = fmap `eq` fmap - -testMonadFunctions :: forall a v. (CommonContext a v, Monad v) => v a -> [Test] -testMonadFunctions _ = $(testProperties - [ 'prop_return, 'prop_bind ]) - where - prop_return :: P (a -> v a) = return `eq` return - prop_bind :: P (v a -> (a -> v a) -> v a) = (>>=) `eq` (>>=) - -testApplicativeFunctions :: forall a v. (CommonContext a v, V.Vector v (a -> a), Applicative.Applicative v) => v a -> [Test] -testApplicativeFunctions _ = $(testProperties - [ 'prop_applicative_pure, 'prop_applicative_appl ]) - where - prop_applicative_pure :: P (a -> v a) - = Applicative.pure `eq` Applicative.pure - prop_applicative_appl :: [a -> a] -> P (v a -> v a) - = \fs -> (Applicative.<*>) (V.fromList fs) `eq` (Applicative.<*>) fs - -testAlternativeFunctions :: forall a v. (CommonContext a v, Applicative.Alternative v) => v a -> [Test] -testAlternativeFunctions _ = $(testProperties - [ 'prop_alternative_empty, 'prop_alternative_or ]) - where - prop_alternative_empty :: P (v a) = Applicative.empty `eq` Applicative.empty - prop_alternative_or :: P (v a -> v a -> v a) - = (Applicative.<|>) `eq` (Applicative.<|>) - -testBoolFunctions :: forall v. (CommonContext Bool v) => v Bool -> [Test] -testBoolFunctions _ = $(testProperties ['prop_and, 'prop_or]) - where - prop_and :: P (v Bool -> Bool) = V.and `eq` and - prop_or :: P (v Bool -> Bool) = V.or `eq` or - -testNumFunctions :: forall a v. (CommonContext a v, Num a) => v a -> [Test] -testNumFunctions _ = $(testProperties ['prop_sum, 'prop_product]) - where - prop_sum :: P (v a -> a) = V.sum `eq` sum - prop_product :: P (v a -> a) = V.product `eq` product - -testNestedVectorFunctions :: forall a v. (CommonContext a v) => v a -> [Test] -testNestedVectorFunctions _ = $(testProperties []) - where - -- Prelude - --prop_concat = (V.concat :: [v a] -> v a) `eq1` concat - - -- Data.List - --prop_transpose = V.transpose `eq1` (transpose :: [v a] -> [v a]) - --prop_group = V.group `eq1` (group :: v a -> [v a]) - --prop_inits = V.inits `eq1` (inits :: v a -> [v a]) - --prop_tails = V.tails `eq1` (tails :: v a -> [v a]) - -testGeneralBoxedVector :: forall a. (CommonContext a Data.Vector.Vector, Ord a) => Data.Vector.Vector a -> [Test] -testGeneralBoxedVector dummy = concatMap ($ dummy) [ - testSanity, - testPolymorphicFunctions, - testOrdFunctions, - testTuplyFunctions, - testNestedVectorFunctions, - testMonoidFunctions, - testFunctorFunctions, - testMonadFunctions, - testApplicativeFunctions, - testAlternativeFunctions - ] - -testBoolBoxedVector dummy = concatMap ($ dummy) - [ - testGeneralBoxedVector - , testBoolFunctions - ] - -testNumericBoxedVector :: forall a. (CommonContext a Data.Vector.Vector, Ord a, Num a, Enum a, Random a) => Data.Vector.Vector a -> [Test] -testNumericBoxedVector dummy = concatMap ($ dummy) - [ - testGeneralBoxedVector - , testNumFunctions - , testEnumFunctions - ] - - -testGeneralPrimitiveVector :: forall a. (CommonContext a Data.Vector.Primitive.Vector, Data.Vector.Primitive.Prim a, Ord a) => Data.Vector.Primitive.Vector a -> [Test] -testGeneralPrimitiveVector dummy = concatMap ($ dummy) [ - testSanity, - testPolymorphicFunctions, - testOrdFunctions, - testMonoidFunctions - ] - -testNumericPrimitiveVector :: forall a. (CommonContext a Data.Vector.Primitive.Vector, Data.Vector.Primitive.Prim a, Ord a, Num a, Enum a, Random a) => Data.Vector.Primitive.Vector a -> [Test] -testNumericPrimitiveVector dummy = concatMap ($ dummy) - [ - testGeneralPrimitiveVector - , testNumFunctions - , testEnumFunctions - ] - - -testGeneralStorableVector :: forall a. (CommonContext a Data.Vector.Storable.Vector, Data.Vector.Storable.Storable a, Ord a) => Data.Vector.Storable.Vector a -> [Test] -testGeneralStorableVector dummy = concatMap ($ dummy) [ - testSanity, - testPolymorphicFunctions, - testOrdFunctions, - testMonoidFunctions - ] - -testNumericStorableVector :: forall a. (CommonContext a Data.Vector.Storable.Vector, Data.Vector.Storable.Storable a, Ord a, Num a, Enum a, Random a) => Data.Vector.Storable.Vector a -> [Test] -testNumericStorableVector dummy = concatMap ($ dummy) - [ - testGeneralStorableVector - , testNumFunctions - , testEnumFunctions - ] - - -testGeneralUnboxedVector :: forall a. (CommonContext a Data.Vector.Unboxed.Vector, Data.Vector.Unboxed.Unbox a, Ord a) => Data.Vector.Unboxed.Vector a -> [Test] -testGeneralUnboxedVector dummy = concatMap ($ dummy) [ - testSanity, - testPolymorphicFunctions, - testOrdFunctions, - testMonoidFunctions - ] - -testUnitUnboxedVector dummy = concatMap ($ dummy) - [ - testGeneralUnboxedVector - ] - -testBoolUnboxedVector dummy = concatMap ($ dummy) - [ - testGeneralUnboxedVector - , testBoolFunctions - ] - -testNumericUnboxedVector :: forall a. (CommonContext a Data.Vector.Unboxed.Vector, Data.Vector.Unboxed.Unbox a, Ord a, Num a, Enum a, Random a) => Data.Vector.Unboxed.Vector a -> [Test] -testNumericUnboxedVector dummy = concatMap ($ dummy) - [ - testGeneralUnboxedVector - , testNumFunctions - , testEnumFunctions - ] - -testTupleUnboxedVector :: forall a. (CommonContext a Data.Vector.Unboxed.Vector, Data.Vector.Unboxed.Unbox a, Ord a) => Data.Vector.Unboxed.Vector a -> [Test] -testTupleUnboxedVector dummy = concatMap ($ dummy) - [ - testGeneralUnboxedVector - ] - -tests = [ - testGroup "Data.Vector.Vector (Bool)" (testBoolBoxedVector (undefined :: Data.Vector.Vector Bool)), - testGroup "Data.Vector.Vector (Int)" (testNumericBoxedVector (undefined :: Data.Vector.Vector Int)), - - testGroup "Data.Vector.Primitive.Vector (Int)" (testNumericPrimitiveVector (undefined :: Data.Vector.Primitive.Vector Int)), - testGroup "Data.Vector.Primitive.Vector (Double)" (testNumericPrimitiveVector (undefined :: Data.Vector.Primitive.Vector Double)), - - testGroup "Data.Vector.Storable.Vector (Int)" (testNumericStorableVector (undefined :: Data.Vector.Storable.Vector Int)), - testGroup "Data.Vector.Storable.Vector (Double)" (testNumericStorableVector (undefined :: Data.Vector.Storable.Vector Double)), - - testGroup "Data.Vector.Unboxed.Vector ()" (testUnitUnboxedVector (undefined :: Data.Vector.Unboxed.Vector ())), - testGroup "Data.Vector.Unboxed.Vector (Bool)" (testBoolUnboxedVector (undefined :: Data.Vector.Unboxed.Vector Bool)), - testGroup "Data.Vector.Unboxed.Vector (Int)" (testNumericUnboxedVector (undefined :: Data.Vector.Unboxed.Vector Int)), - testGroup "Data.Vector.Unboxed.Vector (Double)" (testNumericUnboxedVector (undefined :: Data.Vector.Unboxed.Vector Double)), - testGroup "Data.Vector.Unboxed.Vector (Int,Bool)" (testTupleUnboxedVector (undefined :: Data.Vector.Unboxed.Vector (Int,Bool))), - testGroup "Data.Vector.Unboxed.Vector (Int,Bool,Int)" (testTupleUnboxedVector (undefined :: Data.Vector.Unboxed.Vector (Int,Bool,Int))) - - ] diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Vector/UnitTests.hs b/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Vector/UnitTests.hs deleted file mode 100644 index 5827640d8438..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Vector/UnitTests.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module Tests.Vector.UnitTests (tests) where - -import Control.Applicative as Applicative -import qualified Data.Vector.Storable as Storable -import Foreign.Ptr -import Foreign.Storable -import Text.Printf - -import Test.Framework -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, assertBool) - -newtype Aligned a = Aligned { getAligned :: a } - -instance (Storable a) => Storable (Aligned a) where - sizeOf _ = sizeOf (undefined :: a) - alignment _ = 128 - peek ptr = Aligned Applicative.<$> peek (castPtr ptr) - poke ptr = poke (castPtr ptr) . getAligned - -checkAddressAlignment :: forall a. (Storable a) => Storable.Vector a -> Assertion -checkAddressAlignment xs = Storable.unsafeWith xs $ \ptr -> do - let ptr' = ptrToWordPtr ptr - msg = printf "Expected pointer with alignment %d but got 0x%08x" (toInteger align) (toInteger ptr') - align :: WordPtr - align = fromIntegral $ alignment dummy - assertBool msg $ (ptr' `mod` align) == 0 - where - dummy :: a - dummy = undefined - -tests :: [Test] -tests = - [ testGroup "Data.Vector.Storable.Vector Alignment" - [ testCase "Aligned Double" $ - checkAddressAlignment alignedDoubleVec - , testCase "Aligned Int" $ - checkAddressAlignment alignedIntVec - ] - ] - -alignedDoubleVec :: Storable.Vector (Aligned Double) -alignedDoubleVec = Storable.fromList $ map Aligned [1, 2, 3, 4, 5] - -alignedIntVec :: Storable.Vector (Aligned Int) -alignedIntVec = Storable.fromList $ map Aligned [1, 2, 3, 4, 5] diff --git a/third_party/bazel/rules_haskell/examples/vector/tests/Utilities.hs b/third_party/bazel/rules_haskell/examples/vector/tests/Utilities.hs deleted file mode 100644 index 86a4f2c32462..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/tests/Utilities.hs +++ /dev/null @@ -1,350 +0,0 @@ -{-# LANGUAGE FlexibleInstances, GADTs #-} -module Utilities where - -import Test.QuickCheck - -import qualified Data.Vector as DV -import qualified Data.Vector.Generic as DVG -import qualified Data.Vector.Primitive as DVP -import qualified Data.Vector.Storable as DVS -import qualified Data.Vector.Unboxed as DVU -import qualified Data.Vector.Fusion.Bundle as S - -import Control.Monad (foldM, foldM_, zipWithM, zipWithM_) -import Control.Monad.Trans.Writer -import Data.Function (on) -import Data.Functor.Identity -import Data.List ( sortBy ) -import Data.Monoid -import Data.Maybe (catMaybes) - -instance Show a => Show (S.Bundle v a) where - show s = "Data.Vector.Fusion.Bundle.fromList " ++ show (S.toList s) - - -instance Arbitrary a => Arbitrary (DV.Vector a) where - arbitrary = fmap DV.fromList arbitrary - -instance CoArbitrary a => CoArbitrary (DV.Vector a) where - coarbitrary = coarbitrary . DV.toList - -instance (Arbitrary a, DVP.Prim a) => Arbitrary (DVP.Vector a) where - arbitrary = fmap DVP.fromList arbitrary - -instance (CoArbitrary a, DVP.Prim a) => CoArbitrary (DVP.Vector a) where - coarbitrary = coarbitrary . DVP.toList - -instance (Arbitrary a, DVS.Storable a) => Arbitrary (DVS.Vector a) where - arbitrary = fmap DVS.fromList arbitrary - -instance (CoArbitrary a, DVS.Storable a) => CoArbitrary (DVS.Vector a) where - coarbitrary = coarbitrary . DVS.toList - -instance (Arbitrary a, DVU.Unbox a) => Arbitrary (DVU.Vector a) where - arbitrary = fmap DVU.fromList arbitrary - -instance (CoArbitrary a, DVU.Unbox a) => CoArbitrary (DVU.Vector a) where - coarbitrary = coarbitrary . DVU.toList - -instance Arbitrary a => Arbitrary (S.Bundle v a) where - arbitrary = fmap S.fromList arbitrary - -instance CoArbitrary a => CoArbitrary (S.Bundle v a) where - coarbitrary = coarbitrary . S.toList - -instance (Arbitrary a, Arbitrary b) => Arbitrary (Writer a b) where - arbitrary = do b <- arbitrary - a <- arbitrary - return $ writer (b,a) - -instance CoArbitrary a => CoArbitrary (Writer a ()) where - coarbitrary = coarbitrary . runWriter - -class (Testable (EqTest a), Conclusion (EqTest a)) => TestData a where - type Model a - model :: a -> Model a - unmodel :: Model a -> a - - type EqTest a - equal :: a -> a -> EqTest a - -instance Eq a => TestData (S.Bundle v a) where - type Model (S.Bundle v a) = [a] - model = S.toList - unmodel = S.fromList - - type EqTest (S.Bundle v a) = Property - equal x y = property (x == y) - -instance Eq a => TestData (DV.Vector a) where - type Model (DV.Vector a) = [a] - model = DV.toList - unmodel = DV.fromList - - type EqTest (DV.Vector a) = Property - equal x y = property (x == y) - -instance (Eq a, DVP.Prim a) => TestData (DVP.Vector a) where - type Model (DVP.Vector a) = [a] - model = DVP.toList - unmodel = DVP.fromList - - type EqTest (DVP.Vector a) = Property - equal x y = property (x == y) - -instance (Eq a, DVS.Storable a) => TestData (DVS.Vector a) where - type Model (DVS.Vector a) = [a] - model = DVS.toList - unmodel = DVS.fromList - - type EqTest (DVS.Vector a) = Property - equal x y = property (x == y) - -instance (Eq a, DVU.Unbox a) => TestData (DVU.Vector a) where - type Model (DVU.Vector a) = [a] - model = DVU.toList - unmodel = DVU.fromList - - type EqTest (DVU.Vector a) = Property - equal x y = property (x == y) - -#define id_TestData(ty) \ -instance TestData ty where { \ - type Model ty = ty; \ - model = id; \ - unmodel = id; \ - \ - type EqTest ty = Property; \ - equal x y = property (x == y) } - -id_TestData(()) -id_TestData(Bool) -id_TestData(Int) -id_TestData(Float) -id_TestData(Double) -id_TestData(Ordering) - --- Functorish models --- All of these need UndecidableInstances although they are actually well founded. Oh well. -instance (Eq a, TestData a) => TestData (Maybe a) where - type Model (Maybe a) = Maybe (Model a) - model = fmap model - unmodel = fmap unmodel - - type EqTest (Maybe a) = Property - equal x y = property (x == y) - -instance (Eq a, TestData a) => TestData [a] where - type Model [a] = [Model a] - model = fmap model - unmodel = fmap unmodel - - type EqTest [a] = Property - equal x y = property (x == y) - -instance (Eq a, TestData a) => TestData (Identity a) where - type Model (Identity a) = Identity (Model a) - model = fmap model - unmodel = fmap unmodel - - type EqTest (Identity a) = Property - equal = (property .) . on (==) runIdentity - -instance (Eq a, TestData a, Eq b, TestData b, Monoid a) => TestData (Writer a b) where - type Model (Writer a b) = Writer (Model a) (Model b) - model = mapWriter model - unmodel = mapWriter unmodel - - type EqTest (Writer a b) = Property - equal = (property .) . on (==) runWriter - -instance (Eq a, Eq b, TestData a, TestData b) => TestData (a,b) where - type Model (a,b) = (Model a, Model b) - model (a,b) = (model a, model b) - unmodel (a,b) = (unmodel a, unmodel b) - - type EqTest (a,b) = Property - equal x y = property (x == y) - -instance (Eq a, Eq b, Eq c, TestData a, TestData b, TestData c) => TestData (a,b,c) where - type Model (a,b,c) = (Model a, Model b, Model c) - model (a,b,c) = (model a, model b, model c) - unmodel (a,b,c) = (unmodel a, unmodel b, unmodel c) - - type EqTest (a,b,c) = Property - equal x y = property (x == y) - -instance (Arbitrary a, Show a, TestData a, TestData b) => TestData (a -> b) where - type Model (a -> b) = Model a -> Model b - model f = model . f . unmodel - unmodel f = unmodel . f . model - - type EqTest (a -> b) = a -> EqTest b - equal f g x = equal (f x) (g x) - -newtype P a = P { unP :: EqTest a } - -instance TestData a => Testable (P a) where - property (P a) = property a - -infix 4 `eq` -eq :: TestData a => a -> Model a -> P a -eq x y = P (equal x (unmodel y)) - -class Conclusion p where - type Predicate p - - predicate :: Predicate p -> p -> p - -instance Conclusion Property where - type Predicate Property = Bool - - predicate = (==>) - -instance Conclusion p => Conclusion (a -> p) where - type Predicate (a -> p) = a -> Predicate p - - predicate f p = \x -> predicate (f x) (p x) - -infixr 0 ===> -(===>) :: TestData a => Predicate (EqTest a) -> P a -> P a -p ===> P a = P (predicate p a) - -notNull2 _ xs = not $ DVG.null xs -notNullS2 _ s = not $ S.null s - --- Generators -index_value_pairs :: Arbitrary a => Int -> Gen [(Int,a)] -index_value_pairs 0 = return [] -index_value_pairs m = sized $ \n -> - do - len <- choose (0,n) - is <- sequence [choose (0,m-1) | i <- [1..len]] - xs <- vector len - return $ zip is xs - -indices :: Int -> Gen [Int] -indices 0 = return [] -indices m = sized $ \n -> - do - len <- choose (0,n) - sequence [choose (0,m-1) | i <- [1..len]] - - --- Additional list functions -singleton x = [x] -snoc xs x = xs ++ [x] -generate n f = [f i | i <- [0 .. n-1]] -slice i n xs = take n (drop i xs) -backpermute xs is = map (xs!!) is -prescanl f z = init . scanl f z -postscanl f z = tail . scanl f z -prescanr f z = tail . scanr f z -postscanr f z = init . scanr f z - -accum :: (a -> b -> a) -> [a] -> [(Int,b)] -> [a] -accum f xs ps = go xs ps' 0 - where - ps' = sortBy (\p q -> compare (fst p) (fst q)) ps - - go (x:xs) ((i,y) : ps) j - | i == j = go (f x y : xs) ps j - go (x:xs) ps j = x : go xs ps (j+1) - go [] _ _ = [] - -(//) :: [a] -> [(Int, a)] -> [a] -xs // ps = go xs ps' 0 - where - ps' = sortBy (\p q -> compare (fst p) (fst q)) ps - - go (x:xs) ((i,y) : ps) j - | i == j = go (y:xs) ps j - go (x:xs) ps j = x : go xs ps (j+1) - go [] _ _ = [] - - -withIndexFirst m f = m (uncurry f) . zip [0..] - -imap :: (Int -> a -> a) -> [a] -> [a] -imap = withIndexFirst map - -imapM :: Monad m => (Int -> a -> m a) -> [a] -> m [a] -imapM = withIndexFirst mapM - -imapM_ :: Monad m => (Int -> a -> m b) -> [a] -> m () -imapM_ = withIndexFirst mapM_ - -izipWith :: (Int -> a -> a -> a) -> [a] -> [a] -> [a] -izipWith = withIndexFirst zipWith - -izipWithM :: Monad m => (Int -> a -> a -> m a) -> [a] -> [a] -> m [a] -izipWithM = withIndexFirst zipWithM - -izipWithM_ :: Monad m => (Int -> a -> a -> m b) -> [a] -> [a] -> m () -izipWithM_ = withIndexFirst zipWithM_ - -izipWith3 :: (Int -> a -> a -> a -> a) -> [a] -> [a] -> [a] -> [a] -izipWith3 = withIndexFirst zipWith3 - -ifilter :: (Int -> a -> Bool) -> [a] -> [a] -ifilter f = map snd . withIndexFirst filter f - -mapMaybe :: (a -> Maybe b) -> [a] -> [b] -mapMaybe f = catMaybes . map f - -imapMaybe :: (Int -> a -> Maybe b) -> [a] -> [b] -imapMaybe f = catMaybes . withIndexFirst map f - -indexedLeftFold fld f z = fld (uncurry . f) z . zip [0..] - -ifoldl :: (a -> Int -> a -> a) -> a -> [a] -> a -ifoldl = indexedLeftFold foldl - -iscanl :: (Int -> a -> b -> a) -> a -> [b] -> [a] -iscanl f z = scanl (\a (i, b) -> f i a b) z . zip [0..] - -iscanr :: (Int -> a -> b -> b) -> b -> [a] -> [b] -iscanr f z = scanr (uncurry f) z . zip [0..] - -ifoldr :: (Int -> a -> b -> b) -> b -> [a] -> b -ifoldr f z = foldr (uncurry f) z . zip [0..] - -ifoldM :: Monad m => (a -> Int -> a -> m a) -> a -> [a] -> m a -ifoldM = indexedLeftFold foldM - -ifoldM_ :: Monad m => (b -> Int -> a -> m b) -> b -> [a] -> m () -ifoldM_ = indexedLeftFold foldM_ - -minIndex :: Ord a => [a] -> Int -minIndex = fst . foldr1 imin . zip [0..] - where - imin (i,x) (j,y) | x <= y = (i,x) - | otherwise = (j,y) - -maxIndex :: Ord a => [a] -> Int -maxIndex = fst . foldr1 imax . zip [0..] - where - imax (i,x) (j,y) | x >= y = (i,x) - | otherwise = (j,y) - -iterateNM :: Monad m => Int -> (a -> m a) -> a -> m [a] -iterateNM n f x - | n <= 0 = return [] - | n == 1 = return [x] - | otherwise = do x' <- f x - xs <- iterateNM (n-1) f x' - return (x : xs) - -unfoldrM :: Monad m => (b -> m (Maybe (a,b))) -> b -> m [a] -unfoldrM step b0 = do - r <- step b0 - case r of - Nothing -> return [] - Just (a,b) -> do as <- unfoldrM step b - return (a : as) - - -limitUnfolds f (theirs, ours) - | ours >= 0 - , Just (out, theirs') <- f theirs = Just (out, (theirs', ours - 1)) - | otherwise = Nothing diff --git a/third_party/bazel/rules_haskell/examples/vector/vector.cabal b/third_party/bazel/rules_haskell/examples/vector/vector.cabal deleted file mode 100644 index 013d522b2cb4..000000000000 --- a/third_party/bazel/rules_haskell/examples/vector/vector.cabal +++ /dev/null @@ -1,251 +0,0 @@ -Name: vector -Version: 0.12.0.1 -x-revision: 2 --- don't forget to update the changelog file! -License: BSD3 -License-File: LICENSE -Author: Roman Leshchinskiy <rl@cse.unsw.edu.au> -Maintainer: Haskell Libraries Team <libraries@haskell.org> -Copyright: (c) Roman Leshchinskiy 2008-2012 -Homepage: https://github.com/haskell/vector -Bug-Reports: https://github.com/haskell/vector/issues -Category: Data, Data Structures -Synopsis: Efficient Arrays -Description: - . - An efficient implementation of Int-indexed arrays (both mutable - and immutable), with a powerful loop optimisation framework . - . - It is structured as follows: - . - ["Data.Vector"] Boxed vectors of arbitrary types. - . - ["Data.Vector.Unboxed"] Unboxed vectors with an adaptive - representation based on data type families. - . - ["Data.Vector.Storable"] Unboxed vectors of 'Storable' types. - . - ["Data.Vector.Primitive"] Unboxed vectors of primitive types as - defined by the @primitive@ package. "Data.Vector.Unboxed" is more - flexible at no performance cost. - . - ["Data.Vector.Generic"] Generic interface to the vector types. - . - There is also a (draft) tutorial on common uses of vector. - . - * <http://haskell.org/haskellwiki/Numeric_Haskell:_A_Vector_Tutorial> - -Tested-With: - GHC == 7.4.2, - GHC == 7.6.3, - GHC == 7.8.4, - GHC == 7.10.3, - GHC == 8.0.1 - -Cabal-Version: >=1.10 -Build-Type: Simple - -Extra-Source-Files: - changelog - README.md - tests/LICENSE - tests/Setup.hs - tests/Main.hs - benchmarks/vector-benchmarks.cabal - benchmarks/LICENSE - benchmarks/Setup.hs - benchmarks/Main.hs - benchmarks/Algo/AwShCC.hs - benchmarks/Algo/HybCC.hs - benchmarks/Algo/Leaffix.hs - benchmarks/Algo/ListRank.hs - benchmarks/Algo/Quickhull.hs - benchmarks/Algo/Rootfix.hs - benchmarks/Algo/Spectral.hs - benchmarks/Algo/Tridiag.hs - benchmarks/TestData/Graph.hs - benchmarks/TestData/ParenTree.hs - benchmarks/TestData/Random.hs - changelog - internal/GenUnboxTuple.hs - internal/unbox-tuple-instances - -Flag BoundsChecks - Description: Enable bounds checking - Default: True - Manual: True - -Flag UnsafeChecks - Description: Enable bounds checking in unsafe operations at the cost of a - significant performance penalty - Default: False - Manual: True - -Flag InternalChecks - Description: Enable internal consistency checks at the cost of a - significant performance penalty - Default: False - Manual: True - -Flag Wall - Description: Enable all -Wall warnings - Default: False - Manual: True - -Library - Default-Language: Haskell2010 - Other-Extensions: - BangPatterns - CPP - DeriveDataTypeable - ExistentialQuantification - FlexibleContexts - FlexibleInstances - GADTs - KindSignatures - MagicHash - MultiParamTypeClasses - Rank2Types - ScopedTypeVariables - StandaloneDeriving - TypeFamilies - - Exposed-Modules: - Data.Vector.Internal.Check - - Data.Vector.Fusion.Util - Data.Vector.Fusion.Stream.Monadic - Data.Vector.Fusion.Bundle.Size - Data.Vector.Fusion.Bundle.Monadic - Data.Vector.Fusion.Bundle - - Data.Vector.Generic.Mutable.Base - Data.Vector.Generic.Mutable - Data.Vector.Generic.Base - Data.Vector.Generic.New - Data.Vector.Generic - - Data.Vector.Primitive.Mutable - Data.Vector.Primitive - - Data.Vector.Storable.Internal - Data.Vector.Storable.Mutable - Data.Vector.Storable - - Data.Vector.Unboxed.Base - Data.Vector.Unboxed.Mutable - Data.Vector.Unboxed - - Data.Vector.Mutable - Data.Vector - - Include-Dirs: - include, internal - - Install-Includes: - vector.h - - Build-Depends: base >= 4.5 && < 4.12 - , primitive >= 0.5.0.1 && < 0.7 - , ghc-prim >= 0.2 && < 0.6 - , deepseq >= 1.1 && < 1.5 - if !impl(ghc > 8.0) - Build-Depends: semigroups >= 0.18 && < 0.19 - - Ghc-Options: -O2 -Wall - - if !flag(Wall) - Ghc-Options: -fno-warn-orphans - - if impl(ghc >= 8.0) && impl(ghc < 8.1) - Ghc-Options: -Wno-redundant-constraints - - if flag(BoundsChecks) - cpp-options: -DVECTOR_BOUNDS_CHECKS - - if flag(UnsafeChecks) - cpp-options: -DVECTOR_UNSAFE_CHECKS - - if flag(InternalChecks) - cpp-options: -DVECTOR_INTERNAL_CHECKS - -source-repository head - type: git - location: https://github.com/haskell/vector.git - - - -test-suite vector-tests-O0 - Default-Language: Haskell2010 - type: exitcode-stdio-1.0 - Main-Is: Main.hs - - other-modules: Boilerplater - Tests.Bundle - Tests.Move - Tests.Vector - Tests.Vector.UnitTests - Utilities - - hs-source-dirs: tests - Build-Depends: base >= 4.5 && < 5, template-haskell, vector, - random, - QuickCheck >= 2.9 && < 2.10 , HUnit, test-framework, - test-framework-hunit, test-framework-quickcheck2, - transformers >= 0.2.0.0 - - default-extensions: CPP, - ScopedTypeVariables, - PatternGuards, - MultiParamTypeClasses, - FlexibleContexts, - Rank2Types, - TypeSynonymInstances, - TypeFamilies, - TemplateHaskell - - Ghc-Options: -O0 - Ghc-Options: -Wall - - if !flag(Wall) - Ghc-Options: -fno-warn-orphans -fno-warn-missing-signatures - if impl(ghc >= 8.0) && impl( ghc < 8.1) - Ghc-Options: -Wno-redundant-constraints - - -test-suite vector-tests-O2 - Default-Language: Haskell2010 - type: exitcode-stdio-1.0 - Main-Is: Main.hs - - other-modules: Boilerplater - Tests.Bundle - Tests.Move - Tests.Vector - Tests.Vector.UnitTests - Utilities - - hs-source-dirs: tests - Build-Depends: base >= 4.5 && < 5, template-haskell, vector, - random, - QuickCheck >= 2.9 && < 2.10 , HUnit, test-framework, - test-framework-hunit, test-framework-quickcheck2, - transformers >= 0.2.0.0 - - default-extensions: CPP, - ScopedTypeVariables, - PatternGuards, - MultiParamTypeClasses, - FlexibleContexts, - Rank2Types, - TypeSynonymInstances, - TypeFamilies, - TemplateHaskell - - Ghc-Options: -O2 -Wall - - if !flag(Wall) - Ghc-Options: -fno-warn-orphans -fno-warn-missing-signatures - if impl(ghc >= 8.0) && impl(ghc < 8.1) - Ghc-Options: -Wno-redundant-constraints - |