-- |
-- 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.Semigroup as Sem
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
  { forall s a.
Matcher s a
-> forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r
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 :: forall a. a -> Matcher s a
return a
x = forall s a.
(forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r)
-> Matcher s a
Matcher forall a b. (a -> b) -> a -> b
$ \SomeSEXP s
_ a -> r
f MatcherError s -> r
_ -> a -> r
f a
x
  Matcher forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r
f >>= :: forall a b. Matcher s a -> (a -> Matcher s b) -> Matcher s b
>>= a -> Matcher s b
k = forall s a.
(forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r)
-> Matcher s a
Matcher forall a b. (a -> b) -> a -> b
$ \SomeSEXP s
s b -> r
ok MatcherError s -> r
err -> forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r
f SomeSEXP s
s (\a
o -> forall s a.
Matcher s a
-> forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r
runMatcher (a -> Matcher s b
k a
o) SomeSEXP s
s b -> r
ok MatcherError s -> r
err) MatcherError s -> r
err

instance MonadFail (Matcher s) where
  fail :: forall a. String -> Matcher s a
fail String
s = forall s a.
(forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r)
-> Matcher s a
Matcher forall a b. (a -> b) -> a -> b
$ \SomeSEXP s
_ a -> r
_ MatcherError s -> r
err -> MatcherError s -> r
err forall a b. (a -> b) -> a -> b
$ forall s. String -> MatcherError s
MatcherError String
s

instance Applicative (Matcher s) where
  pure :: forall a. a -> Matcher s a
pure = forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: forall a b. Matcher s (a -> b) -> Matcher s a -> Matcher s b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Functor (Matcher s) where
  fmap :: forall a b. (a -> b) -> Matcher s a -> Matcher s b
fmap = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Alternative (Matcher s) where
  empty :: forall a. Matcher s a
empty = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"empty"
  Matcher s a
f <|> :: forall a. Matcher s a -> Matcher s a -> Matcher s a
<|> Matcher s a
g = forall s a.
(forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r)
-> Matcher s a
Matcher forall a b. (a -> b) -> a -> b
$ \SomeSEXP s
s a -> r
ok MatcherError s -> r
err ->
      forall s a.
Matcher s a
-> forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r
runMatcher Matcher s a
f SomeSEXP s
s a -> r
ok (\MatcherError s
e' -> forall s a.
Matcher s a
-> forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r
runMatcher Matcher s a
g SomeSEXP s
s a -> r
ok (MatcherError s -> r
err forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Monoid a => a -> a -> a
mappend MatcherError s
e')))

instance Sem.Semigroup (MatcherError s) where
  MatcherError s
a <> :: MatcherError s -> MatcherError s -> MatcherError s
<> MatcherError String
"empty" = MatcherError s
a
  MatcherError s
_ <> MatcherError s
a = MatcherError s
a

instance Monoid (MatcherError s) where
  mempty :: MatcherError s
mempty = forall s. String -> MatcherError s
MatcherError String
"empty"
  mappend :: MatcherError s -> MatcherError s -> MatcherError s
mappend = forall a. Semigroup a => a -> 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, Int -> MatcherError s -> ShowS
forall s. Int -> MatcherError s -> ShowS
forall s. [MatcherError s] -> ShowS
forall s. MatcherError s -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MatcherError s] -> ShowS
$cshowList :: forall s. [MatcherError s] -> ShowS
show :: MatcherError s -> String
$cshow :: forall s. MatcherError s -> String
showsPrec :: Int -> MatcherError s -> ShowS
$cshowsPrec :: forall s. Int -> MatcherError s -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s x. Rep (MatcherError s) x -> MatcherError s
forall s x. MatcherError s -> Rep (MatcherError s) x
$cto :: forall s x. Rep (MatcherError s) x -> MatcherError s
$cfrom :: forall s x. MatcherError s -> Rep (MatcherError s) x
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, NFData a)
  => Matcher s a
  -> SomeSEXP s
  -> m (Either (MatcherError s) a)
matchOnly :: forall (m :: * -> *) a s.
(MonadR m, NFData a) =>
Matcher s a -> SomeSEXP s -> m (Either (MatcherError s) a)
matchOnly Matcher s a
p SomeSEXP s
s =
  forall s a.
Matcher s a
-> forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r
runMatcher Matcher s a
p SomeSEXP s
s (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NFData a => a -> a
force forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NFData a => a -> a
force forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
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 :: forall s. Matcher s (SomeSEXP s)
somesexp = forall s a.
(forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r)
-> Matcher s a
Matcher forall a b. (a -> b) -> a -> b
$ \SomeSEXP s
s SomeSEXP s -> r
ok MatcherError s -> r
_ -> SomeSEXP s -> r
ok SomeSEXP s
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 :: forall (ty :: SEXPTYPE) s. SSEXPTYPE ty -> Matcher s (SEXP s ty)
sexp SSEXPTYPE ty
p = forall s a.
(forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r)
-> Matcher s a
Matcher forall a b. (a -> b) -> a -> b
$ \(SomeSEXP SEXP s a
s) SEXP s ty -> r
ok MatcherError s -> r
err ->
    if forall k (a :: k). SingKind k => Sing a -> Demote k
fromSing SSEXPTYPE ty
p forall a. Eq a => a -> a -> Bool
== forall s (a :: SEXPTYPE). SEXP s a -> SEXPTYPE
H.typeOf SEXP s a
s
    then SEXP s ty -> r
ok (forall s (a :: SEXPTYPE) (b :: SEXPTYPE). SEXP s a -> SEXP s b
R.unsafeCoerce SEXP s a
s)
    else MatcherError s -> r
err forall a b. (a -> b) -> a -> b
$ forall s. SomeSEXP s -> SEXPTYPE -> SEXPTYPE -> MatcherError s
TypeMissmatch (forall s (a :: SEXPTYPE). SEXP s a -> SomeSEXP s
SomeSEXP SEXP s a
s) (forall s (a :: SEXPTYPE). SEXP s a -> SEXPTYPE
R.typeOf SEXP s a
s) (forall k (a :: k). SingKind k => Sing a -> Demote k
fromSing SSEXPTYPE ty
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 :: forall s a. SomeSEXP s -> Matcher s a -> Matcher s a
with SomeSEXP s
s Matcher s a
p = forall s a.
(forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r)
-> Matcher s a
Matcher forall a b. (a -> b) -> a -> b
$ \SomeSEXP s
_ a -> r
ok MatcherError s -> r
err -> forall s a.
Matcher s a
-> forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r
runMatcher Matcher s a
p SomeSEXP s
s a -> r
ok MatcherError s -> r
err

-- $guards
--
-- Guards provides a handy way to check if we are expecting object of the type
-- we are interested in.

-- | Succeeds if current @SomeSEXP@ is 'R.Null'.
null :: Matcher s ()
null :: forall s. Matcher s ()
null = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (ty :: SEXPTYPE) s. SSEXPTYPE ty -> Matcher s (SEXP s ty)
sexp SSEXPTYPE 'Nil
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 :: forall s. Matcher s ()
s4 = forall s a.
(forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r)
-> Matcher s a
Matcher forall a b. (a -> b) -> a -> b
$ \(SomeSEXP SEXP s a
s) () -> r
ok MatcherError s -> r
err ->
    -- Manual check using 'sexp' or 'hexp' is not enough, as R is clever enough
    -- to make this check not obvious.
    if forall s (ty :: SEXPTYPE). SEXP s ty -> Bool
R.isS4 SEXP s a
s
    then () -> r
ok ()
    else MatcherError s -> r
err (forall s. SomeSEXP s -> SEXPTYPE -> SEXPTYPE -> MatcherError s
TypeMissmatch (forall s (a :: SEXPTYPE). SEXP s a -> SomeSEXP s
SomeSEXP SEXP s a
s) (forall s (a :: SEXPTYPE). SEXP s a -> SEXPTYPE
R.typeOf SEXP s a
s) SEXPTYPE
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', because guardType
-- does not see additional information about S3 types. And any raw object can be
-- a class instance.
s3 :: [String] -> Matcher s ()
s3 :: forall s. [String] -> Matcher s ()
s3 [String]
ns = forall s. Matcher s [String]
getS3Class forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String]
ns forall a. Eq a => a -> a -> Bool
==)

-- | 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 :: forall s. SEXPTYPE -> Matcher s ()
guardType SEXPTYPE
s = forall s. Matcher s SEXPTYPE
typeOf forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SEXPTYPE
s forall a. Eq a => a -> a -> Bool
==)

-- $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 its name if it exists. Fails with
-- @NoSuchAttribute@ otherwise.
someAttribute :: String -> Matcher s (SomeSEXP s)
someAttribute :: forall s. String -> Matcher s (SomeSEXP s)
someAttribute String
n = forall s a.
(forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r)
-> Matcher s a
Matcher forall a b. (a -> b) -> a -> b
$ \(SomeSEXP SEXP s a
s) SomeSEXP s -> r
ok MatcherError s -> r
err ->
    let result :: SEXP s Any
result = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
          SEXP V 'Symbol
c <- forall a. String -> (CString -> IO a) -> IO a
withCString String
n CString -> IO (SEXP V 'Symbol)
R.install
          forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall s (a :: SEXPTYPE) s2 (b :: SEXPTYPE) (c :: SEXPTYPE).
SEXP s a -> SEXP s2 b -> SEXP s c
R.getAttribute SEXP s a
s SEXP V 'Symbol
c
    in case forall s (a :: SEXPTYPE). SEXP s a -> SEXPTYPE
R.typeOf SEXP s Any
result of
      SEXPTYPE
R.Nil -> MatcherError s -> r
err (forall s. SomeSEXP s -> String -> MatcherError s
NoSuchAttribute (forall s (a :: SEXPTYPE). SEXP s a -> SomeSEXP s
SomeSEXP SEXP s a
s) String
n)
      SEXPTYPE
_ -> SomeSEXP s -> r
ok (forall s (a :: SEXPTYPE). SEXP s a -> SomeSEXP s
SomeSEXP SEXP s Any
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 :: forall (a :: SEXPTYPE) s.
SSEXPTYPE a -> String -> Matcher s (SEXP s a)
attribute SSEXPTYPE a
p String
s = do
    (SomeSEXP SEXP s a
z) <- forall s. String -> Matcher s (SomeSEXP s)
someAttribute String
s
    if forall k (a :: k). SingKind k => Sing a -> Demote k
fromSing SSEXPTYPE a
p forall a. Eq a => a -> a -> Bool
== forall s (a :: SEXPTYPE). SEXP s a -> SEXPTYPE
H.typeOf SEXP s a
z
    then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s (a :: SEXPTYPE) (b :: SEXPTYPE). SEXP s a -> SEXP s b
R.unsafeCoerce SEXP s a
z
    else forall (f :: * -> *) a. Alternative f => f a
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 :: forall s a. Matcher s (Maybe a) -> Matcher s [(String, a)]
attributes Matcher s (Maybe a)
p = do
    SomeSEXP SEXP s a
s <- forall s. Matcher s (SomeSEXP s)
somesexp
    let sa :: SomeSEXP s
sa = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall s (a :: SEXPTYPE). SEXP s a -> SomeSEXP s
SomeSEXP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (a :: SEXPTYPE) (b :: SEXPTYPE). SEXP s a -> IO (SEXP s b)
R.getAttributes SEXP s a
s
    forall s a. SomeSEXP s -> Matcher s a -> Matcher s a
with SomeSEXP s
sa forall a b. (a -> b) -> a -> b
$ forall s a. [Matcher s a] -> Matcher s a
choice
      [ forall s. Matcher s ()
null forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      , do Maybe [String]
mns <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall s. Matcher s [String]
names
           case Maybe [String]
mns of
             Maybe [String]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
             Just [String]
ns -> do
               [Maybe a]
ps <- forall s a. Int -> Matcher s a -> Matcher s [a]
list (forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ns) Matcher s (Maybe a)
p
               forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(String
x,Maybe a
y) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
x,) Maybe a
y) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [String]
ns [Maybe a]
ps
      , forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      ]

-- | Find an attribute in attribute list if it exists.
lookupAttribute :: String -> Matcher s (Maybe (SomeSEXP s))
lookupAttribute :: forall s. String -> Matcher s (Maybe (SomeSEXP s))
lookupAttribute String
s = (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. String -> Matcher s (SomeSEXP s)
someAttribute String
s) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

-- | 'Language.R.Hexp.hexp' lifted to Matcher, applies hexp to the current value
-- and allows you 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 :: forall (ty :: SEXPTYPE) s a.
SSEXPTYPE ty -> (HExp s ty -> Matcher s a) -> Matcher s a
hexp SSEXPTYPE ty
ty HExp s ty -> Matcher s a
f = HExp s ty -> Matcher s a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
H.hexp forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (ty :: SEXPTYPE) s. SSEXPTYPE ty -> Matcher s (SEXP s ty)
sexp SSEXPTYPE ty
ty

-- | Returns type of the current SEXP. Can never fail.
typeOf :: Matcher s R.SEXPTYPE
typeOf :: forall s. Matcher s SEXPTYPE
typeOf = (\(SomeSEXP SEXP s a
s) -> forall s (a :: SEXPTYPE). SEXP s a -> SEXPTYPE
H.typeOf SEXP s a
s) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Matcher s (SomeSEXP s)
somesexp

-- | Return the class of the S3 object, fails otherwise.
getS3Class :: Matcher s [String]
getS3Class :: forall s. Matcher s [String]
getS3Class = forall s. SEXP s 'String -> [String]
charList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: SEXPTYPE) s.
SSEXPTYPE a -> String -> Matcher s (SEXP s a)
attribute SSEXPTYPE 'String
SString String
"class"

--------------------------------------------------------------------------------
-- Helpers
--------------------------------------------------------------------------------

-- | Convert String 'SEXP' to the list of 'String's.
charList :: SEXP s 'R.String -> [String]
charList :: forall s. SEXP s 'String -> [String]
charList (forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
H.hexp -> String Vector 'String (SEXP V 'Char)
v) =
  forall a b. (a -> b) -> [a] -> [b]
map ((\(Char Vector 'Char Word8
s) -> Vector 'Char Word8 -> String
SV.toString Vector 'Char Word8
s) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
H.hexp) forall a b. (a -> b) -> a -> b
$ forall (ty :: SEXPTYPE) a. SVECTOR ty a => Vector ty a -> [a]
SV.toList Vector 'String (SEXP V 'Char)
v

-- | Get 'dim' attribute.
dim :: Matcher s [Int]
dim :: forall s. Matcher s [Int]
dim = forall s. SEXP s 'Int -> [Int]
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: SEXPTYPE) s.
SSEXPTYPE a -> String -> Matcher s (SEXP s a)
attribute SSEXPTYPE 'Int
SInt String
"dim"
  where
    go :: SEXP s 'R.Int -> [Int]
    go :: forall s. SEXP s 'Int -> [Int]
go (forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
H.hexp -> Int Vector 'Int Int32
v) = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (ty :: SEXPTYPE) a. SVECTOR ty a => Vector ty a -> [a]
SV.toList Vector 'Int Int32
v

-- | Get 'dimnames' attribute.
dimnames :: Matcher s [[String]]
dimnames :: forall s. Matcher s [[String]]
dimnames = do
    SEXP s 'Vector
s <- forall (a :: SEXPTYPE) s.
SSEXPTYPE a -> String -> Matcher s (SEXP s a)
attribute SSEXPTYPE 'Vector
SVector String
"dimnames"
    case forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
H.hexp SEXP s 'Vector
s of
      Vector Int32
_ Vector 'Vector (SomeSEXP V)
v -> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall (ty :: SEXPTYPE) a. SVECTOR ty a => Vector ty a -> [a]
SV.toList Vector 'Vector (SomeSEXP V)
v) forall a b. (a -> b) -> a -> b
$ \SomeSEXP V
x ->
        forall s a. SomeSEXP s -> Matcher s a -> Matcher s a
with (forall s g. SomeSEXP s -> SomeSEXP g
R.unsafeReleaseSome SomeSEXP V
x) forall s. Matcher s [String]
go
  where
    go :: Matcher s [String]
go = forall s a. [Matcher s a] -> Matcher s a
choice [forall s. SEXP s 'String -> [String]
charList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (ty :: SEXPTYPE) s. SSEXPTYPE ty -> Matcher s (SEXP s ty)
sexp SSEXPTYPE 'String
SString, forall s. Matcher s ()
null forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure []]

-- | Get 'names' attribute.
names :: Matcher s [String]
names :: forall s. Matcher s [String]
names = do
    SEXP s 'String
s <- forall (a :: SEXPTYPE) s.
SSEXPTYPE a -> String -> Matcher s (SEXP s a)
attribute SSEXPTYPE 'String
SString String
"names"
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. SEXP s 'String -> [String]
charList SEXP s 'String
s

-- | Get 'rownames' attribute.
rownames :: Matcher s [String]
rownames :: forall s. Matcher s [String]
rownames = do
    SEXP s 'String
s <- forall (a :: SEXPTYPE) s.
SSEXPTYPE a -> String -> Matcher s (SEXP s a)
attribute SSEXPTYPE 'String
SString String
"row.names"
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. SEXP s 'String -> [String]
charList SEXP s 'String
s

-- | Execute first matcher that will not fail.
choice :: [Matcher s a] -> Matcher s a
choice :: forall s a. [Matcher s a] -> Matcher s a
choice = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
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 :: forall s a. Int -> Matcher s a -> Matcher s [a]
list Int
0 Matcher s a
_ = forall (m :: * -> *) a. Monad m => a -> m a
return []
list Int
n Matcher s a
p = forall s a. [Matcher s a] -> Matcher s a
choice
    [ forall s. Matcher s ()
null forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      -- TODO: quite possibly this method uses linear stack space. It should be
      -- verified and fixed if this is the case.
    , forall (ty :: SEXPTYPE) s a.
SSEXPTYPE ty -> (HExp s ty -> Matcher s a) -> Matcher s a
hexp SSEXPTYPE 'List
SList forall a b. (a -> b) -> a -> b
$ \(List SEXP s a1
car SEXP s b1
cdr SEXP s c
_) -> do
         a
v <- forall s a. SomeSEXP s -> Matcher s a -> Matcher s a
with (forall s (a :: SEXPTYPE). SEXP s a -> SomeSEXP s
SomeSEXP SEXP s a1
car) Matcher s a
p
         [a]
vs <- forall s a. SomeSEXP s -> Matcher s a -> Matcher s a
with (forall s (a :: SEXPTYPE). SEXP s a -> SomeSEXP s
SomeSEXP SEXP s b1
cdr) forall a b. (a -> b) -> a -> b
$ forall s a. Int -> Matcher s a -> Matcher s [a]
list (Int
nforall a. Num a => a -> a -> a
-Int
1) Matcher s a
p
         forall (m :: * -> *) a. Monad m => a -> m a
return (a
vforall a. a -> [a] -> [a]
:[a]
vs)
    ]

-- | Match a factor. Returns the levels of the factor.
factor :: Matcher s [String]
factor :: forall s. Matcher s [String]
factor = do
    forall s. [String] -> Matcher s ()
s3 [String
"factor"]
    [String]
levels <- forall s. SEXP s 'String -> [String]
charList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: SEXPTYPE) s.
SSEXPTYPE a -> String -> Matcher s (SEXP s a)
attribute SSEXPTYPE 'String
SString String
"levels"
    forall (ty :: SEXPTYPE) s a.
SSEXPTYPE ty -> (HExp s ty -> Matcher s a) -> Matcher s a
hexp SSEXPTYPE 'Int
R.SInt forall a b. (a -> b) -> a -> b
$ \(Int Vector 'Int Int32
v) ->
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (\Int32
i -> [String]
levels forall a. [a] -> Int -> a
!! (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
i forall a. Num a => a -> a -> a
- Int
1)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (ty :: SEXPTYPE) a. SVECTOR ty a => Vector ty a -> [a]
SV.toList Vector 'Int Int32
v