diff --git a/cbits/Hcompat.h b/cbits/Hcompat.h new file mode 100644 --- /dev/null +++ b/cbits/Hcompat.h @@ -0,0 +1,26 @@ +/* Copyright (C) 2013-2014 Amgen, Inc. + * + * Compatibility macros and definitions required to build on some + * platforms. + */ + +#ifndef H_COMPAT__H +#define H_COMPAT__H + +#ifdef H_ARCH_UNIX_DARWIN + +/* NOTE: c2hs-0.17.2 and earlier choke on certain OS X system headers: + * https://github.com/haskell/c2hs/issues/85 + * + * This file must be #included in every *.chs file which #includes any + * system header, before all other #includes. + */ + +#define __AVAILABILITY__ +#define __OSX_AVAILABLE_STARTING(a,b) +#define __OSX_AVAILABLE_BUT_DEPRECATED(a,b,c,d) +#define __OSX_AVAILABLE_BUT_DEPRECATED_MSG(a,b,c,d,e) + +#endif /* H_ARCH_UNIX_DARWIN */ + +#endif /* H_COMPAT__H */ diff --git a/cbits/missing_r.c b/cbits/missing_r.c new file mode 100644 --- /dev/null +++ b/cbits/missing_r.c @@ -0,0 +1,24 @@ +// Copyright: (C) 2013 Amgen, Inc. + +#include "missing_r.h" +#include +#include + +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; +} + +// XXX Initializing isRInitialized to 0 here causes GHCi to fail with +// a linking error in Windows x64. But initializing to 2 poses no +// problem! +int isRInitialized = 2; + +HsStablePtr rVariables; diff --git a/cbits/missing_r.h b/cbits/missing_r.h new file mode 100644 --- /dev/null +++ b/cbits/missing_r.h @@ -0,0 +1,18 @@ +// Copyright: (C) 2013 Amgen, Inc. + +#ifndef MISSING_R__H +#define MISSING_R__H + +#include "HsFFI.h" +#include +#include + +SEXP funPtrToSEXP(DL_FUNC pf); + +// Indicates whether R has been initialized. +extern int isRInitialized; + +// R global variables for GHCi. +extern HsStablePtr rVariables; + +#endif diff --git a/inline-r.cabal b/inline-r.cabal new file mode 100644 --- /dev/null +++ b/inline-r.cabal @@ -0,0 +1,198 @@ +name: inline-r +version: 0.7.0.0 +license: BSD3 +copyright: Copyright (c) 2013-2015 Amgen, Inc. + Copyright (c) 2015 Tweag I/O Limited. +author: Mathieu Boespflug, Facundo Dominguez, Alexander Vershilov +maintainer: Mathieu Boespflug +cabal-version: >=1.10 +build-type: Simple +Category: FFI +Synopsis: Seamlessly call R from Haskell and vice versa. No FFI required. +cabal-version: >=1.10 + +extra-source-files: cbits/Hcompat.h + cbits/missing_r.h + tests/shootout/binarytrees.R + tests/shootout/fasta.R + tests/shootout/knucleotide.R + tests/shootout/fastaredux.R + tests/shootout/mandelbrot.R + tests/shootout/mandelbrot-noout.R + tests/shootout/nbody.R + tests/shootout/pidigits.R + tests/shootout/regexdna.R + tests/shootout/reversecomplement.R + tests/shootout/spectralnorm.R + tests/shootout/spectralnorm-math.R + tests/shootout/fannkuchredux.R + tests/R/fib.R + tests/R/fib-benchmark.R + +source-repository head + type: git + location: git://github.com/tweag/HaskellR.git + subdir: inline-r + +library + exposed-modules: Data.Vector.SEXP + Data.Vector.SEXP.Base + Data.Vector.SEXP.Mutable + Foreign.R + Foreign.R.Constraints + Foreign.R.Embedded + Foreign.R.EventLoop + Foreign.R.Error + Foreign.R.Parse + Foreign.R.Type + H.Prelude + H.Prelude.Interactive + Language.R + Language.R.Debug + Language.R.Event + Language.R.GC + 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 + Internal.Error + build-depends: base >= 4.7 && < 5 + , aeson >= 0.6 + , bytestring >= 0.10 + , data-default-class + , deepseq >= 1.3 + , exceptions >= 0.6 && < 1.1 + , mtl >= 2.1 + , pretty >= 1.1 + , primitive >= 0.5 + , process >= 1.2 + , setenv >= 0.1.1 + , singletons >= 0.9 + , template-haskell >= 2.8 + , text >= 0.11 + , th-lift >= 0.6 + , th-orphans >= 0.8 + , transformers >= 0.3 + , vector >= 0.10 && < 0.11 + hs-source-dirs: src + includes: cbits/Hcompat.h cbits/missing_r.h + c-sources: cbits/missing_r.c + include-dirs: cbits + default-language: Haskell2010 + other-extensions: CPP + ForeignFunctionInterface + build-tools: c2hs + , hsc2hs + if os(windows) + extra-libraries: R + cpp-options: -DH_ARCH_WINDOWS + cc-options: -DH_ARCH_WINDOWS + else + build-depends: unix >= 2.6 + pkgconfig-depends: libR >= 3.0 + cpp-options: -DH_ARCH_UNIX + cc-options: -DH_ARCH_UNIX + if os(darwin) + cpp-options: -DH_ARCH_UNIX_DARWIN + cc-options: -DH_ARCH_UNIX_DARWIN + -- XXX -fcontext-stack=32 required on GHC >= 7.8 to allow foreign + -- export function -wrappers of high arities. + ghc-options: -Wall -fcontext-stack=32 + +test-suite tests + main-is: tests.hs + type: exitcode-stdio-1.0 + build-depends: inline-r + , base >= 4.6 && < 5 + , bytestring >= 0.10 + , directory >= 1.2 + , filepath >= 1.3 + , ieee754 >= 0.7 + , mtl >= 2.0 + , process >= 1.2 + , quickcheck-assertions >= 0.1.1 + , singletons >= 0.10 + , strict >= 0.3.2 + , tasty >= 0.3 + , tasty-golden >= 2.3 + , tasty-hunit >= 0.4.1 + , tasty-quickcheck >= 0.4.1 + , temporary >= 1.2 + , text >= 0.11 + , unix >= 2.5 + , vector + other-modules: Test.GC + Test.FunPtr + Test.Constraints + Test.Event + Test.HExp + Test.Regions + Test.Vector + -- Adding -j4 causes quasiquoters to be compiled concurrently + -- in tests, which helps testing for race conditions when + -- trying to initialize R from multiple threads. + ghc-options: -Wall -threaded -j4 + hs-source-dirs: tests + default-language: Haskell2010 + +test-suite test-qq + main-is: test-qq.hs + type: exitcode-stdio-1.0 + build-depends: inline-r + , base >= 4.6 && < 5 + , mtl >= 2.0 + , process >= 1.2 + , tasty-hunit >= 0.4.1 + , singletons >= 0.9 + , text >= 0.11 + ghc-options: -Wall -threaded + hs-source-dirs: tests + default-language: Haskell2010 + +test-suite test-shootout + main-is: test-shootout.hs + type: exitcode-stdio-1.0 + other-modules: Test.Scripts + build-depends: inline-r + , base >= 4.6 && < 5 + , filepath >= 1.3 + , process >= 1.2 + , silently >= 1.2 + , tasty >= 0.3 + , tasty-hunit >= 0.4.1 + , template-haskell >= 2.8 + ghc-options: -Wall -threaded -O0 + hs-source-dirs: tests + default-language: Haskell2010 + +benchmark bench-qq + main-is: bench-qq.hs + type: exitcode-stdio-1.0 + build-depends: inline-r + , base >= 4.6 && < 5 + , criterion >= 0.8 + , filepath >= 1.3 + , process >= 1.2 + , template-haskell >= 2.8 + ghc-options: -Wall -threaded + hs-source-dirs: tests + default-language: Haskell2010 + +benchmark bench-hexp + main-is: bench-hexp.hs + type: exitcode-stdio-1.0 + build-depends: inline-r + , base >= 4.6 && < 5 + , criterion >= 0.8 + , primitive >= 0.5 + , vector >= 0.10 + , singletons + ghc-options: -Wall -threaded + hs-source-dirs: tests + default-language: Haskell2010 diff --git a/src/Control/Memory/Region.hs b/src/Control/Memory/Region.hs new file mode 100644 --- /dev/null +++ b/src/Control/Memory/Region.hs @@ -0,0 +1,37 @@ +-- | +-- Copyright: (C) 2013 Amgen, Inc. +-- +-- Phantom type indices for segregating values into "regions" of memory, which +-- are markers that serve as static conservative approximations of the liveness +-- of an object. That is, regions have scopes, and objects within a region are +-- guaranteed to remain live within the scope of that region. + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Control.Memory.Region where + +import GHC.Exts (Constraint) + +-- | 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 + +-- | 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. +data Void + +-- | Convenient shorthand. +type G = GlobalRegion + +-- | Convenient shorthand. +type V = Void + +-- | A partial order on regions. In fact regions form a lattice, with +-- 'GlobalRegion' being the supremum and 'Void' the infimum. +type family a <= b :: Constraint +type instance a <= a = () +type instance a <= G = () +type instance V <= b = () diff --git a/src/Control/Monad/R/Class.hs b/src/Control/Monad/R/Class.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/R/Class.hs @@ -0,0 +1,41 @@ +-- | +-- Copyright: (C) 2013 Amgen, Inc. +-- + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DefaultSignatures #-} +module Control.Monad.R.Class + ( MonadR(..) + , acquireSome + ) where + +import Control.Memory.Region +import Foreign.R + +import Control.Applicative +import Control.Monad.Catch (MonadCatch, MonadMask) +import Control.Monad.Trans (MonadIO(..)) +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 + + -- | Lift an 'IO' action. + io :: IO a -> m a + io = liftIO + + -- | Acquire ownership in the current region of the given object. This means + -- that the liveness of the object is guaranteed so long as the current region + -- remains active (the R garbage collector will not attempt to free it). + 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 + +-- | 'acquire' for 'SomeSEXP'. +acquireSome :: (MonadR m) => SomeSEXP V -> m (SomeSEXP (Region m)) +acquireSome (SomeSEXP s) = SomeSEXP <$> acquire s diff --git a/src/Data/Vector/SEXP.chs b/src/Data/Vector/SEXP.chs new file mode 100644 --- /dev/null +++ b/src/Data/Vector/SEXP.chs @@ -0,0 +1,1528 @@ +-- | +-- Copyright: (C) 2013 Amgen, Inc. +-- +-- Vectors that can be passed to and from R with no copying at all. These +-- vectors are an instance of "Data.Vector.Storable", where the memory is +-- allocated from the R heap, in such a way that they can be converted to +-- a 'SEXP' through simple pointer arithmetic (see 'toSEXP') /in constant time/. +-- +-- The main difference between "Data.Vector.SEXP" and "Data.Vector.Storable" is +-- that the former uses a header-prefixed data layout (the header immediately +-- precedes the payload of the vector). This means that no additional pointer +-- dereferencing is needed to reach the vector data. The trade-off is that most +-- slicing operations are O(N) instead of O(1). +-- +-- If you make heavy use of slicing, then it's best to convert to +-- a "Data.Vector.Storable" vector first, using 'unsafeToStorable'. +-- +-- Note that since 'unstream' relies on slicing operations, it will still be an +-- O(N) operation but it will copy vector data twice (instead of once). + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Vector.SEXP + ( Vector(..) + , Mutable.MVector(..) + , ElemRep + , VECTOR + , Data.Vector.SEXP.fromSEXP + , unsafeFromSEXP + , Data.Vector.SEXP.toSEXP + , unsafeToSEXP + + -- * Accessors + -- ** Length information + , length + , null + -- ** Indexing + , (!) + , (!?) + , head + , last + , unsafeIndex + , unsafeHead + , unsafeLast + -- ** Monadic indexing + , indexM + , headM + , lastM + , unsafeIndexM + , unsafeHeadM + , unsafeLastM + -- ** Extracting subvectors (slicing) + , slice + , init + , take + , drop + , tail + , splitAt + , unsafeTail + , unsafeSlice + , unsafeDrop + , unsafeTake + , unsafeInit + + -- * Construction + -- ** Initialisation + , empty + , singleton + , replicate + , generate + , iterateN + -- ** Monadic initialisation + , replicateM + , generateM + , create + -- ** Unfolding + , unfoldr + , unfoldrN + , constructN + , constructrN + -- ** Enumeration + , enumFromN + , enumFromStepN + , enumFromTo + , enumFromThenTo + -- ** Concatenation + , cons + , snoc + , (++) + , concat + + -- ** Restricting memory usage + , force + + -- * Modifying vectors + + -- ** Bulk updates + , (//) -- , update_, + -- unsafeUpd, unsafeUpdate_ + + -- ** Accumulations + , accum{-, accumulate_-} + , unsafeAccum{-, unsafeAccumulate_-} + + -- ** Permutations + , reverse{-, backpermute-}{-, unsafeBackpermute -} + + -- ** Safe destructive updates + {-, modify-} + + -- * Elementwise operations + + -- ** Mapping + , map + , imap + , concatMap + + -- ** Monadic mapping + , mapM + , mapM_ + , forM + , forM_ + + -- ** Zipping + , zipWith + , zipWith3 + , zipWith4 + , zipWith5 + , zipWith6 + , izipWith + , izipWith3 + , izipWith4 + , izipWith5 + , izipWith6 + + -- ** Monadic zipping + {-, zipWithM-}, zipWithM_ + + -- * Working with predicates + + -- ** Filtering + , filter + , ifilter + , filterM + , takeWhile + , dropWhile + + -- ** Partitioning + , partition + , unstablePartition + , span + , break + + -- ** Searching + , elem + , notElem + , find + , findIndex + , {-findIndices,-} elemIndex {-, elemIndices -} + + -- * Folding + , foldl + , foldl1 + , foldl' + , foldl1' + , foldr + , foldr1 + , foldr' + , foldr1' + , ifoldl + , ifoldl' + , ifoldr + , ifoldr' + + -- ** Specialised folds + , all + , any + , and + , or + , sum + , product + , maximum + , maximumBy + , minimum + , minimumBy + , minIndex + , minIndexBy + , maxIndex + , maxIndexBy + + -- ** Monadic folds + , foldM + , foldM' + , fold1M + , fold1M' + , foldM_ + , foldM'_ + , fold1M_ + , fold1M'_ + + -- * Prefix sums (scans) + , prescanl + , prescanl' + , postscanl + , postscanl' + , scanl + , scanl' + , scanl1 + , scanl1' + , prescanr + , prescanr' + , postscanr + , postscanr' + , scanr + , scanr' + , scanr1 + , scanr1' + + -- * Conversions + -- ** Lists + , toList + , fromList + , fromListN + -- ** Mutable vectors + , freeze + , thaw + , copy + , unsafeFreeze + , unsafeThaw + , unsafeCopy + + -- ** SEXP specific + , toString + , toByteString + , fromStorable + , unsafeToStorable + ) where + +import Data.Vector.SEXP.Base +import Data.Vector.SEXP.Mutable (MVector(..)) +import qualified Data.Vector.SEXP.Mutable as Mutable +import Foreign.R ( SEXP ) +import qualified Foreign.R as R +import Foreign.R.Type ( SEXPTYPE(Char) ) + +import Control.Monad.Primitive ( PrimMonad, PrimState ) +import Control.Monad.ST (ST) +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Fusion.Stream as Stream +import qualified Data.Vector.Storable as Storable +import Data.ByteString ( ByteString ) +import qualified Data.ByteString.Unsafe as B + +import Control.Applicative ((<$>)) +import Control.Monad ( liftM ) +import Control.Monad.Primitive ( unsafeInlineIO, unsafePrimToPrim ) +import Data.Word ( Word8 ) +-- import Data.Int ( Int32 ) +import Foreign ( Ptr, plusPtr, castPtr ) +import Foreign.C +import Foreign.Storable +import Foreign.Marshal.Array ( copyArray ) +#if __GLASGOW_HASKELL__ >= 708 +import qualified GHC.Exts as Exts +#endif + +import Prelude + ( Eq(..) + , Enum + , Monad(..) + , Num(..) + , Ord(..) + , Show(..) + , Bool + , Int + , IO + , Maybe + , Ordering + , String + , (.) + , ($) + , ($!) + , (=<<) + , all + , and + , any + , fromIntegral + , or + , seq + , uncurry + ) +import qualified Prelude + +#include +#define USE_RINTERNALS +#include + +-- | Immutable vectors. The second type paramater is a phantom parameter +-- reflecting at the type level the tag of the vector when viewed as a 'SEXP'. +-- The tag of the vector and the representation type are related via 'ElemRep'. +newtype Vector s (ty :: SEXPTYPE) a = Vector { unVector :: SEXP s ty } + +type instance G.Mutable (Vector r ty) = MVector r ty + +instance (Eq a, VECTOR s ty a) => Eq (Vector s ty a) where + a == b = toList a == toList b + +instance (Show a, VECTOR s ty a) => Show (Vector s ty a) where + show v = "fromList " Prelude.++ showList (toList v) "" + +instance (VECTOR s ty a) + => G.Vector (Vector s ty) a where + basicUnsafeFreeze (MVector s) = return (Vector s) + basicUnsafeThaw (Vector s) = return (MVector s) + basicLength (Vector s) = + unsafeInlineIO $ + fromIntegral <$> -- ({# get VECSEXP->vecsxp.length #} (R.unsexp s) :: IO Int32) + ((\ ptr -> do { peekByteOff ptr 32 :: IO CInt }) (R.unsexp s)) + -- XXX Basic unsafe slice is O(N) complexity as it allocates a copy of + -- a vector, due to limitations of R's VECSXP structure, which we reuse + -- directly. + basicUnsafeSlice i l v = unsafeInlineIO $ do + mv <- Mutable.new l + copyArray (toVecPtr v `plusPtr` i) + (toMVecPtr mv) + l + G.basicUnsafeFreeze mv + basicUnsafeIndexM v i = return . unsafeInlineIO + $ peekElemOff (toVecPtr v) i + basicUnsafeCopy mv v = unsafePrimToPrim $ + copyArray (toVecPtr v) + (toMVecPtr mv) + (G.basicLength v) + + elemseq _ = seq + +#if __GLASGOW_HASKELL__ >= 708 +instance VECTOR s ty a => Exts.IsList (Vector s ty a) where + type Item (Vector s ty a) = a + fromList = fromList + fromListN = fromListN + toList = toList +#endif + +toVecPtr :: Vector s ty a -> Ptr a +toVecPtr mv = castPtr (R.unsafeSEXPToVectorPtr $ unVector mv) + +toMVecPtr :: MVector s ty r a -> Ptr a +toMVecPtr mv = castPtr (R.unsafeSEXPToVectorPtr $ unMVector mv) + +-- | /O(n)/ Create an immutable vector from a 'SEXP'. Because 'SEXP's are +-- mutable, this function yields an immutable /copy/ of the 'SEXP'. +fromSEXP :: (VECTOR s ty a, PrimMonad m) + => SEXP s ty + -> m (Vector s ty a) +fromSEXP s = G.freeze (Mutable.fromSEXP s) + +-- | /O(1)/ Unsafe convert a mutable 'SEXP' to an immutable vector without +-- copying. The mutable vector must not be used after this operation, lest one +-- runs the risk of breaking referential transparency. +unsafeFromSEXP :: VECTOR s ty a + => SEXP s ty + -> Vector s ty a +unsafeFromSEXP s = Vector s + +-- | /O(n)/ Yield a (mutable) copy of the vector as a 'SEXP'. +toSEXP :: (VECTOR s ty a, PrimMonad m) + => Vector s ty a + -> m (SEXP s ty) +toSEXP = liftM Mutable.toSEXP . G.thaw + +-- | /O(1)/ Unsafely convert an immutable vector to a (mutable) 'SEXP' without +-- copying. The immutable vector must not be used after this operation. +unsafeToSEXP :: (VECTOR s ty a, PrimMonad m) + => Vector s ty a + -> m (SEXP s ty) +unsafeToSEXP = liftM Mutable.toSEXP . G.unsafeThaw + +-- | /O(n)/ Convert a character vector into a 'String'. +toString :: Vector s 'Char Word8 -> String +toString v = unsafeInlineIO $ peekCString . castPtr + . R.unsafeSEXPToVectorPtr + . unVector $ v + +-- | /O(1)/ Convert a character vector into a strict 'ByteString'. +toByteString :: Vector s 'Char Word8 -> ByteString +toByteString v@(Vector p) = unsafeInlineIO + $ B.unsafePackCStringLen (castPtr $! R.unsafeSEXPToVectorPtr p, G.length v) + +------------------------------------------------------------------------ +-- Vector API +-- + +------------------------------------------------------------------------ +-- Length +------------------------------------------------------------------------ + +-- | /O(1)/ Yield the length of the vector. +length :: VECTOR s ty a => Vector s ty a -> Int +{-# INLINE length #-} +length = G.length + +-- | /O(1)/ Test whether a vector if empty +null :: VECTOR s ty a => Vector s ty a -> Bool +{-# INLINE null #-} +null = G.null + + +------------------------------------------------------------------------ +-- Indexing +------------------------------------------------------------------------ + +-- | O(1) Indexing +(!) :: VECTOR s ty a => Vector s ty a -> Int -> a +{-# INLINE (!) #-} +(!) = (G.!) + +-- | O(1) Safe indexing +(!?) :: VECTOR s ty a => Vector s ty a -> Int -> Maybe a +{-# INLINE (!?) #-} +(!?) = (G.!?) + +-- | /O(1)/ First element +head :: VECTOR s ty a => Vector s ty a -> a +{-# INLINE head #-} +head = G.head + +-- | /O(1)/ Last element +last :: VECTOR s ty a => Vector s ty a -> a +{-# INLINE last #-} +last = G.last + +-- | /O(1)/ Unsafe indexing without bounds checking +unsafeIndex :: VECTOR s ty a => Vector s ty a -> Int -> a +{-# INLINE unsafeIndex #-} +unsafeIndex = G.unsafeIndex + +-- | /O(1)/ First element without checking if the vector is empty +unsafeHead :: VECTOR s ty a => Vector s ty a -> a +{-# INLINE unsafeHead #-} +unsafeHead = G.unsafeHead + +-- | /O(1)/ Last element without checking if the vector is empty +unsafeLast :: VECTOR s ty a => Vector s ty a -> a +{-# INLINE unsafeLast #-} +unsafeLast = G.unsafeLast + +------------------------------------------------------------------------ +-- Monadic indexing +------------------------------------------------------------------------ + +-- | /O(1)/ Indexing in a monad. +-- +-- The monad allows operations to be strict in the vector when necessary. +-- Suppose vector copying is implemented like this: +-- +-- > copy mv v = ... write mv i (v ! i) ... +-- +-- For lazy vectors, @v ! i@ would not be evaluated which means that @mv@ +-- would unnecessarily retain a reference to @v@ in each element written. +-- +-- With 'indexM', copying can be implemented like this instead: +-- +-- > copy mv v = ... do +-- > x <- indexM v i +-- > write mv i x +-- +-- Here, no references to @v@ are retained because indexing (but /not/ the +-- elements) is evaluated eagerly. +-- +indexM :: (VECTOR s ty a, Monad m) => Vector s ty a -> Int -> m a +{-# INLINE indexM #-} +indexM = G.indexM + +-- | /O(1)/ First element of a vector in a monad. See 'indexM' for an +-- explanation of why this is useful. +headM :: (VECTOR s ty a, Monad m) => Vector s ty a -> m a +{-# INLINE headM #-} +headM = G.headM + +-- | /O(1)/ Last element of a vector in a monad. See 'indexM' for an +-- explanation of why this is useful. +lastM :: (VECTOR s ty a, Monad m) => Vector s ty a -> m a +{-# INLINE lastM #-} +lastM = G.lastM + +-- | /O(1)/ Indexing in a monad without bounds checks. See 'indexM' for an +-- explanation of why this is useful. +unsafeIndexM :: (VECTOR s ty a, Monad m) => Vector s ty a -> Int -> m a +{-# INLINE unsafeIndexM #-} +unsafeIndexM = G.unsafeIndexM + +-- | /O(1)/ First element in a monad without checking for empty vectors. +-- See 'indexM' for an explanation of why this is useful. +unsafeHeadM :: (VECTOR s ty a, Monad m) => Vector s ty a -> m a +{-# INLINE unsafeHeadM #-} +unsafeHeadM = G.unsafeHeadM + +-- | /O(1)/ Last element in a monad without checking for empty vectors. +-- See 'indexM' for an explanation of why this is useful. +unsafeLastM :: (VECTOR s ty a, Monad m) => Vector s ty a -> m a +{-# INLINE unsafeLastM #-} +unsafeLastM = G.unsafeLastM + +------------------------------------------------------------------------ +-- Extracting subvectors (slicing) +------------------------------------------------------------------------ + +-- | /O(N)/ Yield a slice of the vector with copying it. The vector must +-- contain at least @i+n@ elements. +slice :: VECTOR s ty a + => Int -- ^ @i@ starting index + -> Int -- ^ @n@ length + -> Vector s ty a + -> Vector s ty a +{-# INLINE slice #-} +slice = G.slice + +-- | /O(N)/ Yield all but the last element, this operation will copy an array. +-- The vector may not be empty. +init :: VECTOR s ty a => Vector s ty a -> Vector s ty a +{-# INLINE init #-} +init = G.init + +-- | /O(N)/ Copy all but the first element. The vector may not be empty. +tail :: VECTOR s ty a => Vector s ty a -> Vector s ty a +{-# INLINE tail #-} +tail = G.tail + +-- | /O(N)/ Yield at the first @n@ elements with copying. The vector may +-- contain less than @n@ elements in which case it is returned unchanged. +take :: VECTOR s ty a => Int -> Vector s ty a -> Vector s ty a +{-# INLINE take #-} +take = G.take + +-- | /O(N)/ Yield all but the first @n@ elements with copying. The vector may +-- contain less than @n@ elements in which case an empty vector is returned. +drop :: VECTOR s ty a => Int -> Vector s ty a -> Vector s ty a +{-# INLINE drop #-} +drop = G.drop + +-- | /O(N)/ Yield the first @n@ elements paired with the remainder with copying. +-- +-- Note that @'splitAt' n v@ is equivalent to @('take' n v, 'drop' n v)@ +-- but slightly more efficient. +{-# INLINE splitAt #-} +splitAt :: VECTOR s ty a => Int -> Vector s ty a -> (Vector s ty a, Vector s ty a) +splitAt = G.splitAt + +-- | /O(N)/ Yield a slice of the vector with copying. The vector must +-- contain at least @i+n@ elements but this is not checked. +unsafeSlice :: VECTOR s ty a => Int -- ^ @i@ starting index + -> Int -- ^ @n@ length + -> Vector s ty a + -> Vector s ty a +{-# INLINE unsafeSlice #-} +unsafeSlice = G.unsafeSlice + +-- | /O(N)/ Yield all but the last element with copying. The vector may not +-- be empty but this is not checked. +unsafeInit :: VECTOR s ty a => Vector s ty a -> Vector s ty a +{-# INLINE unsafeInit #-} +unsafeInit = G.unsafeInit + +-- | /O(N)/ Yield all but the first element with copying. The vector may not +-- be empty but this is not checked. +unsafeTail :: VECTOR s ty a => Vector s ty a -> Vector s ty a +{-# INLINE unsafeTail #-} +unsafeTail = G.unsafeTail + +-- | /O(N)/ Yield the first @n@ elements with copying. The vector must +-- contain at least @n@ elements but this is not checked. +unsafeTake :: VECTOR s ty a => Int -> Vector s ty a -> Vector s ty a +{-# INLINE unsafeTake #-} +unsafeTake = G.unsafeTake + +-- | /O(N)/ Yield all but the first @n@ elements with copying. The vector +-- must contain at least @n@ elements but this is not checked. +unsafeDrop :: VECTOR s ty a => Int -> Vector s ty a -> Vector s ty a +{-# INLINE unsafeDrop #-} +unsafeDrop = G.unsafeDrop + +-- Initialisation +-- -------------- + +-- | /O(1)/ Empty vector +empty :: VECTOR s ty a => Vector s ty a +{-# INLINE empty #-} +empty = G.empty -- TODO test + +-- | /O(1)/ Vector with exactly one element +singleton :: VECTOR s ty a => a -> Vector s ty a +{-# INLINE singleton #-} +singleton = G.singleton + +-- | /O(n)/ Vector of the given length with the same value in each position +replicate :: VECTOR s ty a => Int -> a -> Vector s ty a +{-# INLINE replicate #-} +replicate = G.replicate + +-- | /O(n)/ Construct a vector of the given length by applying the function to +-- each index +generate :: VECTOR s ty a => Int -> (Int -> a) -> Vector s ty a +{-# INLINE generate #-} +generate = G.generate + +-- | /O(n)/ Apply function n times to value. Zeroth element is original value. +iterateN :: VECTOR s ty a => Int -> (a -> a) -> a -> Vector s ty a +{-# INLINE iterateN #-} +iterateN = G.iterateN + +-- Unfolding +-- --------- + +-- | /O(n)/ Construct a Vector s ty by repeatedly applying the generator function +-- to a seed. The generator function yields 'Just' the next element and the +-- new seed or 'Nothing' if there are no more elements. +-- +-- > unfoldr (\n -> if n == 0 then Nothing else Just (n,n-1)) 10 +-- > = <10,9,8,7,6,5,4,3,2,1> +unfoldr :: VECTOR s ty a => (b -> Maybe (a, b)) -> b -> Vector s ty a +{-# INLINE unfoldr #-} +unfoldr = G.unfoldr + +-- | /O(n)/ Construct a vector with at most @n@ by repeatedly applying the +-- generator function to the a seed. The generator function yields 'Just' the +-- next element and the new seed or 'Nothing' if there are no more elements. +-- +-- > unfoldrN 3 (\n -> Just (n,n-1)) 10 = <10,9,8> +unfoldrN :: VECTOR s ty a => Int -> (b -> Maybe (a, b)) -> b -> Vector s ty a +{-# INLINE unfoldrN #-} +unfoldrN = G.unfoldrN + +-- | /O(n)/ Construct a vector with @n@ elements by repeatedly applying the +-- generator function to the already constructed part of the vector. +-- +-- > constructN 3 f = let a = f <> ; b = f ; c = f in f +-- +constructN :: VECTOR s ty a => Int -> (Vector s ty a -> a) -> Vector s ty a +{-# INLINE constructN #-} +constructN = G.constructN + +-- | /O(n)/ Construct a vector with @n@ elements from right to left by +-- repeatedly applying the generator function to the already constructed part +-- of the vector. +-- +-- > constructrN 3 f = let a = f <> ; b = f ; c = f in f +-- +constructrN :: VECTOR s ty a => Int -> (Vector s ty a -> a) -> Vector s ty a +{-# INLINE constructrN #-} +constructrN = G.constructrN + +-- Enumeration +-- ----------- + +-- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+1@ +-- etc. This operation is usually more efficient than 'enumFromTo'. +-- +-- > enumFromN 5 3 = <5,6,7> +enumFromN :: (VECTOR s ty a, Num a) => a -> Int -> Vector s ty a +{-# INLINE enumFromN #-} +enumFromN = G.enumFromN + +-- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+y@, +-- @x+y+y@ etc. This operations is usually more efficient than 'enumFromThenTo'. +-- +-- > enumFromStepN 1 0.1 5 = <1,1.1,1.2,1.3,1.4> +enumFromStepN :: (VECTOR s ty a, Num a) => a -> a -> Int -> Vector s ty a +{-# INLINE enumFromStepN #-} +enumFromStepN = G.enumFromStepN + +-- | /O(n)/ Enumerate values from @x@ to @y@. +-- +-- /WARNING:/ This operation can be very inefficient. If at all possible, use +-- 'enumFromN' instead. +enumFromTo :: (VECTOR s ty a, Enum a) => a -> a -> Vector s ty a +{-# INLINE enumFromTo #-} +enumFromTo = G.enumFromTo + +-- | /O(n)/ Enumerate values from @x@ to @y@ with a specific step @z@. +-- +-- /WARNING:/ This operation can be very inefficient. If at all possible, use +-- 'enumFromStepN' instead. +enumFromThenTo :: (VECTOR s ty a, Enum a) => a -> a -> a -> Vector s ty a +{-# INLINE enumFromThenTo #-} +enumFromThenTo = G.enumFromThenTo + +-- Concatenation +-- ------------- + +-- | /O(n)/ Prepend an element +cons :: VECTOR s ty a => a -> Vector s ty a -> Vector s ty a +{-# INLINE cons #-} +cons = G.cons + +-- | /O(n)/ Append an element +snoc :: VECTOR s ty a => Vector s ty a -> a -> Vector s ty a +{-# INLINE snoc #-} +snoc = G.snoc + +infixr 5 ++ +-- | /O(m+n)/ Concatenate two vectors +(++) :: VECTOR s ty a => Vector s ty a -> Vector s ty a -> Vector s ty a +{-# INLINE (++) #-} +(++) = (G.++) + +-- | /O(n)/ Concatenate all vectors in the list +concat :: VECTOR s ty a => [Vector s ty a] -> Vector s ty a +{-# INLINE concat #-} +concat = G.concat + +-- Monadic initialisation +-- ---------------------- + +-- | /O(n)/ Execute the monadic action the given number of times and store the +-- results in a vector. +replicateM :: (Monad m, VECTOR s ty a) => Int -> m a -> m (Vector s ty a) +{-# INLINE replicateM #-} +replicateM = G.replicateM + +-- | /O(n)/ Construct a vector of the given length by applying the monadic +-- action to each index +generateM :: (Monad m, VECTOR s ty a) => Int -> (Int -> m a) -> m (Vector s ty a) +{-# INLINE generateM #-} +generateM = G.generateM + +-- | Execute the monadic action and freeze the resulting vector. +-- +-- @ +-- create (do { v \<- new 2; write v 0 \'a\'; write v 1 \'b\'; return v }) = \<'a','b'\> +-- @ +create :: VECTOR s ty a => (forall r. ST r (MVector s ty r a)) -> Vector s ty a +{-# INLINE create #-} +-- NOTE: eta-expanded due to http://hackage.haskell.org/trac/ghc/ticket/4120 +create p = G.create p + + +-- Restricting memory usage +-- ------------------------ + +-- | /O(n)/ Yield the argument but force it not to retain any extra memory, +-- possibly by copying it. +-- +-- This is especially useful when dealing with slices. For example: +-- +-- > force (slice 0 2 ) +-- +-- Here, the slice retains a reference to the huge vector. Forcing it creates +-- a copy of just the elements that belong to the slice and allows the huge +-- vector to be garbage collected. +force :: VECTOR s ty a => Vector s ty a -> Vector s ty a +{-# INLINE force #-} +force = G.force + +-- Bulk updates +-- ------------ + +-- | /O(m+n)/ For each pair @(i,a)@ from the list, replace the vector +-- element at position @i@ by @a@. +-- +-- > <5,9,2,7> // [(2,1),(0,3),(2,8)] = <3,9,8,7> +-- +(//) :: VECTOR s ty a => Vector s ty a -- ^ initial vector (of length @m@) + -> [(Int, a)] -- ^ list of index/value pairs (of length @n@) + -> Vector s ty a +{-# INLINE (//) #-} +(//) = (G.//) + +{- +-- | /O(m+min(n1,n2))/ For each index @i@ from the index Vector s ty and the +-- corresponding value @a@ from the value vector, replace the element of the +-- initial Vector s ty at position @i@ by @a@. +-- +-- > update_ <5,9,2,7> <2,0,2> <1,3,8> = <3,9,8,7> +-- +update_ :: VECTOR s ty a + => Vector s ty a -- ^ initial vector (of length @m@) + -> Vector Int -- ^ index vector (of length @n1@) + -> Vector s ty a -- ^ value vector (of length @n2@) + -> Vector s ty a +{-# INLINE update_ #-} +update_ = G.update_ +-} + +{- +-- | Same as ('//') but without bounds checking. +unsafeUpd :: VECTOR s ty a => Vector s ty a -> [(Int, a)] -> Vector s ty a +{-# INLINE unsafeUpd #-} +unsafeUpd = G.unsafeUpd +-} + +{- +-- | Same as 'update_' but without bounds checking. +unsafeUpdate_ :: VECTOR s ty a => Vector s ty a -> Vector Int -> Vector s ty a -> Vector s ty a +{-# INLINE unsafeUpdate_ #-} +unsafeUpdate_ = G.unsafeUpdate_ +-} + +-- Accumulations +-- ------------- + +-- | /O(m+n)/ For each pair @(i,b)@ from the list, replace the vector element +-- @a@ at position @i@ by @f a b@. +-- +-- > accum (+) <5,9,2> [(2,4),(1,6),(0,3),(1,7)] = <5+3, 9+6+7, 2+4> +accum :: VECTOR s ty a + => (a -> b -> a) -- ^ accumulating function @f@ + -> Vector s ty a -- ^ initial vector (of length @m@) + -> [(Int,b)] -- ^ list of index/value pairs (of length @n@) + -> Vector s ty a +{-# INLINE accum #-} +accum = G.accum + +{- +-- | /O(m+min(n1,n2))/ For each index @i@ from the index Vector s ty and the +-- corresponding value @b@ from the the value vector, +-- replace the element of the initial Vector s ty at +-- position @i@ by @f a b@. +-- +-- > accumulate_ (+) <5,9,2> <2,1,0,1> <4,6,3,7> = <5+3, 9+6+7, 2+4> +-- +accumulate_ :: (VECTOR s ty a, VECTOR s ty b) + => (a -> b -> a) -- ^ accumulating function @f@ + -> Vector s ty a -- ^ initial vector (of length @m@) + -> Vector Int -- ^ index vector (of length @n1@) + -> Vector s ty b -- ^ value vector (of length @n2@) + -> Vector s ty a +{-# INLINE accumulate_ #-} +accumulate_ = G.accumulate_ +-} + +-- | Same as 'accum' but without bounds checking. +unsafeAccum :: VECTOR s ty a => (a -> b -> a) -> Vector s ty a -> [(Int,b)] -> Vector s ty a +{-# INLINE unsafeAccum #-} +unsafeAccum = G.unsafeAccum + +{- +-- | Same as 'accumulate_' but without bounds checking. +unsafeAccumulate_ :: (VECTOR s ty a, VECTOR s ty b) => + (a -> b -> a) -> Vector s ty a -> Vector Int -> Vector s ty b -> Vector s ty a +{-# INLINE unsafeAccumulate_ #-} +unsafeAccumulate_ = G.unsafeAccumulate_ +-} + +-- Permutations +-- ------------ + +-- | /O(n)/ Reverse a vector +reverse :: VECTOR s ty a => Vector s ty a -> Vector s ty a +{-# INLINE reverse #-} +reverse = G.reverse + +{- +-- | /O(n)/ Yield the vector obtained by replacing each element @i@ of the +-- index Vector s ty by @xs'!'i@. This is equivalent to @'map' (xs'!') is@ but is +-- often much more efficient. +-- +-- > backpermute <0,3,2,3,1,0> = +backpermute :: VECTOR s ty a => Vector s ty a -> Vector Int -> Vector s ty a +{-# INLINE backpermute #-} +backpermute = G.backpermute +-} + +{- +-- | Same as 'backpermute' but without bounds checking. +unsafeBackpermute :: VECTOR s ty a => Vector s ty a -> Vector Int -> Vector s ty a +{-# INLINE unsafeBackpermute #-} +unsafeBackpermute = G.unsafeBackpermute +-} + +-- Safe destructive updates +-- ------------------------ + +{- +-- | Apply a destructive operation to a vector. The operation will be +-- performed in place if it is safe to do so and will modify a copy of the +-- vector otherwise. +-- +-- @ +-- modify (\\v -> write v 0 \'x\') ('replicate' 3 \'a\') = \<\'x\',\'a\',\'a\'\> +-- @ +modify :: VECTOR s ty a => (forall s. MVector s a -> ST s ()) -> Vector s ty a -> Vector s ty a +{-# INLINE modify #-} +modify p = G.modify p +-} + +-- Mapping +-- ------- + +-- | /O(n)/ Map a function over a vector +map :: (VECTOR s ty a, VECTOR s ty b) => (a -> b) -> Vector s ty a -> Vector s ty b +{-# INLINE map #-} +map = G.map + +-- | /O(n)/ Apply a function to every element of a Vector s ty and its index +imap :: (VECTOR s ty a, VECTOR s ty b) => (Int -> a -> b) -> Vector s ty a -> Vector s ty b +{-# INLINE imap #-} +imap = G.imap + +-- | Map a function over a Vector s ty and concatenate the results. +concatMap :: (VECTOR s ty a, VECTOR s ty b) => (a -> Vector s ty b) -> Vector s ty a -> Vector s ty b +{-# INLINE concatMap #-} +concatMap = G.concatMap + +-- Monadic mapping +-- --------------- + +-- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a +-- vector of results +mapM :: (Monad m, VECTOR s ty a, VECTOR s ty b) => (a -> m b) -> Vector s ty a -> m (Vector s ty b) +{-# INLINE mapM #-} +mapM = G.mapM + +-- | /O(n)/ Apply the monadic action to all elements of a Vector s ty and ignore the +-- results +mapM_ :: (Monad m, VECTOR s ty a) => (a -> m b) -> Vector s ty a -> m () +{-# INLINE mapM_ #-} +mapM_ = G.mapM_ + +-- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a +-- vector of results. Equvalent to @flip 'mapM'@. +forM :: (Monad m, VECTOR s ty a, VECTOR s ty b) => Vector s ty a -> (a -> m b) -> m (Vector s ty b) +{-# INLINE forM #-} +forM = G.forM + +-- | /O(n)/ Apply the monadic action to all elements of a Vector s ty and ignore the +-- results. Equivalent to @flip 'mapM_'@. +forM_ :: (Monad m, VECTOR s ty a) => Vector s ty a -> (a -> m b) -> m () +{-# INLINE forM_ #-} +forM_ = G.forM_ + +-- Zipping +-- ------- + +-- | /O(min(m,n))/ Zip two vectors with the given function. +zipWith :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c) + => (a -> b -> c) -> Vector s tya a -> Vector s tyb b -> Vector s tyc c +{-# INLINE zipWith #-} +zipWith f xs ys = G.unstream (Stream.zipWith f (G.stream xs) (G.stream ys)) + +-- | Zip three vectors with the given function. +zipWith3 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d) + => (a -> b -> c -> d) -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d +{-# INLINE zipWith3 #-} +zipWith3 f as bs cs = G.unstream (Stream.zipWith3 f (G.stream as) (G.stream bs) (G.stream cs)) + +zipWith4 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d, VECTOR s tye e) + => (a -> b -> c -> d -> e) + -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -> Vector s tye e +{-# INLINE zipWith4 #-} +zipWith4 f as bs cs ds = G.unstream (Stream.zipWith4 f (G.stream as) (G.stream bs) (G.stream cs) (G.stream ds)) + +zipWith5 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d, VECTOR s tye e, + VECTOR s tyf f) + => (a -> b -> c -> d -> e -> f) + -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -> Vector s tye e + -> Vector s tyf f +{-# INLINE zipWith5 #-} +zipWith5 f as bs cs ds es = G.unstream (Stream.zipWith5 f (G.stream as) (G.stream bs) (G.stream cs) (G.stream ds) (G.stream es)) + +zipWith6 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d, VECTOR s tye e, + VECTOR s tyf f, VECTOR s tyg g) + => (a -> b -> c -> d -> e -> f -> g) + -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -> Vector s tye e + -> Vector s tyf f -> Vector s tyg g +{-# INLINE zipWith6 #-} +zipWith6 f as bs cs ds es fs = G.unstream (Stream.zipWith6 f (G.stream as) (G.stream bs) (G.stream cs) (G.stream ds) (G.stream es) (G.stream fs)) + +-- | /O(min(m,n))/ Zip two vectors with a function that also takes the +-- elements' indices. +izipWith :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c) + => (Int -> a -> b -> c) -> Vector s tya a -> Vector s tyb b -> Vector s tyc c +{-# INLINE izipWith #-} +izipWith f as bs = G.unstream (Stream.zipWith (uncurry f) (Stream.indexed (G.stream as)) (G.stream bs)) + +-- | Zip three vectors and their indices with the given function. +izipWith3 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d) + => (Int -> a -> b -> c -> d) + -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d +{-# INLINE izipWith3 #-} +izipWith3 f as bs cs = G.unstream (Stream.zipWith3 (uncurry f) (Stream.indexed (G.stream as)) (G.stream bs) (G.stream cs)) + +izipWith4 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d, VECTOR s tye e) + => (Int -> a -> b -> c -> d -> e) + -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -> Vector s tye e +{-# INLINE izipWith4 #-} +izipWith4 f as bs cs ds = G.unstream (Stream.zipWith4 (uncurry f) (Stream.indexed (G.stream as)) (G.stream bs) (G.stream cs) (G.stream ds)) + +izipWith5 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d, VECTOR s tye e, + VECTOR s tyf f) + => (Int -> a -> b -> c -> d -> e -> f) + -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -> Vector s tye e + -> Vector s tyf f +{-# INLINE izipWith5 #-} +izipWith5 f as bs cs ds es = G.unstream (Stream.zipWith5 (uncurry f) (Stream.indexed (G.stream as)) (G.stream bs) (G.stream cs) (G.stream ds) (G.stream es)) + +izipWith6 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d, VECTOR s tye e, + VECTOR s tyf f, VECTOR s tyg g) + => (Int -> a -> b -> c -> d -> e -> f -> g) + -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -> Vector s tye e + -> Vector s tyf f -> Vector s tyg g +{-# INLINE izipWith6 #-} +izipWith6 f as bs cs ds es fs = G.unstream (Stream.zipWith6 (uncurry f) (Stream.indexed (G.stream as)) (G.stream bs) (G.stream cs) (G.stream ds) (G.stream es) (G.stream fs)) + +-- Monadic zipping +-- --------------- + +{- +-- | /O(min(m,n))/ Zip the two vectors with the monadic action and yield a +-- vector of results +zipWithM :: (Monad m, VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c) + => (a -> b -> m c) -> Vector s tya a -> Vector s tyb b -> m (Vector s tyc c) +{-# INLINE zipWithM #-} +zipWithM f as bs = G.unstreamM (Stream.zipWithM f (G.stream as) (G.stream bs)) +-} + +-- | /O(min(m,n))/ Zip the two vectors with the monadic action and ignore the +-- results +zipWithM_ :: (Monad m, VECTOR s tya a, VECTOR s tyb b) + => (a -> b -> m c) -> Vector s tya a -> Vector s tyb b -> m () +{-# INLINE zipWithM_ #-} +zipWithM_ f as bs = Stream.zipWithM_ f (G.stream as) (G.stream bs) + +-- Filtering +-- --------- + +-- | /O(n)/ Drop elements that do not satisfy the predicate +filter :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Vector s ty a +{-# INLINE filter #-} +filter = G.filter + +-- | /O(n)/ Drop elements that do not satisfy the predicate which is applied to +-- values and their indices +ifilter :: VECTOR s ty a => (Int -> a -> Bool) -> Vector s ty a -> Vector s ty a +{-# INLINE ifilter #-} +ifilter = G.ifilter + +-- | /O(n)/ Drop elements that do not satisfy the monadic predicate +filterM :: (Monad m, VECTOR s ty a) => (a -> m Bool) -> Vector s ty a -> m (Vector s ty a) +{-# INLINE filterM #-} +filterM = G.filterM + +-- | /O(n)/ Yield the longest prefix of elements satisfying the predicate +-- with copying. +takeWhile :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Vector s ty a +{-# INLINE takeWhile #-} +takeWhile = G.takeWhile + +-- | /O(n)/ Drop the longest prefix of elements that satisfy the predicate +-- with copying. +dropWhile :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Vector s ty a +{-# INLINE dropWhile #-} +dropWhile = G.dropWhile + +-- Parititioning +-- ------------- + +-- | /O(n)/ Split the vector in two parts, the first one containing those +-- elements that satisfy the predicate and the second one those that don't. The +-- relative order of the elements is preserved at the cost of a sometimes +-- reduced performance compared to 'unstablePartition'. +partition :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> (Vector s ty a, Vector s ty a) +{-# INLINE partition #-} +partition = G.partition + +-- | /O(n)/ Split the vector in two parts, the first one containing those +-- elements that satisfy the predicate and the second one those that don't. +-- The order of the elements is not preserved but the operation is often +-- faster than 'partition'. +unstablePartition :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> (Vector s ty a, Vector s ty a) +{-# INLINE unstablePartition #-} +unstablePartition = G.unstablePartition + +-- | /O(n)/ Split the vector into the longest prefix of elements that satisfy +-- the predicate and the rest with copying. +span :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> (Vector s ty a, Vector s ty a) +{-# INLINE span #-} +span = G.span + +-- | /O(n)/ Split the vector into the longest prefix of elements that do not +-- satisfy the predicate and the rest with copying. +break :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> (Vector s ty a, Vector s ty a) +{-# INLINE break #-} +break = G.break + +-- Searching +-- --------- + +infix 4 `elem` +-- | /O(n)/ Check if the vector contains an element +elem :: (VECTOR s ty a, Eq a) => a -> Vector s ty a -> Bool +{-# INLINE elem #-} +elem = G.elem + +infix 4 `notElem` +-- | /O(n)/ Check if the vector does not contain an element (inverse of 'elem') +notElem :: (VECTOR s ty a, Eq a) => a -> Vector s ty a -> Bool +{-# INLINE notElem #-} +notElem = G.notElem + +-- | /O(n)/ Yield 'Just' the first element matching the predicate or 'Nothing' +-- if no such element exists. +find :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Maybe a +{-# INLINE find #-} +find = G.find + +-- | /O(n)/ Yield 'Just' the index of the first element matching the predicate +-- or 'Nothing' if no such element exists. +findIndex :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Maybe Int +{-# INLINE findIndex #-} +findIndex = G.findIndex + +{- +-- | /O(n)/ Yield the indices of elements satisfying the predicate in ascending +-- order. +findIndices :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Vector Int +{-# INLINE findIndices #-} +findIndices = G.findIndices +-} + +-- | /O(n)/ Yield 'Just' the index of the first occurence of the given element or +-- 'Nothing' if the vector does not contain the element. This is a specialised +-- version of 'findIndex'. +elemIndex :: (VECTOR s ty a, Eq a) => a -> Vector s ty a -> Maybe Int +{-# INLINE elemIndex #-} +elemIndex = G.elemIndex + +{- +-- | /O(n)/ Yield the indices of all occurences of the given element in +-- ascending order. This is a specialised version of 'findIndices'. +elemIndices :: (VECTOR s ty a, Eq a) => a -> Vector s ty a -> Vector Int +{-# INLINE elemIndices #-} +elemIndices = G.elemIndices +-} + +-- Folding +-- ------- + +-- | /O(n)/ Left fold +foldl :: VECTOR s ty b => (a -> b -> a) -> a -> Vector s ty b -> a +{-# INLINE foldl #-} +foldl = G.foldl + +-- | /O(n)/ Left fold on non-empty vectors +foldl1 :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> a +{-# INLINE foldl1 #-} +foldl1 = G.foldl1 + +-- | /O(n)/ Left fold with strict accumulator +foldl' :: VECTOR s ty b => (a -> b -> a) -> a -> Vector s ty b -> a +{-# INLINE foldl' #-} +foldl' = G.foldl' + +-- | /O(n)/ Left fold on non-empty vectors with strict accumulator +foldl1' :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> a +{-# INLINE foldl1' #-} +foldl1' = G.foldl1' + +-- | /O(n)/ Right fold +foldr :: VECTOR s ty a => (a -> b -> b) -> b -> Vector s ty a -> b +{-# INLINE foldr #-} +foldr = G.foldr + +-- | /O(n)/ Right fold on non-empty vectors +foldr1 :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> a +{-# INLINE foldr1 #-} +foldr1 = G.foldr1 + +-- | /O(n)/ Right fold with a strict accumulator +foldr' :: VECTOR s ty a => (a -> b -> b) -> b -> Vector s ty a -> b +{-# INLINE foldr' #-} +foldr' = G.foldr' + +-- | /O(n)/ Right fold on non-empty vectors with strict accumulator +foldr1' :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> a +{-# INLINE foldr1' #-} +foldr1' = G.foldr1' + +-- | /O(n)/ Left fold (function applied to each element and its index) +ifoldl :: VECTOR s ty b => (a -> Int -> b -> a) -> a -> Vector s ty b -> a +{-# INLINE ifoldl #-} +ifoldl = G.ifoldl + +-- | /O(n)/ Left fold with strict accumulator (function applied to each element +-- and its index) +ifoldl' :: VECTOR s ty b => (a -> Int -> b -> a) -> a -> Vector s ty b -> a +{-# INLINE ifoldl' #-} +ifoldl' = G.ifoldl' + +-- | /O(n)/ Right fold (function applied to each element and its index) +ifoldr :: VECTOR s ty a => (Int -> a -> b -> b) -> b -> Vector s ty a -> b +{-# INLINE ifoldr #-} +ifoldr = G.ifoldr + +-- | /O(n)/ Right fold with strict accumulator (function applied to each +-- element and its index) +ifoldr' :: VECTOR s ty a => (Int -> a -> b -> b) -> b -> Vector s ty a -> b +{-# INLINE ifoldr' #-} +ifoldr' = G.ifoldr' + +-- Specialised folds +-- ----------------- + +{- +-- | /O(n)/ Check if all elements satisfy the predicate. +all :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Bool +{-# INLINE all #-} +all = G.all + +-- | /O(n)/ Check if any element satisfies the predicate. +any :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Bool +{-# INLINE any #-} +any = G.any + +-- | /O(n)/ Check if all elements are 'True' +and :: Vector 'Logical Bool -> R.Logical +{-# INLINE and #-} +and = G.and -- FIXME + +-- | /O(n)/ Check if any element is 'True' +or :: Vector 'Logical Bool -> R.Logical +{-# INLINE or #-} +or = G.or +-} + +-- | /O(n)/ Compute the sum of the elements +sum :: (VECTOR s ty a, Num a) => Vector s ty a -> a +{-# INLINE sum #-} +sum = G.sum + +-- | /O(n)/ Compute the produce of the elements +product :: (VECTOR s ty a, Num a) => Vector s ty a -> a +{-# INLINE product #-} +product = G.product + +-- | /O(n)/ Yield the maximum element of the vector. The vector may not be +-- empty. +maximum :: (VECTOR s ty a, Ord a) => Vector s ty a -> a +{-# INLINE maximum #-} +maximum = G.maximum + +-- | /O(n)/ Yield the maximum element of the Vector s ty according to the given +-- comparison function. The vector may not be empty. +maximumBy :: VECTOR s ty a => (a -> a -> Ordering) -> Vector s ty a -> a +{-# INLINE maximumBy #-} +maximumBy = G.maximumBy + +-- | /O(n)/ Yield the minimum element of the vector. The vector may not be +-- empty. +minimum :: (VECTOR s ty a, Ord a) => Vector s ty a -> a +{-# INLINE minimum #-} +minimum = G.minimum + +-- | /O(n)/ Yield the minimum element of the Vector s ty according to the given +-- comparison function. The vector may not be empty. +minimumBy :: VECTOR s ty a => (a -> a -> Ordering) -> Vector s ty a -> a +{-# INLINE minimumBy #-} +minimumBy = G.minimumBy + +-- | /O(n)/ Yield the index of the maximum element of the vector. The vector +-- may not be empty. +maxIndex :: (VECTOR s ty a, Ord a) => Vector s ty a -> Int +{-# INLINE maxIndex #-} +maxIndex = G.maxIndex + +-- | /O(n)/ Yield the index of the maximum element of the Vector s ty according to +-- the given comparison function. The vector may not be empty. +maxIndexBy :: VECTOR s ty a => (a -> a -> Ordering) -> Vector s ty a -> Int +{-# INLINE maxIndexBy #-} +maxIndexBy = G.maxIndexBy + +-- | /O(n)/ Yield the index of the minimum element of the vector. The vector +-- may not be empty. +minIndex :: (VECTOR s ty a, Ord a) => Vector s ty a -> Int +{-# INLINE minIndex #-} +minIndex = G.minIndex + +-- | /O(n)/ Yield the index of the minimum element of the Vector s ty according to +-- the given comparison function. The vector may not be empty. +minIndexBy :: VECTOR s ty a => (a -> a -> Ordering) -> Vector s ty a -> Int +{-# INLINE minIndexBy #-} +minIndexBy = G.minIndexBy + +-- Monadic folds +-- ------------- + +-- | /O(n)/ Monadic fold +foldM :: (Monad m, VECTOR s ty b) => (a -> b -> m a) -> a -> Vector s ty b -> m a +{-# INLINE foldM #-} +foldM = G.foldM + +-- | /O(n)/ Monadic fold over non-empty vectors +fold1M :: (Monad m, VECTOR s ty a) => (a -> a -> m a) -> Vector s ty a -> m a +{-# INLINE fold1M #-} +fold1M = G.fold1M + +-- | /O(n)/ Monadic fold with strict accumulator +foldM' :: (Monad m, VECTOR s ty b) => (a -> b -> m a) -> a -> Vector s ty b -> m a +{-# INLINE foldM' #-} +foldM' = G.foldM' + +-- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator +fold1M' :: (Monad m, VECTOR s ty a) => (a -> a -> m a) -> Vector s ty a -> m a +{-# INLINE fold1M' #-} +fold1M' = G.fold1M' + +-- | /O(n)/ Monadic fold that discards the result +foldM_ :: (Monad m, VECTOR s ty b) => (a -> b -> m a) -> a -> Vector s ty b -> m () +{-# INLINE foldM_ #-} +foldM_ = G.foldM_ + +-- | /O(n)/ Monadic fold over non-empty vectors that discards the result +fold1M_ :: (Monad m, VECTOR s ty a) => (a -> a -> m a) -> Vector s ty a -> m () +{-# INLINE fold1M_ #-} +fold1M_ = G.fold1M_ + +-- | /O(n)/ Monadic fold with strict accumulator that discards the result +foldM'_ :: (Monad m, VECTOR s ty b) => (a -> b -> m a) -> a -> Vector s ty b -> m () +{-# INLINE foldM'_ #-} +foldM'_ = G.foldM'_ + +-- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator +-- that discards the result +fold1M'_ :: (Monad m, VECTOR s ty a) => (a -> a -> m a) -> Vector s ty a -> m () +{-# INLINE fold1M'_ #-} +fold1M'_ = G.fold1M'_ + +-- Prefix sums (scans) +-- ------------------- + +-- | /O(n)/ Prescan +-- +-- @ +-- prescanl f z = 'init' . 'scanl' f z +-- @ +-- +-- Example: @prescanl (+) 0 \<1,2,3,4\> = \<0,1,3,6\>@ +-- +prescanl :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> a) -> a -> Vector s ty b -> Vector s ty a +{-# INLINE prescanl #-} +prescanl = G.prescanl + +-- | /O(n)/ Prescan with strict accumulator +prescanl' :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> a) -> a -> Vector s ty b -> Vector s ty a +{-# INLINE prescanl' #-} +prescanl' = G.prescanl' + +-- | /O(n)/ Scan +-- +-- @ +-- postscanl f z = 'tail' . 'scanl' f z +-- @ +-- +-- Example: @postscanl (+) 0 \<1,2,3,4\> = \<1,3,6,10\>@ +-- +postscanl :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> a) -> a -> Vector s ty b -> Vector s ty a +{-# INLINE postscanl #-} +postscanl = G.postscanl + +-- | /O(n)/ Scan with strict accumulator +postscanl' :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> a) -> a -> Vector s ty b -> Vector s ty a +{-# INLINE postscanl' #-} +postscanl' = G.postscanl' + +-- | /O(n)/ Haskell-style scan +-- +-- > scanl f z = +-- > where y1 = z +-- > yi = f y(i-1) x(i-1) +-- +-- Example: @scanl (+) 0 \<1,2,3,4\> = \<0,1,3,6,10\>@ +-- +scanl :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> a) -> a -> Vector s ty b -> Vector s ty a +{-# INLINE scanl #-} +scanl = G.scanl + +-- | /O(n)/ Haskell-style scan with strict accumulator +scanl' :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> a) -> a -> Vector s ty b -> Vector s ty a +{-# INLINE scanl' #-} +scanl' = G.scanl' + +-- | /O(n)/ Scan over a non-empty vector +-- +-- > scanl f = +-- > where y1 = x1 +-- > yi = f y(i-1) xi +-- +scanl1 :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> Vector s ty a +{-# INLINE scanl1 #-} +scanl1 = G.scanl1 + +-- | /O(n)/ Scan over a non-empty vector with a strict accumulator +scanl1' :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> Vector s ty a +{-# INLINE scanl1' #-} +scanl1' = G.scanl1' + +-- | /O(n)/ Right-to-left prescan +-- +-- @ +-- prescanr f z = 'reverse' . 'prescanl' (flip f) z . 'reverse' +-- @ +-- +prescanr :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> b) -> b -> Vector s ty a -> Vector s ty b +{-# INLINE prescanr #-} +prescanr = G.prescanr + +-- | /O(n)/ Right-to-left prescan with strict accumulator +prescanr' :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> b) -> b -> Vector s ty a -> Vector s ty b +{-# INLINE prescanr' #-} +prescanr' = G.prescanr' + +-- | /O(n)/ Right-to-left scan +postscanr :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> b) -> b -> Vector s ty a -> Vector s ty b +{-# INLINE postscanr #-} +postscanr = G.postscanr + +-- | /O(n)/ Right-to-left scan with strict accumulator +postscanr' :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> b) -> b -> Vector s ty a -> Vector s ty b +{-# INLINE postscanr' #-} +postscanr' = G.postscanr' + +-- | /O(n)/ Right-to-left Haskell-style scan +scanr :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> b) -> b -> Vector s ty a -> Vector s ty b +{-# INLINE scanr #-} +scanr = G.scanr + +-- | /O(n)/ Right-to-left Haskell-style scan with strict accumulator +scanr' :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> b) -> b -> Vector s ty a -> Vector s ty b +{-# INLINE scanr' #-} +scanr' = G.scanr' + +-- | /O(n)/ Right-to-left scan over a non-empty vector +scanr1 :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> Vector s ty a +{-# INLINE scanr1 #-} +scanr1 = G.scanr1 + +-- | /O(n)/ Right-to-left scan over a non-empty vector with a strict +-- accumulator +scanr1' :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> Vector s ty a +{-# INLINE scanr1' #-} +scanr1' = G.scanr1' + +-- Conversions - Lists +-- ------------------------ + +-- | /O(n)/ Convert a vector to a list +toList :: VECTOR s ty a => Vector s ty a -> [a] +{-# INLINE toList #-} +toList = G.toList + +-- | /O(n)/ Convert a list to a vector +fromList :: VECTOR s ty a => [a] -> Vector s ty a +{-# INLINE fromList #-} +fromList xs = G.fromListN (Prelude.length xs) xs + +-- | /O(n)/ Convert the first @n@ elements of a list to a vector +-- +-- @ +-- fromListN n xs = 'fromList' ('take' n xs) +-- @ +fromListN :: VECTOR s ty a => Int -> [a] -> Vector s ty a +{-# INLINE fromListN #-} +fromListN = G.fromListN + +-- Conversions - Unsafe casts +-- -------------------------- + +-- Conversions - Mutable vectors +-- ----------------------------- + +-- | /O(1)/ Unsafe convert a mutable vector to an immutable one with +-- copying. The mutable vector may not be used after this operation. +unsafeFreeze + :: (VECTOR s ty a, PrimMonad m) => MVector s ty (PrimState m) a -> m (Vector s ty a) +{-# INLINE unsafeFreeze #-} +unsafeFreeze = G.unsafeFreeze + +-- | /O(1)/ Unsafely convert an immutable vector to a mutable one with +-- copying. The immutable vector may not be used after this operation. +unsafeThaw + :: (VECTOR s ty a, PrimMonad m) => Vector s ty a -> m (MVector s ty (PrimState m) a) +{-# INLINE unsafeThaw #-} +unsafeThaw = G.unsafeThaw + +-- | /O(n)/ Yield a mutable copy of the immutable vector. +thaw :: (VECTOR s ty a, PrimMonad m) => Vector s ty a -> m (MVector s ty (PrimState m) a) +{-# INLINE thaw #-} +thaw = G.thaw + +-- | /O(n)/ Yield an immutable copy of the mutable vector. +freeze :: (VECTOR s ty a, PrimMonad m) => MVector s ty (PrimState m) a -> m (Vector s ty a) +{-# INLINE freeze #-} +freeze = G.freeze + +-- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must +-- have the same length. This is not checked. +unsafeCopy + :: (VECTOR s ty a, PrimMonad m) => MVector s ty (PrimState m) a -> Vector s ty a -> m () +{-# INLINE unsafeCopy #-} +unsafeCopy = G.unsafeCopy + +-- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must +-- have the same length. +copy :: (VECTOR s ty a, PrimMonad m) => MVector s ty (PrimState m) a -> Vector s ty a -> m () +{-# INLINE copy #-} +copy = G.copy + +-- | O(1) Inplace convertion to Storable vector. +unsafeToStorable :: VECTOR s ty a + => Vector s ty a -- ^ target + -> Storable.Vector a -- ^ source +{-# INLINE unsafeToStorable #-} +unsafeToStorable v = unsafeInlineIO $ + G.unsafeFreeze =<< Mutable.unsafeToStorable =<< G.unsafeThaw v + +-- | O(N) Convertion from storable vector to SEXP vector. +fromStorable :: VECTOR s ty a + => Storable.Vector a + -> Vector s ty a +{-# INLINE fromStorable #-} +fromStorable v = unsafeInlineIO $ + G.unsafeFreeze =<< Mutable.fromStorable =<< G.unsafeThaw v diff --git a/src/Data/Vector/SEXP/Base.hs b/src/Data/Vector/SEXP/Base.hs new file mode 100644 --- /dev/null +++ b/src/Data/Vector/SEXP/Base.hs @@ -0,0 +1,38 @@ +-- | +-- Copyright: (C) 2013 Amgen, Inc. +-- + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Vector.SEXP.Base where + +import Foreign.R.Type +import Foreign.R (SEXP, SomeSEXP) + +import Data.Singletons (SingI) + +import Data.Complex (Complex) +import Data.Word (Word8) +import Data.Int (Int32) +import Foreign.Storable (Storable) + +-- | 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 + +-- | '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) diff --git a/src/Data/Vector/SEXP/Mutable.chs b/src/Data/Vector/SEXP/Mutable.chs new file mode 100644 --- /dev/null +++ b/src/Data/Vector/SEXP/Mutable.chs @@ -0,0 +1,332 @@ +-- | +-- Copyright: (C) 2013 Amgen, Inc. +-- +-- Vectors that can be passed to and from R with no copying at all. These +-- vectors are wrappers over SEXP vectors used by R. Memory for vectors is +-- allocated from the R heap, and in such way that they can be converted to +-- a 'SEXP' by simple pointer arithmetic (see 'toSEXP'). +-- +-- The main difference between "Data.Vector.SEXP.Mutable" and +-- "Data.Vector.Storable" is that the former uses a header-prefixed data layout +-- (the header immediately precedes the payload of the vector). This means that +-- no additional pointer dereferencing is needed to reach the vector data. The +-- trade-off is, for mutable vectors, slicing is not supported. The reason is +-- that slicing header-prefixed vectors is generally not possible without +-- copying, which breaks the semantics of the API for 'MVector'. +-- +-- To perform slicing, it is necessary to convert to a "Data.Vector.Storable" +-- vector first, using 'unsafeToStorable'. + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Vector.SEXP.Mutable + ( -- * Mutable vectors of 'SEXP' types + MVector(..) + , IOVector + , STVector + -- * Accessors + -- ** Length information + , length + , null + -- * Construction + -- ** Initialisation + , new + , unsafeNew + , replicate + , replicateM + , clone + -- ** Restricting memory usage + , clear + -- * Accessing individual elements + , read + , write + , swap + , unsafeRead + , unsafeWrite + , unsafeSwap + -- * Modifying vectors + -- ** Filling and copying + , set + , copy + , move + , unsafeCopy + , unsafeMove + -- * SEXP specific. + , fromSEXP + , toSEXP + , unsafeToStorable + , fromStorable + ) where + +import Data.Vector.SEXP.Base +import qualified Foreign.R as R +import Foreign.R (SEXP, SEXPTYPE) +import Foreign.R.Type (SSEXPTYPE, IsVector) +import Internal.Error + +import Control.Applicative +import Control.Monad (liftM) +import Control.Monad.Primitive + (PrimMonad, PrimState, RealWorld, unsafePrimToPrim, unsafeInlineIO) +import qualified Data.Vector.Generic.Mutable as G +import qualified Data.Vector.Storable.Mutable as Storable +import Data.Singletons (fromSing, sing) +import Data.Int + +import Foreign (castPtr, Ptr, withForeignPtr) +import Foreign.Concurrent (newForeignPtr) +import Foreign.C +import Foreign.Storable +import Foreign.Marshal.Array (copyArray, moveArray) + +import Prelude hiding (length, null, replicate, read) +import System.IO.Unsafe (unsafePerformIO) + +#include +#define USE_RINTERNALS +#include + +-- | Mutable R vector. They are represented in memory with the same header as +-- 'SEXP' nodes. The second type paramater is a phantom parameter reflecting at +-- the type level the tag of the vector when viewed as a 'SEXP'. The tag of the +-- vector and the representation type are related via 'ElemRep'. +newtype MVector s (ty :: SEXPTYPE) r a = MVector { unMVector :: SEXP s ty } + +type IOVector s ty = MVector s ty RealWorld +type STVector s ty r = MVector s ty s + +instance (VECTOR s ty a) + => G.MVector (MVector s ty) a where + basicLength (MVector s) = unsafeInlineIO $ + fromIntegral <$> {# get VECSEXP->vecsxp.length #} (R.unsexp s) +-- N.B. slicing can't be supported properly by vectors prefixed by header, +-- this means that we can support only a reducing size (required for +-- vectors algorithms), and slicing that is noop + basicUnsafeSlice j m v + | j == 0 && m == G.basicLength v = v + | j == 0 = unsafePerformIO $ do + let s = castPtr $ R.unsexp $ unMVector v + {# set VECSEXP->vecsxp.length #} s (fromIntegral m :: CInt) + return v + | otherwise = + failure "Data.Vector.SEXP.Mutable.slice" + "unsafeSlice is not supported for SEXP vectors, to perform slicing convert vector to Storable." + basicOverlaps mv1 mv2 = unMVector mv1 == unMVector mv2 + basicUnsafeNew n + -- R calls using allocVector() for CHARSXP "defunct"... + | fromSing (sing :: SSEXPTYPE ty) == R.Char = + failure "Data.Vector.SEXP.Mutable.new" + "R character vectors are immutable and globally cached. Use 'mkChar' instead." + | otherwise = + -- No functor instance available here in GHC < 7.10 (pre AMP). + liftM fromSEXP $ unsafePrimToPrim (R.allocVectorProtected (sing :: SSEXPTYPE ty) n) + basicUnsafeRead mv i = unsafePrimToPrim + $ peekElemOff (toVecPtr mv) i + basicUnsafeWrite mv i x = unsafePrimToPrim + $ pokeElemOff (toVecPtr mv) i x + basicSet mv x = Prelude.mapM_ (\i -> G.basicUnsafeWrite mv i x) [0..G.basicLength mv] + basicUnsafeCopy mv1 mv2 = unsafePrimToPrim $ do + copyArray (toVecPtr mv1) + (toVecPtr mv2) + (G.basicLength mv1) + basicUnsafeMove mv1 mv2 = unsafePrimToPrim $ do + moveArray (toVecPtr mv1) + (toVecPtr mv2) + (G.basicLength mv1) + +toVecPtr :: MVector s ty r a -> Ptr a +toVecPtr mv = castPtr (R.unsafeSEXPToVectorPtr $ unMVector mv) + +-- | /O(1)/ Create a vector from a 'SEXP'. +fromSEXP :: (E s ty a, Storable a, IsVector ty) + => R.SEXP s ty + -> MVector s ty r a +fromSEXP s = MVector s + +-- | /O(1)/ Convert a mutable vector to a 'SEXP'. This can be done efficiently, +-- without copy, because vectors in this module always include a 'SEXP' header +-- immediately before the vector data in memory. +toSEXP :: forall s a r ty. (E s ty a, IsVector ty, Storable a) + => MVector s ty r a + -> R.SEXP s ty +toSEXP = unMVector + +-- Length information +-- ------------------ + +-- | Length of the mutable vector. +length :: VECTOR s ty a => MVector s ty r a -> Int +{-# INLINE length #-} +length (MVector s) = + unsafeInlineIO $ + fromIntegral <$> {# get VECSEXP->vecsxp.length #} (R.unsexp s) + +-- | Check whether the vector is empty +null :: VECTOR s ty a => (MVector s ty) r a -> Bool +{-# INLINE null #-} +null (MVector s) = + unsafeInlineIO $ + ((/= (0::Int)) . fromIntegral) <$> + {# get VECSEXP->vecsxp.length #} (R.unsexp s) + +-- Initialisation +-- -------------- + +-- | Create a mutable vector of the given length. +new :: (PrimMonad m, VECTOR s ty a) => Int -> m (MVector s ty (PrimState m) a) +{-# INLINE new #-} +new = G.new + +-- | Create a mutable vector of the given length. The length is not checked. +unsafeNew :: (PrimMonad m, VECTOR s ty a) => Int -> m (MVector s ty (PrimState m) a) +{-# INLINE unsafeNew #-} +unsafeNew = G.unsafeNew + +-- | Create a mutable vector of the given length (0 if the length is negative) +-- and fill it with an initial value. +replicate :: (PrimMonad m, VECTOR s ty a) => Int -> a -> m (MVector s ty (PrimState m) a) +{-# INLINE replicate #-} +replicate = G.replicate + +-- | Create a mutable vector of the given length (0 if the length is negative) +-- and fill it with values produced by repeatedly executing the monadic action. +replicateM :: (PrimMonad m, VECTOR s ty a) => Int -> m a -> m (MVector s ty (PrimState m) a) +{-# INLINE replicateM #-} +replicateM = G.replicateM + +-- | Create a copy of a mutable vector. +clone :: (PrimMonad m, VECTOR s ty a) + => MVector s ty (PrimState m) a -> m (MVector s ty (PrimState m) a) +{-# INLINE clone #-} +clone = G.clone + +-- Restricting memory usage +-- ------------------------ + +-- | Reset all elements of the vector to some undefined value, clearing all +-- references to external objects. This is usually a noop for unboxed vectors. +clear :: (PrimMonad m, VECTOR s ty a) => MVector s ty (PrimState m) a -> m () +{-# INLINE clear #-} +clear = G.clear + +-- Accessing individual elements +-- ----------------------------- + +-- | Yield the element at the given position. +read :: (PrimMonad m, VECTOR s ty a) + => MVector s ty (PrimState m) a -> Int -> m a +{-# INLINE read #-} +read = G.read + +-- | Replace the element at the given position. +write :: (PrimMonad m, VECTOR s ty a) + => MVector s ty (PrimState m) a -> Int -> a -> m () +{-# INLINE write #-} +write = G.write + +-- | Swap the elements at the given positions. +swap :: (PrimMonad m, VECTOR s ty a) + => MVector s ty (PrimState m) a -> Int -> Int -> m () +{-# INLINE swap #-} +swap = G.swap + +-- | Yield the element at the given position. No bounds checks are performed. +unsafeRead :: (PrimMonad m, VECTOR s ty a) + => MVector s ty (PrimState m) a -> Int -> m a +{-# INLINE unsafeRead #-} +unsafeRead = G.unsafeRead + +-- | Replace the element at the given position. No bounds checks are performed. +unsafeWrite :: (PrimMonad m, VECTOR s ty a) + => MVector s ty (PrimState m) a -> Int -> a -> m () +{-# INLINE unsafeWrite #-} +unsafeWrite = G.unsafeWrite + +-- | Swap the elements at the given positions. No bounds checks are performed. +unsafeSwap :: (PrimMonad m, VECTOR s ty a) + => MVector s ty (PrimState m) a -> Int -> Int -> m () +{-# INLINE unsafeSwap #-} +unsafeSwap = G.unsafeSwap + +-- Filling and copying +-- ------------------- + +-- | Set all elements of the vector to the given value. +set :: (PrimMonad m, VECTOR s ty a) => MVector s ty (PrimState m) a -> a -> m () +{-# INLINE set #-} +set = G.set + +-- | Copy a vector. The two vectors must have the same length and may not +-- overlap. +copy :: (PrimMonad m, VECTOR s ty a) + => MVector s ty (PrimState m) a + -> MVector s ty (PrimState m) a + -> m () +{-# INLINE copy #-} +copy = G.copy + +-- | Copy a vector. The two vectors must have the same length and may not +-- overlap. This is not checked. +unsafeCopy :: (PrimMonad m, VECTOR s ty a) + => MVector s ty (PrimState m) a -- ^ target + -> MVector s ty (PrimState m) a -- ^ source + -> m () +{-# INLINE unsafeCopy #-} +unsafeCopy = G.unsafeCopy + +-- | Move the contents of a vector. The two vectors must have the same +-- length. +-- +-- If the vectors do not overlap, then this is equivalent to 'copy'. +-- Otherwise, the copying is performed as if the source vector were +-- copied to a temporary vector and then the temporary vector was copied +-- to the target vector. +move :: (PrimMonad m, VECTOR s ty a) + => MVector s ty (PrimState m) a + -> MVector s ty (PrimState m) a + -> m () +{-# INLINE move #-} +move = G.move + +-- | Move the contents of a vector. The two vectors must have the same +-- length, but this is not checked. +-- +-- If the vectors do not overlap, then this is equivalent to 'unsafeCopy'. +-- Otherwise, the copying is performed as if the source vector were +-- copied to a temporary vector and then the temporary vector was copied +-- to the target vector. +unsafeMove :: (PrimMonad m, VECTOR s ty a) + => MVector s ty (PrimState m) a -- ^ target + -> MVector s ty (PrimState m) a -- ^ source + -> m () +{-# INLINE unsafeMove #-} +unsafeMove = G.unsafeMove + +-- | O(1) Inplace convertion to Storable vector. +unsafeToStorable :: (PrimMonad m, VECTOR s ty a) + => MVector s ty (PrimState m) a -- ^ target + -> m (Storable.MVector (PrimState m) a) -- ^ source +{-# INLINE unsafeToStorable #-} +unsafeToStorable v@(MVector p) = unsafePrimToPrim $ do + R.preserveObject p + ptr <- newForeignPtr (toVecPtr v) (R.releaseObject (R.sexp $ castPtr $ toVecPtr v)) + return $ Storable.unsafeFromForeignPtr0 ptr (length v) + +-- | O(N) Convertion from storable vector to SEXP vector. +fromStorable :: (PrimMonad m, VECTOR s ty a) + => Storable.MVector (PrimState m) a + -> m (MVector s ty (PrimState m) a) +{-# INLINE fromStorable #-} +fromStorable v = do + let (fptr, l) = Storable.unsafeToForeignPtr0 v + mv <- new l + unsafePrimToPrim $ withForeignPtr fptr $ \p -> do + copyArray (toVecPtr mv) p (Storable.length v) + return mv diff --git a/src/Foreign/R.chs b/src/Foreign/R.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/R.chs @@ -0,0 +1,657 @@ +-- | +-- Copyright: (C) 2013 Amgen, Inc. +-- +-- Low-level bindings to core R datatypes and functions. Nearly all structures +-- allocated internally in R are instances of a 'SEXPREC'. A pointer to +-- a 'SEXPREC' is called a 'SEXP'. +-- +-- To allow for precise typing of bindings to primitive R functions, we index +-- 'SEXP's by 'SEXPTYPE', which classifies the /form/ of a 'SEXP' (see +-- "Foreign.R.Type"). A function accepting 'SEXP' arguments of any type should +-- leave the type index uninstantiated. A function returning a 'SEXP' result of +-- unknown type should use 'SomeSEXP'. (More precisely, unknown types in +-- /negative/ position should be /universally/ quantified and unknown types in +-- /positive/ position should be /existentially/ quantified). +-- +-- This module is intended to be imported qualified. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +#if __GLASGOW_HASKELL__ >= 710 +-- We don't use ticks in this module, because they confuse c2hs. +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} +#endif +module Foreign.R + ( module Foreign.R.Type + -- * Internal R structures + , SEXPTYPE(..) + , R.Logical(..) + , SEXP(..) + , SomeSEXP(..) + , Callback + , unSomeSEXP + -- * Casts and coercions + -- $cast-coerce + , cast + , asTypeOf + , unsafeCoerce + -- * Node creation + , allocSEXP + , allocList + , allocVector + , allocVectorProtected + , install + , mkString + , mkChar + , CEType(..) + , mkCharCE + , mkWeakRef + -- * Node attributes + , typeOf + , setAttribute + , getAttribute + -- * Node accessor functions + -- ** Lists + , cons + , car + , cdr + , tag + , setCar + , setCdr + , setTag + -- ** Environments + , envFrame + , envEnclosing + , envHashtab + -- ** Closures + , closureFormals + , closureBody + , closureEnv + -- ** Promises + , promiseCode + , promiseEnv + , promiseValue + -- ** Symbols + , symbolPrintName + , symbolValue + , symbolInternal + -- ** Vectors + , length + , trueLength + , char + , real + , integer + , logical + , complex + , raw + , string + , unsafeSEXPToVectorPtr + , unsafeVectorPtrToSEXP + , indexVector + , writeVector + -- * Evaluation + , eval + , tryEval + , tryEvalSilent + , lang1 + , lang2 + , lang3 + , findFun + , findVar + -- * GC functions + , protect + , unprotect + , unprotectPtr + , preserveObject + , releaseObject + , gc + -- * Globals + , isRInteractive + , nilValue + , unboundValue + , missingArg + , baseEnv + , emptyEnv + , globalEnv + -- * Communication with runtime + , printValue + -- * Low level info header access + , SEXPInfo(..) + , peekInfo + , pokeInfo + , mark + , named + -- * Internal types and functions + -- + -- | Should not be used in user code. These exports are only needed for + -- binding generation tools. + , SEXPREC + , SEXP0 + , sexp + , unsexp + , release + , unsafeRelease + , withProtected + ) where + +import Control.Memory.Region +import {-# SOURCE #-} Language.R.HExp (HExp) +import qualified Foreign.R.Type as R +import Foreign.R.Type (SEXPTYPE, SSEXPTYPE) + +import Control.Applicative +import Control.Monad.Primitive ( unsafeInlineIO ) +import Control.Exception (bracket) +import Data.Bits +import Data.Complex +import Data.Int (Int32) +import Data.Singletons (fromSing) +import Control.DeepSeq (NFData(..)) +import Foreign (Ptr, castPtr, plusPtr, Storable(..)) +#ifdef H_ARCH_WINDOWS +import Foreign (nullPtr) +#endif +import Foreign.C +import Prelude hiding (asTypeOf, length) + +#define USE_RINTERNALS +#include "Hcompat.h" +#include +#include +#include +#include "missing_r.h" + +-- XXX temp workaround due to R bug: doesn't export R_CHAR when USE_RINTERNALS +-- is defined. +#c +const char *(R_CHAR)(SEXP x); +#endc + +-------------------------------------------------------------------------------- +-- R data structures -- +-------------------------------------------------------------------------------- + +data SEXPREC + +-- | The basic type of all R expressions, classified by the form of the +-- expression, and the memory region in which it has been allocated. +newtype SEXP s (a :: SEXPTYPE) = SEXP { unSEXP :: Ptr (HExp s a) } + deriving (Eq, Storable) + +instance Show (SEXP s a) where + show (SEXP ptr) = show ptr + +instance NFData (SEXP s a) where + rnf = (`seq` ()) + +-- | 'SEXP' with no type index. This type and 'sexp' / 'unsexp' +-- are purely an artifact of c2hs (which doesn't support indexing a Ptr with an +-- arbitrary type in a @#pointer@ hook). +{#pointer SEXP as SEXP0 -> SEXPREC #} + +-- | Add a type index to the pointer. +sexp :: SEXP0 -> SEXP s a +sexp = SEXP . castPtr + +-- | Remove the type index from the pointer. +unsexp :: SEXP s a -> SEXP0 +unsexp = castPtr . unSEXP + +-- | Like 'sexp' but for 'SomeSEXP'. +somesexp :: SEXP0 -> SomeSEXP s +somesexp = SomeSEXP . sexp + +-- | Release object into another region. Releasing is safe so long as the target +-- region is "smaller" than the source region, in the sense of +-- '(Control.Memory.Region.<=)'. +release :: (t <= s) => SEXP s a -> SEXP t a +release = unsafeRelease + +unsafeRelease :: SEXP s a -> SEXP r a +unsafeRelease = sexp . unsexp + +-- | A 'SEXP' of unknown form. +data SomeSEXP s = forall a. SomeSEXP {-# UNPACK #-} !(SEXP s a) + +instance Show (SomeSEXP s) where + show s = unSomeSEXP s show + +instance Storable (SomeSEXP s) where + sizeOf _ = sizeOf (undefined :: SEXP s a) + alignment _ = alignment (undefined :: SEXP s a) + peek ptr = SomeSEXP <$> peek (castPtr ptr) + poke ptr (SomeSEXP s) = poke (castPtr ptr) s + +instance NFData (SomeSEXP s) where + rnf = (`seq` ()) + +-- | Deconstruct a 'SomeSEXP'. Takes a continuation since otherwise the +-- existentially quantified variable hidden inside 'SomeSEXP' would escape. +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 + +cUIntToEnum :: Enum a => CUInt -> a +cUIntToEnum = toEnum . cIntConv + +cUIntFromSingEnum :: SSEXPTYPE a -> CUInt +cUIntFromSingEnum = cIntConv . fromEnum . fromSing + +cIntFromEnum :: Enum a => a -> CInt +cIntFromEnum = cIntConv . fromEnum + +-------------------------------------------------------------------------------- +-- Generic accessor functions -- +-------------------------------------------------------------------------------- + +-- | Return the \"type\" tag (aka the form tag) of the given 'SEXP'. This +-- function is pure because the type of an object does not normally change over +-- the lifetime of the object. +typeOf :: SEXP s a -> SEXPTYPE +typeOf s = unsafeInlineIO $ cUIntToEnum <$> {#get SEXP->sxpinfo.type #} (unsexp s) + +-- | read CAR object value +{#fun CAR as car { unsexp `SEXP s a' } -> `SomeSEXP s' somesexp #} + +-- | read CDR object +{#fun CDR as cdr { unsexp `SEXP s a' } -> `SomeSEXP s' somesexp #} + +-- | read object`s Tag +{# fun TAG as tag { unsexp `SEXP s a' } -> `SomeSEXP s' somesexp #} --- XXX: add better constraint + +-- | Set CAR field of object, when object is viewed as a cons cell. +setCar :: SEXP s a -> SEXP s b -> IO () +setCar s s' = {#set SEXP->u.listsxp.carval #} (unsexp s) (castPtr $ unsexp s') + +-- | Set CDR field of object, when object is viewed as a cons cell. +setCdr :: SEXP s a -> SEXP s b -> IO () +setCdr s s' = {#set SEXP->u.listsxp.cdrval #} (unsexp s) (castPtr $ unsexp s') + +-- | Set TAG field of object, when object is viewed as a cons cell. +setTag :: SEXP s a -> SEXP s b -> IO () +setTag s s' = {#set SEXP->u.listsxp.tagval #} (unsexp s) (castPtr $ unsexp s') + +-------------------------------------------------------------------------------- +-- Coercion functions -- +-------------------------------------------------------------------------------- + +-- $cast-coerce +-- +-- /Coercions/ have no runtime cost, but are completely unsafe. Use with +-- caution, only when you know that a 'SEXP' is of the target type. /Casts/ are +-- safer, but introduce a runtime type check. The difference between the two is +-- akin to the difference between a C-style typecasts and C++-style +-- @dynamic_cast@'s. + +unsafeCast :: SEXPTYPE -> SomeSEXP s -> SEXP s b +unsafeCast ty (SomeSEXP s) + | ty == typeOf s = unsafeCoerce s + | otherwise = + error $ "cast: Dynamic type cast failed. Expected: " ++ show ty ++ + ". Actual: " ++ show (typeOf s) ++ "." + +-- | Cast the type of a 'SEXP' into another type. This function is partial: at +-- runtime, an error is raised if the source form tag does not match the target +-- form tag. +cast :: SSEXPTYPE a -> SomeSEXP s -> SEXP s a +cast ty s = unsafeCast (fromSing ty) s + +-- | Cast form of first argument to that of the second argument. +asTypeOf :: SomeSEXP s -> SEXP s a -> SEXP s a +asTypeOf s s' = typeOf s' `unsafeCast` s + +-- | Unsafe coercion from one form to another. This is unsafe, in the sense that +-- using this function improperly could cause code to crash in unpredictable +-- ways. Contrary to 'cast', it has no runtime cost since it does not introduce +-- any dynamic check at runtime. +unsafeCoerce :: SEXP s a -> SEXP s b +unsafeCoerce = sexp . castPtr . unsexp + +-------------------------------------------------------------------------------- +-- Environment functions -- +-------------------------------------------------------------------------------- + +-- | Environment frame. +{# fun FRAME as envFrame { unsexp `SEXP s R.Env' } -> `SEXP s R.PairList' sexp #} + +-- | Enclosing environment. +{# fun ENCLOS as envEnclosing { unsexp `SEXP s R.Env' } -> `SEXP s R.Env' sexp #} + +-- | Hash table associated with the environment, used for faster name lookups. +{# fun HASHTAB as envHashtab { unsexp `SEXP s R.Env' } -> `SEXP s R.Vector' sexp #} + +-------------------------------------------------------------------------------- +-- Closure functions -- +-------------------------------------------------------------------------------- + +-- | Closure formals (aka the actual arguments). +{# fun FORMALS as closureFormals { unsexp `SEXP s R.Closure' } -> `SEXP s R.PairList' sexp #} + +-- | The code of the closure. +{# fun BODY as closureBody { unsexp `SEXP s R.Closure' } -> `SomeSEXP s' somesexp #} + +-- | The environment of the closure. +{# fun CLOENV as closureEnv { unsexp `SEXP s R.Closure' } -> `SEXP s R.Env' sexp #} + +-------------------------------------------------------------------------------- +-- Promise functions -- +-------------------------------------------------------------------------------- + +-- | The code of a promise. +{# fun PRCODE as promiseCode { unsexp `SEXP s R.Promise'} -> `SomeSEXP s' somesexp #} + +-- | The environment in which to evaluate the promise. +{# fun PRENV as promiseEnv { unsexp `SEXP s R.Promise'} -> `SEXP s R.Env' sexp #} + +-- | The value of the promise, if it has already been forced. +{# fun PRVALUE as promiseValue { unsexp `SEXP s R.Promise'} -> `SomeSEXP s' somesexp #} + +-------------------------------------------------------------------------------- +-- Vector accessor functions -- +-------------------------------------------------------------------------------- + +-- | Length of the vector. +length :: R.IsVector a => SEXP s a -> IO Int +length s = fromIntegral <$> {#get VECSEXP->vecsxp.length #} (unsexp s) + +-- | Read True Length vector field. +{#fun TRUELENGTH as trueLength `R.IsVector a' => { unsexp `SEXP s a' } -> `CInt' id #} + +-- | Read character vector data +{#fun R_CHAR as char { unsexp `SEXP s R.Char' } -> `CString' id #} +-- XXX: check if we really need Word8 here, maybe some better handling of +-- encoding + +-- | Read real vector data. +{#fun REAL as real { unsexp `SEXP s R.Real' } -> `Ptr Double' castPtr #} + +-- | Read integer vector data. +{#fun unsafe INTEGER as integer { unsexp `SEXP s R.Int' } -> `Ptr Int32' castPtr #} + +-- | Read raw data. +{#fun RAW as raw { unsexp `SEXP s R.Raw' } -> `Ptr CChar' castPtr #} + +-- XXX Workaround c2hs syntax limitations. +type Logical = 'R.Logical + +-- | Read logical vector data. +{#fun LOGICAL as logical { unsexp `SEXP s Logical' } -> `Ptr R.Logical' castPtr #} + +-- | Read complex vector data. +{#fun COMPLEX as complex { unsexp `SEXP s R.Complex' } + -> `Ptr (Complex Double)' castPtr #} + +-- | Read string vector data. +{#fun STRING_PTR as string { unsexp `SEXP s R.String'} + -> `Ptr (SEXP s R.Char)' castPtr #} + +-- | Extract the data pointer from a vector. +unsafeSEXPToVectorPtr :: SEXP s a -> Ptr () +unsafeSEXPToVectorPtr s = (unsexp s) `plusPtr` {#sizeof SEXPREC_ALIGN #} + +-- | Inverse of 'vectorPtr'. +unsafeVectorPtrToSEXP :: Ptr a -> SomeSEXP s +unsafeVectorPtrToSEXP s = SomeSEXP $ sexp $ s `plusPtr` (-{#sizeof SEXPREC_ALIGN #}) + +{# fun VECTOR_ELT as indexVector `R.IsGenericVector a' + => { unsexp `SEXP s a', `Int' } + -> `SomeSEXP s' somesexp #} + +{# fun SET_VECTOR_ELT as writeVector `R.IsGenericVector a' + => { unsexp `SEXP s a', `Int', unsexp `SEXP s b' } + -> `SEXP s a' sexp #} + +-------------------------------------------------------------------------------- +-- Symbol accessor functions -- +-------------------------------------------------------------------------------- + +-- | Read a name from symbol. +{#fun PRINTNAME as symbolPrintName { unsexp `SEXP s R.Symbol' } -> `SEXP s R.Char' sexp #} + +-- | Read value from symbol. +{#fun SYMVALUE as symbolValue { unsexp `SEXP s R.Symbol' } -> `SEXP s a' sexp #} + +-- | Read internal value from symbol. +{#fun INTERNAL as symbolInternal { unsexp `SEXP s R.Symbol' } -> `SEXP s a' sexp #} + +-------------------------------------------------------------------------------- +-- Value conversion -- +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- Value contruction -- +-------------------------------------------------------------------------------- + +-- | Initialize a new string vector. +{#fun Rf_mkString as mkString { id `CString' } -> `SEXP V R.String' sexp #} + +-- | Initialize a new character vector (aka a string). +{#fun Rf_mkChar as mkChar { id `CString' } -> `SEXP V R.Char' sexp #} + +-- | Create Character value with specified encoding +{#fun Rf_mkCharCE as mkCharCE_ { id `CString', cIntFromEnum `CEType' } -> `SEXP V R.Char' sexp #} + +mkCharCE :: CEType -> CString -> IO (SEXP V R.Char) +mkCharCE = flip mkCharCE_ + +-- | Intern a string @name@ into the symbol table. +-- +-- If @name@ is not found, it is added to the symbol table. The symbol +-- corresponding to the string @name@ is returned. +{#fun Rf_install as install { id `CString' } -> `SEXP V R.Symbol' sexp #} + +-- | Allocate a 'SEXP'. +{#fun Rf_allocSExp as allocSEXP { cUIntFromSingEnum `SSEXPTYPE a' } + -> `SEXP V a' sexp #} + +-- | Allocate a pairlist of 'SEXP's, chained together. +{#fun Rf_allocList as allocList { `Int' } -> `SEXP V R.List' sexp #} + +-- | Allocate Vector. +{#fun Rf_allocVector as allocVector `R.IsVector a' + => { cUIntFromSingEnum `SSEXPTYPE a',`Int' } + -> `SEXP V a' sexp #} + +allocVectorProtected :: (R.IsVector a) => SSEXPTYPE a -> Int -> IO (SEXP s a) +allocVectorProtected ty n = fmap release (protect =<< allocVector ty n) + +-- | 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 #} + +-- | Print a string representation of a 'SEXP' on the console. +{#fun Rf_PrintValue as printValue { unsexp `SEXP s a'} -> `()' #} + +-------------------------------------------------------------------------------- +-- Garbage collection -- +-------------------------------------------------------------------------------- + +-- | Protect a 'SEXP' from being garbage collected by R. It is in particular +-- necessary to do so for objects that are not yet pointed by any other object, +-- e.g. when constructing a tree bottom-up rather than top-down. +-- +-- To avoid unbalancing calls to 'protect' and 'unprotect', do not use these +-- functions directly but use 'Language.R.withProtected' instead. +{#fun Rf_protect as protect { unsexp `SEXP s a'} -> `SEXP G a' sexp #} + +-- | @unprotect n@ unprotects the last @n@ objects that were protected. +{#fun Rf_unprotect as unprotect { `Int' } -> `()' #} + +-- | Unprotect a specific object, referred to by pointer. +{#fun Rf_unprotect_ptr as unprotectPtr { unsexp `SEXP G a' } -> `()' #} + +-- | Invoke an R garbage collector sweep. +{#fun R_gc as gc { } -> `()' #} + +-- | Preserve an object accross GCs. +{#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' } -> `()' #} + +-------------------------------------------------------------------------------- +-- Evaluation -- +-------------------------------------------------------------------------------- + +-- | Evaluate any 'SEXP' to its value. +{#fun Rf_eval as eval { unsexp `SEXP s a', unsexp `SEXP s R.Env' } + -> `SomeSEXP V' somesexp #} + +-- | Try to evaluate expression. +{#fun R_tryEval as tryEval { unsexp `SEXP s a', unsexp `SEXP s R.Env', id `Ptr CInt'} + -> `SomeSEXP V' somesexp #} + +-- | Try to evaluate without printing error/warning messages to stdout. +{#fun R_tryEvalSilent as tryEvalSilent + { unsexp `SEXP s a', unsexp `SEXP s R.Env', id `Ptr CInt'} + -> `SomeSEXP V' somesexp #} + +-- | Construct a nullary function call. +{#fun Rf_lang1 as lang1 { unsexp `SEXP s a'} -> `SEXP V R.Lang' sexp #} + +-- | Construct unary function call. +{#fun Rf_lang2 as lang2 { unsexp `SEXP s a', unsexp `SEXP s b'} -> `SEXP V R.Lang' sexp #} + +-- | Construct a binary function call. +{#fun Rf_lang3 as lang3 { unsexp `SEXP s a', unsexp `SEXP s b', unsexp `SEXP s c'} + -> `SEXP V R.Lang' sexp #} + +-- | Find a function by name. +{#fun Rf_findFun as findFun { unsexp `SEXP s a', unsexp `SEXP s R.Env'} + -> `SomeSEXP s' somesexp #} + +-- | Find a variable by name. +{#fun Rf_findVar as findVar { unsexp `SEXP s a', unsexp `SEXP s R.Env'} + -> `SEXP s R.Symbol' sexp #} + +{#fun R_MakeWeakRef as mkWeakRef { unsexp `SEXP s a', unsexp `SEXP s b', unsexp `SEXP s c', cIntFromEnum `Bool' } + -> `SEXP V R.WeakRef' sexp #} + +-------------------------------------------------------------------------------- +-- Global variables -- +-------------------------------------------------------------------------------- + +foreign import ccall "&R_Interactive" isRInteractive :: Ptr CInt + +-- | Global nil value. Constant throughout the lifetime of the R instance. +foreign import ccall "&R_NilValue" nilValue :: Ptr (SEXP G R.Nil) + +-- | Unbound marker. Constant throughout the lifetime of the R instance. +foreign import ccall "&R_UnboundValue" unboundValue :: Ptr (SEXP G R.Symbol) + +-- | Missing argument marker. Constant throughout the lifetime of the R instance. +foreign import ccall "&R_MissingArg" missingArg :: Ptr (SEXP G R.Symbol) + +-- | The base environment. +foreign import ccall "&R_BaseEnv" baseEnv :: Ptr (SEXP G R.Env) + +-- | The empty environment. +foreign import ccall "&R_EmptyEnv" emptyEnv :: Ptr (SEXP G R.Env) + +-- | Global environment. +foreign import ccall "&R_GlobalEnv" globalEnv :: Ptr (SEXP G R.Env) + +---------------------------------------------------------------------------------- +-- Structure header -- +---------------------------------------------------------------------------------- + +-- | Info header for the SEXP data structure. +data SEXPInfo = SEXPInfo + { infoType :: SEXPTYPE -- ^ Type of the SEXP. + , infoObj :: Bool -- ^ Is this an object with a class attribute. + , infoNamed :: Int -- ^ Control copying information. + , infoGp :: Int -- ^ General purpose data. + , infoMark :: Bool -- ^ Mark object as 'in use' in GC. + , infoDebug :: Bool -- ^ Debug marker. + , infoTrace :: Bool -- ^ Trace marker. + , infoSpare :: Bool -- ^ Alignment (not in use). + , infoGcGen :: Int -- ^ GC Generation. + , infoGcCls :: Int -- ^ GC Class of node. + } deriving ( Show ) + +-- | Extract the header from the given 'SEXP'. +peekInfo :: SEXP s a -> IO SEXPInfo +peekInfo ts = + SEXPInfo + <$> (toEnum.fromIntegral <$> {#get SEXP->sxpinfo.type #} s) + <*> ((/=0) <$> {#get SEXP->sxpinfo.obj #} s) + <*> (fromIntegral <$> {#get SEXP->sxpinfo.named #} s) + <*> (fromIntegral <$> {#get SEXP->sxpinfo.gp #} s) + <*> ((/=0) <$> {#get SEXP->sxpinfo.mark #} s) + <*> ((/=0) <$> {#get SEXP->sxpinfo.debug #} s) + <*> ((/=0) <$> {#get SEXP->sxpinfo.trace #} s) + <*> ((/=0) <$> {#get SEXP->sxpinfo.spare #} s) + <*> (fromIntegral <$> {#get SEXP->sxpinfo.gcgen #} s) + <*> (fromIntegral <$> {#get SEXP->sxpinfo.gccls #} s) + where + s = unsexp ts + +-- | Write a new header. +pokeInfo :: SEXP s a -> SEXPInfo -> IO () +pokeInfo (unsexp -> s) i = do + {#set SEXP->sxpinfo.type #} s (fromIntegral.fromEnum $ infoType i) + {#set SEXP->sxpinfo.obj #} s (if infoObj i then 1 else 0) + {#set SEXP->sxpinfo.named #} s (fromIntegral $ infoNamed i) + {#set SEXP->sxpinfo.gp #} s (fromIntegral $ infoGp i) + {#set SEXP->sxpinfo.mark #} s (if infoMark i then 1 else 0) + {#set SEXP->sxpinfo.debug #} s (if infoDebug i then 1 else 0) + {#set SEXP->sxpinfo.trace #} s (if infoTrace i then 1 else 0) + {#set SEXP->sxpinfo.spare #} s (if infoSpare i then 1 else 0) + {#set SEXP->sxpinfo.gcgen #} s (fromIntegral $ infoGcGen i) + {#set SEXP->sxpinfo.gccls #} s (fromIntegral $ infoGcCls i) + +-- | Set the GC mark. +mark :: Bool -> SEXP s a -> IO () +mark b ts = {#set SEXP->sxpinfo.mark #} (unsexp ts) (if b then 1 else 0) + +named :: Int -> SEXP s a -> IO () +named v ts = {#set SEXP->sxpinfo.named #} (unsexp ts) (fromIntegral v) + +------------------------------------------------------------------------------- +-- Attribute header -- +------------------------------------------------------------------------------- + +-- | Get the attribute list from the given object. +getAttribute :: SEXP s a -> IO (SEXP s b) +getAttribute s = sexp . castPtr <$> ({#get SEXP->attrib #} (unsexp s)) + +-- | Set the attribute list. +setAttribute :: SEXP s a -> SEXP s b -> IO () +setAttribute s v = {#set SEXP->attrib #} (unsexp s) (castPtr $ unsexp v) + +------------------------------------------------------------------------------- +-- Encoding -- +------------------------------------------------------------------------------- + +-- | Content encoding. +{#enum cetype_t as CEType {} deriving (Eq, Show) #} + +-- | Perform an action with resource while protecting it from the garbage +-- collection. This function is a safer alternative to 'R.protect' and +-- 'R.unprotect', guaranteeing that a protected resource gets unprotected +-- irrespective of the control flow, much like 'Control.Exception.bracket_'. +withProtected :: IO (SEXP V a) -- Action to acquire resource + -> (SEXP s a -> IO b) -- Action + -> IO b +withProtected create f = + bracket + (do { x <- create; _ <- protect x; return x }) + (const $ unprotect 1) + (f . unsafeRelease) diff --git a/src/Foreign/R/Constraints.hs b/src/Foreign/R/Constraints.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/R/Constraints.hs @@ -0,0 +1,28 @@ +-- | +-- Copyright: (C) 2013 Amgen, Inc. +-- +-- R-specific predicates for encoding form constraints in type signatures. There +-- are no actual bindings in this module. + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Foreign.R.Constraints where + +import GHC.Exts (Constraint) +import {-# SOURCE #-} Foreign.R.Type (SEXPTYPE(..)) + +infix 1 :∈ + +-- | The predicate @a :∈ as@ states that @a@ is a member type of the set @as@. +type family (a :: SEXPTYPE) :∈ (as :: [SEXPTYPE]) :: Constraint where + 'Any :∈ as = () + a :∈ (a ': as) = () + a :∈ (b ': as) = a :∈ as + +-- | Class alias used for c2hs @fun@ hooks, since it currently does not like +-- Unicode operators. +type In a b = a :∈ b diff --git a/src/Foreign/R/Embedded.chs b/src/Foreign/R/Embedded.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/R/Embedded.chs @@ -0,0 +1,27 @@ +-- | +-- Copyright: (C) 2013 Amgen, Inc. +-- +-- Bindings for @@, containing entry points for running an +-- instance of R embedded within another program. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +module Foreign.R.Embedded + ( initEmbeddedR + , endEmbeddedR + ) where + +import Foreign +import Foreign.C + +#include "Hcompat.h" +#include +#include "missing_r.h" + +-- | Initialize R. +{# fun Rf_initEmbeddedR as initEmbeddedR { `Int', castPtr `Ptr CString' } -> `()' #} + +-- | Finalize R. +{# fun Rf_endEmbeddedR as endEmbeddedR { `Int' } -> `()' #} diff --git a/src/Foreign/R/Error.chs b/src/Foreign/R/Error.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/R/Error.chs @@ -0,0 +1,21 @@ +-- | +-- Copyright: (C) 2013 Amgen, Inc. +-- +-- Exception type wrapping errors thrown by the R runtime. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Foreign.R.Error + ( RError(..) + ) where + +import Control.Exception +import Data.Typeable + +data RError = RError String + deriving ( Typeable ) + +instance Show RError where + show (RError s) = "R Runtime Error: " ++ s + +instance Exception RError diff --git a/src/Foreign/R/EventLoop.chs b/src/Foreign/R/EventLoop.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/R/EventLoop.chs @@ -0,0 +1,129 @@ +-- | +-- Copyright: (C) 2015 Tweag I/O Limited. +-- +-- Bindings for @@, for building event loops. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} + +module Foreign.R.EventLoop + ( InputHandler(..) + , inputHandlers + , polledEvents + , pollingPeriod + , graphicsPolledEvents + , graphicsPollingPeriod + , checkActivity + , runHandlers + , addInputHandler + , removeInputHandler + ) where + +import Control.Applicative +import Foreign (FunPtr, Ptr, Storable(..), castPtr) +import Foreign.C +import Foreign.Marshal.Utils (with) +import System.Posix.Types (Fd(..)) +import Prelude -- Silence AMP warning. + +#include + +-- | R input handler chain. Each input handler points to the next. This view of +-- input handlers is /shallow/, in the sense that the 'Storable' instance only +-- unmarshalls the first element in the chain at any one time. A shallow view +-- allows 'peek' and 'poke' to be inlinable. +data InputHandler = InputHandler + { -- | The input handler callback. + inputHandlerCallback :: FunPtr (Ptr () -> IO ()) + -- | Undocumented and currently unused. + , inputHandlerActivity :: CInt + -- | Whether this input handler is activated or deactivated. + , inputHandlerActive :: CInt + -- | The file descriptor ahssociated with this handler. + , inputHandlerFD :: Fd + -- | Callbacks can optionally be passed in arbitrary data. + , inputHandlerUserData :: Ptr () + -- | The next input handler in the chain. + , inputHandlerNext :: Ptr InputHandler + } deriving (Eq, Show) +{#pointer *InputHandler as InputHandler nocode#} + +instance Storable InputHandler where + sizeOf _ = {#sizeof InputHandler#} + alignment _ = {#alignof InputHandler#} + peek hptr = InputHandler <$> + {#get InputHandler->handler#} hptr <*> + {#get InputHandler->activity#} hptr <*> + {#get InputHandler->active#} hptr <*> + (Fd <$> {#get InputHandler->fileDescriptor#} hptr) <*> + {#get InputHandler->userData#} hptr <*> + (castPtr <$> {#get InputHandler->next#} hptr) + poke hptr InputHandler{..} = do + {#set InputHandler->handler#} hptr inputHandlerCallback + {#set InputHandler->activity#} hptr inputHandlerActivity + {#set InputHandler->active#} hptr inputHandlerActive + {#set InputHandler->fileDescriptor#} hptr (case inputHandlerFD of Fd fd -> fd) + {#set InputHandler->userData#} hptr inputHandlerUserData + {#set InputHandler->next#} hptr (castPtr inputHandlerNext) + +-- | @R_PolledEvents@ global variable. +foreign import ccall "&R_PolledEvents" polledEvents :: Ptr (FunPtr (IO ())) + +-- | @R_wait_usec@ global variable. +foreign import ccall "&R_wait_usec" pollingPeriod :: Ptr CInt + +-- | @R_PolledEvents@ global variable. +foreign import ccall "&Rg_PolledEvents" graphicsPolledEvents :: Ptr (FunPtr (IO ())) + +-- | @R_wait_usec@ global variable. +foreign import ccall "&Rg_wait_usec" graphicsPollingPeriod :: Ptr CInt + +-- | Input handlers used in event loops. +foreign import ccall "&R_InputHandlers" inputHandlers :: Ptr (Ptr InputHandler) + +data FdSet + +foreign import ccall unsafe "R_checkActivity" checkActivity + :: CInt + -> CInt + -> IO (Ptr FdSet) + +foreign import ccall "R_runHandlers" runHandlers + :: Ptr InputHandler + -> Ptr FdSet + -> IO () + +foreign import ccall "addInputHandler" addInputHandler_ + :: Ptr InputHandler + -> Fd + -> FunPtr (Ptr () -> IO ()) + -> CInt + -> IO (Ptr InputHandler) + +-- | Create and register a new 'InputHandler'. The given file descriptor should +-- be open in non-blocking read mode. Make sure to dispose of the callback using +-- 'freeHaskellFunPtr' after calling 'removeInputHandler' where appropriate. +addInputHandler + :: Ptr InputHandler + -> Fd + -> FunPtr (Ptr () -> IO ()) + -> Int + -> IO (Ptr InputHandler) +addInputHandler ihptr fd f activity = do + addInputHandler_ ihptr fd f (fromIntegral activity) + +foreign import ccall "removeInputHandler" removeInputHandler_ + :: Ptr (Ptr InputHandler) + -> Ptr InputHandler + -> IO CInt + +-- | Remove an input handler from an input handler chain. Returns 'True' if the +-- handler was successfully removed, 'False' otherwise. +removeInputHandler :: Ptr InputHandler -> Ptr InputHandler -> IO Bool +removeInputHandler handlers ih = + with handlers $ \handlersptr -> do + rc <- removeInputHandler_ handlersptr ih + case rc of + 0 -> return $ False + 1 -> return $ True + _ -> error "removeInputHandler: unexpected result." diff --git a/src/Foreign/R/Parse.chs b/src/Foreign/R/Parse.chs new file mode 100644 --- /dev/null +++ b/src/Foreign/R/Parse.chs @@ -0,0 +1,47 @@ +-- | +-- Copyright: (C) 2013 Amgen, Inc. +-- +-- Bindings for @@. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ForeignFunctionInterface #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} +#endif + +#include "Hcompat.h" + +#include +#include +module Foreign.R.Parse + ( parseVector + , ParseStatus(..) + ) where + +import Foreign.R.Constraints +import qualified Foreign.R as R +-- XXX Duplicate import to make c2hs happy. The problem is that c2hs doesn't +-- like the "as R" of the above import. +{#import Foreign.R #} + +import Foreign +import Foreign.C + +-- | The return code of a call to 'parseVector', indicating whether the parser +-- failed or succeeded. +{#enum ParseStatus {} deriving (Eq, Show) #} + +-- | @parseVector text num status source@ parses the input string into an AST. +-- @source@, if provided, names the origin of @text@ (e.g. a filename). @num@ +-- limits the number of expressions to parse, or @-1@ if no limit. + +-- TODO: use ParseStatus or write a wrapper for parseVector. +{#fun R_ParseVector as parseVector + `(In a [R.Nil, R.String])' + => { unsexp `SEXP s (R.String)' + , `Int' + , id `Ptr CInt' + , unsexp `SEXP s a' } + -> `SEXP s (R.Expr)' sexp #} diff --git a/src/Foreign/R/Type.hs-boot b/src/Foreign/R/Type.hs-boot new file mode 100644 --- /dev/null +++ b/src/Foreign/R/Type.hs-boot @@ -0,0 +1,30 @@ +module Foreign.R.Type where + +data SEXPTYPE + = Nil + | Symbol + | List + | Closure + | Env + | Promise + | Lang + | Special + | Builtin + | Char + | Logical + | Int + | Real + | Complex + | String + | DotDotDot + | Any + | Vector + | Expr + | Bytecode + | ExtPtr + | WeakRef + | Raw + | S4 + | New + | Free + | Fun diff --git a/src/Foreign/R/Type.hsc b/src/Foreign/R/Type.hsc new file mode 100644 --- /dev/null +++ b/src/Foreign/R/Type.hsc @@ -0,0 +1,212 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} +#endif + + +-- | +-- Copyright: (C) 2013 Amgen, Inc. +-- +-- Definition of 'SEXPTYPE', which classifies the possible forms of an +-- R expression (a 'SEXP'). It is normally not necessary to import this module +-- directly, since it is reexported by "Foreign.R". +-- +-- This is done in a separate module because we want to use hsc2hs rather than +-- c2hs for discharging the boilerplate around 'SEXPTYPE'. This is because +-- 'SEXPTYPE' is nearly but not quite a true enumeration and c2hs has trouble +-- dealing with that. +-- +-- This module also defines a singleton version of 'SEXPTYPE', called +-- 'SSEXPTYPE'. This is actually a family of types, one for each possible +-- 'SEXPTYPE'. Singleton types are a way of emulating dependent types in +-- a language that does not have true dependent type. They are useful in +-- functions whose result type depends on the value of one of its arguments. See +-- e.g. 'Foreign.R.allocVector'. + +module Foreign.R.Type where + +#include + +import Foreign.R.Constraints +import Internal.Error + +import qualified Language.Haskell.TH.Syntax as Hs +import qualified Language.Haskell.TH.Lib as Hs + +import Data.Singletons.TH + +import Control.DeepSeq (NFData(..)) +import Foreign (castPtr) +import Foreign.C (CInt) +import Foreign.Storable(Storable(..)) +import Prelude hiding (Bool(..)) + +-- | R \"type\". Note that what R calls a \"type\" is not what is usually meant +-- by the term: there is really only a single type, called 'SEXP', and an +-- R "type" in fact refers to the /class/ or /form/ of the expression. +-- +-- To better illustrate the distinction, note that any sane type system normally +-- has the /subject reduction property/: that the type of an expression is +-- invariant under reduction. For example, @(\x -> x) 1@ has type 'Int', and so +-- does the value of this expression, @2@, have type 'Int'. Yet the /form/ of +-- the expression is an application of a function to a literal, while the form +-- of its reduct is an integer literal. +-- +-- We introduce convenient Haskell-like names for forms because this datatype is +-- used to index 'SEXP' and other types through the @DataKinds@ extension. +-- +data SEXPTYPE + = Nil + | Symbol + | List + | Closure + | Env + | Promise + | Lang + | Special + | Builtin + | Char + | Logical + | Int + | Real + | Complex + | String + | DotDotDot + | Any + | Vector + | Expr + | Bytecode + | ExtPtr + | WeakRef + | Raw + | S4 + | New + | Free + | Fun + deriving (Eq, Show) + +instance Enum SEXPTYPE where + fromEnum Nil = #const NILSXP + fromEnum Symbol = #const SYMSXP + fromEnum List = #const LISTSXP + fromEnum Closure = #const CLOSXP + fromEnum Env = #const ENVSXP + fromEnum Promise = #const PROMSXP + fromEnum Lang = #const LANGSXP + fromEnum Special = #const SPECIALSXP + fromEnum Builtin = #const BUILTINSXP + fromEnum Char = #const CHARSXP + fromEnum Logical = #const LGLSXP + fromEnum Int = #const INTSXP + fromEnum Real = #const REALSXP + fromEnum Complex = #const CPLXSXP + fromEnum String = #const STRSXP + fromEnum DotDotDot = #const DOTSXP + fromEnum Any = #const ANYSXP + fromEnum Vector = #const VECSXP + fromEnum Expr = #const EXPRSXP + fromEnum Bytecode = #const BCODESXP + fromEnum ExtPtr = #const EXTPTRSXP + fromEnum WeakRef = #const WEAKREFSXP + fromEnum Raw = #const RAWSXP + fromEnum S4 = #const S4SXP + fromEnum New = #const NEWSXP + fromEnum Free = #const FREESXP + fromEnum Fun = #const FUNSXP + + toEnum (#const NILSXP) = Nil + toEnum (#const SYMSXP) = Symbol + toEnum (#const LISTSXP) = List + toEnum (#const CLOSXP) = Closure + toEnum (#const ENVSXP) = Env + toEnum (#const PROMSXP) = Promise + toEnum (#const LANGSXP) = Lang + toEnum (#const SPECIALSXP) = Special + toEnum (#const BUILTINSXP) = Builtin + toEnum (#const CHARSXP) = Char + toEnum (#const LGLSXP) = Logical + toEnum (#const INTSXP) = Int + toEnum (#const REALSXP) = Real + toEnum (#const CPLXSXP) = Complex + toEnum (#const STRSXP) = String + toEnum (#const DOTSXP) = DotDotDot + toEnum (#const ANYSXP) = Any + toEnum (#const VECSXP) = Vector + toEnum (#const EXPRSXP) = Expr + toEnum (#const BCODESXP) = Bytecode + toEnum (#const EXTPTRSXP) = ExtPtr + toEnum (#const WEAKREFSXP) = WeakRef + toEnum (#const RAWSXP) = Raw + toEnum (#const S4SXP) = S4 + toEnum (#const NEWSXP) = New + toEnum (#const FREESXP) = Free + toEnum (#const FUNSXP) = Fun + toEnum _ = violation "toEnum" "Unknown R type." + +instance NFData SEXPTYPE where + rnf = (`seq` ()) + +genSingletons [''SEXPTYPE] + +instance Hs.Lift SEXPTYPE where + lift a = [| $(Hs.conE (Hs.mkName $ "Foreign.R.Type." ++ show a)) |] + +-- | R uses three-valued logic. +data Logical = False + | True + | NA +-- XXX no Enum instance because NA = INT_MIN, not representable as an Int on +-- 32-bit systems. + deriving (Eq, Show) + +instance Storable Logical where + sizeOf _ = sizeOf (undefined :: CInt) + alignment _ = alignment (undefined :: CInt) + poke ptr False = poke (castPtr ptr) (0 :: CInt) + poke ptr True = poke (castPtr ptr) (1 :: CInt) + -- Currently NA_LOGICAL = INT_MIN. + poke ptr NA = poke (castPtr ptr) (#{const INT_MIN} :: CInt) + peek ptr = do + x <- peek (castPtr ptr) + case x :: CInt of + 0 -> return False + 1 -> return True + #{const INT_MIN} -> return NA + _ -> failure "Storable Logical peek" "Not a Logical." + +-- | Used where the R documentation speaks of "pairlists", which are really just +-- regular lists. +type PairList = List + +-- Use a macro to avoid having to define append at the type level. +#let VECTOR_FORMS = " 'Char \ + ': 'Logical \ + ': 'Int \ + ': 'Real \ + ': 'Complex \ + ': 'String \ + ': 'Vector \ + ': 'Expr \ + ': 'WeakRef \ + ': 'Raw" + +-- | Constraint synonym grouping all vector forms into one class. @IsVector a@ +-- holds iff R's @is.vector()@ returns @TRUE@. +type IsVector (a :: SEXPTYPE) = (SingI a, a :∈ #{VECTOR_FORMS} ': '[]) + +-- | Non-atomic vector forms. See @src\/main\/memory.c:SET_VECTOR_ELT@ in the +-- R source distribution. +type IsGenericVector (a :: SEXPTYPE) = (SingI a, a :∈ [Vector, Expr, WeakRef]) + +-- | @IsList a@ holds iff R's @is.list()@ returns @TRUE@. +type IsList (a :: SEXPTYPE) = (SingI a, a :∈ #{VECTOR_FORMS} ': List ': '[]) + +-- | @IsPairList a@ holds iff R's @is.pairlist()@ returns @TRUE@. +type IsPairList (a :: SEXPTYPE) = (SingI a, a :∈ [List, Nil]) diff --git a/src/H/Prelude.hs b/src/H/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/H/Prelude.hs @@ -0,0 +1,81 @@ +-- | +-- Copyright: (C) 2013 Amgen, Inc. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# Language GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# Language ViewPatterns #-} + +module H.Prelude + ( module Language.R.Instance + , module Control.Monad.R.Class + , module Foreign.R.Error + -- * Language.R functions + , module Language.R + , module Language.R.Event + , module Language.R.Literal + -- * Globals + , module Language.R.Globals + , Show(..) + , show + ) where + +import Control.Memory.Region +import Control.Monad.R.Class +import qualified Foreign.R as R +import Foreign.R (SEXP, SomeSEXP(..)) +import Language.R.HExp +import Language.R.Internal (r1) +import qualified Data.Vector.SEXP as Vector + +-- Reexported modules. +import Language.R +import Language.R.Event (refresh) +import Language.R.Globals +import Language.R.Literal +import Language.R.Instance +import Foreign.R.Error + +import qualified Data.Text.Lazy.IO as Text +import qualified Data.Text as Text +import qualified Data.Text.Lazy as Text.Lazy +import Data.Text.Lazy (Text) + +import Control.Monad ((>=>)) +import Foreign.C (withCString) +import System.IO.Unsafe (unsafePerformIO) + +import Prelude hiding (Show(..), print) + +class Show a where + -- | Equivalent of R's @deparse()@. + showIO :: a -> IO Text + + -- | Make this a class method to allow matching R's @print()@ behaviour, whose + -- output is subtly different from @deparse()@. + print :: MonadR m => a -> m () + print = io . (showIO >=> Text.putStrLn) + +-- | Pure version of 'showIO'. +show :: Show a => a -> Text +show = unsafePerformIO . showIO + +instance Show (SEXP s a) where + showIO s = + withCString "quote" $ R.install >=> \quote -> + R.lang2 quote (R.release s) >>= r1 "deparse" >>= \(SomeSEXP slang) -> + return . + Text.Lazy.fromChunks . + map (Text.pack . Vector.toString . vector) . + Vector.toList . + vector $ + (R.unsafeCoerce (R.release slang) :: SEXP V 'R.String) + + print = io . R.printValue + +instance Show (R.SomeSEXP s) where + showIO s = R.unSomeSEXP s showIO + print s = R.unSomeSEXP s print diff --git a/src/H/Prelude/Interactive.hs b/src/H/Prelude/Interactive.hs new file mode 100644 --- /dev/null +++ b/src/H/Prelude/Interactive.hs @@ -0,0 +1,30 @@ +-- | +-- Copyright: (C) 2013 Amgen, Inc. +-- +-- This class is not meant to be imported in any other circumstance than in +-- a GHCi session. + +{-# OPTIONS_GHC -fno-warn-orphans #-} +module H.Prelude.Interactive + ( module H.Prelude + , p + , printQuote + ) + where + +import H.Prelude hiding (withEmbeddedR) +import qualified H.Prelude as H + +instance MonadR IO where + io = id + +-- | A form of the 'print' function that is more convenient in an +-- interactive session. +p :: (MonadR m, H.Show a) => m a -> m () +p = (>>= H.print) + +-- | A form of the 'print' function that that is more convenient in an +-- interactive session. +{-# DEPRECATED printQuote "Use 'p' instead." #-} +printQuote :: (MonadR m, H.Show a) => m a -> m () +printQuote = p diff --git a/src/Internal/Error.hs b/src/Internal/Error.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Error.hs @@ -0,0 +1,54 @@ +-- | +-- Copyright: (C) 2013 Amgen, Inc. +-- +-- Wrappers around 'error' that classify problems into whether these are bugs +-- internal to H, or whether they are due to a mistake by the user. +-- +-- This module should only be imported by H modules and not reexported. + +{-# LANGUAGE DeriveDataTypeable #-} + +module Internal.Error + ( failure + , violation + , impossible + , unimplemented + ) where + +import Control.Exception +import Data.Typeable + +data Violation = Violation String String deriving ( Typeable ) +data Failure = Failure String String deriving ( Typeable ) + +instance Show Failure where + show (Failure f m) = f ++ ":" ++ m + +instance Show Violation where + show (Violation f m) = "Bug in " ++ f ++ ", please report: " ++ m + +instance Exception Violation +instance Exception Failure + +-- | User error. +failure :: String -- ^ Function name + -> String -- ^ Error message + -> a +failure f msg = throw $ Failure f msg + +-- | An internal invariant has been violated. That's a bug. +violation :: String -- ^ Function name + -> String -- ^ Error message + -> a +violation f msg = throw $ Violation f msg + +-- | A violation that should have been made impossible by the type system was +-- not. +impossible :: String -- ^ Function name + -> a +impossible f = violation f "The impossible happened." + +-- | Feature not yet implemented. +unimplemented :: String + -> a +unimplemented f = failure f "Unimplemented." diff --git a/src/Language/R.hs b/src/Language/R.hs new file mode 100644 --- /dev/null +++ b/src/Language/R.hs @@ -0,0 +1,148 @@ +-- | +-- Copyright: 2013 (C) Amgen, Inc +-- +-- Wrappers for low-level R functions. + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# Language GADTs #-} +{-# Language ViewPatterns #-} + +module Language.R + ( parseFile + , parseText + , install + , string + , strings + , eval + , eval_ + , evalEnv + -- * R global constants + -- $ghci-bug + , module Language.R.Instance + -- * Exceptions + , throwR + , throwRMessage + -- * Memory management + , module Language.R.GC + ) where + +import Control.Memory.Region +import qualified Data.Vector.SEXP as Vector +import Control.Monad.R.Class +import Foreign.R (SEXP, SomeSEXP(..)) +import qualified Foreign.R as R +import qualified Foreign.R.Parse as R +import qualified Foreign.R.Error as R +import Language.R.GC +import Language.R.Globals +import Language.R.HExp +import Language.R.Instance +import {-# SOURCE #-} Language.R.Internal + +import Control.Applicative +import Control.Exception ( throwIO ) +import Control.Monad ( (>=>), when, unless, forM, void ) +import Data.ByteString as B +import Data.ByteString.Char8 as C8 ( pack, unpack ) +import Foreign + ( alloca + , castPtr + , peek + ) +import Data.Singletons (sing) +import Foreign.C.String ( withCString, peekCString ) +import Prelude + +-- NOTE: In this module, cannot use quasiquotations, since we are lower down in +-- the dependency hierarchy. + +-- | Parse and then evaluate expression. +parseEval :: ByteString -> IO (SomeSEXP V) +parseEval txt = useAsCString txt $ \ctxt -> + R.withProtected (R.mkString ctxt) $ \rtxt -> + alloca $ \status -> do + 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 + SomeSEXP expr <- peek $ castPtr $ R.unsafeSEXPToVectorPtr exprs + unsafeRToIO $ eval expr + +-- | Parse file and perform some actions on parsed file. +-- +-- This function uses continuation because this is an easy way to make +-- operations GC-safe. +-- +-- This function is not safe to use inside GHCi. +parseFile :: FilePath -> (SEXP s 'R.Expr -> IO a) -> IO a +parseFile fl f = do + withCString fl $ \cfl -> + R.withProtected (R.mkString cfl) $ \rfl -> + r1 (C8.pack "parse") rfl >>= \(R.SomeSEXP s) -> + return (R.unsafeCoerce s) `R.withProtected` f + +parseText :: String -- ^ Text to parse + -> Bool -- ^ Whether to annotate the + -- AST with source locations. + -> IO (R.SEXP V 'R.Expr) +parseText txt b = do + s <- parseEval $ C8.pack $ + "parse(text=" ++ show txt ++ ", keep.source=" ++ keep ++ ")" + return $ (sing :: R.SSEXPTYPE 'R.Expr) `R.cast` s + where + keep | b = "TRUE" + | otherwise = "FALSE" + +install :: MonadR m => String -> m (SEXP V 'R.Symbol) +install = io . installIO + +-- | Create an R character string from a Haskell string. +string :: String -> IO (SEXP V 'R.Char) +string str = withCString str R.mkChar + +-- | Create an R string vector from a Haskell string. +strings :: String -> IO (SEXP V 'R.String) +strings str = withCString str R.mkString + +-- | Evaluate an expression in the given environment. +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 + mapM_ (\(SomeSEXP s) -> void $ R.protect s) (Vector.toList v) + 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 + return z) + R.unprotect (Vector.length v) + return x +evalEnv x rho = acquireSome =<< do + io $ alloca $ \p -> do + v <- R.tryEvalSilent x rho p + e <- peek p + when (e /= 0) $ unsafeRToIO $ throwR rho + return v + +-- | Evaluate an expression in the global environment. +eval :: MonadR m => SEXP s a -> m (SomeSEXP (Region m)) +eval x = evalEnv x (R.release globalEnv) + +-- | Silent version of 'evalIO' function that discards it's result. +eval_ :: MonadR m => SEXP s a -> m () +eval_ = void . eval + +-- | Throw an R error as an exception. +throwR :: MonadR m => R.SEXP s 'R.Env -- ^ Environment in which to find error. + -> m a +throwR env = getErrorMessage env >>= io . throwIO . R.RError + +-- | Throw an R exception with specified message. +throwRMessage :: MonadR m => String -> m a +throwRMessage = io . throwIO . R.RError + +-- | 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) diff --git a/src/Language/R/Debug.hs b/src/Language/R/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Language/R/Debug.hs @@ -0,0 +1,140 @@ +-- | +-- Copyright: (C) 2013 Amgen, Inc. +-- +-- Debugging facilities, in particular to analyze the internal structure of +-- a 'SEXP' as structured JSON. +-- +-- This module is intended to be imported qualified. + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Language.R.Debug + ( inspect ) + where + +import qualified Data.Vector.SEXP as Vector +import qualified Foreign.R as R +import Foreign.R (SEXP, SomeSEXP(..), SEXPTYPE, SEXPInfo) +import Foreign.R.Type (IsVector) +import Foreign.Storable +import Language.R.Globals as H +import Language.R.HExp + +import Data.Complex +import System.IO.Unsafe ( unsafePerformIO ) + +import Data.Aeson as A +import qualified Data.Text as T +import qualified Data.Vector as V +import qualified Data.ByteString.Lazy.Char8 as LBS + +instance ToJSON SEXPTYPE where + toJSON = A.String . T.pack . show + +instance ToJSON SEXPInfo where + toJSON x = + object + [ "type" .= R.infoType x + , "obj" .= R.infoObj x + , "named" .= R.infoNamed x + , "gp" .= R.infoGp x + , "mark" .= R.infoMark x + , "debug" .= R.infoDebug x + , "trace" .= R.infoTrace x + , "spare" .= R.infoSpare x + , "gcgen" .= R.infoGcGen x + , "gccls" .= R.infoGcCls x + ] + +instance ToJSON a => ToJSON (Complex a) where + toJSON (x :+ y) = + object ["Re" .= x, "Im" .= y] + +instance ToJSON (SEXP s a) where + toJSON x = + object + [ "header" .= info + , "attributes" .= if R.unsexp x == R.unsexp attr then "loop" else toJSON attr + , tp .= go x + ] + where + vector :: (IsVector a, ToJSON (Vector.ElemRep s a), Storable (Vector.ElemRep s a)) + => Vector.Vector s a (Vector.ElemRep s a) -> V.Vector Value + vector = V.fromList . map toJSON . Vector.toList -- XXX: do not use lists + ub = R.unsexp H.unboundValue + nil = R.unsexp H.nilValue + miss = R.unsexp H.missingArg + info = unsafePerformIO $ R.peekInfo x + attr = unsafePerformIO $ R.getAttribute x + tp = T.pack . show $ R.infoType info + go :: SEXP s a -> Value + go y | R.unsexp y == ub = A.String "UnboundValue" + | R.unsexp y == nil = A.String "NilValue" + | R.unsexp y == miss = A.String "MissingArg" + go (hexp -> Nil) = A.String "NilValue" + go (hexp -> Lang i j) = + object [ "function" .= i + , "parameters" .= j + ] + go h@(hexp -> Symbol i j k) = + object [ "name" .= i + , "value" .= if R.unsexp j == R.unsexp h then "loop" else toJSON j + , "internal" .= k + ] + go (hexp -> Special i) = object ["index" .= i] + go (hexp -> Builtin i) = object ["index" .= i] + go (hexp -> Char v) = A.String (T.pack (Vector.toString v)) + go (hexp -> Int v) = A.Array (vector v) + go (hexp -> Real v) = A.Array (vector v) + go (hexp -> Complex v) = A.Array (vector v) + go (hexp -> Vector _ v) = A.Array (vector v) +-- String :: {-# UNPACK #-} !(Vector.Vector (SEXP (R.Vector Word8))) +-- -> HExp (R.Vector (SEXP (R.Vector Word8))) + go (hexp -> List i j k) = + object [ "value" .= i + , "next" .= j + , "tag" .= k + ] + go (hexp -> Env _ _ _) = A.String "Environment" + go (hexp -> Closure f b e) = + object [ "formals" .= f + , "body" .= b + , "environment" .= e + ] + go (hexp -> Promise vl ex en) = + object [ "value" .= vl + , "expr" .= ex + , "environment" .= en + ] + go (hexp -> DotDotDot v) = + object [ "promises" .= v] + go (hexp -> Expr _ v) = A.Array (vector v) + go (hexp -> Bytecode) = A.String "Bytecode" + go (hexp -> ExtPtr _ a b) = + object [ "ptr" .= A.String "" + , "second" .= a + , "symbol" .= b + ] + go (hexp -> WeakRef k v fn nxt) = + object [ "key" .= k + , "value" .= v + , "finalizer" .= fn + , "next" .= nxt + ] + go (hexp -> Raw _bs) = A.String "" + go (hexp -> S4 s) = + object [ "tagval" .= s ] + go _ = A.String "Unimplemented." + +instance ToJSON (SomeSEXP s) where + toJSON (R.SomeSEXP s) = toJSON s + +inspect :: SEXP s a -> String +inspect = LBS.unpack . A.encode diff --git a/src/Language/R/Event.hs b/src/Language/R/Event.hs new file mode 100644 --- /dev/null +++ b/src/Language/R/Event.hs @@ -0,0 +1,133 @@ +-- | +-- Copyright: (C) 2015 Tweag I/O Limited. +-- +-- Helper module for writing event loops that mesh with R events. +-- +-- Events in R are dispatched from a number of file descriptors. The R runtime +-- maintains a list of "input handlers", essentially a set of file descriptors +-- together with callbacks for each one, invoked whenever the file descriptor +-- becomes available for reading. This module exports functions for dispatching +-- on both R events and Haskell events simultaneously, using "GHC.Event", which +-- is based on epoll/kqueue/poll under the hood for efficient and scalable event +-- dispatching. +-- +-- Event dispatching and processing is in particular necessary for R's GUI to be +-- responsive. For a consistent user experience, you should arrange for all GUI +-- related events to be dispatched from a single thread, ideally the program's +-- main thread. In fact on some platforms, most notably OS X (darwin), you +-- /must/ use the main thread. +-- +-- Event loops can be constructed in one of two ways: +-- +-- 1. 'eventLoopPoll', which uses GHC's @poll(2)@ (and related syscalls) based +-- efficient and scalable mechanisms for event dispatch; +-- +-- 2. 'eventLoopSelect', which uses R's @select(2)@ based mechasism. +-- +-- __NOTE:__ in GHC 7.8 and 7.10, 'eventLoopPoll' is currently unusable, due to +-- a number of functions from the event API not being exported like they were +-- previously. + +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} + +module Language.R.Event + ( forIH + , forIH_ + , registerREvents + , eventLoopPoll + , eventLoopSelect + , refresh + ) where + +import Control.Applicative +import Control.Monad (forever) +import Control.Monad.R.Class +import Data.Maybe (catMaybes) +import qualified Foreign.R.EventLoop as R +import qualified GHC.Event as Event +import Language.R.Globals (inputHandlers) +import Foreign (FunPtr, Ptr, nullPtr, peek) +import Prelude -- Silence AMP warning. + +-- | Iterate over each input handler in a chain. +forIH :: Ptr R.InputHandler -> (R.InputHandler -> IO a) -> IO [a] +forIH ihptr f + | ihptr == nullPtr = return [] + | otherwise = do + ih <- peek ihptr + (:) <$> f ih <*> forIH (R.inputHandlerNext ih) f + +-- | Variant of 'forIH' that throws away the result. +forIH_ :: Ptr R.InputHandler -> (R.InputHandler -> IO ()) -> IO () +forIH_ ihptr f + | ihptr == nullPtr = return () + | otherwise = do + ih <- peek ihptr + f ih + forIH_ (R.inputHandlerNext ih) f + +foreign import ccall "dynamic" invokeIO :: FunPtr (IO ()) -> IO () +foreign import ccall "dynamic" invokeCallback :: FunPtr (Ptr () -> IO ()) -> Ptr () -> IO () + +-- | Register all R input handlers with the given event manager. Set an alarm to +-- process polled events if @R_wait_usec@ is non-zero. Returns keys useful for +-- unregistering input handlers. +registerREvents + :: MonadR m + => Event.EventManager + -> m ([Event.FdKey], Maybe Event.TimeoutKey) +registerREvents emgr = io $ do + tmgr <- Event.getSystemTimerManager + fdkeys <- forIH inputHandlers $ \R.InputHandler{..} -> do + let action _ _ = invokeCallback inputHandlerCallback inputHandlerUserData + case 0 < inputHandlerActive of + True -> +#if MIN_VERSION_base(4,8,1) + Just <$> Event.registerFd emgr action inputHandlerFD Event.evtRead Event.MultiShot +#elif MIN_VERSION_base(4,8,0) + fail "registerREvents not implementable in GHC 7.10.1. Use 7.10.2." +#else + Just <$> Event.registerFd emgr action inputHandlerFD Event.evtRead +#endif + False -> return Nothing + usecs <- peek R.pollingPeriod + gusecs <- peek R.graphicsPollingPeriod + let eusecs + | usecs == 0 && gusecs == 0 = 10000 + | usecs == 0 || gusecs == 0 = max usecs gusecs + | otherwise = min usecs gusecs + mbtkey <- case 0 < eusecs of + True -> do + let action = do + peek R.polledEvents >>= invokeIO + peek R.graphicsPolledEvents >>= invokeIO + Just <$> Event.registerTimeout tmgr (fromIntegral usecs) action + False -> return Nothing + return (catMaybes fdkeys, mbtkey) + +-- | Process events in a loop. Uses a new GHC event manager under the hood. This +-- function should be called from the main thread. It never returns. +-- +-- Currently unimplemented. +eventLoopPoll :: MonadR m => m () +eventLoopPoll = error "Unimplemented." + +-- | Process events in a loop. Uses R's @select()@ mechanism under the hood. +-- This function should be called from the main thread. It never returns. +eventLoopSelect :: MonadR m => m () +eventLoopSelect = + io $ forever $ do + usecs <- peek R.pollingPeriod + gusecs <- peek R.graphicsPollingPeriod + let eusecs + | usecs == 0 && gusecs == 0 = 10000 + | usecs == 0 || gusecs == 0 = max usecs gusecs + | otherwise = min usecs gusecs + R.checkActivity eusecs 1 >>= + R.runHandlers inputHandlers + +-- | Manually trigger processing all pending events. Useful when at an +-- interactive prompt and no event loop is running. +refresh :: MonadR m => m () +refresh = io $ R.checkActivity 0 1 >>= R.runHandlers inputHandlers diff --git a/src/Language/R/GC.hs b/src/Language/R/GC.hs new file mode 100644 --- /dev/null +++ b/src/Language/R/GC.hs @@ -0,0 +1,55 @@ +-- | +-- Copyright: (C) 2013 Amgen, Inc. +-- +-- Facilities to get Haskell's garbage collector to manage the liveness of +-- values allocated on the R heap. By default, R values remain live so long as +-- the current region is extant. The R garbage collector may only free them +-- after the end of the region. Sometimes, this discipline incurs too high of +-- a memory usage and nested regions are not always a solution. +-- +-- This module enables registering a callback with the GHC garbage collector. In +-- this way, when the GHC garbage collector detects that a value is no longer +-- live, we can notify the R garbage collector of this fact. The R garbage +-- collector is then free to deallocate the memory associated with the value +-- soon after that. +-- +-- This module hence offers an alternative, more flexible memory management +-- discipline, at a performance cost. In particular, collections of many small, +-- short-lived objects are best managed using regions. + +module Language.R.GC + ( automatic + , automaticSome + ) where + +import Control.Memory.Region +import Control.Monad.R.Class +import Foreign.R (SomeSEXP(..)) +import qualified Foreign.R as R +import System.Mem.Weak (addFinalizer) + +-- | Declare memory management for this value to be automatic. That is, the +-- memory associated with it may be freed as soon as the garbage collector +-- notices that it is safe to do so. +-- +-- Values with automatic memory management are tagged with the global region. +-- The reason is that just like for other global values, deallocation of the +-- value can never be observed. Indeed, it is a mere "optimization" to +-- deallocate the value sooner - it would still be semantically correct to never +-- deallocate it at all. +automatic :: MonadR m => R.SEXP s a -> m (R.SEXP G a) +automatic s = io $ do + R.preserveObject s' + s' `addFinalizer` (R.releaseObject (R.unsafeRelease s')) + return s' + where + s' = R.unsafeRelease s + +-- | 'automatic' for 'SomeSEXP'. +automaticSome :: MonadR m => R.SomeSEXP s -> m (R.SomeSEXP G) +automaticSome (SomeSEXP s) = io $ do + R.preserveObject s' + s' `addFinalizer` (R.releaseObject s') + return $ SomeSEXP s' + where + s' = R.unsafeRelease s diff --git a/src/Language/R/Globals.hs b/src/Language/R/Globals.hs new file mode 100644 --- /dev/null +++ b/src/Language/R/Globals.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} + +-- | +-- Copyright: (C) 2013 Amgen, Inc. +-- +-- Global variables used by the R interpreter. All are constant, but the values +-- of some of them may change over time (e.g. the global environment). + +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module Language.R.Globals + ( baseEnv + , emptyEnv + , globalEnv + , nilValue + , missingArg + , unboundValue + -- * R Internal constants + , isRInteractive + , inputHandlers + -- * R global constants + -- $ghci-bug + , pokeRVariables + ) where + +import Control.Memory.Region +import Control.Monad ((<=<)) +import Foreign + ( Ptr + , StablePtr + , deRefStablePtr + , newStablePtr + , peek + , poke + ) +import Foreign.C.Types (CInt) +import Foreign.R (SEXP) +import qualified Foreign.R as R +import qualified Foreign.R.EventLoop as R +import System.IO.Unsafe (unsafePerformIO) + +-- $ghci-bug +-- The main reason to have all R constants referenced with a StablePtr +-- is that variables in shared libraries are linked incorrectly by GHCi with +-- loaded code. +-- +-- The workaround is to grab all variables in the ghci session for the loaded +-- code to use them, that is currently done by the H.ghci script. +-- +-- Upstream ticket: + +type RVariables = + ( Ptr (SEXP G 'R.Env) + , Ptr (SEXP G 'R.Env) + , Ptr (SEXP G 'R.Env) + , Ptr (SEXP G 'R.Nil) + , Ptr (SEXP G 'R.Symbol) + , Ptr (SEXP G 'R.Symbol) + , Ptr CInt + , Ptr (Ptr R.InputHandler) + ) + +-- | Stores R variables in a static location. This makes the variables' +-- addresses accesible after reloading in GHCi. +foreign import ccall "missing_r.h &" rVariables :: Ptr (StablePtr RVariables) + +pokeRVariables :: RVariables -> IO () +pokeRVariables = poke rVariables <=< newStablePtr + +( baseEnvPtr + , emptyEnvPtr + , globalEnvPtr + , nilValuePtr + , unboundValuePtr + , missingArgPtr + , isRInteractive + , inputHandlersPtr + ) = unsafePerformIO $ peek rVariables >>= deRefStablePtr + +-- | Special value to which all symbols unbound in the current environment +-- resolve to. +unboundValue :: SEXP G 'R.Symbol +unboundValue = unsafePerformIO $ peek unboundValuePtr + +-- | R's @NULL@ value. +nilValue :: SEXP G 'R.Nil +nilValue = unsafePerformIO $ peek nilValuePtr + +-- | Value substituted for all missing actual arguments of a function call. +missingArg :: SEXP G 'R.Symbol +missingArg = unsafePerformIO $ peek missingArgPtr + +-- | The base environment. +baseEnv :: SEXP G 'R.Env +baseEnv = unsafePerformIO $ peek baseEnvPtr + +-- | The empty environment. +emptyEnv :: SEXP G 'R.Env +emptyEnv = unsafePerformIO $ peek emptyEnvPtr + +-- | The global environment. +globalEnv :: SEXP G 'R.Env +globalEnv = unsafePerformIO $ peek globalEnvPtr + +inputHandlers :: Ptr R.InputHandler +inputHandlers = unsafePerformIO $ peek inputHandlersPtr diff --git a/src/Language/R/HExp.chs b/src/Language/R/HExp.chs new file mode 100644 --- /dev/null +++ b/src/Language/R/HExp.chs @@ -0,0 +1,518 @@ +-- | +-- Copyright: (C) 2013 Amgen, Inc. +-- +-- Provides a /shallow/ view of a 'SEXP' R value as an algebraic datatype. This +-- is useful to define functions over R values in Haskell with pattern matching. +-- For example: +-- +-- @ +-- toPair :: SEXP a -> (SomeSEXP, SomeSEXP) +-- toPair (hexp -> List _ (Just car) (Just cdr)) = (SomeSEXP car, SomeSEXP cdr) +-- toPair (hexp -> Lang car (Just cdr)) = (SomeSEXP car, SomeSEXP cdr) +-- toPair s = error $ "Cannot extract pair from object of type " ++ typeOf s +-- @ +-- +-- (See 'Foreign.R.SomeSEXP' for why we need to use it here.) +-- +-- The view is said to be 'shallow' because it only unfolds the head of the +-- R value into an algebraic datatype. In this way, functions producing views +-- can be written non-recursively, hence inlined at all call sites and +-- simplified away. When produced by a view function in a pattern match, +-- allocation of the view can be compiled away and hence producing a view can be +-- done at no runtime cost. In fact, pattern matching on a view in this way is +-- more efficient than using the accessor functions defined in "Foreign.R", +-- because we avoid the overhead of calling one or more FFI functions entirely. +-- +-- 'HExp' is the /view/ and 'hexp' is the /view function/ that projects 'SEXP's +-- into 'HExp' views. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PolyKinds #-} +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE RoleAnnotations #-} +#endif +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +#if __GLASGOW_HASKELL__ >= 710 +-- XXX necessary for c2hs. +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} +#else +{-# OPTIONS_GHC -fno-warn-orphans #-} +#endif +module Language.R.HExp + ( HExp(..) + , (===) + , hexp + , unhexp + , vector + , selfSymbol + ) where + +import Control.Applicative +import Control.Monad.R.Class +import qualified Foreign.R as R +import qualified Foreign.R.Type as R +import Foreign.R (SEXP, SEXPREC, SomeSEXP(..), SEXPTYPE, withProtected) +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 + +import Control.Monad ((<=<), guard, void) +import Control.Monad.Primitive ( unsafeInlineIO ) +import Data.Int (Int32) +import Data.Word (Word8) +import Data.Complex +import Data.Maybe (isJust) +import Data.Type.Equality (TestEquality(..), (:~:)(Refl)) +import GHC.Ptr (Ptr(..)) +import Foreign.Storable +import Foreign.C +import Foreign ( castPtr, nullPtr ) +import Unsafe.Coerce (unsafeCoerce) +-- Fixes redundant import warning >= 7.10 without CPP +import Prelude + +#define USE_RINTERNALS +#include "Hcompat.h" +#include +#include + +{#pointer *SEXPREC as SEXP0 -> SEXPREC #} + +-- Use explicit UNPACK pragmas rather than -funbox-strict-fields in order to get +-- warnings if a field is not unpacked when we expect it to. + +-- | A view of R's internal 'SEXP' structure as an algebraic datatype. Because +-- this is in fact a GADT, the use of named record fields is not possible here. +-- Named record fields give rise to functions for whom it is not possible to +-- assign a reasonable type (existentially quantified type variables would +-- escape). +-- +-- Note further that Haddock does not currently support constructor comments +-- when using the GADT syntax. +#if __GLASGOW_HASKELL__ >= 708 +type role HExp phantom nominal +#endif +data HExp :: * -> SEXPTYPE -> * where + -- Primitive types. The field names match those of . + Nil :: HExp s R.Nil + -- Fields: pname, value, internal. + Symbol :: SEXP s R.Char + -> SEXP s a + -> SEXP s b + -> HExp s R.Symbol + -- Fields: carval, cdrval, tagval. + List :: (R.IsPairList b, c :∈ [R.Symbol, R.Nil]) + => SEXP s a + -> SEXP s b + -> SEXP s c + -> HExp s R.List + -- Fields: frame, enclos, hashtab. + Env :: (R.IsPairList a, b :∈ [R.Env, R.Nil], c :∈ [R.Vector, R.Nil]) + => SEXP s a + -> SEXP s b + -> SEXP s c + -> HExp s R.Env + -- Fields: formals, body, env. + Closure :: (R.IsPairList a) + => SEXP s a + -> SEXP s b + -> SEXP s R.Env + -> HExp s R.Closure + -- Fields: value, expr, env. + -- Once an promise has been evaluated, the environment is set to NULL. + Promise :: (R.IsPairList a, c :∈ [R.Env, R.Nil]) + => SEXP s a + -> SEXP s b + -> SEXP s c + -> HExp s R.Promise + -- Derived types. These types don't have their own 'struct' declaration in + -- . + -- Fields: function, args. + Lang :: (a :∈ [R.Symbol, R.Lang], R.IsPairList b) + => SEXP s a + -> SEXP s b + -> HExp s R.Lang + -- Fields: offset. + Special :: {-# UNPACK #-} !Int32 + -> HExp s R.Special + -- Fields: offset. + Builtin :: {-# UNPACK #-} !Int32 + -> HExp s R.Builtin + Char :: {-# UNPACK #-} !(Vector.Vector s R.Char Word8) + -> HExp s R.Char + Logical :: {-# UNPACK #-} !(Vector.Vector s 'R.Logical R.Logical) + -> HExp s 'R.Logical + Int :: {-# UNPACK #-} !(Vector.Vector s R.Int Int32) + -> HExp s R.Int + Real :: {-# UNPACK #-} !(Vector.Vector s R.Real Double) + -> HExp s R.Real + Complex :: {-# UNPACK #-} !(Vector.Vector s R.Complex (Complex Double)) + -> HExp s R.Complex + String :: {-# UNPACK #-} !(Vector.Vector s R.String (SEXP s R.Char)) + -> HExp s R.String + -- Fields: pairlist of promises. + DotDotDot :: (R.IsPairList a) + => SEXP s a + -> HExp s R.List + -- Fields: truelength, content. + Vector :: {-# UNPACK #-} !Int32 + -> {-# UNPACK #-} !(Vector.Vector s R.Vector (SomeSEXP s)) + -> HExp s R.Vector + -- Fields: truelength, content. + Expr :: {-# UNPACK #-} !Int32 + -> {-# UNPACK #-} !(Vector.Vector s R.Expr (SomeSEXP s)) + -> HExp s R.Expr + Bytecode :: HExp s R.Bytecode -- XXX + -- Fields: pointer, protectionValue, tagval + ExtPtr :: Ptr () + -> SEXP s b + -> SEXP s R.Symbol + -> HExp s R.ExtPtr + -- Fields: key, value, finalizer, next. + WeakRef :: ( a :∈ [R.Env, R.ExtPtr, R.Nil] + , c :∈ [R.Closure, R.Builtin, R.Special, R.Nil] + , d :∈ [R.WeakRef, R.Nil] ) + => SEXP s a + -> SEXP s b + -> SEXP s c + -> SEXP s d + -> HExp s R.WeakRef + Raw :: {-# UNPACK #-} !(Vector.Vector s R.Raw Word8) + -> HExp s R.Raw + -- Fields: tagval. + S4 :: SEXP s a + -> HExp s R.S4 + +-- | Heterogeneous equality. +(===) :: TestEquality f => f a -> f b -> Bool +x === y = isJust $ testEquality x y + +-- | Wrapper for partially applying a type synonym. +newtype E s a = E (SEXP s a) + +instance TestEquality (E s) where + testEquality (E x@(hexp -> t1)) (E y@(hexp -> t2)) = + (guard (R.unsexp x == R.unsexp y) >> return (unsafeCoerce Refl)) <|> + testEquality t1 t2 + +instance TestEquality (HExp s) where + testEquality Nil Nil = return Refl + testEquality (Symbol pname1 value1 internal1) (Symbol pname2 value2 internal2) = do + void $ testEquality (E pname1) (E pname2) + void $ testEquality (E value1) (E value2) + void $ testEquality (E internal1) (E internal2) + return Refl + testEquality (List carval1 cdrval1 tagval1) (List carval2 cdrval2 tagval2) = do + void $ testEquality (E carval1) (E carval2) + void $ testEquality (E cdrval1) (E cdrval2) + void $ testEquality (E tagval1) (E tagval2) + return Refl + testEquality (Env frame1 enclos1 hashtab1) (Env frame2 enclos2 hashtab2) = do + void $ testEquality (E frame1) (E frame2) + void $ testEquality (E enclos1) (E enclos2) + void $ testEquality (E hashtab1) (E hashtab2) + return Refl + testEquality (Closure formals1 body1 env1) (Closure formals2 body2 env2) = do + void $ testEquality (E formals1) (E formals2) + void $ testEquality (E body1) (E body2) + void $ testEquality (E env1) (E env2) + return Refl + testEquality (Promise value1 expr1 env1) (Promise value2 expr2 env2) = do + void $ testEquality (E value1) (E value2) + void $ testEquality (E expr1) (E expr2) + void $ testEquality (E env1) (E env2) + return Refl + testEquality (Lang carval1 cdrval1) (Lang carval2 cdrval2) = do + void $ testEquality (E carval1) (E carval2) + void $ testEquality (E cdrval1) (E cdrval2) + return Refl + testEquality (Special offset1) (Special offset2) = do + guard $ offset1 == offset2 + return Refl + testEquality (Builtin offset1) (Builtin offset2) = do + guard $ offset1 == offset2 + return Refl + testEquality (Char vec1) (Char vec2) = do + guard $ vec1 == vec2 + return Refl + testEquality (Int vec1) (Int vec2) = do + guard $ vec1 == vec2 + return Refl + testEquality (Real vec1) (Real vec2) = do + guard $ vec1 == vec2 + return Refl + testEquality (String vec1) (String vec2) = do + guard $ vec1 == vec2 + return Refl + testEquality (Complex vec1) (Complex vec2) = do + guard $ vec1 == vec2 + return Refl + testEquality (DotDotDot pairlist1) (DotDotDot pairlist2) = do + void $ testEquality (E pairlist1) (E pairlist2) + return Refl + testEquality (Vector truelength1 vec1) (Vector truelength2 vec2) = do + let eq (SomeSEXP s1) (SomeSEXP s2) = isJust $ testEquality (E s1) (E s2) + guard $ truelength1 == truelength2 + guard $ and $ zipWith eq (Vector.toList vec1) (Vector.toList vec2) + return Refl + testEquality (Expr truelength1 vec1) (Expr truelength2 vec2) = do + let eq (SomeSEXP s1) (SomeSEXP s2) = isJust $ testEquality (E s1) (E s2) + guard $ truelength1 == truelength2 + guard $ and $ zipWith eq (Vector.toList vec1) (Vector.toList vec2) + return Refl + testEquality Bytecode Bytecode = return Refl + testEquality (ExtPtr pointer1 protectionValue1 tagval1) (ExtPtr pointer2 protectionValue2 tagval2) = do + guard $ castPtr pointer1 == castPtr pointer2 + void $ testEquality (E protectionValue1) (E protectionValue2) + void $ testEquality (E tagval1) (E tagval2) + return Refl + testEquality (WeakRef key1 value1 finalizer1 next1) (WeakRef key2 value2 finalizer2 next2) = do + void $ testEquality (E key1) (E key2) + void $ testEquality (E value1) (E value2) + void $ testEquality (E finalizer1) (E finalizer2) + void $ testEquality (E next1) (E next2) + return Refl + testEquality (Raw vec1) (Raw vec2) = do + guard $ vec1 == vec2 + return Refl + testEquality (S4 tagval1) (S4 tagval2) = do + void $ testEquality (E tagval1) (E tagval2) + return Refl + testEquality _ _ = Nothing + +-- XXX Orphan instance. Could find a better place to put it. +-- this #ifdef is not correct as it should be MIN_VERSION_base, +-- so this one will not work in non GHC compilers. +#if __GLASGOW_HASKELL__ < 710 +instance (Fractional a, Real a, Storable a) => Storable (Complex a) where + sizeOf _ = {#sizeof Rcomplex #} + alignment _ = {#alignof Rcomplex #} + poke cptr (r :+ i) = do + {#set Rcomplex->r #} cptr (realToFrac r) + {#set Rcomplex->i #} cptr (realToFrac i) + peek cptr = + (:+) <$> (realToFrac <$> {#get Rcomplex->r #} cptr) + <*> (realToFrac <$> {#get Rcomplex->i #} cptr) +#endif + +instance Storable (HExp s a) where + sizeOf _ = {#sizeof SEXPREC #} + alignment _ = {#alignof SEXPREC #} + poke = pokeHExp + peek = peekHExp . R.SEXP + {-# INLINE peek #-} + +{-# INLINE peekHExp #-} +peekHExp :: SEXP s a -> IO (HExp s a) +peekHExp s = do + let coerce :: IO (HExp s a) -> IO (HExp s b) + coerce = unsafeCoerce + + -- (:∈) constraints are impossible to respect in 'peekHExp', because + -- R doesn't tell us statically the form of the SEXPREC referred to by + -- a pointer. So in this function only, we pretend all constrained + -- fields actually always contain fields of form ANYSXP. This has no + -- operational significance - it's only a way to bypass what's + -- impossible to prove. + coerceAny :: SEXP s a -> SEXP s R.Any + coerceAny = R.unsafeCoerce + + sptr = R.unsexp s + + case R.typeOf s of + R.Nil -> coerce $ return Nil + R.Symbol -> coerce $ + Symbol <$> (R.sexp <$> {#get SEXP->u.symsxp.pname #} sptr) + <*> (R.sexp <$> {#get SEXP->u.symsxp.value #} sptr) + <*> (R.sexp <$> {#get SEXP->u.symsxp.internal #} sptr) + R.List -> coerce $ + List <$> (R.sexp <$> {#get SEXP->u.listsxp.carval #} sptr) + <*> (coerceAny <$> R.sexp <$> {#get SEXP->u.listsxp.cdrval #} sptr) + <*> (coerceAny <$> R.sexp <$> {#get SEXP->u.listsxp.tagval #} sptr) + R.Env -> coerce $ + Env <$> (coerceAny <$> R.sexp <$> {#get SEXP->u.envsxp.frame #} sptr) + <*> (coerceAny <$> R.sexp <$> {#get SEXP->u.envsxp.enclos #} sptr) + <*> (coerceAny <$> R.sexp <$> {#get SEXP->u.envsxp.hashtab #} sptr) + R.Closure -> coerce $ + Closure <$> (coerceAny <$> R.sexp <$> {#get SEXP->u.closxp.formals #} sptr) + <*> (R.sexp <$> {#get SEXP->u.closxp.body #} sptr) + <*> (R.sexp <$> {#get SEXP->u.closxp.env #} sptr) + R.Promise -> coerce $ + Promise <$> (coerceAny <$> R.sexp <$> {#get SEXP->u.promsxp.value #} sptr) + <*> (R.sexp <$> {#get SEXP->u.promsxp.expr #} sptr) + <*> (coerceAny <$> R.sexp <$> {#get SEXP->u.promsxp.env #} sptr) + R.Lang -> coerce $ + Lang <$> (coerceAny <$> R.sexp <$> {#get SEXP->u.listsxp.carval #} sptr) + <*> (coerceAny <$> R.sexp <$> {#get SEXP->u.listsxp.cdrval #} sptr) + R.Special -> coerce $ + Special <$> (fromIntegral <$> {#get SEXP->u.primsxp.offset #} sptr) + R.Builtin -> coerce $ + Builtin <$> (fromIntegral <$> {#get SEXP->u.primsxp.offset #} sptr) + R.Char -> unsafeCoerce $ Char (Vector.unsafeFromSEXP (unsafeCoerce s)) + R.Logical -> unsafeCoerce $ Logical (Vector.unsafeFromSEXP (unsafeCoerce s)) + R.Int -> unsafeCoerce $ Int (Vector.unsafeFromSEXP (unsafeCoerce s)) + R.Real -> unsafeCoerce $ Real (Vector.unsafeFromSEXP (unsafeCoerce s)) + R.Complex -> unsafeCoerce $ Complex (Vector.unsafeFromSEXP (unsafeCoerce s)) + R.String -> unsafeCoerce $ String (Vector.unsafeFromSEXP (unsafeCoerce s)) + R.DotDotDot -> unimplemented $ "peekHExp: " ++ show (R.typeOf s) + R.Vector -> coerce $ + Vector <$> (fromIntegral <$> {#get VECSEXP->vecsxp.truelength #} sptr) + <*> pure (Vector.unsafeFromSEXP (unsafeCoerce s)) + R.Expr -> coerce $ + Expr <$> (fromIntegral <$> {#get VECSEXP->vecsxp.truelength #} sptr) + <*> pure (Vector.unsafeFromSEXP (unsafeCoerce s)) + R.Bytecode -> coerce $ return Bytecode + R.ExtPtr -> coerce $ + ExtPtr <$> (castPtr <$> {#get SEXP->u.listsxp.carval #} sptr) + <*> (R.sexp <$> {#get SEXP->u.listsxp.cdrval #} sptr) + <*> (R.sexp <$> {#get SEXP->u.listsxp.tagval #} sptr) + R.WeakRef -> coerce $ + WeakRef <$> (coerceAny <$> R.sexp <$> + peekElemOff (castPtr $ R.unsafeSEXPToVectorPtr s) 0) + <*> (R.sexp <$> + peekElemOff (castPtr $ R.unsafeSEXPToVectorPtr s) 1) + <*> (coerceAny <$> R.sexp <$> + peekElemOff (castPtr $ R.unsafeSEXPToVectorPtr s) 2) + <*> (coerceAny <$> R.sexp <$> + peekElemOff (castPtr $ R.unsafeSEXPToVectorPtr s) 3) + R.Raw -> unsafeCoerce $ Raw (Vector.unsafeFromSEXP (unsafeCoerce s)) + R.S4 -> coerce $ + S4 <$> (R.sexp <$> {# get SEXP->u.listsxp.tagval #} sptr) + _ -> unimplemented $ "peekHExp: " ++ show (R.typeOf s) + +pokeHExp :: Ptr (HExp s a) -> HExp s a -> IO () +pokeHExp s h = do + case h of + Nil -> return () + Symbol pname value internal -> do + {#set SEXP->u.symsxp.pname #} s (R.unsexp pname) + {#set SEXP->u.symsxp.value #} s (R.unsexp value) + {#set SEXP->u.symsxp.internal#} s (R.unsexp internal) + List carval cdrval tagval -> do + {#set SEXP->u.listsxp.carval #} s (R.unsexp carval) + {#set SEXP->u.listsxp.cdrval #} s (R.unsexp cdrval) + {#set SEXP->u.listsxp.tagval #} s (R.unsexp tagval) + Env frame enclos hashtab -> do + {#set SEXP->u.envsxp.frame #} s (R.unsexp frame) + {#set SEXP->u.envsxp.enclos #} s (R.unsexp enclos) + {#set SEXP->u.envsxp.hashtab #} s (R.unsexp hashtab) + Closure formals body env -> do + {#set SEXP->u.closxp.formals #} s (R.unsexp formals) + {#set SEXP->u.closxp.body #} s (R.unsexp body) + {#set SEXP->u.closxp.env #} s (R.unsexp env) + Promise value expr env -> do + {#set SEXP->u.promsxp.value #} s (R.unsexp value) + {#set SEXP->u.promsxp.expr #} s (R.unsexp expr) + {#set SEXP->u.promsxp.env #} s (R.unsexp env) + Lang carval cdrval -> do + {#set SEXP->u.listsxp.carval #} s (R.unsexp carval) + {#set SEXP->u.listsxp.cdrval #} s (R.unsexp cdrval) + Special offset -> do + {#set SEXP->u.primsxp.offset #} s (fromIntegral offset) + Builtin offset -> do + {#set SEXP->u.primsxp.offset #} s (fromIntegral offset) + Char _vc -> unimplemented "pokeHExp" + Logical _vt -> unimplemented "pokeHExp" + Int _vt -> unimplemented "pokeHExp" + Real _vt -> unimplemented "pokeHExp" + String _vt -> unimplemented "pokeHExp" + Complex _vt -> unimplemented "pokeHExp" + Vector _v _ -> unimplemented "pokeHExp" + Bytecode -> unimplemented "pokeHExp" + ExtPtr _ _ _ -> unimplemented "pokeHExp" + WeakRef _ _ _ _ -> unimplemented "pokeHExp" + Raw _ -> unimplemented "pokeHExp" + S4 _ -> unimplemented "pokeHExp" + DotDotDot _ -> unimplemented "pokeHExp" + Expr _ _ -> unimplemented "pokeHExp" + +-- | A view function projecting a view of 'SEXP' as an algebraic datatype, that +-- can be analyzed through pattern matching. +hexp :: SEXP s a -> HExp s a +hexp = unsafeInlineIO . peek . R.unSEXP +{-# INLINE hexp #-} + +-- | Inverse hexp view to the real structure, note that for scalar types +-- hexp will allocate new SEXP, and @unhexp . hexp@ is not an identity function. +-- however for vector types it will return original SEXP. +unhexp :: MonadR m => HExp (Region m) a -> m (SEXP (Region m) a) +unhexp Nil = return $ R.release H.nilValue +unhexp s@(Symbol{}) = io $ + withProtected (R.allocSEXP R.SSymbol) + (\x -> poke (R.unSEXP x) s >> return x) +unhexp (List carval cdrval tagval) = acquire <=< io $ do + rc <- R.protect carval + rd <- R.protect cdrval + rt <- R.protect tagval + z <- R.cons rc rd + {# set SEXP-> u.listsxp.tagval #} (R.unsexp z) (R.unsexp rt) + R.unprotect 3 + return z +unhexp (Lang carval cdrval) = acquire <=< io $ do + carval' <- R.protect carval + cdrval' <- R.protect cdrval + x <- R.allocSEXP R.SLang + R.setCar x (R.release carval') + R.setCdr x (R.release cdrval') + R.unprotect 2 + return x +unhexp s@(Env{}) = io $ + withProtected (R.allocSEXP R.SEnv) + (\x -> poke (R.unSEXP x) s >> return x) +unhexp s@(Closure{}) = io $ + withProtected (R.allocSEXP R.SClosure) + (\x -> poke (R.unSEXP x) s >> return x) +unhexp s@(Special{}) = io $ + withProtected (R.allocSEXP R.SSpecial) + (\x -> poke (R.unSEXP x) s >> return x) +unhexp s@(Builtin{}) = io $ + withProtected (R.allocSEXP R.SBuiltin) + (\x -> poke (R.unSEXP x) s >> return x) +unhexp s@(Promise{}) = io $ + 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 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 DotDotDot{} = unimplemented "unhexp" +unhexp ExtPtr{} = unimplemented "unhexp" + +-- | Project the vector out of 'SEXP's. +vector :: R.IsVector a => SEXP s a -> Vector.Vector s a (Vector.ElemRep s a) +vector (hexp -> Char vec) = vec +vector (hexp -> Logical vec) = vec +vector (hexp -> Int vec) = vec +vector (hexp -> Real vec) = vec +vector (hexp -> Complex vec) = vec +vector (hexp -> String vec) = vec +vector (hexp -> Vector _ vec) = vec +vector (hexp -> Expr _ vec) = vec +vector s = violation "vector" $ show (R.typeOf s) ++ " unexpected vector type." + +-- | Symbols can have values attached to them. This function creates a symbol +-- whose value is itself. +selfSymbol :: SEXP s R.Char -> IO (SEXP s R.Symbol) +selfSymbol pname = unsafeRToIO $ do + s <- unhexp =<< Symbol pname (R.sexp nullPtr) <$> unhexp Nil + io $ R.setCdr s s + return s diff --git a/src/Language/R/HExp.hs-boot b/src/Language/R/HExp.hs-boot new file mode 100644 --- /dev/null +++ b/src/Language/R/HExp.hs-boot @@ -0,0 +1,14 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE RoleAnnotations #-} +#endif +module Language.R.HExp where + +import Foreign.R.Type (SEXPTYPE) + +#if __GLASGOW_HASKELL__ >= 708 +type role HExp phantom nominal +#endif +data HExp :: * -> SEXPTYPE -> * diff --git a/src/Language/R/Instance.hs b/src/Language/R/Instance.hs new file mode 100644 --- /dev/null +++ b/src/Language/R/Instance.hs @@ -0,0 +1,256 @@ +-- | +-- Copyright: (C) 2013 Amgen, Inc. +-- +-- Interaction with an instance of R. The interface in this module allows for +-- instantiating an arbitrary number of concurrent R sessions, even though +-- currently the R library only allows for one global instance, for forward +-- compatibility. +-- +-- The 'R' monad defined here serves to give static guarantees that an instance +-- is only ever used after it has been initialized and before it is finalized. +-- Doing otherwise should result in a type error. This is done in the same way +-- that the 'Control.Monad.ST' monad encapsulates side effects: by assigning +-- a rank-2 type to the only run function for the monad. +-- +-- This module is intended to be imported qualified. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TypeFamilies #-} + +module Language.R.Instance + ( -- * The R monad + R + , runRegion + , unsafeRToIO + -- * R instance creation + , Config(..) + , defaultConfig + , withEmbeddedR + , initialize + , finalize + ) where + +import Control.Monad.Primitive (PrimMonad(..)) +import Control.Monad.R.Class +import Control.Monad.ST.Unsafe (unsafeSTToIO) +import Data.Monoid +import Data.Default.Class (Default(..)) +import qualified Foreign.R as R +import qualified Foreign.R.Embedded as R +import qualified Foreign.R.EventLoop as R +import Foreign.C.String +import Language.R.Globals + +import Control.Applicative +import Control.Concurrent.MVar + ( newMVar + , withMVar + , MVar + ) +import Control.DeepSeq ( NFData, deepseq ) +import Control.Exception + ( bracket + , bracket_ + ) +import Control.Monad.Catch ( MonadCatch, MonadMask, MonadThrow ) +import Control.Monad.Reader +import Data.IORef (IORef, newIORef, readIORef, modifyIORef') +import Foreign + ( Ptr + , allocaArray + ) +import Foreign.C.Types ( CInt(..) ) +import Foreign.Storable (Storable(..)) +import System.Environment ( getProgName, lookupEnv ) +import System.IO.Unsafe ( unsafePerformIO ) +import System.Process ( readProcess ) +import System.SetEnv +#ifdef H_ARCH_UNIX +import Control.Exception ( onException ) +import System.IO ( hPutStrLn, stderr ) +import System.Posix.Resource +#endif +import Prelude + +-- | The 'R' monad, for sequencing actions interacting with a single instance of +-- the R interpreter, much as the 'IO' monad sequences actions interacting with +-- the real world. The 'R' monad embeds the 'IO' monad, so all 'IO' actions can +-- be lifted to 'R' actions. +newtype R s a = R { unR :: ReaderT (IORef Int) IO a } + deriving (Applicative, Functor, Monad, MonadIO, MonadCatch, MonadMask, MonadThrow) + +instance MonadR (R s) where + type Region (R s) = s + io m = R $ ReaderT $ \_ -> m + acquire s = R $ ReaderT $ \cnt -> 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 + +-- | 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 +-- very beginning of the @main@ function of the program. +-- +-- > main = withEmbeddedR $ do {...} +-- +-- Note that R does not currently support reinitialization after finalization, +-- so this function should be called only once during the lifetime of the +-- program (see @src/unix/system.c:Rf_initialize()@ in the R source code). +withEmbeddedR :: Config -> IO a -> IO a +withEmbeddedR config = bracket_ (initialize config) finalize + +-- | Run an R action in the global R instance from the IO monad. This action +-- provides no static guarantees that the R instance was indeed initialized and +-- has not yet been finalized. Make sure to call it within the scope of +-- `withEmbeddedR`. +-- +-- @runRegion m@ fully evaluates the result of action @m@, to ensure that no +-- 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 = + 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. +data Config = Config + { -- | Program name. If 'Nothing' then the value of 'getProgName' will be + -- used. + configProgName :: Maybe String + -- | Command-line arguments. + , configArgs :: [String] + } + +instance Default Config where + def = defaultConfig + +instance Monoid Config where + mempty = defaultConfig + mappend cfg1 cfg2 = Config + { configProgName = configProgName cfg1 <> configProgName cfg2 + , configArgs = configArgs cfg1 <> configArgs cfg2 + } + +-- | Default argument to pass to 'initialize'. +defaultConfig :: Config +defaultConfig = Config Nothing ["--vanilla", "--silent"] + +-- | Populate environment with @R_HOME@ variable if it does not exist. +populateEnv :: IO () +populateEnv = do + mh <- lookupEnv "R_HOME" + when (mh == Nothing) $ + setEnv "R_HOME" =<< fmap (head . lines) (readProcess "R" ["-e","cat(R.home())","--quiet","--slave"] "") + +-- | A static address that survives GHCi reloadings which indicates +-- whether R has been initialized. +foreign import ccall "missing_r.h &isRInitialized" isRInitializedPtr :: Ptr CInt + +-- | Allocate and initialize a new array of elements. +newCArray :: Storable a + => [a] -- ^ Array elements + -> (Ptr a -> IO r) -- ^ Continuation + -> IO r +newCArray xs k = + allocaArray (length xs) $ \ptr -> do + zipWithM_ (pokeElemOff ptr) [0..] xs + k ptr + +-- | An MVar to make an atomic step of checking whether R is initialized and +-- initializing it if needed. +initLock :: MVar () +initLock = unsafePerformIO $ newMVar () +{-# NOINLINE initLock #-} + +-- Note [Concurrent initialization] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- In 'initialize' we check a first time if R is initialized. This test is fast +-- since it happens without taking an MVar. If R needs initialization, after +-- taking the MVar we check again if R is initialized to avoid concurrent +-- threads from initializing R multiple times. The user is not expected to call +-- initialize multiple times concurrently, but there is nothing stopping the +-- compiler from doing so when compiling quasiquotes. + +-- | Create a new embedded instance of the R interpreter. Only works from the +-- main thread of the program. That is, from the same thread of execution that +-- the program's @main@ function is running on. In GHCi, use @-fno-ghci-sandbox@ +-- to achieve this. +initialize :: Config + -> IO () +initialize Config{..} = do +#ifdef H_ARCH_UNIX +#ifdef H_ARCH_UNIX_DARWIN + -- NOTE: OS X does not allow removing the stack size limit completely, + -- instead forcing a hard limit of just under 64MB. + let stackLimit = ResourceLimit 67104768 +#else + let stackLimit = ResourceLimitUnknown +#endif + setResourceLimit ResourceStackSize (ResourceLimits stackLimit stackLimit) + `onException` (hPutStrLn stderr $ + "Language.R.Interpreter: " + ++ "Cannot increase stack size limit." + ++ "Try increasing your stack size limit manually:" +#ifdef H_ARCH_UNIX_DARWIN + ++ "$ launchctl limit stack 67104768" + ++ "$ ulimit -s 65532" +#else + ++ "$ ulimit -s unlimited" +#endif + ) +#endif + initialized <- fmap (==1) $ peek isRInitializedPtr + -- See note [Concurrent initialization] + unless initialized $ withMVar initLock $ const $ do + initialized2 <- fmap (==1) $ peek isRInitializedPtr + unless initialized2 $ mdo + -- Grab addresses of R global variables + pokeRVariables + ( R.baseEnv + , R.emptyEnv + , R.globalEnv + , R.nilValue + , R.unboundValue + , R.missingArg + , R.isRInteractive + , R.inputHandlers + ) + populateEnv + args <- (:) <$> maybe getProgName return configProgName + <*> pure configArgs + argv <- mapM newCString args + let argc = length argv + newCArray argv $ R.initEmbeddedR argc + poke isRInteractive 0 + poke isRInitializedPtr 1 + +-- | Finalize an R instance. +finalize :: IO () +finalize = do + R.endEmbeddedR 0 + poke isRInitializedPtr 0 diff --git a/src/Language/R/Internal.hs b/src/Language/R/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Language/R/Internal.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DataKinds #-} +{-# Language ViewPatterns #-} + +module Language.R.Internal where + +import Control.Memory.Region +import Foreign.R (SEXP, SomeSEXP(..)) +import qualified Foreign.R as R +import Language.R + +import Data.ByteString as B +import Foreign.C.String ( withCString ) + +-- | 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) + +-- | 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) + +-- | Internalize a symbol name. +installIO :: String -> IO (SEXP V 'R.Symbol) +installIO str = withCString str R.install diff --git a/src/Language/R/Internal.hs-boot b/src/Language/R/Internal.hs-boot new file mode 100644 --- /dev/null +++ b/src/Language/R/Internal.hs-boot @@ -0,0 +1,12 @@ +{-# Language DataKinds #-} + +module Language.R.Internal where + +import Control.Memory.Region +import Data.ByteString (ByteString) +import Foreign.R (SEXP, SomeSEXP(..)) +import qualified Foreign.R.Type as R + +r1 :: ByteString -> SEXP s a -> IO (SomeSEXP V) +r2 :: ByteString -> SEXP s a -> SEXP s b -> IO (SomeSEXP V) +installIO :: String -> IO (SEXP V 'R.Symbol) diff --git a/src/Language/R/Internal/FunWrappers.hs b/src/Language/R/Internal/FunWrappers.hs new file mode 100644 --- /dev/null +++ b/src/Language/R/Internal/FunWrappers.hs @@ -0,0 +1,28 @@ +-- | +-- Copyright: 2013 (C) Amgen, Inc +-- +-- Helpers for passing functions pointers between Haskell and R. + +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TemplateHaskell #-} + +module Language.R.Internal.FunWrappers where + +import Foreign.R (SEXP0) +import Language.R.Internal.FunWrappers.TH +import Foreign ( FunPtr ) + +foreign import ccall "wrapper" wrap0 :: IO SEXP0 -> IO (FunPtr (IO SEXP0)) + +foreign import ccall "wrapper" wrap1 + :: (SEXP0 -> IO SEXP0) -> IO (FunPtr (SEXP0 -> IO SEXP0)) + +foreign import ccall "wrapper" wrap2 + :: (SEXP0 -> SEXP0 -> IO SEXP0) + -> IO (FunPtr (SEXP0 -> SEXP0 -> IO SEXP0)) + +foreign import ccall "wrapper" wrap3 + :: (SEXP0 -> SEXP0 -> SEXP0 -> IO SEXP0) + -> IO (FunPtr (SEXP0 -> SEXP0 -> SEXP0 -> IO SEXP0)) + +$(thWrappers 4 12) diff --git a/src/Language/R/Internal/FunWrappers/TH.hs b/src/Language/R/Internal/FunWrappers/TH.hs new file mode 100644 --- /dev/null +++ b/src/Language/R/Internal/FunWrappers/TH.hs @@ -0,0 +1,99 @@ +-- | +-- Copyright: (C) 2013 Amgen, Inc. + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} + +module Language.R.Internal.FunWrappers.TH + ( thWrappers + , thWrapper + , thWrapperLiteral + , thWrapperLiterals + ) where + +import Internal.Error +import qualified Foreign.R.Type as R + +import Control.Monad (replicateM) +import Foreign (FunPtr) +import Language.Haskell.TH + +-- XXX: If we build quotes that mention names imported from Foreign.R, then +-- GHC panics because it fails to link in all adequate object files to +-- resolve all R symbols. So instead we build the symbol names +-- programmatically, using mkName... +nSEXP0 :: Q Type +nSEXP0 = conT (mkName "SEXP0") + +-- | Generate wrappers from n to m. +thWrappers :: Int -> Int -> Q [Dec] +thWrappers n m = mapM thWrapper [n..m] + +-- | Generate wrapper. +-- +-- Example for input 5: +-- +-- @ +-- foreign import ccall \"wrapper\" wrap5 +-- :: ( SEXP a -> SEXP b -> SEXP c +-- -> SEXP d -> SEXP e -> IO (SEXP f) +-- ) +-- -> IO (FunPtr ( SEXP a -> SEXP b -> SEXP c +-- -> SEXP d -> SEXP e -> IO (SEXP f) +-- ) +-- ) +-- @ +thWrapper :: Int -> Q Dec +thWrapper n = do + let vars = map (mkName . return) $ take (n + 1) ['a'..] + ty = go (map varT vars) + forImpD cCall safe "wrapper" (mkName $ "wrap" ++ show n) $ + [t| $ty -> IO (FunPtr $ty) |] + where + go :: [Q Type] -> Q Type + go [] = impossible "thWrapper" + go [_] = [t| IO $nSEXP0 |] + go (_:xs) = [t| $nSEXP0 -> $(go xs) |] + +thWrapperLiterals :: Int -> Int -> Q [Dec] +thWrapperLiterals n m = mapM thWrapperLiteral [n..m] + +-- | Generate Literal Instance for wrapper. +-- +-- Example for input 6: +-- @ +-- instance ( Literal a a0, Literal b b0, Literal c c0, Literal d d0, Literal e e0 +-- , Literal f f0, Literal g g0 +-- ) +-- => Literal (a -> b -> c -> d -> e -> f -> IO g) R.ExtPtr where +-- mkSEXP = funToSEXP wrap6 +-- fromSEXP = error \"Unimplemented.\" +-- @ +thWrapperLiteral :: Int -> Q Dec +thWrapperLiteral n = do + let s = varT =<< newName "s" + names1 <- replicateM (n + 1) $ newName "a" + names2 <- replicateM (n + 1) $ newName "i" + 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)) + where +#if MIN_VERSION_template_haskell(2,10,0) + f tv1 tv2 = foldl AppT (ConT (mkName "Literal")) <$> sequence [tv1, tv2] +#else + f tv1 tv2 = classP (mkName "Literal") [tv1, tv2] +#endif + -- XXX: Ideally would import these names from their defining module, but + -- see GHC bug #1012. Using 'mkName' is a workaround. + nR = conT $ mkName "R" + nwrapn = varE $ mkName $ "wrap" ++ show n + nfunToSEXP = varE $ mkName "Language.R.Literal.funToSEXP" + nLiteral = conT $ mkName "Literal" + instanceD ctx [t| $nLiteral $(mkTy $ map varT names1) 'R.ExtPtr |] + [ funD (mkName "mkSEXPIO") + [ clause [] (normalB [| $nfunToSEXP $nwrapn |]) [] ] + , funD (mkName "fromSEXP") + [ clause [] (normalB [| unimplemented "thWrapperLiteral fromSEXP" |]) [] ] + ] diff --git a/src/Language/R/Literal.hs b/src/Language/R/Literal.hs new file mode 100644 --- /dev/null +++ b/src/Language/R/Literal.hs @@ -0,0 +1,229 @@ +-- | +-- Copyright: 2013 (C) Amgen, Inc +-- + +{-# Language ConstraintKinds #-} +{-# Language DefaultSignatures #-} +{-# Language DataKinds #-} +{-# Language FlexibleContexts #-} +{-# Language FlexibleInstances #-} +{-# Language FunctionalDependencies #-} +{-# Language GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# Language TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# Language ViewPatterns #-} + +module Language.R.Literal + ( Literal(..) + , fromSomeSEXP + , mkSEXP + , dynSEXP + , mkSEXPVector + , mkSEXPVectorIO + , HFunWrap(..) + , funToSEXP + , mkProtectedSEXPVector + , mkProtectedSEXPVectorIO + -- * wrapper helpers + ) where + +import Control.Memory.Region +import Control.Monad.R.Class +import qualified Data.Vector.SEXP as SVector +import qualified Data.Vector.SEXP.Mutable as SMVector +import qualified Foreign.R as R +import Foreign.R.Type ( IsVector, SSEXPTYPE ) +import Foreign.R ( SEXP, SomeSEXP(..) ) +import Internal.Error +import Language.R.Internal (r1) +import Language.R.HExp +import Language.R.Instance +import Language.R.Internal.FunWrappers +import Language.R.Internal.FunWrappers.TH + +import Data.Singletons ( Sing, SingI, fromSing, sing ) + +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 System.IO.Unsafe ( unsafePerformIO ) + +-- | Values that can be converted to 'SEXP'. +class Literal a ty | a -> ty where + -- | Internal function for converting a literal to a 'SEXP' value. You + -- probably want to be using 'mkSEXP' instead. + mkSEXPIO :: a -> IO (SEXP V ty) + fromSEXP :: SEXP s ty -> a + + default mkSEXPIO :: (IsVector ty, Literal [a] ty) => a -> IO (SEXP V ty) + mkSEXPIO x = mkSEXPIO [x] + + default fromSEXP :: (IsVector ty, Literal [a] ty) => SEXP s ty -> a + fromSEXP (fromSEXP -> [x]) = x + fromSEXP _ = failure "fromSEXP" "Not a singleton vector." + +-- | Create a SEXP value and protect it in current region +mkSEXP :: (Literal a b, MonadR m) => a -> m (SEXP (Region m) b) +mkSEXP x = acquire =<< io (mkSEXPIO x) + +-- | Like 'fromSEXP', but with no static type satefy. Performs a dynamic +-- (i.e. at runtime) check instead. +fromSomeSEXP :: forall s a form. (Literal a form,SingI form) => R.SomeSEXP s -> a +fromSomeSEXP = fromSEXP . R.cast (sing :: Sing form) + +-- | Like 'fromSomeSEXP', but behaves like the @as.*@ family of functions +-- in R, by performing a best effort conversion to the target form (e.g. rounds +-- reals to integers, etc) for atomic types. +dynSEXP :: forall a s ty. (Literal a ty, SingI ty) => SomeSEXP s -> a +dynSEXP (SomeSEXP sx) = + fromSomeSEXP $ unsafePerformIO $ case fromSing (sing :: SSEXPTYPE ty) of + R.Char -> r1 "as.character" sx + R.Int -> r1 "as.integer" sx + R.Real -> r1 "as.double" sx + R.Complex -> r1 "as.complex" sx + R.Logical -> r1 "as.logical" sx + R.Raw -> r1 "as.raw" sx + _ -> return $ SomeSEXP $ R.release sx + +{-# NOINLINE mkSEXPVector #-} +mkSEXPVector :: (Storable (SVector.ElemRep s a), IsVector a) + => SSEXPTYPE a + -> [IO (SVector.ElemRep s a)] + -> SEXP s a +mkSEXPVector ty allocators = unsafePerformIO $ mkSEXPVectorIO ty allocators + +mkSEXPVectorIO :: (Storable (SVector.ElemRep s a), IsVector a) + => SSEXPTYPE a + -> [IO (SVector.ElemRep s a)] + -> IO (SEXP s a) +mkSEXPVectorIO ty allocators = + R.withProtected (R.allocVector ty $ length allocators) $ \vec -> do + let ptr = castPtr $ R.unsafeSEXPToVectorPtr vec + zipWithM_ (\i -> (>>= pokeElemOff ptr i)) [0..] allocators + return vec + +{-# NOINLINE mkProtectedSEXPVector #-} +mkProtectedSEXPVector :: IsVector b + => SSEXPTYPE b + -> [SEXP s a] + -> SEXP s b +mkProtectedSEXPVector ty xs = unsafePerformIO $ mkProtectedSEXPVectorIO ty xs + +mkProtectedSEXPVectorIO :: IsVector b + => SSEXPTYPE b + -> [SEXP s a] + -> IO (SEXP s b) +mkProtectedSEXPVectorIO ty xs = do + mapM_ (void . R.protect) xs + z <- R.withProtected (R.allocVector ty $ length xs) $ \vec -> do + let ptr = castPtr $ R.unsafeSEXPToVectorPtr vec + zipWithM_ (pokeElemOff ptr) [0..] xs + return vec + R.unprotect (length xs) + return z + +instance Literal [R.Logical] 'R.Logical where + mkSEXPIO = mkSEXPVectorIO sing . map return + fromSEXP (hexp -> Logical v) = SVector.toList v + fromSEXP _ = + failure "fromSEXP" "Logical expected where some other expression appeared." + +instance Literal [Int32] 'R.Int where + mkSEXPIO = mkSEXPVectorIO sing . map return + fromSEXP (hexp -> Int v) = SVector.toList v + fromSEXP _ = + failure "fromSEXP" "Int expected where some other expression appeared." + +instance Literal [Double] 'R.Real where + mkSEXPIO = mkSEXPVectorIO sing . map return + fromSEXP (hexp -> Real v) = SVector.toList v + fromSEXP _ = + failure "fromSEXP" "Numeric expected where some other expression appeared." + +instance Literal [Complex Double] 'R.Complex where + mkSEXPIO = mkSEXPVectorIO sing . map return + fromSEXP (hexp -> Complex v) = SVector.toList v + fromSEXP _ = + failure "fromSEXP" "Complex expected where some other expression appeared." + +instance Literal [String] 'R.String where + mkSEXPIO = + mkSEXPVectorIO sing . map (`withCString` 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." + +-- Use the default definitions included in the class declaration. +instance Literal R.Logical 'R.Logical +instance Literal Int32 'R.Int +instance Literal Double 'R.Real +instance Literal (Complex Double) 'R.Complex + +instance Literal String 'R.String where + mkSEXPIO x = mkSEXPIO [x] + fromSEXP x@(hexp -> String {}) + | [h] <- fromSEXP x = h + | otherwise = failure "fromSEXP" "Not a singleton vector." + fromSEXP _ = + 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 + +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 SingI a => Literal (SEXP s a) a where + mkSEXPIO = fmap R.unsafeRelease . return + fromSEXP = R.cast (sing :: SSEXPTYPE a) . SomeSEXP . R.unsafeRelease + +instance Literal (SomeSEXP s) 'R.Any where + -- The ANYSXP type in R plays the same role as SomeSEXP in H. It is a dummy + -- type tag, that is never seen in any object. It serves only as a stand-in + -- when the real type is not known. + mkSEXPIO (SomeSEXP s) = return . R.unsafeRelease $ R.unsafeCoerce s + fromSEXP = SomeSEXP . R.unsafeRelease + +instance 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 + mkSEXPIO = funToSEXP wrap1 + fromSEXP = unimplemented "Literal (a -> R s b) fromSEXP" + +instance (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" + +-- | A class for functions that can be converted to functions on SEXPs. +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 (Literal a la, HFunWrap b wb) + => HFunWrap (a -> b) (R.SEXP0 -> wb) where + hFunWrap f a = hFunWrap $ f $! fromSEXP (R.sexp a :: SEXP s la) + +foreign import ccall "missing_r.h funPtrToSEXP" funPtrToSEXP + :: FunPtr a -> IO (SEXP s 'R.ExtPtr) + +funToSEXP :: HFunWrap a b => (b -> IO (FunPtr b)) -> a -> IO (SEXP s 'R.ExtPtr) +funToSEXP w x = funPtrToSEXP =<< w (hFunWrap x) + +$(thWrapperLiterals 3 12) diff --git a/src/Language/R/QQ.hs b/src/Language/R/QQ.hs new file mode 100644 --- /dev/null +++ b/src/Language/R/QQ.hs @@ -0,0 +1,316 @@ +-- | +-- Copyright: (C) 2013 Amgen, Inc. +-- + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Language.R.QQ + ( r + , rexp + , rsafe + ) where + +import Control.Memory.Region +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 qualified H.Prelude as H +import Internal.Error +import Language.R (parseText, string, 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.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 System.IO.Unsafe (unsafePerformIO) + +------------------------------------------------------------------------------- +-- Compile time Quasi-Quoter -- +------------------------------------------------------------------------------- + +-- | 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) |] + , quotePat = unimplemented "quotePat" + , quoteType = unimplemented "quoteType" + , quoteDec = unimplemented "quoteDec" + } + +-- | Quasiquoter for pure R code (no side effects) and that does not depend on +-- the global environment (referential transparency). This means that all +-- symbols must appear qualified with a package namespace (whose bindings are +-- locked by default), the code must not affect R shared state in any way, +-- including the global environment, and must not perform I/O. + +-- TODO some of the above invariants can be checked statically. Do so. +rsafe :: QuasiQuoter +rsafe = QuasiQuoter + { quoteExp = \txt -> [| unsafePerformIO $ unsafeRToIO . eval =<< $(parseExp 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 () +qqLock = unsafePerformIO $ newMVar () +{-# NOINLINE qqLock #-} + +parse :: String -> Q (R.SEXP V 'R.Expr) +parse txt = runIO $ do + 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`) + +-- | 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 + +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 |] + +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 |] + +unhexpIO :: HExp s a -> IO (SEXP s a) +unhexpIO = unsafeRToIO . unhexp diff --git a/tests/R/fib-benchmark.R b/tests/R/fib-benchmark.R new file mode 100644 --- /dev/null +++ b/tests/R/fib-benchmark.R @@ -0,0 +1,10 @@ +fib <- function(n) { + if(n == 0) return(1) + if(n == 1) return(1) + return(fib(n - 1) + fib(n - 2)) +} + +cat("fib in plain R:\n") +iterations <- 10 +t <- system.time( replicate(iterations, fib(18)) ) +t / iterations diff --git a/tests/R/fib.R b/tests/R/fib.R new file mode 100644 --- /dev/null +++ b/tests/R/fib.R @@ -0,0 +1,5 @@ +fib <- function(n) { + if(n == 0) return(1) + if(n == 1) return(1) + return(fib(n - 1) + fib(n - 2)) +} diff --git a/tests/Test/Constraints.hs b/tests/Test/Constraints.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Constraints.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeOperators #-} +module Test.Constraints + ( tests ) + where + +import Foreign.R.Constraints +import qualified Foreign.R.Type as R + +import Test.Tasty +import Test.Tasty.HUnit + +import Control.Monad (guard) + +prop_reflexivity :: (a :∈ '[a]) => R.SSEXPTYPE a -> Bool +prop_reflexivity _ = True + +prop_rightExtension :: (a :∈ '[a, b]) => R.SSEXPTYPE a -> R.SSEXPTYPE b -> Bool +prop_rightExtension _ _ = True + +prop_leftExtension :: (a :∈ '[b, a]) => R.SSEXPTYPE a -> R.SSEXPTYPE b -> Bool +prop_leftExtension _ _ = True + +prop_rightAssociative :: (a :∈ '[a, b, c]) => R.SSEXPTYPE a -> R.SSEXPTYPE b -> R.SSEXPTYPE c -> Bool +prop_rightAssociative _ _ _ = True + +prop_reverse :: (a :∈ '[c, b, a]) => R.SSEXPTYPE a -> R.SSEXPTYPE b -> R.SSEXPTYPE c -> Bool +prop_reverse _ _ _ = True + +tests :: TestTree +tests = testGroup "Constraints" + [ testCase "reflexivity" $ guard $ prop_reflexivity a + , testCase "right extension" $ guard $ prop_rightExtension a b + , testCase "left extension" $ guard $ prop_leftExtension a b + , testCase "right associativity" $ guard $ prop_rightAssociative a b c + , testCase "reverse" $ guard $ prop_reverse a b c + ] + where + a = R.SInt + b = R.SReal + c = R.SLogical diff --git a/tests/Test/Event.hs b/tests/Test/Event.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Event.hs @@ -0,0 +1,87 @@ +-- | Tests for "Language.R.Event". + +{-# LANGUAGE CPP #-} +module Test.Event where + +#ifndef mingw32_HOST_OS +import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef) +import Foreign (FunPtr, Ptr, freeHaskellFunPtr) +import qualified Foreign.R.EventLoop as R +import H.Prelude +import Language.R.Event +import System.IO (hClose, hPutStrLn) +import System.IO.Temp (withSystemTempFile) +import System.Posix.IO + ( OpenMode(..) + , OpenFileFlags(..) + , closeFd + , defaultFileFlags + , openFd + ) +import System.Posix.Types (Fd) +#endif +import Test.Tasty +import Test.Tasty.HUnit + +#ifndef mingw32_HOST_OS +foreign import ccall "wrapper" wrap + :: (Ptr () -> IO ()) + -> IO (FunPtr (Ptr () -> IO ())) +#endif + +tests :: TestTree +tests = testGroup "events" +#ifdef mingw32_HOST_OS + [] +#else + [ testCase "addInputHandler increases handler count" $ do + withReadFd $ \fd -> do + f <- wrap $ \_ -> return () + ref1 <- newIORef (0 :: Int) + forIH_ inputHandlers $ \_ -> modifyIORef' ref1 (+1) + _ <- R.addInputHandler inputHandlers fd f 0 + ref2 <- newIORef 0 + forIH_ inputHandlers $ \_ -> modifyIORef' ref2 (+1) + n1 <- readIORef ref1 + n2 <- readIORef ref2 + n1 @?= n2 - 1 + freeHaskellFunPtr f + + , testCase "removeInputHandler decreases handler count" $ do + withReadFd $ \fd -> do + f <- wrap $ \_ -> return () + ih <- R.addInputHandler inputHandlers fd f 0 + (@?= True) =<< R.removeInputHandler inputHandlers ih + freeHaskellFunPtr f + + , testCase "file events (select)" $ do + withReadFd $ \fd -> do + ref <- newIORef False + f <- wrap $ \_ -> writeIORef ref True + _ <- R.addInputHandler inputHandlers fd f 0 + runRegion $ refresh + (@?= True) =<< readIORef ref + freeHaskellFunPtr f +-- XXX GHC bug: https://ghc.haskell.org/trac/ghc/ticket/10736 +{- + , testCase "file events (poll)" $ do + withReadFd $ \fd -> do + mv <- newEmptyMVar + f <- wrap $ \_ -> putMVar mv () + _ <- R.addInputHandler inputHandlers fd f 0 + Just evtmgr <- getSystemEventManager + runRegion $ void $ registerREvents evtmgr + Just () <- timeout 1000000 $ takeMVar mv + freeHaskellFunPtr f +-} + ] + where + withReadFd :: (Fd -> IO ()) -> IO () + withReadFd action = + withSystemTempFile "inline-r-" $ \path h -> do + hPutStrLn h "hello" + hClose h + fd <- openFd path ReadOnly Nothing defaultFileFlags{ nonBlock = True } + action fd + closeFd fd +#endif diff --git a/tests/Test/FunPtr.hs b/tests/Test/FunPtr.hs new file mode 100644 --- /dev/null +++ b/tests/Test/FunPtr.hs @@ -0,0 +1,67 @@ +{-# Language FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# Language GADTs #-} +{-# Language TemplateHaskell #-} +{-# Language ViewPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE QuasiQuotes #-} +module Test.FunPtr + ( tests ) + where + +import Control.Memory.Region +import H.Prelude +import qualified Language.R.Internal.FunWrappers as R +import qualified Foreign.R as R +import qualified Foreign.R.Type as SingR +import qualified Language.R.Internal as R (r2) +import Language.R.QQ + +import Test.Tasty hiding (defaultMain) +import Test.Tasty.HUnit + +import Control.Applicative +import Control.Concurrent.MVar +import Control.Monad +import Data.ByteString.Char8 +import Foreign (FunPtr, castFunPtr) +import System.Mem.Weak +import System.Mem +import Prelude -- silence AMP warning + +data HaveWeak a b = HaveWeak + (R.SEXP0 -> IO R.SEXP0) + (MVar (Weak (FunPtr (R.SEXP0 -> IO R.SEXP0)))) + +foreign import ccall "missing_r.h funPtrToSEXP" funPtrToSEXP + :: FunPtr () -> IO (R.SEXP s 'R.Any) + +instance Literal (HaveWeak a b) 'R.ExtPtr where + mkSEXPIO (HaveWeak a box) = do + z <- R.wrap1 a + putMVar box =<< mkWeakPtr z Nothing + fmap R.unsafeCoerce . funPtrToSEXP . castFunPtr $ z + fromSEXP = error "not now" + +tests :: TestTree +tests = testGroup "funptr" + [ testCase "funptr is freed from R" $ do + ((Nothing @=?) =<<) $ do + hwr <- HaveWeak return <$> newEmptyMVar + _ <- R.withProtected (mkSEXPIO hwr) $ + \sf -> R.withProtected (mkSEXPIO (2::Double)) $ \z -> + return $ R.r2 (Data.ByteString.Char8.pack ".Call") sf z + replicateM_ 10 (R.allocVector SingR.SReal 1024 :: IO (R.SEXP V 'R.Real)) + replicateM_ 10 R.gc + replicateM_ 10 performGC + (\(HaveWeak _ x) -> takeMVar x >>= deRefWeak) hwr + , testCase "funptr works in quasi-quotes" $ + (((2::Double) @=?) =<<) $ unsafeRToIO $ do + let foo = (\x -> return $ x + 1) :: Double -> R s Double + s <- [r| foo_hs(1) |] + return $ dynSEXP s + ] diff --git a/tests/Test/GC.hs b/tests/Test/GC.hs new file mode 100644 --- /dev/null +++ b/tests/Test/GC.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.GC + ( tests ) + where + +import Control.Memory.Region +import H.Prelude +import qualified Foreign.R as R +import qualified Foreign.R.Type as SingR +import Language.R.QQ + +import Control.Exception (bracket) +import Test.Tasty hiding (defaultMain) +import Test.Tasty.HUnit +import System.Directory + +import System.Mem (performMajorGC) + +tests :: TestTree +tests = testGroup "HVal" + [ testCase "Automatic value is not collected by R GC" $ + bracket getCurrentDirectory setCurrentDirectory $ const $ do + ((assertBool "Automatic value was collected" . isInt) =<<) $ do + unsafeRToIO $ 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" $ + bracket getCurrentDirectory setCurrentDirectory $ const $ do + ((assertBool "Automatic value was collected" . isInt) =<<) $ do + runRegion $ do + _ <- [r| gctorture(TRUE) |] + x <- automatic =<< io (R.allocVector SingR.SInt 1024 :: IO (R.SEXP V 'R.Int)) + y <- return $ R.release x + io $ performMajorGC + _ <- io $ R.allocList 1 + return $! R.typeOf y + ] + where + isInt (R.Int) = True + isInt _ = False diff --git a/tests/Test/HExp.hs b/tests/Test/HExp.hs new file mode 100644 --- /dev/null +++ b/tests/Test/HExp.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE QuasiQuotes #-} +module Test.HExp ( tests ) where + +import Language.R.HExp +import Foreign.R as R + +import Foreign.C + +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "hexp" + [ testGroup "Cyclyc structures" + [ testCase "naked-cyclic-structure" $ + R.withProtected (withCString "test" R.mkChar) $ \chr -> do + R.withProtected (selfSymbol chr) $ \slf -> do + assertBool "selfSymbol==selfSymbol" (hexp slf === hexp slf) + ] + ] diff --git a/tests/Test/Regions.hs b/tests/Test/Regions.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Regions.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +module Test.Regions + ( tests ) + where + +import H.Prelude +import qualified Foreign.R as R +import Language.R.QQ + +import Test.Tasty hiding (defaultMain) +import Test.Tasty.HUnit +import Foreign + +import System.Directory (getCurrentDirectory, setCurrentDirectory) +import Control.Exception (bracket) + +#include + +preserveDirectory :: IO a -> IO a +preserveDirectory = + bracket getCurrentDirectory setCurrentDirectory . const + +#if defined(R_VERSION) && R_VERSION >= R_Version(3, 1, 0) +foreign import ccall "&R_PPStackTop" ppStackTop :: Ptr Int +#endif + +assertBalancedStack :: IO () -> IO () +#if defined(R_VERSION) && R_VERSION >= R_Version(3, 1, 0) +assertBalancedStack m = do + i <- peek ppStackTop + m + j <- peek ppStackTop + assertEqual "protection stack should be balanced" i j +#else +assertBalancedStack m = do + putStrLn "Warning: Cannot check stack balance on R < 3.1. Disabling check." + m +#endif + +tests :: TestTree +tests = testGroup "regions" + [ testCase "qq-dont-leak" $ + preserveDirectory $ assertBalancedStack $ + runRegion $ do + _ <- [r| gctorture(TRUE) |] + R.SomeSEXP x <- [r| 1 |] + _ <- io $ R.allocList 1 + io $ assertEqual "value is protected" R.Real (R.typeOf x) + _ <- [r| gctorture(FALSE) |] + return () + , testCase "mksexp-dont-leak" $ + preserveDirectory $ assertBalancedStack $ + runRegion $ do + _ <- [r| gctorture(TRUE) |] + x <- mkSEXP (1::Int32) + _ <- io $ R.allocList 1 + 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 () + return (z::Int32) + ] diff --git a/tests/Test/Scripts.hs b/tests/Test/Scripts.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Scripts.hs @@ -0,0 +1,23 @@ +-- | List of shootout programs to test. In its own module due to TH stage +-- restriction. + +module Test.Scripts where + +import System.FilePath + +scripts :: [FilePath] +scripts = map ("tests/shootout" ) + [ "binarytrees.R" +-- , "fannkuchredux.R" -- XXX takes long + , "fasta.R" + , "fastaredux.R" +-- , "knucleotide.R" -- XXX seems to require command line arguments + , "mandelbrot-noout.R" +-- , "mandelbrot.R" -- XXX produces some binary output which causes readProcess to fail + , "nbody.R" + , "pidigits.R" +-- , "regexdna.R" -- XXX seems to require command line arguments +-- , "reversecomplement.R" -- XXX seems to require command line arguments + , "spectralnorm-math.R" + , "spectralnorm.R" + ] diff --git a/tests/Test/Vector.hs b/tests/Test/Vector.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Vector.hs @@ -0,0 +1,131 @@ +-- | +-- Copyright: (C) 2013 Amgen, Inc. +-- (C) 2015 Tweag I/O Limited. +-- +-- Tests for the "Data.Vector.SEXP" module. + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Test.Vector where + +import Data.AEq +import Data.Int +import Data.Singletons +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 +import qualified Data.Vector.Fusion.Stream as S +import qualified Foreign.R as R +import H.Prelude hiding (Show) +import Language.R.QQ +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Tasty.HUnit +import Test.QuickCheck.Assertions + +instance (Arbitrary a, V.VECTOR s ty a) => Arbitrary (V.Vector s ty a) where + arbitrary = fmap V.fromList arbitrary + +instance Arbitrary a => Arbitrary (S.Stream a) where + arbitrary = fmap S.fromList arbitrary + +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) + +testIdentity :: (Eq a, Show a, Arbitrary a, V.VECTOR s ty a, AEq a) => V.Vector s ty a -> TestTree +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 "stream.unstream == id" (prop_stream_unstream dummy) + ] + where + prop_fromList_toList (_:: V.Vector s ty a) (v :: V.Vector s ty a) + = (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_stream_unstream (_ :: V.Vector ty a) (s :: S.Stream a) +-- = ((G.stream :: V.Vector ty a -> S.Stream a) . G.unstream) s == s + + +testPolymorphicFunctions :: (Eq a, Show a, Arbitrary a, V.VECTOR s ty a, AEq a) => V.Vector s ty a -> TestTree +testPolymorphicFunctions dummy = testGroup "Polymorphic functions." + [ -- Length information + testProperty "prop_length" (prop_length dummy) + , testProperty "prop_null" (prop_null dummy) + , testProperty "prop_index" (prop_index dummy) + , testProperty "prop_head" (prop_head dummy) + , testProperty "prop_last" (prop_last dummy) + ] + where + prop_length (_:: V.Vector s ty a) (v :: V.Vector s ty a) + = (length . V.toList) v ~==? V.length v + prop_null (_:: V.Vector s ty a) (v :: V.Vector s ty a) + = (null . V.toList) v ~==? V.null v + prop_index (_:: V.Vector s ty a) (v :: V.Vector s ty a, j::Int) + | V.length v == 0 = True + | otherwise = let i = j `mod` V.length v in ((\w -> w !! i) . V.toList) v == (v V.! i) + prop_head (_:: V.Vector s ty a) (v :: V.Vector s ty a) + | V.length v == 0 = True + | otherwise = (head . V.toList) v == V.head v + prop_last (_:: V.Vector s ty a) (v :: V.Vector s ty a) + | V.length v == 0 = True + | otherwise = (last . V.toList) v == V.last v + +testGeneralSEXPVector :: (Eq a, Show a, Arbitrary a, V.VECTOR s ty a, AEq a) => V.Vector s ty a -> TestTree +testGeneralSEXPVector dummy = testGroup "General Vector" + [ testIdentity dummy + , testPolymorphicFunctions dummy + ] + +testNumericSEXPVector :: (Eq a, Show a, Arbitrary a, V.VECTOR s ty a, AEq a) => V.Vector s ty a -> TestTree +testNumericSEXPVector dummy = testGroup "Test Numeric Vector" + [ testGeneralSEXPVector dummy + ] + +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) + io $ assertEqual "Length should be equal to list length" 3 (V.length 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 + 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 + VM.unsafeWrite mutV 0 7 + return $ immV V.! 0 + i @?= 1 + +tests :: TestTree +tests = testGroup "Tests." + [ testGroup "Data.Vector.Storable.Vector (Int32)" + [testNumericSEXPVector (undefined :: Data.Vector.SEXP.Vector s 'R.Int Int32)] + , testGroup "Data.Vector.Storable.Vector (Double)" + [testNumericSEXPVector (undefined :: Data.Vector.SEXP.Vector s 'R.Real Double)] + , testGroup "Regression tests" [fromListLength + ,vectorIsImmutable + ] + ] diff --git a/tests/bench-hexp.hs b/tests/bench-hexp.hs new file mode 100644 --- /dev/null +++ b/tests/bench-hexp.hs @@ -0,0 +1,78 @@ +-- A benchmark comparing hexp with integer. +-- +-- To get the lowest results: +-- +-- * define integer as an unsafe foreign call +-- +-- * replace 'System.IO.Unsafe.unsafePerformIO' with +-- 'Control.Monad.Primitive.unsafeInlineIO' in the definition +-- of 'hexp' and 'Foreign.R.typeOf'. +-- +-- * Add an INLINE pragma for peekHExp +-- +-- > {-# INLINE peekHExp #-} +-- +-- * redefine hexp as +-- +-- > hexp :: SEXP a -> HExp a +-- > hexp = unsafeInlineIO . peekHExp +-- > {-# INLINE hexp #-} +-- +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} + +import Foreign.R (integer, SEXP, SomeSEXP(..)) +import qualified Foreign.R as R (SSEXPTYPE, SEXPTYPE(Int), typeOf, cast) +import H.Prelude (withEmbeddedR, defaultConfig) +import Language.R.Literal (mkSEXPIO) +import Language.R.HExp (hexp, HExp(..)) +import Data.Singletons (sing) + +import Control.Monad.Primitive +import Criterion.Main +import Data.Int +import Data.Vector.Generic (basicUnsafeIndexM) +import Foreign.Ptr (Ptr) +import Foreign.Storable (peek) +import System.IO.Unsafe (unsafePerformIO) + + +main :: IO () +main = withEmbeddedR H.Prelude.defaultConfig $ do + x <- mkSEXPIO (1 :: Int32) + defaultMain + [ bgroup "vector access" + [ bench "typeof>integer" $ whnfIO $ benchInteger x + , bench "hexp>unsafeIndex" $ whnf benchHExp x + , bench "unsafe-integer" $ whnfIO $ benchUncheckedInteger x + , bench "hexp-cast" $ whnf benchCast (SomeSEXP x) + +-- , bench "unsafePerformIO" $ whnf unsafePerformIO $ return x +-- , bench "unsafeInlineIO" $ whnf unsafeInlineIO $ return x +-- , bench "(+)" $ whnf (\i -> i + 1) (1 :: Int) + , bench "unsafePerformIO" $ whnf unsafePerformIO $ return x + , bench "unsafeInlineIO" $ whnf unsafeInlineIO $ return x + , bench "(+)" $ whnf (\i -> i + 1) (1 :: Int) + ] + ] + +benchInteger :: SEXP s 'R.Int -> IO Int32 +benchInteger x = do + case R.typeOf x of + R.Int -> integer x >>= (peek :: Ptr Int32 -> IO Int32) + _ -> error "unexpected SEXP" + +benchHExp :: SEXP s a -> Int32 +benchHExp x = + case hexp x of + Int s -> unsafeInlineIO $ basicUnsafeIndexM s 0 + _ -> error "unexpected SEXP" + +benchUncheckedInteger :: SEXP s 'R.Int -> IO Int32 +benchUncheckedInteger x = integer x >>= (peek :: Ptr Int32 -> IO Int32) + +benchCast :: SomeSEXP s -> Int32 +benchCast x = + let y = R.cast (sing :: R.SSEXPTYPE 'R.Int) x + in case hexp y of +  Int s -> unsafeInlineIO $ basicUnsafeIndexM s 0 diff --git a/tests/bench-qq.hs b/tests/bench-qq.hs new file mode 100644 --- /dev/null +++ b/tests/bench-qq.hs @@ -0,0 +1,51 @@ +-- Copyright: (C) 2013 Amgen, Inc. +-- +-- This program executes the benchmark of the fib function using R and +-- the compile-time qq. +-- + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +import Foreign.R as R +import Language.R as R +import H.Prelude as H +import Language.R.QQ + +import Control.Applicative +import Criterion.Main +import Data.Int +import Language.Haskell.TH.Quote + +import System.FilePath +import Prelude -- Silence AMP warning + +fib :: Int -> Int +fib 0 = 0 +fib 1 = 1 +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))) |] + +main :: IO () +main = do + H.withEmbeddedR H.defaultConfig $ runRegion $ do + _ <- $(quoteExp (quoteFile r) ("tests" "R" "fib.R")) + io $ defaultMain [ + bgroup "fib" + [ bench "pure Haskell" $ + nf fib 18 + , bench "compile-time-qq" $ + nfIO $ unsafeRToIO [r| fib(18) |] + , bench "compile-time-qq-hybrid" $ + nfIO $ unsafeRToIO $ hFib =<< mkSEXP (18 :: Int32) + ] + ] diff --git a/tests/shootout/binarytrees.R b/tests/shootout/binarytrees.R new file mode 100644 --- /dev/null +++ b/tests/shootout/binarytrees.R @@ -0,0 +1,49 @@ +# ------------------------------------------------------------------ +# The Computer Language Shootout +# http://shootout.alioth.debian.org/ +# +# Contributed by Leo Osvald +# ------------------------------------------------------------------ + +tree <- function(item, depth) { + if (depth == 0L) + return(c(item, NA, NA)) + # it is ridiculous that this doesn't help + next_depth <- depth - 1L + right_item <- 2L * item + left_item <- right_item - 1L + return(list(item, + tree(left_item, next_depth), + tree(right_item, next_depth))) +} + +check <- function(tree) + if(is.na(tree[[2]][[1]])) tree[[1]] else tree[[1]] + check(tree[[2]]) - check(tree[[3]]) + +binarytrees <- function(args) { + n = if (length(args)) as.integer(args[[1]]) else 10L + + min_depth <- 4L + max_depth <- max(min_depth + 2L, n) + stretch_depth <- max_depth + 1L + + cat(sep="", "stretch tree of depth ", stretch_depth, "\t check: ", + check(tree(0L, stretch_depth)), "\n") + + long_lived_tree <- tree(0L, max_depth) + + for (depth in seq(min_depth, max_depth, 2L)) { + iterations <- as.integer(2^(max_depth - depth + min_depth)) + check_sum <- sum(sapply( + 1:iterations, + function(i) check(tree(i, depth)) + check(tree(-i, depth)))) + cat(sep="", iterations * 2L, "\t trees of depth ", depth, "\t check: ", + check_sum, "\n") + } + + cat(sep="", "long lived tree of depth ", max_depth, "\t check: ", + check(long_lived_tree), "\n") +} + +if (!exists("i_am_wrapper")) + binarytrees(commandArgs(trailingOnly=TRUE)) diff --git a/tests/shootout/fannkuchredux.R b/tests/shootout/fannkuchredux.R new file mode 100644 --- /dev/null +++ b/tests/shootout/fannkuchredux.R @@ -0,0 +1,74 @@ +# ------------------------------------------------------------------ +# The Computer Language Shootout +# http://shootout.alioth.debian.org/ +# +# Contributed by Leo Osvald +# ------------------------------------------------------------------ + +fannkuch <- function(n) { + one_two = c(1, 2) + two_one = c(2, 1) + two_three = c(2, 3) + three_two = c(3, 2) + if (n > 3L) + rxrange = 3:(n - 1) + else + rxrange = integer(0) + + max_flip_count <- 0L + perm_sign <- TRUE + checksum <- 0L + perm1 <- 1:n + count <- 0:(n - 1L) + while (TRUE) { + if (k <- perm1[[1L]]) { + perm <- perm1 + flip_count <- 1L + while ((kk <- perm[[k]]) > 1L) { + k_range = 1:k + perm[k_range] <- rev.default(perm[k_range]) + flip_count <- flip_count + 1L + k <- kk + kk <- perm[[kk]] + } + max_flip_count <- max(max_flip_count, flip_count) + checksum <- checksum + if (perm_sign) flip_count else -flip_count + } + + # Use incremental change to generate another permutation + if (perm_sign) { + perm1[one_two] <- perm1[two_one] + perm_sign = FALSE + } else { + perm1[two_three] <- perm1[three_two] + perm_sign = TRUE + was_break <- FALSE + for (r in rxrange) { + if (count[[r]]) { + was_break <- TRUE + break + } + count[[r]] <- r - 1L + perm0 <- perm1[[1L]] + perm1[1:r] <- perm1[2:(r + 1L)] + perm1[[r + 1L]] <- perm0 + } + if (!was_break) { + r <- n + if (!count[[r]]) { + cat(checksum, "\n", sep="") + return(max_flip_count) + } + } + count[[r]] <- count[[r]] - 1L + } + } +} + +fannkuchredux <- function(args) { + n = if (length(args)) as.integer(args[[1]]) else 12L + cat("Pfannkuchen(", n, ") = ", fannkuch(n), "\n", sep="") +} + +if (!exists("i_am_wrapper")) + fannkuchredux(commandArgs(trailingOnly=TRUE)) diff --git a/tests/shootout/fasta.R b/tests/shootout/fasta.R new file mode 100644 --- /dev/null +++ b/tests/shootout/fasta.R @@ -0,0 +1,89 @@ +# ------------------------------------------------------------------ +# The Computer Language Shootout +# http://shootout.alioth.debian.org/ +# +# Contributed by Leo Osvald +# ------------------------------------------------------------------ +width <- 60L +myrandom_last <- 42L +myrandom <- function(m) { + myrandom_last <<- (myrandom_last * 3877L + 29573L) %% 139968L + return(m * myrandom_last / 139968) +} + +alu <- paste( + "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG", + "GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA", + "CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT", + "ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA", + "GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG", + "AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC", + "AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA", + sep="", collapse="") + +iub <- matrix(c( + c(0.27, 'a'), + c(0.12, 'c'), + c(0.12, 'g'), + c(0.27, 't'), + c(0.02, 'B'), + c(0.02, 'D'), + c(0.02, 'H'), + c(0.02, 'K'), + c(0.02, 'M'), + c(0.02, 'N'), + c(0.02, 'R'), + c(0.02, 'S'), + c(0.02, 'V'), + c(0.02, 'W'), + c(0.02, 'Y') +), 2) + +homosapiens <- matrix(c( + c(0.3029549426680, 'a'), + c(0.1979883004921, 'c'), + c(0.1975473066391, 'g'), + c(0.3015094502008, 't') +), 2) + +repeat_fasta <- function(s, count) { + chars <- strsplit(s, split="")[[1]] + len <- nchar(s) + s2 <- c(chars, chars[1:width]) + pos <- 1L + while (count) { + line <- min(width, count) + next_pos <- pos + line + cat(s2[pos:(next_pos - 1)], "\n", sep="") + pos <- next_pos + if (pos > len) pos <- pos - len + count <- count - line + } +} + +random_fasta <- function(genelist, count) { + psum <- cumsum(genelist[1,]) + while (count) { + line <- min(width, count) + + rs <- double(line) + for (i in 1:line) + rs[[i]] <- myrandom(1) + + cat(genelist[2, colSums(outer(psum, rs, "<")) + 1], "\n", sep='') + count <- count - line + } +} + +fasta <- function(args) { + n = if (length(args)) as.integer(args[[1]]) else 1000L + cat(">ONE Homo sapiens alu\n") + repeat_fasta(alu, 2 * n) + cat(">TWO IUB ambiguity codes\n") + random_fasta(iub, 3L * n) + cat(">THREE Homo sapiens frequency\n") + random_fasta(homosapiens, 5L * n) +} + +if (!exists("i_am_wrapper")) + fasta(commandArgs(trailingOnly=TRUE)) diff --git a/tests/shootout/fastaredux.R b/tests/shootout/fastaredux.R new file mode 100644 --- /dev/null +++ b/tests/shootout/fastaredux.R @@ -0,0 +1,114 @@ +# ------------------------------------------------------------------ +# The Computer Language Shootout +# http://shootout.alioth.debian.org/ +# +# Contributed by Leo Osvald +# ------------------------------------------------------------------ +width = 60L +lookup_size = 4096L +lookup_scale = as.double(lookup_size - 1L) + +alu = paste( + "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGG", + "GAGGCCGAGGCGGGCGGATCACCTGAGGTCAGGAGTTCGAGA", + "CCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAAT", + "ACAAAAATTAGCCGGGCGTGGTGGCGCGCGCCTGTAATCCCA", + "GCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGG", + "AGGCGGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCC", + "AGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA", + sep="", collapse="") + +iub = matrix(c( + c(0.27, 'a'), + c(0.12, 'c'), + c(0.12, 'g'), + c(0.27, 't'), + c(0.02, 'B'), + c(0.02, 'D'), + c(0.02, 'H'), + c(0.02, 'K'), + c(0.02, 'M'), + c(0.02, 'N'), + c(0.02, 'R'), + c(0.02, 'S'), + c(0.02, 'V'), + c(0.02, 'W'), + c(0.02, 'Y') +), 2) + +homosapiens = matrix(c( + c(0.3029549426680, 'a'), + c(0.1979883004921, 'c'), + c(0.1975473066391, 'g'), + c(0.3015094502008, 't') +), 2) + +random <- 42L +random_next_lookup <- function() { + random <<- (random * 3877L + 29573L) %% 139968L + return(random * (lookup_scale / 139968)) # TODO +} + +repeat_fasta <- function(s, count) { + chars = strsplit(s, split="")[[1]] + len = nchar(s) + s2 = c(chars, chars[1:width]) + pos <- 1L + while (count) { + line = min(width, count) + next_pos <- pos + line + cat(s2[pos:(next_pos - 1)], "\n", sep="") + pos <- next_pos + if (pos > len) pos <- pos - len + count <- count - line + } +} + +random_fasta <- function(genelist, count) { + n = ncol(genelist) + lookup <- integer(lookup_size) + cprob_lookup <- cumsum(genelist[1, ]) * lookup_scale + cprob_lookup[[n]] <- lookup_size - 1 + + j <- 1L + for (i in 1:lookup_size) { + while (cprob_lookup[[j]] + 1L < i) + j <- j + 1L + lookup[[i]] <- j + } + + while (count) { + line <- min(width, count) + + rs <- double(line) + for (i in 1:line) + rs[[i]] <- random_next_lookup() + + inds <- lookup[rs + 1L] + missed <- which(cprob_lookup[inds] < rs) + if (length(missed)) + repeat { + inds[missed] <- inds[missed] + 1L + missed <- which(cprob_lookup[inds] < rs) + if (!length(missed)) + break + } + + cat(paste(genelist[2, inds], collapse="", sep=""), "\n", sep="") + count <- count - line + } + +} + +fastaredux <- function(args) { + n = if (length(args)) as.integer(args[[1]]) else 1000L + cat(">ONE Homo sapiens alu\n") + repeat_fasta(alu, 2 * n) + cat(">TWO IUB ambiguity codes\n") + random_fasta(iub, 3L * n) + cat(">THREE Homo sapiens frequency\n") + random_fasta(homosapiens, 5L * n) +} + +if (!exists("i_am_wrapper")) + fastaredux(commandArgs(trailingOnly=TRUE)) diff --git a/tests/shootout/knucleotide.R b/tests/shootout/knucleotide.R new file mode 100644 --- /dev/null +++ b/tests/shootout/knucleotide.R @@ -0,0 +1,85 @@ +# ------------------------------------------------------------------ +# The Computer Language Shootout +# http://shootout.alioth.debian.org/ +# +# Contributed by Leo Osvald +# ------------------------------------------------------------------ + +gen_freq <- function(seq, frame) { + frame <- frame - 1L + ns <- length(seq) - frame + h <- new.env(emptyenv(), hash=TRUE) + for (i in 1:ns) { + subseq_str = paste(seq[i:(i + frame)], collapse="", sep="") + if (exists(subseq_str, h, inherits=FALSE)) + cnt <- get(subseq_str, h, inherits=FALSE) + else + cnt <- 0L + assign(subseq_str, cnt + 1L, h) + } + return(sapply(ls(h), function(k) get(k, h, inherits=FALSE))) +} + +sort_seq <- function(seq, len) { + fs <- gen_freq(seq, len) + seqs <- names(fs) + inds <- order(-fs, seqs) + cat(paste.(seqs[inds], 100 * fs[inds] / sum(fs), collapse="\n", digits=3), + "\n") +} + +find_seq <- function(seq, s) { + freqs <- gen_freq(seq, nchar(s)) + if (s %in% names(freqs)) + return(freqs[[s]]) + return(0L) +} + +knucleotide <- function(args) { + in_filename = args[[1]] + f <- file(in_filename, "r") + while (length(line <- readLines(f, n=1, warn=FALSE))) { + first_char <- substr(line, 1L, 1L) + if (first_char == '>' || first_char == ';') + if (substr(line, 2L, 3L) == 'TH') + break + } + + n <- 0L + cap <- 8L + str_buf <- character(cap) + while (length(line <- scan(f, what="", nmax=1, quiet=TRUE))) { + first_char <- substr(line, 1L, 1L) + if (first_char == '>' || first_char == ';') + break + n <- n + 1L + # ensure O(N) resizing (instead of O(N^2)) + str_buf[[cap <- if (cap < n) 2L * cap else cap]] <- "" + str_buf[[n]] <- line + } + length(str_buf) <- n + close(f) + seq <- strsplit(paste(str_buf, collapse=""), split="")[[1]] + + for (frame in 1:2) + sort_seq(seq, frame) + for (s in c("GGT", "GGTA", "GGTATT", "GGTATTTTAATT", "GGTATTTTAATTTATAGT")) + cat(find_seq(seq, tolower(s)), sep="\t", s, "\n") +} + +paste. <- function (..., digits=16, sep=" ", collapse=NULL) { + args <- list(...) + if (length(args) == 0) + if (length(collapse) == 0) character(0) + else "" + else { + for(i in seq(along=args)) + if(is.numeric(args[[i]])) + args[[i]] <- as.character(round(args[[i]], digits)) + else args[[i]] <- as.character(args[[i]]) + .Internal(paste(args, sep, collapse)) + } +} + +if (!exists("i_am_wrapper")) + knucleotide(commandArgs(trailingOnly=TRUE)) diff --git a/tests/shootout/mandelbrot-noout.R b/tests/shootout/mandelbrot-noout.R new file mode 100644 --- /dev/null +++ b/tests/shootout/mandelbrot-noout.R @@ -0,0 +1,37 @@ +# ------------------------------------------------------------------ +# The Computer Language Shootout +# http://shootout.alioth.debian.org/ +# +# Contributed by Leo Osvald +# ------------------------------------------------------------------ + +lim <- 2 +iter <- 50 +# Turn off warnings that appear on Windows, so that we can compare +# the output without the warning messages. +options ( warn = -1) + +mandelbrot_noout <- function(args) { + n = if (length(args)) as.integer(args[[1]]) else 200L + n_mod8 = n %% 8L + pads <- if (n_mod8) rep.int(0, 8L - n_mod8) else integer(0) + p <- rep(as.integer(rep.int(2, 8) ^ (7:0)), length.out=n) + + cat("P4\n") + cat(n, n, "\n") + bin_con <- pipe("cat", "wb") + for (y in 0:(n-1)) { + c <- 2 * 0:(n-1) / n - 1.5 + 1i * (2 * y / n - 1) + z <- rep(0+0i, n) + i <- 0L + while (i < iter) { # faster than for loop + z <- z * z + c + i <- i + 1L + } + bits <- as.integer(abs(z) <= lim) + bytes <- as.raw(colSums(matrix(c(bits * p, pads), 8L))) + } +} + +if (!exists("i_am_wrapper")) + mandelbrot_noout(commandArgs(trailingOnly=TRUE)) diff --git a/tests/shootout/mandelbrot.R b/tests/shootout/mandelbrot.R new file mode 100644 --- /dev/null +++ b/tests/shootout/mandelbrot.R @@ -0,0 +1,36 @@ +# ------------------------------------------------------------------ +# The Computer Language Shootout +# http://shootout.alioth.debian.org/ +# +# Contributed by Leo Osvald +# ------------------------------------------------------------------ + +lim <- 2 +iter <- 50 + +mandelbrot <- function(args) { + n = if (length(args)) as.integer(args[[1]]) else 200L + n_mod8 = n %% 8L + pads <- if (n_mod8) rep.int(0, 8L - n_mod8) else integer(0) + p <- rep(as.integer(rep.int(2, 8) ^ (7:0)), length.out=n) + + cat("P4\n") + cat(n, n, "\n") + bin_con <- pipe("cat", "wb") + for (y in 0:(n-1)) { + c <- 2 * 0:(n-1) / n - 1.5 + 1i * (2 * y / n - 1) + z <- rep(0+0i, n) + i <- 0L + while (i < iter) { # faster than for loop + z <- z * z + c + i <- i + 1L + } + bits <- as.integer(abs(z) <= lim) + bytes <- as.raw(colSums(matrix(c(bits * p, pads), 8L))) + writeBin(bytes, bin_con) + flush(bin_con) + } +} + +if (!exists("i_am_wrapper")) + mandelbrot(commandArgs(trailingOnly=TRUE)) diff --git a/tests/shootout/nbody.R b/tests/shootout/nbody.R new file mode 100644 --- /dev/null +++ b/tests/shootout/nbody.R @@ -0,0 +1,108 @@ +# ------------------------------------------------------------------ +# The Computer Language Shootout +# http://shootout.alioth.debian.org/ +# +# Contributed by Leo Osvald +# ------------------------------------------------------------------ + +pi <- 3.141592653589793 +solar_mass <- 4 * pi * pi +days_per_year <- 365.24 +n_bodies <- 5 + +body_x <- c( + 0, # sun + 4.84143144246472090e+00, # jupiter + 8.34336671824457987e+00, # saturn + 1.28943695621391310e+01, # uranus + 1.53796971148509165e+01 # neptune +) +body_y <- c( + 0, # sun + -1.16032004402742839e+00, # jupiter + 4.12479856412430479e+00, # saturn + -1.51111514016986312e+01, # uranus + -2.59193146099879641e+01 # neptune +) +body_z <- c( + 0, # sun + -1.03622044471123109e-01, # jupiter + -4.03523417114321381e-01, # saturn + -2.23307578892655734e-01, # uranus + 1.79258772950371181e-01 # neptune +) + +body_vx <- c( + 0, # sun + 1.66007664274403694e-03 * days_per_year, # jupiter + -2.76742510726862411e-03 * days_per_year, # saturn + 2.96460137564761618e-03 * days_per_year, # uranus + 2.68067772490389322e-03 * days_per_year # neptune +) +body_vy <- c( + 0, # sun + 7.69901118419740425e-03 * days_per_year, # jupiter + 4.99852801234917238e-03 * days_per_year, # saturn + 2.37847173959480950e-03 * days_per_year, # uranus + 1.62824170038242295e-03 * days_per_year # neptune +) +body_vz <- c( + 0, # sun + -6.90460016972063023e-05 * days_per_year, # jupiter + 2.30417297573763929e-05 * days_per_year, # saturn + -2.96589568540237556e-05 * days_per_year, # uranus + -9.51592254519715870e-05 * days_per_year # neptune +) + +body_mass <- c( + solar_mass, # sun + 9.54791938424326609e-04 * solar_mass, # jupiter + 2.85885980666130812e-04 * solar_mass, # saturn + 4.36624404335156298e-05 * solar_mass, # uranus + 5.15138902046611451e-05 * solar_mass # neptune +) + +offset_momentum <- function() { + body_vx[[1]] <<- -sum(body_vx * body_mass) / solar_mass + body_vy[[1]] <<- -sum(body_vy * body_mass) / solar_mass + body_vz[[1]] <<- -sum(body_vz * body_mass) / solar_mass +} + +advance <- function(dt) { + dxx <- outer(body_x, body_x, "-") # ~2x faster then nested for loops + dyy <- outer(body_y, body_y, "-") + dzz <- outer(body_z, body_z, "-") + distance <- sqrt(dxx * dxx + dyy * dyy + dzz * dzz) + mag <- dt / (distance * distance * distance) # ~fast as distance^3 + diag(mag) <- 0 + body_vx <<- body_vx - as.vector((dxx * mag) %*% body_mass) + body_vy <<- body_vy - as.vector((dyy * mag) %*% body_mass) + body_vz <<- body_vz - as.vector((dzz * mag) %*% body_mass) + body_x <<- body_x + dt * body_vx + body_y <<- body_y + dt * body_vy + body_z <<- body_z + dt * body_vz +} + +energy <- function() { + dxx <- outer(body_x, body_x, "-") + dyy <- outer(body_y, body_y, "-") + dzz <- outer(body_z, body_z, "-") + distance <- sqrt(dxx * dxx + dyy * dyy + dzz * dzz) + q <- (body_mass %o% body_mass) / distance + return(sum(0.5 * body_mass * + (body_vx * body_vx + body_vy * body_vy + body_vz * body_vz)) - + sum(q[upper.tri(q)])) +} + +nbody <- function(args) { + n = if (length(args)) as.integer(args[[1]]) else 1000L + options(digits=9) + offset_momentum() + cat(energy(), "\n") + for (i in 1:n) + advance(0.01) + cat(energy(), "\n") +} + +if (!exists("i_am_wrapper")) + nbody(commandArgs(trailingOnly=TRUE)) diff --git a/tests/shootout/pidigits.R b/tests/shootout/pidigits.R new file mode 100644 --- /dev/null +++ b/tests/shootout/pidigits.R @@ -0,0 +1,407 @@ + +# Constructors and string conversion functions + +zero_mag = integer(0) +zero = c(0L, zero_mag) # ( = 0L ) +one_mag = c(1L) +one = c(1L, one_mag) +ten_mag = c(10L) +ten = c(1L, ten_mag) + +elem_max = 10000 +elem_digits = as.integer(log10(elem_max)) + +signum <- function(v) v[[1]] +mag <- function(v) v[2:length(v)] + +str_to_mag <- function(s) { + strip_leading_zeros <- function(s) { + for (i in 1:nchar(s)) + if (substr(s, i, i) != '0') + return(substr(s, i, nchar(s))) + return("") + } + + len = nchar(s <- strip_leading_zeros(s)) + if (len == 0) + return(zero_mag) + mod <- len %% elem_digits + if (mod > 0) chunks <- substr(s, 1, mod) + else chunks <- character(0) + if (1 + mod < len) { + chunk_inds_begin <- seq(1 + mod, len, elem_digits) + chunk_inds_end <- chunk_inds_begin + elem_digits - 1 + chunks <- c(chunks, substring(s, chunk_inds_begin, chunk_inds_end)) + } + return(sapply(chunks, as.integer)) +} +hi = +bigint <- function(s, i=NA) { + if (!is.na(i)) { + s <- as.character(i) + #x <- abs(i) + #sgn <- if (i < 0L) -1L else 1L + #while (i >= max_elem) { + #} + } +# } else { + if (substr(s, 1, 1) == '-') { + mag <- str_to_mag(substr(s, 2L, nchar(s))) + sgn <- -1L + } else { + mag <- str_to_mag(s) + sgn <- 1L + } +# } + return(c(if (length(mag)) sgn else 0L, mag)) +} + +to_int <- function(x) { + ret <- 0L + if ((x_len = length(x)) > 1L) + for (i in length(x):2) + ret <- ret * elem_max + x[[i]] + return(x[[1]] * ret) +} + +mag_to_str <- function(x) { + len = length(x) + if (len == 1) return(as.character(x[[1]])) + xs <- sapply(x[2:length(x)], function(e) zeropad(e, 4)) + x1 <- x[[1]] + return(paste(collapse="", sep="", c( + x[[1]], + sapply(x[2:length(x)], function(e) zeropad(e, elem_digits))))) +} + +to_str <- function(x) { + if (x[[1]] == 0L) + return("0") + return(paste(sep="", if (x[[1]] < 0L) '-' else '', mag_to_str(mag(x)))) +} + +# Comparison functions + +cmp_elem <- function(x, y) (x > y) - (x < y) +cmp_mag <- function(x, y) { + x_len = length(x) + y_len = length(y) + if (x_len < y_len) return(-1L) + if (x_len > y_len) return(1L) + for (i in 1:x_len) + if (c <- cmp_elem(x[[i]], y[[i]])) + return(c) + return(0L) +} +cmp <- function(x, y) { + x_sign = x[[1]] + y_sign = y[[1]] + if (x_sign == y_sign) { + if (x[[1]] == 1L) return(cmp_mag(mag(x), mag(y))) + if (x[[1]] == -1L) return(cmp_mag(mag(y), mag(x))) + return(0L) + } + return((x_sign > y_sign) - (x_sign < y_sign)) +} + +eq <- function(x, y) cmp(x, y) == 0L +ne <- function(x, y) cmp(x, y) != 0L +le <- function(x, y) cmp(x, y) <= 0L +lt <- function(x, y) cmp(x, y) < 0L +ge <- function(x, y) cmp(x, y) >= 0L +gt <- function(x, y) cmp(x, y) > 0L + +# Arithmetic operations + +add_mag <- function(x, y) { + # if x is shorter, swap the two vectors + if (length(x) < length(y)) { + tmp <- x; x <- y; y <- tmp + } + x_len = length(x) + y_len = length(y) + + x_index <- x_len + y_index <- y_len + result <- integer(x_len) + sum <- 0L + + # add common parts of both numbers + while (y_index > 0L) { + sum <- (x[[x_index]] %% elem_max + y[[y_index]] %% elem_max + + sum %/% elem_max) # TODO shift + result[[x_index]] <- sum %% elem_max + x_index <- x_index - 1L + y_index <- y_index - 1L + } + + # copy remainder of the longer number while carry propagation is required + carry <- (sum >= elem_max) + while (x_index > 0L & carry) { + carry <- (result[[x_index]] <- x[[x_index]] + 1L) == 0L + x_index <- x_index - 1L + } + + # copy remainder of the longer number + while (x_index > 0L) { + result[[x_index]] <- x[[x_index]] + x_index <- x_index - 1L + } + + # grow result if necessary + if (carry) + return(c(0x01L, result)) + return(result) +} + +add <- function(x, y) { + if (y[[1]] == 0L) + return(x) + if (x[[1]] == 0L) + return(y) + if (x[[1]] == y[[1]]) + return(c(x[[1]], add_mag(mag(x), mag(y)))) + + c <- cmp_mag(mag(x), mag(y)) + if (c == 0L) + return(zero) + if (c > 0L) + result_mag <- sub_mag(mag(x), mag(y)) + else + result_mag <- sub_mag(mag(y), mag(x)) + return(c(sign_prod(c, x[[1]]), + strip_leading_zero_elems(result_mag))) +} + +sub_mag <- function(big, little) { + big_len = length(big) + little_len = length(little) + result <- integer(big_len) + big_index <- big_len + little_index <- little_len + difference <- 0L + + # subtract common parts of both numbers + while (little_index > 0L) { + difference <- (big[[big_index]] - little[[little_index]] + + if (difference < 0L) -1L else 0L) + result[[big_index]] <- difference %% elem_max + big_index <- big_index - 1L + little_index <- little_index - 1L + } + + # subtract remainder of longer number while borrow propagates + borrow <- if (difference < 0L) -1 else 0L + while (big_index > 0L && borrow) { + borrow <- (result[[big_index]] <- big[[big_index]] - 1L) == -1L + big_index <- big_index - 1L + } + + # copy remainder of the longer number + while (big_index > 0L) { + result[[big_index]] <- big[[big_index]] + big_index <- big_index - 1L + } + + return(result) +} + +sub <- function(x, y) { + if (y[[1]] == 0L) + return(x) + if (x[[1]] == 0L) + return(negate(y)) + if (x[[1]] != y[[1]]) + return(c(x[[1]], add_mag(mag(x), mag(y)))) + + c <- cmp_mag(mag(x), mag(y)) + if (c == 0L) + return(zero) + if (c > 0L) + result_mag <- sub_mag(mag(x), mag(y)) + else + result_mag <- sub_mag(mag(y), mag(x)) + return(c(sign_prod(c, x[[1]]), + strip_leading_zero_elems(result_mag))) +} + +negate <- function(x) c(-x[[1]], x[2:length(x)]) + +multiply_mag <- function(x, y) { + x_len = length(x) + y_len = length(y) + x_start = x_len # remove + y_start = y_len # remove + c <- integer(x_len + y_len) + + carry <- 0L + k <- y_start + x_start + for (j in seq(y_start, 1L, -1L)) { + product = y[[j]] * x[[x_start]] + carry + c[k] <- product %% elem_max + carry <- product %/% elem_max + k <- k - 1L + } + c[x_start] <- carry + + if (x_len <= 1) + return(c) + + for (i in seq(x_start - 1L, 1L, -1L)) { + carry <- 0 + k <- y_start + i + for (j in seq(y_start, 1L, -1L)) { + product = y[[j]] * x[[i]] + c[[k]] + carry + c[[k]] <- product %% elem_max + carry <- product %/% elem_max + k <- k - 1L + } + c[[i]] <- carry %% elem_max + } + return(c) +} + +mul <- function(x, y) { + if (y[[1]] == 0L || x[[1]] == 0) + return(zero) + + return(c(sign_prod(x[[1]], y[[1]]), + strip_leading_zero_elems(multiply_mag(mag(x), mag(y))))) +} + +div_mag <- function(x_mag, y_mag) { + if (length(y_mag) == 1L && y_mag == one_mag) + return(x_mag) + + x <- c(1L, x_mag) + y <- c(1L, y_mag) + x_mag_log10 = log10_mag(x_mag); y_mag_log10 = log10_mag(y_mag) + lo_log10 = x_mag_log10 - y_mag_log10 - (x_mag_log10 != y_mag_log10) + hi_log10 <- x_mag_log10 - y_mag_log10 + 1L + lo <- bigint_pow10(lo_log10) + + # try pruning hi > 10 or lo <= 10 + if (lo_log10 == 0L && hi_log10 > 1L) { + lo10 = mul(lo, ten) + if (gt(mul(lo10, y), x)) + hi <- lo10 + else { + lo <- lo10 + hi <- bigint_pow10(hi_log10) + } + } else + hi <- bigint_pow10(hi_log10) + + while (lt(lo, hi)) { + mid <- div2(add(add(lo, hi), one)) + if (le(mul(mid, y), x)) + lo <- mid + else + hi <- sub(mid, one) + } + return(mag(lo)) +} + +div <- function(x, y) { + # check if division by zero + if (x[[1]] == 0L) + return(zero) + c <- cmp_mag(mag(x), mag(y)) + if (c == 0L) + return(one) + if (c < 0L) + return(zero) + return(c(sign_prod(x[[1]], y[[1]]), div_mag(mag(x), mag(y)))) +} + +# Helper arithmetic functions + +div2_mag <- function(x) { + x_len <- length(x) + if (x_len == 1L) + return(x %/% 2L) + + borrow <- (x[[1]] == 1) + x_start <- borrow + 1L + x_end <- x_len + result_index <- 1L + result <- integer(x_end - x_start + 1L) + for (x_index in x_start:x_end) { + d = x[[x_index]] + elem_max * borrow + result[[result_index]] <- d %/% 2 + borrow <- d %% 2 + result_index <- result_index + 1L + } + return(result) +} + +div2 <- function(x) { + if (x[[1]] == 0L || (length(x) == 2L && x[[2]] == 1L)) + return(zero) + return(c(x[[1]], div2_mag(mag(x)))) +} + +log10_mag <- function(m) elem_digits * (length(m) - 1L) + as.integer(log(m[[1]], 10)) + +bigint_pow10 <- function(n) c(1L, as.integer(10^(n %% elem_digits)), rep.int(0L, n %/% elem_digits)) + +# Misc functions +sign_prod <- function(x, y) (x == y) - (x != y) +strip_leading_zero_elems <- function(x) { + for (i in 1:length(x)) + if (x[[i]] != 0L) + return(x[i:length(x)]) + return(zero_mag) +} + +zeropad <- function(s, n) + paste(sep="", paste(collapse="", rep('0', max(0L, n - nchar(s)))), s) + + +# PIDIGITS program + +pidigits <- function(args) { + N = if (length(args)) as.integer(args[[1]]) else 100L + ONE = one + TWO = bigint("2") + TEN = bigint("10") + THREE = add(ONE, TWO) + i <- k <- ns <- 0L + k1 <- 1L + a <- t <- u <- bigint("0") + n <- d <- bigint("1") + while (TRUE) { + k <- k + 1L + t <- mul(n, TWO) + n <- mul(n, bigint(k)) + a <- add(a, t) + k1 <- k1 + 2L + k1_big <- bigint(i=k1) + a <- mul(a, k1_big) + d <- mul(d, k1_big) + if (ge(a, n)) { + n3a <- add(mul(n, THREE), a) + t <- div(n3a, d) + td = mul(t, d) + u <- add(sub(n3a, td), n) + if (gt(d, u)) { + ns <- ns * 10L + to_int(t) + i <- i + 1L + if (i %% 5L == 0L) { + cat(zeropad(as.character(ns), 5)) + if (i %% 2L == 0L) + cat(sep="", "\t:", i, "\n") + ns = 0L + } + if (i >= N) + break + a <- sub(a, td) # TODO use td + a <- mul(a, TEN) + n <- mul(n, TEN) + } + } + } +} + +if (!exists("i_am_wrapper")) + pidigits(commandArgs(trailingOnly=TRUE)) diff --git a/tests/shootout/regexdna.R b/tests/shootout/regexdna.R new file mode 100644 --- /dev/null +++ b/tests/shootout/regexdna.R @@ -0,0 +1,60 @@ +# ------------------------------------------------------------------ +# The Computer Language Shootout +# http://shootout.alioth.debian.org/ +# +# Contributed by Leo Osvald +# ------------------------------------------------------------------ + +pattern1 <- c( + "agggtaaa|tttaccct", + "[cgt]gggtaaa|tttaccc[acg]", + "a[act]ggtaaa|tttacc[agt]t", + "ag[act]gtaaa|tttac[agt]ct", + "agg[act]taaa|ttta[agt]cct", + "aggg[acg]aaa|ttt[cgt]ccct", + "agggt[cgt]aa|tt[acg]accct", + "agggta[cgt]a|t[acg]taccct", + "agggtaa[cgt]|[acg]ttaccct") + +pattern2 <- matrix(c( + c("B", "(c|g|t)"), + c("D", "(a|g|t)"), + c("H", "(a|c|t)"), + c("K", "(g|t)"), + c("M", "(a|c)"), + c("N", "(a|c|g|t)"), + c("R", "(a|g)"), + c("S", "(c|g)"), + c("V", "(a|c|g)"), + c("W", "(a|t)"), + c("Y", "(c|t)") +), ncol=2, byrow=TRUE) + +match_count <- function(ms) { + l <- length(ms[[1]]) + fst <- ms[[1]][[1]] + return(if (l > 1) l else if (fst != -1L) fst else 0) +} + +regexdna <- function(args) { + in_filename = args[[1]] + f <- file(in_filename, "r") + str <- paste(c(readLines(f), ""), collapse="\n") + close(f) + + len1 <- nchar(str) + str <- gsub(">.*\n|\n", "", str, perl=TRUE, useBytes=TRUE) + len2 <- nchar(str) + + for (pat in pattern1) + cat(pat, match_count(gregexpr(pat, str, useBytes=TRUE)), "\n") + + for (i in 1:nrow(pattern2)) + str <- gsub(pattern2[[i, 1]], pattern2[[i, 2]], str, perl=TRUE, + useBytes=TRUE) + + cat("", len1, len2, nchar(str), sep="\n") +} + +if (!exists("i_am_wrapper")) + regexdna(commandArgs(trailingOnly=TRUE)) diff --git a/tests/shootout/reversecomplement.R b/tests/shootout/reversecomplement.R new file mode 100644 --- /dev/null +++ b/tests/shootout/reversecomplement.R @@ -0,0 +1,33 @@ +# ------------------------------------------------------------------ +# The Computer Language Shootout +# http://shootout.alioth.debian.org/ +# +# Contributed by Leo Osvald +# ------------------------------------------------------------------ + +codes <- c( + "A", "C", "G", "T", "U", "M", "R", "W", "S", "Y", "K", "V", "H", "D", "B", + "N") +complements <- c( + "T", "G", "C", "A", "A", "K", "Y", "W", "S", "R", "M", "B", "D", "H", "V", + "N") +comp_map <- NULL +comp_map[codes] <- complements +comp_map[tolower(codes)] <- complements + +reversecomplement <- function(args) { + in_filename = args[[1]] + f <- file(in_filename, "r") + while (length(s <- readLines(f, n=1, warn=FALSE))) { + codes <- strsplit(s, split="")[[1]] + if (codes[[1]] == '>') + cat(s, "\n", sep="") + else { + cat(paste(comp_map[codes], collapse=""), "\n", sep="") + } + } + close(f) +} + +if (!exists("i_am_wrapper")) + reversecomplement(commandArgs(trailingOnly=TRUE)) diff --git a/tests/shootout/spectralnorm-math.R b/tests/shootout/spectralnorm-math.R new file mode 100644 --- /dev/null +++ b/tests/shootout/spectralnorm-math.R @@ -0,0 +1,19 @@ +# ------------------------------------------------------------------ +# The Computer Language Shootout +# http://shootout.alioth.debian.org/ +# +# Contributed by Leo Osvald +# ------------------------------------------------------------------ + +spectralnorm_math <- function(args) { + n = if (length(args)) as.integer(args[[1]]) else 100L + options(digits=10) + + eval_A <- function(i, j) 1 / ((i + j - 2) * (i + j - 1) / 2 + i) + + m <- outer(seq(n), seq(n), FUN=eval_A) + cat(sqrt(max(eigen(t(m) %*% m)$val)), "\n") +} + +if (!exists("i_am_wrapper")) + spectralnorm_math(commandArgs(trailingOnly=TRUE)) diff --git a/tests/shootout/spectralnorm.R b/tests/shootout/spectralnorm.R new file mode 100644 --- /dev/null +++ b/tests/shootout/spectralnorm.R @@ -0,0 +1,47 @@ +# ------------------------------------------------------------------ +# The Computer Language Shootout +# http://shootout.alioth.debian.org/ +# +# Contributed by Leo Osvald +# ------------------------------------------------------------------ + +spectralnorm <- function(args) { + n = if (length(args)) as.integer(args[[1]]) else 100L + options(digits=10) + + eval_A <- function(i, j) 1 / ((i + j) * (i + j + 1) / 2 + i + 1) + eval_A_times_u <- function(u) { + ret <- double(n) + for (i in 0:n1) { + eval_A_col <- double(n) + for (j in 0:n1) + eval_A_col[[j + 1]] <- eval_A(i, j) + ret[[i + 1]] <- u %*% eval_A_col + } + return(ret) + } + eval_At_times_u <- function(u) { + ret <- double(n) + for (i in 0:n1) { + eval_At_col <- double(n) + for (j in 0:n1) + eval_At_col[[j + 1]] <- eval_A(j, i) + ret[[i + 1]] <- u %*% eval_At_col + } + return(ret) + } + eval_AtA_times_u <- function(u) eval_At_times_u(eval_A_times_u(u)) + + n1 <- n - 1 + u <- rep(1, n) + v <- rep(0, n) + for (itr in seq(10)) { + v <- eval_AtA_times_u(u) + u <- eval_AtA_times_u(v) + } + + cat(sqrt(sum(u * v) / sum(v * v)), "\n") +} + +if (!exists("i_am_wrapper")) + spectralnorm(commandArgs(trailingOnly=TRUE)) diff --git a/tests/test-qq.hs b/tests/test-qq.hs new file mode 100644 --- /dev/null +++ b/tests/test-qq.hs @@ -0,0 +1,130 @@ +-- | +-- Copyright: (C) 2013 Amgen, Inc. +-- +-- Run H on a number of R programs of increasing size and complexity, comparing +-- the output of H with the output of R. + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +module Main where + +import qualified Foreign.R as R +import Foreign.R (SEXP) +import H.Prelude as H +import Language.R.QQ +import qualified Data.Vector.SEXP as SVector +import qualified Data.Vector.SEXP.Mutable as SMVector +import Control.Memory.Region + +import Control.Applicative ((<$>)) +import Control.Monad.Trans (liftIO) +import Data.Int +import Data.Singletons (sing) +import qualified Data.Text.Lazy as Text +import Test.Tasty.HUnit hiding ((@=?)) + +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))) |] + +-- | Version of '(@=?)' that works in the R monad. +(@=?) :: H.Show a => String -> a -> R s () +expected @=? actual = liftIO $ do + txt <- H.showIO actual + assertEqual "" expected (Text.unpack txt) + +main :: IO () +main = H.withEmbeddedR H.defaultConfig $ H.runRegion $ do + + -- Placing it before enabling gctorture2 for speed. + ("4181L" @=?) =<< hFib =<< H.mkSEXP (19 :: Int32) + + _ <- [r| gctorture2(1,0,TRUE) |] + + ("1" @=?) =<< [r| 1 |] + + -- Should be: [1] 1 + -- H.print [rsafe| 1 |] -- XXX Fails with -O0 and --enable-strict-barrier + + ("3" @=?) =<< [r| 1 + 2 |] + + -- Should be: [1] 2 + -- H.print [rsafe| base::`+`(1, 2) |] -- XXX Fails with -O0 and --enable-strict-barrier + + ("c(\"1\", \"2\", \"3\")" @=?) =<< [r| c(1,2,"3") |] + + ("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 |] + ("8" @=?) =<< [r| z(3) |] + + ("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) |] + + ("2:11" @=?) =<< [r| (function(x).Call(foo2_hs,x))(y) |] + + ("43" @=?) =<< [r| x <- 42 ; x + 1 |] + + let xs = [1,2,3]::[Double] + ("c(1, 2, 3)" @=?) =<< [r| xs_hs |] + + ("8" @=?) =<< [r| foo1_hs(7) |] + + ("NULL" @=?) H.nilValue + + let foo3 = (\n -> fmap fromSomeSEXP [r| n_hs |]) :: Int32 -> R s Int32 + ("3L" @=?) =<< [r| foo3_hs(as.integer(3)) |] + + 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 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) ) |] + + 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) + 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 |] + io . assertEqual "" "fromList [1,2,3]" . Prelude.show =<< SVector.unsafeFreeze v1 + + let utf8string = "abcd çéõßø" + io . assertEqual "" utf8string =<< fromSEXP <$> R.cast (sing :: R.SSEXPTYPE 'R.String) <$> [r| utf8string_hs |] + + return () diff --git a/tests/test-shootout.hs b/tests/test-shootout.hs new file mode 100644 --- /dev/null +++ b/tests/test-shootout.hs @@ -0,0 +1,40 @@ +-- | +-- Copyright: (C) 2013 Amgen, Inc. +-- +-- Execute entries from the Great Language Shootout using R, quasiquotes and +-- compare the output. +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +import Test.Scripts + +import H.Prelude as H hiding (show) +import Language.R.QQ + +import Control.Monad (forM) +import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH.Quote as TH +import System.IO +import System.IO.Silently (capture_) +import System.Process +import Test.Tasty +import Test.Tasty.HUnit +import Prelude + +main :: IO () +main = do + let qqs = + $(do exps <- forM scripts $ \script -> do + TH.runIO (readFile script) >>= TH.quoteExp r + return $ TH.ListE exps) + H.withEmbeddedR H.defaultConfig $ defaultMain $ + testGroup "Quoted shootout programs" $ + zipWith cmp scripts qqs + where + cmp script qq = testCase script $ do + x <- readProcess "R" ["--slave"] =<< readFile script + y <- capture_ $ H.unsafeRToIO qq + x @=? y diff --git a/tests/tests.hs b/tests/tests.hs new file mode 100644 --- /dev/null +++ b/tests/tests.hs @@ -0,0 +1,107 @@ +-- | +-- 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. + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +module Main where + +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 + +import H.Prelude +import Language.R.HExp +import qualified Foreign.R as R +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 Control.Applicative ((<$>)) +import qualified Data.ByteString.Char8 (pack) +import Data.Vector.Generic (basicUnsafeIndexM) +import Data.Singletons (sing) +import Foreign + +tests :: TestTree +tests = testGroup "Unit tests" + [ testCase "fromSEXP . mkSEXP" $ do + z <- fromSEXP <$> mkSEXPIO (2 :: Double) + (2 :: Double) @=? z + , testCase "HEq HExp" $ do + -- XXX ideally randomly generate input. + let x = 2 :: Double + R.withProtected (mkSEXPIO x) $ \z -> + assertBool "reflexive" $ + let s = hexp z in s === s + R.withProtected (mkSEXPIO x) $ \z -> + assertBool "symmetric" $ + let s1 = hexp z + s2 = hexp z + in s1 === s2 && s2 === s1 + R.withProtected (mkSEXPIO x) $ \z -> + assertBool "transitive" $ + let s1 = hexp z + s2 = hexp z + 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 + , 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 + n <- unhexp Nil + rf <- io $ R.mkWeakRef key val n True + True <- case hexp rf of + WeakRef a b c _ -> do + True <- return $ (R.unsexp a) == (R.unsexp key) + True <- return $ (R.unsexp b) == (R.unsexp val) + return $ (R.unsexp c) == (R.unsexp n) + return () + , testCase "Hexp works" $ + (((42::Double) @=?) =<<) $ runRegion $ do + y <- R.cast (sing :: R.SSEXPTYPE R.Real) . R.SomeSEXP + <$> mkSEXP (42::Double) + case hexp y of +  Real s -> basicUnsafeIndexM s 0 + , Test.Constraints.tests + , Test.FunPtr.tests + , Test.HExp.tests + , Test.GC.tests + , 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 "sanity check " $ return () + ] + +main :: IO () +main = do + _ <- R.initialize R.defaultConfig + defaultMain tests