inline-r 0.9.0.1 → 0.9.0.2
raw patch · 11 files changed
+460/−12 lines, 11 filesnew-uploader
Files
- CHANGELOG.md +4/−0
- inline-r.cabal +7/−5
- src/Control/Monad/R/Class.hs +2/−2
- src/Foreign/R.chs +9/−2
- src/Foreign/R/Internal.hsc +3/−0
- src/Language/R.hs +12/−0
- src/Language/R/Literal.hs +3/−2
- src/Language/R/Matcher.hs +348/−0
- src/Language/R/QQ.hs +1/−1
- tests/Test/Parser.hs +63/−0
- tests/tests.hs +8/−0
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Change Log +## 0.9.0.2 - 2016-10-23+* Fix build on ghc-8.2.+* Introduce Matcher API.+ ## 0.9.0 - 2016-06-20 * Breaking change: Rewrite of the `H.Prelude` module API.
inline-r.cabal view
@@ -1,9 +1,9 @@ name: inline-r-version: 0.9.0.1+version: 0.9.0.2 license: BSD3 license-file: LICENSE copyright: Copyright (c) 2013-2015 Amgen, Inc.- Copyright (c) 2015 Tweag I/O Limited.+ Copyright (c) 2015-2017 Tweag I/O Limited. author: Mathieu Boespflug, Facundo Dominguez, Alexander Vershilov maintainer: Mathieu Boespflug <m@tweag.io> cabal-version: >=1.10@@ -61,11 +61,12 @@ Language.R.Globals Language.R.HExp Language.R.Instance- Language.R.Literal- Language.R.QQ Language.R.Internal Language.R.Internal.FunWrappers Language.R.Internal.FunWrappers.TH+ Language.R.Literal+ Language.R.Matcher+ Language.R.QQ if !os(windows) exposed-modules: Foreign.R.EventLoop Language.R.Event@@ -109,7 +110,7 @@ pkgconfig-depends: libR >= 3.0 -- XXX -fcontext-stack=32 required on GHC >= 7.8 to allow foreign -- export function -wrappers of high arities.- ghc-options: -Wall -fcontext-stack=32+ ghc-options: -Wall -freduction-depth=32 test-suite tests main-is: tests.hs@@ -141,6 +142,7 @@ Test.Event Test.Regions Test.Vector+ Test.Parser -- Adding -j4 causes quasiquoters to be compiled concurrently -- in tests, which helps testing for race conditions when -- trying to initialize R from multiple threads.
src/Control/Monad/R/Class.hs view
@@ -32,8 +32,8 @@ -- | 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 :: s ~ V => SEXP s a -> m (SEXP (Region m) a)+ default acquire :: (MonadIO m, Region m ~ G) => SEXP s a -> m (SEXP (Region m) a) acquire = liftIO . protect -- | A reification of an R execution context, i.e. a "session".
src/Foreign/R.chs view
@@ -103,7 +103,7 @@ , string , unsafeSEXPToVectorPtr , unsafeVectorPtrToSEXP- , indexVector+ , readVector , writeVector -- * Evaluation , eval@@ -130,6 +130,7 @@ , emptyEnv , globalEnv , signalHandlers+ , interruptsPending -- * Communication with runtime , printValue -- * Low level info header access@@ -149,6 +150,8 @@ , release , unsafeRelease , withProtected+ -- * Deprecated+ , indexVector ) where import Control.Memory.Region@@ -277,9 +280,13 @@ {#fun STRING_PTR as string { unsexp `SEXP s R.String'} -> `Ptr (SEXP s R.Char)' castPtr #} -{# fun VECTOR_ELT as indexVector `R.IsGenericVector a'+{# fun VECTOR_ELT as readVector `R.IsGenericVector a' => { unsexp `SEXP s a', `Int' } -> `SomeSEXP s' somesexp #}++indexVector :: IsGenericVector a => SEXP s a -> Int -> IO (SomeSEXP s)+{-# DEPRECATED indexVector "Use readVector instead." #-}+indexVector = readVector {# fun SET_VECTOR_ELT as writeVector `R.IsGenericVector a' => { unsexp `SEXP s a', `Int', unsexp `SEXP s b' }
src/Foreign/R/Internal.hsc view
@@ -231,6 +231,9 @@ -- | Signal handler switch foreign import ccall "&R_SignalHandlers" signalHandlers :: Ptr CInt +-- | Flag that shows if computation should be interrupted.+foreign import ccall "&R_interrupts_pending" interruptsPending :: Ptr CInt+ ---------------------------------------------------------------------------------- -- Structure header -- ----------------------------------------------------------------------------------
src/Language/R.hs view
@@ -20,6 +20,7 @@ , eval_ , evalEnv , install+ , cancel -- * Exceptions , throwR , throwRMessage@@ -63,6 +64,7 @@ ( alloca , castPtr , peek+ , poke ) import Foreign.C.String ( withCString, peekCString ) import Prelude@@ -155,6 +157,16 @@ throwR :: MonadR m => R.SEXP s 'R.Env -- ^ Environment in which to find error. -> m a throwR env = getErrorMessage env >>= io . throwIO . R.RError++-- | Cancel any ongoing R computation in the current process. After interruption+-- an 'RError' exception will be raised.+--+-- This call is safe to run in any thread. If there is no R computation running,+-- the next computaion will be immediately cancelled. Note that R will only+-- interrupt computations at so-called "safe points" (in particular, not in the+-- middle of a C call).+cancel :: IO ()+cancel = poke R.interruptsPending 1 -- | Throw an R exception with specified message. throwRMessage :: MonadR m => String -> m a
src/Language/R/Literal.hs view
@@ -38,6 +38,7 @@ import qualified Data.Vector.SEXP as SVector import qualified Data.Vector.SEXP.Mutable as SMVector import qualified Foreign.R as R+import qualified Foreign.R.Internal as R (somesexp) import Foreign.R.Type ( IsVector, SSEXPTYPE ) import Foreign.R ( SEXP, SomeSEXP(..) ) import Internal.Error@@ -62,7 +63,7 @@ import System.IO.Unsafe ( unsafePerformIO ) -- | Values that can be converted to 'SEXP'.-class Literal a ty | a -> ty where+class SingI ty => 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)@@ -252,7 +253,7 @@ 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)+ hFunWrap f a = hFunWrap $ f $! fromSEXP (R.cast sing (R.somesexp a) :: SEXP s la) foreign import ccall "missing_r.h funPtrToSEXP" funPtrToSEXP :: FunPtr a -> IO (SEXP s 'R.ExtPtr)
+ src/Language/R/Matcher.hs view
@@ -0,0 +1,348 @@+-- |+-- Copyright: (c) 2016, AlphaSheets, Inc+-- Stability: Experimental+-- Portability: Portable+--+-- A 'Matcher' lets you match 'SEXP' values against composable patterns, where+-- cascading cases would otherwise be necessary otherwise.+--+-- Example:+--+-- @+-- -- Check that input is an S3 object of class "matrix"+-- -- and return the value of the "dim" attribute.+-- isMatrix = matchOnly $ do+-- s3 ["matrix"]+-- dim+-- @++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++module Language.R.Matcher+ ( Matcher(..)+ , matchOnly+ -- * Matcher interface.+ -- $interface+ , somesexp+ , sexp+ , with+ -- * Type guards+ -- $guards+ , hexp+ , null+ , s4+ , s3+ , guardType+ -- * Queries+ , typeOf+ , getS3Class+ -- * Attributes+ -- $attributes+ , someAttribute+ , attribute+ , attributes+ , lookupAttribute+ -- * Attribute matchers+ , names+ , dim+ , dimnames+ , rownames+ -- * Derived matchers+ , factor+ -- * Helpers+ , charList+ , choice+ , list+ ) where++import Control.Applicative+import Control.DeepSeq+import Control.Exception (evaluate)+import Control.Monad (guard, ap, liftM)+import Data.Foldable (asum)+import Data.Functor (void)+import Data.Maybe (mapMaybe)+import Data.Singletons+import Data.Traversable+import Data.Typeable (Typeable)+import qualified Data.Vector.SEXP as SV+import Foreign hiding (void, with)+import Foreign.C.String+import qualified Foreign.R as R+import GHC.Generics (Generic)+import qualified H.Prelude as H+import H.Prelude hiding (typeOf, hexp)+import System.IO.Unsafe++import Prelude hiding (null)++-- | A composition of 'SEXP' destructors. A 'Matcher' is bound to the region+-- where 'SomeSEXP' is allocated, so extracted value will not leak out of the+-- region scope.+--+-- This matcher is a pure function, so if you need to allocate any object (for+-- example for comparison or lookup) you should do it before running matcher.+newtype Matcher s a = Matcher+ { runMatcher+ :: forall r.+ SomeSEXP s -- expression to match+ -> (a -> r) -- continuation in case of success+ -> (MatcherError s -> r) -- continuation in case of failure+ -> r+ }++-- Continuation monad is used in order to make matching fast and and have an+-- equal cost for left and right combinations. Different continuations for+-- success and failure cases were chosen because otherwise we'd have to keep+-- result in 'Either' that would lead to more boxing. Though I have to admit+-- that benchmarks were not done, and this approach were chosen as initial one,+-- as it's not much more complex then others.++instance Monad (Matcher s) where+ return x = Matcher $ \_ f _ -> f x+ Matcher f >>= k = Matcher $ \s ok err -> f s (\o -> runMatcher (k o) s ok err) err+ fail s = Matcher $ \_ _ err -> err $ MatcherError s++instance Applicative (Matcher s) where+ pure = return+ (<*>) = ap++instance Functor (Matcher s) where+ fmap = liftM++instance Alternative (Matcher s) where+ empty = fail "empty"+ f <|> g = Matcher $ \s ok err ->+ runMatcher f s ok (\e' -> runMatcher g s ok (err . (mappend e')))++instance Monoid (MatcherError s) where+ mempty = MatcherError "empty"+ a `mappend` MatcherError "empty" = a+ _ `mappend` a = a++-- | Exception during matching.+data MatcherError s+ = MatcherError String+ -- ^ Generic error.+ | TypeMissmatch (SomeSEXP s) R.SEXPTYPE R.SEXPTYPE+ -- ^ SEXP's type differ from requested one.+ | NoSuchAttribute (SomeSEXP s) String+ -- ^ Requested attribute does not exit.+ deriving (Typeable, Show, Generic)++instance NFData (MatcherError s)++-- | Match a 'SomeSEXP', returning a 'MatchError' if matching failed.+--+-- Result is always fully evaluated, since otherwise it wouldn't be possible to+-- guarantee that thunks in the return value will not escape the memory region.+matchOnly+ :: (MonadR m, Region m ~ s, NFData a)+ => Matcher s a+ -> SomeSEXP s+ -> m (Either (MatcherError s) a)+matchOnly p s =+ runMatcher p s (return . force . Right) (return . force . Left)++-- $interface+--+-- The main functions of the matcher provide a simple way of accessing+-- information about the current 'SomeSEXP'. Those functions are useful if you+-- use pure internal functions 'Foreign.R' functions to get information out of+-- the data structure.+--+-- Another scenario is to use them in submatchers together with 'with'+-- combinator, that allow you to inspect the structure deeper without exiting+-- the matcher.++-- | Returns current 'SomeSEXP'. Never fails.+somesexp :: Matcher s (SomeSEXP s)+somesexp = Matcher $ \s ok _ -> ok s++-- | Returns current 'SEXP' if it is of the requested type, fails otherwise,+-- returns @TypeMissmatch@ in that case.+sexp :: SSEXPTYPE ty -> Matcher s (SEXP s ty)+sexp p = Matcher $ \(SomeSEXP s) ok err ->+ if fromSing p == H.typeOf s+ then ok (R.unsafeCoerce s)+ else err $ TypeMissmatch (SomeSEXP s) (R.typeOf s) (fromSing p)++-- | Run a submatcher on another 'SomeSEXP'. All exceptions in the internal+-- matcher are propagated to the parent one. This combinator allows to inspect+-- nested structures without exiting the matcher, so it's possible to effectively+-- combine it with alternative function.+with :: SomeSEXP s -> Matcher s a -> Matcher s a+with s p = Matcher $ \_ ok err -> runMatcher p s ok err++-- $guards+--+-- Guards provides a handy way to check if we are expecting object of the type+-- we are interesting in.++-- | Succeeds if current @SomeSEXP@ is 'R.Null'.+null :: Matcher s ()+null = void $ sexp SNil++-- | Succeeds if current @SomeSEXP@ is S4 object. This check is more accurate+-- then using @guardType S4@ as it uses internal R's function to check if the+-- object is S4.+s4 :: Matcher s ()+s4 = Matcher $ \(SomeSEXP s) ok err ->+ -- Manual check using 'sexp' or 'hexp' is not enough, as R is clever enough+ -- to make this check not obvious.+ if R.isS4 s+ then ok ()+ else err (TypeMissmatch (SomeSEXP s) (R.typeOf s) R.S4)++-- | Succeeds if 'SomeSEXP' is an S3 object of the given type. In general case+-- it's better to use 'getS3Class' because it will run same check, but also will+-- return the class(es) of the current expression.+--+-- This test is not expressible in terms of the 'guardType', becausee guardType+-- does not see additional information about S3 types. And any raw object can be+-- a class instance.+s3 :: [String] -> Matcher s ()+s3 ns = getS3Class >>= guard . (ns ==)++-- | Continue execution if SEXP have required type. This check tests basic types+-- of the expression like if it's integer, or real or character vector and such.+-- If you need to test object type use 's3' or 's4' directly.+guardType :: R.SEXPTYPE -> Matcher s ()+guardType s = typeOf >>= guard . (s ==)++-- $attributes+--+-- Attributes are additional data that can be attached to any R value.+-- Attributes may be seen as a @Map Text (SomeSEXP s0)@. Attributes may add+-- additional information to the data that may completely change it's meaning.+-- For example by adding 'dim' attribute matrix or array can be created out of+-- vector, or factors are presented as an interger vector with 'rownames'+-- attribute attached.++-- | Returns any attribute by it's name if it exists. Fails with+-- @NoSuchAttribute@ otherwise.+someAttribute :: String -> Matcher s (SomeSEXP s)+someAttribute n = Matcher $ \(SomeSEXP s) ok err ->+ let result = unsafePerformIO $ do+ c <- withCString n R.install+ evaluate $ R.getAttribute s c+ in case R.typeOf result of+ R.Nil -> err (NoSuchAttribute (SomeSEXP s) n)+ _ -> ok (SomeSEXP result)++-- | Typed version of the 'someAttribute' call. In addition to retrieving value+-- it's dynamically type checked.+attribute :: SSEXPTYPE a -> String -> Matcher s (SEXP s a)+attribute p s = do+ (SomeSEXP z) <- someAttribute s+ if fromSing p == H.typeOf z+ then return $ R.unsafeCoerce z+ else empty++-- | Match all attributes, takes a matcher and applies it to the each attribute+-- exists, returns list of the attribute name, together with matcher result. If+-- matcher returns @Nothing@ - result is omitted..+attributes :: Matcher s (Maybe a) -> Matcher s [(String, a)]+attributes p = do+ SomeSEXP s <- somesexp+ let sa = unsafePerformIO $ SomeSEXP <$> R.getAttributes s+ with sa $ choice+ [ null *> pure []+ , do mns <- optional names+ case mns of+ Nothing -> return []+ Just ns -> do+ ps <- list (length ns) p+ return $ mapMaybe (\(x,y) -> fmap (x,) y) $ zip ns ps+ , pure []+ ]++-- | Find an attribute in attribute list if it exists.+lookupAttribute :: String -> Matcher s (Maybe (SomeSEXP s))+lookupAttribute s = (Just <$> someAttribute s) <|> pure Nothing++-- | 'Language.R.Hexp.hexp' lifted to Matcher, applies hexp to the current value+-- and allow to run internal matcher on it. Is useful when you need to inspect+-- data using high level functions from @Language.R@.+hexp :: SSEXPTYPE ty -> (HExp s ty -> Matcher s a) -> Matcher s a+hexp ty f = f . H.hexp =<< sexp ty++-- | Returns type of the current SEXP. Can never fail.+typeOf :: Matcher s R.SEXPTYPE+typeOf = (\(SomeSEXP s) -> H.typeOf s) <$> somesexp++-- | Return the class of the S3 object, fails otherwise.+getS3Class :: Matcher s [String]+getS3Class = charList <$> attribute SString "class"++--------------------------------------------------------------------------------+-- Helpers+--------------------------------------------------------------------------------++-- | Convert String 'SEXP' to the list of 'String's.+charList :: SEXP s 'R.String -> [String]+charList (H.hexp -> String v) =+ map ((\(Char s) -> SV.toString s) . H.hexp) $ SV.toList v+charList _ = error "Impossible happened."++-- | Get 'dim' attribute.+dim :: Matcher s [Int]+dim = go <$> attribute SInt "dim"+ where+ go :: SEXP s 'R.Int -> [Int]+ go (H.hexp -> Int v) = fromIntegral <$> SV.toList v+ go _ = error "Impossible happened."++-- | Get 'dimnames' attribute.+dimnames :: Matcher s [[String]]+dimnames = do+ s <- attribute SVector "dimnames"+ case H.hexp s of+ Vector _ v -> for (SV.toList v) (`with` go)+ where+ go = choice [charList <$> sexp SString, null *> pure []]++-- | Get 'names' attribute.+names :: Matcher s [String]+names = do+ s <- attribute SString "names"+ return $ charList s++-- | Get 'rownames' attribute.+rownames :: Matcher s [String]+rownames = do+ s <- attribute SString "row.names"+ return $ charList s++-- | Execute first matcher that will not fail.+choice :: [Matcher s a] -> Matcher s a+choice = asum++-- | Matches a @List@ object.+list+ :: Int -- ^ Upper bound on number of elements to match.+ -> Matcher s a -- ^ Matcher to apply to each element+ -> Matcher s [a]+list 0 _ = return []+list n p = choice+ [ null *> pure []+ -- TODO: quite possibly this method uses linear stack space. It should be+ -- verified and fixed if this is the case.+ , hexp SList $ \(List car cdr _) -> do+ v <- with (SomeSEXP car) p+ vs <- with (SomeSEXP cdr) $ list (n-1) p+ return (v:vs)+ ]++-- | Match a factor. Returns the levels of the factor.+factor :: Matcher s [String]+factor = do+ s3 ["factor"]+ levels <- charList <$> attribute SString "levels"+ hexp R.SInt $ \(Int v) ->+ return $! (\i -> levels !! (fromIntegral i - 1)) <$> SV.toList v
src/Language/R/QQ.hs view
@@ -147,7 +147,7 @@ -- compiler notices that it can let-float to top-level). let sx = unsafePerformIO $ do exprs <- parse closure- SomeSEXP e <- R.indexVector exprs 0+ SomeSEXP e <- R.readVector exprs 0 clos <- R.eval e (R.release globalEnv) R.unSomeSEXP clos R.preserveObject return clos
+ tests/Test/Parser.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+module Test.Parser+ ( tests )+ where++import Control.Applicative+import Data.Int+import H.Prelude+import qualified Foreign.R as R+import Language.R.Matcher as P++import Test.Tasty hiding (defaultMain)+import Test.Tasty.HUnit++tests :: TestTree+tests = testGroup "matcher"+ [ testCase "null" $ ((True @=?) =<<) $ do+ runRegion $ do+ s <- [r| NULL |]+ Right t <- matchOnly (P.null *> pure True <|> pure False) s+ return t+ , testCase "s3: pass non s3" $ ((True @=?) =<<) $ do+ runRegion $ do+ s <- [r| c(1:10) |]+ Right t <- matchOnly (P.s3 ["matrix"] *> pure False <|> pure True) s+ return t+ , testCase "s3: matches matrix" $ ((True @=?) =<<) $ do+ runRegion $ do+ s <- [r| x <- matrix(c(1:10)); class(x) <- "shmatrix"; x |]+ Right t <- matchOnly (P.s3 ["shmatrix"] *> pure True <|> pure False) s+ return t+ , testCase "typeOf: reads type" $ ((R.Int @=?) =<<) $ do+ runRegion $ do+ s <- [r| matrix(c(1:10)) |]+ Right t <- matchOnly P.typeOf s+ return t+ , testCase "guardType: proceeds" $ ((True @=?) =<<) $ do+ runRegion $ do+ s <- [r| matrix(c(1:10)) |]+ Right t <- matchOnly (P.guardType R.Int *> pure True <|> pure False) s+ return t+ , testCase "guardType: fails" $ ((True @=?) =<<) $ do+ runRegion $ do+ s <- [r| 1.0 |]+ Right t <- matchOnly (P.guardType R.Int *> pure False <|> pure True ) s+ return t+ , testCase "someAttribute" $ (([2,3::Int32] @=?) =<<) $ do+ runRegion $ do+ s <- [r| matrix(c(1:6), 2,3) |]+ Right t <- matchOnly (P.someAttribute "dim") s+ return (fromSEXP (R.cast SInt t))+ , testCase "someAttribute" $ (([2,3::Int32] @=?) =<<) $ do+ runRegion $ do+ s <- [r| matrix(c(1:6), 2,3) |]+ Right t <- matchOnly (P.attribute SInt "dim") s+ return (fromSEXP t)+ , testCase "getS3Class" $ ((["shmatrix"] @=?) =<<) $ do+ runRegion $ do+ s <- [r| x <- matrix(c(1:10),2,3); class(x) <- "shmatrix"; x |]+ Right t <- matchOnly P.getS3Class s+ return t+ ]
tests/tests.hs view
@@ -19,6 +19,7 @@ import qualified Test.GC import qualified Test.Regions import qualified Test.Vector+import qualified Test.Parser import H.Prelude import qualified Foreign.R as R@@ -31,6 +32,8 @@ import Test.Tasty.ExpectedFailure import Control.Applicative+import Control.Concurrent+import Control.Exception (handle) import Control.Memory.Region import Control.Monad (void) import Data.List (delete, find)@@ -99,11 +102,16 @@ , (if torture then id else ignoreTest) Test.Regions.tests , Test.Vector.tests , Test.Event.tests+ , Test.Parser.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" $ runRegion $ [r| 1 |] >> return () , testCase "sanity check " $ return ()+ , testCase "cancel works" $ do+ void $ forkIO $ cancel+ handle (\RError{} -> return ())+ (runRegion $ void $ [r| while(1){}; |]) ] main :: IO ()