Rationalize H.Prelude exports and adapt H.ghci accordingly.

As part of this patch, remove the 'Show' class - or rather, make it private and rename it. It was being annoying before, because its name would clash with the standard type class from the Prelude. Now the H REPL only has H.Prelude imported by default. So the prompt is no longer cabalistic.
tweag · Jan 31, 2016 · 123ce15 · 123ce15
1 parent 11966dd
commit 123ce15
Show file tree

Hide file tree

Showing 17 changed files with 92 additions and 138 deletions.
diff --git a/H/H.ghci b/H/H.ghci
@@ -7,10 +7,6 @@
 :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, rsafe)
+import H.Prelude.Interactive as H.Prelude
 
 Language.R.Instance.initialize Language.R.Instance.defaultConfig
diff --git a/H/tests/qq.ghci b/H/tests/qq.ghci
@@ -4,106 +4,104 @@ import qualified Foreign.R as R
 import Control.Applicative ((<$>))
 
 -- Should be: [1] 1
-H.print =<< [r| 1 |]
+p [r| 1 |]
 
 -- Should be: [1] 2
-H.print =<< [r| 1 + 2 |]
+p [r| 1 + 2 |]
 
 -- Should be: [1] "1" "2" "3"
-H.print =<< [r| c(1,2,"3") |] :: IO ()
+p [r| c(1,2,"3") |] :: IO ()
 
 -- Should be: [1] 2
-H.print =<< [r| x <<- 2 |] :: IO ()
+p [r| x <<- 2 |] :: IO ()
 
 -- Should be: [1] 3
-H.print =<< [r| x+1 |]
+p [r| x+1 |]
 
 ---- Should be: [1] 6
 let y = (5::Double)
-H.print =<< [r| y_hs + 1 |]
+p [r| y_hs + 1 |]
 
 -- Printing of functions gives non deterministic output (env names change).
---H.print =<< [r| function(y) y_hs + y |]
+--p [r| function(y) y_hs + y |]
 
 -- Should be 8
-H.print =<< [r| z <- function(y) y_hs + y; z(3) |]
+p [r| z <- function(y) y_hs + y; z(3) |]
 
 -- Should be [1] 1 2 3 4 5 6 7 8 9 10
-H.print =<< [r| y <<- c(1:10) |]
+p [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| mapply(foo1_hs, 2) |]
+p [r| mapply(foo1_hs, 2) |]
 
 -- Should be [1] 2 3 4 5 6 7 8 9 10 11
-H.print =<< [r| mapply(foo2_hs, y) |]
+p [r| mapply(foo2_hs, y) |]
 
 -- Should be [1] 43
-H.print =<< [r| x <<- 42 ; x + 1 |]
+p [r| x <<- 42 ; x + 1 |]
 
 -- Should be [1] 1 2 3
 let xs = [1,2,3]::[Double]
-H.print =<< [r| xs_hs |]
+p [r| xs_hs |]
 
 -- Should be [1] 8
-H.print =<< [r| foo1_hs(7) |]
+p [r| foo1_hs(7) |]
 
 -- Should be NULL
-H.print H.nilValue
+p (return nilValue)
 
 -- Should be [1] 3
-let foo3 = (\n -> fmap H.fromSomeSEXP [r| n_hs |]) :: Int32 -> R s Int32
-H.print =<< [r| foo3_hs(3L) |]
+let foo3 = (\n -> fmap fromSomeSEXP [r| n_hs |]) :: Int32 -> R s Int32
+p [r| foo3_hs(3L) |]
 
 -- | should be 3
 let foo4 = (\n m -> return $ n + m) :: Double -> Double -> R s Double
-H.print =<< [r| foo4_hs(33, 66) |]
+p [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(n_hs - 1L)) |]
-H.print =<< [r| fact_hs(5L) |]
+let fact n = if n == (0 :: Int32) then (return 1 :: R s Int32) else fmap fromSomeSEXP [r| as.integer(n_hs * fact_hs(n_hs - 1L)) |]
+p [r| fact_hs(5L) |]
 
 -- Should be [1] 29
 let foo5  = (\n -> return (n+1)) :: Int32 -> R s Int32
 let apply = (\n m -> [r| n_hs(m_hs) |]) :: SEXP s 'R.Closure -> Int32 -> R s (R.SomeSEXP s)
-H.print =<< [r| apply_hs(foo5_hs, 28L ) |]
+p [r| apply_hs(foo5_hs, 28L ) |]
 
-sym <- H.install "blah"
-H.print sym
+p $ install "blah"
 
 :{
 let 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@(fromSEXP -> 0 :: Int32) = fmap (flip R.asTypeOf n) [r| 0L |]
+    hFib n@(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) |]
 :}
 
 -- Should be [1] 4181
--- H.print =<< H.Prelude.runR H.defaultConfig (hFib (H.Prelude.mkSEXP (19 :: Int32))) -- XXX produces wrong result.
+-- p Prelude.runR defaultConfig (hFib (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)) |]
+p [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") |]
+p [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
+p (return x)
 -- Should be 1. Use slot accessor on R object.
-H.print =<< [r| x@a |]
+p [r| x@a |]
 -- Should be 2. Use slot accessor on H object.
-H.print =<< [r| x_hs@b |]
+p [r| x_hs@b |]
 -- Should be "S4". Get type of R object.
-H.print =<< [r| typeof(x) |]
+p [r| typeof(x) |]
 -- Should be "S4". Get type of H object.
-H.print =<< [r| typeof(x_hs) |]
+p [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
+    testpm (SomeSEXP z@(hexp -> S4 _))
+      | R.TRUE <- dynSEXP [rsafe| z_hs @ a > 0 |] = p (return z)
       | otherwise = print "unexpected value"
 :}
 
@@ -114,4 +112,4 @@ testpm x
 -- 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) |]
+p [r| typeof(x_hs) |]
diff --git a/IHaskell/src/IHaskell/Display/InlineR.hs b/IHaskell/src/IHaskell/Display/InlineR.hs
@@ -22,7 +22,6 @@ import           IHaskell.Display
 import           IHaskell.Display.Blaze () -- to confirm it's installed
 import           Language.Haskell.TH.Quote
 import           Language.R.Instance
-import           Language.R.QQ
 import           System.IO (hClose)
 import           System.IO.Temp (withSystemTempFile)
 import qualified Text.Blaze.Html5 as BH

diff --git a/examples/RelaxWithNM.hs b/examples/RelaxWithNM.hs
@@ -10,8 +10,8 @@ import           Control.DeepSeq
 import           Control.Monad
 import           Data.Int
 import qualified Foreign.R as R
-import qualified Foreign.R.Type as R
-import           H.Prelude as H
+import           Language.R.Instance
+import           Language.R.Literal
 import           Language.R.QQ
 import           Numeric.Integration.TanhSinh
 import           System.IO.Temp (withSystemTempDirectory)
@@ -141,14 +141,14 @@ cost n alpha beta gamma =
 nmMin :: Int -> IO (Double, Double, Double, Double, Double, Int32, Int32)
 nmMin n = runRegion $ do
     initParms <- [r| c(-1.9,-0.1,-2.9) |]
-    initVal  <- H.fromSEXP . R.cast R.SReal <$> [r|(function(v) costH_hs(v[1], v[2], v[3]))(initParms_hs)|]
+    initVal  <- fromSEXP . R.cast R.SReal <$> [r|(function(v) costH_hs(v[1], v[2], v[3]))(initParms_hs)|]
     relaxMin <- [r| optimx(c(-1.9,-0.1,-2.9), function(v) costH_hs(v[1], v[2], v[3]), method = "Nelder-Mead") |]
-    aMin     <- H.fromSEXP . R.cast R.SReal <$> [r| relaxMin_hs$p1 |]
-    bMin     <- H.fromSEXP . R.cast R.SReal <$> [r| relaxMin_hs$p2 |]
-    cMin     <- H.fromSEXP . R.cast R.SReal <$> [r| relaxMin_hs$p3 |]
-    vMin     <- H.fromSEXP . R.cast R.SReal <$> [r| relaxMin_hs$value |]
-    fEvals   <- H.fromSEXP . R.cast R.SInt  <$> [r| as.integer(relaxMin_hs$fevals) |]
-    convCode <- H.fromSEXP . R.cast R.SInt  <$> [r| as.integer(relaxMin_hs$convcode) |]
+    aMin     <- fromSEXP . R.cast R.SReal <$> [r| relaxMin_hs$p1 |]
+    bMin     <- fromSEXP . R.cast R.SReal <$> [r| relaxMin_hs$p2 |]
+    cMin     <- fromSEXP . R.cast R.SReal <$> [r| relaxMin_hs$p3 |]
+    vMin     <- fromSEXP . R.cast R.SReal <$> [r| relaxMin_hs$value |]
+    fEvals   <- fromSEXP . R.cast R.SInt  <$> [r| as.integer(relaxMin_hs$fevals) |]
+    convCode <- fromSEXP . R.cast R.SInt  <$> [r| as.integer(relaxMin_hs$convcode) |]
     return $!! (initVal, aMin, bMin, cMin, vMin, fEvals, convCode)
   where
     costH :: Double -> Double -> Double -> R s Double

diff --git a/examples/fib/Fib.hs b/examples/fib/Fib.hs
@@ -13,7 +13,6 @@ module Fib
 import           H.Prelude as H
 import           Foreign.R.Type as R
 import qualified Foreign.R as R
-import           Foreign.R (SEXP)
 import           Data.Int (Int32)
 import           Language.R.QQ
 import           Control.Applicative

diff --git a/examples/fib/Main.hs b/examples/fib/Main.hs
@@ -1,29 +1,30 @@
 {-# LANGUAGE QuasiQuotes #-}
-module Main
-  where
+module Main where
 
 import Fib
 
 import qualified H.Prelude as H
 import           Language.R.QQ
 
+p x = [r| print(x_hs) |] >> return ()
+
 main :: IO ()
 main = H.withEmbeddedR H.defaultConfig $ H.runRegion $ do
-  H.print =<< [r| "test" |]
-  H.print =<< [r| 1+2 |]
+  p =<< [r| "test" |]
+  p =<< [r| 1+2 |]
   H.io $ putStrLn "[r| neg_hs(TRUE, 5L) |]"
-  H.print =<< [r| neg_hs(TRUE, 5L) |]
+  p =<< [r| neg_hs(TRUE, 5L) |]
   H.io $ putStrLn "[r| neg_hs(FALSE, 6L) |]"
-  H.print =<< [r| neg_hs(FALSE, 6L) |]
+  p =<< [r| neg_hs(FALSE, 6L) |]
   H.io $ putStrLn "[r| neg_hs(NA, 7L) |]"
-  H.print =<< [r| neg_hs(NA, 7L) |]
+  p =<< [r| neg_hs(NA, 7L) |]
   H.io $ putStrLn "[r| fib_hs(1L) |]"
-  H.print =<< [r| fib_hs(1L) |]
+  p =<< [r| fib_hs(1L) |]
   H.io $ putStrLn "[r| fib_hs(10L) |]"
-  H.print =<< [r| fib_hs(10L) |]
+  p =<< [r| fib_hs(10L) |]
   H.io $ putStrLn "[r| fact_hs(0L) |]"
-  H.print =<< [r| fact_hs(0L) |]
+  p =<< [r| fact_hs(0L) |]
   H.io $ putStrLn "[r| fact_hs(7L) |]"
-  H.print =<< [r| fact_hs(7L) |]
+  p =<< [r| fact_hs(7L) |]
   H.io $ putStrLn "[r| factSexp_hs(7L) |]"
-  H.print =<< [r| factSexp_hs(7L) |]
+  p =<< [r| factSexp_hs(7L) |]
diff --git a/inline-r/src/H/Prelude.hs b/inline-r/src/H/Prelude.hs
@@ -1,5 +1,7 @@
 -- |
--- Copyright: (C) 2013 Amgen, Inc.
+-- | Copyright: (C) 2013 Amgen, Inc.
+--
+-- DEPRECATED: use "Language.R" instead.
 
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
@@ -16,61 +18,21 @@ module H.Prelude
   -- * Language.R functions
   , module Language.R
   , module Language.R.Event
+  , module Language.R.HExp
   , module Language.R.Literal
+  , module Language.R.QQ
   -- * Globals
   , module Language.R.Globals
-  , Show(..)
   ) where
 
-import           Control.Memory.Region
 import           Control.Monad.R.Class
-import qualified Foreign.R as R
 import           Language.R.HExp
-import           Language.R.Internal (r1)
-import qualified Data.Vector.SEXP as Vector
 
 -- Reexported modules.
 import           Language.R hiding (SEXPTYPE(..))
 import           Language.R.Event (refresh)
 import           Language.R.Globals
-import           Language.R.Literal
 import           Language.R.Instance
+import           Language.R.Literal
+import           Language.R.QQ
 import           Foreign.R.Error
-
-import qualified Data.Text.Lazy.IO as Text
-import qualified Data.Text as Text
-import qualified Data.Text.Lazy as Text.Lazy
-import           Data.Text.Lazy (Text)
-
-import           Control.Monad ((>=>))
-import           Foreign.C (withCString)
-import           System.IO.Unsafe (unsafePerformIO)
-
-import Prelude hiding (Show(..), print)
-
-class Show a where
-  -- | Equivalent of R's @deparse()@.
-  show :: a -> Text
-
-  -- | Make this a class method to allow matching R's @print()@ behaviour, whose
-  -- output is subtly different from @deparse()@.
-  print :: MonadR m => a -> m ()
-  print = io . Text.putStrLn . show
-
-instance Show (SEXP s a) where
-  show s =
-      unsafePerformIO $
-      withCString "quote" $ R.install >=> \quote ->
-        R.lang2 quote (R.release s) >>= r1 "deparse" >>= \(SomeSEXP slang) ->
-          return .
-          Text.Lazy.fromChunks .
-          map (Text.pack . Vector.toString . vector) .
-          Vector.toList .
-          vector $
-          (R.unsafeCoerce (R.release slang) :: SEXP V 'R.String)
-
-  print = io . R.printValue
-
-instance Show (R.SomeSEXP s) where
-  show s = R.unSomeSEXP s show
-  print s = R.unSomeSEXP s print
diff --git a/inline-r/src/H/Prelude/Interactive.hs b/inline-r/src/H/Prelude/Interactive.hs
@@ -14,22 +14,31 @@ module H.Prelude.Interactive
   )
   where
 
+import qualified Foreign.R as R
 import H.Prelude hiding (withEmbeddedR)
-import qualified H.Prelude as H
 
 instance MonadR IO where
   io = id
   data ExecContext IO = ExecContext
   getExecContext = return ExecContext
   unsafeRunWithExecContext = const
 
+class PrintR a where
+  printR :: MonadR m => a -> m ()
+
+instance PrintR (SEXP s a) where
+  printR = io . R.printValue
+
+instance PrintR (R.SomeSEXP s) where
+  printR s = R.unSomeSEXP s printR
+
 -- | A form of the 'print' function that is more convenient in an
 -- interactive session.
-p :: (MonadR m, H.Show a) => m a -> m ()
-p = (>>= H.print)
+p :: (MonadR m, PrintR a) => m a -> m ()
+p = (>>= printR)
 
 -- | A form of the 'print' function that that is more convenient in an
 -- interactive session.
 {-# DEPRECATED printQuote "Use 'p' instead." #-}
-printQuote :: (MonadR m, H.Show a) => m a -> m ()
+printQuote :: (MonadR m, PrintR a) => m a -> m ()
 printQuote = p
diff --git a/inline-r/src/Language/R.hs b/inline-r/src/Language/R.hs
@@ -36,6 +36,7 @@ import Control.Monad.R.Class
 import Foreign.R
   ( SEXP
   , SomeSEXP(..)
+  , typeOf
   , asTypeOf
   , cast
   , unSomeSEXP