diff options
Diffstat (limited to 'third_party/bazel/rules_haskell/examples')
124 files changed, 33312 insertions, 0 deletions
diff --git a/third_party/bazel/rules_haskell/examples/.bazelrc b/third_party/bazel/rules_haskell/examples/.bazelrc new file mode 120000 index 000000000000..adb61980d232 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/.bazelrc @@ -0,0 +1 @@ +../.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 new file mode 100644 index 000000000000..a6ef824c1f83 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/.gitignore @@ -0,0 +1 @@ +/bazel-* diff --git a/third_party/bazel/rules_haskell/examples/BUILD.bazel b/third_party/bazel/rules_haskell/examples/BUILD.bazel new file mode 100644 index 000000000000..ff7445a2f7c3 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/BUILD.bazel @@ -0,0 +1,10 @@ +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 new file mode 100644 index 000000000000..7b477f547619 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/README.md @@ -0,0 +1,45 @@ +# 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 new file mode 100644 index 000000000000..1e99f221190a --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/WORKSPACE @@ -0,0 +1,58 @@ +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 new file mode 100644 index 000000000000..798e55f29be7 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/BUILD.bazel @@ -0,0 +1,33 @@ +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 new file mode 100644 index 000000000000..f182c18b086b --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Control/Monad/Primitive.hs @@ -0,0 +1,298 @@ +{-# 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 new file mode 100644 index 000000000000..db545ed81514 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive.hs @@ -0,0 +1,85 @@ +{-# 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 new file mode 100644 index 000000000000..2ff25005c6aa --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Addr.hs @@ -0,0 +1,133 @@ +{-# 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 new file mode 100644 index 000000000000..13352f6cb444 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Array.hs @@ -0,0 +1,822 @@ +{-# 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 new file mode 100644 index 000000000000..527205330b8b --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/ByteArray.hs @@ -0,0 +1,549 @@ +{-# 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 new file mode 100644 index 000000000000..f6b8016ad92a --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Compat.hs @@ -0,0 +1,38 @@ +{-# 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 new file mode 100644 index 000000000000..091e11f5d6a9 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Internal/Operations.hs @@ -0,0 +1,90 @@ +{-# 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 new file mode 100644 index 000000000000..3c7bfd1fa054 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MVar.hs @@ -0,0 +1,155 @@ +{-# 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 new file mode 100644 index 000000000000..d36c25236413 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MachDeps.hs @@ -0,0 +1,123 @@ +{-# 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 new file mode 100644 index 000000000000..f707bfb6308c --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/MutVar.hs @@ -0,0 +1,86 @@ +{-# 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 new file mode 100644 index 000000000000..33d81c2092ee --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/PrimArray.hs @@ -0,0 +1,969 @@ +{-# 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 new file mode 100644 index 000000000000..d93ae9ac114d --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Ptr.hs @@ -0,0 +1,125 @@ +{-# 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 new file mode 100644 index 000000000000..3a50cf218380 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/SmallArray.hs @@ -0,0 +1,967 @@ +{-# 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 new file mode 100644 index 000000000000..fd36ea0c9455 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/Types.hs @@ -0,0 +1,395 @@ +{-# 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 new file mode 100644 index 000000000000..75a4847364dc --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Data/Primitive/UnliftedArray.hs @@ -0,0 +1,638 @@ +{-# 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 new file mode 100644 index 000000000000..fc213a6ffbfe --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/LICENSE @@ -0,0 +1,30 @@ +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 new file mode 100644 index 000000000000..200a2e51d0b4 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/Setup.hs @@ -0,0 +1,3 @@ +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 new file mode 100644 index 000000000000..81b1d6f57530 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/cbits/primitive-memops.c @@ -0,0 +1,56 @@ +#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 new file mode 100644 index 000000000000..d7c3396f8f8b --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/cbits/primitive-memops.h @@ -0,0 +1,23 @@ +#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 new file mode 100644 index 000000000000..53485f664428 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/changelog.md @@ -0,0 +1,164 @@ +## 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 new file mode 100644 index 000000000000..e370f6d005a1 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/primitive.cabal @@ -0,0 +1,74 @@ +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 new file mode 100644 index 000000000000..fc213a6ffbfe --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/test/LICENSE @@ -0,0 +1,30 @@ +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 new file mode 100644 index 000000000000..abec96df032d --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/test/main.hs @@ -0,0 +1,342 @@ +{-# 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 new file mode 100644 index 000000000000..957fe5ee1f64 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/primitive/test/primitive-tests.cabal @@ -0,0 +1,45 @@ +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 new file mode 100644 index 000000000000..1bbf94b1c0a9 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/rts/BUILD.bazel @@ -0,0 +1,29 @@ +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 new file mode 100644 index 000000000000..bc24fb7cb274 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/rts/One.hs @@ -0,0 +1,6 @@ +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 new file mode 100644 index 000000000000..28624227d8c0 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/rts/main.c @@ -0,0 +1,11 @@ +#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 new file mode 100644 index 000000000000..092111f9f19a --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/BUILD.bazel @@ -0,0 +1,19 @@ +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 new file mode 100644 index 000000000000..7ed74acbace0 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Applicative/Backwards.hs @@ -0,0 +1,112 @@ +{-# 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 new file mode 100644 index 000000000000..8d35e288c025 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Applicative/Lift.hs @@ -0,0 +1,165 @@ +{-# 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 new file mode 100644 index 000000000000..ce128ee182e1 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Signatures.hs @@ -0,0 +1,56 @@ +{-# 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 new file mode 100644 index 000000000000..0a85c43f62bb --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Accum.hs @@ -0,0 +1,292 @@ +{-# 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 new file mode 100644 index 000000000000..b92bc0e8b0f6 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Class.hs @@ -0,0 +1,262 @@ +{-# 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 new file mode 100644 index 000000000000..ce2005d4b29f --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Cont.hs @@ -0,0 +1,240 @@ +{-# 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 new file mode 100644 index 000000000000..6eda4b3e015a --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Error.hs @@ -0,0 +1,333 @@ +{-# 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 new file mode 100644 index 000000000000..477b9dd4826c --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Except.hs @@ -0,0 +1,316 @@ +{-# 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 new file mode 100644 index 000000000000..2a0db5e5a165 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Identity.hs @@ -0,0 +1,188 @@ +{-# 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 new file mode 100644 index 000000000000..0bdbcc732e83 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/List.hs @@ -0,0 +1,185 @@ +{-# 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 new file mode 100644 index 000000000000..f02b225444f8 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Maybe.hs @@ -0,0 +1,241 @@ +{-# 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 new file mode 100644 index 000000000000..b4cc6adaad78 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS.hs @@ -0,0 +1,25 @@ +{-# 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 new file mode 100644 index 000000000000..8a565e1652c3 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/CPS.hs @@ -0,0 +1,406 @@ +{-# 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 new file mode 100644 index 000000000000..8f98b2c5e05a --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/Lazy.hs @@ -0,0 +1,389 @@ +{-# 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 new file mode 100644 index 000000000000..557dd2028dd0 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/RWS/Strict.hs @@ -0,0 +1,392 @@ +{-# 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 new file mode 100644 index 000000000000..25e3ad27c3c6 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Reader.hs @@ -0,0 +1,262 @@ +{-# 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 new file mode 100644 index 000000000000..22fdf8fd8abc --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Select.hs @@ -0,0 +1,161 @@ +{-# 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 new file mode 100644 index 000000000000..36de964ea1d3 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State.hs @@ -0,0 +1,33 @@ +{-# 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 new file mode 100644 index 000000000000..d7cdde5444a8 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State/Lazy.hs @@ -0,0 +1,428 @@ +{-# 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 new file mode 100644 index 000000000000..d0fb58edb4cf --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/State/Strict.hs @@ -0,0 +1,425 @@ +{-# 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 new file mode 100644 index 000000000000..f45f4d27687c --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer.hs @@ -0,0 +1,25 @@ +{-# 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 new file mode 100644 index 000000000000..28951016cf81 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/CPS.hs @@ -0,0 +1,283 @@ +{-# 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 new file mode 100644 index 000000000000..d12b0e7d583c --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/Lazy.hs @@ -0,0 +1,313 @@ +{-# 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 new file mode 100644 index 000000000000..f39862c02044 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Control/Monad/Trans/Writer/Strict.hs @@ -0,0 +1,316 @@ +{-# 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 new file mode 100644 index 000000000000..9c0b8d42dcad --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Data/Functor/Constant.hs @@ -0,0 +1,152 @@ +{-# 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 new file mode 100644 index 000000000000..5d8c41fa15c1 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Data/Functor/Reverse.hs @@ -0,0 +1,143 @@ +{-# 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 new file mode 100644 index 000000000000..92337b951eb0 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/LICENSE @@ -0,0 +1,31 @@ +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 new file mode 100644 index 000000000000..9a994af677b0 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/Setup.hs @@ -0,0 +1,2 @@ +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 new file mode 100644 index 000000000000..5dd688f35b78 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/changelog @@ -0,0 +1,124 @@ +-*-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 new file mode 100644 index 000000000000..940e4e470f47 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre709/Data/Functor/Identity.hs @@ -0,0 +1,259 @@ +{-# 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 new file mode 100644 index 000000000000..7c74d4ef0d71 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Control/Monad/IO/Class.hs @@ -0,0 +1,51 @@ +{-# 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 new file mode 100644 index 000000000000..bda1749643d1 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Classes.hs @@ -0,0 +1,529 @@ +{-# 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 new file mode 100644 index 000000000000..ed781309aff8 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Compose.hs @@ -0,0 +1,154 @@ +{-# 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 new file mode 100644 index 000000000000..ba0dc0407e00 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Product.hs @@ -0,0 +1,156 @@ +{-# 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 new file mode 100644 index 000000000000..e6d1428b30e3 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/legacy/pre711/Data/Functor/Sum.hs @@ -0,0 +1,136 @@ +{-# 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 new file mode 100644 index 000000000000..945adda910fd --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/transformers/transformers.cabal @@ -0,0 +1,91 @@ +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 new file mode 100644 index 000000000000..7c00806efe5f --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/BUILD.bazel @@ -0,0 +1,38 @@ +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 new file mode 100644 index 000000000000..21b61960ca40 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector.hs @@ -0,0 +1,1719 @@ +{-# 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 new file mode 100644 index 000000000000..6b6b6236d7cb --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Bundle.hs @@ -0,0 +1,655 @@ +{-# 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 new file mode 100644 index 000000000000..46f4a165f88d --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Bundle/Monadic.hs @@ -0,0 +1,1106 @@ +{-# 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 new file mode 100644 index 000000000000..e90cf373202d --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Bundle/Size.hs @@ -0,0 +1,121 @@ +-- | +-- 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 new file mode 100644 index 000000000000..cca002ca6f74 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Stream/Monadic.hs @@ -0,0 +1,1639 @@ +{-# 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 new file mode 100644 index 000000000000..855bf5ddd40d --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Fusion/Util.hs @@ -0,0 +1,60 @@ +{-# 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 new file mode 100644 index 000000000000..066c07fd3d1d --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic.hs @@ -0,0 +1,2206 @@ +{-# 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 new file mode 100644 index 000000000000..a760329c599f --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/Base.hs @@ -0,0 +1,140 @@ +{-# 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 new file mode 100644 index 000000000000..89bebf360765 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/Mutable.hs @@ -0,0 +1,1034 @@ +{-# 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 new file mode 100644 index 000000000000..ce931eec9b41 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/Mutable/Base.hs @@ -0,0 +1,145 @@ +{-# 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 new file mode 100644 index 000000000000..e94ce19e1669 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Generic/New.hs @@ -0,0 +1,178 @@ +{-# 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 new file mode 100644 index 000000000000..4a4ef80fe172 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Internal/Check.hs @@ -0,0 +1,152 @@ +{-# 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 new file mode 100644 index 000000000000..ba701afb6a19 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Mutable.hs @@ -0,0 +1,416 @@ +{-# 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 new file mode 100644 index 000000000000..ba18f9ba957f --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Primitive.hs @@ -0,0 +1,1393 @@ +{-# 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 new file mode 100644 index 000000000000..33aca812e208 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Primitive/Mutable.hs @@ -0,0 +1,366 @@ +{-# 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 new file mode 100644 index 000000000000..30c9a4615c60 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Storable.hs @@ -0,0 +1,1489 @@ +{-# 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 new file mode 100644 index 000000000000..69a46d84215b --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Storable/Internal.hs @@ -0,0 +1,33 @@ +-- | +-- 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 new file mode 100644 index 000000000000..29eb2fbfa31e --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Storable/Mutable.hs @@ -0,0 +1,543 @@ +{-# 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 new file mode 100644 index 000000000000..72dd109fb3b4 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Unboxed.hs @@ -0,0 +1,1488 @@ +{-# 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 new file mode 100644 index 000000000000..a88795c5b4bc --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Unboxed/Base.hs @@ -0,0 +1,408 @@ +{-# 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 new file mode 100644 index 000000000000..cb82acea8f87 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Data/Vector/Unboxed/Mutable.hs @@ -0,0 +1,307 @@ +{-# 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 new file mode 100644 index 000000000000..cafa68efb33e --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/LICENSE @@ -0,0 +1,30 @@ +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 new file mode 100644 index 000000000000..079dbd0b6b93 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/README.md @@ -0,0 +1,6 @@ +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 new file mode 100644 index 000000000000..200a2e51d0b4 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/Setup.hs @@ -0,0 +1,3 @@ +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 new file mode 100644 index 000000000000..404e289fae15 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/AwShCC.hs @@ -0,0 +1,38 @@ +{-# 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 new file mode 100644 index 000000000000..876d08f75b62 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/HybCC.hs @@ -0,0 +1,42 @@ +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 new file mode 100644 index 000000000000..40ec517556fe --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Leaffix.hs @@ -0,0 +1,16 @@ +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 new file mode 100644 index 000000000000..933bd8eb2ec9 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/ListRank.hs @@ -0,0 +1,21 @@ +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 new file mode 100644 index 000000000000..694bea3097a3 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Quickhull.hs @@ -0,0 +1,32 @@ +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 new file mode 100644 index 000000000000..1b112a801a5e --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Rootfix.hs @@ -0,0 +1,15 @@ +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 new file mode 100644 index 000000000000..811c58269e84 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Spectral.hs @@ -0,0 +1,21 @@ +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 new file mode 100644 index 000000000000..7668deace132 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Algo/Tridiag.hs @@ -0,0 +1,16 @@ +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 new file mode 100644 index 000000000000..fc213a6ffbfe --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/LICENSE @@ -0,0 +1,30 @@ +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 new file mode 100644 index 000000000000..65bd297a7552 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Main.hs @@ -0,0 +1,46 @@ +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 new file mode 100644 index 000000000000..200a2e51d0b4 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/Setup.hs @@ -0,0 +1,3 @@ +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 new file mode 100644 index 000000000000..8b8ca837b890 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/TestData/Graph.hs @@ -0,0 +1,45 @@ +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 new file mode 100644 index 000000000000..4aeb750954a9 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/TestData/ParenTree.hs @@ -0,0 +1,20 @@ +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 new file mode 100644 index 000000000000..f9b741fb97ae --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/TestData/Random.hs @@ -0,0 +1,16 @@ +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 new file mode 100644 index 000000000000..3e825c0fa4e6 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/benchmarks/vector-benchmarks.cabal @@ -0,0 +1,37 @@ +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 new file mode 100644 index 000000000000..3d824b74d123 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/changelog @@ -0,0 +1,75 @@ +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 new file mode 100644 index 000000000000..1568bb290633 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/include/vector.h @@ -0,0 +1,20 @@ +#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 new file mode 100644 index 000000000000..8debff23a975 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/internal/GenUnboxTuple.hs @@ -0,0 +1,239 @@ +{-# 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 new file mode 100644 index 000000000000..6fb88d4a4047 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/internal/unbox-tuple-instances @@ -0,0 +1,1134 @@ +#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 new file mode 100644 index 000000000000..5506209ebc01 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/Boilerplater.hs @@ -0,0 +1,27 @@ +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 new file mode 100644 index 000000000000..43c0cee637be --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/LICENSE @@ -0,0 +1,30 @@ +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 new file mode 100644 index 000000000000..6642888323fd --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/Main.hs @@ -0,0 +1,15 @@ +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 new file mode 100644 index 000000000000..200a2e51d0b4 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/Setup.hs @@ -0,0 +1,3 @@ +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 new file mode 100644 index 000000000000..09368a199971 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Bundle.hs @@ -0,0 +1,163 @@ +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 new file mode 100644 index 000000000000..60ea8d334600 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Move.hs @@ -0,0 +1,49 @@ +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 new file mode 100644 index 000000000000..46569d909549 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Vector.hs @@ -0,0 +1,706 @@ +{-# 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 new file mode 100644 index 000000000000..5827640d8438 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/Tests/Vector/UnitTests.hs @@ -0,0 +1,48 @@ +{-# 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 new file mode 100644 index 000000000000..86a4f2c32462 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/tests/Utilities.hs @@ -0,0 +1,350 @@ +{-# 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 new file mode 100644 index 000000000000..013d522b2cb4 --- /dev/null +++ b/third_party/bazel/rules_haskell/examples/vector/vector.cabal @@ -0,0 +1,251 @@ +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 + |