-- |
-- Copyright: (C) 2013 Amgen, Inc.
--

{-# 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

-------------------------------------------------------------------------------
-- Compile time Quasi-Quoter                                                 --
-------------------------------------------------------------------------------

-- | An R value, expressed as an R expression, in R's syntax.
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"
    }

-- | Quasiquoter for pure R code (no side effects) and that does not depend on
-- the global environment (referential transparency). This means that all
-- symbols must appear qualified with a package namespace (whose bindings are
-- locked by default), the code must not affect R shared state in any way,
-- including the global environment, and must not perform I/O.

-- TODO some of the above invariants can be checked statically. Do so.
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"
    }

-- | Serialize quasiquotes using a global lock, because the compiler is allowed
-- in theory to run them in parallel, yet the R runtime is not reentrant.
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 antiquotation variable names to get the corresponding Haskell variable name.
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

-- | Map backwards slashes to forward slashes.
#ifdef mingw32_HOST_OS
fixwinslash :: String -> String
fixwinslash str = let
  repl '\\' = '/'
  repl c = c
  in map repl str
#endif

-- | Find all occurences of antiquotations.
--
-- This function works by parsing the user's R code in a separate
-- R process. As a nice side-effect, it will detect and return any syntax
-- errors in the quasi-quoted R code.
--
-- This function is exposed only for testing; you probably don't need to
-- call it in the user code.
collectAntis
  :: String
    -- ^ the R code that may contain antiquotations, which are
    -- identifiers ending with 'antiSuffix'
  -> IO (Either String [String])
    -- ^ either an error message from R, or a list of unique antiquoted
    -- identifiers
collectAntis :: [Char] -> IO (Either [Char] [[Char]])
collectAntis [Char]
input = do
  -- Write our input to a temporary file. We could interpolate it into the
  -- R code below directly, but that would make it harder to disentangle
  -- syntax errors in the user's code from our wrapper code.
  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"]
      -- Note: --slave was recently renamed to --no-echo. --slave still works
      -- but is no longer documented. Using the old option name for now just
      -- in case the user have an older (pre-2020) version of R.
      --                              
      -- Change backslashes to forward slashes in tempFile names 
      -- under Windows. Windows is tolerant of this Unixification, but 
      -- Unix systems (and R) are less tolerant of naked backslashes 
      -- outside of valid escape sequences. For example, 
      -- str <- "C:\Users\joe" is invalid in R.
#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

-- | An R quasiquote is syntactic sugar for a function that we
-- generate, which closes over all antiquotation variables, and applies the
-- function to the Haskell values to which those variables are bound. Example:
--
-- @
-- [r| x_hs + y_hs |] ==> apply (apply [r| function(x_hs, y_hs) x_hs + y_hs |] x) y
-- @
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
    -- Abstract over antis using fresh vars, to avoid captures with names bound
    -- internally (such as 'f' below).
    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)
      [| -- Memoize the runtime parsing of the generated closure (provided the
         -- compiler notices that it can let-float to top-level).
         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