H (empty) → 0.7.0.0
raw patch · 8 files changed
+420/−0 lines, 8 filesdep +basedep +bytestringdep +cmdargs
Dependencies added: base, bytestring, cmdargs, directory, file-embed, inline-r, pretty, process, singletons, tasty, tasty-golden, tasty-hunit, temporary-rc, text, vector
Files
- H.cabal +58/−0
- H.ghci +16/−0
- H.hs +52/−0
- tests/qq-errors.ghci +10/−0
- tests/qq-errors.ghci.golden.err +21/−0
- tests/qq.ghci +132/−0
- tests/qq.ghci.golden.out +54/−0
- tests/tests.hs +77/−0
+ H.cabal view
@@ -0,0 +1,58 @@+name: H+version: 0.7.0.0+license: BSD3+copyright: Copyright (c) 2013-2015 Amgen, Inc.+ Copyright (c) 2015 Tweag I/O Limited.+author: Mathieu Boespflug, Facundo Dominguez, Alexander Vershilov+maintainer: Alexander Vershilov <alexander.vershilov@tweag.io>+cabal-version: >=1.10+build-type: Simple+Category: FFI+Synopsis: The Haskell/R mixed programming environment.+description: This package is part of the HaskellR project.+cabal-version: >=1.10+extra-source-files: H.ghci+ tests/qq.ghci+ tests/qq.ghci.golden.out+ tests/qq-errors.ghci+ tests/qq-errors.ghci.golden.err++source-repository head+ type: git+ location: git://github.com/tweag/HaskellR.git+ subdir: H++executable H+ main-is: H.hs+ build-depends: inline-r+ , base >= 4.6 && < 5+ , bytestring >= 0.10+ , cmdargs >= 0.10.5+ , file-embed >= 0.0.7+ , pretty >= 1.1+ , process >= 1.2+ , temporary-rc >= 1.2.0.3+ , vector >= 0.10+ default-language: Haskell2010+ ghc-options: -Wall -threaded++test-suite tests+ main-is: tests.hs+ type: exitcode-stdio-1.0+ build-depends: base >= 4.6 && < 5+ , bytestring >= 0.10+ , directory >= 1.2+ , inline-r >= 0.6+ , process >= 1.2+ , tasty >= 0.3+ , tasty-golden >= 2.3+ , tasty-hunit >= 0.4.1+ , text >= 0.11+ , vector+ , singletons+ -- Adding -j4 causes quasiquoters to be compiled concurrently+ -- in tests, which helps testing for race conditions when+ -- trying to initialize R from multiple threads.+ ghc-options: -Wall -threaded -j4+ hs-source-dirs: tests+ default-language: Haskell2010
+ H.ghci view
@@ -0,0 +1,16 @@+-- Copyright: (C) 2013 Amgen, Inc.+:set -fno-ghci-sandbox+:set -XDataKinds+:set -XGADTs+:set -XQuasiQuotes+:set -XScopedTypeVariables+:set -XTemplateHaskell+:set -XViewPatterns++import Language.R.HExp as H+import qualified H.Prelude.Interactive as H+import Foreign.R as R (SEXP, SomeSEXP(..), SEXPTYPE, SEXPInfo, unSomeSEXP)+import Language.R as R (R)+import Language.R.QQ as H (r, rexp, rsafe)++Language.R.Instance.initialize Language.R.Instance.defaultConfig
+ H.hs view
@@ -0,0 +1,52 @@+-- |+-- Copyright: (C) 2013 Amgen, Inc.+--++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TemplateHaskell #-}++module Main where++import Data.ByteString (hPut)+import Data.FileEmbed (embedFile)+import Data.Version ( showVersion )+import System.Console.CmdArgs+import System.Exit (exitWith)+import System.IO (hClose)+import System.IO.Temp (withSystemTempFile)+import System.Process++import qualified Paths_H++data H = H+ { configFiles :: [FilePath]+ , configInteractive :: FilePath+ } deriving (Eq, Data, Typeable, Show)++cmdSpec :: H+cmdSpec = H+ { configFiles = def &= args &= typ "-- [GHCi options]"+ , configInteractive = "ghci" &= explicit &= name "interactive" &= help "Run interpreter" &= opt "ghci" &= typ "ghci" &= help "Set an alternative haskell interpreter."+ }+ &= program "H" &=+ help "H wrapper over ghci. " &=+ summary ("H version " ++ showVersion Paths_H.version +++ "\nCopyright (C) 2013-2014 Amgen, Inc." +++ "\nCopyright (C) 2015 Tweag I/O Limited.")+ -- TODO: add details clause++main :: IO ()+main = do+ config <- cmdArgs cmdSpec+ case config of+ H {configFiles, configInteractive} -> withSystemTempFile "H.ghci" $ \cfg h -> do+ hPut h $(embedFile "H.ghci") >> hClose h+ let argv = configFiles ++ ["-v0", "-ghci-script", cfg]+ (_,_,_,ph) <-+ createProcess (proc configInteractive argv)+ { std_in = Inherit+ , std_out = Inherit+ , delegate_ctlc = True+ }+ exitWith =<< waitForProcess ph
+ tests/qq-errors.ghci view
@@ -0,0 +1,10 @@+:m +Control.Exception++-- Disable showing summaries of the call stack for more reproducible tests.+_ <- [r| options('showErrorCalls'=FALSE) |]++[r| plot() |]++[r| plot( |]++[r| 1+()-2 |]
+ tests/qq-errors.ghci.golden.err view
@@ -0,0 +1,21 @@+*** Exception: R Runtime Error: Error in xy.coords(x, y, xlabel, ylabel, log) : + argument "x" is missing, with no default+++<interactive>:9:1:+ Exception when trying to run compile-time code:+ R Runtime Error: Error in parse(text = " plot( ", keep.source = FALSE) : + <text>:2:0: unexpected end of input+1: plot( + ^++ Code: Language.Haskell.TH.Quote.quoteExp r " plot( "++<interactive>:11:1:+ Exception when trying to run compile-time code:+ R Runtime Error: Error in parse(text = " 1+()-2 ", keep.source = FALSE) : + <text>:1:5: unexpected ')'+1: 1+()+ ^++ Code: Language.Haskell.TH.Quote.quoteExp r " 1+()-2 "
+ tests/qq.ghci view
@@ -0,0 +1,132 @@+:set -XDataKinds+:set -XScopedTypeVariables+:m +Data.Int+import qualified Foreign.R as R+import Control.Applicative ((<$>))++-- Should be: [1] 1+H.print =<< [r| 1 |]++-- Should be: [1] 2+H.print =<< [r| 1 + 2 |]++-- Should be: [1] "1" "2" "3"+H.print =<< [r| c(1,2,"3") |] :: IO ()++-- Should be: [1] 2+H.print =<< [r| x <- 2 |] :: IO ()++-- Should be: [1] 3+H.print =<< [r| x+1 |]++---- Should be: [1] 6+let y = (5::Double)+H.print =<< [r| y_hs + 1 |]++---- Should be: Closure ???+H.print =<< [r| function(y) y_hs + y |]++-- Should be 8+H.print =<< [r| z <- function(y) y_hs + y |]+H.print =<< [r| z(3) |]++-- Should be [1] 1 2 3 4 5 6 7 8 9 10+H.print =<< [r| y <- c(1:10) |]+let foo1 = (\x -> (return $ x+1 :: R s Double))+let foo2 = (\x -> (return $ map (+1) x :: R s [Int32]))++-- Should be [1] 2+H.print =<< [r| (function(x).Call(foo1_hs,x))(2) |]++-- Should be [1] 2 3 4 5 6 7 8 9 10 11+H.print =<< [r| (function(x).Call(foo2_hs,x))(y) |]++-- Should be [1] 43+H.print =<< [r| x <- 42 ; x + 1 |]++-- Should be [1] 1 2 3+let xs = [1,2,3]::[Double]+H.print =<< [r| xs_hs |]++-- Should be [1] 8+H.print =<< [r| foo1_hs(7) |]++-- Should be NULL+H.print H.nilValue++-- Should be [1] 3+let foo3 = (\n -> fmap H.fromSomeSEXP [r| n_hs |]) :: Int32 -> R s Int32+H.print =<< [r| foo3_hs(as.integer(3)) |]++-- | should be 3+let foo4 = (\n m -> return $ n + m) :: Double -> Double -> R s Double+H.print =<< [r| foo4_hs(33, 66) |]++-- Should be [1] 120 but it doesn't work+let fact n = if n == (0 :: Int32) then (return 1 :: R s Int32) else fmap H.fromSomeSEXP [r| as.integer(n_hs * fact_hs(as.integer(n_hs - 1))) |]+H.print =<< [r| fact_hs(as.integer(5)) |]++:set -XDataKinds+-- Should be [1] 29+let foo5 = (\n -> return (n+1)) :: Int32 -> R s Int32+let apply = (\n m -> [r| .Call(n_hs, m_hs) |]) :: R.Callback s -> Int32 -> R s (R.SomeSEXP s)+H.print =<< [r| apply_hs(foo5_hs, as.integer(28) ) |]++sym <- H.install "blah"+H.print sym++-- Should be [1] 100+_ <- [r| `+` <- function(x,y) x * y |]+H.print =<< [r| 10 + 10 |]++-- Should be [1] 20+H.print =<< [r| base::`+`(10,10) |]++-- restore usual meaning of `+`+_ <- [r| `+` <- base::`+` |]++:{+let hFib :: Foreign.R.SEXP s Foreign.R.Int -> H.Prelude.R s (Foreign.R.SEXP s Foreign.R.Int)+ hFib n@(H.fromSEXP -> (0 :: Int32)) = fmap (flip R.asTypeOf n) [r| as.integer(0) |]+ hFib n@(H.fromSEXP -> (1 :: Int32)) = fmap (flip R.asTypeOf n) [r| as.integer(1) |]+ hFib n =+ (`R.asTypeOf` n) <$>+ [r| as.integer(hFib_hs(as.integer(n_hs - 1)) + hFib_hs(as.integer(n_hs - 2))) |]+:}++-- Should be [1] 4181+-- H.print =<< H.Prelude.runR H.defaultConfig (hFib (H.Prelude.mkSEXP (19 :: Int32))) -- XXX produces wrong result.++-- s4 objects test+-- Create an S4 class+H.print =<< [r| setClass("x-test",representation(a = "numeric", b = "numeric"), prototype(a=1,b=2)) |]+-- instantiate and object in R+H.print =<< [r| x <- new("x-test") |]+-- instantiate and object and pass it to H as-is+x <- [r| new("x-test") |]+-- show object+H.print x+-- Should be 1. Use slot accessor on R object.+H.print =<< [r| x@a |]+-- Should be 2. Use slot accessor on H object.+H.print =<< [r| x_hs@b |]+-- Should be "S4". Get type of R object.+H.print =<< [r| typeof(x) |]+-- Should be "S4". Get type of H object.+H.print =<< [r| typeof(x_hs) |]++:{+let testpm :: SomeSEXP s -> IO ()+ testpm (SomeSEXP z@(hexp -> S4 p))+ | R.True <- H.dynSEXP [rsafe| z_hs @ a > 0 |] = H.print z+ | otherwise = print "unexpected value"+:}++testpm x++-- Should be "S4". Get type of H object.+-- XXX This is a workaround to avoid the test hanging on windows.+-- For some reason, if the output of ghci is redirected and the last+-- command in the test is `testpm x`, then ghci executes all commands+-- but does not produce any R output and seems to block forever.+H.print =<< [r| typeof(x_hs) |]
+ tests/qq.ghci.golden.out view
@@ -0,0 +1,54 @@+[1] 1+[1] 3+[1] "1" "2" "3"+[1] 2+[1] 3+[1] 6+function (y = ) +5 + y+function (y = ) +5 + y+[1] 8+ [1] 1 2 3 4 5 6 7 8 9 10+[1] 3+ [1] 2 3 4 5 6 7 8 9 10 11+[1] 43+[1] 1 2 3+[1] 8+NULL+[1] 3+[1] 99+[1] 120+[1] 29+blah+[1] 100+[1] 20+class generator function for class "x-test" from package '.GlobalEnv'+function (...) +new("x-test", ...)+An object of class "x-test"+Slot "a":+[1] 1++Slot "b":+[1] 2++An object of class "x-test"+Slot "a":+[1] 1++Slot "b":+[1] 2++[1] 1+[1] 2+[1] "S4"+[1] "S4"+An object of class "x-test"+Slot "a":+[1] 1++Slot "b":+[1] 2++[1] "S4"
+ tests/tests.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++-- | Contains golden tests. To reset the expected output with the actual output,+-- run with @--accept@ or remove the golden file that you want to reset.++module Main where++import Control.Applicative+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import qualified Language.R.Instance as R+import System.Environment (setEnv)+import System.IO+import System.Process+import Test.Tasty+import Test.Tasty.Golden.Advanced+import Prelude -- silence AMP warning++-- | Pipe input to given command and return stdout, stderr.+cat :: FilePath -> [String] -> FilePath -> IO (Text, Text)+cat cmd args fp = do+ inh <- openFile fp ReadMode+ (_, Just outh, Just errh, _) <- createProcess $ (proc cmd args)+ { std_in = UseHandle inh+ , std_out = CreatePipe+ , std_err = CreatePipe+ }+ (,) <$> Text.hGetContents outh <*> Text.hGetContents errh++invokeH :: FilePath -> IO (Text, Text)+invokeH = cat "H" []++gold :: TestName -> FilePath -> IO Text -> TestTree+gold name golden action =+ goldenTest+ name+ (Text.readFile golden)+ action+ (\(scrub -> expected) (scrub -> actual) ->+ if Text.words expected == Text.words actual+ then return Nothing+ else return $ Just $+ unlines ["Outputs don't match."+ , "Expected:"+ , Text.unpack expected+ , ""+ , "Actual:"+ , Text.unpack actual+ ])+ (Text.writeFile golden)+ where+ scrub = Text.replace "\r\n" "\n"++tests :: TestTree+tests = testGroup "Integration tests"+ [ gold+ "qq"+ "tests/qq.ghci.golden.out"+ (fst <$> invokeH "tests/qq.ghci")+ , gold+ "qq-stderr"+ "tests/qq-errors.ghci.golden.err"+ (snd <$> invokeH "tests/qq-errors.ghci")+ -- , scriptCase "Functions - factorial" $+ -- "tests" </> "R" </> "fact.R"+ -- , scriptCase "Functions - Fibonacci sequence" $+ -- "tests" </> "R" </> "fib.R"+ ]++main :: IO ()+main = do+ -- Normalize internalization settings.+ setEnv "LC_ALL" "C"+ _ <- R.initialize R.defaultConfig+ defaultMain tests