packages feed

inline-r (empty) → 0.7.0.0

raw patch · 62 files changed

+7710/−0 lines, 62 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, criterion, data-default-class, deepseq, directory, exceptions, filepath, ieee754, inline-r, mtl, pretty, primitive, process, quickcheck-assertions, setenv, silently, singletons, strict, tasty, tasty-golden, tasty-hunit, tasty-quickcheck, template-haskell, temporary, text, th-lift, th-orphans, transformers, unix, vector

Files

+ cbits/Hcompat.h view
@@ -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 */
+ cbits/missing_r.c view
@@ -0,0 +1,24 @@+// Copyright: (C) 2013 Amgen, Inc.++#include "missing_r.h"+#include <R.h>+#include <R_ext/Rdynload.h>++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;
+ cbits/missing_r.h view
@@ -0,0 +1,18 @@+// Copyright: (C) 2013 Amgen, Inc.++#ifndef MISSING_R__H+#define MISSING_R__H++#include "HsFFI.h"+#include <Rinternals.h>+#include <R_ext/Rdynload.h>++SEXP funPtrToSEXP(DL_FUNC pf);++// Indicates whether R has been initialized.+extern int isRInitialized;++// R global variables for GHCi.+extern HsStablePtr rVariables;++#endif
+ inline-r.cabal view
@@ -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 <m@tweag.io>+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
+ src/Control/Memory/Region.hs view
@@ -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 = ()
+ src/Control/Monad/R/Class.hs view
@@ -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
+ src/Data/Vector/SEXP.chs view
@@ -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 <R.h>+#define USE_RINTERNALS+#include <Rinternals.h>++-- | Immutable vectors. The second type paramater is a phantom parameter+-- reflecting at the type level the tag of the vector when viewed as a 'SEXP'.+-- The tag of the vector and the representation type are related via 'ElemRep'.+newtype Vector s (ty :: SEXPTYPE) a = Vector { unVector :: SEXP s ty }++type instance G.Mutable (Vector r ty) = MVector r ty++instance (Eq a, VECTOR s ty a) => Eq (Vector s ty a) where+  a == b = toList a == toList b++instance (Show a, VECTOR s ty a)  => Show (Vector s ty a) where+  show v = "fromList " Prelude.++ showList (toList v) ""++instance (VECTOR s ty a)+         => G.Vector (Vector s ty) a where+  basicUnsafeFreeze (MVector s)  = return (Vector s)+  basicUnsafeThaw   (Vector s)   = return (MVector s)+  basicLength       (Vector s)   =+      unsafeInlineIO $+      fromIntegral <$> -- ({# get VECSEXP->vecsxp.length #} (R.unsexp s) :: IO Int32)+        ((\ ptr -> do { peekByteOff ptr 32 :: IO CInt }) (R.unsexp s))+  -- XXX Basic unsafe slice is O(N) complexity as it allocates a copy of+  -- a vector, due to limitations of R's VECSXP structure, which we reuse+  -- directly.+  basicUnsafeSlice i l v         = unsafeInlineIO $ do+    mv <- Mutable.new l+    copyArray (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 <a> ; c = f <a,b> in f <a,b,c>+--+constructN :: VECTOR s ty a => Int -> (Vector s ty a -> a) -> Vector s ty a+{-# INLINE constructN #-}+constructN = G.constructN++-- | /O(n)/ Construct a vector with @n@ elements from right to left by+-- repeatedly applying the generator function to the already constructed part+-- of the vector.+--+-- > constructrN 3 f = let a = f <> ; b = f<a> ; c = f <b,a> in f <c,b,a>+--+constructrN :: VECTOR s ty a => Int -> (Vector s ty a -> a) -> Vector s ty a+{-# INLINE constructrN #-}+constructrN = G.constructrN++-- Enumeration+-- -----------++-- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+1@+-- etc. This operation is usually more efficient than 'enumFromTo'.+--+-- > enumFromN 5 3 = <5,6,7>+enumFromN :: (VECTOR s ty a, Num a) => a -> Int -> Vector s ty a+{-# INLINE enumFromN #-}+enumFromN = G.enumFromN++-- | /O(n)/ Yield a vector of the given length containing the values @x@, @x+y@,+-- @x+y+y@ etc. This operations is usually more efficient than 'enumFromThenTo'.+--+-- > enumFromStepN 1 0.1 5 = <1,1.1,1.2,1.3,1.4>+enumFromStepN :: (VECTOR s ty a, Num a) => a -> a -> Int -> Vector s ty a+{-# INLINE enumFromStepN #-}+enumFromStepN = G.enumFromStepN++-- | /O(n)/ Enumerate values from @x@ to @y@.+--+-- /WARNING:/ This operation can be very inefficient. If at all possible, use+-- 'enumFromN' instead.+enumFromTo :: (VECTOR s ty a, Enum a) => a -> a -> Vector s ty a+{-# INLINE enumFromTo #-}+enumFromTo = G.enumFromTo++-- | /O(n)/ Enumerate values from @x@ to @y@ with a specific step @z@.+--+-- /WARNING:/ This operation can be very inefficient. If at all possible, use+-- 'enumFromStepN' instead.+enumFromThenTo :: (VECTOR s ty a, Enum a) => a -> a -> a -> Vector s ty a+{-# INLINE enumFromThenTo #-}+enumFromThenTo = G.enumFromThenTo++-- Concatenation+-- -------------++-- | /O(n)/ Prepend an element+cons :: VECTOR s ty a => a -> Vector s ty a -> Vector s ty a+{-# INLINE cons #-}+cons = G.cons++-- | /O(n)/ Append an element+snoc :: VECTOR s ty a => Vector s ty a -> a -> Vector s ty a+{-# INLINE snoc #-}+snoc = G.snoc++infixr 5 +++-- | /O(m+n)/ Concatenate two vectors+(++) :: VECTOR s ty a => Vector s ty a -> Vector s ty a -> Vector s ty a+{-# INLINE (++) #-}+(++) = (G.++)++-- | /O(n)/ Concatenate all vectors in the list+concat :: VECTOR s ty a => [Vector s ty a] -> Vector s ty a+{-# INLINE concat #-}+concat = G.concat++-- Monadic initialisation+-- ----------------------++-- | /O(n)/ Execute the monadic action the given number of times and store the+-- results in a vector.+replicateM :: (Monad m, VECTOR s ty a) => Int -> m a -> m (Vector s ty a)+{-# INLINE replicateM #-}+replicateM = G.replicateM++-- | /O(n)/ Construct a vector of the given length by applying the monadic+-- action to each index+generateM :: (Monad m, VECTOR s ty a) => Int -> (Int -> m a) -> m (Vector s ty a)+{-# INLINE generateM #-}+generateM = G.generateM++-- | Execute the monadic action and freeze the resulting vector.+--+-- @+-- create (do { v \<- new 2; write v 0 \'a\'; write v 1 \'b\'; return v }) = \<'a','b'\>+-- @+create :: VECTOR s ty a => (forall r. ST r (MVector s ty r a)) -> Vector s ty a+{-# INLINE create #-}+-- NOTE: eta-expanded due to http://hackage.haskell.org/trac/ghc/ticket/4120+create p = G.create p+++-- Restricting memory usage+-- ------------------------++-- | /O(n)/ Yield the argument but force it not to retain any extra memory,+-- possibly by copying it.+--+-- This is especially useful when dealing with slices. For example:+--+-- > force (slice 0 2 <huge vector>)+--+-- Here, the slice retains a reference to the huge vector. Forcing it creates+-- a copy of just the elements that belong to the slice and allows the huge+-- vector to be garbage collected.+force :: VECTOR s ty a => Vector s ty a -> Vector s ty a+{-# INLINE force #-}+force = G.force++-- Bulk updates+-- ------------++-- | /O(m+n)/ For each pair @(i,a)@ from the list, replace the vector+-- element at position @i@ by @a@.+--+-- > <5,9,2,7> // [(2,1),(0,3),(2,8)] = <3,9,8,7>+--+(//) :: VECTOR s ty a => Vector s ty a   -- ^ initial vector (of length @m@)+                -> [(Int, a)] -- ^ list of index/value pairs (of length @n@)+                -> Vector s ty a+{-# INLINE (//) #-}+(//) = (G.//)++{-+-- | /O(m+min(n1,n2))/ For each index @i@ from the index Vector s ty and the+-- corresponding value @a@ from the value vector, replace the element of the+-- initial Vector s ty at position @i@ by @a@.+--+-- > update_ <5,9,2,7>  <2,0,2> <1,3,8> = <3,9,8,7>+--+update_ :: VECTOR s ty a+        => Vector s ty a   -- ^ initial vector (of length @m@)+        -> Vector Int -- ^ index vector (of length @n1@)+        -> Vector s ty a   -- ^ value vector (of length @n2@)+        -> Vector s ty a+{-# INLINE update_ #-}+update_ = G.update_+-}++{-+-- | Same as ('//') but without bounds checking.+unsafeUpd :: VECTOR s ty a => Vector s ty a -> [(Int, a)] -> Vector s ty a+{-# INLINE unsafeUpd #-}+unsafeUpd = G.unsafeUpd+-}++{-+-- | Same as 'update_' but without bounds checking.+unsafeUpdate_ :: VECTOR s ty a => Vector s ty a -> Vector Int -> Vector s ty a -> Vector s ty a+{-# INLINE unsafeUpdate_ #-}+unsafeUpdate_ = G.unsafeUpdate_+-}++-- Accumulations+-- -------------++-- | /O(m+n)/ For each pair @(i,b)@ from the list, replace the vector element+-- @a@ at position @i@ by @f a b@.+--+-- > accum (+) <5,9,2> [(2,4),(1,6),(0,3),(1,7)] = <5+3, 9+6+7, 2+4>+accum :: VECTOR s ty a+      => (a -> b -> a) -- ^ accumulating function @f@+      -> Vector s ty a      -- ^ initial vector (of length @m@)+      -> [(Int,b)]     -- ^ list of index/value pairs (of length @n@)+      -> Vector s ty a+{-# INLINE accum #-}+accum = G.accum++{-+-- | /O(m+min(n1,n2))/ For each index @i@ from the index Vector s ty and the+-- corresponding value @b@ from the the value vector,+-- replace the element of the initial Vector s ty at+-- position @i@ by @f a b@.+--+-- > accumulate_ (+) <5,9,2> <2,1,0,1> <4,6,3,7> = <5+3, 9+6+7, 2+4>+--+accumulate_ :: (VECTOR s ty a, VECTOR s ty b)+            => (a -> b -> a) -- ^ accumulating function @f@+            -> Vector s ty a      -- ^ initial vector (of length @m@)+            -> Vector Int    -- ^ index vector (of length @n1@)+            -> Vector s ty b      -- ^ value vector (of length @n2@)+            -> Vector s ty a+{-# INLINE accumulate_ #-}+accumulate_ = G.accumulate_+-}++-- | Same as 'accum' but without bounds checking.+unsafeAccum :: VECTOR s ty a => (a -> b -> a) -> Vector s ty a -> [(Int,b)] -> Vector s ty a+{-# INLINE unsafeAccum #-}+unsafeAccum = G.unsafeAccum++{-+-- | Same as 'accumulate_' but without bounds checking.+unsafeAccumulate_ :: (VECTOR s ty a, VECTOR s ty b) =>+               (a -> b -> a) -> Vector s ty a -> Vector Int -> Vector s ty b -> Vector s ty a+{-# INLINE unsafeAccumulate_ #-}+unsafeAccumulate_ = G.unsafeAccumulate_+-}++-- Permutations+-- ------------++-- | /O(n)/ Reverse a vector+reverse :: VECTOR s ty a => Vector s ty a -> Vector s ty a+{-# INLINE reverse #-}+reverse = G.reverse++{-+-- | /O(n)/ Yield the vector obtained by replacing each element @i@ of the+-- index Vector s ty by @xs'!'i@. This is equivalent to @'map' (xs'!') is@ but is+-- often much more efficient.+--+-- > backpermute <a,b,c,d> <0,3,2,3,1,0> = <a,d,c,d,b,a>+backpermute :: VECTOR s ty a => Vector s ty a -> Vector Int -> Vector s ty a+{-# INLINE backpermute #-}+backpermute = G.backpermute+-}++{-+-- | Same as 'backpermute' but without bounds checking.+unsafeBackpermute :: VECTOR s ty a => Vector s ty a -> Vector Int -> Vector s ty a+{-# INLINE unsafeBackpermute #-}+unsafeBackpermute = G.unsafeBackpermute+-}++-- Safe destructive updates+-- ------------------------++{-+-- | Apply a destructive operation to a vector. The operation will be+-- performed in place if it is safe to do so and will modify a copy of the+-- vector otherwise.+--+-- @+-- modify (\\v -> write v 0 \'x\') ('replicate' 3 \'a\') = \<\'x\',\'a\',\'a\'\>+-- @+modify :: VECTOR s ty a => (forall s. MVector s a -> ST s ()) -> Vector s ty a -> Vector s ty a+{-# INLINE modify #-}+modify p = G.modify p+-}++-- Mapping+-- -------++-- | /O(n)/ Map a function over a vector+map :: (VECTOR s ty a, VECTOR s ty b) => (a -> b) -> Vector s ty a -> Vector s ty b+{-# INLINE map #-}+map = G.map++-- | /O(n)/ Apply a function to every element of a Vector s ty and its index+imap :: (VECTOR s ty a, VECTOR s ty b) => (Int -> a -> b) -> Vector s ty a -> Vector s ty b+{-# INLINE imap #-}+imap = G.imap++-- | Map a function over a Vector s ty and concatenate the results.+concatMap :: (VECTOR s ty a, VECTOR s ty b) => (a -> Vector s ty b) -> Vector s ty a -> Vector s ty b+{-# INLINE concatMap #-}+concatMap = G.concatMap++-- Monadic mapping+-- ---------------++-- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a+-- vector of results+mapM :: (Monad m, VECTOR s ty a, VECTOR s ty b) => (a -> m b) -> Vector s ty a -> m (Vector s ty b)+{-# INLINE mapM #-}+mapM = G.mapM++-- | /O(n)/ Apply the monadic action to all elements of a Vector s ty and ignore the+-- results+mapM_ :: (Monad m, VECTOR s ty a) => (a -> m b) -> Vector s ty a -> m ()+{-# INLINE mapM_ #-}+mapM_ = G.mapM_++-- | /O(n)/ Apply the monadic action to all elements of the vector, yielding a+-- vector of results. Equvalent to @flip 'mapM'@.+forM :: (Monad m, VECTOR s ty a, VECTOR s ty b) => Vector s ty a -> (a -> m b) -> m (Vector s ty b)+{-# INLINE forM #-}+forM = G.forM++-- | /O(n)/ Apply the monadic action to all elements of a Vector s ty and ignore the+-- results. Equivalent to @flip 'mapM_'@.+forM_ :: (Monad m, VECTOR s ty a) => Vector s ty a -> (a -> m b) -> m ()+{-# INLINE forM_ #-}+forM_ = G.forM_++-- Zipping+-- -------++-- | /O(min(m,n))/ Zip two vectors with the given function.+zipWith :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c)+        => (a -> b -> c) -> Vector s tya a -> Vector s tyb b -> Vector s tyc c+{-# INLINE zipWith #-}+zipWith f xs ys = G.unstream (Stream.zipWith f (G.stream xs) (G.stream ys))++-- | Zip three vectors with the given function.+zipWith3 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d)+         => (a -> b -> c -> d) -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d+{-# INLINE zipWith3 #-}+zipWith3 f as bs cs = G.unstream (Stream.zipWith3 f (G.stream as) (G.stream bs) (G.stream cs))++zipWith4 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d, VECTOR s tye e)+         => (a -> b -> c -> d -> e)+         -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -> Vector s tye e+{-# INLINE zipWith4 #-}+zipWith4 f as bs cs ds = G.unstream (Stream.zipWith4 f (G.stream as) (G.stream bs) (G.stream cs) (G.stream ds))++zipWith5 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d, VECTOR s tye e,+             VECTOR s tyf f)+         => (a -> b -> c -> d -> e -> f)+         -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -> Vector s tye e+         -> Vector s tyf f+{-# INLINE zipWith5 #-}+zipWith5 f as bs cs ds es = G.unstream (Stream.zipWith5 f (G.stream as) (G.stream bs) (G.stream cs) (G.stream ds) (G.stream es))++zipWith6 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d, VECTOR s tye e,+             VECTOR s tyf f, VECTOR s tyg g)+         => (a -> b -> c -> d -> e -> f -> g)+         -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -> Vector s tye e+         -> Vector s tyf f -> Vector s tyg g+{-# INLINE zipWith6 #-}+zipWith6 f as bs cs ds es fs = G.unstream (Stream.zipWith6 f (G.stream as) (G.stream bs) (G.stream cs) (G.stream ds) (G.stream es) (G.stream fs))++-- | /O(min(m,n))/ Zip two vectors with a function that also takes the+-- elements' indices.+izipWith :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c)+         => (Int -> a -> b -> c) -> Vector s tya a -> Vector s tyb b -> Vector s tyc c+{-# INLINE izipWith #-}+izipWith f as bs = G.unstream (Stream.zipWith (uncurry f) (Stream.indexed (G.stream as)) (G.stream bs))++-- | Zip three vectors and their indices with the given function.+izipWith3 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d)+          => (Int -> a -> b -> c -> d)+          -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d+{-# INLINE izipWith3 #-}+izipWith3 f as bs cs = G.unstream (Stream.zipWith3 (uncurry f) (Stream.indexed (G.stream as)) (G.stream bs) (G.stream cs))++izipWith4 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d, VECTOR s tye e)+          => (Int -> a -> b -> c -> d -> e)+          -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -> Vector s tye e+{-# INLINE izipWith4 #-}+izipWith4 f as bs cs ds =  G.unstream (Stream.zipWith4 (uncurry f) (Stream.indexed (G.stream as)) (G.stream bs) (G.stream cs) (G.stream ds))++izipWith5 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d, VECTOR s tye e,+              VECTOR s tyf f)+          => (Int -> a -> b -> c -> d -> e -> f)+          -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -> Vector s tye e+          -> Vector s tyf f+{-# INLINE izipWith5 #-}+izipWith5 f as bs cs ds es =  G.unstream (Stream.zipWith5 (uncurry f) (Stream.indexed (G.stream as)) (G.stream bs) (G.stream cs) (G.stream ds) (G.stream es))++izipWith6 :: (VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c, VECTOR s tyd d, VECTOR s tye e,+              VECTOR s tyf f, VECTOR s tyg g)+          => (Int -> a -> b -> c -> d -> e -> f -> g)+          -> Vector s tya a -> Vector s tyb b -> Vector s tyc c -> Vector s tyd d -> Vector s tye e+          -> Vector s tyf f -> Vector s tyg g+{-# INLINE izipWith6 #-}+izipWith6 f as bs cs ds es fs =  G.unstream (Stream.zipWith6 (uncurry f) (Stream.indexed (G.stream as)) (G.stream bs) (G.stream cs) (G.stream ds) (G.stream es) (G.stream fs))++-- Monadic zipping+-- ---------------++{-+-- | /O(min(m,n))/ Zip the two vectors with the monadic action and yield a+-- vector of results+zipWithM :: (Monad m, VECTOR s tya a, VECTOR s tyb b, VECTOR s tyc c)+         => (a -> b -> m c) -> Vector s tya a -> Vector s tyb b -> m (Vector s tyc c)+{-# INLINE zipWithM #-}+zipWithM f as bs = G.unstreamM (Stream.zipWithM f (G.stream as) (G.stream bs))+-}++-- | /O(min(m,n))/ Zip the two vectors with the monadic action and ignore the+-- results+zipWithM_ :: (Monad m, VECTOR s tya a, VECTOR s tyb b)+          => (a -> b -> m c) -> Vector s tya a -> Vector s tyb b -> m ()+{-# INLINE zipWithM_ #-}+zipWithM_ f as bs = Stream.zipWithM_ f (G.stream as) (G.stream bs)++-- Filtering+-- ---------++-- | /O(n)/ Drop elements that do not satisfy the predicate+filter :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Vector s ty a+{-# INLINE filter #-}+filter = G.filter++-- | /O(n)/ Drop elements that do not satisfy the predicate which is applied to+-- values and their indices+ifilter :: VECTOR s ty a => (Int -> a -> Bool) -> Vector s ty a -> Vector s ty a+{-# INLINE ifilter #-}+ifilter = G.ifilter++-- | /O(n)/ Drop elements that do not satisfy the monadic predicate+filterM :: (Monad m, VECTOR s ty a) => (a -> m Bool) -> Vector s ty a -> m (Vector s ty a)+{-# INLINE filterM #-}+filterM = G.filterM++-- | /O(n)/ Yield the longest prefix of elements satisfying the predicate+-- with copying.+takeWhile :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Vector s ty a+{-# INLINE takeWhile #-}+takeWhile = G.takeWhile++-- | /O(n)/ Drop the longest prefix of elements that satisfy the predicate+-- with copying.+dropWhile :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Vector s ty a+{-# INLINE dropWhile #-}+dropWhile = G.dropWhile++-- Parititioning+-- -------------++-- | /O(n)/ Split the vector in two parts, the first one containing those+-- elements that satisfy the predicate and the second one those that don't. The+-- relative order of the elements is preserved at the cost of a sometimes+-- reduced performance compared to 'unstablePartition'.+partition :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> (Vector s ty a, Vector s ty a)+{-# INLINE partition #-}+partition = G.partition++-- | /O(n)/ Split the vector in two parts, the first one containing those+-- elements that satisfy the predicate and the second one those that don't.+-- The order of the elements is not preserved but the operation is often+-- faster than 'partition'.+unstablePartition :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> (Vector s ty a, Vector s ty a)+{-# INLINE unstablePartition #-}+unstablePartition = G.unstablePartition++-- | /O(n)/ Split the vector into the longest prefix of elements that satisfy+-- the predicate and the rest with copying.+span :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> (Vector s ty a, Vector s ty a)+{-# INLINE span #-}+span = G.span++-- | /O(n)/ Split the vector into the longest prefix of elements that do not+-- satisfy the predicate and the rest with copying.+break :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> (Vector s ty a, Vector s ty a)+{-# INLINE break #-}+break = G.break++-- Searching+-- ---------++infix 4 `elem`+-- | /O(n)/ Check if the vector contains an element+elem :: (VECTOR s ty a, Eq a) => a -> Vector s ty a -> Bool+{-# INLINE elem #-}+elem = G.elem++infix 4 `notElem`+-- | /O(n)/ Check if the vector does not contain an element (inverse of 'elem')+notElem :: (VECTOR s ty a, Eq a) => a -> Vector s ty a -> Bool+{-# INLINE notElem #-}+notElem = G.notElem++-- | /O(n)/ Yield 'Just' the first element matching the predicate or 'Nothing'+-- if no such element exists.+find :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Maybe a+{-# INLINE find #-}+find = G.find++-- | /O(n)/ Yield 'Just' the index of the first element matching the predicate+-- or 'Nothing' if no such element exists.+findIndex :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Maybe Int+{-# INLINE findIndex #-}+findIndex = G.findIndex++{-+-- | /O(n)/ Yield the indices of elements satisfying the predicate in ascending+-- order.+findIndices :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Vector Int+{-# INLINE findIndices #-}+findIndices = G.findIndices+-}++-- | /O(n)/ Yield 'Just' the index of the first occurence of the given element or+-- 'Nothing' if the vector does not contain the element. This is a specialised+-- version of 'findIndex'.+elemIndex :: (VECTOR s ty a, Eq a) => a -> Vector s ty a -> Maybe Int+{-# INLINE elemIndex #-}+elemIndex = G.elemIndex++{-+-- | /O(n)/ Yield the indices of all occurences of the given element in+-- ascending order. This is a specialised version of 'findIndices'.+elemIndices :: (VECTOR s ty a, Eq a) => a -> Vector s ty a -> Vector Int+{-# INLINE elemIndices #-}+elemIndices = G.elemIndices+-}++-- Folding+-- -------++-- | /O(n)/ Left fold+foldl :: VECTOR s ty b => (a -> b -> a) -> a -> Vector s ty b -> a+{-# INLINE foldl #-}+foldl = G.foldl++-- | /O(n)/ Left fold on non-empty vectors+foldl1 :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> a+{-# INLINE foldl1 #-}+foldl1 = G.foldl1++-- | /O(n)/ Left fold with strict accumulator+foldl' :: VECTOR s ty b => (a -> b -> a) -> a -> Vector s ty b -> a+{-# INLINE foldl' #-}+foldl' = G.foldl'++-- | /O(n)/ Left fold on non-empty vectors with strict accumulator+foldl1' :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> a+{-# INLINE foldl1' #-}+foldl1' = G.foldl1'++-- | /O(n)/ Right fold+foldr :: VECTOR s ty a => (a -> b -> b) -> b -> Vector s ty a -> b+{-# INLINE foldr #-}+foldr = G.foldr++-- | /O(n)/ Right fold on non-empty vectors+foldr1 :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> a+{-# INLINE foldr1 #-}+foldr1 = G.foldr1++-- | /O(n)/ Right fold with a strict accumulator+foldr' :: VECTOR s ty a => (a -> b -> b) -> b -> Vector s ty a -> b+{-# INLINE foldr' #-}+foldr' = G.foldr'++-- | /O(n)/ Right fold on non-empty vectors with strict accumulator+foldr1' :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> a+{-# INLINE foldr1' #-}+foldr1' = G.foldr1'++-- | /O(n)/ Left fold (function applied to each element and its index)+ifoldl :: VECTOR s ty b => (a -> Int -> b -> a) -> a -> Vector s ty b -> a+{-# INLINE ifoldl #-}+ifoldl = G.ifoldl++-- | /O(n)/ Left fold with strict accumulator (function applied to each element+-- and its index)+ifoldl' :: VECTOR s ty b => (a -> Int -> b -> a) -> a -> Vector s ty b -> a+{-# INLINE ifoldl' #-}+ifoldl' = G.ifoldl'++-- | /O(n)/ Right fold (function applied to each element and its index)+ifoldr :: VECTOR s ty a => (Int -> a -> b -> b) -> b -> Vector s ty a -> b+{-# INLINE ifoldr #-}+ifoldr = G.ifoldr++-- | /O(n)/ Right fold with strict accumulator (function applied to each+-- element and its index)+ifoldr' :: VECTOR s ty a => (Int -> a -> b -> b) -> b -> Vector s ty a -> b+{-# INLINE ifoldr' #-}+ifoldr' = G.ifoldr'++-- Specialised folds+-- -----------------++{-+-- | /O(n)/ Check if all elements satisfy the predicate.+all :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Bool+{-# INLINE all #-}+all = G.all++-- | /O(n)/ Check if any element satisfies the predicate.+any :: VECTOR s ty a => (a -> Bool) -> Vector s ty a -> Bool+{-# INLINE any #-}+any = G.any++-- | /O(n)/ Check if all elements are 'True'+and :: Vector 'Logical Bool -> R.Logical+{-# INLINE and #-}+and = G.and -- FIXME++-- | /O(n)/ Check if any element is 'True'+or :: Vector 'Logical Bool -> R.Logical+{-# INLINE or #-}+or = G.or+-}++-- | /O(n)/ Compute the sum of the elements+sum :: (VECTOR s ty a, Num a) => Vector s ty a -> a+{-# INLINE sum #-}+sum = G.sum++-- | /O(n)/ Compute the produce of the elements+product :: (VECTOR s ty a, Num a) => Vector s ty a -> a+{-# INLINE product #-}+product = G.product++-- | /O(n)/ Yield the maximum element of the vector. The vector may not be+-- empty.+maximum :: (VECTOR s ty a, Ord a) => Vector s ty a -> a+{-# INLINE maximum #-}+maximum = G.maximum++-- | /O(n)/ Yield the maximum element of the Vector s ty according to the given+-- comparison function. The vector may not be empty.+maximumBy :: VECTOR s ty a => (a -> a -> Ordering) -> Vector s ty a -> a+{-# INLINE maximumBy #-}+maximumBy = G.maximumBy++-- | /O(n)/ Yield the minimum element of the vector. The vector may not be+-- empty.+minimum :: (VECTOR s ty a, Ord a) => Vector s ty a -> a+{-# INLINE minimum #-}+minimum = G.minimum++-- | /O(n)/ Yield the minimum element of the Vector s ty according to the given+-- comparison function. The vector may not be empty.+minimumBy :: VECTOR s ty a => (a -> a -> Ordering) -> Vector s ty a -> a+{-# INLINE minimumBy #-}+minimumBy = G.minimumBy++-- | /O(n)/ Yield the index of the maximum element of the vector. The vector+-- may not be empty.+maxIndex :: (VECTOR s ty a, Ord a) => Vector s ty a -> Int+{-# INLINE maxIndex #-}+maxIndex = G.maxIndex++-- | /O(n)/ Yield the index of the maximum element of the Vector s ty according to+-- the given comparison function. The vector may not be empty.+maxIndexBy :: VECTOR s ty a => (a -> a -> Ordering) -> Vector s ty a -> Int+{-# INLINE maxIndexBy #-}+maxIndexBy = G.maxIndexBy++-- | /O(n)/ Yield the index of the minimum element of the vector. The vector+-- may not be empty.+minIndex :: (VECTOR s ty a, Ord a) => Vector s ty a -> Int+{-# INLINE minIndex #-}+minIndex = G.minIndex++-- | /O(n)/ Yield the index of the minimum element of the Vector s ty according to+-- the given comparison function. The vector may not be empty.+minIndexBy :: VECTOR s ty a => (a -> a -> Ordering) -> Vector s ty a -> Int+{-# INLINE minIndexBy #-}+minIndexBy = G.minIndexBy++-- Monadic folds+-- -------------++-- | /O(n)/ Monadic fold+foldM :: (Monad m, VECTOR s ty b) => (a -> b -> m a) -> a -> Vector s ty b -> m a+{-# INLINE foldM #-}+foldM = G.foldM++-- | /O(n)/ Monadic fold over non-empty vectors+fold1M :: (Monad m, VECTOR s ty a) => (a -> a -> m a) -> Vector s ty a -> m a+{-# INLINE fold1M #-}+fold1M = G.fold1M++-- | /O(n)/ Monadic fold with strict accumulator+foldM' :: (Monad m, VECTOR s ty b) => (a -> b -> m a) -> a -> Vector s ty b -> m a+{-# INLINE foldM' #-}+foldM' = G.foldM'++-- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator+fold1M' :: (Monad m, VECTOR s ty a) => (a -> a -> m a) -> Vector s ty a -> m a+{-# INLINE fold1M' #-}+fold1M' = G.fold1M'++-- | /O(n)/ Monadic fold that discards the result+foldM_ :: (Monad m, VECTOR s ty b) => (a -> b -> m a) -> a -> Vector s ty b -> m ()+{-# INLINE foldM_ #-}+foldM_ = G.foldM_++-- | /O(n)/ Monadic fold over non-empty vectors that discards the result+fold1M_ :: (Monad m, VECTOR s ty a) => (a -> a -> m a) -> Vector s ty a -> m ()+{-# INLINE fold1M_ #-}+fold1M_ = G.fold1M_++-- | /O(n)/ Monadic fold with strict accumulator that discards the result+foldM'_ :: (Monad m, VECTOR s ty b) => (a -> b -> m a) -> a -> Vector s ty b -> m ()+{-# INLINE foldM'_ #-}+foldM'_ = G.foldM'_++-- | /O(n)/ Monadic fold over non-empty vectors with strict accumulator+-- that discards the result+fold1M'_ :: (Monad m, VECTOR s ty a) => (a -> a -> m a) -> Vector s ty a -> m ()+{-# INLINE fold1M'_ #-}+fold1M'_ = G.fold1M'_++-- Prefix sums (scans)+-- -------------------++-- | /O(n)/ Prescan+--+-- @+-- prescanl f z = 'init' . 'scanl' f z+-- @+--+-- Example: @prescanl (+) 0 \<1,2,3,4\> = \<0,1,3,6\>@+--+prescanl :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> a) -> a -> Vector s ty b -> Vector s ty a+{-# INLINE prescanl #-}+prescanl = G.prescanl++-- | /O(n)/ Prescan with strict accumulator+prescanl' :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> a) -> a -> Vector s ty b -> Vector s ty a+{-# INLINE prescanl' #-}+prescanl' = G.prescanl'++-- | /O(n)/ Scan+--+-- @+-- postscanl f z = 'tail' . 'scanl' f z+-- @+--+-- Example: @postscanl (+) 0 \<1,2,3,4\> = \<1,3,6,10\>@+--+postscanl :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> a) -> a -> Vector s ty b -> Vector s ty a+{-# INLINE postscanl #-}+postscanl = G.postscanl++-- | /O(n)/ Scan with strict accumulator+postscanl' :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> a) -> a -> Vector s ty b -> Vector s ty a+{-# INLINE postscanl' #-}+postscanl' = G.postscanl'++-- | /O(n)/ Haskell-style scan+--+-- > scanl f z <x1,...,xn> = <y1,...,y(n+1)>+-- >   where y1 = z+-- >         yi = f y(i-1) x(i-1)+--+-- Example: @scanl (+) 0 \<1,2,3,4\> = \<0,1,3,6,10\>@+--+scanl :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> a) -> a -> Vector s ty b -> Vector s ty a+{-# INLINE scanl #-}+scanl = G.scanl++-- | /O(n)/ Haskell-style scan with strict accumulator+scanl' :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> a) -> a -> Vector s ty b -> Vector s ty a+{-# INLINE scanl' #-}+scanl' = G.scanl'++-- | /O(n)/ Scan over a non-empty vector+--+-- > scanl f <x1,...,xn> = <y1,...,yn>+-- >   where y1 = x1+-- >         yi = f y(i-1) xi+--+scanl1 :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> Vector s ty a+{-# INLINE scanl1 #-}+scanl1 = G.scanl1++-- | /O(n)/ Scan over a non-empty vector with a strict accumulator+scanl1' :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> Vector s ty a+{-# INLINE scanl1' #-}+scanl1' = G.scanl1'++-- | /O(n)/ Right-to-left prescan+--+-- @+-- prescanr f z = 'reverse' . 'prescanl' (flip f) z . 'reverse'+-- @+--+prescanr :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> b) -> b -> Vector s ty a -> Vector s ty b+{-# INLINE prescanr #-}+prescanr = G.prescanr++-- | /O(n)/ Right-to-left prescan with strict accumulator+prescanr' :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> b) -> b -> Vector s ty a -> Vector s ty b+{-# INLINE prescanr' #-}+prescanr' = G.prescanr'++-- | /O(n)/ Right-to-left scan+postscanr :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> b) -> b -> Vector s ty a -> Vector s ty b+{-# INLINE postscanr #-}+postscanr = G.postscanr++-- | /O(n)/ Right-to-left scan with strict accumulator+postscanr' :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> b) -> b -> Vector s ty a -> Vector s ty b+{-# INLINE postscanr' #-}+postscanr' = G.postscanr'++-- | /O(n)/ Right-to-left Haskell-style scan+scanr :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> b) -> b -> Vector s ty a -> Vector s ty b+{-# INLINE scanr #-}+scanr = G.scanr++-- | /O(n)/ Right-to-left Haskell-style scan with strict accumulator+scanr' :: (VECTOR s ty a, VECTOR s ty b) => (a -> b -> b) -> b -> Vector s ty a -> Vector s ty b+{-# INLINE scanr' #-}+scanr' = G.scanr'++-- | /O(n)/ Right-to-left scan over a non-empty vector+scanr1 :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> Vector s ty a+{-# INLINE scanr1 #-}+scanr1 = G.scanr1++-- | /O(n)/ Right-to-left scan over a non-empty vector with a strict+-- accumulator+scanr1' :: VECTOR s ty a => (a -> a -> a) -> Vector s ty a -> Vector s ty a+{-# INLINE scanr1' #-}+scanr1' = G.scanr1'++-- Conversions - Lists+-- ------------------------++-- | /O(n)/ Convert a vector to a list+toList :: VECTOR s ty a => Vector s ty a -> [a]+{-# INLINE toList #-}+toList = G.toList++-- | /O(n)/ Convert a list to a vector+fromList :: VECTOR s ty a => [a] -> Vector s ty a+{-# INLINE fromList #-}+fromList xs = G.fromListN (Prelude.length xs) xs++-- | /O(n)/ Convert the first @n@ elements of a list to a vector+--+-- @+-- fromListN n xs = 'fromList' ('take' n xs)+-- @+fromListN :: VECTOR s ty a => Int -> [a] -> Vector s ty a+{-# INLINE fromListN #-}+fromListN = G.fromListN++-- Conversions - Unsafe casts+-- --------------------------++-- Conversions - Mutable vectors+-- -----------------------------++-- | /O(1)/ Unsafe convert a mutable vector to an immutable one with+-- copying. The mutable vector may not be used after this operation.+unsafeFreeze+        :: (VECTOR s ty a, PrimMonad m) => MVector s ty (PrimState m) a -> m (Vector s ty a)+{-# INLINE unsafeFreeze #-}+unsafeFreeze = G.unsafeFreeze++-- | /O(1)/ Unsafely convert an immutable vector to a mutable one with+-- copying. The immutable vector may not be used after this operation.+unsafeThaw+        :: (VECTOR s ty a, PrimMonad m) => Vector s ty a -> m (MVector s ty (PrimState m) a)+{-# INLINE unsafeThaw #-}+unsafeThaw = G.unsafeThaw++-- | /O(n)/ Yield a mutable copy of the immutable vector.+thaw :: (VECTOR s ty a, PrimMonad m) => Vector s ty a -> m (MVector s ty (PrimState m) a)+{-# INLINE thaw #-}+thaw = G.thaw++-- | /O(n)/ Yield an immutable copy of the mutable vector.+freeze :: (VECTOR s ty a, PrimMonad m) => MVector s ty (PrimState m) a -> m (Vector s ty a)+{-# INLINE freeze #-}+freeze = G.freeze++-- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must+-- have the same length. This is not checked.+unsafeCopy+  :: (VECTOR s ty a, PrimMonad m) => MVector s ty (PrimState m) a -> Vector s ty a -> m ()+{-# INLINE unsafeCopy #-}+unsafeCopy = G.unsafeCopy++-- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must+-- have the same length.+copy :: (VECTOR s ty a, PrimMonad m) => MVector s ty (PrimState m) a -> Vector s ty a -> m ()+{-# INLINE copy #-}+copy = G.copy++-- | O(1) Inplace convertion to Storable vector.+unsafeToStorable :: VECTOR s ty a+                 => Vector s ty a         -- ^ target+                 -> Storable.Vector a     -- ^ source+{-# INLINE unsafeToStorable #-}+unsafeToStorable v = unsafeInlineIO $+  G.unsafeFreeze =<< Mutable.unsafeToStorable =<< G.unsafeThaw v++-- | O(N) Convertion from storable vector to SEXP vector.+fromStorable :: VECTOR s ty a+             => Storable.Vector a+             -> Vector s ty a+{-# INLINE fromStorable #-}+fromStorable v = unsafeInlineIO $+  G.unsafeFreeze =<< Mutable.fromStorable =<< G.unsafeThaw v
+ src/Data/Vector/SEXP/Base.hs view
@@ -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)
+ src/Data/Vector/SEXP/Mutable.chs view
@@ -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 <R.h>+#define USE_RINTERNALS+#include <Rinternals.h>++-- | Mutable R vector. They are represented in memory with the same header as+-- 'SEXP' nodes. The second type paramater is a phantom parameter reflecting at+-- the type level the tag of the vector when viewed as a 'SEXP'. The tag of the+-- vector and the representation type are related via 'ElemRep'.+newtype MVector s (ty :: SEXPTYPE) r a = MVector { unMVector :: SEXP s ty }++type IOVector s ty   = MVector s ty RealWorld+type STVector s ty r = MVector s ty s++instance (VECTOR s ty a)+         => G.MVector (MVector s ty) a where+  basicLength (MVector s) = unsafeInlineIO $+    fromIntegral <$> {# get VECSEXP->vecsxp.length #} (R.unsexp s)+-- N.B. slicing can't be supported properly by vectors prefixed by header,+-- this means that we can support only a reducing size (required for+-- vectors algorithms), and slicing that is noop+  basicUnsafeSlice j m v+    | j == 0 && m == G.basicLength v = v+    | j == 0 = unsafePerformIO $ do+        let s = castPtr $ R.unsexp $ unMVector v+        {# set VECSEXP->vecsxp.length #} s (fromIntegral m :: CInt)+        return v+    | otherwise =+      failure "Data.Vector.SEXP.Mutable.slice"+              "unsafeSlice is not supported for SEXP vectors, to perform slicing convert vector to Storable."+  basicOverlaps mv1 mv2   = unMVector mv1 == unMVector mv2+  basicUnsafeNew n+    -- R calls using allocVector() for CHARSXP "defunct"...+    | fromSing (sing :: SSEXPTYPE ty) == R.Char =+      failure "Data.Vector.SEXP.Mutable.new"+              "R character vectors are immutable and globally cached. Use 'mkChar' instead."+    | otherwise =+      -- No functor instance available here in GHC < 7.10 (pre AMP).+      liftM fromSEXP $ unsafePrimToPrim (R.allocVectorProtected (sing :: SSEXPTYPE ty) n)+  basicUnsafeRead mv i     = unsafePrimToPrim+                           $ peekElemOff (toVecPtr mv) i+  basicUnsafeWrite mv i x  = unsafePrimToPrim+                           $ pokeElemOff (toVecPtr mv) i x+  basicSet mv x            = Prelude.mapM_ (\i -> G.basicUnsafeWrite mv i x) [0..G.basicLength mv]+  basicUnsafeCopy mv1 mv2  = unsafePrimToPrim $ do+      copyArray (toVecPtr mv1)+                (toVecPtr mv2)+                (G.basicLength mv1)+  basicUnsafeMove mv1 mv2  = unsafePrimToPrim $ do+      moveArray (toVecPtr mv1)+                (toVecPtr mv2)+                (G.basicLength mv1)++toVecPtr :: MVector s ty r a -> Ptr a+toVecPtr mv = castPtr (R.unsafeSEXPToVectorPtr $ unMVector mv)++-- | /O(1)/ Create a vector from a 'SEXP'.+fromSEXP :: (E s ty a, Storable a, IsVector ty)+         => R.SEXP s ty+         -> MVector s ty r a+fromSEXP s = MVector s++-- | /O(1)/ Convert a mutable vector to a 'SEXP'. This can be done efficiently,+-- without copy, because vectors in this module always include a 'SEXP' header+-- immediately before the vector data in memory.+toSEXP :: forall s a r ty. (E s ty a, IsVector ty, Storable a)+       => MVector s ty r a+       -> R.SEXP s ty+toSEXP = unMVector++-- Length information+-- ------------------++-- | Length of the mutable vector.+length :: VECTOR s ty a => MVector s ty r a -> Int+{-# INLINE length #-}+length (MVector s) =+    unsafeInlineIO $+    fromIntegral <$> {# get VECSEXP->vecsxp.length #} (R.unsexp s)++-- | Check whether the vector is empty+null :: VECTOR s ty a => (MVector s ty) r a -> Bool+{-# INLINE null #-}+null (MVector s) =+    unsafeInlineIO $+    ((/= (0::Int)) . fromIntegral) <$>+    {# get VECSEXP->vecsxp.length #} (R.unsexp s)++-- Initialisation+-- --------------++-- | Create a mutable vector of the given length.+new :: (PrimMonad m, VECTOR s ty a) => Int -> m (MVector s ty (PrimState m) a)+{-# INLINE new #-}+new = G.new++-- | Create a mutable vector of the given length. The length is not checked.+unsafeNew :: (PrimMonad m, VECTOR s ty a) => Int -> m (MVector s ty (PrimState m) a)+{-# INLINE unsafeNew #-}+unsafeNew = G.unsafeNew++-- | Create a mutable vector of the given length (0 if the length is negative)+-- and fill it with an initial value.+replicate :: (PrimMonad m, VECTOR s ty a) => Int -> a -> m (MVector s ty (PrimState m) a)+{-# INLINE replicate #-}+replicate = G.replicate++-- | Create a mutable vector of the given length (0 if the length is negative)+-- and fill it with values produced by repeatedly executing the monadic action.+replicateM :: (PrimMonad m, VECTOR s ty a) => Int -> m a -> m (MVector s ty (PrimState m) a)+{-# INLINE replicateM #-}+replicateM = G.replicateM++-- | Create a copy of a mutable vector.+clone :: (PrimMonad m, VECTOR s ty a)+      => MVector s ty (PrimState m) a -> m (MVector s ty (PrimState m) a)+{-# INLINE clone #-}+clone = G.clone++-- Restricting memory usage+-- ------------------------++-- | Reset all elements of the vector to some undefined value, clearing all+-- references to external objects. This is usually a noop for unboxed vectors.+clear :: (PrimMonad m, VECTOR s ty a) => MVector s ty (PrimState m) a -> m ()+{-# INLINE clear #-}+clear = G.clear++-- Accessing individual elements+-- -----------------------------++-- | Yield the element at the given position.+read :: (PrimMonad m, VECTOR s ty a)+     => MVector s ty (PrimState m) a -> Int -> m a+{-# INLINE read #-}+read = G.read++-- | Replace the element at the given position.+write :: (PrimMonad m, VECTOR s ty a)+      => MVector s ty (PrimState m) a -> Int -> a -> m ()+{-# INLINE write #-}+write = G.write++-- | Swap the elements at the given positions.+swap :: (PrimMonad m, VECTOR s ty a)+     => MVector s ty (PrimState m) a -> Int -> Int -> m ()+{-# INLINE swap #-}+swap = G.swap++-- | Yield the element at the given position. No bounds checks are performed.+unsafeRead :: (PrimMonad m, VECTOR s ty a)+           => MVector s ty (PrimState m) a -> Int -> m a+{-# INLINE unsafeRead #-}+unsafeRead = G.unsafeRead++-- | Replace the element at the given position. No bounds checks are performed.+unsafeWrite :: (PrimMonad m, VECTOR s ty a)+            => MVector s ty (PrimState m) a -> Int -> a -> m ()+{-# INLINE unsafeWrite #-}+unsafeWrite = G.unsafeWrite++-- | Swap the elements at the given positions. No bounds checks are performed.+unsafeSwap :: (PrimMonad m, VECTOR s ty a)+           => MVector s ty (PrimState m) a -> Int -> Int -> m ()+{-# INLINE unsafeSwap #-}+unsafeSwap = G.unsafeSwap++-- Filling and copying+-- -------------------++-- | Set all elements of the vector to the given value.+set :: (PrimMonad m, VECTOR s ty a) => MVector s ty (PrimState m) a -> a -> m ()+{-# INLINE set #-}+set = G.set++-- | Copy a vector. The two vectors must have the same length and may not+-- overlap.+copy :: (PrimMonad m, VECTOR s ty a)+     => MVector s ty (PrimState m) a+     -> MVector s ty (PrimState m) a+     -> m ()+{-# INLINE copy #-}+copy = G.copy++-- | Copy a vector. The two vectors must have the same length and may not+-- overlap. This is not checked.+unsafeCopy :: (PrimMonad m, VECTOR s ty a)+           => MVector s ty (PrimState m) a   -- ^ target+           -> MVector s ty (PrimState m) a   -- ^ source+           -> m ()+{-# INLINE unsafeCopy #-}+unsafeCopy = G.unsafeCopy++-- | Move the contents of a vector. The two vectors must have the same+-- length.+--+-- If the vectors do not overlap, then this is equivalent to 'copy'.+-- Otherwise, the copying is performed as if the source vector were+-- copied to a temporary vector and then the temporary vector was copied+-- to the target vector.+move :: (PrimMonad m, VECTOR s ty a)+     => MVector s ty (PrimState m) a+     -> MVector s ty (PrimState m) a+     -> m ()+{-# INLINE move #-}+move = G.move++-- | Move the contents of a vector. The two vectors must have the same+-- length, but this is not checked.+--+-- If the vectors do not overlap, then this is equivalent to 'unsafeCopy'.+-- Otherwise, the copying is performed as if the source vector were+-- copied to a temporary vector and then the temporary vector was copied+-- to the target vector.+unsafeMove :: (PrimMonad m, VECTOR s ty a)+           => MVector s ty (PrimState m) a          -- ^ target+           -> MVector s ty (PrimState m) a          -- ^ source+           -> m ()+{-# INLINE unsafeMove #-}+unsafeMove = G.unsafeMove++-- | O(1) Inplace convertion to Storable vector.+unsafeToStorable :: (PrimMonad m, VECTOR s ty a)+                 => MVector s ty (PrimState m) a           -- ^ target+                 -> m (Storable.MVector (PrimState m) a) -- ^ source+{-# INLINE unsafeToStorable #-}+unsafeToStorable v@(MVector p) = unsafePrimToPrim $ do+  R.preserveObject p+  ptr <- newForeignPtr (toVecPtr v) (R.releaseObject (R.sexp $ castPtr $ toVecPtr v))+  return $ Storable.unsafeFromForeignPtr0 ptr (length v)++-- | O(N) Convertion from storable vector to SEXP vector.+fromStorable :: (PrimMonad m, VECTOR s ty a)+             => Storable.MVector (PrimState m) a+             -> m (MVector s ty (PrimState m) a)+{-# INLINE fromStorable #-}+fromStorable v = do+  let (fptr, l) = Storable.unsafeToForeignPtr0 v+  mv <- new l+  unsafePrimToPrim $ withForeignPtr fptr $ \p -> do+    copyArray (toVecPtr mv) p (Storable.length v)+  return mv
+ src/Foreign/R.chs view
@@ -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 <R.h>+#include <Rinternals.h>+#include <R_ext/Memory.h>+#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)
+ src/Foreign/R/Constraints.hs view
@@ -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
+ src/Foreign/R/Embedded.chs view
@@ -0,0 +1,27 @@+-- |+-- Copyright: (C) 2013 Amgen, Inc.+--+-- Bindings for @<R/Rembedded.h>@, 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 <Rembedded.h>+#include "missing_r.h"++-- | Initialize R.+{# fun Rf_initEmbeddedR as initEmbeddedR { `Int', castPtr `Ptr CString' } -> `()' #}++-- | Finalize R.+{# fun Rf_endEmbeddedR as endEmbeddedR { `Int' } -> `()' #}
+ src/Foreign/R/Error.chs view
@@ -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
+ src/Foreign/R/EventLoop.chs view
@@ -0,0 +1,129 @@+-- |+-- Copyright: (C) 2015 Tweag I/O Limited.+--+-- Bindings for @<R/R_ext/eventloop.h>@, 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_ext/eventloop.h>++-- | 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."
+ src/Foreign/R/Parse.chs view
@@ -0,0 +1,47 @@+-- |+-- Copyright: (C) 2013 Amgen, Inc.+--+-- Bindings for @<R/R_ext/Parse.h>@.++{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ForeignFunctionInterface #-}+#if __GLASGOW_HASKELL__ >= 710+{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}+#endif++#include "Hcompat.h"++#include <Rinternals.h>+#include <R_ext/Parse.h>+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 #}
+ src/Foreign/R/Type.hs-boot view
@@ -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
+ src/Foreign/R/Type.hsc view
@@ -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 <Rinternals.h>++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])
+ src/H/Prelude.hs view
@@ -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
+ src/H/Prelude/Interactive.hs view
@@ -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
+ src/Internal/Error.hs view
@@ -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."
+ src/Language/R.hs view
@@ -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)
+ src/Language/R/Debug.hs view
@@ -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 "<PTR>"+                 , "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 "<data>"+      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
+ src/Language/R/Event.hs view
@@ -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
+ src/Language/R/GC.hs view
@@ -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
+ src/Language/R/Globals.hs view
@@ -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: <https://ghc.haskell.org/trac/ghc/ticket/8549#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
+ src/Language/R/HExp.chs view
@@ -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 <R.h>+#include <Rinternals.h>++{#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 <RInternals.h>.+  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+  -- <Rinternals.h>.+  -- 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
+ src/Language/R/HExp.hs-boot view
@@ -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 -> *
+ src/Language/R/Instance.hs view
@@ -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
+ src/Language/R/Internal.hs view
@@ -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
+ src/Language/R/Internal.hs-boot view
@@ -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)
+ src/Language/R/Internal/FunWrappers.hs view
@@ -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)
+ src/Language/R/Internal/FunWrappers/TH.hs view
@@ -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" |]) [] ]+      ]
+ src/Language/R/Literal.hs view
@@ -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)
+ src/Language/R/QQ.hs view
@@ -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
+ tests/R/fib-benchmark.R view
@@ -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
+ tests/R/fib.R view
@@ -0,0 +1,5 @@+fib <- function(n) {+    if(n == 0) return(1)+    if(n == 1) return(1)+    return(fib(n - 1) + fib(n - 2))+}
+ tests/Test/Constraints.hs view
@@ -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
+ tests/Test/Event.hs view
@@ -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
+ tests/Test/FunPtr.hs view
@@ -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+  ]
+ tests/Test/GC.hs view
@@ -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
+ tests/Test/HExp.hs view
@@ -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)+        ]+  ]
+ tests/Test/Regions.hs view
@@ -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 <Rversion.h>++preserveDirectory :: IO a -> IO a+preserveDirectory =+ bracket getCurrentDirectory setCurrentDirectory . const++#if defined(R_VERSION) && R_VERSION >= R_Version(3, 1, 0)+foreign import ccall "&R_PPStackTop" ppStackTop :: Ptr Int+#endif++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)+    ]
+ tests/Test/Scripts.hs view
@@ -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"+    ]
+ tests/Test/Vector.hs view
@@ -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+                                 ]+  ]
+ tests/bench-hexp.hs view
@@ -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
+ tests/bench-qq.hs view
@@ -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)+                   ]+               ]
+ tests/shootout/binarytrees.R view
@@ -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))
+ tests/shootout/fannkuchredux.R view
@@ -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))
+ tests/shootout/fasta.R view
@@ -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))
+ tests/shootout/fastaredux.R view
@@ -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))
+ tests/shootout/knucleotide.R view
@@ -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))
+ tests/shootout/mandelbrot-noout.R view
@@ -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))
+ tests/shootout/mandelbrot.R view
@@ -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))
+ tests/shootout/nbody.R view
@@ -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))
+ tests/shootout/pidigits.R view
@@ -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))
+ tests/shootout/regexdna.R view
@@ -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))
+ tests/shootout/reversecomplement.R view
@@ -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))
+ tests/shootout/spectralnorm-math.R view
@@ -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))
+ tests/shootout/spectralnorm.R view
@@ -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))
+ tests/test-qq.hs view
@@ -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 ()
+ tests/test-shootout.hs view
@@ -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
+ tests/tests.hs view
@@ -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