diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/inline-r.cabal b/inline-r.cabal --- a/inline-r.cabal +++ b/inline-r.cabal @@ -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 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. diff --git a/src/Control/Monad/R/Class.hs b/src/Control/Monad/R/Class.hs --- a/src/Control/Monad/R/Class.hs +++ b/src/Control/Monad/R/Class.hs @@ -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". diff --git a/src/Foreign/R.chs b/src/Foreign/R.chs --- a/src/Foreign/R.chs +++ b/src/Foreign/R.chs @@ -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' } diff --git a/src/Foreign/R/Internal.hsc b/src/Foreign/R/Internal.hsc --- a/src/Foreign/R/Internal.hsc +++ b/src/Foreign/R/Internal.hsc @@ -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 -- ---------------------------------------------------------------------------------- diff --git a/src/Language/R.hs b/src/Language/R.hs --- a/src/Language/R.hs +++ b/src/Language/R.hs @@ -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 diff --git a/src/Language/R/Literal.hs b/src/Language/R/Literal.hs --- a/src/Language/R/Literal.hs +++ b/src/Language/R/Literal.hs @@ -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) diff --git a/src/Language/R/Matcher.hs b/src/Language/R/Matcher.hs new file mode 100644 --- /dev/null +++ b/src/Language/R/Matcher.hs @@ -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 diff --git a/src/Language/R/QQ.hs b/src/Language/R/QQ.hs --- a/src/Language/R/QQ.hs +++ b/src/Language/R/QQ.hs @@ -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 diff --git a/tests/Test/Parser.hs b/tests/Test/Parser.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Parser.hs @@ -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 + ] diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -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 ()