diff --git a/cbits/missing_r.c b/cbits/missing_r.c --- a/cbits/missing_r.c +++ b/cbits/missing_r.c @@ -4,16 +4,27 @@ #include #include -void freeHsSEXP(SEXP extPtr) { - hs_free_fun_ptr(R_ExternalPtrAddr(extPtr)); +static void freeHsSEXP(SEXP extPtr) +{ + hs_free_fun_ptr(R_ExternalPtrAddr(extPtr)); } -SEXP funPtrToSEXP(DL_FUNC pf) { - SEXP value; - PROTECT(value = R_MakeExternalPtr(pf, install("native symbol"), R_NilValue)); - R_RegisterCFinalizerEx(value, freeHsSEXP, TRUE); - UNPROTECT(1); - return value; +SEXP funPtrToSEXP(DL_FUNC pf) +{ + static SEXP callsym, functionsym, nativesym; + if(!callsym) callsym = install(".Call"); + if(!functionsym) functionsym = install("function"); + if(!nativesym) nativesym = install("native symbol"); + SEXP value, formals; + + PROTECT(value = R_MakeExternalPtr(pf, nativesym, R_NilValue)); + R_RegisterCFinalizerEx(value, freeHsSEXP, TRUE); + PROTECT(value = lang3(callsym, value, R_DotsSymbol)); + PROTECT(formals = CONS(R_MissingArg, R_NilValue)); + SET_TAG(formals, R_DotsSymbol); + PROTECT(value = lang4(functionsym, formals, value, R_NilValue)); + UNPROTECT(4); + return value; } // XXX Initializing isRInitialized to 0 here causes GHCi to fail with diff --git a/cbits/missing_r.h b/cbits/missing_r.h --- a/cbits/missing_r.h +++ b/cbits/missing_r.h @@ -7,12 +7,13 @@ #include #include +/* Create a variadic R function given any function pointer. */ SEXP funPtrToSEXP(DL_FUNC pf); -// Indicates whether R has been initialized. +/* Indicates whether R has been initialized. */ extern int isRInitialized; -// R global variables for GHCi. +/* R global variables for GHCi. */ extern HsStablePtr rVariables; #endif diff --git a/inline-r.cabal b/inline-r.cabal --- a/inline-r.cabal +++ b/inline-r.cabal @@ -1,5 +1,5 @@ name: inline-r -version: 0.7.3.0 +version: 0.8.0.0 license: BSD3 license-file: LICENSE copyright: Copyright (c) 2013-2015 Amgen, Inc. @@ -59,17 +59,20 @@ Language.R.Globals Language.R.HExp Language.R.Instance - Language.R.Internal - Language.R.Internal.FunWrappers - Language.R.Internal.FunWrappers.TH Language.R.Literal Language.R.QQ Control.Memory.Region other-modules: Control.Monad.R.Class + Control.Monad.R.Internal + Data.Vector.SEXP.Mutable.Internal Internal.Error + Language.R.Internal + Language.R.Internal.FunWrappers + Language.R.Internal.FunWrappers.TH build-depends: base >= 4.7 && < 5 , aeson >= 0.6 , bytestring >= 0.10 + , containers >= 0.5 , data-default-class , deepseq >= 1.3 , exceptions >= 0.6 && < 1.1 @@ -77,6 +80,7 @@ , pretty >= 1.1 , primitive >= 0.5 , process >= 1.2 + , reflection >= 2 , setenv >= 0.1.1 , singletons >= 0.9 , template-haskell >= 2.8 @@ -84,7 +88,7 @@ , th-lift >= 0.6 , th-orphans >= 0.8 , transformers >= 0.3 - , vector >= 0.10 && < 0.11 + , vector >= 0.10 && < 0.12 hs-source-dirs: src includes: cbits/missing_r.h c-sources: cbits/missing_r.c @@ -124,7 +128,8 @@ , quickcheck-assertions >= 0.1.1 , singletons >= 0.10 , strict >= 0.3.2 - , tasty >= 0.3 + , tasty >= 0.11 + , tasty-expected-failure >= 0.11 , tasty-golden >= 2.3 , tasty-hunit >= 0.4.1 , tasty-quickcheck >= 0.4.1 @@ -136,7 +141,6 @@ Test.FunPtr Test.Constraints Test.Event - Test.HExp Test.Regions Test.Vector -- Adding -j4 causes quasiquoters to be compiled concurrently diff --git a/src/Control/Memory/Region.hs b/src/Control/Memory/Region.hs --- a/src/Control/Memory/Region.hs +++ b/src/Control/Memory/Region.hs @@ -11,13 +11,13 @@ module Control.Memory.Region where -import GHC.Exts (Constraint) +import GHC.Exts (Constraint, RealWorld) -- | The global region is a special region whose scope extends all the way to -- the end of the program. As such, any object allocated within this region -- lives "forever". In this sense, it is the top-level region, whose scope -- includes all other regions. -data GlobalRegion +type GlobalRegion = RealWorld -- | Void is not a region. It is a placeholder marking the absence of region. -- Useful to tag objects that belong to no region at all. diff --git a/src/Control/Monad/R/Class.hs b/src/Control/Monad/R/Class.hs --- a/src/Control/Monad/R/Class.hs +++ b/src/Control/Monad/R/Class.hs @@ -6,6 +6,7 @@ {-# LANGUAGE DefaultSignatures #-} module Control.Monad.R.Class ( MonadR(..) + , Region , acquireSome ) where @@ -15,16 +16,15 @@ import Control.Applicative import Control.Monad.Catch (MonadCatch, MonadMask) import Control.Monad.Trans (MonadIO(..)) +import Control.Monad.Primitive (PrimMonad, PrimState) import Prelude -- | The class of R interaction monads. For safety, in compiled code we normally -- use the 'Language.R.Instance.R' monad. For convenience, in a GHCi session, we -- normally use the 'IO' monad directly (by means of a 'MonadR' instance for -- 'IO', imported only in GHCi). -class (Applicative m, MonadIO m, MonadCatch m, MonadMask m) => MonadR m where - type Region m :: * - type Region m = G - +class (Applicative m, MonadIO m, MonadCatch m, MonadMask m, PrimMonad m) + => MonadR m where -- | Lift an 'IO' action. io :: IO a -> m a io = liftIO @@ -35,6 +35,19 @@ acquire :: SEXP V a -> m (SEXP (Region m) a) default acquire :: (MonadIO m, Region m ~ G) => SEXP s a -> m (SEXP G a) acquire = liftIO . protect + + -- | A reification of an R execution context, i.e. a "session". + data ExecContext m :: * + + -- | Get the current execution context. + getExecContext :: m (ExecContext m) + + -- | Provides no static guarantees that resources do not extrude the scope of + -- their region. Acquired resources are not freed automatically upon exit. + -- For internal use only. + unsafeRunWithExecContext :: m a -> ExecContext m -> IO a + +type Region m = PrimState m -- | 'acquire' for 'SomeSEXP'. acquireSome :: (MonadR m) => SomeSEXP V -> m (SomeSEXP (Region m)) diff --git a/src/Control/Monad/R/Internal.hs b/src/Control/Monad/R/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/R/Internal.hs @@ -0,0 +1,25 @@ +-- | +-- Copyright: (C) 2016 Tweag I/O Limited. + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Control.Monad.R.Internal where + +import Control.Memory.Region +import Control.Monad.R.Class +import Data.Proxy (Proxy(..)) +import Data.Reflection (Reifies, reify) +import Foreign.R (SEXP) + +newtype AcquireIO s = AcquireIO (forall ty. SEXP V ty -> IO (SEXP s ty)) + +withAcquire + :: forall m r. + (MonadR m) + => (forall s. Reifies s (AcquireIO (Region m)) => Proxy s -> m r) + -> m r +withAcquire f = do + cxt <- getExecContext + reify (AcquireIO (\sx -> unsafeRunWithExecContext (acquire sx) cxt)) f diff --git a/src/Data/Vector/SEXP.chs b/src/Data/Vector/SEXP.chs deleted file mode 100644 --- a/src/Data/Vector/SEXP.chs +++ /dev/null @@ -1,1528 +0,0 @@ --- | --- Copyright: (C) 2013 Amgen, Inc. --- --- Vectors that can be passed to and from R with no copying at all. These --- vectors are an instance of "Data.Vector.Storable", where the memory is --- allocated from the R heap, in such a way that they can be converted to --- a 'SEXP' through simple pointer arithmetic (see 'toSEXP') /in constant time/. --- --- The main difference between "Data.Vector.SEXP" and "Data.Vector.Storable" is --- that the former uses a header-prefixed data layout (the header immediately --- precedes the payload of the vector). This means that no additional pointer --- dereferencing is needed to reach the vector data. The trade-off is that most --- slicing operations are O(N) instead of O(1). --- --- If you make heavy use of slicing, then it's best to convert to --- a "Data.Vector.Storable" vector first, using 'unsafeToStorable'. --- --- Note that since 'unstream' relies on slicing operations, it will still be an --- O(N) operation but it will copy vector data twice (instead of once). - -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module Data.Vector.SEXP - ( Vector(..) - , Mutable.MVector(..) - , ElemRep - , VECTOR - , Data.Vector.SEXP.fromSEXP - , unsafeFromSEXP - , Data.Vector.SEXP.toSEXP - , unsafeToSEXP - - -- * Accessors - -- ** Length information - , length - , null - -- ** Indexing - , (!) - , (!?) - , head - , last - , unsafeIndex - , unsafeHead - , unsafeLast - -- ** Monadic indexing - , indexM - , headM - , lastM - , unsafeIndexM - , unsafeHeadM - , unsafeLastM - -- ** Extracting subvectors (slicing) - , slice - , init - , take - , drop - , tail - , splitAt - , unsafeTail - , unsafeSlice - , unsafeDrop - , unsafeTake - , unsafeInit - - -- * Construction - -- ** Initialisation - , empty - , singleton - , replicate - , generate - , iterateN - -- ** Monadic initialisation - , replicateM - , generateM - , create - -- ** Unfolding - , unfoldr - , unfoldrN - , 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 - , 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 - -- ** Mutable vectors - , freeze - , thaw - , copy - , unsafeFreeze - , unsafeThaw - , unsafeCopy - - -- ** SEXP specific - , toString - , toByteString - , fromStorable - , unsafeToStorable - ) where - -import Data.Vector.SEXP.Base -import Data.Vector.SEXP.Mutable (MVector(..)) -import qualified Data.Vector.SEXP.Mutable as Mutable -import Foreign.R ( SEXP ) -import qualified Foreign.R as R -import Foreign.R.Type ( SEXPTYPE(Char) ) - -import Control.Monad.Primitive ( PrimMonad, PrimState ) -import Control.Monad.ST (ST) -import qualified Data.Vector.Generic as G -import qualified Data.Vector.Fusion.Stream as Stream -import qualified Data.Vector.Storable as Storable -import Data.ByteString ( ByteString ) -import qualified Data.ByteString.Unsafe as B - -import Control.Applicative ((<$>)) -import Control.Monad ( liftM ) -import Control.Monad.Primitive ( unsafeInlineIO, unsafePrimToPrim ) -import Data.Word ( Word8 ) --- import Data.Int ( Int32 ) -import Foreign ( Ptr, plusPtr, castPtr ) -import Foreign.C -import Foreign.Storable -import Foreign.Marshal.Array ( copyArray ) -#if __GLASGOW_HASKELL__ >= 708 -import qualified GHC.Exts as Exts -#endif - -import Prelude - ( Eq(..) - , Enum - , Monad(..) - , Num(..) - , Ord(..) - , Show(..) - , Bool - , Int - , IO - , Maybe - , Ordering - , String - , (.) - , ($) - , ($!) - , (=<<) - , all - , and - , any - , fromIntegral - , or - , seq - , uncurry - ) -import qualified Prelude - -#include -#define USE_RINTERNALS -#include - --- | Immutable vectors. The second type paramater is a phantom parameter --- reflecting at the type level the tag of the vector when viewed as a 'SEXP'. --- The tag of the vector and the representation type are related via 'ElemRep'. -newtype Vector s (ty :: SEXPTYPE) a = Vector { unVector :: SEXP s ty } - -type instance G.Mutable (Vector r ty) = MVector r ty - -instance (Eq a, VECTOR s ty a) => Eq (Vector s ty a) where - a == b = toList a == toList b - -instance (Show a, VECTOR s ty a) => Show (Vector s ty a) where - show v = "fromList " Prelude.++ showList (toList v) "" - -instance (VECTOR s ty a) - => G.Vector (Vector s ty) a where - basicUnsafeFreeze (MVector s) = return (Vector s) - basicUnsafeThaw (Vector s) = return (MVector s) - basicLength (Vector s) = - unsafeInlineIO $ - fromIntegral <$> -- ({# get VECSEXP->vecsxp.length #} (R.unsexp s) :: IO Int32) - ((\ ptr -> do { peekByteOff ptr 32 :: IO CInt }) (R.unsexp s)) - -- XXX Basic unsafe slice is O(N) complexity as it allocates a copy of - -- a vector, due to limitations of R's VECSXP structure, which we reuse - -- directly. - basicUnsafeSlice i l v = unsafeInlineIO $ do - mv <- Mutable.new l - copyArray (toMVecPtr mv) - (toVecPtr v `plusPtr` i) - l - G.basicUnsafeFreeze mv - basicUnsafeIndexM v i = return . unsafeInlineIO - $ peekElemOff (toVecPtr v) i - basicUnsafeCopy mv v = unsafePrimToPrim $ - copyArray (toMVecPtr mv) - (toVecPtr v) - (G.basicLength v) - - elemseq _ = seq - -#if __GLASGOW_HASKELL__ >= 708 -instance VECTOR s ty a => Exts.IsList (Vector s ty a) where - type Item (Vector s ty a) = a - fromList = fromList - fromListN = fromListN - toList = toList -#endif - -toVecPtr :: Vector s ty a -> Ptr a -toVecPtr mv = castPtr (R.unsafeSEXPToVectorPtr $ unVector mv) - -toMVecPtr :: MVector s ty r a -> Ptr a -toMVecPtr mv = castPtr (R.unsafeSEXPToVectorPtr $ unMVector mv) - --- | /O(n)/ Create an immutable vector from a 'SEXP'. Because 'SEXP's are --- mutable, this function yields an immutable /copy/ of the 'SEXP'. -fromSEXP :: (VECTOR s ty a, PrimMonad m) - => SEXP s ty - -> m (Vector s ty a) -fromSEXP s = G.freeze (Mutable.fromSEXP s) - --- | /O(1)/ Unsafe convert a mutable 'SEXP' to an immutable vector without --- copying. The mutable vector must not be used after this operation, lest one --- runs the risk of breaking referential transparency. -unsafeFromSEXP :: VECTOR s ty a - => SEXP s ty - -> Vector s ty a -unsafeFromSEXP s = Vector s - --- | /O(n)/ Yield a (mutable) copy of the vector as a 'SEXP'. -toSEXP :: (VECTOR s ty a, PrimMonad m) - => Vector s ty a - -> m (SEXP s ty) -toSEXP = liftM Mutable.toSEXP . G.thaw - --- | /O(1)/ Unsafely convert an immutable vector to a (mutable) 'SEXP' without --- copying. The immutable vector must not be used after this operation. -unsafeToSEXP :: (VECTOR s ty a, PrimMonad m) - => Vector s ty a - -> m (SEXP s ty) -unsafeToSEXP = liftM Mutable.toSEXP . G.unsafeThaw - --- | /O(n)/ Convert a character vector into a 'String'. -toString :: Vector s 'Char Word8 -> String -toString v = unsafeInlineIO $ peekCString . castPtr - . R.unsafeSEXPToVectorPtr - . unVector $ v - --- | /O(1)/ Convert a character vector into a strict 'ByteString'. -toByteString :: Vector s 'Char Word8 -> ByteString -toByteString v@(Vector p) = unsafeInlineIO - $ B.unsafePackCStringLen (castPtr $! R.unsafeSEXPToVectorPtr p, G.length v) - ------------------------------------------------------------------------- --- Vector API --- - ------------------------------------------------------------------------- --- Length ------------------------------------------------------------------------- - --- | /O(1)/ Yield the length of the vector. -length :: VECTOR s ty a => Vector s ty a -> Int -{-# INLINE length #-} -length = G.length - --- | /O(1)/ Test whether a vector if empty -null :: VECTOR s ty a => Vector s ty a -> Bool -{-# INLINE null #-} -null = G.null - - ------------------------------------------------------------------------- --- Indexing ------------------------------------------------------------------------- - --- | O(1) Indexing -(!) :: VECTOR s ty a => Vector s ty a -> Int -> a -{-# INLINE (!) #-} -(!) = (G.!) - --- | O(1) Safe indexing -(!?) :: VECTOR s ty a => Vector s ty a -> Int -> Maybe a -{-# INLINE (!?) #-} -(!?) = (G.!?) - --- | /O(1)/ First element -head :: VECTOR s ty a => Vector s ty a -> a -{-# INLINE head #-} -head = G.head - --- | /O(1)/ Last element -last :: VECTOR s ty a => Vector s ty a -> a -{-# INLINE last #-} -last = G.last - --- | /O(1)/ Unsafe indexing without bounds checking -unsafeIndex :: VECTOR s ty a => Vector s ty a -> Int -> a -{-# INLINE unsafeIndex #-} -unsafeIndex = G.unsafeIndex - --- | /O(1)/ First element without checking if the vector is empty -unsafeHead :: VECTOR s ty a => Vector s ty a -> a -{-# INLINE unsafeHead #-} -unsafeHead = G.unsafeHead - --- | /O(1)/ Last element without checking if the vector is empty -unsafeLast :: VECTOR s ty a => Vector s ty 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 :: (VECTOR s ty a, Monad m) => Vector s ty 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 :: (VECTOR s ty a, Monad m) => Vector s ty 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 :: (VECTOR s ty a, Monad m) => Vector s ty 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 :: (VECTOR s ty a, Monad m) => Vector s ty 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 :: (VECTOR s ty a, Monad m) => Vector s ty 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 :: (VECTOR s ty a, Monad m) => Vector s ty a -> m a -{-# INLINE unsafeLastM #-} -unsafeLastM = G.unsafeLastM - ------------------------------------------------------------------------- --- Extracting subvectors (slicing) ------------------------------------------------------------------------- - --- | /O(N)/ Yield a slice of the vector with copying it. The vector must --- contain at least @i+n@ elements. -slice :: VECTOR s ty a - => Int -- ^ @i@ starting index - -> Int -- ^ @n@ length - -> Vector s ty a - -> Vector s ty a -{-# INLINE slice #-} -slice = G.slice - --- | /O(N)/ Yield all but the last element, this operation will copy an array. --- The vector may not be empty. -init :: VECTOR s ty a => Vector s ty a -> Vector s ty a -{-# INLINE init #-} -init = G.init - --- | /O(N)/ Copy all but the first element. The vector may not be empty. -tail :: VECTOR s ty a => Vector s ty a -> Vector s ty a -{-# INLINE tail #-} -tail = G.tail - --- | /O(N)/ Yield at the first @n@ elements with copying. The vector may --- contain less than @n@ elements in which case it is returned unchanged. -take :: VECTOR s ty a => Int -> Vector s ty a -> Vector s ty a -{-# INLINE take #-} -take = G.take - --- | /O(N)/ Yield all but the first @n@ elements with copying. The vector may --- contain less than @n@ elements in which case an empty vector is returned. -drop :: VECTOR s ty a => Int -> Vector s ty a -> Vector s ty a -{-# INLINE drop #-} -drop = G.drop - --- | /O(N)/ Yield the first @n@ elements paired with the remainder with copying. --- --- Note that @'splitAt' n v@ is equivalent to @('take' n v, 'drop' n v)@ --- but slightly more efficient. -{-# INLINE splitAt #-} -splitAt :: VECTOR s ty a => Int -> Vector s ty a -> (Vector s ty a, Vector s ty a) -splitAt = G.splitAt - --- | /O(N)/ Yield a slice of the vector with copying. The vector must --- contain at least @i+n@ elements but this is not checked. -unsafeSlice :: VECTOR s ty a => Int -- ^ @i@ starting index - -> Int -- ^ @n@ length - -> Vector s ty a - -> Vector s ty a -{-# INLINE unsafeSlice #-} -unsafeSlice = G.unsafeSlice - --- | /O(N)/ Yield all but the last element with copying. The vector may not --- be empty but this is not checked. -unsafeInit :: VECTOR s ty a => Vector s ty a -> Vector s ty a -{-# INLINE unsafeInit #-} -unsafeInit = G.unsafeInit - --- | /O(N)/ Yield all but the first element with copying. The vector may not --- be empty but this is not checked. -unsafeTail :: VECTOR s ty a => Vector s ty a -> Vector s ty a -{-# INLINE unsafeTail #-} -unsafeTail = G.unsafeTail - --- | /O(N)/ Yield the first @n@ elements with copying. The vector must --- contain at least @n@ elements but this is not checked. -unsafeTake :: VECTOR s ty a => Int -> Vector s ty a -> Vector s ty a -{-# INLINE unsafeTake #-} -unsafeTake = G.unsafeTake - --- | /O(N)/ Yield all but the first @n@ elements with copying. The vector --- must contain at least @n@ elements but this is not checked. -unsafeDrop :: VECTOR s ty a => Int -> Vector s ty a -> Vector s ty a -{-# INLINE unsafeDrop #-} -unsafeDrop = G.unsafeDrop - --- Initialisation --- -------------- - --- | /O(1)/ Empty vector -empty :: VECTOR s ty a => Vector s ty a -{-# INLINE empty #-} -empty = G.empty -- TODO test - --- | /O(1)/ Vector with exactly one element -singleton :: VECTOR s ty a => a -> Vector s ty a -{-# INLINE singleton #-} -singleton = G.singleton - --- | /O(n)/ Vector of the given length with the same value in each position -replicate :: VECTOR s ty a => Int -> a -> Vector s ty a -{-# INLINE replicate #-} -replicate = G.replicate - --- | /O(n)/ Construct a vector of the given length by applying the function to --- each index -generate :: VECTOR s ty a => Int -> (Int -> a) -> Vector s ty a -{-# INLINE generate #-} -generate = G.generate - --- | /O(n)/ Apply function n times to value. Zeroth element is original value. -iterateN :: VECTOR s ty a => Int -> (a -> a) -> a -> Vector s ty a -{-# INLINE iterateN #-} -iterateN = G.iterateN - --- Unfolding --- --------- - --- | /O(n)/ Construct a Vector s ty 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 s ty a => (b -> Maybe (a, b)) -> b -> Vector s ty a -{-# INLINE unfoldr #-} -unfoldr = G.unfoldr - --- | /O(n)/ Construct a vector with at most @n@ by repeatedly applying the --- generator function to the 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 s ty a => Int -> (b -> Maybe (a, b)) -> b -> Vector s ty a -{-# INLINE unfoldrN #-} -unfoldrN = G.unfoldrN - --- | /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 ; c = f in f --- -constructN :: VECTOR s ty a => Int -> (Vector s ty a -> a) -> Vector s ty 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 ; c = f in f --- -constructrN :: VECTOR s ty a => Int -> (Vector s ty a -> a) -> Vector s ty 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 :: (VECTOR s ty a, Num a) => a -> Int -> Vector s ty 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 :: (VECTOR s ty a, Num a) => a -> a -> Int -> Vector s ty 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 :: (VECTOR s ty a, Enum a) => a -> a -> Vector s ty 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 :: (VECTOR s ty a, Enum a) => a -> a -> a -> Vector s ty a -{-# INLINE enumFromThenTo #-} -enumFromThenTo = G.enumFromThenTo - --- Concatenation --- ------------- - --- | /O(n)/ Prepend an element -cons :: VECTOR s ty a => a -> Vector s ty a -> Vector s ty a -{-# INLINE cons #-} -cons = G.cons - --- | /O(n)/ Append an element -snoc :: VECTOR s ty a => Vector s ty a -> a -> Vector s ty a -{-# INLINE snoc #-} -snoc = G.snoc - -infixr 5 ++ --- | /O(m+n)/ Concatenate two vectors -(++) :: VECTOR s ty a => Vector s ty a -> Vector s ty a -> Vector s ty a -{-# INLINE (++) #-} -(++) = (G.++) - --- | /O(n)/ Concatenate all vectors in the list -concat :: VECTOR s ty a => [Vector s ty a] -> Vector s ty 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, VECTOR s ty a) => Int -> m a -> m (Vector s ty 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, VECTOR s ty a) => Int -> (Int -> m a) -> m (Vector s ty a) -{-# INLINE generateM #-} -generateM = G.generateM - --- | 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 :: VECTOR s ty a => (forall r. ST r (MVector s ty r a)) -> Vector s ty a -{-# INLINE create #-} --- NOTE: eta-expanded due to http://hackage.haskell.org/trac/ghc/ticket/4120 -create p = G.create 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 ) --- --- 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 s ty a => Vector s ty a -> Vector s ty 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 s ty a => Vector s ty a -- ^ initial vector (of length @m@) - -> [(Int, a)] -- ^ list of index/value pairs (of length @n@) - -> Vector s ty a -{-# INLINE (//) #-} -(//) = (G.//) - -{- --- | /O(m+min(n1,n2))/ For each index @i@ from the index Vector s ty and the --- corresponding value @a@ from the value vector, replace the element of the --- initial Vector s ty at position @i@ by @a@. --- --- > update_ <5,9,2,7> <2,0,2> <1,3,8> = <3,9,8,7> --- -update_ :: VECTOR s ty a - => Vector s ty a -- ^ initial vector (of length @m@) - -> Vector Int -- ^ index vector (of length @n1@) - -> Vector s ty a -- ^ value vector (of length @n2@) - -> Vector s ty a -{-# INLINE update_ #-} -update_ = G.update_ --} - -{- --- | Same as ('//') but without bounds checking. -unsafeUpd :: VECTOR s ty a => Vector s ty a -> [(Int, a)] -> Vector s ty a -{-# INLINE unsafeUpd #-} -unsafeUpd = G.unsafeUpd --} - -{- --- | Same as 'update_' but without bounds checking. -unsafeUpdate_ :: VECTOR s ty a => Vector s ty a -> Vector Int -> Vector s ty a -> Vector s ty 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 :: VECTOR s ty a - => (a -> b -> a) -- ^ accumulating function @f@ - -> Vector s ty a -- ^ initial vector (of length @m@) - -> [(Int,b)] -- ^ list of index/value pairs (of length @n@) - -> Vector s ty a -{-# INLINE accum #-} -accum = G.accum - -{- --- | /O(m+min(n1,n2))/ For each index @i@ from the index Vector s ty and the --- corresponding value @b@ from the the value vector, --- replace the element of the initial Vector s ty 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_ :: (VECTOR s ty a, VECTOR s ty b) - => (a -> b -> a) -- ^ accumulating function @f@ - -> Vector s ty a -- ^ initial vector (of length @m@) - -> Vector Int -- ^ index vector (of length @n1@) - -> Vector s ty b -- ^ value vector (of length @n2@) - -> Vector s ty a -{-# INLINE accumulate_ #-} -accumulate_ = G.accumulate_ --} - --- | Same as 'accum' but without bounds checking. -unsafeAccum :: VECTOR s ty a => (a -> b -> a) -> Vector s ty a -> [(Int,b)] -> Vector s ty a -{-# INLINE unsafeAccum #-} -unsafeAccum = G.unsafeAccum - -{- --- | Same as 'accumulate_' but without bounds checking. -unsafeAccumulate_ :: (VECTOR s ty a, VECTOR s ty b) => - (a -> b -> a) -> Vector s ty a -> Vector Int -> Vector s ty b -> Vector s ty a -{-# INLINE unsafeAccumulate_ #-} -unsafeAccumulate_ = G.unsafeAccumulate_ --} - --- Permutations --- ------------ - --- | /O(n)/ Reverse a vector -reverse :: VECTOR s ty a => Vector s ty a -> Vector s ty a -{-# INLINE reverse #-} -reverse = G.reverse - -{- --- | /O(n)/ Yield the vector obtained by replacing each element @i@ of the --- index Vector s ty by @xs'!'i@. This is equivalent to @'map' (xs'!') is@ but is --- often much more efficient. --- --- > backpermute <0,3,2,3,1,0> = -backpermute :: VECTOR s ty a => Vector s ty a -> Vector Int -> Vector s ty a -{-# INLINE backpermute #-} -backpermute = G.backpermute --} - -{- --- | Same as 'backpermute' but without bounds checking. -unsafeBackpermute :: VECTOR s ty a => Vector s ty a -> Vector Int -> Vector s ty 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 :: VECTOR s ty a => (forall s. MVector s a -> ST s ()) -> Vector s ty a -> Vector s ty a -{-# INLINE modify #-} -modify p = G.modify p --} - --- Mapping --- ------- - --- | /O(n)/ Map a function over a vector -map :: (VECTOR s ty a, VECTOR s ty b) => (a -> b) -> Vector s ty a -> Vector s ty b -{-# INLINE map #-} -map = G.map - --- | /O(n)/ Apply a function to every element of a Vector s ty and its index -imap :: (VECTOR s ty a, VECTOR s ty b) => (Int -> a -> b) -> Vector s ty a -> Vector s ty b -{-# INLINE imap #-} -imap = G.imap - --- | Map a function over a Vector s ty and concatenate the results. -concatMap :: (VECTOR s ty a, VECTOR s ty b) => (a -> Vector s ty b) -> Vector s ty a -> Vector s ty 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, VECTOR s ty a, VECTOR s ty b) => (a -> m b) -> Vector s ty a -> m (Vector s ty b) -{-# INLINE mapM #-} -mapM = G.mapM - --- | /O(n)/ Apply the monadic action to all elements of a Vector s ty and ignore the --- results -mapM_ :: (Monad m, VECTOR s ty a) => (a -> m b) -> Vector s ty a -> m () -{-# INLINE mapM_ #-} -mapM_ = G.mapM_ - --- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a --- vector of results. Equvalent to @flip 'mapM'@. -forM :: (Monad m, VECTOR s ty a, VECTOR s ty b) => Vector s ty a -> (a -> m b) -> m (Vector s ty b) -{-# INLINE forM #-} -forM = G.forM - --- | /O(n)/ Apply the monadic action to all elements of a Vector s ty and ignore the --- results. Equivalent to @flip 'mapM_'@. -forM_ :: (Monad m, VECTOR s ty a) => Vector s ty a -> (a -> m b) -> m () -{-# INLINE forM_ #-} -forM_ = G.forM_ - --- Zipping --- ------- - --- | /O(min(m,n))/ Zip two vectors with the given function. -zipWith :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c) - => (a -> b -> c) -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -{-# INLINE zipWith #-} -zipWith f xs ys = G.unstream (Stream.zipWith f (G.stream xs) (G.stream ys)) - --- | Zip three vectors with the given function. -zipWith3 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d) - => (a -> b -> c -> d) -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -{-# INLINE zipWith3 #-} -zipWith3 f as bs cs = G.unstream (Stream.zipWith3 f (G.stream as) (G.stream bs) (G.stream cs)) - -zipWith4 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d, VECTOR s tye e) - => (a -> b -> c -> d -> e) - -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -> Vector s tye e -{-# INLINE zipWith4 #-} -zipWith4 f as bs cs ds = G.unstream (Stream.zipWith4 f (G.stream as) (G.stream bs) (G.stream cs) (G.stream ds)) - -zipWith5 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d, VECTOR s tye e, - VECTOR s tyf f) - => (a -> b -> c -> d -> e -> f) - -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -> Vector s tye e - -> Vector s tyf f -{-# INLINE zipWith5 #-} -zipWith5 f as bs cs ds es = G.unstream (Stream.zipWith5 f (G.stream as) (G.stream bs) (G.stream cs) (G.stream ds) (G.stream es)) - -zipWith6 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d, VECTOR s tye e, - VECTOR s tyf f, VECTOR s tyg g) - => (a -> b -> c -> d -> e -> f -> g) - -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -> Vector s tye e - -> Vector s tyf f -> Vector s tyg g -{-# INLINE zipWith6 #-} -zipWith6 f as bs cs ds es fs = G.unstream (Stream.zipWith6 f (G.stream as) (G.stream bs) (G.stream cs) (G.stream ds) (G.stream es) (G.stream fs)) - --- | /O(min(m,n))/ Zip two vectors with a function that also takes the --- elements' indices. -izipWith :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c) - => (Int -> a -> b -> c) -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -{-# INLINE izipWith #-} -izipWith f as bs = G.unstream (Stream.zipWith (uncurry f) (Stream.indexed (G.stream as)) (G.stream bs)) - --- | Zip three vectors and their indices with the given function. -izipWith3 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d) - => (Int -> a -> b -> c -> d) - -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -{-# INLINE izipWith3 #-} -izipWith3 f as bs cs = G.unstream (Stream.zipWith3 (uncurry f) (Stream.indexed (G.stream as)) (G.stream bs) (G.stream cs)) - -izipWith4 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d, VECTOR s tye e) - => (Int -> a -> b -> c -> d -> e) - -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -> Vector s tye e -{-# INLINE izipWith4 #-} -izipWith4 f as bs cs ds = G.unstream (Stream.zipWith4 (uncurry f) (Stream.indexed (G.stream as)) (G.stream bs) (G.stream cs) (G.stream ds)) - -izipWith5 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d, VECTOR s tye e, - VECTOR s tyf f) - => (Int -> a -> b -> c -> d -> e -> f) - -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -> Vector s tye e - -> Vector s tyf f -{-# INLINE izipWith5 #-} -izipWith5 f as bs cs ds es = G.unstream (Stream.zipWith5 (uncurry f) (Stream.indexed (G.stream as)) (G.stream bs) (G.stream cs) (G.stream ds) (G.stream es)) - -izipWith6 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d, VECTOR s tye e, - VECTOR s tyf f, VECTOR s tyg g) - => (Int -> a -> b -> c -> d -> e -> f -> g) - -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -> Vector s tye e - -> Vector s tyf f -> Vector s tyg g -{-# INLINE izipWith6 #-} -izipWith6 f as bs cs ds es fs = G.unstream (Stream.zipWith6 (uncurry f) (Stream.indexed (G.stream as)) (G.stream bs) (G.stream cs) (G.stream ds) (G.stream es) (G.stream fs)) - --- Monadic zipping --- --------------- - -{- --- | /O(min(m,n))/ Zip the two vectors with the monadic action and yield a --- vector of results -zipWithM :: (Monad m, VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c) - => (a -> b -> m c) -> Vector s tya a -> Vector s tyb b -> m (Vector s tyc c) -{-# INLINE zipWithM #-} -zipWithM f as bs = G.unstreamM (Stream.zipWithM f (G.stream as) (G.stream bs)) --} - --- | /O(min(m,n))/ Zip the two vectors with the monadic action and ignore the --- results -zipWithM_ :: (Monad m, VECTOR s tya a, VECTOR s tyb b) - => (a -> b -> m c) -> Vector s tya a -> Vector s tyb b -> m () -{-# INLINE zipWithM_ #-} -zipWithM_ f as bs = Stream.zipWithM_ f (G.stream as) (G.stream bs) - --- Filtering --- --------- - --- | /O(n)/ Drop elements that do not satisfy the predicate -filter :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Vector s ty 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 :: VECTOR s ty a => (Int -> a -> Bool) -> Vector s ty a -> Vector s ty a -{-# INLINE ifilter #-} -ifilter = G.ifilter - --- | /O(n)/ Drop elements that do not satisfy the monadic predicate -filterM :: (Monad m, VECTOR s ty a) => (a -> m Bool) -> Vector s ty a -> m (Vector s ty a) -{-# INLINE filterM #-} -filterM = G.filterM - --- | /O(n)/ Yield the longest prefix of elements satisfying the predicate --- with copying. -takeWhile :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Vector s ty a -{-# INLINE takeWhile #-} -takeWhile = G.takeWhile - --- | /O(n)/ Drop the longest prefix of elements that satisfy the predicate --- with copying. -dropWhile :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Vector s ty 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 :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> (Vector s ty a, Vector s ty 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 :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> (Vector s ty a, Vector s ty a) -{-# INLINE unstablePartition #-} -unstablePartition = G.unstablePartition - --- | /O(n)/ Split the vector into the longest prefix of elements that satisfy --- the predicate and the rest with copying. -span :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> (Vector s ty a, Vector s ty 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 with copying. -break :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> (Vector s ty a, Vector s ty a) -{-# INLINE break #-} -break = G.break - --- Searching --- --------- - -infix 4 `elem` --- | /O(n)/ Check if the vector contains an element -elem :: (VECTOR s ty a, Eq a) => a -> Vector s ty 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 :: (VECTOR s ty a, Eq a) => a -> Vector s ty 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 :: VECTOR s ty a => (a -> Bool) -> Vector s ty 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 :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Maybe Int -{-# INLINE findIndex #-} -findIndex = G.findIndex - -{- --- | /O(n)/ Yield the indices of elements satisfying the predicate in ascending --- order. -findIndices :: VECTOR s ty a => (a -> Bool) -> Vector s ty 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 :: (VECTOR s ty a, Eq a) => a -> Vector s ty 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 :: (VECTOR s ty a, Eq a) => a -> Vector s ty a -> Vector Int -{-# INLINE elemIndices #-} -elemIndices = G.elemIndices --} - --- Folding --- ------- - --- | /O(n)/ Left fold -foldl :: VECTOR s ty b => (a -> b -> a) -> a -> Vector s ty b -> a -{-# INLINE foldl #-} -foldl = G.foldl - --- | /O(n)/ Left fold on non-empty vectors -foldl1 :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> a -{-# INLINE foldl1 #-} -foldl1 = G.foldl1 - --- | /O(n)/ Left fold with strict accumulator -foldl' :: VECTOR s ty b => (a -> b -> a) -> a -> Vector s ty b -> a -{-# INLINE foldl' #-} -foldl' = G.foldl' - --- | /O(n)/ Left fold on non-empty vectors with strict accumulator -foldl1' :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> a -{-# INLINE foldl1' #-} -foldl1' = G.foldl1' - --- | /O(n)/ Right fold -foldr :: VECTOR s ty a => (a -> b -> b) -> b -> Vector s ty a -> b -{-# INLINE foldr #-} -foldr = G.foldr - --- | /O(n)/ Right fold on non-empty vectors -foldr1 :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> a -{-# INLINE foldr1 #-} -foldr1 = G.foldr1 - --- | /O(n)/ Right fold with a strict accumulator -foldr' :: VECTOR s ty a => (a -> b -> b) -> b -> Vector s ty a -> b -{-# INLINE foldr' #-} -foldr' = G.foldr' - --- | /O(n)/ Right fold on non-empty vectors with strict accumulator -foldr1' :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> a -{-# INLINE foldr1' #-} -foldr1' = G.foldr1' - --- | /O(n)/ Left fold (function applied to each element and its index) -ifoldl :: VECTOR s ty b => (a -> Int -> b -> a) -> a -> Vector s ty b -> a -{-# INLINE ifoldl #-} -ifoldl = G.ifoldl - --- | /O(n)/ Left fold with strict accumulator (function applied to each element --- and its index) -ifoldl' :: VECTOR s ty b => (a -> Int -> b -> a) -> a -> Vector s ty b -> a -{-# INLINE ifoldl' #-} -ifoldl' = G.ifoldl' - --- | /O(n)/ Right fold (function applied to each element and its index) -ifoldr :: VECTOR s ty a => (Int -> a -> b -> b) -> b -> Vector s ty a -> b -{-# INLINE ifoldr #-} -ifoldr = G.ifoldr - --- | /O(n)/ Right fold with strict accumulator (function applied to each --- element and its index) -ifoldr' :: VECTOR s ty a => (Int -> a -> b -> b) -> b -> Vector s ty a -> b -{-# INLINE ifoldr' #-} -ifoldr' = G.ifoldr' - --- Specialised folds --- ----------------- - -{- --- | /O(n)/ Check if all elements satisfy the predicate. -all :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Bool -{-# INLINE all #-} -all = G.all - --- | /O(n)/ Check if any element satisfies the predicate. -any :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Bool -{-# INLINE any #-} -any = G.any - --- | /O(n)/ Check if all elements are 'True' -and :: Vector 'Logical Bool -> R.Logical -{-# INLINE and #-} -and = G.and -- FIXME - --- | /O(n)/ Check if any element is 'True' -or :: Vector 'Logical Bool -> R.Logical -{-# INLINE or #-} -or = G.or --} - --- | /O(n)/ Compute the sum of the elements -sum :: (VECTOR s ty a, Num a) => Vector s ty a -> a -{-# INLINE sum #-} -sum = G.sum - --- | /O(n)/ Compute the produce of the elements -product :: (VECTOR s ty a, Num a) => Vector s ty a -> a -{-# INLINE product #-} -product = G.product - --- | /O(n)/ Yield the maximum element of the vector. The vector may not be --- empty. -maximum :: (VECTOR s ty a, Ord a) => Vector s ty a -> a -{-# INLINE maximum #-} -maximum = G.maximum - --- | /O(n)/ Yield the maximum element of the Vector s ty according to the given --- comparison function. The vector may not be empty. -maximumBy :: VECTOR s ty a => (a -> a -> Ordering) -> Vector s ty a -> a -{-# INLINE maximumBy #-} -maximumBy = G.maximumBy - --- | /O(n)/ Yield the minimum element of the vector. The vector may not be --- empty. -minimum :: (VECTOR s ty a, Ord a) => Vector s ty a -> a -{-# INLINE minimum #-} -minimum = G.minimum - --- | /O(n)/ Yield the minimum element of the Vector s ty according to the given --- comparison function. The vector may not be empty. -minimumBy :: VECTOR s ty a => (a -> a -> Ordering) -> Vector s ty 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 :: (VECTOR s ty a, Ord a) => Vector s ty a -> Int -{-# INLINE maxIndex #-} -maxIndex = G.maxIndex - --- | /O(n)/ Yield the index of the maximum element of the Vector s ty according to --- the given comparison function. The vector may not be empty. -maxIndexBy :: VECTOR s ty a => (a -> a -> Ordering) -> Vector s ty 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 :: (VECTOR s ty a, Ord a) => Vector s ty a -> Int -{-# INLINE minIndex #-} -minIndex = G.minIndex - --- | /O(n)/ Yield the index of the minimum element of the Vector s ty according to --- the given comparison function. The vector may not be empty. -minIndexBy :: VECTOR s ty a => (a -> a -> Ordering) -> Vector s ty a -> Int -{-# INLINE minIndexBy #-} -minIndexBy = G.minIndexBy - --- Monadic folds --- ------------- - --- | /O(n)/ Monadic fold -foldM :: (Monad m, VECTOR s ty b) => (a -> b -> m a) -> a -> Vector s ty b -> m a -{-# INLINE foldM #-} -foldM = G.foldM - --- | /O(n)/ Monadic fold over non-empty vectors -fold1M :: (Monad m, VECTOR s ty a) => (a -> a -> m a) -> Vector s ty a -> m a -{-# INLINE fold1M #-} -fold1M = G.fold1M - --- | /O(n)/ Monadic fold with strict accumulator -foldM' :: (Monad m, VECTOR s ty b) => (a -> b -> m a) -> a -> Vector s ty b -> m a -{-# INLINE foldM' #-} -foldM' = G.foldM' - --- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator -fold1M' :: (Monad m, VECTOR s ty a) => (a -> a -> m a) -> Vector s ty a -> m a -{-# INLINE fold1M' #-} -fold1M' = G.fold1M' - --- | /O(n)/ Monadic fold that discards the result -foldM_ :: (Monad m, VECTOR s ty b) => (a -> b -> m a) -> a -> Vector s ty b -> m () -{-# INLINE foldM_ #-} -foldM_ = G.foldM_ - --- | /O(n)/ Monadic fold over non-empty vectors that discards the result -fold1M_ :: (Monad m, VECTOR s ty a) => (a -> a -> m a) -> Vector s ty a -> m () -{-# INLINE fold1M_ #-} -fold1M_ = G.fold1M_ - --- | /O(n)/ Monadic fold with strict accumulator that discards the result -foldM'_ :: (Monad m, VECTOR s ty b) => (a -> b -> m a) -> a -> Vector s ty 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, VECTOR s ty a) => (a -> a -> m a) -> Vector s ty 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 :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> a) -> a -> Vector s ty b -> Vector s ty a -{-# INLINE prescanl #-} -prescanl = G.prescanl - --- | /O(n)/ Prescan with strict accumulator -prescanl' :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> a) -> a -> Vector s ty b -> Vector s ty 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 :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> a) -> a -> Vector s ty b -> Vector s ty a -{-# INLINE postscanl #-} -postscanl = G.postscanl - --- | /O(n)/ Scan with strict accumulator -postscanl' :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> a) -> a -> Vector s ty b -> Vector s ty a -{-# INLINE postscanl' #-} -postscanl' = G.postscanl' - --- | /O(n)/ Haskell-style scan --- --- > scanl f z = --- > 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 s ty a, VECTOR s ty b) => (a -> b -> a) -> a -> Vector s ty b -> Vector s ty a -{-# INLINE scanl #-} -scanl = G.scanl - --- | /O(n)/ Haskell-style scan with strict accumulator -scanl' :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> a) -> a -> Vector s ty b -> Vector s ty a -{-# INLINE scanl' #-} -scanl' = G.scanl' - --- | /O(n)/ Scan over a non-empty vector --- --- > scanl f = --- > where y1 = x1 --- > yi = f y(i-1) xi --- -scanl1 :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> Vector s ty a -{-# INLINE scanl1 #-} -scanl1 = G.scanl1 - --- | /O(n)/ Scan over a non-empty vector with a strict accumulator -scanl1' :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> Vector s ty a -{-# INLINE scanl1' #-} -scanl1' = G.scanl1' - --- | /O(n)/ Right-to-left prescan --- --- @ --- prescanr f z = 'reverse' . 'prescanl' (flip f) z . 'reverse' --- @ --- -prescanr :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> b) -> b -> Vector s ty a -> Vector s ty b -{-# INLINE prescanr #-} -prescanr = G.prescanr - --- | /O(n)/ Right-to-left prescan with strict accumulator -prescanr' :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> b) -> b -> Vector s ty a -> Vector s ty b -{-# INLINE prescanr' #-} -prescanr' = G.prescanr' - --- | /O(n)/ Right-to-left scan -postscanr :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> b) -> b -> Vector s ty a -> Vector s ty b -{-# INLINE postscanr #-} -postscanr = G.postscanr - --- | /O(n)/ Right-to-left scan with strict accumulator -postscanr' :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> b) -> b -> Vector s ty a -> Vector s ty b -{-# INLINE postscanr' #-} -postscanr' = G.postscanr' - --- | /O(n)/ Right-to-left Haskell-style scan -scanr :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> b) -> b -> Vector s ty a -> Vector s ty b -{-# INLINE scanr #-} -scanr = G.scanr - --- | /O(n)/ Right-to-left Haskell-style scan with strict accumulator -scanr' :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> b) -> b -> Vector s ty a -> Vector s ty b -{-# INLINE scanr' #-} -scanr' = G.scanr' - --- | /O(n)/ Right-to-left scan over a non-empty vector -scanr1 :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> Vector s ty a -{-# INLINE scanr1 #-} -scanr1 = G.scanr1 - --- | /O(n)/ Right-to-left scan over a non-empty vector with a strict --- accumulator -scanr1' :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> Vector s ty a -{-# INLINE scanr1' #-} -scanr1' = G.scanr1' - --- Conversions - Lists --- ------------------------ - --- | /O(n)/ Convert a vector to a list -toList :: VECTOR s ty a => Vector s ty a -> [a] -{-# INLINE toList #-} -toList = G.toList - --- | /O(n)/ Convert a list to a vector -fromList :: VECTOR s ty a => [a] -> Vector s ty a -{-# INLINE fromList #-} -fromList xs = G.fromListN (Prelude.length xs) xs - --- | /O(n)/ Convert the first @n@ elements of a list to a vector --- --- @ --- fromListN n xs = 'fromList' ('take' n xs) --- @ -fromListN :: VECTOR s ty a => Int -> [a] -> Vector s ty a -{-# INLINE fromListN #-} -fromListN = G.fromListN - --- Conversions - Unsafe casts --- -------------------------- - --- Conversions - Mutable vectors --- ----------------------------- - --- | /O(1)/ Unsafe convert a mutable vector to an immutable one with --- copying. The mutable vector may not be used after this operation. -unsafeFreeze - :: (VECTOR s ty a, PrimMonad m) => MVector s ty (PrimState m) a -> m (Vector s ty a) -{-# INLINE unsafeFreeze #-} -unsafeFreeze = G.unsafeFreeze - --- | /O(1)/ Unsafely convert an immutable vector to a mutable one with --- copying. The immutable vector may not be used after this operation. -unsafeThaw - :: (VECTOR s ty a, PrimMonad m) => Vector s ty a -> m (MVector s ty (PrimState m) a) -{-# INLINE unsafeThaw #-} -unsafeThaw = G.unsafeThaw - --- | /O(n)/ Yield a mutable copy of the immutable vector. -thaw :: (VECTOR s ty a, PrimMonad m) => Vector s ty a -> m (MVector s ty (PrimState m) a) -{-# INLINE thaw #-} -thaw = G.thaw - --- | /O(n)/ Yield an immutable copy of the mutable vector. -freeze :: (VECTOR s ty a, PrimMonad m) => MVector s ty (PrimState m) a -> m (Vector s ty 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 - :: (VECTOR s ty a, PrimMonad m) => MVector s ty (PrimState m) a -> Vector s ty 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 :: (VECTOR s ty a, PrimMonad m) => MVector s ty (PrimState m) a -> Vector s ty a -> m () -{-# INLINE copy #-} -copy = G.copy - --- | O(1) Inplace convertion to Storable vector. -unsafeToStorable :: VECTOR s ty a - => Vector s ty a -- ^ target - -> Storable.Vector a -- ^ source -{-# INLINE unsafeToStorable #-} -unsafeToStorable v = unsafeInlineIO $ - G.unsafeFreeze =<< Mutable.unsafeToStorable =<< G.unsafeThaw v - --- | O(N) Convertion from storable vector to SEXP vector. -fromStorable :: VECTOR s ty a - => Storable.Vector a - -> Vector s ty a -{-# INLINE fromStorable #-} -fromStorable v = unsafeInlineIO $ - G.unsafeFreeze =<< Mutable.fromStorable =<< G.unsafeThaw v diff --git a/src/Data/Vector/SEXP.hs b/src/Data/Vector/SEXP.hs new file mode 100644 --- /dev/null +++ b/src/Data/Vector/SEXP.hs @@ -0,0 +1,1743 @@ +-- | +-- Copyright: (C) 2013 Amgen, Inc. +-- +-- Vectors that can be passed to and from R with no copying at all. These +-- vectors are an instance of "Data.Vector.Storable", where the memory is +-- allocated from the R heap, in such a way that they can be converted to +-- a 'SEXP' through simple pointer arithmetic (see 'toSEXP') /in constant time/. +-- +-- The main difference between "Data.Vector.SEXP" and "Data.Vector.Storable" is +-- that the former uses a header-prefixed data layout (the header immediately +-- precedes the payload of the vector). This means that no additional pointer +-- dereferencing is needed to reach the vector data. The trade-off is that most +-- slicing operations are O(N) instead of O(1). +-- +-- If you make heavy use of slicing, then it's best to convert to +-- a "Data.Vector.Storable" vector first, using 'unsafeToStorable'. +-- +-- Note that since 'unstream' relies on slicing operations, it will still be an +-- O(N) operation but it will copy vector data twice (instead of once). + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +module Data.Vector.SEXP + ( Vector(..) + , Mutable.MVector(..) + , ElemRep + , VECTOR + , Data.Vector.SEXP.fromSEXP + , unsafeFromSEXP + , Data.Vector.SEXP.toSEXP + , unsafeToSEXP + -- * Accessors + -- ** Length information + , length + , null + -- ** Indexing + , (!) + , (!?) + , head + , last + , unsafeIndex + , unsafeHead + , unsafeLast + -- ** Monadic indexing + , indexM + , headM + , lastM + , unsafeIndexM + , unsafeHeadM + , unsafeLastM + -- ** Extracting subvectors (slicing) + , slice + , init + , take + , drop + , tail + , splitAt + , unsafeTail + , unsafeSlice + , unsafeDrop + , unsafeTake + , unsafeInit + + -- * Construction + -- ** Initialisation + , empty + , singleton + , replicate + , generate + , iterateN + -- ** Monadic initialisation + , replicateM + , generateM + , create + -- ** Unfolding + , unfoldr + , unfoldrN + , 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 + , 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 + -- ** Mutable vectors + , freeze + , thaw + , copy + , unsafeFreeze + , unsafeThaw + , unsafeCopy + + -- ** SEXP specific helpers. + , toString + , toByteString + ) where + +import Control.Monad.R.Class +import Control.Monad.R.Internal +import Control.Memory.Region +import Data.Vector.SEXP.Base +import Data.Vector.SEXP.Mutable (MVector) +import qualified Data.Vector.SEXP.Mutable as Mutable +import qualified Data.Vector.SEXP.Mutable.Internal as Mutable +import Foreign.R ( SEXP(..) ) +import qualified Foreign.R as R +import Foreign.R.Type ( SEXPTYPE(Char) ) + +import Control.Monad.Primitive ( PrimMonad ) +import Control.Monad.ST (ST, runST) +import Data.Int +import Data.Proxy (Proxy(..)) +import Data.Reflection (Reifies(..), reify) +import qualified Data.Vector.Generic as G +import Data.Vector.Generic.New (run) +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as B + +import Control.Applicative hiding (empty) +#if MIN_VERSION_vector(0,11,0) +import qualified Data.Vector.Fusion.Bundle.Monadic as Bundle +import Data.Vector.Fusion.Bundle.Monadic (sSize, sElems) +import Data.Vector.Fusion.Bundle.Size (Size(Unknown), smaller) +import Data.Vector.Fusion.Bundle (lift) +import qualified Data.Vector.Fusion.Stream.Monadic as Stream +import qualified Data.List as List +#else +import qualified Data.Vector.Fusion.Stream as Stream +import qualified Data.Vector.Fusion.Stream.Monadic as MStream +#endif + +import Control.Monad.Primitive ( unsafeInlineIO, unsafePrimToPrim ) +import Data.Word ( Word8 ) +import Foreign ( Storable, Ptr, castPtr, peekElemOff ) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import Foreign.Marshal.Array ( copyArray ) +import qualified GHC.Foreign as GHC +import qualified GHC.ForeignPtr as GHC +import GHC.IO.Encoding.UTF8 +#if __GLASGOW_HASKELL__ >= 708 +import qualified GHC.Exts as Exts +#endif +import System.IO.Unsafe + +import Prelude + ( Eq(..) + , Enum + , Monad(..) + , Num(..) + , Ord(..) + , Show(..) + , Bool + , IO + , Maybe + , Ordering + , String + , (.) + , ($) + , fromIntegral + , seq + , uncurry + ) +import qualified Prelude + +newtype ForeignSEXP (ty::SEXPTYPE) = ForeignSEXP (ForeignPtr ()) + +-- | Create a 'ForeignSEXP' from 'SEXP'. +foreignSEXP :: PrimMonad m => SEXP s ty -> m (ForeignSEXP ty) +foreignSEXP sx@(SEXP ptr) = + unsafePrimToPrim $ do + R.preserveObject sx + ForeignSEXP <$> GHC.newConcForeignPtr (castPtr ptr) (R.releaseObject sx) + +withForeignSEXP + :: ForeignSEXP ty + -> (SEXP s ty -> IO r) + -> IO r +withForeignSEXP (ForeignSEXP fptr) f = + withForeignPtr fptr $ \ptr -> f (SEXP (castPtr ptr)) + +-- | Immutable vectors. The second type paramater is a phantom parameter +-- reflecting at the type level the tag of the vector when viewed as a 'SEXP'. +-- The tag of the vector and the representation type are related via 'ElemRep'. +data Vector s (ty :: SEXPTYPE) a = Vector + { vectorBase :: {-# UNPACK #-} !(ForeignSEXP ty) + , vectorOffset :: {-# UNPACK #-} !Int32 + , vectorLength :: {-# UNPACK #-} !Int32 + } + +instance (Eq a, VECTOR s ty a) => Eq (Vector s ty a) where + a == b = toList a == toList b + +instance (Show a, VECTOR s ty a) => Show (Vector s ty a) where + show v = "fromList " Prelude.++ showList (toList v) "" + +-- | Internal wrapper type for reflection. First type parameter is the reified +-- type to reflect. +newtype W t ty s a = W { unW :: Vector s ty a } + +withW :: proxy t -> Vector s ty a -> W t ty s a +withW _ v = W v + +proxyFW :: (W t ty s a -> r) -> Vector s ty a -> p t -> r +proxyFW f v p = f (withW p v) + +proxyFW2 :: (W t tya s a -> W t tyb s b -> r) -> Vector s tya a -> Vector s tyb b -> p t -> r +proxyFW2 f v1 v2 p = f (withW p v1) (withW p v2) + +proxyW :: W t ty s a -> p t -> Vector s ty a +proxyW v _ = unW v + +type instance G.Mutable (W t ty s) = Mutable.W t ty + +instance (Reifies t (AcquireIO s), VECTOR s ty a) => G.Vector (W t ty s) a where + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeFreeze (Mutable.unW -> Mutable.MVector sx off len) = do + fp <- foreignSEXP sx + return $ W $ Vector fp off len + {-# INLINE basicUnsafeThaw #-} + basicUnsafeThaw (unW -> Vector fp off len) = unsafePrimToPrim $ + withForeignSEXP fp $ \ptr -> do + sx' <- acquireIO (R.release ptr) + return $ Mutable.withW p $ Mutable.MVector (R.unsafeRelease sx') off len + where + AcquireIO acquireIO = reflect (Proxy :: Proxy t) + p = Proxy :: Proxy t + basicLength (unW -> Vector _ _ len) = fromIntegral len + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice (fromIntegral ->i) + (fromIntegral ->n) (unW -> Vector fp off _len) = W $ Vector fp (off + i) n + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeIndexM v i = return . unsafeInlineIO $ peekElemOff (unsafeToPtr (unW v)) i + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy mv v = + unsafePrimToPrim $ + copyArray (Mutable.unsafeToPtr (Mutable.unW mv)) + (unsafeToPtr (unW v)) + (G.basicLength v) + {-# INLINE elemseq #-} + elemseq _ = seq + +#if __GLASGOW_HASKELL__ >= 708 +instance VECTOR s ty a => Exts.IsList (Vector s ty a) where + type Item (Vector s ty a) = a + fromList = fromList + fromListN = fromListN + toList = toList +#endif + +-- | Return Pointer of the first element of the vector storage. +unsafeToPtr :: Storable a => Vector s ty a -> Ptr a +{-# INLINE unsafeToPtr #-} +unsafeToPtr (Vector fp off len) = unsafeInlineIO $ withForeignSEXP fp $ \sx -> + return $ Mutable.unsafeToPtr $ Mutable.MVector sx off len + +-- | /O(n)/ Create an immutable vector from a 'SEXP'. Because 'SEXP's are +-- mutable, this function yields an immutable /copy/ of the 'SEXP'. +fromSEXP :: (VECTOR s ty a) => SEXP s ty -> Vector s ty a +fromSEXP s = phony $ \p -> runST $ do w <- run (proxyFW G.clone (unsafeFromSEXP s) p) + v <- G.unsafeFreeze w + return (unW v) + +-- | /O(1)/ Unsafe convert a mutable 'SEXP' to an immutable vector without +-- copying. The mutable vector must not be used after this operation, lest one +-- runs the risk of breaking referential transparency. +unsafeFromSEXP :: VECTOR s ty a + => SEXP s ty + -> Vector s ty a +unsafeFromSEXP s = unsafeInlineIO $ do + sxp <- foreignSEXP s + l <- R.length s + return $ Vector sxp 0 (fromIntegral l) + +-- | /O(n)/ Yield a (mutable) copy of the vector as a 'SEXP'. +toSEXP :: VECTOR s ty a => Vector s ty a -> SEXP s ty +toSEXP s = phony $ \p -> runST $ do w <- run (proxyFW G.clone s p) + v <- G.unsafeFreeze w + return (unsafeToSEXP (unW v)) + +-- | /O(1)/ Unsafely convert an immutable vector to a (mutable) 'SEXP' without +-- copying. The immutable vector must not be used after this operation. +unsafeToSEXP :: VECTOR s ty a => Vector s ty a -> SEXP s ty +unsafeToSEXP (Vector (ForeignSEXP fsx) _ _) = unsafePerformIO $ -- XXX + withForeignPtr fsx $ return . R.sexp . castPtr + +-- | /O(n)/ Convert a character vector into a 'String'. +toString :: Vector s 'Char Word8 -> String +toString v = unsafeInlineIO $ + GHC.peekCStringLen utf8 ( castPtr $ unsafeToPtr v + , fromIntegral $ vectorLength v) + + +-- | /O(n)/ Convert a character vector into a strict 'ByteString'. +toByteString :: Vector s 'Char Word8 -> ByteString +toByteString v = unsafeInlineIO $ + B.packCStringLen ( castPtr $ unsafeToPtr v + , fromIntegral $ vectorLength v) + +------------------------------------------------------------------------ +-- Vector API +-- + +------------------------------------------------------------------------ +-- Length +------------------------------------------------------------------------ + +-- | /O(1)/ Yield the length of the vector. +length :: VECTOR s ty a => Vector s ty a -> Int +{-# INLINE length #-} +length v = phony $ proxyFW G.length v + +-- | /O(1)/ Test whether a vector if empty +null :: VECTOR s ty a => Vector s ty a -> Bool +{-# INLINE null #-} +null v = phony $ proxyFW G.null v + + +------------------------------------------------------------------------ +-- Indexing +------------------------------------------------------------------------ + +-- | O(1) Indexing +(!) :: VECTOR s ty a => Vector s ty a -> Int -> a +{-# INLINE (!) #-} +(!) v i = phony $ proxyFW (G.! i) v + +-- | O(1) Safe indexing +(!?) :: VECTOR s ty a => Vector s ty a -> Int -> Maybe a +{-# INLINE (!?) #-} +(!?) v i = phony $ proxyFW (G.!? i) v + +-- | /O(1)/ First element +head :: VECTOR s ty a => Vector s ty a -> a +{-# INLINE head #-} +head v = phony $ proxyFW G.head v + +-- | /O(1)/ Last element +last :: VECTOR s ty a => Vector s ty a -> a +{-# INLINE last #-} +last v = phony $ proxyFW G.last v + +-- | /O(1)/ Unsafe indexing without bounds checking +unsafeIndex :: VECTOR s ty a => Vector s ty a -> Int -> a +{-# INLINE unsafeIndex #-} +unsafeIndex v i = phony $ proxyFW (`G.unsafeIndex` i) v + +-- | /O(1)/ First element without checking if the vector is empty +unsafeHead :: VECTOR s ty a => Vector s ty a -> a +{-# INLINE unsafeHead #-} +unsafeHead v = phony $ proxyFW G.unsafeHead v + +-- | /O(1)/ Last element without checking if the vector is empty +unsafeLast :: VECTOR s ty a => Vector s ty a -> a +{-# INLINE unsafeLast #-} +unsafeLast v = phony $ proxyFW G.unsafeLast v + +------------------------------------------------------------------------ +-- 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 s ty a, Monad m) => Vector s ty a -> Int -> m a +{-# INLINE indexM #-} +indexM v i = phony $ proxyFW (`G.indexM` i) v + +-- | /O(1)/ First element of a vector in a monad. See 'indexM' for an +-- explanation of why this is useful. +headM :: (VECTOR s ty a, Monad m) => Vector s ty a -> m a +{-# INLINE headM #-} +headM v = phony $ proxyFW G.headM v + +-- | /O(1)/ Last element of a vector in a monad. See 'indexM' for an +-- explanation of why this is useful. +lastM :: (VECTOR s ty a, Monad m) => Vector s ty a -> m a +{-# INLINE lastM #-} +lastM v = phony $ proxyFW G.lastM v + +-- | /O(1)/ Indexing in a monad without bounds checks. See 'indexM' for an +-- explanation of why this is useful. +unsafeIndexM :: (VECTOR s ty a, Monad m) => Vector s ty a -> Int -> m a +{-# INLINE unsafeIndexM #-} +unsafeIndexM v = phony $ proxyFW G.unsafeIndexM v + +-- | /O(1)/ First element in a monad without checking for empty vectors. +-- See 'indexM' for an explanation of why this is useful. +unsafeHeadM :: (VECTOR s ty a, Monad m) => Vector s ty a -> m a +{-# INLINE unsafeHeadM #-} +unsafeHeadM v = phony $ proxyFW G.unsafeHeadM v + +-- | /O(1)/ Last element in a monad without checking for empty vectors. +-- See 'indexM' for an explanation of why this is useful. +unsafeLastM :: (VECTOR s ty a, Monad m) => Vector s ty a -> m a +{-# INLINE unsafeLastM #-} +unsafeLastM v = phony $ proxyFW G.unsafeLastM v + +------------------------------------------------------------------------ +-- Extracting subvectors (slicing) +------------------------------------------------------------------------ + +-- | /O(N)/ Yield a slice of the vector with copying it. The vector must +-- contain at least @i+n@ elements. +slice :: VECTOR s ty a + => Int -- ^ @i@ starting index + -> Int -- ^ @n@ length + -> Vector s ty a + -> Vector s ty a +{-# INLINE slice #-} +slice i n v = phony $ unW . proxyFW (G.slice i n) v + +-- | /O(N)/ Yield all but the last element, this operation will copy an array. +-- The vector may not be empty. +init :: VECTOR s ty a => Vector s ty a -> Vector s ty a +{-# INLINE init #-} +init v = phony $ unW . proxyFW G.init v + +-- | /O(N)/ Copy all but the first element. The vector may not be empty. +tail :: VECTOR s ty a => Vector s ty a -> Vector s ty a +{-# INLINE tail #-} +tail v = phony $ unW . proxyFW G.tail v + +-- | /O(N)/ Yield at the first @n@ elements with copying. The vector may +-- contain less than @n@ elements in which case it is returned unchanged. +take :: VECTOR s ty a => Int -> Vector s ty a -> Vector s ty a +{-# INLINE take #-} +take i v = phony $ unW . proxyFW (G.take i) v + +-- | /O(N)/ Yield all but the first @n@ elements with copying. The vector may +-- contain less than @n@ elements in which case an empty vector is returned. +drop :: VECTOR s ty a => Int -> Vector s ty a -> Vector s ty a +{-# INLINE drop #-} +drop i v = phony $ unW . proxyFW (G.drop i) v + +-- | /O(N)/ Yield the first @n@ elements paired with the remainder with copying. +-- +-- Note that @'splitAt' n v@ is equivalent to @('take' n v, 'drop' n v)@ +-- but slightly more efficient. +{-# INLINE splitAt #-} +splitAt :: VECTOR s ty a => Int -> Vector s ty a -> (Vector s ty a, Vector s ty a) +splitAt i v = phony $ (\(a,b) -> (unW a, unW b)) . proxyFW (G.splitAt i) v + +-- | /O(N)/ Yield a slice of the vector with copying. The vector must +-- contain at least @i+n@ elements but this is not checked. +unsafeSlice :: VECTOR s ty a => Int -- ^ @i@ starting index + -> Int -- ^ @n@ length + -> Vector s ty a + -> Vector s ty a +{-# INLINE unsafeSlice #-} +unsafeSlice i j v = phony $ unW . proxyFW (G.unsafeSlice i j) v + +-- | /O(N)/ Yield all but the last element with copying. The vector may not +-- be empty but this is not checked. +unsafeInit :: VECTOR s ty a => Vector s ty a -> Vector s ty a +{-# INLINE unsafeInit #-} +unsafeInit v = phony $ unW . proxyFW G.unsafeInit v + +-- | /O(N)/ Yield all but the first element with copying. The vector may not +-- be empty but this is not checked. +unsafeTail :: VECTOR s ty a => Vector s ty a -> Vector s ty a +{-# INLINE unsafeTail #-} +unsafeTail v = phony $ unW . proxyFW G.unsafeTail v + +-- | /O(N)/ Yield the first @n@ elements with copying. The vector must +-- contain at least @n@ elements but this is not checked. +unsafeTake :: VECTOR s ty a => Int -> Vector s ty a -> Vector s ty a +{-# INLINE unsafeTake #-} +unsafeTake i v = phony $ unW . proxyFW (G.unsafeTake i) v + +-- | /O(N)/ Yield all but the first @n@ elements with copying. The vector +-- must contain at least @n@ elements but this is not checked. +unsafeDrop :: VECTOR s ty a => Int -> Vector s ty a -> Vector s ty a +{-# INLINE unsafeDrop #-} +unsafeDrop i v = phony $ unW . proxyFW (G.unsafeDrop i) v + +-- Initialisation +-- -------------- + +-- | /O(1)/ Empty vector +empty :: VECTOR s ty a => Vector s ty a +{-# INLINE empty #-} +empty = phony $ proxyW G.empty + +-- | /O(1)/ Vector with exactly one element +singleton :: VECTOR s ty a => a -> Vector s ty a +{-# INLINE singleton #-} +singleton a = phony $ proxyW (G.singleton a) + +-- | /O(n)/ Vector of the given length with the same value in each position +replicate :: VECTOR s ty a => Int -> a -> Vector s ty a +{-# INLINE replicate #-} +replicate i v = phony $ proxyW (G.replicate i v) + +-- | /O(n)/ Construct a vector of the given length by applying the function to +-- each index +generate :: VECTOR s ty a => Int -> (Int -> a) -> Vector s ty a +{-# INLINE generate #-} +generate i f = phony $ proxyW (G.generate i f) + +-- | /O(n)/ Apply function n times to value. Zeroth element is original value. +iterateN :: VECTOR s ty a => Int -> (a -> a) -> a -> Vector s ty a +{-# INLINE iterateN #-} +iterateN i f a = phony $ proxyW (G.iterateN i f a) + +-- Unfolding +-- --------- +-- | /O(n)/ Construct a Vector s ty 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 s ty a => (b -> Maybe (a, b)) -> b -> Vector s ty a +{-# INLINE unfoldr #-} +unfoldr g a = phony $ proxyW (G.unfoldr g a) + +-- | /O(n)/ Construct a vector with at most @n@ by repeatedly applying the +-- generator function to the 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 s ty a => Int -> (b -> Maybe (a, b)) -> b -> Vector s ty a +{-# INLINE unfoldrN #-} +unfoldrN n g a = phony $ proxyW (G.unfoldrN n g a) + +-- | /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 ; c = f in f +-- +constructN :: VECTOR s ty a => Int -> (Vector s ty a -> a) -> Vector s ty a +{-# INLINE constructN #-} +constructN n g = phony $ proxyW (G.constructN n (g.unW)) + +-- | /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 ; c = f in f +-- +constructrN :: VECTOR s ty a => Int -> (Vector s ty a -> a) -> Vector s ty a +{-# INLINE constructrN #-} +constructrN n g = phony $ proxyW (G.constructrN n (g.unW)) + +-- 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 s ty a, Num a) => a -> Int -> Vector s ty a +{-# INLINE enumFromN #-} +enumFromN a i = phony $ proxyW (G.enumFromN a i) + +-- | /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 :: (VECTOR s ty a, Num a) => a -> a -> Int -> Vector s ty a +{-# INLINE enumFromStepN #-} +enumFromStepN f t s = phony $ proxyW (G.enumFromStepN f t s) + +-- | /O(n)/ Enumerate values from @x@ to @y@. +-- +-- /WARNING:/ This operation can be very inefficient. If at all possible, use +-- 'enumFromN' instead. +enumFromTo :: (VECTOR s ty a, Enum a) => a -> a -> Vector s ty a +{-# INLINE enumFromTo #-} +enumFromTo f t = phony $ proxyW (G.enumFromTo f t) + +-- | /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 s ty a, Enum a) => a -> a -> a -> Vector s ty a +{-# INLINE enumFromThenTo #-} +enumFromThenTo f t s = phony $ proxyW (G.enumFromThenTo f t s) + +-- Concatenation +-- ------------- + +-- | /O(n)/ Prepend an element +cons :: VECTOR s ty a => a -> Vector s ty a -> Vector s ty a +{-# INLINE cons #-} +cons a v = phony $ unW . proxyFW (G.cons a) v + +-- | /O(n)/ Append an element +snoc :: VECTOR s ty a => Vector s ty a -> a -> Vector s ty a +{-# INLINE snoc #-} +snoc v a = phony $ unW . proxyFW (`G.snoc` a) v + +infixr 5 ++ +-- | /O(m+n)/ Concatenate two vectors +(++) :: VECTOR s ty a => Vector s ty a -> Vector s ty a -> Vector s ty a +{-# INLINE (++) #-} +v1 ++ v2 = phony $ unW . proxyFW2 (G.++) v1 v2 + +-- | /O(n)/ Concatenate all vectors in the list +concat :: VECTOR s ty a => [Vector s ty a] -> Vector s ty a +{-# INLINE concat #-} +concat vs = phony $ \p -> unW $ G.concat $ Prelude.map (withW p) vs + +-- Monadic initialisation +-- ---------------------- + +-- | /O(n)/ Execute the monadic action the given number of times and store the +-- results in a vector. +replicateM :: (Monad m, VECTOR s ty a) => Int -> m a -> m (Vector s ty a) +{-# INLINE replicateM #-} +replicateM n f = phony $ \p -> (\v -> proxyW v p) <$> G.replicateM n f + +-- | /O(n)/ Construct a vector of the given length by applying the monadic +-- action to each index +generateM :: (Monad m, VECTOR s ty a) => Int -> (Int -> m a) -> m (Vector s ty a) +{-# INLINE generateM #-} +generateM n f = phony $ \p -> (\v -> proxyW v p) <$> G.generateM n f + +-- | 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 :: VECTOR s ty a => (forall r. ST r (MVector r ty a)) -> Vector s ty a +{-# INLINE create #-} +-- NOTE: eta-expanded due to http://hackage.haskell.org/trac/ghc/ticket/4120 +create f = phony $ \p -> unW $ G.create (Mutable.withW p <$> f) + +-- 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 ) +-- +-- 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 s ty a => Vector s ty a -> Vector s ty a +{-# INLINE force #-} +force v = phony $ unW . proxyFW G.force 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 s ty a + => Vector s ty a -- ^ initial vector (of length @m@) + -> [(Int, a)] -- ^ list of index/value pairs (of length @n@) + -> Vector s ty a +{-# INLINE (//) #-} +(//) v l = phony $ unW . proxyFW (G.// l) v + +{- +-- | /O(m+min(n1,n2))/ For each index @i@ from the index Vector s ty and the +-- corresponding value @a@ from the value vector, replace the element of the +-- initial Vector s ty at position @i@ by @a@. +-- +-- > update_ <5,9,2,7> <2,0,2> <1,3,8> = <3,9,8,7> +-- +update_ :: VECTOR s ty a + => Vector s ty a -- ^ initial vector (of length @m@) + -> Vector Int -- ^ index vector (of length @n1@) + -> Vector s ty a -- ^ value vector (of length @n2@) + -> Vector s ty a +{-# INLINE update_ #-} +update_ = G.update_ +-} + +-- | Same as ('//') but without bounds checking. +unsafeUpd :: VECTOR s ty a => Vector s ty a -> [(Int, a)] -> Vector s ty a +{-# INLINE unsafeUpd #-} +unsafeUpd v l = phony $ unW . proxyFW (`G.unsafeUpd` l) v + +{- +-- | Same as 'update_' but without bounds checking. +unsafeUpdate_ :: VECTOR s ty a => Vector s ty a -> Vector Int -> Vector s ty a -> Vector s ty 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 :: VECTOR s ty a + => (a -> b -> a) -- ^ accumulating function @f@ + -> Vector s ty a -- ^ initial vector (of length @m@) + -> [(Int,b)] -- ^ list of index/value pairs (of length @n@) + -> Vector s ty a +{-# INLINE accum #-} +accum f v l = phony $ unW . proxyFW (\w -> G.accum f w l) v + +{- +-- | /O(m+min(n1,n2))/ For each index @i@ from the index Vector s ty and the +-- corresponding value @b@ from the the value vector, +-- replace the element of the initial Vector s ty 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_ :: (VECTOR s ty a, VECTOR s ty b) + => (a -> b -> a) -- ^ accumulating function @f@ + -> Vector s ty a -- ^ initial vector (of length @m@) + -> Vector Int -- ^ index vector (of length @n1@) + -> Vector s ty b -- ^ value vector (of length @n2@) + -> Vector s ty a +{-# INLINE accumulate_ #-} +accumulate_ = G.accumulate_ +-} + +-- | Same as 'accum' but without bounds checking. +unsafeAccum :: VECTOR s ty a => (a -> b -> a) -> Vector s ty a -> [(Int,b)] -> Vector s ty a +{-# INLINE unsafeAccum #-} +unsafeAccum f v l = phony $ unW . proxyFW (\w -> G.unsafeAccum f w l) v + +{- +-- | Same as 'accumulate_' but without bounds checking. +unsafeAccumulate_ :: (VECTOR s ty a, VECTOR s ty b) => + (a -> b -> a) -> Vector s ty a -> Vector Int -> Vector s ty b -> Vector s ty a +{-# INLINE unsafeAccumulate_ #-} +unsafeAccumulate_ = G.unsafeAccumulate_ +-} + +-- Permutations +-- ------------ + +-- | /O(n)/ Reverse a vector +reverse :: VECTOR s ty a => Vector s ty a -> Vector s ty a +{-# INLINE reverse #-} +reverse v = phony $ unW . proxyFW G.reverse v + +{- +-- | /O(n)/ Yield the vector obtained by replacing each element @i@ of the +-- index Vector s ty by @xs'!'i@. This is equivalent to @'map' (xs'!') is@ but is +-- often much more efficient. +-- +-- > backpermute <0,3,2,3,1,0> = +backpermute :: VECTOR s ty a => Vector s ty a -> Vector Int -> Vector s ty a +{-# INLINE backpermute #-} +backpermute = G.backpermute +-} + +{- +-- | Same as 'backpermute' but without bounds checking. +unsafeBackpermute :: VECTOR s ty a => Vector s ty a -> Vector Int -> Vector s ty 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 :: VECTOR s ty a => (forall s. MVector s a -> ST s ()) -> Vector s ty a -> Vector s ty a +{-# INLINE modify #-} +modify p = G.modify p +-} + +-- Mapping +-- ------- + +-- | /O(n)/ Map a function over a vector +map :: (VECTOR s ty a, VECTOR s ty b) => (a -> b) -> Vector s ty a -> Vector s ty b +{-# INLINE map #-} +map f v = phony $ unW . proxyFW (G.map f) v + +-- | /O(n)/ Apply a function to every element of a Vector s ty and its index +imap :: (VECTOR s ty a, VECTOR s ty b) => (Int -> a -> b) -> Vector s ty a -> Vector s ty b +{-# INLINE imap #-} +imap f v = phony $ unW . proxyFW (G.imap f) v + + +-- | Map a function over a Vector s ty and concatenate the results. +concatMap :: (VECTOR s tya a, VECTOR s tyb b) + => (a -> Vector s tyb b) + -> Vector s tya a + -> Vector s tyb b +{-# INLINE concatMap #-} +#if MIN_VERSION_vector(0,11,0) +concatMap f v = phony $ \p -> + let v' = G.stream (withW p v) + in proxyW (G.unstream $ Bundle.fromStream (Stream.concatMap (sElems . G.stream . withW p . f) (sElems v')) Unknown) p +#else +concatMap f v = + phony $ \p -> + (`proxyW` p) $ + G.unstream $ + Stream.concatMap (G.stream . withW p . f) $ + G.stream $ + withW p v +#endif + +-- Monadic mapping +-- --------------- + +-- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a +-- vector of results +mapM :: (Monad m, VECTOR s ty a, VECTOR s ty b) => (a -> m b) -> Vector s ty a -> m (Vector s ty b) +{-# INLINE mapM #-} +mapM f v = phony $ \p -> unW <$> proxyFW (G.mapM f) v p + +-- | /O(n)/ Apply the monadic action to all elements of a Vector s ty and ignore the +-- results +mapM_ :: (Monad m, VECTOR s ty a) => (a -> m b) -> Vector s ty a -> m () +{-# INLINE mapM_ #-} +mapM_ f v = phony $ proxyFW (G.mapM_ f) v + +-- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a +-- vector of results. Equvalent to @flip 'mapM'@. +forM :: (Monad m, VECTOR s ty a, VECTOR s ty b) => Vector s ty a -> (a -> m b) -> m (Vector s ty b) +{-# INLINE forM #-} +forM v f = phony $ \p -> unW <$> proxyFW (`G.forM` f) v p + +-- | /O(n)/ Apply the monadic action to all elements of a Vector s ty and ignore the +-- results. Equivalent to @flip 'mapM_'@. +forM_ :: (Monad m, VECTOR s ty a) => Vector s ty a -> (a -> m b) -> m () +{-# INLINE forM_ #-} +forM_ v f = phony $ proxyFW (`G.forM_` f) v + +-- Zipping +-- ------- +#if MIN_VERSION_vector(0,11,0) +smallest :: [Size] -> Size +smallest = List.foldl1' smaller +#endif + +-- | /O(min(m,n))/ Zip two vectors with the given function. +zipWith :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c) + => (a -> b -> c) -> Vector s tya a -> Vector s tyb b -> Vector s tyc c +{-# INLINE zipWith #-} +#if MIN_VERSION_vector(0,11,0) +zipWith f xs ys = phony $ \p -> + let xs' = G.stream (withW p xs) + ys' = G.stream (withW p ys) + sz = smaller (sSize xs') (sSize ys') + in proxyW (G.unstream $ Bundle.fromStream (Stream.zipWith f (sElems xs') (sElems ys')) sz) p +#else +zipWith f xs ys = phony $ \p -> + proxyW (G.unstream (Stream.zipWith f (G.stream (withW p xs)) (G.stream (withW p ys)))) p +#endif + +-- | Zip three vectors with the given function. +zipWith3 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d) + => (a -> b -> c -> d) -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d +{-# INLINE zipWith3 #-} +#if MIN_VERSION_vector(0,11,0) +zipWith3 f as bs cs = phony $ \p -> + let as' = G.stream (withW p as) + bs' = G.stream (withW p bs) + cs' = G.stream (withW p cs) + sz = smallest [sSize as', sSize bs', sSize cs'] + in proxyW (G.unstream $ Bundle.fromStream (Stream.zipWith3 f (sElems as') (sElems bs') (sElems cs')) sz) p +#else +zipWith3 f as bs cs = phony $ \p -> + proxyW (G.unstream (Stream.zipWith3 f (G.stream (withW p as)) (G.stream (withW p bs)) (G.stream (withW p cs)))) p +#endif + +zipWith4 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d, VECTOR s tye e) + => (a -> b -> c -> d -> e) + -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -> Vector s tye e +{-# INLINE zipWith4 #-} +#if MIN_VERSION_vector(0,11,0) +zipWith4 f as bs cs ds = phony $ \p -> + let as' = G.stream (withW p as) + bs' = G.stream (withW p bs) + cs' = G.stream (withW p cs) + ds' = G.stream (withW p ds) + sz = smallest [sSize as', sSize bs', sSize cs', sSize ds'] + in proxyW (G.unstream $ Bundle.fromStream (Stream.zipWith4 f (sElems as') (sElems bs') (sElems cs') (sElems ds')) sz) p +#else +zipWith4 f as bs cs ds = phony $ \p -> + proxyW (G.unstream (Stream.zipWith4 f (G.stream (withW p as)) (G.stream (withW p bs)) (G.stream (withW p cs)) (G.stream (withW p ds)))) p +#endif + +zipWith5 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d, VECTOR s tye e, + VECTOR s tyf f) + => (a -> b -> c -> d -> e -> f) + -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -> Vector s tye e + -> Vector s tyf f +{-# INLINE zipWith5 #-} +#if MIN_VERSION_vector(0,11,0) +zipWith5 f as bs cs ds es = phony $ \p -> + let as' = G.stream (withW p as) + bs' = G.stream (withW p bs) + cs' = G.stream (withW p cs) + ds' = G.stream (withW p ds) + es' = G.stream (withW p es) + sz = smallest [sSize as', sSize bs', sSize cs', sSize ds', sSize es'] + in proxyW (G.unstream $ Bundle.fromStream (Stream.zipWith5 f (sElems as') (sElems bs') (sElems cs') (sElems ds') (sElems es')) sz) p +#else +zipWith5 f as bs cs ds es = phony $ \p -> + proxyW (G.unstream (Stream.zipWith5 f (G.stream (withW p as)) (G.stream (withW p bs)) (G.stream (withW p cs)) (G.stream (withW p ds)) (G.stream (withW p es)))) p +#endif + +zipWith6 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d, VECTOR s tye e, + VECTOR s tyf f, VECTOR s tyg g) + => (a -> b -> c -> d -> e -> f -> g) + -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -> Vector s tye e + -> Vector s tyf f -> Vector s tyg g +{-# INLINE zipWith6 #-} +#if MIN_VERSION_vector(0,11,0) +zipWith6 f as bs cs ds es fs = phony $ \p -> + let as' = G.stream (withW p as) + bs' = G.stream (withW p bs) + cs' = G.stream (withW p cs) + ds' = G.stream (withW p ds) + es' = G.stream (withW p es) + fs' = G.stream (withW p fs) + sz = smallest [sSize as', sSize bs', sSize cs', sSize ds', sSize es', sSize fs'] + in proxyW (G.unstream $ Bundle.fromStream (Stream.zipWith6 f (sElems as') (sElems bs') (sElems cs') (sElems ds') (sElems es') (sElems fs')) sz) p +#else +zipWith6 f as bs cs ds es fs = phony $ \p -> + proxyW (G.unstream (Stream.zipWith6 f (G.stream (withW p as)) (G.stream (withW p bs)) (G.stream (withW p cs)) (G.stream (withW p ds)) (G.stream (withW p es)) (G.stream (withW p fs)))) p +#endif + +-- | /O(min(m,n))/ Zip two vectors with a function that also takes the +-- elements' indices. +izipWith :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c) + => (Int -> a -> b -> c) -> Vector s tya a -> Vector s tyb b -> Vector s tyc c +{-# INLINE izipWith #-} +#if MIN_VERSION_vector(0,11,0) +izipWith f as bs = phony $ \p -> + let as' = G.stream (withW p as) + bs' = G.stream (withW p bs) + sz = smaller (sSize as') (sSize bs') + in proxyW (G.unstream $ Bundle.fromStream (Stream.zipWith (uncurry f) (Stream.indexed (sElems as')) (sElems bs')) sz) p +#else +izipWith f as bs = phony $ \p -> + proxyW (G.unstream (Stream.zipWith (uncurry f) (Stream.indexed (G.stream (withW p as))) (G.stream (withW p bs)))) p +#endif + +-- | Zip three vectors and their indices with the given function. +izipWith3 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d) + => (Int -> a -> b -> c -> d) + -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d +{-# INLINE izipWith3 #-} +#if MIN_VERSION_vector(0,11,0) +izipWith3 f as bs cs = phony $ \p -> + let as' = G.stream (withW p as) + bs' = G.stream (withW p bs) + cs' = G.stream (withW p cs) + sz = smallest [sSize as', sSize bs', sSize cs'] + in proxyW (G.unstream $ Bundle.fromStream (Stream.zipWith3 (uncurry f) (Stream.indexed (sElems as')) (sElems bs') (sElems cs')) sz) p +#else +izipWith3 f as bs cs = phony $ \p -> + proxyW (G.unstream (Stream.zipWith3 (uncurry f) (Stream.indexed (G.stream (withW p as))) (G.stream (withW p bs)) (G.stream (withW p cs)))) p +#endif + +izipWith4 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d, VECTOR s tye e) + => (Int -> a -> b -> c -> d -> e) + -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -> Vector s tye e +{-# INLINE izipWith4 #-} +#if MIN_VERSION_vector(0,11,0) +izipWith4 f as bs cs ds = phony $ \p -> + let as' = G.stream (withW p as) + bs' = G.stream (withW p bs) + cs' = G.stream (withW p cs) + ds' = G.stream (withW p ds) + sz = smallest [ sSize as', sSize bs', sSize cs', sSize ds'] + in proxyW (G.unstream $ Bundle.fromStream (Stream.zipWith4 (uncurry f) (Stream.indexed (sElems as')) (sElems bs') (sElems cs') (sElems ds')) sz) p +#else +izipWith4 f as bs cs ds = phony $ \p -> + proxyW (G.unstream (Stream.zipWith4 (uncurry f) (Stream.indexed (G.stream (withW p as))) (G.stream (withW p bs)) (G.stream (withW p cs)) (G.stream (withW p ds)))) p +#endif + +izipWith5 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d, VECTOR s tye e, + VECTOR s tyf f) + => (Int -> a -> b -> c -> d -> e -> f) + -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -> Vector s tye e + -> Vector s tyf f +{-# INLINE izipWith5 #-} +#if MIN_VERSION_vector(0,11,0) +izipWith5 f as bs cs ds es = phony $ \p -> + let as' = G.stream (withW p as) + bs' = G.stream (withW p bs) + cs' = G.stream (withW p cs) + ds' = G.stream (withW p ds) + es' = G.stream (withW p es) + sz = smallest [ sSize as', sSize bs', sSize cs', sSize ds', sSize es'] + in proxyW (G.unstream $ Bundle.fromStream (Stream.zipWith5 (uncurry f) (Stream.indexed (sElems as')) (sElems bs') (sElems cs') (sElems ds') (sElems es')) sz) p +#else +izipWith5 f as bs cs ds es = phony $ \p -> + proxyW (G.unstream (Stream.zipWith5 (uncurry f) (Stream.indexed (G.stream (withW p as))) (G.stream (withW p bs)) (G.stream (withW p cs)) (G.stream (withW p ds)) (G.stream (withW p es)))) p +#endif + +izipWith6 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d, VECTOR s tye e, + VECTOR s tyf f, VECTOR s tyg g) + => (Int -> a -> b -> c -> d -> e -> f -> g) + -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -> Vector s tye e + -> Vector s tyf f -> Vector s tyg g +{-# INLINE izipWith6 #-} +#if MIN_VERSION_vector(0,11,0) +izipWith6 f as bs cs ds es fs = phony $ \p -> + let as' = G.stream (withW p as) + bs' = G.stream (withW p bs) + cs' = G.stream (withW p cs) + ds' = G.stream (withW p ds) + es' = G.stream (withW p es) + fs' = G.stream (withW p fs) + sz = smallest [ sSize as', sSize bs', sSize cs', sSize ds', sSize es', sSize fs'] + in proxyW (G.unstream $ Bundle.fromStream (Stream.zipWith6 (uncurry f) (Stream.indexed (sElems as')) (sElems bs') (sElems cs') (sElems ds') (sElems es') (sElems fs')) sz) p +#else +izipWith6 f as bs cs ds es fs = phony $ \p -> + proxyW (G.unstream (Stream.zipWith6 (uncurry f) (Stream.indexed (G.stream (withW p as))) (G.stream (withW p bs)) (G.stream (withW p cs)) (G.stream (withW p ds)) (G.stream (withW p es)) (G.stream (withW p fs)))) p +#endif + +-- Monadic zipping +-- --------------- + + +-- | /O(min(m,n))/ Zip the two vectors with the monadic action and yield a +-- vector of results +zipWithM :: (MonadR m, VECTOR (Region m) tya a, VECTOR (Region m) tyb b, VECTOR (Region m) tyc c) + => (a -> b -> m c) + -> Vector (Region m) tya a + -> Vector (Region m) tyb b + -> m (Vector (Region m) tyc c) +{-# INLINE zipWithM #-} +#if MIN_VERSION_vector(0,11,0) +zipWithM f xs ys = phony $ \p -> + let xs' = lift $ G.stream (withW p xs) + ys' = lift $ G.stream (withW p ys) + sz = smaller (sSize xs') (sSize ys') + in proxyW <$> Prelude.fmap G.unstream (Bundle.unsafeFromList sz <$> Stream.toList (Stream.zipWithM f (sElems xs') (sElems ys'))) + <*> pure p +#else +zipWithM f xs ys = phony $ \p -> + proxyW <$> + unstreamM (Stream.zipWithM f (G.stream (withW p xs)) (G.stream (withW p ys))) <*> + return p + where + -- Inlined from vector-0.10, which doesn't export unstreamM. + unstreamM s = do + zs <- MStream.toList s + return $ G.unstream $ Stream.unsafeFromList (MStream.size s) zs +#endif + + +-- | /O(min(m,n))/ Zip the two vectors with the monadic action and ignore the +-- results +zipWithM_ :: (Monad m, VECTOR s tya a, VECTOR s tyb b) + => (a -> b -> m c) + -> Vector s tya a + -> Vector s tyb b + -> m () +{-# INLINE zipWithM_ #-} +#if MIN_VERSION_vector(0,11,0) +zipWithM_ f xs ys = phony $ \p -> + let xs' = lift $ G.stream (withW p xs) + ys' = lift $ G.stream (withW p ys) + in Stream.zipWithM_ f (sElems xs') (sElems ys') +#else +zipWithM_ f xs ys = phony $ \p -> + Stream.zipWithM_ f (G.stream (withW p xs)) (G.stream (withW p ys)) +#endif + +-- Filtering +-- --------- + +-- | /O(n)/ Drop elements that do not satisfy the predicate +filter :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Vector s ty a +{-# INLINE filter #-} +filter f v = phony $ unW . proxyFW (G.filter f) v + +-- | /O(n)/ Drop elements that do not satisfy the predicate which is applied to +-- values and their indices +ifilter :: VECTOR s ty a => (Int -> a -> Bool) -> Vector s ty a -> Vector s ty a +{-# INLINE ifilter #-} +ifilter f v = phony $ unW . proxyFW (G.ifilter f) v + +-- | /O(n)/ Drop elements that do not satisfy the monadic predicate +filterM :: (Monad m, VECTOR s ty a) => (a -> m Bool) -> Vector s ty a -> m (Vector s ty a) +{-# INLINE filterM #-} +filterM f v = phony $ \p -> unW <$> proxyFW (G.filterM f) v p + +-- | /O(n)/ Yield the longest prefix of elements satisfying the predicate +-- with copying. +takeWhile :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Vector s ty a +{-# INLINE takeWhile #-} +takeWhile f v = phony $ unW . proxyFW (G.takeWhile f) v + +-- | /O(n)/ Drop the longest prefix of elements that satisfy the predicate +-- with copying. +dropWhile :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Vector s ty a +{-# INLINE dropWhile #-} +dropWhile f v = phony $ unW . proxyFW (G.dropWhile f) v + +-- 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 s ty a => (a -> Bool) -> Vector s ty a -> (Vector s ty a, Vector s ty a) +{-# INLINE partition #-} +partition f v = phony $ (\(a,b) -> (unW a, unW b)) . proxyFW (G.partition f) v + +-- | /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 s ty a => (a -> Bool) -> Vector s ty a -> (Vector s ty a, Vector s ty a) +{-# INLINE unstablePartition #-} +unstablePartition f v = phony $ (\(a,b) -> (unW a, unW b)) . proxyFW (G.unstablePartition f) v + +-- | /O(n)/ Split the vector into the longest prefix of elements that satisfy +-- the predicate and the rest with copying. +span :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> (Vector s ty a, Vector s ty a) +{-# INLINE span #-} +span f v = phony $ (\(a,b) -> (unW a, unW b)) . proxyFW (G.span f) v + +-- | /O(n)/ Split the vector into the longest prefix of elements that do not +-- satisfy the predicate and the rest with copying. +break :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> (Vector s ty a, Vector s ty a) +{-# INLINE break #-} +break f v = phony $ (\(a,b) -> (unW a, unW b)) . proxyFW (G.break f) v + +-- Searching +-- --------- + +infix 4 `elem` +-- | /O(n)/ Check if the vector contains an element +elem :: (VECTOR s ty a, Eq a) => a -> Vector s ty a -> Bool +{-# INLINE elem #-} +elem a v = phony $ proxyFW (G.elem a) v + +infix 4 `notElem` +-- | /O(n)/ Check if the vector does not contain an element (inverse of 'elem') +notElem :: (VECTOR s ty a, Eq a) => a -> Vector s ty a -> Bool +{-# INLINE notElem #-} +notElem a v = phony $ proxyFW (G.notElem a) v + +-- | /O(n)/ Yield 'Just' the first element matching the predicate or 'Nothing' +-- if no such element exists. +find :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Maybe a +{-# INLINE find #-} +find f v = phony $ proxyFW (G.find f) v + +-- | /O(n)/ Yield 'Just' the index of the first element matching the predicate +-- or 'Nothing' if no such element exists. +findIndex :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Maybe Int +{-# INLINE findIndex #-} +findIndex f v = phony $ proxyFW (G.findIndex f) v + +{- +-- | /O(n)/ Yield the indices of elements satisfying the predicate in ascending +-- order. +findIndices :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Vector Int +{-# INLINE findIndices #-} +findIndices f v = phony $ proxyFW (G.findIndices f) v +-} + +-- | /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 s ty a, Eq a) => a -> Vector s ty a -> Maybe Int +{-# INLINE elemIndex #-} +elemIndex a v = phony $ proxyFW (G.elemIndex a) v + +{- +-- | /O(n)/ Yield the indices of all occurences of the given element in +-- ascending order. This is a specialised version of 'findIndices'. +elemIndices :: (VECTOR s ty a, Eq a) => a -> Vector s ty a -> Vector s 'R.Int Int32 +{-# INLINE elemIndices #-} +elemIndices s v = phony $ unW . proxyFW (G.elemIndices s) v +-} + +-- Folding +-- ------- + +-- | /O(n)/ Left fold +foldl :: VECTOR s ty b => (a -> b -> a) -> a -> Vector s ty b -> a +{-# INLINE foldl #-} +foldl f s v = phony $ proxyFW (G.foldl f s) v + +-- | /O(n)/ Left fold on non-empty vectors +foldl1 :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> a +{-# INLINE foldl1 #-} +foldl1 f v = phony $ proxyFW (G.foldl1 f) v + +-- | /O(n)/ Left fold with strict accumulator +foldl' :: VECTOR s ty b => (a -> b -> a) -> a -> Vector s ty b -> a +{-# INLINE foldl' #-} +foldl' f s v = phony $ proxyFW (G.foldl' f s) v + +-- | /O(n)/ Left fold on non-empty vectors with strict accumulator +foldl1' :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> a +{-# INLINE foldl1' #-} +foldl1' f v = phony $ proxyFW (G.foldl1' f) v + +-- | /O(n)/ Right fold +foldr :: VECTOR s ty a => (a -> b -> b) -> b -> Vector s ty a -> b +{-# INLINE foldr #-} +foldr f s v = phony $ proxyFW (G.foldr f s) v + +-- | /O(n)/ Right fold on non-empty vectors +foldr1 :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> a +{-# INLINE foldr1 #-} +foldr1 f v = phony $ proxyFW (G.foldr1 f) v + +-- | /O(n)/ Right fold with a strict accumulator +foldr' :: VECTOR s ty a => (a -> b -> b) -> b -> Vector s ty a -> b +{-# INLINE foldr' #-} +foldr' f s v = phony $ proxyFW (G.foldr' f s) v + +-- | /O(n)/ Right fold on non-empty vectors with strict accumulator +foldr1' :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> a +{-# INLINE foldr1' #-} +foldr1' f v = phony $ proxyFW (G.foldr1' f) v + +-- | /O(n)/ Left fold (function applied to each element and its index) +ifoldl :: VECTOR s ty b => (a -> Int -> b -> a) -> a -> Vector s ty b -> a +{-# INLINE ifoldl #-} +ifoldl f s v = phony $ proxyFW (G.ifoldl f s) v + +-- | /O(n)/ Left fold with strict accumulator (function applied to each element +-- and its index) +ifoldl' :: VECTOR s ty b => (a -> Int -> b -> a) -> a -> Vector s ty b -> a +{-# INLINE ifoldl' #-} +ifoldl' f s v = phony $ proxyFW (G.ifoldl' f s) v + +-- | /O(n)/ Right fold (function applied to each element and its index) +ifoldr :: VECTOR s ty a => (Int -> a -> b -> b) -> b -> Vector s ty a -> b +{-# INLINE ifoldr #-} +ifoldr f s v = phony $ proxyFW (G.ifoldr f s) v + +-- | /O(n)/ Right fold with strict accumulator (function applied to each +-- element and its index) +ifoldr' :: VECTOR s ty a => (Int -> a -> b -> b) -> b -> Vector s ty a -> b +{-# INLINE ifoldr' #-} +ifoldr' f s v = phony $ proxyFW (G.ifoldr' f s) v + +-- Specialised folds +-- ----------------- + + +-- | /O(n)/ Check if all elements satisfy the predicate. +all :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Bool +{-# INLINE all #-} +all f v = phony $ \p -> G.all f (withW p v) + +-- | /O(n)/ Check if any element satisfies the predicate. +any :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Bool +{-# INLINE any #-} +any f v = phony $ \p -> G.any f (withW p v) + +-- -- | /O(n)/ Check if all elements are 'True' +-- and :: Vector s 'Logical Bool -> Bool +-- {-# INLINE and #-} +-- and v = phony $ \p -> G.and (withW p v) +-- +-- -- | /O(n)/ Check if any element is 'True' +-- or :: Vector s 'Logical Bool -> Bool +-- {-# INLINE or #-} +-- or v = phony $ \p -> G.or (withW p v) + +-- | /O(n)/ Compute the sum of the elements +sum :: (VECTOR s ty a, Num a) => Vector s ty a -> a +{-# INLINE sum #-} +sum v = phony $ proxyFW G.sum v + +-- | /O(n)/ Compute the produce of the elements +product :: (VECTOR s ty a, Num a) => Vector s ty a -> a +{-# INLINE product #-} +product v = phony $ proxyFW G.product v + +-- | /O(n)/ Yield the maximum element of the vector. The vector may not be +-- empty. +maximum :: (VECTOR s ty a, Ord a) => Vector s ty a -> a +{-# INLINE maximum #-} +maximum v = phony $ proxyFW G.maximum v + +-- | /O(n)/ Yield the maximum element of the Vector s ty according to the given +-- comparison function. The vector may not be empty. +maximumBy :: VECTOR s ty a => (a -> a -> Ordering) -> Vector s ty a -> a +{-# INLINE maximumBy #-} +maximumBy f v = phony $ proxyFW (G.maximumBy f) v + +-- | /O(n)/ Yield the minimum element of the vector. The vector may not be +-- empty. +minimum :: (VECTOR s ty a, Ord a) => Vector s ty a -> a +{-# INLINE minimum #-} +minimum v = phony $ proxyFW G.minimum v + +-- | /O(n)/ Yield the minimum element of the Vector s ty according to the given +-- comparison function. The vector may not be empty. +minimumBy :: VECTOR s ty a => (a -> a -> Ordering) -> Vector s ty a -> a +{-# INLINE minimumBy #-} +minimumBy f v = phony $ proxyFW (G.minimumBy f) v + +-- | /O(n)/ Yield the index of the maximum element of the vector. The vector +-- may not be empty. +maxIndex :: (VECTOR s ty a, Ord a) => Vector s ty a -> Int +{-# INLINE maxIndex #-} +maxIndex v = phony $ proxyFW G.maxIndex v + +-- | /O(n)/ Yield the index of the maximum element of the Vector s ty according to +-- the given comparison function. The vector may not be empty. +maxIndexBy :: VECTOR s ty a => (a -> a -> Ordering) -> Vector s ty a -> Int +{-# INLINE maxIndexBy #-} +maxIndexBy f v = phony $ proxyFW (G.maxIndexBy f) v + +-- | /O(n)/ Yield the index of the minimum element of the vector. The vector +-- may not be empty. +minIndex :: (VECTOR s ty a, Ord a) => Vector s ty a -> Int +{-# INLINE minIndex #-} +minIndex v = phony $ proxyFW G.minIndex v + +-- | /O(n)/ Yield the index of the minimum element of the Vector s ty according to +-- the given comparison function. The vector may not be empty. +minIndexBy :: VECTOR s ty a => (a -> a -> Ordering) -> Vector s ty a -> Int +{-# INLINE minIndexBy #-} +minIndexBy f v = phony $ proxyFW (G.minIndexBy f) v + +-- Monadic folds +-- ------------- + +-- | /O(n)/ Monadic fold +foldM :: (Monad m, VECTOR s ty b) => (a -> b -> m a) -> a -> Vector s ty b -> m a +{-# INLINE foldM #-} +foldM f s v = phony $ proxyFW (G.foldM f s) v + +-- | /O(n)/ Monadic fold over non-empty vectors +fold1M :: (Monad m, VECTOR s ty a) => (a -> a -> m a) -> Vector s ty a -> m a +{-# INLINE fold1M #-} +fold1M f v = phony $ proxyFW (G.fold1M f) v + +-- | /O(n)/ Monadic fold with strict accumulator +foldM' :: (Monad m, VECTOR s ty b) => (a -> b -> m a) -> a -> Vector s ty b -> m a +{-# INLINE foldM' #-} +foldM' f s v = phony $ proxyFW (G.foldM' f s) v + +-- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator +fold1M' :: (Monad m, VECTOR s ty a) => (a -> a -> m a) -> Vector s ty a -> m a +{-# INLINE fold1M' #-} +fold1M' f v = phony $ proxyFW (G.fold1M' f) v + +-- | /O(n)/ Monadic fold that discards the result +foldM_ :: (Monad m, VECTOR s ty b) => (a -> b -> m a) -> a -> Vector s ty b -> m () +{-# INLINE foldM_ #-} +foldM_ f s v = phony $ proxyFW (G.foldM_ f s) v + +-- | /O(n)/ Monadic fold over non-empty vectors that discards the result +fold1M_ :: (Monad m, VECTOR s ty a) => (a -> a -> m a) -> Vector s ty a -> m () +{-# INLINE fold1M_ #-} +fold1M_ f v = phony $ proxyFW (G.fold1M_ f) v + +-- | /O(n)/ Monadic fold with strict accumulator that discards the result +foldM'_ :: (Monad m, VECTOR s ty b) => (a -> b -> m a) -> a -> Vector s ty b -> m () +{-# INLINE foldM'_ #-} +foldM'_ f s v = phony $ proxyFW (G.foldM'_ f s) v + +-- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator +-- that discards the result +fold1M'_ :: (Monad m, VECTOR s ty a) => (a -> a -> m a) -> Vector s ty a -> m () +{-# INLINE fold1M'_ #-} +fold1M'_ f v = phony $ proxyFW (G.fold1M'_ f) v + +-- 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 s ty a, VECTOR s ty b) => (a -> b -> a) -> a -> Vector s ty b -> Vector s ty a +{-# INLINE prescanl #-} +prescanl f s v = phony $ unW . proxyFW (G.prescanl f s) v + +-- | /O(n)/ Prescan with strict accumulator +prescanl' :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> a) -> a -> Vector s ty b -> Vector s ty a +{-# INLINE prescanl' #-} +prescanl' f s v = phony $ unW . proxyFW (G.prescanl' f s) v + +-- | /O(n)/ Scan +-- +-- @ +-- postscanl f z = 'tail' . 'scanl' f z +-- @ +-- +-- Example: @postscanl (+) 0 \<1,2,3,4\> = \<1,3,6,10\>@ +-- +postscanl :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> a) -> a -> Vector s ty b -> Vector s ty a +{-# INLINE postscanl #-} +postscanl f s v = phony $ unW . proxyFW (G.postscanl f s) v + +-- | /O(n)/ Scan with strict accumulator +postscanl' :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> a) -> a -> Vector s ty b -> Vector s ty a +{-# INLINE postscanl' #-} +postscanl' f s v = phony $ unW . proxyFW (G.postscanl' f s) v + +-- | /O(n)/ Haskell-style scan +-- +-- > scanl f z = +-- > 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 s ty a, VECTOR s ty b) => (a -> b -> a) -> a -> Vector s ty b -> Vector s ty a +{-# INLINE scanl #-} +scanl f s v = phony $ unW . proxyFW (G.scanl f s) v + +-- | /O(n)/ Haskell-style scan with strict accumulator +scanl' :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> a) -> a -> Vector s ty b -> Vector s ty a +{-# INLINE scanl' #-} +scanl' f s v = phony $ unW . proxyFW (G.scanl' f s) v + +-- | /O(n)/ Scan over a non-empty vector +-- +-- > scanl f = +-- > where y1 = x1 +-- > yi = f y(i-1) xi +-- +scanl1 :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> Vector s ty a +{-# INLINE scanl1 #-} +scanl1 f v = phony $ unW . proxyFW (G.scanl1 f) v + +-- | /O(n)/ Scan over a non-empty vector with a strict accumulator +scanl1' :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> Vector s ty a +{-# INLINE scanl1' #-} +scanl1' f v = phony $ unW . proxyFW (G.scanl1' f) v + +-- | /O(n)/ Right-to-left prescan +-- +-- @ +-- prescanr f z = 'reverse' . 'prescanl' (flip f) z . 'reverse' +-- @ +-- +prescanr :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> b) -> b -> Vector s ty a -> Vector s ty b +{-# INLINE prescanr #-} +prescanr f s v = phony $ unW . proxyFW (G.prescanr f s) v + +-- | /O(n)/ Right-to-left prescan with strict accumulator +prescanr' :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> b) -> b -> Vector s ty a -> Vector s ty b +{-# INLINE prescanr' #-} +prescanr' f s v = phony $ unW . proxyFW (G.prescanr' f s) v + +-- | /O(n)/ Right-to-left scan +postscanr :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> b) -> b -> Vector s ty a -> Vector s ty b +{-# INLINE postscanr #-} +postscanr f s v = phony $ unW . proxyFW (G.postscanr f s) v + +-- | /O(n)/ Right-to-left scan with strict accumulator +postscanr' :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> b) -> b -> Vector s ty a -> Vector s ty b +{-# INLINE postscanr' #-} +postscanr' f s v = phony $ unW . proxyFW (G.postscanr' f s) v + +-- | /O(n)/ Right-to-left Haskell-style scan +scanr :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> b) -> b -> Vector s ty a -> Vector s ty b +{-# INLINE scanr #-} +scanr f s v = phony $ unW . proxyFW (G.scanr f s) v + +-- | /O(n)/ Right-to-left Haskell-style scan with strict accumulator +scanr' :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> b) -> b -> Vector s ty a -> Vector s ty b +{-# INLINE scanr' #-} +scanr' f s v = phony $ unW . proxyFW (G.scanr' f s) v + +-- | /O(n)/ Right-to-left scan over a non-empty vector +scanr1 :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> Vector s ty a +{-# INLINE scanr1 #-} +scanr1 f v = phony $ unW . proxyFW (G.scanr1 f) v + +-- | /O(n)/ Right-to-left scan over a non-empty vector with a strict +-- accumulator +scanr1' :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> Vector s ty a +{-# INLINE scanr1' #-} +scanr1' f v = phony $ unW . proxyFW (G.scanr1' f) v + +-- Conversions - Lists +-- ------------------------ + +-- | /O(n)/ Convert a vector to a list +toList :: VECTOR s ty a => Vector s ty a -> [a] +{-# INLINE toList #-} +toList v = phony $ proxyFW G.toList v + +-- | /O(n)/ Convert a list to a vector +fromList :: forall s ty a . VECTOR s ty a => [a] -> Vector s ty a +{-# INLINE fromList #-} +fromList xs = phony $ proxyW (G.fromListN (Prelude.length xs) xs) + +-- | /O(n)/ Convert the first @n@ elements of a list to a vector +-- +-- @ +-- fromListN n xs = 'fromList' ('take' n xs) +-- @ +fromListN :: forall s ty a . VECTOR s ty a => Int -> [a] -> Vector s ty a +{-# INLINE fromListN #-} +fromListN i l = phony $ proxyW (G.fromListN i l) + +-- Conversions - Unsafe casts +-- -------------------------- + +-- Conversions - Mutable vectors +-- ----------------------------- + +-- | /O(1)/ Unsafe convert a mutable vector to an immutable one with +-- copying. The mutable vector may not be used after this operation. +unsafeFreeze :: (VECTOR (Region m) ty a, MonadR m) + => MVector (Region m) ty a -> m (Vector (Region m) ty a) +{-# INLINE unsafeFreeze #-} +unsafeFreeze m = withAcquire $ \p -> unW <$> G.unsafeFreeze (Mutable.withW p m) + +-- | /O(1)/ Unsafely convert an immutable vector to a mutable one with +-- copying. The immutable vector may not be used after this operation. +unsafeThaw :: (MonadR m, VECTOR (Region m) ty a) + => Vector (Region m) ty a -> m (MVector (Region m) ty a) +{-# INLINE unsafeThaw #-} +unsafeThaw v = withAcquire $ \p -> Mutable.unW <$> G.unsafeThaw (withW p v) + +-- | /O(n)/ Yield a mutable copy of the immutable vector. +thaw :: (MonadR m, VECTOR (Region m) ty a) + => Vector (Region m) ty a -> m (MVector (Region m) ty a) +{-# INLINE thaw #-} +thaw v1 = withAcquire $ \p -> Mutable.unW <$> G.thaw (withW p v1) + +-- | /O(n)/ Yield an immutable copy of the mutable vector. +freeze :: (MonadR m, VECTOR (Region m) ty a) + => MVector (Region m) ty a -> m (Vector (Region m) ty a) +{-# INLINE freeze #-} +freeze m1 = withAcquire $ \p -> unW <$> G.freeze (Mutable.withW p m1) + +-- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must +-- have the same length. This is not checked. +unsafeCopy + :: (MonadR m, VECTOR (Region m) ty a) + => MVector (Region m) ty a -> Vector (Region m) ty a -> m () +{-# INLINE unsafeCopy #-} +unsafeCopy m1 v2 = withAcquire $ \p -> G.unsafeCopy (Mutable.withW p m1) (withW p v2) + +-- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must +-- have the same length. +copy :: (MonadR m, VECTOR (Region m) ty a) + => MVector (Region m) ty a -> Vector (Region m) ty a -> m () +{-# INLINE copy #-} +copy m1 v2 = withAcquire $ \p -> G.copy (Mutable.withW p m1) (withW p v2) + +phony :: (forall t . Reifies t (AcquireIO s) => Proxy t -> r) -> r +phony f = reify (AcquireIO acquireIO) $ \p -> f p + where + acquireIO :: SEXP V ty -> IO (SEXP g ty) + acquireIO x = do + R.preserveObject x + return $ R.unsafeRelease x diff --git a/src/Data/Vector/SEXP/Base.hs b/src/Data/Vector/SEXP/Base.hs --- a/src/Data/Vector/SEXP/Base.hs +++ b/src/Data/Vector/SEXP/Base.hs @@ -8,6 +8,8 @@ module Data.Vector.SEXP.Base where +import Control.Memory.Region + import Foreign.R.Type import Foreign.R (SEXP, SomeSEXP) @@ -20,19 +22,22 @@ -- | Function from R types to the types of the representations of each element -- in the vector. -type family ElemRep s (a :: SEXPTYPE) -type instance ElemRep s 'Char = Word8 -type instance ElemRep s 'Logical = Logical -type instance ElemRep s 'Int = Int32 -type instance ElemRep s 'Real = Double -type instance ElemRep s 'Complex = Complex Double -type instance ElemRep s 'String = SEXP s 'Char -type instance ElemRep s 'Vector = SomeSEXP s -type instance ElemRep s 'Expr = SomeSEXP s -type instance ElemRep s 'Raw = Word8 +type family ElemRep s (a :: SEXPTYPE) where + ElemRep s 'Char = Word8 + ElemRep s 'Logical = Logical + ElemRep s 'Int = Int32 + ElemRep s 'Real = Double + ElemRep s 'Complex = Complex Double + ElemRep s 'String = SEXP s 'Char + ElemRep s 'Vector = SomeSEXP s + ElemRep s 'Expr = SomeSEXP s + ElemRep s 'Raw = Word8 -- | 'ElemRep' in the form of a relation, for convenience. type E s a b = ElemRep s a ~ b -- | Constraint synonym for all operations on vectors. type VECTOR s ty a = (Storable a, IsVector ty, SingI ty, ElemRep s ty ~ a) + +-- | Constraint synonym for all operations on vectors. +type SVECTOR ty a = (Storable a, IsVector ty, SingI ty, ElemRep V ty ~ a) diff --git a/src/Data/Vector/SEXP/Mutable.chs b/src/Data/Vector/SEXP/Mutable.chs deleted file mode 100644 --- a/src/Data/Vector/SEXP/Mutable.chs +++ /dev/null @@ -1,332 +0,0 @@ --- | --- Copyright: (C) 2013 Amgen, Inc. --- --- Vectors that can be passed to and from R with no copying at all. These --- vectors are wrappers over SEXP vectors used by R. Memory for vectors is --- allocated from the R heap, and in such way that they can be converted to --- a 'SEXP' by simple pointer arithmetic (see 'toSEXP'). --- --- The main difference between "Data.Vector.SEXP.Mutable" and --- "Data.Vector.Storable" is that the former uses a header-prefixed data layout --- (the header immediately precedes the payload of the vector). This means that --- no additional pointer dereferencing is needed to reach the vector data. The --- trade-off is, for mutable vectors, slicing is not supported. The reason is --- that slicing header-prefixed vectors is generally not possible without --- copying, which breaks the semantics of the API for 'MVector'. --- --- To perform slicing, it is necessary to convert to a "Data.Vector.Storable" --- vector first, using 'unsafeToStorable'. - -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module Data.Vector.SEXP.Mutable - ( -- * Mutable vectors of 'SEXP' types - MVector(..) - , IOVector - , STVector - -- * Accessors - -- ** Length information - , length - , null - -- * Construction - -- ** Initialisation - , new - , unsafeNew - , replicate - , replicateM - , clone - -- ** Restricting memory usage - , clear - -- * Accessing individual elements - , read - , write - , swap - , unsafeRead - , unsafeWrite - , unsafeSwap - -- * Modifying vectors - -- ** Filling and copying - , set - , copy - , move - , unsafeCopy - , unsafeMove - -- * SEXP specific. - , fromSEXP - , toSEXP - , unsafeToStorable - , fromStorable - ) where - -import Data.Vector.SEXP.Base -import qualified Foreign.R as R -import Foreign.R (SEXP, SEXPTYPE) -import Foreign.R.Type (SSEXPTYPE, IsVector) -import Internal.Error - -import Control.Applicative -import Control.Monad (liftM) -import Control.Monad.Primitive - (PrimMonad, PrimState, RealWorld, unsafePrimToPrim, unsafeInlineIO) -import qualified Data.Vector.Generic.Mutable as G -import qualified Data.Vector.Storable.Mutable as Storable -import Data.Singletons (fromSing, sing) -import Data.Int - -import Foreign (castPtr, Ptr, withForeignPtr) -import Foreign.Concurrent (newForeignPtr) -import Foreign.C -import Foreign.Storable -import Foreign.Marshal.Array (copyArray, moveArray) - -import Prelude hiding (length, null, replicate, read) -import System.IO.Unsafe (unsafePerformIO) - -#include -#define USE_RINTERNALS -#include - --- | Mutable R vector. They are represented in memory with the same header as --- 'SEXP' nodes. The second type paramater is a phantom parameter reflecting at --- the type level the tag of the vector when viewed as a 'SEXP'. The tag of the --- vector and the representation type are related via 'ElemRep'. -newtype MVector s (ty :: SEXPTYPE) r a = MVector { unMVector :: SEXP s ty } - -type IOVector s ty = MVector s ty RealWorld -type STVector s ty r = MVector s ty s - -instance (VECTOR s ty a) - => G.MVector (MVector s ty) a where - basicLength (MVector s) = unsafeInlineIO $ - fromIntegral <$> {# get VECSEXP->vecsxp.length #} (R.unsexp s) --- N.B. slicing can't be supported properly by vectors prefixed by header, --- this means that we can support only a reducing size (required for --- vectors algorithms), and slicing that is noop - basicUnsafeSlice j m v - | j == 0 && m == G.basicLength v = v - | j == 0 = unsafePerformIO $ do - let s = castPtr $ R.unsexp $ unMVector v - {# set VECSEXP->vecsxp.length #} s (fromIntegral m :: CInt) - return v - | otherwise = - failure "Data.Vector.SEXP.Mutable.slice" - "unsafeSlice is not supported for SEXP vectors, to perform slicing convert vector to Storable." - basicOverlaps mv1 mv2 = unMVector mv1 == unMVector mv2 - basicUnsafeNew n - -- R calls using allocVector() for CHARSXP "defunct"... - | fromSing (sing :: SSEXPTYPE ty) == R.Char = - failure "Data.Vector.SEXP.Mutable.new" - "R character vectors are immutable and globally cached. Use 'mkChar' instead." - | otherwise = - -- No functor instance available here in GHC < 7.10 (pre AMP). - liftM fromSEXP $ unsafePrimToPrim (R.allocVectorProtected (sing :: SSEXPTYPE ty) n) - basicUnsafeRead mv i = unsafePrimToPrim - $ peekElemOff (toVecPtr mv) i - basicUnsafeWrite mv i x = unsafePrimToPrim - $ pokeElemOff (toVecPtr mv) i x - basicSet mv x = Prelude.mapM_ (\i -> G.basicUnsafeWrite mv i x) [0..G.basicLength mv] - basicUnsafeCopy mv1 mv2 = unsafePrimToPrim $ do - copyArray (toVecPtr mv1) - (toVecPtr mv2) - (G.basicLength mv1) - basicUnsafeMove mv1 mv2 = unsafePrimToPrim $ do - moveArray (toVecPtr mv1) - (toVecPtr mv2) - (G.basicLength mv1) - -toVecPtr :: MVector s ty r a -> Ptr a -toVecPtr mv = castPtr (R.unsafeSEXPToVectorPtr $ unMVector mv) - --- | /O(1)/ Create a vector from a 'SEXP'. -fromSEXP :: (E s ty a, Storable a, IsVector ty) - => R.SEXP s ty - -> MVector s ty r a -fromSEXP s = MVector s - --- | /O(1)/ Convert a mutable vector to a 'SEXP'. This can be done efficiently, --- without copy, because vectors in this module always include a 'SEXP' header --- immediately before the vector data in memory. -toSEXP :: forall s a r ty. (E s ty a, IsVector ty, Storable a) - => MVector s ty r a - -> R.SEXP s ty -toSEXP = unMVector - --- Length information --- ------------------ - --- | Length of the mutable vector. -length :: VECTOR s ty a => MVector s ty r a -> Int -{-# INLINE length #-} -length (MVector s) = - unsafeInlineIO $ - fromIntegral <$> {# get VECSEXP->vecsxp.length #} (R.unsexp s) - --- | Check whether the vector is empty -null :: VECTOR s ty a => (MVector s ty) r a -> Bool -{-# INLINE null #-} -null (MVector s) = - unsafeInlineIO $ - ((/= (0::Int)) . fromIntegral) <$> - {# get VECSEXP->vecsxp.length #} (R.unsexp s) - --- Initialisation --- -------------- - --- | Create a mutable vector of the given length. -new :: (PrimMonad m, VECTOR s ty a) => Int -> m (MVector s ty (PrimState m) a) -{-# INLINE new #-} -new = G.new - --- | Create a mutable vector of the given length. The length is not checked. -unsafeNew :: (PrimMonad m, VECTOR s ty a) => Int -> m (MVector s ty (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, VECTOR s ty a) => Int -> a -> m (MVector s ty (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, VECTOR s ty a) => Int -> m a -> m (MVector s ty (PrimState m) a) -{-# INLINE replicateM #-} -replicateM = G.replicateM - --- | Create a copy of a mutable vector. -clone :: (PrimMonad m, VECTOR s ty a) - => MVector s ty (PrimState m) a -> m (MVector s ty (PrimState m) a) -{-# INLINE clone #-} -clone = G.clone - --- 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, VECTOR s ty a) => MVector s ty (PrimState m) a -> m () -{-# INLINE clear #-} -clear = G.clear - --- Accessing individual elements --- ----------------------------- - --- | Yield the element at the given position. -read :: (PrimMonad m, VECTOR s ty a) - => MVector s ty (PrimState m) a -> Int -> m a -{-# INLINE read #-} -read = G.read - --- | Replace the element at the given position. -write :: (PrimMonad m, VECTOR s ty a) - => MVector s ty (PrimState m) a -> Int -> a -> m () -{-# INLINE write #-} -write = G.write - --- | Swap the elements at the given positions. -swap :: (PrimMonad m, VECTOR s ty a) - => MVector s ty (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, VECTOR s ty a) - => MVector s ty (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, VECTOR s ty a) - => MVector s ty (PrimState m) a -> Int -> a -> m () -{-# INLINE unsafeWrite #-} -unsafeWrite = G.unsafeWrite - --- | Swap the elements at the given positions. No bounds checks are performed. -unsafeSwap :: (PrimMonad m, VECTOR s ty a) - => MVector s ty (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, VECTOR s ty a) => MVector s ty (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, VECTOR s ty a) - => MVector s ty (PrimState m) a - -> MVector s ty (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, VECTOR s ty a) - => MVector s ty (PrimState m) a -- ^ target - -> MVector s ty (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, VECTOR s ty a) - => MVector s ty (PrimState m) a - -> MVector s ty (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, VECTOR s ty a) - => MVector s ty (PrimState m) a -- ^ target - -> MVector s ty (PrimState m) a -- ^ source - -> m () -{-# INLINE unsafeMove #-} -unsafeMove = G.unsafeMove - --- | O(1) Inplace convertion to Storable vector. -unsafeToStorable :: (PrimMonad m, VECTOR s ty a) - => MVector s ty (PrimState m) a -- ^ target - -> m (Storable.MVector (PrimState m) a) -- ^ source -{-# INLINE unsafeToStorable #-} -unsafeToStorable v@(MVector p) = unsafePrimToPrim $ do - R.preserveObject p - ptr <- newForeignPtr (toVecPtr v) (R.releaseObject (R.sexp $ castPtr $ toVecPtr v)) - return $ Storable.unsafeFromForeignPtr0 ptr (length v) - --- | O(N) Convertion from storable vector to SEXP vector. -fromStorable :: (PrimMonad m, VECTOR s ty a) - => Storable.MVector (PrimState m) a - -> m (MVector s ty (PrimState m) a) -{-# INLINE fromStorable #-} -fromStorable v = do - let (fptr, l) = Storable.unsafeToForeignPtr0 v - mv <- new l - unsafePrimToPrim $ withForeignPtr fptr $ \p -> do - copyArray (toVecPtr mv) p (Storable.length v) - return mv diff --git a/src/Data/Vector/SEXP/Mutable.hs b/src/Data/Vector/SEXP/Mutable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Vector/SEXP/Mutable.hs @@ -0,0 +1,359 @@ +-- | +-- Copyright: (C) 2013 Amgen, Inc. +-- 2016 Tweag I/O Limited. +-- +-- Vectors that can be passed to and from R with no copying at all. These +-- vectors are wrappers over SEXP vectors used by R. Memory for vectors is +-- allocated from the R heap, and in such way that they can be converted to +-- a 'SEXP' by simple pointer arithmetic (see 'toSEXP'). +-- +-- Like "Data.Vector.Storable.Mutable" vectors, the vector type in this module +-- adds one extra level of indirection and a small amount of storage overhead +-- for maintainging lengths and slice offsets. If you're keeping a very large +-- number of tiny vectors in memory, you're better off keeping them as 'SEXP's +-- and calling 'fromSEXP' on-the-fly. + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Vector.SEXP.Mutable + ( -- * Mutable slices of 'SEXP' vector types + MVector + , fromSEXP + , toSEXP + , release + , unsafeRelease + -- * Accessors + -- ** Length information + , length + , null + -- * Construction + -- ** Initialisation + , new + , unsafeNew + , replicate + , replicateM + , clone + -- ** Extracting subvectors + , slice + , init + , tail + , take + , drop + , splitAt + , unsafeSlice + , unsafeInit + , unsafeTail + , unsafeTake + , unsafeDrop + -- ** Overlapping + , overlaps + -- ** Restricting memory usage + , clear + -- * Accessing individual elements + , read + , write + , swap + , unsafeRead + , unsafeWrite + , unsafeSwap + -- * Modifying vectors + -- ** Filling and copying + , set + , copy + , move + , unsafeCopy + , unsafeMove + ) where + +import Control.Monad.R.Class +import Control.Monad.R.Internal +import Data.Vector.SEXP.Base +import Data.Vector.SEXP.Mutable.Internal +import qualified Foreign.R as R +import Foreign.R (SEXP) +import Internal.Error + +import qualified Data.Vector.Generic.Mutable as G + +import Control.Applicative +import Control.Arrow ((>>>), (***)) +import Data.Proxy (Proxy(..)) +import Data.Reflection (Reifies(..), reify) +import System.IO.Unsafe (unsafePerformIO) + +import Prelude hiding + ( length, drop, init, null, read, replicate, splitAt, tail, take ) + +-- Internal helpers +-- ---------------- + +phony + :: forall s ty a b. + (VECTOR s ty a) + => (forall t. Reifies t (AcquireIO s) => W t ty s a -> b) + -> MVector s ty a + -> b +phony f v = + reify (AcquireIO acquireIO) $ \(Proxy :: Proxy t) -> do + f (W v :: W t ty s a) + where + acquireIO = violation "phony" "phony acquire called." + +phony2 + :: forall s ty a b. + (VECTOR s ty a) + => (forall t. Reifies t (AcquireIO s) => W t ty s a -> W t ty s a -> b) + -> MVector s ty a + -> MVector s ty a + -> b +phony2 f v1 v2 = + reify (AcquireIO acquireIO) $ \(Proxy :: Proxy t) -> do + f (W $ v1 :: W t ty s a) + (W $ v2 :: W t ty s a) + where + acquireIO = violation "phony2" "phony acquire called." + +-- Conversions +-- ----------- + +-- | /O(1)/ Create a vector from a 'SEXP'. +fromSEXP :: VECTOR s ty a => SEXP s ty -> MVector s ty a +fromSEXP sx = + MVector sx 0 $ unsafePerformIO $ do + fromIntegral <$> R.length sx + +-- | /O(1)/ in the common case, /O(n)/ for proper slices. Convert a mutable +-- vector to a 'SEXP'. This can be done efficiently, without copy, because +-- vectors in this module always include a 'SEXP' header immediately before the +-- vector data in memory. +toSEXP + :: (MonadR m, VECTOR (Region m) ty a) + => MVector (Region m) ty a + -> m (SEXP (Region m) ty) +toSEXP (MVector sx 0 len) + | len == sexplen = return sx + where + sexplen = unsafePerformIO $ do + fromIntegral <$> R.length sx +toSEXP v = toSEXP =<< clone v -- yield a zero based slice. + +-- Length information +-- ------------------ + +-- | Length of the mutable vector. +length :: VECTOR s ty a => MVector s ty a -> Int +{-# INLINE length #-} +length = phony G.length + +-- | Check whether the vector is empty. +null :: VECTOR s ty a => MVector s ty a -> Bool +{-# INLINE null #-} +null = phony G.null + +-- Extracting subvectors +-- --------------------- + +-- | Yield a part of the mutable vector without copying it. +slice :: VECTOR s ty a => Int -> Int -> MVector s ty a -> MVector s ty a +{-# INLINE slice #-} +slice i j = phony (unW . G.slice i j) + +take :: VECTOR s ty a => Int -> MVector s ty a -> MVector s ty a +{-# INLINE take #-} +take n = phony (unW . G.take n) + +drop :: VECTOR s ty a => Int -> MVector s ty a -> MVector s ty a +{-# INLINE drop #-} +drop n = phony (unW . G.drop n) + +splitAt :: VECTOR s ty a => Int -> MVector s ty a -> (MVector s ty a, MVector s ty a) +{-# INLINE splitAt #-} +splitAt n = phony (G.splitAt n >>> unW *** unW) + +init :: VECTOR s ty a => MVector s ty a -> MVector s ty a +{-# INLINE init #-} +init = phony (unW . G.init) + +tail :: VECTOR s ty a => MVector s ty a -> MVector s ty a +{-# INLINE tail #-} +tail = phony (unW . G.tail) + +-- | Yield a part of the mutable vector without copying it. No bounds checks +-- are performed. +unsafeSlice :: VECTOR s ty a + => Int -- ^ starting index + -> Int -- ^ length of the slice + -> MVector s ty a + -> MVector s ty a +{-# INLINE unsafeSlice #-} +unsafeSlice i j = phony (unW . G.unsafeSlice i j) + +unsafeTake :: VECTOR s ty a => Int -> MVector s ty a -> MVector s ty a +{-# INLINE unsafeTake #-} +unsafeTake n = phony (unW . G.unsafeTake n) + +unsafeDrop :: VECTOR s ty a => Int -> MVector s ty a -> MVector s ty a +{-# INLINE unsafeDrop #-} +unsafeDrop n = phony (unW . G.unsafeDrop n) + +unsafeInit :: VECTOR s ty a => MVector s ty a -> MVector s ty a +{-# INLINE unsafeInit #-} +unsafeInit = phony (unW . G.unsafeInit) + +unsafeTail :: VECTOR s ty a => MVector s ty a -> MVector s ty a +{-# INLINE unsafeTail #-} +unsafeTail = phony (unW . G.unsafeTail) + +-- Overlapping +-- ----------- + +-- | Check whether two vectors overlap. +overlaps :: VECTOR s ty a => MVector s ty a -> MVector s ty a -> Bool +{-# INLINE overlaps #-} +overlaps = phony2 G.overlaps + +-- Initialisation +-- -------------- + +-- | Create a mutable vector of the given length. +new :: forall m ty a. + (MonadR m, VECTOR (Region m) ty a) + => Int + -> m (MVector (Region m) ty a) +{-# INLINE new #-} +new n = withAcquire $ proxyW $ G.new n + +-- | Create a mutable vector of the given length. The length is not checked. +unsafeNew :: (MonadR m, VECTOR (Region m) ty a) => Int -> m (MVector (Region m) ty a) +{-# INLINE unsafeNew #-} +unsafeNew n = withAcquire $ proxyW $ G.unsafeNew n + +-- | Create a mutable vector of the given length (0 if the length is negative) +-- and fill it with an initial value. +replicate :: (MonadR m, VECTOR (Region m) ty a) => Int -> a -> m (MVector (Region m) ty a) +{-# INLINE replicate #-} +replicate n x = withAcquire $ proxyW $ G.replicate 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 :: (MonadR m, VECTOR (Region m) ty a) => Int -> m a -> m (MVector (Region m) ty a) +{-# INLINE replicateM #-} +replicateM n m = withAcquire $ proxyW $ G.replicateM n m + +-- | Create a copy of a mutable vector. +clone :: (MonadR m, VECTOR (Region m) ty a) + => MVector (Region m) ty a + -> m (MVector (Region m) ty a) +{-# INLINE clone #-} +clone v = withAcquire $ proxyW $ G.clone (W 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 :: (MonadR m, VECTOR (Region m) ty a) => MVector (Region m) ty a -> m () +{-# INLINE clear #-} +clear v = withAcquire $ \p -> G.clear (withW p v) + +-- Accessing individual elements +-- ----------------------------- + +-- | Yield the element at the given position. +read :: (MonadR m, VECTOR (Region m) ty a) + => MVector (Region m) ty a -> Int -> m a +{-# INLINE read #-} +read v i = withAcquire $ \p -> G.read (withW p v) i + +-- | Replace the element at the given position. +write :: (MonadR m, VECTOR (Region m) ty a) + => MVector (Region m) ty a -> Int -> a -> m () +{-# INLINE write #-} +write v i x = withAcquire $ \p -> G.write (withW p v) i x + +-- | Swap the elements at the given positions. +swap :: (MonadR m, VECTOR (Region m) ty a) + => MVector (Region m) ty a -> Int -> Int -> m () +{-# INLINE swap #-} +swap v i j = withAcquire $ \p -> G.swap (withW p v) i j + +-- | Yield the element at the given position. No bounds checks are performed. +unsafeRead :: (MonadR m, VECTOR (Region m) ty a) + => MVector (Region m) ty a -> Int -> m a +{-# INLINE unsafeRead #-} +unsafeRead v i = withAcquire $ \p -> G.unsafeRead (withW p v) i + +-- | Replace the element at the given position. No bounds checks are performed. +unsafeWrite :: (MonadR m, VECTOR (Region m) ty a) + => MVector (Region m) ty a -> Int -> a -> m () +{-# INLINE unsafeWrite #-} +unsafeWrite v i x = withAcquire $ \p -> G.unsafeWrite (withW p v) i x + +-- | Swap the elements at the given positions. No bounds checks are performed. +unsafeSwap :: (MonadR m, VECTOR (Region m) ty a) + => MVector (Region m) ty a -> Int -> Int -> m () +{-# INLINE unsafeSwap #-} +unsafeSwap v i j = withAcquire $ \p -> G.unsafeSwap (withW p v) i j + +-- Filling and copying +-- ------------------- + +-- | Set all elements of the vector to the given value. +set :: (MonadR m, VECTOR (Region m) ty a) => MVector (Region m) ty a -> a -> m () +{-# INLINE set #-} +set v x = withAcquire $ \p -> G.set (withW p v) x + +-- | Copy a vector. The two vectors must have the same length and may not +-- overlap. +copy :: (MonadR m, VECTOR (Region m) ty a) + => MVector (Region m) ty a + -> MVector (Region m) ty a + -> m () +{-# INLINE copy #-} +copy v1 v2 = withAcquire $ \p -> G.copy (withW p v1) (withW p v2) + +-- | Copy a vector. The two vectors must have the same length and may not +-- overlap. This is not checked. +unsafeCopy :: (MonadR m, VECTOR (Region m) ty a) + => MVector (Region m) ty a -- ^ target + -> MVector (Region m) ty a -- ^ source + -> m () +{-# INLINE unsafeCopy #-} +unsafeCopy v1 v2 = withAcquire $ \p -> G.unsafeCopy (withW p v1) (withW p v2) + +-- | 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 :: (MonadR m, VECTOR (Region m) ty a) + => MVector (Region m) ty a + -> MVector (Region m) ty a + -> m () +{-# INLINE move #-} +move v1 v2 = withAcquire $ \p -> G.move (withW p v1) (withW p v2) + +-- | 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 :: (MonadR m, VECTOR (Region m) ty a) + => MVector (Region m) ty a -- ^ target + -> MVector (Region m) ty a -- ^ source + -> m () +{-# INLINE unsafeMove #-} +unsafeMove v1 v2 = withAcquire $ \p -> G.unsafeMove (withW p v1) (withW p v2) diff --git a/src/Data/Vector/SEXP/Mutable/Internal.hs b/src/Data/Vector/SEXP/Mutable/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Vector/SEXP/Mutable/Internal.hs @@ -0,0 +1,116 @@ +-- | +-- Copyright: (C) 2016 Tweag I/O Limited. + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} + +module Data.Vector.SEXP.Mutable.Internal + ( MVector(..) + , W(..) + , withW + , proxyW + , unsafeToPtr + , release + , unsafeRelease + ) where + +import Control.Memory.Region +import qualified Foreign.R as R + +import Control.Monad.Primitive (unsafePrimToPrim) +import Control.Monad.R.Internal +import Data.Int (Int32) +import Data.Proxy (Proxy(..)) +import Data.Reflection (Reifies(..)) +import Data.Singletons (fromSing, sing) +import qualified Data.Vector.Generic.Mutable as G +import Data.Vector.SEXP.Base +import Foreign (Storable(..), Ptr, castPtr) +import Foreign.Marshal.Array (advancePtr, copyArray, moveArray) +import Foreign.R (SEXP) +import Foreign.R.Type (SSEXPTYPE) +import Internal.Error + +-- | Mutable R vector. Represented in memory with the same header as 'SEXP' +-- nodes. The second type parameter is phantom, reflecting at the type level the +-- tag of the vector when viewed as a 'SEXP'. The tag of the vector and the +-- representation type are related via 'ElemRep'. +data MVector s ty a = MVector + { mvectorBase :: {-# UNPACK #-} !(SEXP s ty) + , mvectorOffset :: {-# UNPACK #-} !Int32 + , mvectorLength :: {-# UNPACK #-} !Int32 + } + +-- | Internal wrapper type for reflection. First type parameter is the reified +-- type to reflect. +newtype W t ty s a = W { unW :: MVector s ty a } + +instance (Reifies t (AcquireIO s), VECTOR s ty a) => G.MVector (W t ty) a where +#if MIN_VERSION_vector(0,11,0) + basicInitialize _ = return () +#endif + {-# INLINE basicLength #-} + basicLength (unW -> MVector _ _ len) = fromIntegral len + + {-# INLINE basicUnsafeSlice #-} + basicUnsafeSlice j m (unW -> MVector ptr off _len) = + W $ MVector ptr (off + fromIntegral j) (fromIntegral m) + + {-# INLINE basicOverlaps #-} + basicOverlaps (unW -> MVector ptr1 off1 len1) (unW -> MVector ptr2 off2 len2) = + ptr1 == ptr2 && (off2 < off1 + len1 || off1 < off2 + len2) + + {-# INLINE basicUnsafeNew #-} + basicUnsafeNew n + -- R calls using allocVector() for CHARSXP "defunct"... + | fromSing (sing :: SSEXPTYPE ty) == R.Char = + failure "Data.Vector.SEXP.Mutable.new" + "R character vectors are immutable and globally cached. Use 'mkChar' instead." + | otherwise = do + sx <- unsafePrimToPrim (acquireIO =<< R.allocVector (sing :: SSEXPTYPE ty) n) + return $ W $ MVector (R.unsafeRelease sx) 0 (fromIntegral n) + where + AcquireIO acquireIO = reflect (Proxy :: Proxy t) + + {-# INLINE basicUnsafeRead #-} + basicUnsafeRead (unW -> mv) i = + unsafePrimToPrim $ peekElemOff (unsafeToPtr mv) i + + {-# INLINE basicUnsafeWrite #-} + basicUnsafeWrite (unW -> mv) i x = + unsafePrimToPrim $ pokeElemOff (unsafeToPtr mv) i x + + {-# INLINE basicUnsafeCopy #-} + basicUnsafeCopy w1@(unW -> mv1) (unW -> mv2) = unsafePrimToPrim $ do + copyArray (unsafeToPtr mv1) + (unsafeToPtr mv2) + (G.basicLength w1) + + {-# INLINE basicUnsafeMove #-} + basicUnsafeMove w1@(unW -> mv1) (unW -> mv2) = unsafePrimToPrim $ do + moveArray (unsafeToPtr mv1) + (unsafeToPtr mv2) + (G.basicLength w1) + +unsafeToPtr :: Storable a => MVector s ty a -> Ptr a +unsafeToPtr (MVector sx off _) = + castPtr (R.unsafeSEXPToVectorPtr sx) `advancePtr` fromIntegral off + +proxyW :: Monad m => m (W t ty s a) -> proxy t -> m (MVector s ty a) +proxyW m _ = fmap unW m + +withW :: proxy t -> MVector s ty a -> W t ty s a +withW _ v = W v + +release :: (s' <= s) => MVector s ty a -> MVector s' ty a +release = unsafeRelease + +unsafeRelease :: MVector s ty a -> MVector s' ty a +unsafeRelease (MVector b o l) = MVector (R.unsafeRelease b) o l diff --git a/src/Foreign/R.chs b/src/Foreign/R.chs --- a/src/Foreign/R.chs +++ b/src/Foreign/R.chs @@ -30,6 +30,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +-- Necessary for c2hs < 0.26 compat. +{-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} #if __GLASGOW_HASKELL__ >= 710 -- We don't use ticks in this module, because they confuse c2hs. @@ -40,9 +42,9 @@ -- * Internal R structures , SEXPTYPE(..) , R.Logical(..) + , R.PairList , SEXP(..) , SomeSEXP(..) - , Callback , unSomeSEXP -- * Casts and coercions -- $cast-coerce @@ -67,6 +69,7 @@ -- * Node accessor functions -- ** Lists , cons + , lcons , car , cdr , tag @@ -158,7 +161,7 @@ import Control.DeepSeq (NFData(..)) import Control.Exception (bracket) import Control.Monad.Primitive ( unsafeInlineIO ) -import Data.Bits +import Data.Bits -- For c2hs < 0.26. import Data.Complex import Data.Int (Int32) import Data.Singletons (fromSing) @@ -254,11 +257,6 @@ unSomeSEXP :: SomeSEXP s -> (forall a. SEXP s a -> r) -> r unSomeSEXP (SomeSEXP s) k = k s --- | Foreign functions are represented in R as external pointers. We call these --- "callbacks", because they will typically be Haskell functions passed as --- arguments to higher-order R functions. -type Callback s = SEXP s R.ExtPtr - cIntConv :: (Integral a, Integral b) => a -> b cIntConv = fromIntegral @@ -489,6 +487,10 @@ -- | Allocate a so-called cons cell, in essence a pair of 'SEXP' pointers. {#fun Rf_cons as cons { unsexp `SEXP s a', unsexp `SEXP s b' } -> `SEXP V R.List' sexp #} +-- | Allocate a so-called cons cell of language objects, in essence a pair of +-- 'SEXP' pointers. +{#fun Rf_lcons as lcons { unsexp `SEXP s a', unsexp `SEXP s b' } -> `SEXP V R.Lang' sexp #} + -- | Print a string representation of a 'SEXP' on the console. {#fun Rf_PrintValue as printValue { unsexp `SEXP s a'} -> `()' #} @@ -517,7 +519,7 @@ {#fun R_PreserveObject as preserveObject { unsexp `SEXP s a' } -> `()' #} -- | Allow GC to remove an preserved object. -{#fun R_ReleaseObject as releaseObject { unsexp `SEXP G a' } -> `()' #} +{#fun R_ReleaseObject as releaseObject { unsexp `SEXP s a' } -> `()' #} -------------------------------------------------------------------------------- -- Evaluation -- diff --git a/src/H/Prelude/Interactive.hs b/src/H/Prelude/Interactive.hs --- a/src/H/Prelude/Interactive.hs +++ b/src/H/Prelude/Interactive.hs @@ -4,6 +4,8 @@ -- This class is not meant to be imported in any other circumstance than in -- a GHCi session. +{-# LANGUAGE TypeFamilies #-} + {-# OPTIONS_GHC -fno-warn-orphans #-} module H.Prelude.Interactive ( module H.Prelude @@ -17,6 +19,9 @@ instance MonadR IO where io = id + data ExecContext IO = ExecContext + getExecContext = return ExecContext + unsafeRunWithExecContext = const -- | A form of the 'print' function that is more convenient in an -- interactive session. diff --git a/src/Language/R.hs b/src/Language/R.hs --- a/src/Language/R.hs +++ b/src/Language/R.hs @@ -65,9 +65,11 @@ R.withProtected (R.parseVector rtxt 1 status (R.release nilValue)) $ \exprs -> do rc <- fromIntegral <$> peek status unless (R.PARSE_OK == toEnum rc) $ - unsafeRToIO $ throwRMessage $ "Parse error in: " ++ C8.unpack txt + runRegion $ throwRMessage $ "Parse error in: " ++ C8.unpack txt SomeSEXP expr <- peek $ castPtr $ R.unsafeSEXPToVectorPtr exprs - unsafeRToIO $ eval expr + runRegion $ do + SomeSEXP val <- eval expr + return $ SomeSEXP (R.release val) -- | Parse file and perform some actions on parsed file. -- @@ -105,7 +107,8 @@ strings :: String -> IO (SEXP V 'R.String) strings str = withCString str R.mkString --- | Evaluate an expression in the given environment. +-- | Evaluate a (sequence of) expression(s) in the given environment, returning the +-- value of the last. evalEnv :: MonadR m => SEXP s a -> SEXP s 'R.Env -> m (SomeSEXP (Region m)) evalEnv (hexp -> Expr _ v) rho = acquireSome =<< do io $ alloca $ \p -> do @@ -113,18 +116,18 @@ x <- Prelude.last <$> forM (Vector.toList v) (\(SomeSEXP s) -> do z <- R.tryEvalSilent s rho p e <- peek p - when (e /= 0) $ unsafeRToIO $ throwR rho + when (e /= 0) $ runRegion $ throwR rho return z) R.unprotect (Vector.length v) return x evalEnv x rho = acquireSome =<< do - io $ alloca $ \p -> do + io $ alloca $ \p -> R.withProtected (return (R.release x)) $ \_ -> do v <- R.tryEvalSilent x rho p e <- peek p - when (e /= 0) $ unsafeRToIO $ throwR rho + when (e /= 0) $ runRegion $ throwR rho return v --- | Evaluate an expression in the global environment. +-- | Evaluate a (sequence of) expression(s) in the global environment. eval :: MonadR m => SEXP s a -> m (SomeSEXP (Region m)) eval x = evalEnv x (R.release globalEnv) @@ -144,5 +147,10 @@ -- | Read last error message. getErrorMessage :: MonadR m => R.SEXP s 'R.Env -> m String getErrorMessage e = io $ do - f <- withCString "geterrmessage" (R.install >=> R.lang1) - peekCString =<< R.char =<< peek =<< R.string . R.cast (sing :: R.SSEXPTYPE 'R.String) =<< R.eval f (R.release e) + R.withProtected (withCString "geterrmessage" ((R.install >=> R.lang1))) $ \f -> do + R.withProtected (return (R.release e)) $ \env -> do + peekCString + =<< R.char + =<< peek + =<< R.string . R.cast (sing :: R.SSEXPTYPE 'R.String) + =<< R.eval f env diff --git a/src/Language/R/HExp.chs b/src/Language/R/HExp.chs --- a/src/Language/R/HExp.chs +++ b/src/Language/R/HExp.chs @@ -46,13 +46,14 @@ #else {-# OPTIONS_GHC -fno-warn-orphans #-} #endif +-- Necessary for c2hs < 0.26 compat. +{-# OPTIONS_GHC -fno-warn-unused-imports #-} module Language.R.HExp ( HExp(..) , (===) , hexp , unhexp , vector - , selfSymbol ) where import Control.Applicative @@ -63,7 +64,6 @@ import Foreign.R.Constraints import Internal.Error import qualified Language.R.Globals as H -import Language.R.Instance import qualified Data.Vector.SEXP as Vector @@ -76,8 +76,8 @@ import Data.Type.Equality (TestEquality(..), (:~:)(Refl)) import GHC.Ptr (Ptr(..)) import Foreign.Storable -import Foreign.C -import Foreign ( castPtr, nullPtr ) +import Foreign.C -- For c2hs < 0.26 +import Foreign (castPtr) import Unsafe.Coerce (unsafeCoerce) -- Fixes redundant import warning >= 7.10 without CPP import Prelude @@ -485,17 +485,17 @@ withProtected (R.allocSEXP R.SPromise) (\x -> poke (R.unSEXP x) s >> return x) unhexp (Bytecode{}) = unimplemented "unhexp" -unhexp (Real vt) = io $ Vector.unsafeToSEXP vt -unhexp (Logical vt) = io $ Vector.unsafeToSEXP vt -unhexp (Int vt) = io $ Vector.unsafeToSEXP vt -unhexp (Complex vt) = io $ Vector.unsafeToSEXP vt -unhexp (Vector _ vt) = io $ Vector.unsafeToSEXP vt -unhexp (Char vt) = io $ Vector.unsafeToSEXP vt -unhexp (String vt) = io $ Vector.unsafeToSEXP vt -unhexp (Raw vt) = io $ Vector.unsafeToSEXP vt +unhexp (Real vt) = return $ Vector.unsafeToSEXP vt +unhexp (Logical vt) = return $ Vector.unsafeToSEXP vt +unhexp (Int vt) = return $ Vector.unsafeToSEXP vt +unhexp (Complex vt) = return $ Vector.unsafeToSEXP vt +unhexp (Vector _ vt) = return $ Vector.unsafeToSEXP vt +unhexp (Char vt) = return $ Vector.unsafeToSEXP vt +unhexp (String vt) = return $ Vector.unsafeToSEXP vt +unhexp (Raw vt) = return $ Vector.unsafeToSEXP vt unhexp S4{} = unimplemented "unhexp" -unhexp (Expr _ vt) = io $ Vector.unsafeToSEXP vt -unhexp WeakRef{} = io $ error "unhexp does not support WeakRef, use Foreign.R.mkWeakRef instead." +unhexp (Expr _ vt) = return $ Vector.unsafeToSEXP vt +unhexp WeakRef{} = error "unhexp does not support WeakRef, use Foreign.R.mkWeakRef instead." unhexp DotDotDot{} = unimplemented "unhexp" unhexp ExtPtr{} = unimplemented "unhexp" @@ -510,11 +510,3 @@ vector (hexp -> Vector _ vec) = vec vector (hexp -> Expr _ vec) = vec vector s = violation "vector" $ show (R.typeOf s) ++ " unexpected vector type." - --- | Symbols can have values attached to them. This function creates a symbol --- whose value is itself. -selfSymbol :: SEXP s R.Char -> IO (SEXP s R.Symbol) -selfSymbol pname = unsafeRToIO $ do - s <- unhexp =<< Symbol pname (R.sexp nullPtr) <$> unhexp Nil - io $ R.setCdr s s - return s diff --git a/src/Language/R/Instance.hs b/src/Language/R/Instance.hs --- a/src/Language/R/Instance.hs +++ b/src/Language/R/Instance.hs @@ -28,7 +28,7 @@ ( -- * The R monad R , runRegion - , unsafeRToIO + , unsafeRunRegion -- * R instance creation , Config(..) , defaultConfig @@ -58,6 +58,7 @@ import Control.Exception ( bracket , bracket_ + , uninterruptibleMask_ ) import Control.Monad.Catch ( MonadCatch, MonadMask, MonadThrow ) import Control.Monad.Reader @@ -86,17 +87,19 @@ newtype R s a = R { unR :: ReaderT (IORef Int) IO a } deriving (Applicative, Functor, Monad, MonadIO, MonadCatch, MonadMask, MonadThrow) +instance PrimMonad (R s) where + type PrimState (R s) = s + primitive f = R $ lift $ unsafeSTToIO $ primitive f + instance MonadR (R s) where - type Region (R s) = s io m = R $ ReaderT $ \_ -> m - acquire s = R $ ReaderT $ \cnt -> do + acquire s = R $ ReaderT $ \cnt -> uninterruptibleMask_ $ do x <- R.release <$> R.protect s modifyIORef' cnt succ return x - -instance PrimMonad (R s) where - type PrimState (R s) = s - primitive f = R $ lift $ unsafeSTToIO $ primitive f + newtype ExecContext (R s) = ExecContext (IORef Int) + getExecContext = R $ ReaderT $ \ref -> return (ExecContext ref) + unsafeRunWithExecContext m (ExecContext ref) = runReaderT (unR m) ref -- | Initialize a new instance of R, execute actions that interact with the -- R instance and then finalize the instance. This is typically called at the @@ -119,21 +122,16 @@ -- thunks hold onto resources in a way that would extrude the scope of the -- region. This means that the result must be first-order data (i.e. not -- a function). -runRegion :: NFData a => (forall s . R s a) -> IO a -runRegion r = +runRegion :: NFData a => (forall s. R s a) -> IO a +runRegion r = unsafeRunRegion r + +unsafeRunRegion :: NFData a => R s a -> IO a +unsafeRunRegion r = bracket (newIORef 0) (R.unprotect <=< readIORef) (\d -> do x <- runReaderT (unR r) d x `deepseq` return x) - --- | An unsafe version of 'runRegion', providing no static guarantees that --- resources do not extrude the scope of their region. For internal use only. -unsafeRToIO :: R s a -> IO a -unsafeRToIO r = - bracket (newIORef 0) - (R.unprotect <=< readIORef) - (runReaderT (unR r)) -- | Configuration options for the R runtime. Configurations form monoids, so -- arguments can be accumulated left-to-right through monoidal composition. diff --git a/src/Language/R/Internal.hs b/src/Language/R/Internal.hs --- a/src/Language/R/Internal.hs +++ b/src/Language/R/Internal.hs @@ -1,27 +1,32 @@ {-# LANGUAGE DataKinds #-} {-# Language ViewPatterns #-} -module Language.R.Internal where +module Language.R.Internal (r1, r2, installIO) where import Control.Memory.Region -import Foreign.R (SEXP, SomeSEXP(..)) import qualified Foreign.R as R +import Foreign.R (SEXP, SomeSEXP) import Language.R import Data.ByteString as B import Foreign.C.String ( withCString ) +-- | Helper +inVoid :: R V z -> R V z +inVoid = id +{-# INLINE inVoid #-} + -- | Call a pure unary R function of the given name in the global environment. r1 :: ByteString -> SEXP s a -> IO (SomeSEXP V) r1 fn a = useAsCString fn $ \cfn -> R.install cfn >>= \f -> - R.withProtected (R.lang2 f (R.release a)) (unsafeRToIO . eval) + R.withProtected (R.lang2 f (R.release a)) (unsafeRunRegion . inVoid . eval) -- | Call a pure binary R function. See 'r1' for additional comments. r2 :: ByteString -> SEXP s a -> SEXP s b -> IO (SomeSEXP V) r2 fn a b = useAsCString fn $ \cfn -> R.install cfn >>= \f -> - R.withProtected (R.lang3 f (R.release a) (R.release b)) (unsafeRToIO . eval) + R.withProtected (R.lang3 f (R.release a) (R.release b)) (unsafeRunRegion . inVoid . eval) -- | Internalize a symbol name. installIO :: String -> IO (SEXP V 'R.Symbol) diff --git a/src/Language/R/Internal/FunWrappers/TH.hs b/src/Language/R/Internal/FunWrappers/TH.hs --- a/src/Language/R/Internal/FunWrappers/TH.hs +++ b/src/Language/R/Internal/FunWrappers/TH.hs @@ -78,7 +78,13 @@ let mkTy [] = impossible "thWrapperLiteral" mkTy [x] = [t| $nR $s $x |] mkTy (x:xs) = [t| $x -> $(mkTy xs) |] - ctx = cxt (zipWith f (map varT names1) (map varT names2)) + ctx = cxt $ +#if MIN_VERSION_template_haskell(2,10,0) + [AppT (ConT (mkName "NFData")) <$> varT (last names1)] ++ +#else + [classP (mkName "NFData") [varT (last names1)]] ++ +#endif + zipWith f (map varT names1) (map varT names2) where #if MIN_VERSION_template_haskell(2,10,0) f tv1 tv2 = foldl AppT (ConT (mkName "Literal")) <$> sequence [tv1, tv2] diff --git a/src/Language/R/Literal.hs b/src/Language/R/Literal.hs --- a/src/Language/R/Literal.hs +++ b/src/Language/R/Literal.hs @@ -9,6 +9,7 @@ {-# Language FlexibleInstances #-} {-# Language FunctionalDependencies #-} {-# Language GADTs #-} +{-# Language LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# Language TemplateHaskell #-} @@ -16,17 +17,20 @@ {-# Language ViewPatterns #-} module Language.R.Literal - ( Literal(..) + ( -- * Literals conversion + Literal(..) + , toPairList + , fromPairList + -- * Derived helpers , fromSomeSEXP , mkSEXP , dynSEXP , mkSEXPVector , mkSEXPVectorIO - , HFunWrap(..) - , funToSEXP , mkProtectedSEXPVector , mkProtectedSEXPVectorIO - -- * wrapper helpers + -- * Internal + , funToSEXP ) where import Control.Memory.Region @@ -38,6 +42,7 @@ import Foreign.R ( SEXP, SomeSEXP(..) ) import Internal.Error import Language.R.Internal (r1) +import Language.R.Globals (nilValue) import Language.R.HExp import Language.R.Instance import Language.R.Internal.FunWrappers @@ -45,12 +50,15 @@ import Data.Singletons ( Sing, SingI, fromSing, sing ) +import Control.DeepSeq ( NFData ) import Control.Monad ( void, zipWithM_ ) import Data.Int (Int32) import Data.Complex (Complex) import Foreign ( FunPtr, castPtr ) import Foreign.C.String ( withCString ) import Foreign.Storable ( Storable, pokeElemOff ) +import qualified GHC.Foreign as GHC +import GHC.IO.Encoding.UTF8 import System.IO.Unsafe ( unsafePerformIO ) -- | Values that can be converted to 'SEXP'. @@ -153,12 +161,40 @@ instance Literal [String] 'R.String where mkSEXPIO = - mkSEXPVectorIO sing . map (`withCString` R.mkCharCE R.CE_UTF8) + mkSEXPVectorIO sing . + map (\str -> GHC.withCString utf8 str (R.mkCharCE R.CE_UTF8)) fromSEXP (hexp -> String v) = map (\(hexp -> Char xs) -> SVector.toString xs) (SVector.toList v) fromSEXP _ = failure "fromSEXP" "String expected where some other expression appeared." +-- | Create a pairlist from an association list. Result is either a pairlist or +-- @nilValue@ if the input is the null list. These are two distinct forms. Hence +-- why the type of this function is not more precise. +toPairList :: MonadR m => [(String, SomeSEXP (Region m))] -> m (SomeSEXP (Region m)) +toPairList [] = return $ SomeSEXP (R.release nilValue) +toPairList ((k, SomeSEXP v):kvs) = do + -- No need to protect the tag because it's in the symbol table, so won't be + -- garbage collected. + tag <- io $ withCString k R.install + toPairList kvs >>= \case + SomeSEXP cdr@(hexp -> Nil) -> + fmap SomeSEXP $ unhexp $ List v cdr (R.unsafeRelease tag) + SomeSEXP cdr@(hexp -> List _ _ _) -> + fmap SomeSEXP $ unhexp $ List v cdr (R.unsafeRelease tag) + _ -> impossible "toPairList" + +-- | Create an association list from a pairlist. R Pairlists are nil-terminated +-- chains of nested cons cells, as in LISP. +fromPairList :: SomeSEXP s -> [(String, SomeSEXP s)] +fromPairList (SomeSEXP (hexp -> Nil)) = [] +fromPairList (SomeSEXP (hexp -> List car cdr (hexp -> Symbol (hexp -> Char name) _ _))) = + (SVector.toString name, SomeSEXP car) : fromPairList (SomeSEXP cdr) +fromPairList (SomeSEXP (hexp -> List _ _ _)) = + failure "fromPairList" "Association listed expected but tag not set." +fromPairList _ = + failure "fromPairList" "Pairlist expected where some other expression appeared." + -- Use the default definitions included in the class declaration. instance Literal R.Logical 'R.Logical instance Literal Int32 'R.Int @@ -174,16 +210,14 @@ failure "fromSEXP" "String expected where some other expression appeared." instance SVector.VECTOR V ty a => Literal (SVector.Vector V ty a) ty where - mkSEXPIO = SVector.toSEXP - fromSEXP = unsafePerformIO . SVector.freeze . fromSEXP + mkSEXPIO = return . SVector.toSEXP + fromSEXP = SVector.fromSEXP . R.cast (sing :: SSEXPTYPE ty) + . SomeSEXP . R.release -instance SVector.VECTOR V ty a => Literal (SMVector.MVector V ty s a) ty where - mkSEXPIO = return . SMVector.toSEXP - fromSEXP = - SMVector.fromSEXP . - R.cast (sing :: SSEXPTYPE ty) . - SomeSEXP . - R.release +instance SVector.VECTOR V ty a => Literal (SMVector.MVector V ty a) ty where + mkSEXPIO = unsafeRunRegion . SMVector.toSEXP + fromSEXP = SMVector.fromSEXP . R.cast (sing :: SSEXPTYPE ty) + . SomeSEXP . R.release instance SingI a => Literal (SEXP s a) a where mkSEXPIO = fmap R.unsafeRelease . return @@ -196,15 +230,15 @@ mkSEXPIO (SomeSEXP s) = return . R.unsafeRelease $ R.unsafeCoerce s fromSEXP = SomeSEXP . R.unsafeRelease -instance Literal a b => Literal (R s a) 'R.ExtPtr where +instance (NFData a, Literal a b) => Literal (R s a) 'R.ExtPtr where mkSEXPIO = funToSEXP wrap0 fromSEXP = unimplemented "Literal (R s a) fromSEXP" -instance (Literal a a0, Literal b b0) => Literal (a -> R s b) 'R.ExtPtr where +instance (NFData b, Literal a a0, Literal b b0) => Literal (a -> R s b) 'R.ExtPtr where mkSEXPIO = funToSEXP wrap1 fromSEXP = unimplemented "Literal (a -> R s b) fromSEXP" -instance (Literal a a0, Literal b b0, Literal c c0) +instance (NFData c, Literal a a0, Literal b b0, Literal c c0) => Literal (a -> b -> R s c) 'R.ExtPtr where mkSEXPIO = funToSEXP wrap2 fromSEXP = unimplemented "Literal (a -> b -> IO c) fromSEXP" @@ -213,8 +247,8 @@ class HFunWrap a b | a -> b where hFunWrap :: a -> b -instance Literal a la => HFunWrap (R s a) (IO R.SEXP0) where - hFunWrap a = fmap R.unsexp $ (mkSEXPIO $!) =<< unsafeRToIO a +instance (NFData a, Literal a la) => HFunWrap (R s a) (IO R.SEXP0) where + hFunWrap a = fmap R.unsexp $ (mkSEXPIO $!) =<< unsafeRunRegion a instance (Literal a la, HFunWrap b wb) => HFunWrap (a -> b) (R.SEXP0 -> wb) where diff --git a/src/Language/R/QQ.hs b/src/Language/R/QQ.hs --- a/src/Language/R/QQ.hs +++ b/src/Language/R/QQ.hs @@ -13,11 +13,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - module Language.R.QQ ( r - , rexp , rsafe ) where @@ -25,30 +22,23 @@ import Control.Monad.R.Class import qualified Data.Vector.SEXP as Vector import qualified Foreign.R as R -import qualified Foreign.R.Type as SingR -import Foreign.R (SEXP, SomeSEXP(..), SEXPInfo) +import Foreign.R (SEXP, SomeSEXP(..)) import qualified H.Prelude as H import Internal.Error -import Language.R (parseText, string, eval) +import Language.R (parseText, eval) import Language.R.HExp import Language.R.Instance -import Language.R.Literal -import Language.R.Internal (installIO) - -import qualified Data.ByteString.Char8 as BS +import Language.R.Literal (mkSEXPIO) import Language.Haskell.TH (Q, runIO) -import Language.Haskell.TH.Lift (deriveLift) import Language.Haskell.TH.Quote import qualified Language.Haskell.TH.Syntax as TH import qualified Language.Haskell.TH.Lib as TH import Control.Concurrent (MVar, newMVar, withMVar) -import Control.Monad ((>=>), (<=<)) -import Data.List (isSuffixOf) -import Data.Complex (Complex) -import Data.Int (Int32) -import Data.Word (Word8) +import Data.List (intercalate, isSuffixOf) +import qualified Data.Set as Set +import Data.Set (Set) import System.IO.Unsafe (unsafePerformIO) ------------------------------------------------------------------------------- @@ -58,16 +48,7 @@ -- | An R value, expressed as an R expression, in R's syntax. r :: QuasiQuoter r = QuasiQuoter - { quoteExp = \txt -> parseEval txt - , quotePat = unimplemented "quotePat" - , quoteType = unimplemented "quoteType" - , quoteDec = unimplemented "quoteDec" - } - --- | Construct an R expression but don't evaluate it. -rexp :: QuasiQuoter -rexp = QuasiQuoter - { quoteExp = \txt -> [| io $(parseExp txt) |] + { quoteExp = \txt -> [| eval =<< $(expQQ txt) |] , quotePat = unimplemented "quotePat" , quoteType = unimplemented "quoteType" , quoteDec = unimplemented "quoteDec" @@ -82,31 +63,12 @@ -- TODO some of the above invariants can be checked statically. Do so. rsafe :: QuasiQuoter rsafe = QuasiQuoter - { quoteExp = \txt -> [| unsafePerformIO $ unsafeRToIO . eval =<< $(parseExp txt) |] + { quoteExp = \txt -> [| unsafePerformIO $ runRegion $ H.automaticSome =<< eval =<< $(expQQ txt) |] , quotePat = unimplemented "quotePat" , quoteType = unimplemented "quoteType" , quoteDec = unimplemented "quoteDec" } -parseEval :: String -> Q TH.Exp -parseEval txt = do - sexp <- parse txt - case hexp sexp of - Expr _ v -> - let vs = Vector.toList v - in [| acquireSome <=< io $ $(go vs) |] - where - go :: [SomeSEXP s] -> Q TH.Exp - go [] = error "Impossible happen." - go [SomeSEXP (returnIO -> a)] = [| R.withProtected a (unsafeRToIO . eval) |] - go (SomeSEXP (returnIO -> a) : as) = - [| R.withProtected a $ unsafeRToIO . eval >=> \(SomeSEXP s) -> - R.withProtected (return s) (const $(go as)) - |] - -returnIO :: a -> IO a -returnIO = return - -- | Serialize quasiquotes using a global lock, because the compiler is allowed -- in theory to run them in parallel, yet the R runtime is not reentrant. qqLock :: MVar () @@ -118,199 +80,66 @@ H.initialize H.defaultConfig withMVar qqLock $ \_ -> parseText txt False -parseExp :: String -> Q TH.Exp -parseExp txt = TH.lift . returnIO =<< parse txt - --- XXX Orphan instance defined here due to bad interaction betwen TH and c2hs. -instance TH.Lift (IO (SomeSEXP s)) where - lift = runIO >=> \s -> R.unSomeSEXP s (TH.lift . returnIO) - -deriveLift ''SEXPInfo -deriveLift ''Complex -deriveLift ''R.Logical - -instance TH.Lift (IO [SEXP s a]) where - lift = runIO >=> go - where - go [] = [| return [] |] - go [returnIO -> xio] = [| xio >>= return . (:[]) |] - go ((returnIO -> xio) : xs) = - [| R.withProtected xio $ $(go xs) . fmap . (:) |] - -instance TH.Lift BS.ByteString where - lift bs = let s = BS.unpack bs in [| BS.pack s |] - -#if ! MIN_VERSION_th_orphans(0,11,0) -instance TH.Lift Int32 where - lift x = let x' = fromIntegral x :: Integer in [| fromInteger x' :: Int32 |] - -instance TH.Lift Word8 where - lift x = let x' = fromIntegral x :: Integer in [| fromInteger x' :: Word8 |] - -instance TH.Lift Double where - lift x = [| $(return $ TH.LitE $ TH.RationalL $ toRational x) :: Double |] -#endif - -instance TH.Lift (IO (Vector.Vector s 'R.Raw Word8)) where - -- Apparently R considers 'allocVector' to be "defunct" for the CHARSXP - -- type. So we have to use some bespoke function. - lift = runIO >=> \v -> do - let xs :: String - xs = map (toEnum . fromIntegral) $ Vector.toList v - [| fmap vector $ string xs |] - -instance TH.Lift (IO (Vector.Vector s 'R.Char Word8)) where - -- Apparently R considers 'allocVector' to be "defunct" for the CHARSXP - -- type. So we have to use some bespoke function. - lift = runIO >=> \ v -> do - let xs :: String - xs = map (toEnum . fromIntegral) $ Vector.toList v - [| fmap vector $ string xs |] - -instance TH.Lift (IO (Vector.Vector s 'R.Logical R.Logical)) where - lift = runIO >=> \v -> do - let xs = Vector.toList v - [| fmap vector $ mkSEXPVectorIO SingR.SLogical $ map return xs |] - -instance TH.Lift (IO (Vector.Vector s 'R.Int Int32)) where - lift = runIO >=> \v -> do - let xs = Vector.toList v - [| fmap vector $ mkSEXPVectorIO SingR.SInt $ map return xs |] - -instance TH.Lift (IO (Vector.Vector s 'R.Real Double)) where - lift = runIO >=> \v -> do - let xs = Vector.toList v - [| fmap vector $ mkSEXPVectorIO SingR.SReal $ map return xs |] - -instance TH.Lift (IO (Vector.Vector s 'R.Complex (Complex Double))) where - lift = runIO >=> \v -> do - let xs = Vector.toList v - [| fmap vector $ mkSEXPVectorIO SingR.SComplex $ map return xs |] - -instance TH.Lift (IO (Vector.Vector s 'R.String (SEXP s 'R.Char))) where - lift = runIO >=> \v -> do - let xsio = returnIO $ Vector.toList v - [| fmap vector . mkProtectedSEXPVectorIO SingR.SString =<< xsio |] - -instance TH.Lift (IO (Vector.Vector s 'R.Vector (SomeSEXP s))) where - lift = runIO >=> \v -> do - let xsio = returnIO $ map (\(SomeSEXP s) -> R.unsafeCoerce s) - $ Vector.toList v :: IO [SEXP s 'R.Any] - [| fmap vector $ mkProtectedSEXPVectorIO SingR.SVector =<< xsio |] - -instance TH.Lift (IO (Vector.Vector s 'R.Expr (SomeSEXP s))) where - lift = runIO >=> \v -> do - let xsio = returnIO $ map (\(SomeSEXP s) -> R.unsafeCoerce s) - $ Vector.toList v :: IO [SEXP s 'R.Any] - [| fmap vector . mkProtectedSEXPVectorIO SingR.SExpr =<< xsio |] - --- | Returns 'True' if the variable name is in fact a Haskell value splice. -isSplice :: String -> Bool -isSplice = ("_hs" `isSuffixOf`) +antiSuffix :: String +antiSuffix = "_hs" --- | Chop a splice variable in order to obtain the name of the haskell variable --- to splice. -spliceNameChop :: String -> String -spliceNameChop name = take (length name - 3) name +isAnti :: SEXP s 'R.Char -> Bool +isAnti (hexp -> Char (Vector.toString -> name)) = antiSuffix `isSuffixOf` name +isAnti _ = error "Impossible" -instance TH.Lift (IO (SEXP s a)) where - -- Special case some forms, rather than relying on the default code - -- generated by 'deriveLift'. - lift = runIO >=> \case - (hexp -> Symbol pname _ s) | not (hexp s === Nil) -> [| installIO xs |] - where - xs :: String - xs = map (toEnum . fromIntegral) $ Vector.toList $ vector pname - (hexp -> List s (hexp -> Nil) (hexp -> Nil)) - | R.unsexp s == R.unsexp H.missingArg -> - [| R.cons H.missingArg H.nilValue |] - s@(hexp -> Symbol (returnIO -> pnameio) value _) - | R.unsexp s == R.unsexp value -> [| selfSymbol =<< pnameio |] -- FIXME - (hexp -> Symbol pname _ (hexp -> Nil)) - | Char (Vector.toString -> name) <- hexp pname - , isSplice name -> do - let hvar = TH.varE $ TH.mkName $ spliceNameChop name - [| H.mkSEXPIO $hvar |] - | otherwise -> [| installIO xs |] -- FIXME - where - xs :: String - xs = map (toEnum . fromIntegral) $ Vector.toList $ vector pname - (hexp -> Lang (hexp -> Symbol pname _ (hexp -> Nil)) (returnIO -> randsio)) - | Char (Vector.toString -> name) <- hexp pname - , isSplice name -> do - let nm = spliceNameChop name - hvar <- fmap (TH.varE . (maybe (TH.mkName nm) id)) (TH.lookupValueName nm) - [| R.withProtected (installIO ".Call") $ \call -> - R.withProtected (H.mkSEXPIO $hvar) $ \f -> do - rands <- randsio - unhexpIO . Lang call =<< unhexpIO . List f rands =<< unhexpIO Nil - |] - -- Override the default for expressions because the default Lift instance - -- for vectors will allocate a node of VECSXP type, when the node is real an - -- EXPRSXP. - (hexp -> Expr n v) -> - let xsio = returnIO $ map (\(SomeSEXP s) -> R.unsafeCoerce s) - $ Vector.toList v :: IO [SEXP s 'R.Any] - in [| R.withProtected (mkProtectedSEXPVectorIO SingR.SExpr =<< xsio) $ - unhexpIO . Expr n . vector - |] - (returnIO . hexp -> iot) -> - [| unhexpIO =<< iot |] +-- | Chop antiquotation variable names to get the corresponding Haskell variable name. +chop :: String -> String +chop name = take (length name - length antiSuffix) name -instance TH.Lift (IO (HExp s a)) where - lift = runIO >=> \case - Nil -> [| return Nil |] - Symbol (returnIO -> x0io) (returnIO -> x1io) (returnIO -> x2io) -> - [| R.withProtected x0io $ \x0 -> - R.withProtected x1io $ \x1 -> - fmap (Symbol x0 x1) x2io - |] - List (returnIO -> x0io) (returnIO -> x1io) (returnIO -> x2io) -> - [| R.withProtected x0io $ \x0 -> - R.withProtected x1io $ \x1 -> - fmap (List x0 x1) x2io - |] - Env (returnIO -> x0io) (returnIO -> x1io) (returnIO -> x2io) -> - [| R.withProtected x0io $ \x0 -> - R.withProtected x1io $ \x1 -> - fmap (Env x0 x1) x2io - |] - Closure (returnIO -> x0io) (returnIO -> x1io) (returnIO -> x2io) -> - [| R.withProtected x0io $ \x0 -> - R.withProtected x1io $ \x1 -> - fmap (Closure x0 x1) x2io - |] - Promise (returnIO -> x0io) (returnIO -> x1io) (returnIO -> x2io) -> - [| R.withProtected x0io $ \x0 -> - R.withProtected x1io $ \x1 -> - fmap (Promise x0 x1) x2io - |] - Lang (returnIO -> x0io) (returnIO -> x1io) -> - [| R.withProtected x0io $ \x0 -> - fmap (Lang x0) x1io - |] - Special x0 -> [| return $ Special x0 |] - Builtin x0 -> [| return $ Builtin x0 |] - Char (returnIO -> x0io) -> [| fmap Char x0io |] - Logical (returnIO -> x0io) -> [| fmap Logical x0io |] - Int (returnIO -> x0io) -> [| fmap Int x0io |] - Real (returnIO -> x0io) -> [| fmap Real x0io |] - Complex (returnIO -> x0io) -> [| fmap Complex x0io |] - String (returnIO -> x0io) -> [| fmap String x0io |] - DotDotDot (returnIO -> x0io) -> [| fmap DotDotDot x0io |] - Vector x0 (returnIO -> x1io) -> [| fmap (Vector x0) x1io |] - Expr x0 (returnIO -> x1io) -> [| fmap (Expr x0) x1io |] - Bytecode -> [| return Bytecode |] - ExtPtr _ _ _ -> violation "TH.Lift.lift HExp" "Attempted to lift an ExtPtr." - WeakRef (returnIO -> x0io) (returnIO -> x1io) - (returnIO -> x2io) (returnIO -> x3io) -> - [| R.withProtected x0io $ \x0 -> - R.withProtected x1io $ \x1 -> - R.withProtected x2io $ \x2 -> - fmap (WeakRef x0 x1 x2) x3io - |] - Raw (returnIO -> x0io) -> [| fmap Raw x0io |] - S4 (returnIO -> x0io) -> [| fmap S4 x0io |] +-- | Traverse 'R.SEXP' structure and find all occurences of antiquotations. +collectAntis :: R.SEXP s a -> Set (SEXP s 'R.Char) +collectAntis (hexp -> Symbol name _ _) + | isAnti name = Set.singleton name +collectAntis (hexp -> (List sxa sxb sxc)) = do + Set.unions [collectAntis sxa, collectAntis sxb, collectAntis sxc] +collectAntis (hexp -> (Lang (hexp -> Symbol name _ _) sxb)) + | isAnti name = Set.insert name (collectAntis sxb) +collectAntis (hexp -> (Lang sxa sxb)) = + Set.union (collectAntis sxa) (collectAntis sxb) +collectAntis (hexp -> (Closure sxa sxb sxc)) = + Set.unions [collectAntis sxa, collectAntis sxb, collectAntis sxc] +collectAntis (hexp -> (Vector _ sxv)) = + Set.unions [collectAntis sx | SomeSEXP sx <- Vector.toList sxv] +collectAntis (hexp -> (Expr _ sxv)) = + Set.unions [collectAntis sx | SomeSEXP sx <- Vector.toList sxv] +collectAntis _ = Set.empty -unhexpIO :: HExp s a -> IO (SEXP s a) -unhexpIO = unsafeRToIO . unhexp +-- | An R quasiquote is syntactic sugar for a function that we +-- generate, which closes over all antiquotation variables, and applies the +-- function to the Haskell values to which those variables are bound. Example: +-- +-- @ +-- [r| x_hs + y_hs |] ==> apply (apply [r| function(x_hs, y_hs) x_hs + y_hs |] x) y +-- @ +expQQ :: String -> Q TH.Exp +expQQ input = do + expr <- parse input + let antis = [x | (hexp -> Char (Vector.toString -> x)) + <- Set.toList (collectAntis expr)] + args = map (TH.dyn . chop) antis + closure = "function(" ++ intercalate "," antis ++ "){" ++ input ++ "}" + z = [| return (R.release H.nilValue) |] + vars <- mapM (\_ -> TH.newName "x") antis + -- Abstract over antis using fresh vars, to avoid captures with names bound + -- internally (such as 'f' below). + (\body -> foldl TH.appE body args) $ TH.lamE (map TH.varP vars) + [| do -- Memoize the runtime parsing of the generated closure (provided the + -- compiler notices that it can let-float to top-level). + let sx = unsafePerformIO $ do + exprs <- parseText closure False + SomeSEXP e <- R.indexVector exprs 0 + clos <- R.eval e (R.release H.globalEnv) + R.unSomeSEXP clos R.preserveObject + return clos + io $ case sx of + SomeSEXP f -> + R.lcons f =<< + $(foldr (\x xs -> [| R.withProtected $xs $ \cdr -> do + car <- mkSEXPIO $(TH.varE x) + R.lcons car cdr |]) z vars) + |] diff --git a/tests/Test/FunPtr.hs b/tests/Test/FunPtr.hs --- a/tests/Test/FunPtr.hs +++ b/tests/Test/FunPtr.hs @@ -60,7 +60,7 @@ replicateM_ 10 performGC (\(HaveWeak _ x) -> takeMVar x >>= deRefWeak) hwr , testCase "funptr works in quasi-quotes" $ - (((2::Double) @=?) =<<) $ unsafeRToIO $ do + (((2::Double) @=?) =<<) $ runRegion $ do let foo = (\x -> return $ x + 1) :: Double -> R s Double s <- [r| foo_hs(1) |] return $ dynSEXP s diff --git a/tests/Test/GC.hs b/tests/Test/GC.hs --- a/tests/Test/GC.hs +++ b/tests/Test/GC.hs @@ -18,18 +18,21 @@ import System.Mem (performMajorGC) +-- These tests only work with a version of R compiled +-- with --enable-strict-barrier. + tests :: TestTree -tests = testGroup "HVal" - [ testCase "Automatic value is not collected by R GC" $ +tests = testGroup "Automatic values" + [ testCase "Live automatic not collected by GC" $ bracket getCurrentDirectory setCurrentDirectory $ const $ do - ((assertBool "Automatic value was collected" . isInt) =<<) $ do - unsafeRToIO $ do + ((assertBool "Automatic value was not collected" . isInt) =<<) $ do + runRegion $ do x <- automatic =<< io (R.allocVector SingR.SInt 1024 :: IO (R.SEXP V 'R.Int)) io $ R.gc return $ R.typeOf x - , testCase "Automatic value works after release" $ + , testCase "Dead automatic collected by GC" $ bracket getCurrentDirectory setCurrentDirectory $ const $ do - ((assertBool "Automatic value was collected" . isInt) =<<) $ do + ((assertBool "Automatic value was collected" . not . isInt) =<<) $ do runRegion $ do _ <- [r| gctorture(TRUE) |] x <- automatic =<< io (R.allocVector SingR.SInt 1024 :: IO (R.SEXP V 'R.Int)) diff --git a/tests/Test/HExp.hs b/tests/Test/HExp.hs deleted file mode 100644 --- a/tests/Test/HExp.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -module Test.HExp ( tests ) where - -import Language.R.HExp -import Foreign.R as R - -import Foreign.C - -import Test.Tasty -import Test.Tasty.HUnit - -tests :: TestTree -tests = testGroup "hexp" - [ testGroup "Cyclyc structures" - [ testCase "naked-cyclic-structure" $ - R.withProtected (withCString "test" R.mkChar) $ \chr -> do - R.withProtected (selfSymbol chr) $ \slf -> do - assertBool "selfSymbol==selfSymbol" (hexp slf === hexp slf) - ] - ] diff --git a/tests/Test/Regions.hs b/tests/Test/Regions.hs --- a/tests/Test/Regions.hs +++ b/tests/Test/Regions.hs @@ -15,15 +15,9 @@ import Test.Tasty.HUnit import Foreign -import System.Directory (getCurrentDirectory, setCurrentDirectory) -import Control.Exception (bracket) #include -preserveDirectory :: IO a -> IO a -preserveDirectory = - bracket getCurrentDirectory setCurrentDirectory . const - #if defined(R_VERSION) && R_VERSION >= R_Version(3, 1, 0) foreign import ccall "&R_PPStackTop" ppStackTop :: Ptr Int #endif @@ -41,37 +35,27 @@ m #endif +-- XXX these tests are only effective when using a "hardened" version of +-- R compiled with --enable-strict-barrier enabled, and with the R_GCTORTURE +-- environment variable set. + tests :: TestTree tests = testGroup "regions" - [ testCase "qq-dont-leak" $ - preserveDirectory $ assertBalancedStack $ + [ testCase "qq-object-live-inside-extend" $ + assertBalancedStack $ runRegion $ do - _ <- [r| gctorture(TRUE) |] R.SomeSEXP x <- [r| 1 |] - _ <- io $ R.allocList 1 + _ <- [r| gc() |] io $ assertEqual "value is protected" R.Real (R.typeOf x) - _ <- [r| gctorture(FALSE) |] - return () - , testCase "mksexp-dont-leak" $ - preserveDirectory $ assertBalancedStack $ + , testCase "mksexp-object-live-inside-extend" $ + assertBalancedStack $ runRegion $ do - _ <- [r| gctorture(TRUE) |] x <- mkSEXP (1::Int32) - _ <- io $ R.allocList 1 + _ <- [r| gc() |] io $ assertEqual "value is protected" R.Int (R.typeOf x) - _ <- [r| gctorture(FALSE) |] - return () , testCase "runRegion-no-leaked-thunks" $ - preserveDirectory $ ((8 @=?) =<<) $ do - runRegion $ do - _ <- [r| gctorture(TRUE) |] - return () - z <- runRegion $ do - fmap dynSEXP [r| 5+3 |] - runRegion $ do - _ <- io $ R.allocList 1 - _ <- [r| gctorture(FALSE) |] - return () + z <- runRegion $ fmap dynSEXP [r| 5+3 |] + _ <- runRegion $ [r| gc() |] >> return () return (z::Int32) ] diff --git a/tests/Test/Vector.hs b/tests/Test/Vector.hs --- a/tests/Test/Vector.hs +++ b/tests/Test/Vector.hs @@ -5,6 +5,7 @@ -- Tests for the "Data.Vector.SEXP" module. {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -16,6 +17,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -28,8 +30,11 @@ import qualified Data.Vector.SEXP import qualified Data.Vector.SEXP as V import qualified Data.Vector.SEXP.Mutable as VM -import qualified Data.Vector.Generic as G +#if MIN_VERSION_vector(0,11,0) +import qualified Data.Vector.Fusion.Bundle as S +#else import qualified Data.Vector.Fusion.Stream as S +#endif import qualified Foreign.R as R import H.Prelude hiding (Show) import Language.R.QQ @@ -40,10 +45,15 @@ import Test.QuickCheck.Assertions instance (Arbitrary a, V.VECTOR s ty a) => Arbitrary (V.Vector s ty a) where - arbitrary = fmap V.fromList arbitrary + arbitrary = fmap (\x -> V.fromListN (length x) x) arbitrary +#if MIN_VERSION_vector(0,11,0) +instance Arbitrary a => Arbitrary (S.Bundle v a) where + arbitrary = fmap (\x -> S.fromListN (length x) x) arbitrary +#else instance Arbitrary a => Arbitrary (S.Stream a) where - arbitrary = fmap S.fromList arbitrary + arbitrary = fmap (\x -> S.fromListN (length x) x) arbitrary +#endif instance (AEq a, V.VECTOR s ty a) => AEq (V.Vector s ty a) where a ~== b = all (uncurry (~==)) $ zip (V.toList a) (V.toList b) @@ -52,7 +62,7 @@ testIdentity dummy = testGroup "Test identities" [ testProperty "fromList.toList == id" (prop_fromList_toList dummy) , testProperty "toList.fromList == id" (prop_toList_fromList dummy) - , testProperty "unstream.stream == id" (prop_unstream_stream dummy) +-- , testProperty "unstream.stream == id" (prop_unstream_stream dummy) -- , testProperty "stream.unstream == id" (prop_stream_unstream dummy) ] where @@ -60,8 +70,8 @@ = (V.fromList . V.toList) v ?~== v prop_toList_fromList (_ :: V.Vector s ty a) (l :: [a]) = ((V.toList :: V.Vector s ty a -> [a]) . V.fromList) l ?~== l - prop_unstream_stream (_ :: V.Vector s ty a) (v :: V.Vector s ty a) - = (G.unstream . G.stream) v ?~== v +-- prop_unstream_stream (_ :: V.Vector s ty a) (v :: V.Vector s ty a) +-- = (G.unstream . G.stream) v ?~== v -- prop_stream_unstream (_ :: V.Vector ty a) (s :: S.Stream a) -- = ((G.stream :: V.Vector ty a -> S.Stream a) . G.unstream) s == s @@ -103,29 +113,36 @@ fromListLength :: TestTree fromListLength = testCase "fromList should have correct length" $ runRegion $ do - _ <- return $ idVec $ V.fromListN 3 [-1.9, -0.1, -2.9] - let v = idVec $ V.fromList [-1.9, -0.1, -2.9] - _ <- io $ R.protect (V.unVector v) + let lst = [-1.9, -0.1, -2.9] + let vn = idVec $ V.fromListN 3 lst + let v = idVec $ V.fromList lst + io $ assertEqual "Length should be equal to list length" 3 (V.length vn) io $ assertEqual "Length should be equal to list length" 3 (V.length v) + io $ assertBool "Vectors should be almost equal" (vn ~== v) + io $ assertEqual "i0" (lst !!0) =<< (V.unsafeIndexM vn 0) + io $ assertEqual "i1" (lst !!1) =<< (V.unsafeIndexM vn 1) + io $ assertEqual "i2" (lst !!2) =<< (V.unsafeIndexM vn 2) + io $ assertEqual "Convertion back to list works" lst (V.toList vn) + io $ assertEqual "Convertion back to list works 2" lst (V.toList v) return () where idVec :: V.Vector s 'R.Real Double -> V.Vector s 'R.Real Double idVec = id vectorIsImmutable :: TestTree -vectorIsImmutable = testCase "fromList should have correct length" $ do +vectorIsImmutable = testCase "immutable vector, should not be affected by SEXP changes" $ do i <- runRegion $ do s <- fmap (R.cast (sing :: R.SSEXPTYPE 'R.Real)) [r| c(1.0,2.0,3.0) |] - let mutV = VM.fromSEXP s - immV <- V.fromSEXP s + !mutV <- return $ VM.fromSEXP s + !immV <- return $ V.fromSEXP s VM.unsafeWrite mutV 0 7 return $ immV V.! 0 i @?= 1 vectorCopy :: TestTree vectorCopy = testCase "Copying vector of doubles works" $ runRegion $ do - vs1 :: R.SEXP s 'R.Real <- V.toSEXP (V.fromList [1..3::Double]) - vs2 :: R.SEXP s 'R.Real <- V.unsafeToSEXP (V.fromList [1..3::Double]) + let vs1 = V.toSEXP (V.fromList [1..3::Double]) :: R.SEXP s 'R.Real + vs2 = V.unsafeToSEXP (V.fromList [1..3::Double]) :: R.SEXP s 'R.Real R.SomeSEXP (hexp -> Logical [R.TRUE]) <- [r| identical(vs1_hs, vs2_hs) |] return () diff --git a/tests/bench-hexp.hs b/tests/bench-hexp.hs --- a/tests/bench-hexp.hs +++ b/tests/bench-hexp.hs @@ -31,7 +31,7 @@ import Control.Monad.Primitive import Criterion.Main import Data.Int -import Data.Vector.Generic (basicUnsafeIndexM) +import Data.Vector.SEXP (unsafeIndexM) import Foreign.Ptr (Ptr) import Foreign.Storable (peek) import System.IO.Unsafe (unsafePerformIO) @@ -65,7 +65,7 @@ benchHExp :: SEXP s a -> Int32 benchHExp x = case hexp x of - Int s -> unsafeInlineIO $ basicUnsafeIndexM s 0 + Int s -> unsafeInlineIO $ s `unsafeIndexM` 0 _ -> error "unexpected SEXP" benchUncheckedInteger :: SEXP s 'R.Int -> IO Int32 @@ -75,4 +75,4 @@ benchCast x = let y = R.cast (sing :: R.SSEXPTYPE 'R.Int) x in case hexp y of -  Int s -> unsafeInlineIO $ basicUnsafeIndexM s 0 +  Int s -> unsafeInlineIO $ s `unsafeIndexM` 0 diff --git a/tests/bench-qq.hs b/tests/bench-qq.hs --- a/tests/bench-qq.hs +++ b/tests/bench-qq.hs @@ -16,6 +16,7 @@ import Language.R.QQ import Control.Applicative +import Control.Monad (void) import Criterion.Main import Data.Int import Language.Haskell.TH.Quote @@ -29,11 +30,9 @@ fib n = fib (n-1) + fib (n-2) hFib :: SEXP s 'R.Int -> R s (SEXP s 'R.Int) -hFib n@(fromSEXP -> (0 :: Int32)) = fmap (flip R.asTypeOf n) [r| as.integer(0) |] -hFib n@(fromSEXP -> (1 :: Int32)) = fmap (flip R.asTypeOf n) [r| as.integer(1) |] -hFib n = - (`R.asTypeOf` n) <$> - [r| as.integer(hFib_hs(as.integer(n_hs - 1)) + hFib_hs(as.integer(n_hs - 2))) |] +hFib n@(H.fromSEXP -> 0 :: Int32) = fmap (flip R.asTypeOf n) [r| 0L |] +hFib n@(H.fromSEXP -> 1 :: Int32) = fmap (flip R.asTypeOf n) [r| 1L |] +hFib n = (`R.asTypeOf` n) <$> [r| hFib_hs(n_hs - 1L) + hFib_hs(n_hs - 2L) |] main :: IO () main = do @@ -44,8 +43,11 @@ [ bench "pure Haskell" $ nf fib 18 , bench "compile-time-qq" $ - nfIO $ unsafeRToIO [r| fib(18) |] + nfIO $ runRegion $ do + _ <- [r| fib <<- function(n) {if (n == 1) return(1); if (n == 2) return(2); return(fib(n-1)+fib(n-2))} |] + _ <- [r| fib(18) |] + return () , bench "compile-time-qq-hybrid" $ - nfIO $ unsafeRToIO $ hFib =<< mkSEXP (18 :: Int32) + nfIO $ runRegion $ void $ hFib =<< mkSEXP (18 :: Int32) ] ] diff --git a/tests/test-qq.hs b/tests/test-qq.hs --- a/tests/test-qq.hs +++ b/tests/test-qq.hs @@ -29,11 +29,9 @@ import Prelude -- Silence AMP warning hFib :: SEXP s 'R.Int -> R s (SEXP s 'R.Int) -hFib n@(H.fromSEXP -> (0 :: Int32)) = fmap (flip R.asTypeOf n) [r| as.integer(0) |] -hFib n@(H.fromSEXP -> (1 :: Int32)) = fmap (flip R.asTypeOf n) [r| as.integer(1) |] -hFib n = - (`R.asTypeOf` n) <$> - [r| as.integer(hFib_hs(as.integer(n_hs - 1)) + hFib_hs(as.integer(n_hs - 2))) |] +hFib n@(H.fromSEXP -> 0 :: Int32) = fmap (flip R.asTypeOf n) [r| 0L |] +hFib n@(H.fromSEXP -> 1 :: Int32) = fmap (flip R.asTypeOf n) [r| 1L |] +hFib n = (`R.asTypeOf` n) <$> [r| hFib_hs(n_hs - 1L) + hFib_hs(n_hs - 2L) |] -- | Version of '(@=?)' that works in the R monad. (@=?) :: H.Show a => String -> a -> R s () @@ -50,38 +48,34 @@ ("1" @=?) =<< [r| 1 |] - -- Should be: [1] 1 - -- H.print [rsafe| 1 |] -- XXX Fails with -O0 and --enable-strict-barrier + ("1" @=?) =<< return [rsafe| 1 |] ("3" @=?) =<< [r| 1 + 2 |] - -- Should be: [1] 2 - -- H.print [rsafe| base::`+`(1, 2) |] -- XXX Fails with -O0 and --enable-strict-barrier + ("3" @=?) =<< return [rsafe| base::`+`(1, 2) |] ("c(\"1\", \"2\", \"3\")" @=?) =<< [r| c(1,2,"3") |] - ("2" @=?) =<< [r| x <- 2 |] + ("2" @=?) =<< [r| x <<- 2 |] ("3" @=?) =<< [r| x+1 |] let y = (5::Double) ("6" @=?) =<< [r| y_hs + 1 |] - ("function (y = ) 5 + y" @=?) =<< [r| function(y) y_hs + y |] - - _ <- [r| z <- function(y) y_hs + y |] + _ <- [r| z <<- function(y) y_hs + y |] ("8" @=?) =<< [r| z(3) |] - ("1:10" @=?) =<< [r| y <- c(1:10) |] + ("1:10" @=?) =<< [r| y <<- c(1:10) |] let foo1 = (\x -> (return $ x+1 :: R s Double)) let foo2 = (\x -> (return $ map (+1) x :: R s [Int32])) - ("3" @=?) =<< [r| (function(x).Call(foo1_hs,x))(2) |] + ("3" @=?) =<< [r| mapply(foo1_hs, 2) |] - ("2:11" @=?) =<< [r| (function(x).Call(foo2_hs,x))(y) |] + ("2:11" @=?) =<< [r| mapply(foo2_hs, y) |] - ("43" @=?) =<< [r| x <- 42 ; x + 1 |] + ("43" @=?) =<< [r| x <<- 42 ; x + 1 |] let xs = [1,2,3]::[Double] ("c(1, 2, 3)" @=?) =<< [r| xs_hs |] @@ -91,37 +85,32 @@ ("NULL" @=?) H.nilValue let foo3 = (\n -> fmap fromSomeSEXP [r| n_hs |]) :: Int32 -> R s Int32 - ("3L" @=?) =<< [r| foo3_hs(as.integer(3)) |] + ("3L" @=?) =<< [r| foo3_hs(3L) |] let foo4 = (\n m -> return $ n + m) :: Double -> Double -> R s Double ("99" @=?) =<< [r| foo4_hs(33, 66) |] - let fact n = if n == (0 :: Int32) then (return 1 :: R s Int32) else fmap dynSEXP [r| as.integer(n_hs * fact_hs(as.integer(n_hs - 1))) |] - ("120L" @=?) =<< [r| fact_hs(as.integer(5)) |] + let fact (0 :: Int32) = return 1 :: R s Int32 + fact n = fmap dynSEXP [r| n_hs * fact_hs(n_hs - 1L) |] + ("120L" @=?) =<< [r| fact_hs(5L) |] let foo5 = \(n :: Int32) -> return (n+1) :: R s Int32 - let apply = \(n :: R.Callback s) (m :: Int32) -> [r| .Call(n_hs, m_hs) |] :: R s (R.SomeSEXP s) - ("29L" @=?) =<< [r| apply_hs(foo5_hs, as.integer(28) ) |] + let apply :: R.SEXP s 'R.Closure -> Int32 -> R s (R.SomeSEXP s) + apply n m = [r| n_hs(m_hs) |] + ("29L" @=?) =<< [r| apply_hs(foo5_hs, 28L ) |] sym <- H.install "blah" ("blah" @=?) sym - _ <- [r| `+` <- function(x,y) x * y |] - ("100" @=?) =<< [r| 10 + 10 |] - - ("20" @=?) =<< [r| base::`+`(10,10) |] - - -- restore usual meaning of `+` - _ <- [r| `+` <- base::`+` |] - -- test Vector literal instance v1 <- do - x <- SMVector.new 3 :: R s (SMVector.MVector V 'R.Int s Int32) + x <- SMVector.new 3 :: R s (SMVector.MVector s 'R.Int Int32) SMVector.unsafeWrite x 0 1 SMVector.unsafeWrite x 1 2 SMVector.unsafeWrite x 2 3 return x - ("c(7, 2, 3)" @=?) =<< [r| v = v1_hs; v[1] <- 7; v |] + let v2 = SMVector.release v1 :: SMVector.MVector V 'R.Int Int32 + ("c(7, 2, 3)" @=?) =<< [r| v = v2_hs; v[1] <- 7; v |] io . assertEqual "" "fromList [1,2,3]" . Prelude.show =<< SVector.unsafeFreeze v1 let utf8string = "abcd çéõßø" diff --git a/tests/test-shootout.hs b/tests/test-shootout.hs --- a/tests/test-shootout.hs +++ b/tests/test-shootout.hs @@ -6,6 +6,7 @@ -- {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RankNTypes #-} module Main where @@ -15,6 +16,7 @@ import Language.R.QQ import Control.Monad (forM) +import Control.Memory.Region import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Quote as TH import System.IO @@ -24,6 +26,9 @@ import Test.Tasty.HUnit import Prelude +inVoid :: R V s -> R V s +inVoid = id + main :: IO () main = do let qqs = @@ -36,5 +41,5 @@ where cmp script qq = testCase script $ do x <- readProcess "R" ["--slave"] =<< readFile script - y <- capture_ $ H.unsafeRToIO qq + y <- capture_ $ H.unsafeRunRegion qq x @=? y diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -1,11 +1,14 @@ -- | -- Copyright: (C) 2013 Amgen, Inc. -- --- Tests. Run H on a number of R programs of increasing size and complexity, --- comparing the output of H with the output of R. +-- Main test suite for inline-r. Pass --torture on command-line or set +-- R_GCTORTURE environment variable to perform memory tests. They will be +-- ignored otherwise. Only pass --torture when linking against a version of +-- R compiled with the --enable-strict-barrier configure flag turned on. {-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} module Main where @@ -13,7 +16,6 @@ import qualified Test.Constraints import qualified Test.Event import qualified Test.FunPtr -import qualified Test.HExp import qualified Test.GC import qualified Test.Regions import qualified Test.Vector @@ -24,21 +26,27 @@ import qualified Language.R.Instance as R ( initialize , defaultConfig ) -import qualified Language.R.Internal as R ( r2 ) import Language.R.QQ import Test.Tasty import Test.Tasty.HUnit +import Test.Tasty.ExpectedFailure import Control.Applicative -import qualified Data.ByteString.Char8 (pack) -import Data.Vector.Generic (basicUnsafeIndexM) -import Data.Singletons (sing) -import Foreign +import Control.Memory.Region +import Control.Monad (void) +import Data.List (delete, find) +import Data.Singletons (sing) +import Data.Vector.SEXP (indexM) +import Foreign hiding (void) +import System.Environment (getArgs, lookupEnv, withArgs) import Prelude -- Silence AMP warning -tests :: TestTree -tests = testGroup "Unit tests" +inVoid :: R V z -> R V z +inVoid = id + +tests :: Bool -> TestTree +tests torture = testGroup "Unit tests" [ testCase "fromSEXP . mkSEXP" $ do z <- fromSEXP <$> mkSEXPIO (2 :: Double) (2 :: Double) @=? z @@ -60,20 +68,19 @@ s3 = hexp z in s1 === s2 && s2 === s3 && s1 === s3 , testCase "Haskell function from R" $ do --- (("[1] 3.0" @=?) =<<) $ --- fmap ((\s -> trace s s). show . toHVal) $ alloca $ \p -> do (((3::Double) @=?) =<<) $ fmap fromSEXP $ alloca $ \p -> do e <- peek R.globalEnv R.withProtected (mkSEXPIO $ \x -> return $ x + 1 :: R s Double) $ \sf -> R.withProtected (mkSEXPIO (2::Double)) $ \d -> - R.r2 (Data.ByteString.Char8.pack ".Call") sf d - >>= \(R.SomeSEXP s) -> R.cast (sing :: R.SSEXPTYPE 'R.Real) - <$> R.tryEval s (R.release e) p + R.withProtected (R.lang2 sf d) (unsafeRunRegion . eval) + >>= \(R.SomeSEXP s) -> + R.cast (sing :: R.SSEXPTYPE 'R.Real) <$> + R.tryEval s (R.release e) p , testCase "Weak Ptr test" $ runRegion $ do - key <- mkSEXP (return 4 :: R s Int32) - val <- mkSEXP (return 5 :: R s Int32) - True <- return $ R.typeOf val == R.ExtPtr + R.SomeSEXP key <- [r| new.env() |] + R.SomeSEXP val <- [r| new.env() |] + True <- return $ R.typeOf val == R.Env n <- unhexp Nil rf <- io $ R.mkWeakRef key val n True True <- case hexp rf of @@ -87,22 +94,35 @@ y <- R.cast (sing :: R.SSEXPTYPE 'R.Real) . R.SomeSEXP <$> mkSEXP (42::Double) case hexp y of -  Real s -> basicUnsafeIndexM s 0 +  Real s -> s `indexM` 0 , Test.Constraints.tests , Test.FunPtr.tests - , Test.HExp.tests - , Test.GC.tests - , Test.Regions.tests + , (if torture then id else ignoreTest) Test.GC.tests + , (if torture then id else ignoreTest) Test.Regions.tests , Test.Vector.tests , Test.Event.tests -- This test helps compiling quasiquoters concurrently from -- multiple modules. This in turns helps testing for race -- conditions when initializing R from multiple threads. - , testCase "qq/concurrent-initialization" $ unsafeRToIO $ [r| 1 |] >> return () + , testCase "qq/concurrent-initialization" $ runRegion $ [r| 1 |] >> return () , testCase "sanity check " $ return () ] main :: IO () main = do _ <- R.initialize R.defaultConfig - defaultMain tests + argv <- getArgs + -- Assume gctorture() step size of 1. + let tortureCLI = "1" <$ find (== "--torture") argv + tortureEnv <- lookupEnv "R_GCTORTURE" + torture <- case tortureCLI <|> tortureEnv of + Nothing -> return False + Just x -> do + -- gctorture turned on. So assume moreover --enable-strict-barrier. + let step = read x :: Int32 + putStrLn "WARNING: gctorture() turned on.\n\ + \ Tests will fail if R not compiled with --enable-strict-barrier." + runRegion $ void [r| gctorture2(step = step_hs, inhibit_release = TRUE) |] + return True + withArgs (delete "--torture" argv) $ + defaultMain (tests torture)