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

instance Applicative (Matcher s) where
  pure :: a -> Matcher s a
pure = a -> Matcher s a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: Matcher s (a -> b) -> Matcher s a -> Matcher s 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 :: (a -> b) -> Matcher s a -> Matcher s b
fmap = (a -> b) -> Matcher s a -> Matcher s b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

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

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

instance Monoid (MatcherError s) where
  mempty :: MatcherError s
mempty = String -> MatcherError s
forall s. String -> MatcherError s
MatcherError "empty"
  mappend :: MatcherError s -> MatcherError s -> MatcherError s
mappend = MatcherError s -> MatcherError s -> MatcherError s
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
[MatcherError s] -> ShowS
MatcherError s -> String
(Int -> MatcherError s -> ShowS)
-> (MatcherError s -> String)
-> ([MatcherError s] -> ShowS)
-> Show (MatcherError s)
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 x. MatcherError s -> Rep (MatcherError s) x)
-> (forall x. Rep (MatcherError s) x -> MatcherError s)
-> Generic (MatcherError s)
forall x. Rep (MatcherError s) x -> MatcherError s
forall x. MatcherError s -> Rep (MatcherError s) x
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 :: Matcher s a -> SomeSEXP s -> m (Either (MatcherError s) a)
matchOnly p :: Matcher s a
p s :: SomeSEXP s
s =
  Matcher s a
-> SomeSEXP s
-> (a -> m (Either (MatcherError s) a))
-> (MatcherError s -> m (Either (MatcherError s) a))
-> m (Either (MatcherError s) a)
forall s a.
Matcher s a
-> forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r
runMatcher Matcher s a
p SomeSEXP s
s (Either (MatcherError s) a -> m (Either (MatcherError s) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (MatcherError s) a -> m (Either (MatcherError s) a))
-> (a -> Either (MatcherError s) a)
-> a
-> m (Either (MatcherError s) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (MatcherError s) a -> Either (MatcherError s) a
forall a. NFData a => a -> a
force (Either (MatcherError s) a -> Either (MatcherError s) a)
-> (a -> Either (MatcherError s) a)
-> a
-> Either (MatcherError s) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either (MatcherError s) a
forall a b. b -> Either a b
Right) (Either (MatcherError s) a -> m (Either (MatcherError s) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (MatcherError s) a -> m (Either (MatcherError s) a))
-> (MatcherError s -> Either (MatcherError s) a)
-> MatcherError s
-> m (Either (MatcherError s) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (MatcherError s) a -> Either (MatcherError s) a
forall a. NFData a => a -> a
force (Either (MatcherError s) a -> Either (MatcherError s) a)
-> (MatcherError s -> Either (MatcherError s) a)
-> MatcherError s
-> Either (MatcherError s) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MatcherError s -> Either (MatcherError s) a
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 :: Matcher s (SomeSEXP s)
somesexp = (forall r.
 SomeSEXP s -> (SomeSEXP s -> r) -> (MatcherError s -> r) -> r)
-> Matcher s (SomeSEXP s)
forall s a.
(forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r)
-> Matcher s a
Matcher ((forall r.
  SomeSEXP s -> (SomeSEXP s -> r) -> (MatcherError s -> r) -> r)
 -> Matcher s (SomeSEXP s))
-> (forall r.
    SomeSEXP s -> (SomeSEXP s -> r) -> (MatcherError s -> r) -> r)
-> Matcher s (SomeSEXP s)
forall a b. (a -> b) -> a -> b
$ \s :: SomeSEXP s
s ok :: SomeSEXP s -> r
ok _ -> 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 :: SSEXPTYPE ty -> Matcher s (SEXP s ty)
sexp p :: SSEXPTYPE ty
p = (forall r.
 SomeSEXP s -> (SEXP s ty -> r) -> (MatcherError s -> r) -> r)
-> Matcher s (SEXP s ty)
forall s a.
(forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r)
-> Matcher s a
Matcher ((forall r.
  SomeSEXP s -> (SEXP s ty -> r) -> (MatcherError s -> r) -> r)
 -> Matcher s (SEXP s ty))
-> (forall r.
    SomeSEXP s -> (SEXP s ty -> r) -> (MatcherError s -> r) -> r)
-> Matcher s (SEXP s ty)
forall a b. (a -> b) -> a -> b
$ \(SomeSEXP s :: SEXP s a
s) ok :: SEXP s ty -> r
ok err :: MatcherError s -> r
err ->
    if Sing ty -> Demote SEXPTYPE
forall k (a :: k). SingKind k => Sing a -> Demote k
fromSing Sing ty
SSEXPTYPE ty
p SEXPTYPE -> SEXPTYPE -> Bool
forall a. Eq a => a -> a -> Bool
== SEXP s a -> SEXPTYPE
forall s (a :: SEXPTYPE). SEXP s a -> SEXPTYPE
H.typeOf SEXP s a
s
    then SEXP s ty -> r
ok (SEXP s a -> SEXP s ty
forall s (a :: SEXPTYPE) (b :: SEXPTYPE). SEXP s a -> SEXP s b
R.unsafeCoerce SEXP s a
s)
    else MatcherError s -> r
err (MatcherError s -> r) -> MatcherError s -> r
forall a b. (a -> b) -> a -> b
$ SomeSEXP s -> SEXPTYPE -> SEXPTYPE -> MatcherError s
forall s. SomeSEXP s -> SEXPTYPE -> SEXPTYPE -> MatcherError s
TypeMissmatch (SEXP s a -> SomeSEXP s
forall s (a :: SEXPTYPE). SEXP s a -> SomeSEXP s
SomeSEXP SEXP s a
s) (SEXP s a -> SEXPTYPE
forall s (a :: SEXPTYPE). SEXP s a -> SEXPTYPE
R.typeOf SEXP s a
s) (Sing ty -> Demote SEXPTYPE
forall k (a :: k). SingKind k => Sing a -> Demote k
fromSing Sing ty
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 :: SomeSEXP s -> Matcher s a -> Matcher s a
with s :: SomeSEXP s
s p :: Matcher s a
p = (forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r)
-> Matcher s a
forall s a.
(forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r)
-> Matcher s a
Matcher ((forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r)
 -> Matcher s a)
-> (forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r)
-> Matcher s a
forall a b. (a -> b) -> a -> b
$ \_ ok :: a -> r
ok err :: MatcherError s -> r
err -> Matcher s a -> SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r
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 :: Matcher s ()
null = Matcher s (SEXP s 'Nil) -> Matcher s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Matcher s (SEXP s 'Nil) -> Matcher s ())
-> Matcher s (SEXP s 'Nil) -> Matcher s ()
forall a b. (a -> b) -> a -> b
$ SSEXPTYPE 'Nil -> Matcher s (SEXP s 'Nil)
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 :: Matcher s ()
s4 = (forall r. SomeSEXP s -> (() -> r) -> (MatcherError s -> r) -> r)
-> Matcher s ()
forall s a.
(forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r)
-> Matcher s a
Matcher ((forall r. SomeSEXP s -> (() -> r) -> (MatcherError s -> r) -> r)
 -> Matcher s ())
-> (forall r.
    SomeSEXP s -> (() -> r) -> (MatcherError s -> r) -> r)
-> Matcher s ()
forall a b. (a -> b) -> a -> b
$ \(SomeSEXP s :: SEXP s a
s) ok :: () -> r
ok err :: 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 SEXP s a -> Bool
forall s (ty :: SEXPTYPE). SEXP s ty -> Bool
R.isS4 SEXP s a
s
    then () -> r
ok ()
    else MatcherError s -> r
err (SomeSEXP s -> SEXPTYPE -> SEXPTYPE -> MatcherError s
forall s. SomeSEXP s -> SEXPTYPE -> SEXPTYPE -> MatcherError s
TypeMissmatch (SEXP s a -> SomeSEXP s
forall s (a :: SEXPTYPE). SEXP s a -> SomeSEXP s
SomeSEXP SEXP s a
s) (SEXP s a -> SEXPTYPE
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 :: [String] -> Matcher s ()
s3 ns :: [String]
ns = Matcher s [String]
forall s. Matcher s [String]
getS3Class Matcher s [String] -> ([String] -> Matcher s ()) -> Matcher s ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Matcher s ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Matcher s ())
-> ([String] -> Bool) -> [String] -> Matcher s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String]
ns [String] -> [String] -> Bool
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 :: SEXPTYPE -> Matcher s ()
guardType s :: SEXPTYPE
s = Matcher s SEXPTYPE
forall s. Matcher s SEXPTYPE
typeOf Matcher s SEXPTYPE -> (SEXPTYPE -> Matcher s ()) -> Matcher s ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Matcher s ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Matcher s ())
-> (SEXPTYPE -> Bool) -> SEXPTYPE -> Matcher s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SEXPTYPE
s SEXPTYPE -> SEXPTYPE -> Bool
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 :: String -> Matcher s (SomeSEXP s)
someAttribute n :: String
n = (forall r.
 SomeSEXP s -> (SomeSEXP s -> r) -> (MatcherError s -> r) -> r)
-> Matcher s (SomeSEXP s)
forall s a.
(forall r. SomeSEXP s -> (a -> r) -> (MatcherError s -> r) -> r)
-> Matcher s a
Matcher ((forall r.
  SomeSEXP s -> (SomeSEXP s -> r) -> (MatcherError s -> r) -> r)
 -> Matcher s (SomeSEXP s))
-> (forall r.
    SomeSEXP s -> (SomeSEXP s -> r) -> (MatcherError s -> r) -> r)
-> Matcher s (SomeSEXP s)
forall a b. (a -> b) -> a -> b
$ \(SomeSEXP s :: SEXP s a
s) ok :: SomeSEXP s -> r
ok err :: MatcherError s -> r
err ->
    let result :: SEXP s Any
result = IO (SEXP s Any) -> SEXP s Any
forall a. IO a -> a
unsafePerformIO (IO (SEXP s Any) -> SEXP s Any) -> IO (SEXP s Any) -> SEXP s Any
forall a b. (a -> b) -> a -> b
$ do
          SEXP V 'Symbol
c <- String -> (CString -> IO (SEXP V 'Symbol)) -> IO (SEXP V 'Symbol)
forall a. String -> (CString -> IO a) -> IO a
withCString String
n CString -> IO (SEXP V 'Symbol)
R.install
          SEXP s Any -> IO (SEXP s Any)
forall a. a -> IO a
evaluate (SEXP s Any -> IO (SEXP s Any)) -> SEXP s Any -> IO (SEXP s Any)
forall a b. (a -> b) -> a -> b
$ SEXP s a -> SEXP V 'Symbol -> SEXP s Any
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 SEXP s Any -> SEXPTYPE
forall s (a :: SEXPTYPE). SEXP s a -> SEXPTYPE
R.typeOf SEXP s Any
result of
      R.Nil -> MatcherError s -> r
err (SomeSEXP s -> String -> MatcherError s
forall s. SomeSEXP s -> String -> MatcherError s
NoSuchAttribute (SEXP s a -> SomeSEXP s
forall s (a :: SEXPTYPE). SEXP s a -> SomeSEXP s
SomeSEXP SEXP s a
s) String
n)
      _ -> SomeSEXP s -> r
ok (SEXP s Any -> SomeSEXP s
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 :: SSEXPTYPE a -> String -> Matcher s (SEXP s a)
attribute p :: SSEXPTYPE a
p s :: String
s = do
    (SomeSEXP z :: SEXP s a
z) <- String -> Matcher s (SomeSEXP s)
forall s. String -> Matcher s (SomeSEXP s)
someAttribute String
s
    if Sing a -> Demote SEXPTYPE
forall k (a :: k). SingKind k => Sing a -> Demote k
fromSing Sing a
SSEXPTYPE a
p SEXPTYPE -> SEXPTYPE -> Bool
forall a. Eq a => a -> a -> Bool
== SEXP s a -> SEXPTYPE
forall s (a :: SEXPTYPE). SEXP s a -> SEXPTYPE
H.typeOf SEXP s a
z
    then SEXP s a -> Matcher s (SEXP s a)
forall (m :: * -> *) a. Monad m => a -> m a
return (SEXP s a -> Matcher s (SEXP s a))
-> SEXP s a -> Matcher s (SEXP s a)
forall a b. (a -> b) -> a -> b
$ SEXP s a -> SEXP s a
forall s (a :: SEXPTYPE) (b :: SEXPTYPE). SEXP s a -> SEXP s b
R.unsafeCoerce SEXP s a
z
    else Matcher s (SEXP s a)
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 :: Matcher s (Maybe a) -> Matcher s [(String, a)]
attributes p :: Matcher s (Maybe a)
p = do
    SomeSEXP s :: SEXP s a
s <- Matcher s (SomeSEXP s)
forall s. Matcher s (SomeSEXP s)
somesexp
    let sa :: SomeSEXP s
sa = IO (SomeSEXP s) -> SomeSEXP s
forall a. IO a -> a
unsafePerformIO (IO (SomeSEXP s) -> SomeSEXP s) -> IO (SomeSEXP s) -> SomeSEXP s
forall a b. (a -> b) -> a -> b
$ SEXP s Any -> SomeSEXP s
forall s (a :: SEXPTYPE). SEXP s a -> SomeSEXP s
SomeSEXP (SEXP s Any -> SomeSEXP s) -> IO (SEXP s Any) -> IO (SomeSEXP s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SEXP s a -> IO (SEXP s Any)
forall s (a :: SEXPTYPE) (b :: SEXPTYPE). SEXP s a -> IO (SEXP s b)
R.getAttributes SEXP s a
s
    SomeSEXP s -> Matcher s [(String, a)] -> Matcher s [(String, a)]
forall s a. SomeSEXP s -> Matcher s a -> Matcher s a
with SomeSEXP s
sa (Matcher s [(String, a)] -> Matcher s [(String, a)])
-> Matcher s [(String, a)] -> Matcher s [(String, a)]
forall a b. (a -> b) -> a -> b
$ [Matcher s [(String, a)]] -> Matcher s [(String, a)]
forall s a. [Matcher s a] -> Matcher s a
choice
      [ Matcher s ()
forall s. Matcher s ()
null Matcher s () -> Matcher s [(String, a)] -> Matcher s [(String, a)]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [(String, a)] -> Matcher s [(String, a)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      , do Maybe [String]
mns <- Matcher s [String] -> Matcher s (Maybe [String])
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Matcher s [String]
forall s. Matcher s [String]
names
           case Maybe [String]
mns of
             Nothing -> [(String, a)] -> Matcher s [(String, a)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
             Just ns :: [String]
ns -> do
               [Maybe a]
ps <- Int -> Matcher s (Maybe a) -> Matcher s [Maybe a]
forall s a. Int -> Matcher s a -> Matcher s [a]
list ([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ns) Matcher s (Maybe a)
p
               [(String, a)] -> Matcher s [(String, a)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, a)] -> Matcher s [(String, a)])
-> [(String, a)] -> Matcher s [(String, a)]
forall a b. (a -> b) -> a -> b
$ ((String, Maybe a) -> Maybe (String, a))
-> [(String, Maybe a)] -> [(String, a)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(x :: String
x,y :: Maybe a
y) -> (a -> (String, a)) -> Maybe a -> Maybe (String, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
x,) Maybe a
y) ([(String, Maybe a)] -> [(String, a)])
-> [(String, Maybe a)] -> [(String, a)]
forall a b. (a -> b) -> a -> b
$ [String] -> [Maybe a] -> [(String, Maybe a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
ns [Maybe a]
ps
      , [(String, a)] -> Matcher s [(String, a)]
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 :: String -> Matcher s (Maybe (SomeSEXP s))
lookupAttribute s :: String
s = (SomeSEXP s -> Maybe (SomeSEXP s)
forall a. a -> Maybe a
Just (SomeSEXP s -> Maybe (SomeSEXP s))
-> Matcher s (SomeSEXP s) -> Matcher s (Maybe (SomeSEXP s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Matcher s (SomeSEXP s)
forall s. String -> Matcher s (SomeSEXP s)
someAttribute String
s) Matcher s (Maybe (SomeSEXP s))
-> Matcher s (Maybe (SomeSEXP s)) -> Matcher s (Maybe (SomeSEXP s))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (SomeSEXP s) -> Matcher s (Maybe (SomeSEXP s))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (SomeSEXP s)
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 :: SSEXPTYPE ty -> (HExp s ty -> Matcher s a) -> Matcher s a
hexp ty :: SSEXPTYPE ty
ty f :: HExp s ty -> Matcher s a
f = HExp s ty -> Matcher s a
f (HExp s ty -> Matcher s a)
-> (SEXP s ty -> HExp s ty) -> SEXP s ty -> Matcher s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SEXP s ty -> HExp s ty
forall s (a :: SEXPTYPE). SEXP s a -> HExp s a
H.hexp (SEXP s ty -> Matcher s a) -> Matcher s (SEXP s ty) -> Matcher s a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SSEXPTYPE ty -> Matcher s (SEXP s ty)
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 :: Matcher s SEXPTYPE
typeOf = (\(SomeSEXP s :: SEXP s a
s) -> SEXP s a -> SEXPTYPE
forall s (a :: SEXPTYPE). SEXP s a -> SEXPTYPE
H.typeOf SEXP s a
s) (SomeSEXP s -> SEXPTYPE)
-> Matcher s (SomeSEXP s) -> Matcher s SEXPTYPE
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Matcher s (SomeSEXP s)
forall s. Matcher s (SomeSEXP s)
somesexp

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

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

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

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

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

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

-- | Get 'rownames' attribute.
rownames :: Matcher s [String]
rownames :: Matcher s [String]
rownames = do
    SEXP s 'String
s <- SSEXPTYPE 'String -> String -> Matcher s (SEXP s 'String)
forall (a :: SEXPTYPE) s.
SSEXPTYPE a -> String -> Matcher s (SEXP s a)
attribute SSEXPTYPE 'String
SString "row.names"
    [String] -> Matcher s [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> Matcher s [String]) -> [String] -> Matcher s [String]
forall a b. (a -> b) -> a -> b
$ SEXP s 'String -> [String]
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 :: [Matcher s a] -> Matcher s a
choice = [Matcher s a] -> Matcher s a
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 :: Int -> Matcher s a -> Matcher s [a]
list 0 _ = [a] -> Matcher s [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
list n :: Int
n p :: Matcher s a
p = [Matcher s [a]] -> Matcher s [a]
forall s a. [Matcher s a] -> Matcher s a
choice
    [ Matcher s ()
forall s. Matcher s ()
null Matcher s () -> Matcher s [a] -> Matcher s [a]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [a] -> Matcher s [a]
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.
    , SSEXPTYPE 'List -> (HExp s 'List -> Matcher s [a]) -> Matcher s [a]
forall (ty :: SEXPTYPE) s a.
SSEXPTYPE ty -> (HExp s ty -> Matcher s a) -> Matcher s a
hexp SSEXPTYPE 'List
SList ((HExp s 'List -> Matcher s [a]) -> Matcher s [a])
-> (HExp s 'List -> Matcher s [a]) -> Matcher s [a]
forall a b. (a -> b) -> a -> b
$ \(List car :: SEXP s a
car cdr :: SEXP s b
cdr _) -> do
         a
v <- SomeSEXP s -> Matcher s a -> Matcher s a
forall s a. SomeSEXP s -> Matcher s a -> Matcher s a
with (SEXP s a -> SomeSEXP s
forall s (a :: SEXPTYPE). SEXP s a -> SomeSEXP s
SomeSEXP SEXP s a
car) Matcher s a
p
         [a]
vs <- SomeSEXP s -> Matcher s [a] -> Matcher s [a]
forall s a. SomeSEXP s -> Matcher s a -> Matcher s a
with (SEXP s b -> SomeSEXP s
forall s (a :: SEXPTYPE). SEXP s a -> SomeSEXP s
SomeSEXP SEXP s b
cdr) (Matcher s [a] -> Matcher s [a]) -> Matcher s [a] -> Matcher s [a]
forall a b. (a -> b) -> a -> b
$ Int -> Matcher s a -> Matcher s [a]
forall s a. Int -> Matcher s a -> Matcher s [a]
list (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) Matcher s a
p
         [a] -> Matcher s [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (a
va -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
vs)
    ]

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