inline-r 0.7.3.0 → 0.8.0.0
raw patch · 31 files changed
+2643/−2347 lines, 31 filesdep +containersdep +reflectiondep +tasty-expected-failuredep ~tastydep ~vector
Dependencies added: containers, reflection, tasty-expected-failure
Dependency ranges changed: tasty, vector
Files
- cbits/missing_r.c +19/−8
- cbits/missing_r.h +3/−2
- inline-r.cabal +11/−7
- src/Control/Memory/Region.hs +2/−2
- src/Control/Monad/R/Class.hs +17/−4
- src/Control/Monad/R/Internal.hs +25/−0
- src/Data/Vector/SEXP.chs +0/−1528
- src/Data/Vector/SEXP.hs +1743/−0
- src/Data/Vector/SEXP/Base.hs +15/−10
- src/Data/Vector/SEXP/Mutable.chs +0/−332
- src/Data/Vector/SEXP/Mutable.hs +359/−0
- src/Data/Vector/SEXP/Mutable/Internal.hs +116/−0
- src/Foreign/R.chs +10/−8
- src/H/Prelude/Interactive.hs +5/−0
- src/Language/R.hs +17/−9
- src/Language/R/HExp.chs +14/−22
- src/Language/R/Instance.hs +15/−17
- src/Language/R/Internal.hs +9/−4
- src/Language/R/Internal/FunWrappers/TH.hs +7/−1
- src/Language/R/Literal.hs +53/−19
- src/Language/R/QQ.hs +67/−238
- tests/Test/FunPtr.hs +1/−1
- tests/Test/GC.hs +9/−6
- tests/Test/HExp.hs +0/−20
- tests/Test/Regions.hs +12/−28
- tests/Test/Vector.hs +31/−14
- tests/bench-hexp.hs +3/−3
- tests/bench-qq.hs +9/−7
- tests/test-qq.hs +21/−32
- tests/test-shootout.hs +6/−1
- tests/tests.hs +44/−24
cbits/missing_r.c view
@@ -4,16 +4,27 @@ #include <R.h> #include <R_ext/Rdynload.h> -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
cbits/missing_r.h view
@@ -7,12 +7,13 @@ #include <Rinternals.h> #include <R_ext/Rdynload.h> +/* 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
inline-r.cabal view
@@ -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
src/Control/Memory/Region.hs view
@@ -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.
src/Control/Monad/R/Class.hs view
@@ -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))
+ src/Control/Monad/R/Internal.hs view
@@ -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
− src/Data/Vector/SEXP.chs
@@ -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 <R.h>-#define USE_RINTERNALS-#include <Rinternals.h>---- | 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 <a> ; c = f <a,b> in f <a,b,c>----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<a> ; c = f <b,a> in f <c,b,a>----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 <huge vector>)------ Here, the slice retains a reference to the huge vector. Forcing it creates--- a copy of just the elements that belong to the slice and allows the huge--- vector to be garbage collected.-force :: VECTOR 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 <a,b,c,d> <0,3,2,3,1,0> = <a,d,c,d,b,a>-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 <x1,...,xn> = <y1,...,y(n+1)>--- > where y1 = z--- > yi = f y(i-1) x(i-1)------ Example: @scanl (+) 0 \<1,2,3,4\> = \<0,1,3,6,10\>@----scanl :: (VECTOR 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 <x1,...,xn> = <y1,...,yn>--- > 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
+ src/Data/Vector/SEXP.hs view
@@ -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 <a> ; c = f <a,b> in f <a,b,c>+--+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<a> ; c = f <b,a> in f <c,b,a>+--+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 <huge vector>)+--+-- Here, the slice retains a reference to the huge vector. Forcing it creates+-- a copy of just the elements that belong to the slice and allows the huge+-- vector to be garbage collected.+force :: VECTOR 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 <a,b,c,d> <0,3,2,3,1,0> = <a,d,c,d,b,a>+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 <x1,...,xn> = <y1,...,y(n+1)>+-- > where y1 = z+-- > yi = f y(i-1) x(i-1)+--+-- Example: @scanl (+) 0 \<1,2,3,4\> = \<0,1,3,6,10\>@+--+scanl :: (VECTOR 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 <x1,...,xn> = <y1,...,yn>+-- > 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
src/Data/Vector/SEXP/Base.hs view
@@ -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)
− src/Data/Vector/SEXP/Mutable.chs
@@ -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 <R.h>-#define USE_RINTERNALS-#include <Rinternals.h>---- | 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
+ src/Data/Vector/SEXP/Mutable.hs view
@@ -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)
+ src/Data/Vector/SEXP/Mutable/Internal.hs view
@@ -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
src/Foreign/R.chs view
@@ -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 --
src/H/Prelude/Interactive.hs view
@@ -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.
src/Language/R.hs view
@@ -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
src/Language/R/HExp.chs view
@@ -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
src/Language/R/Instance.hs view
@@ -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.
src/Language/R/Internal.hs view
@@ -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)
src/Language/R/Internal/FunWrappers/TH.hs view
@@ -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]
src/Language/R/Literal.hs view
@@ -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
src/Language/R/QQ.hs view
@@ -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)+ |]
tests/Test/FunPtr.hs view
@@ -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
tests/Test/GC.hs view
@@ -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))
− tests/Test/HExp.hs
@@ -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)- ]- ]
tests/Test/Regions.hs view
@@ -15,15 +15,9 @@ import Test.Tasty.HUnit import Foreign -import System.Directory (getCurrentDirectory, setCurrentDirectory)-import Control.Exception (bracket) #include <Rversion.h> -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) ]
tests/Test/Vector.hs view
@@ -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 ()
tests/bench-hexp.hs view
@@ -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
tests/bench-qq.hs view
@@ -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) ] ]
tests/test-qq.hs view
@@ -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 çéõßø"
tests/test-shootout.hs view
@@ -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
tests/tests.hs view
@@ -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)