inline-r-0.9.2: tests/test-qq.hs

-- |
-- Copyright: (C) 2013 Amgen, Inc.
--
-- Run H on a number of R programs of increasing size and complexity, comparing
-- the output of H with the output of R.

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}

module Main where

import qualified Foreign.R as R
import H.Prelude as H
import qualified Data.Vector.SEXP as SVector
import qualified Data.Vector.SEXP.Mutable as SMVector
import Control.Memory.Region
import Data.Text (Text)

import Control.Applicative
import Control.Monad.Trans (liftIO)
import Data.Int
import Data.Singletons (sing)
import Test.Tasty.HUnit hiding ((@=?))
import Prelude -- Silence AMP warning

hFib :: SEXP s 'R.Int -> R s (SEXP s 'R.Int)
hFib n@(H.fromSEXP -> 0 :: Int32) = fmap (flip R.asTypeOf n) [r| 0L |]
hFib n@(H.fromSEXP -> 1 :: Int32) = fmap (flip R.asTypeOf n) [r| 1L |]
hFib n = (`R.asTypeOf` n) <$> [r| hFib_hs(n_hs - 1L) + hFib_hs(n_hs - 2L) |]

-- | Version of '(@=?)' that works in the R monad.
(@=?) :: Literal a b => String -> a -> R s ()
expected @=? actual = liftIO $ do
    let actualstr = cast SString [rsafe| deparse(actual_hs) |]
    assertEqual "" expected (fromSEXP actualstr)

main :: IO ()
main = H.withEmbeddedR H.defaultConfig $ H.runRegion $ do

    -- Placing it before enabling gctorture2 for speed.
    ("4181L" @=?) =<< hFib =<< H.mkSEXP (19 :: Int32)

    _ <- [r| gctorture2(1,0,TRUE) |]

    ("1" @=?) =<< [r| 1 |]

    ("1" @=?) =<< return [rsafe| 1 |]

    ("3" @=?) =<< [r| 1 + 2 |]

    ("3" @=?) =<< return [rsafe| base::`+`(1, 2) |]

    ("c(\"1\", \"2\", \"3\")" @=?) =<< [r| c(1,2,"3") |]

    ("2" @=?) =<< [r| x <<- 2 |]

    ("3" @=?) =<< [r| x+1 |]

    let y = (5::Double)
    ("6" @=?) =<< [r| y_hs + 1 |]

    _ <- [r| z <<- function(y) y_hs + y |]
    ("8" @=?) =<< [r| z(3) |]

    ("1:10" @=?) =<< [r| y <<- c(1:10) |]

    let foo1 = (\x -> (return $ x+1 :: R s Double))
    let foo2 = (\x -> (return $ map (+1) x :: R s [Int32]))

    ("3" @=?) =<< [r| mapply(foo1_hs, 2) |]

    ("2:11" @=?) =<< [r| mapply(foo2_hs, y) |]

    ("43" @=?) =<< [r| x <<- 42 ; x + 1 |]

    let xs = [1,2,3]::[Double]
    ("c(1, 2, 3)" @=?) =<< [r| xs_hs |]

    ("8" @=?) =<< [r| foo1_hs(7) |]

    ("NULL" @=?) H.nilValue

    let foo3 = (\n -> fmap fromSomeSEXP [r| n_hs |]) :: Int32 -> R s Int32
    ("3L" @=?) =<< [r| foo3_hs(3L) |]

    let foo4 = (\n m -> return $ n + m) :: Double -> Double -> R s Double
    ("99" @=?) =<< [r| foo4_hs(33, 66) |]

    let fact (0 :: Int32) = return 1 :: R s Int32
        fact n = fmap dynSEXP [r| n_hs * fact_hs(n_hs - 1L) |]
    ("120L" @=?) =<< [r| fact_hs(5L) |]

    let foo5  = \(n :: Int32) -> return (n+1) :: R s Int32
    let apply :: R.SEXP s 'R.Closure -> Int32 -> R s (R.SomeSEXP s)
        apply n m = [r| n_hs(m_hs) |]
    ("29L" @=?) =<< [r| apply_hs(foo5_hs, 28L ) |]

    -- test Vector literal instance
    v1 <- do
      x <- SMVector.new 3 :: R s (SMVector.MVector s 'R.Int Int32)
      SMVector.unsafeWrite x 0 1
      SMVector.unsafeWrite x 1 2
      SMVector.unsafeWrite x 2 3
      return x
    let v2 = SMVector.release v1 :: SMVector.MVector V 'R.Int Int32
    ("c(7, 2, 3)" @=?) =<< [r| v = v2_hs; v[1] <- 7; v |]
    io . assertEqual "" "fromList [1,2,3]" . Prelude.show =<< SVector.unsafeFreeze v1

    let utf8string = "abcd çéõßø" :: String
    io . assertEqual "" utf8string =<< fromSEXP <$> R.cast (sing :: R.SSEXPTYPE 'R.String) <$> [r| utf8string_hs |]

    let utf8string1 = "abcd çéõßø" :: Text
    io . assertEqual "" utf8string1 =<< fromSEXP <$> R.cast (sing :: R.SSEXPTYPE 'R.String) <$> [r| utf8string1_hs |]

    -- Disable gctorture, otherwise test takes too long to execute.
    _ <- [r| gctorture2(0) |]
    let x = ([1] :: [Double])
    ("3" @=?) =<< [r| suppressMessages(require("Matrix"))
                      v <- x_hs + 1
                      v <- v + 1
                      v |]

    return ()