{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
module Language.R.QQ
( r
, rsafe
, collectAntis
) where
import Control.Memory.Region
import Control.Monad.R.Class
import qualified Data.Vector.SEXP as Vector
import qualified Foreign.R as R
import qualified Foreign.R.Parse as R
import Foreign.R (SEXP, SomeSEXP(..))
import Foreign.R.Error
import Internal.Error
import Language.R (eval)
import Language.R.Globals (nilValue, globalEnv)
import Language.R.GC (automaticSome)
import Language.R.HExp
import Language.R.Instance
import Language.R.Literal (mkSEXPIO)
import Language.Haskell.TH (Q, runIO)
import Language.Haskell.TH.Quote
import qualified Language.Haskell.TH.Syntax as TH
import qualified Language.Haskell.TH.Lib as TH
import Control.Concurrent (MVar, newMVar, takeMVar, putMVar)
import Control.Exception (throwIO)
import Control.Monad (unless)
import Control.Monad.IO.Class (liftIO)
import Data.List (intercalate, isSuffixOf)
import qualified Data.Set as Set
import Data.Set (Set)
import Foreign (alloca, peek)
import Foreign.C.String (withCString)
import System.IO.Unsafe (unsafePerformIO)
import qualified Text.Heredoc as Heredoc
import qualified System.IO.Temp as Temp
import System.Process
import System.IO
import System.Exit
r :: QuasiQuoter
r :: QuasiQuoter
r = QuasiQuoter
{ quoteExp :: [Char] -> Q Exp
quoteExp = \[Char]
txt -> [| eval =<< $(expQQ txt) |]
, quotePat :: [Char] -> Q Pat
quotePat = forall a. [Char] -> a
unimplemented [Char]
"quotePat"
, quoteType :: [Char] -> Q Type
quoteType = forall a. [Char] -> a
unimplemented [Char]
"quoteType"
, quoteDec :: [Char] -> Q [Dec]
quoteDec = forall a. [Char] -> a
unimplemented [Char]
"quoteDec"
}
rsafe :: QuasiQuoter
rsafe :: QuasiQuoter
rsafe = QuasiQuoter
{ quoteExp :: [Char] -> Q Exp
quoteExp = \[Char]
txt -> [| unsafePerformIO $ runRegion $ automaticSome =<< eval =<< $(expQQ txt) |]
, quotePat :: [Char] -> Q Pat
quotePat = forall a. [Char] -> a
unimplemented [Char]
"quotePat"
, quoteType :: [Char] -> Q Type
quoteType = forall a. [Char] -> a
unimplemented [Char]
"quoteType"
, quoteDec :: [Char] -> Q [Dec]
quoteDec = forall a. [Char] -> a
unimplemented [Char]
"quoteDec"
}
qqLock :: MVar ()
qqLock :: MVar ()
qqLock = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (MVar a)
newMVar ()
{-# NOINLINE qqLock #-}
parse :: String -> IO (R.SEXP V 'R.Expr)
parse :: [Char] -> IO (SEXP V 'Expr)
parse [Char]
txt = do
Config -> IO ()
initialize Config
defaultConfig
forall a. [Char] -> (CString -> IO a) -> IO a
withCString [Char]
txt forall a b. (a -> b) -> a -> b
$ \CString
ctxt ->
forall (a :: SEXPTYPE) s b.
IO (SEXP V a) -> (SEXP s a -> IO b) -> IO b
R.withProtected (CString -> IO (SEXP V 'String)
R.mkString CString
ctxt) forall a b. (a -> b) -> a -> b
$ \SEXP V 'String
rtxt ->
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr CInt
status -> do
forall (a :: SEXPTYPE) s b.
IO (SEXP V a) -> (SEXP s a -> IO b) -> IO b
R.withProtected (forall (a :: SEXPTYPE) s.
In a '[ 'Nil, 'String] =>
SEXP s 'String -> Int -> Ptr CInt -> SEXP s a -> IO (SEXP s 'Expr)
R.parseVector SEXP V 'String
rtxt (-Int
1) Ptr CInt
status (forall t s (a :: SEXPTYPE). (t <= s) => SEXP s a -> SEXP t a
R.release SEXP G 'Nil
nilValue)) forall a b. (a -> b) -> a -> b
$ \SEXP V 'Expr
exprs -> do
Int
rc <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
status
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ParseStatus
R.PARSE_OK forall a. Eq a => a -> a -> Bool
== forall a. Enum a => Int -> a
toEnum Int
rc) forall a b. (a -> b) -> a -> b
$
forall e a. Exception e => e -> IO a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> RError
RError forall a b. (a -> b) -> a -> b
$ [Char]
"Parse error in: " forall a. [a] -> [a] -> [a]
++ [Char]
txt
forall (m :: * -> *) a. Monad m => a -> m a
return SEXP V 'Expr
exprs
antiSuffix :: String
antiSuffix :: [Char]
antiSuffix = [Char]
"_hs"
chop :: String -> String
chop :: [Char] -> [Char]
chop [Char]
name = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
name forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
antiSuffix) [Char]
name
#ifdef mingw32_HOST_OS
fixwinslash :: String -> String
fixwinslash str = let
repl '\\' = '/'
repl c = c
in map repl str
#endif
collectAntis
:: String
-> IO (Either String [String])
collectAntis :: [Char] -> IO (Either [Char] [[Char]])
collectAntis [Char]
input = do
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[Char] -> ([Char] -> Handle -> m a) -> m a
Temp.withSystemTempFile [Char]
"inline-r-.R" forall a b. (a -> b) -> a -> b
$ \[Char]
input_file Handle
input_fh -> do
Handle -> [Char] -> IO ()
hPutStr Handle
input_fh [Char]
input
Handle -> IO ()
hClose Handle
input_fh
(ExitCode
code, [Char]
stdout, [Char]
stderr) <- [Char] -> [[Char]] -> [Char] -> IO (ExitCode, [Char], [Char])
readProcessWithExitCode [Char]
"R" [[Char]
"--slave"]
#ifdef mingw32_HOST_OS
$ "input_file <- \"" ++ (fixwinslash input_file) ++ "\"\n" ++
#else
forall a b. (a -> b) -> a -> b
$ [Char]
"input_file <- \"" forall a. [a] -> [a] -> [a]
++ [Char]
input_file forall a. [a] -> [a] -> [a]
++ [Char]
"\"\n" forall a. [a] -> [a] -> [a]
++
#endif
[Heredoc.there|R/collectAntis.R|]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case ExitCode
code of
ExitCode
ExitSuccess -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
words [Char]
stdout
ExitFailure{} -> forall a b. a -> Either a b
Left [Char]
stderr
expQQ :: String -> Q TH.Exp
expQQ :: [Char] -> Q Exp
expQQ [Char]
input = do
Either [Char] [[Char]]
mb_antis <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO (Either [Char] [[Char]])
collectAntis [Char]
input
[[Char]]
antis <- case Either [Char] [[Char]]
mb_antis of
Right [[Char]]
antis -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Char]]
antis
Left [Char]
msg -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$
[ [Char]
"An error occurred while trying to parse the R code."
, [Char]
"The stderr of the R interpreter was:"
, [Char]
msg
]
let args :: [Q Exp]
args = forall a b. (a -> b) -> [a] -> [b]
map (forall (m :: * -> *). Quote m => [Char] -> m Exp
TH.dyn forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
chop) [[Char]]
antis
closure :: [Char]
closure = [Char]
"function(" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," [[Char]]
antis forall a. [a] -> [a] -> [a]
++ [Char]
"){" forall a. [a] -> [a] -> [a]
++ [Char]
input forall a. [a] -> [a] -> [a]
++ [Char]
"}"
z :: Q Exp
z = [| return (R.release nilValue) |]
[Name]
vars <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\[Char]
_ -> forall (m :: * -> *). Quote m => [Char] -> m Name
TH.newName [Char]
"x") [[Char]]
antis
Exp
x <- (\Q Exp
body -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
TH.appE Q Exp
body [Q Exp]
args) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
TH.lamE (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
TH.varP [Name]
vars)
[|
let sx = unsafePerformIO $ do
exprs <- parse closure
SomeSEXP e <- R.readVector exprs 0
clos <- R.eval e (R.release globalEnv)
R.unSomeSEXP clos R.preserveObject
return clos
in io $ case sx of
SomeSEXP f ->
R.lcons f =<<
$(foldr (\x xs -> [| R.withProtected $xs $ \cdr -> do
car <- mkSEXPIO $(TH.varE x)
R.lcons car cdr |]) z vars)
|]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
x