diff --git a/Rlang-QQ.cabal b/Rlang-QQ.cabal --- a/Rlang-QQ.cabal +++ b/Rlang-QQ.cabal @@ -1,6 +1,6 @@ name: Rlang-QQ -version: 0.1.1.0 -cabal-version: >=1.8 +version: 0.2.0.0 +cabal-version: >=1.10 build-type: Simple license: BSD3 license-file: LICENSE @@ -18,12 +18,11 @@ > R --no-save <<< 'install.packages("knitr")' category: Development author: Adam Vogt -tested-with: GHC == 7.6.2 +tested-with: GHC == 7.6.2, GHC == 7.8-RC1 data-dir: rsrc data-files: Tree.R parseTreeExample.R extra-source-files: examples/*.hs, examples/*.Rmd, - examples/*.ref examples/*.png examples/*.ipynb examples/*.html @@ -36,12 +35,34 @@ library hs-source-dirs: src + default-language: Haskell2010 + default-extensions: ConstraintKinds + DataKinds + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + KindSignatures + MultiParamTypeClasses + ScopedTypeVariables + TypeFamilies + TypeOperators + ViewPatterns + + other-extensions: NoMonomorphismRestriction + PolyKinds + TemplateHaskell + UndecidableInstances + if (impl(ghc > 7.7)) + default-extensions: AllowAmbiguousTypes + build-depends: base ==4.*, containers, - template-haskell ==2.8.*, directory, process, + template-haskell <= 3, directory, process, trifecta ==1.*, utf8-string ==0.3.*, bytestring, Cabal, syb, mtl, MaybeT, - binary, vector, HList >= 0.3, temporary, + binary, vector, HList >= 0.3.4, temporary, text, array, zlib, repa, + filepath, split, haskell-src-meta exposed-modules: RlangQQ.Internal @@ -50,6 +71,7 @@ RlangQQ.FN RlangQQ.NatQQ RlangQQ.MakeRecord + RlangQQ.ParseKnitted RlangQQ HListExtras diff --git a/examples/Makefile b/examples/Makefile --- a/examples/Makefile +++ b/examples/Makefile @@ -6,6 +6,7 @@ default: test6.html test7.html cd ../; runghc examples/runexamples.hs + runghc examples/tests.hs ghc -O2 romberg.hs; ./romberg %.html: %.md @@ -28,5 +29,5 @@ installdeps: R --no-save <<< 'install.packages(c("knitr", "lattice", "reshape", "ggplot2", "lattice"))' - cabal install lens numbers + cabal install lens numbers hspec diff --git a/examples/ihaskell3.html b/examples/ihaskell3.html new file mode 100644 --- /dev/null +++ b/examples/ihaskell3.html @@ -0,0 +1,1998 @@ + + + + + +ihaskell2 + + + + + + + + + + + + + + + + + + + + +
+
+
+
+
+

Multiple plots with Rlang-QQ

+

An example of Rlang-QQ-0.1.2.0, which supports multiple figures.

+

First a pile of imports needed:

+
+
+
+
+
+
+In [1]: +
+
+
:set -XQuasiQuotes -XTupleSections -XViewPatterns
+import IHaskell.Display -- shouldn't be needed but it turns out that it is essential
+import IHaskell.Display.Rlangqq () -- to check it's installed
+import Data.Monoid
+import Control.Applicative
+import Data.List
+
+ +
+
+ +
+
+
+
+
+
+

Rlang-QQ saves intermediate files. There is some code hidden in IHaskell.Display.RlangQQ and RlangQQ.ParseKnitted which gets those messages/warnings/plots.

+
+
+
+
+
+
+
+
+

Just some more of the same integration stuff that may be easier to think about because it's written in haskell

+
+
+
+
+
+
+In [2]: +
+
+
-- | trapezoid rule. doesn't reuse previous values
+trap :: Fractional a
+    => (a -> a) -- ^ function
+    -> a -- ^ lower bound
+    -> a -- ^ upepr bound
+    -> Int -- ^ number of panels to divide the interval into
+    -> a -- ^ integral approximation
+trap f a b n =
+    let h = (b - a) / fromIntegral n
+        xs = take (n-1) $ iterate (h+) (a+h)
+            -- easier to see as [a+h, a+2*h .. b-h])
+            -- but some interval arithmetic doesn't support [a..b]
+    in h * foldl' (\s x -> s + f x) ((f a + f b) / 2) xs
+
+ +
+
+ +
+
+
+
+In [7]: +
+
+
improve :: Fractional a
+    => Int -- n
+    -> a -- O(h^n) estimate with step size h/2
+    -> a -- O(h^n) estimate with step size h
+    -> a -- O(h^(n+1)) estimate
+improve n x y = let c = 4^(n-1) in (c*x - y) / (c - 1)
+
+rombM :: Fractional a
+    => (a -> a)
+    -> a
+    -> a
+    -> [[a]]
+rombM f a b =
+    let is = map (\n -> trap f a b (2^n)) [0..]
+    in map snd
+        $ iterate
+            (\(n,s) -> (n+1, zipWith (improve n) (tail s) s))
+            (2,is)
+
+romb :: Fractional a
+    => (a -> a)
+    -> a
+    -> a
+    -> [a] -- successive approximations
+romb f a b = map head $ rombM f a b
+
+ +
+
+ +
+
+
+
+In [3]: +
+
+
xs = take 5 $ romb exp 0 1 :: [Double]
+
+print xs
+
+ +
+
+ +
+
+ + +
+
+ + +
+[1.8591409142295225,1.7188611518765928,1.7182826879247577,1.7182818287945305,1.7182818284590786]
+
+ +
+
+ +
+
+ +
+
+
+
+In [4]: +
+
+
sse <- do
+ [pun| (sse) |] <- [rDisp|
+    m <- lm( log($(xs) / (exp(1)-1)) ~ I(1:length($(xs))))
+    plot(m, which=1:2)
+    print(predict(m))
+    hs_sse <- sum( resid(m)^2 )
+    |]
+ return (sse :: Double)
+() -- needed to force a display
+
+ +
+
+ +
+
+ + +
+
+ + +
+()
+
+ +
+
+ +
+
+ + +
+
+
+ +
+
+ +
+
+ +
+ + +
+ +
+
+ +
+
+ +
+ + +
+ +
+
+ +
+
+ + +
+
+
+ +
+
+ +
+
+ + +
+
+
+ +
+
+ +
+
+ + +
+         1          2          3          4          5 
+ 4.741e-02  3.162e-02  1.583e-02  3.381e-05 -1.576e-02
+
+ +
+
+ +
+
+ + +
+
+
+ +
+
+ +
+
+ + +
+
+
+ +
+
+ +
+
+ + +
+
+
+ +
+
+ +
+
+ + + +
+
+ +
+
+ +
+
+
+
+In [5]: +
+
+
sse
+
+ +
+
+ +
+
+ + +
+
+ + +
+2.4619397033555017e-3
+
+ +
+
+ +
+
+ +
+
+
+
+In []: +
+
+
+
+ +
+
+ +
+ + diff --git a/examples/ihaskell3.ipynb b/examples/ihaskell3.ipynb new file mode 100644 --- /dev/null +++ b/examples/ihaskell3.ipynb @@ -0,0 +1,253 @@ +{ + "metadata": { + "language": "haskell", + "name": "", + "signature": "sha256:77784b243dcc073ca234e267b10dd773decbb010b9dbb529bf20bf1714830221" + }, + "nbformat": 3, + "nbformat_minor": 0, + "worksheets": [ + { + "cells": [ + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "# Multiple plots with Rlang-QQ\n", + "An example of `Rlang-QQ-0.1.2.0`, which supports multiple figures.\n", + "\n", + "First a pile of imports needed:" + ] + }, + { + "cell_type": "code", + "collapsed": false, + "input": [ + ":set -XQuasiQuotes -XTupleSections -XViewPatterns\n", + "import IHaskell.Display -- shouldn't be needed but it turns out that it is essential\n", + "import IHaskell.Display.Rlangqq () -- to check it's installed\n", + "import Data.Monoid\n", + "import Control.Applicative\n", + "import Data.List" + ], + "language": "python", + "metadata": {}, + "outputs": [], + "prompt_number": 1 + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "Rlang-QQ saves intermediate files. There is some code\n", + "hidden in `IHaskell.Display.RlangQQ` and `RlangQQ.ParseKnitted`\n", + "which gets those messages/warnings/plots." + ] + }, + { + "cell_type": "markdown", + "metadata": {}, + "source": [ + "Just some more of the same integration stuff that may be easier to think about because it's written in haskell" + ] + }, + { + "cell_type": "code", + "collapsed": false, + "input": [ + "-- | trapezoid rule. doesn't reuse previous values\n", + "trap :: Fractional a\n", + " => (a -> a) -- ^ function\n", + " -> a -- ^ lower bound\n", + " -> a -- ^ upepr bound\n", + " -> Int -- ^ number of panels to divide the interval into\n", + " -> a -- ^ integral approximation\n", + "trap f a b n =\n", + " let h = (b - a) / fromIntegral n\n", + " xs = take (n-1) $ iterate (h+) (a+h)\n", + " -- easier to see as [a+h, a+2*h .. b-h])\n", + " -- but some interval arithmetic doesn't support [a..b]\n", + " in h * foldl' (\\s x -> s + f x) ((f a + f b) / 2) xs" + ], + "language": "python", + "metadata": {}, + "outputs": [], + "prompt_number": 2 + }, + { + "cell_type": "code", + "collapsed": false, + "input": [ + "improve :: Fractional a\n", + " => Int -- n\n", + " -> a -- O(h^n) estimate with step size h/2\n", + " -> a -- O(h^n) estimate with step size h\n", + " -> a -- O(h^(n+1)) estimate\n", + "improve n x y = let c = 4^(n-1) in (c*x - y) / (c - 1)\n", + "\n", + "rombM :: Fractional a\n", + " => (a -> a)\n", + " -> a\n", + " -> a\n", + " -> [[a]]\n", + "rombM f a b =\n", + " let is = map (\\n -> trap f a b (2^n)) [0..]\n", + " in map snd\n", + " $ iterate\n", + " (\\(n,s) -> (n+1, zipWith (improve n) (tail s) s))\n", + " (2,is)\n", + "\n", + "romb :: Fractional a\n", + " => (a -> a)\n", + " -> a\n", + " -> a\n", + " -> [a] -- successive approximations\n", + "romb f a b = map head $ rombM f a b" + ], + "language": "python", + "metadata": {}, + "outputs": [], + "prompt_number": 7 + }, + { + "cell_type": "code", + "collapsed": false, + "input": [ + "xs = take 5 $ romb exp 0 1 :: [Double]\n", + "\n", + "print xs" + ], + "language": "python", + "metadata": {}, + "outputs": [ + { + "metadata": {}, + "output_type": "display_data", + "text": [ + "[1.8591409142295225,1.7188611518765928,1.7182826879247577,1.7182818287945305,1.7182818284590786]" + ] + } + ], + "prompt_number": 3 + }, + { + "cell_type": "code", + "collapsed": false, + "input": [ + "sse <- do\n", + " [pun| (sse) |] <- [rDisp|\n", + " m <- lm( log($(xs) / (exp(1)-1)) ~ I(1:length($(xs))))\n", + " plot(m, which=1:2)\n", + " print(predict(m))\n", + " hs_sse <- sum( resid(m)^2 )\n", + " |]\n", + " return (sse :: Double)\n", + "() -- needed to force a display" + ], + "language": "python", + "metadata": {}, + "outputs": [ + { + "metadata": {}, + "output_type": "display_data", + "text": [ + "()" + ] + }, + { + "metadata": {}, + "output_type": "display_data", + "text": [] + }, + { + "html": [ + "\n" + ], + "metadata": {}, + "output_type": "display_data", + "text": [ + "" + ] + }, + { + "html": [ + "\n" + ], + "metadata": {}, + "output_type": "display_data", + "text": [ + "" + ] + }, + { + "metadata": {}, + "output_type": "display_data", + "text": [] + }, + { + "metadata": {}, + "output_type": "display_data", + "text": [] + }, + { + "metadata": {}, + "output_type": "display_data", + "text": [ + " 1 2 3 4 5 \n", + " 4.741e-02 3.162e-02 1.583e-02 3.381e-05 -1.576e-02" + ] + }, + { + "metadata": {}, + "output_type": "display_data", + "text": [] + }, + { + "metadata": {}, + "output_type": "display_data", + "text": [] + }, + { + "metadata": {}, + "output_type": "display_data", + "text": [] + }, + { + "metadata": {}, + "output_type": "display_data" + } + ], + "prompt_number": 4 + }, + { + "cell_type": "code", + "collapsed": false, + "input": [ + "sse" + ], + "language": "python", + "metadata": {}, + "outputs": [ + { + "metadata": {}, + "output_type": "display_data", + "text": [ + "2.4619397033555017e-3" + ] + } + ], + "prompt_number": 5 + }, + { + "cell_type": "code", + "collapsed": false, + "input": [], + "language": "python", + "metadata": {}, + "outputs": [] + } + ], + "metadata": {} + } + ] +} diff --git a/examples/runexamples.hs b/examples/runexamples.hs --- a/examples/runexamples.hs +++ b/examples/runexamples.hs @@ -1,4 +1,4 @@ --- same test runner as in HList +-- similar to the test runner as in HList module Main where import Control.Exception @@ -16,18 +16,19 @@ es <- getDirectoryContents "examples" + putStrLn "Candidate tests" print es -- very dumb es <- filterM (\e -> allM [return (takeExtension e == ".hs"), - doesFileExist (dropExtension ("examples"e) ++ ".ref") ]) es + doesFileExist (dropExtension ("examples"e) ++ ".ref")]) es + putStrLn "\nSelected tests" print es hspec $ do mapM_ runghcwith es - runghcwith f = describe f $ it "ok" $ checkResult $ do let ex = ("examples" ) @@ -37,7 +38,9 @@ (ec, stdout, stderr) <- readProcessWithExitCode "cabal" ["repl","-v0", "--ghc-options", "-w -fcontext-stack=50 -iexamples -v0 "] - (":set -package lens\n:load " ++ inFile ++ "\nmain") + (":set -package lens\n\ + \:load " ++ inFile ++ + "\nmain\n") writeFile outFile stdout diff --git a/examples/test.png b/examples/test.png Binary files a/examples/test.png and b/examples/test.png differ diff --git a/examples/test2.hs b/examples/test2.hs deleted file mode 100644 --- a/examples/test2.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE QuasiQuotes #-} -module Main where -import RlangQQ -import Data.HList - - -x = [0 .. 10 :: Double] -y = map (sin . (*pi) . (/10)) x - - -test = [r| print('hi'); hs_z <- hs_x + hs_y |] - -test2 = fmap (.!. (Label :: Label "z")) test - -test3 = print =<< (test2 :: IO [Double]) - - -main = do - test3 - let hs = zipWith (+) x y - let sse x y = sum $ zipWith (\a b -> (a-b)^2) x y - fmap (sse hs) test2 diff --git a/examples/test2.ref b/examples/test2.ref deleted file mode 100644 --- a/examples/test2.ref +++ /dev/null @@ -1,2 +0,0 @@ -[0.0,1.3090169943749475,2.5877852522924734,3.8090169943749475,4.951056516295154,6.0,6.951056516295154,7.8090169943749475,8.587785252292473,9.309016994374948,10.0] -0.0 diff --git a/examples/test3.hs b/examples/test3.hs deleted file mode 100644 --- a/examples/test3.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} -- for pun -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} -module Main where -import RlangQQ -import GHC.TypeLits - -makeLabels6 (words "x y z") - -inRec = x .=. "xlabel" .*. y .=. [1,2,3::Double] .*. z .=. [3,2,1 :: Double] .*. emptyRecord - --- fixity is bad for .!. see test3_lens.hs for something better? -main = do - o <- [r| - print(hs_inRec) - hs_inRec <- within(hs_inRec, y <- y + z) |] - print ((o .!. (Label :: Label "inRec")) .!. y) - - - -- alternative to the above (shadows the label y) - let [pun| inRec{ y } |] = o - print y diff --git a/examples/test3.ref b/examples/test3.ref deleted file mode 100644 --- a/examples/test3.ref +++ /dev/null @@ -1,2 +0,0 @@ -[4.0,4.0,4.0] -[4.0,4.0,4.0] diff --git a/examples/test3_lens.hs b/examples/test3_lens.hs deleted file mode 100644 --- a/examples/test3_lens.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} -module Main where -import RlangQQ -import GHC.TypeLits -import Control.Lens - -makeLabelable "x y z" - -inRec = x .==. "xlabel" .*. y .==. [1,2,3::Double] .*. z .==. [3,2,1 :: Double] .*. emptyRecord - -main = do - o <- [r| - print(hs_inRec) - hs_inRec <- within(hs_inRec, y <- y + z) |] - let inR = hLens' (Label :: Label "inRec") - print (o ^.inR.y) diff --git a/examples/test3_lens.ref b/examples/test3_lens.ref deleted file mode 100644 --- a/examples/test3_lens.ref +++ /dev/null @@ -1,1 +0,0 @@ -[4.0,4.0,4.0] diff --git a/examples/test4.hs b/examples/test4.hs deleted file mode 100644 --- a/examples/test4.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE DataKinds, TemplateHaskell, QuasiQuotes #-} -module Main where -import RlangQQ -import GHC.TypeLits -- ghc7.6 workaround -import Control.Monad - -makeLabels6 (words "x y z") - -inRec = x .=. "xlabel" .*. y .=. [1,2,3::Double] .*. z .=. [3,2,1 :: Double] .*. emptyRecord - -inRecL = Label :: Label "inRec" - -{- $test - -note that the same R-session is run for all calls to f1, -that is why the results differ between f1 and f2: - ->>> f1 -[5.0,5.0,5.0] -[10.0,9.0,8.0] -[16.0,14.0,12.0] -[23.0,20.0,17.0] - - ->>> f2 -[5.0,5.0,5.0] -[6.0,6.0,6.0] -[7.0,7.0,7.0] -[8.0,8.0,8.0] - --} -f1 = do - - w <- newRChan - - [r| - print(hs_inRec) # this shouldn't be necessary to force INOUT - hs_inRec <- within(hs_inRec, y <- y + z + ch_w) |] - - - forM_ [1,2,3,4 :: Double] $ \n -> do - o' <- sendRcv w n - print ((o' .!. inRecL) .!. y) - -f2 = forM_ [1,2,3,4 :: Double] $ \n -> do - o' <- [r| - print(hs_inRec) # this shouldn't be necessary to force INOUT - hs_inRec <- within(hs_inRec, y <- y + z + hs_n) |] - print ((o' .!. inRecL) .!. y) - - -main = do f1;f2 diff --git a/examples/test4.ref b/examples/test4.ref deleted file mode 100644 --- a/examples/test4.ref +++ /dev/null @@ -1,8 +0,0 @@ -[5.0,5.0,5.0] -[10.0,9.0,8.0] -[16.0,14.0,12.0] -[23.0,20.0,17.0] -[5.0,5.0,5.0] -[6.0,6.0,6.0] -[7.0,7.0,7.0] -[8.0,8.0,8.0] diff --git a/examples/test5.hs b/examples/test5.hs deleted file mode 100644 --- a/examples/test5.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE DataKinds, TemplateHaskell, QuasiQuotes #-} -module Main where -import RlangQQ -import GHC.TypeLits -- ghc7.6 workaround -import Control.Monad - -makeLabels6 (words "x y z") - -inRec = x .=. "xlabel" .*. y .=. [1,2,3::Double] .*. z .=. [3,2,1 :: Double] .*. emptyRecord - -inRecL = Label :: Label "inRec" - -f2 = forM_ [1,2,3,4 :: Double] $ \n -> do - o' <- [r| # this shouldn't be necessary to force INOUT - print(hs_inRec) - hs_inRec <- within(hs_inRec, y <- y + z + $(n+1) ) |] - print ((o' .!. inRecL) .!. y) - - -{- $output - - ->>> f2 -[6.0,6.0,6.0] -[7.0,7.0,7.0] -[8.0,8.0,8.0] -[9.0,9.0,9.0] - --} - -main = f2 diff --git a/examples/test5.ref b/examples/test5.ref deleted file mode 100644 --- a/examples/test5.ref +++ /dev/null @@ -1,4 +0,0 @@ -[6.0,6.0,6.0] -[7.0,7.0,7.0] -[8.0,8.0,8.0] -[9.0,9.0,9.0] diff --git a/examples/test6.html b/examples/test6.html new file mode 100644 --- /dev/null +++ b/examples/test6.html @@ -0,0 +1,48 @@ + + + + + + + + + + +

test 6

+

This file can be loaded into whatever editor you like to use for knitr. ghc is called for the second code block.

+
library(knitr)
+opts_chunk$set(engine = "haskell", engine.path = "ghc")
+
:set -XQuasiQuotes
+:module +RlangQQ
+let fibs = 0.0:1: zipWith (+) fibs (drop 1 fibs)
+[r| png('test6_fig1.png'); plot(1:20, $(take 20 fibs)); dev.off() |]
+
+test6 caption here

test6 caption here

+
+

limitations

+ + + diff --git a/examples/test7.html b/examples/test7.html new file mode 100644 --- /dev/null +++ b/examples/test7.html @@ -0,0 +1,58 @@ + + + + + + + + + + +

test 7

+

Same as test6, except needs a change to knitr as of October 2013 (ie. 1.5 is not good enough). This commit is needed.

+

This file can be loaded into whatever editor you like to use for knitr. I use vim-r-plugin, but perhaps ESS or Rstudio can also work. After some set-up in the first block. ghc is called for the second code block.

+
library(knitr)
+opts_chunk$set(engine = "haskell", engine.path = "ghc", engine.opts = "-e \":set -XQuasiQuotes\" -e \"import RlangQQ\"")
+

+let fibs = 0.0:1: zipWith (+) fibs (drop 1 fibs)
+
+[r| png('test6_fig1.png')
+    plot(1:20, $(take 20 fibs))
+    dev.off() |]
+

+do let x = 1
+   print(1+x)
+   print(2+x)
+
## 2
+## 3
+
+test6 caption here

test6 caption here

+
+

limitations

+ +

raw code

+

See here

+ + diff --git a/examples/testplot.png b/examples/testplot.png new file mode 100644 Binary files /dev/null and b/examples/testplot.png differ diff --git a/examples/tests.hs b/examples/tests.hs new file mode 100644 --- /dev/null +++ b/examples/tests.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE DataKinds, PolyKinds, FlexibleContexts, TemplateHaskell, QuasiQuotes #-} +module Main where +import Test.Hspec + +import System.Directory +import RlangQQ +import GHC.TypeLits +import Control.Lens + +import Control.Monad +import qualified Data.Vector as V + +makeLabelable "x y z" + +inRecL = hLens' (Label :: Label "inRec") + +inRec = [pun| x y z |] where + x = "xlabel" + y,z :: [Double] + y = [1,2,3] + z = [3,2,1] + + +main = hspec $ describe "rlangqq" $ do + it "can read a tsv file" $ do + [pun| x@(a b) s |] <- [r| + # find the file whether we runghc tests.hs + # runghc examples/tests.hs + fname <- c(Sys.glob('*.tsv'), Sys.glob('examples/*.tsv'))[1] + hs_x <- as.list(read.delim(fname, sep=' ')) + hs_s <- as.numeric(with(hs_x, t(a) %*% b)) + |] + (V.sum (V.zipWith (*) a b) :: Double, s :: Double) + `shouldBe` (93.783, 93.783) + + it "does the same as zipWith" $ do + + o <- [r| print(hs_inRec) # should be unnecessary + hs_inRec <- within(hs_inRec, y <- y + z) |] + let inR = hLens' (Label :: Label "inRec") + (o ^.inR.y) `shouldBe` zipWith (+) (inRec^.y) (inRec^.z) + + it "accumulates when variables are ch_" $ do + w <- newRChan + [r| + print(hs_inRec) # this shouldn't be necessary to force INOUT + hs_inRec <- within(hs_inRec, y <- y + z + ch_w) |] + + out <- forM [1,2,3,4 :: Double] $ \n -> do + sendRcv w n <&> view (inRecL . y) + out `shouldBe` + tail (scanl + (\ accum n -> map (+n) $ zipWith (+) (inRec^.z) accum) + (inRec^.y) + [1 .. 4]) + + it "repeats when variables are not ch_" $ do + out <- forM [1,2,3,4 :: Double] $ \n -> do + [r| print(hs_inRec) # this shouldn't be necessary to force INOUT + hs_inRec <- within(hs_inRec, y <- y + z + hs_n) |] + <&> view (inRecL . y) + out `shouldBe` + map (\n -> map (+n) (zipWith (+) (inRec^.y) (inRec^.z))) [1 .. 4] + + it "interpolates haskell expressions" $ do + ys <- forM [1,2,3,4 :: Double] $ \n -> do + [pun| inRec{y} |] <- [r| # this shouldn't be necessary to force INOUT + print(hs_inRec) + hs_inRec <- within(hs_inRec, y <- y + z + $(n+1) ) |] + return y + ys `shouldBe` map (\n -> map (+(1+n)) (zipWith (+) (inRec^.y) (inRec^.z))) [1 .. 4] + + it "can make a plot where you ask it to" $ do + let x = [0 .. 10 :: Double] + y = map (sin . (*pi) . (/10)) x + b <- doesFileExist "testplot.png" + when b (removeFile "testplot.png") + -- normally you would just call qplot, and find a plot in Rtmp/figN/... + [r| library(ggplot2) + print('blahh') + png(file='testplot.png') + plot(qplot( hs_x, hs_y )) + dev.off() + |] + doesFileExist "testplot.png" `shouldReturn` True diff --git a/src/HListExtras.hs b/src/HListExtras.hs --- a/src/HListExtras.hs +++ b/src/HListExtras.hs @@ -1,18 +1,7 @@ -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} module HListExtras where import Data.HList.CommonMain @@ -22,65 +11,4 @@ instance (ApplyAB f a b, ab ~ (a -> b)) => ApplyAB FApply f ab where applyAB _ = applyAB -class HReplicate2 (n ::HNat) e l | n e -> l, l -> n - where hReplicate2 :: Proxy n -> e -> HList l -instance HReplicate2 HZero e '[] where - hReplicate2 _ _ = HNil -instance (HReplicate2 n e es') => HReplicate2 (HSucc n) e (e ': es') where - hReplicate2 n e = e `HCons` hReplicate2 (hPred n) e - --- hReplicateApp :: HReplicate2 (HLength r) e r' => e -> HList r -hReplicateApp e = let r = hMap FApply (hReplicate2 (hLength r) e) in r - --- | splitAt -hSplitAt n xs = hSplitAtAux n xs HNil - -class HSplitAtAux (n :: HNat) l a0 a b | n -> l a0 a b where - hSplitAtAux :: Proxy n -> HList l -> HList a0 -> (HList a, HList b) - -instance (l ~ b, a ~ HRevApp a0 '[]) => HSplitAtAux HZero l a0 a b where - hSplitAtAux _ l acc = (hReverse acc, l) - -instance ( (x ': xs) ~ ls, acc' ~ (x ': acc), - HSplitAtAux n xs acc' a b) => HSplitAtAux (HSucc n) ls acc a b where - hSplitAtAux n (HCons x xs) acc = hSplitAtAux (hPred n) xs (HCons x acc) - - -hEnumFromTo :: Proxy a -> Proxy b -> Proxy (HEnumFromTo a b) -hEnumFromTo a b = proxy - --- | [n1 .. n1 + n2] - -type family HEnumFromTo (from::HNat) (to::HNat) :: [HNat] -type instance HEnumFromTo a HZero = '[a] -type instance HEnumFromTo a (HSucc b) = a ': HEnumFromTo (HSucc a) b - - --- this doesn't work any better... want ghc to be able to simplify --- that (hReverse (hReverse x) `asTypeOf` x) -class (SameLength a b, SameLength b a) => HReverse2 a b | a -> b, b -> a where - hReverse2 :: HList a -> HList b - -instance (SameLength a b, SameLength b a, HRevApp a '[] ~ b, HRevApp b '[] ~ a) => HReverse2 a b where - hReverse2 = hReverse - - -class HMap1 f a b where hMap1 :: f -> HList a -> HList b - -instance (a ~ '[]) => HMap1 f a '[] where - hMap1 _ _ = HNil - -instance (ApplyAB f a b, (a ': as) ~ aas, HMap1 f as bs) => - HMap1 f aas (b ': bs) where - hMap1 f (HCons a as) = HCons (applyAB f a) (hMap1 f as) - - -class HMap2 f a b where hMap2 :: f -> HList a -> HList b - -instance (a ~ '[]) => HMap2 f '[] a where - hMap2 _ _ = HNil - -instance (ApplyAB f a b, (b ': bs) ~ bbs, HMap2 f as bs) => - HMap2 f (a ': as) bbs where - hMap2 f (HCons a as) = HCons (applyAB f a) (hMap2 f as) diff --git a/src/RlangQQ.hs b/src/RlangQQ.hs --- a/src/RlangQQ.hs +++ b/src/RlangQQ.hs @@ -36,15 +36,10 @@ import Language.Haskell.TH.Quote import Data.HList.CommonMain - import GHC.TypeLits - - import Control.Concurrent - - {- | Calls R with the supplied string. Variables in R prefixed hs_ cause the corresponding (un-prefixed) variable to be converted. The variable(s) must be in at least one class 'FromRDS' or 'ToRDS'. Currently the relation between @@ -74,24 +69,22 @@ While it is only somewhat usable, you can have Rnw/Rmd documents (knitr) that include haskell code. One example is given - +. A second +option is to use , for +which there are two example notebooks in the same -} r = QuasiQuoter { quoteExp = \s -> do n <- getRlangQQ_n - quoteRExpression2 n False ("print('');"++ s) - -- the first expression gets dropped somewhere else - -- this hack is easiest + quoteRExpression2 n False s } --- | same as @[rChan| |]@ does the same as [r| |], except the +-- | @[rChan| |]@ does the same as [r| |], except the -- return value will be a @Chan (Record a)@. rChan = QuasiQuoter { quoteExp = \s -> do n <- getRlangQQ_n - quoteRExpression2 n True ("print('');"++ s) - -- the first expression gets dropped somewhere else - -- this hack is easiest + quoteRExpression2 n True s } {- $records @@ -149,6 +142,8 @@ -- | @y <- sendRcv c x@ sends the value @x@ using the chan @c@. -- Provided that an @[r| |]@ quasiquote above refers to a @ch_c@, -- the call to 'sendRcv' will eventually produce a 'Record' @y@ +-- which provides a reference to all the output variables that +-- R calculated with the given @x@. sendRcv :: Chan (t, b -> IO ()) -> t -> IO b sendRcv ch e = do v <- newEmptyMVar @@ -164,7 +159,7 @@ also, return R's stdout / stderr / exitcode in the HList. This won't be practical for the Chan option since the stdout is getting consumed? -[@antiquote@] doesn't do escapes, so a string '$( blah )' might end badly +[@antiquote@] doesn't do escapes, so a string \'$( blah )\' might end badly [@more examples@] conversion both ways etc. @@ -173,7 +168,7 @@ [@more datatypes@] support things like ??, ... [@call R functions as if they were defined in haskell@] -This can be achievede already by doing something like +This can be achieved already by doing something like > x <- newRChan > [r| hs_f <- ch_x + 1 |] @@ -188,8 +183,10 @@ Can this be made to work without looking at whether there is a function() after the <-? [@call hs functions as if they were defined in R@] -we might like to be able to have values like @f x = x + 1@ -be callable by. +Likewise, we might like values like @f x = x + 1@ to be callable from +R (for example by defining a foreign export ccall f :: Int32 -> Int32), and +dyn.load('something'); .C('f', x=1L). Alternatively the R interpreter might +have a way to communicate some other way. [@use libR.so@] there is a which might @@ -218,5 +215,7 @@ or run the code first with some dummy inputs (say vectors of length 10 or so), and assume those types will continue to be the same. + + -} diff --git a/src/RlangQQ/Binary.hs b/src/RlangQQ/Binary.hs --- a/src/RlangQQ/Binary.hs +++ b/src/RlangQQ/Binary.hs @@ -1,19 +1,7 @@ -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} - +{-# LANGUAGE UndecidableInstances #-} {- | Conversions between R's RDS/RDA format and haskell data types. tested with R 3.0.1 @@ -53,6 +41,8 @@ import Data.Int import Data.HList.CommonMain import qualified Data.Vector as V +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Generic as VG import qualified Data.Map as M import Data.Binary @@ -77,12 +67,12 @@ import HListExtras data FLVPair = FLVPair -instance (LVPair l a ~ b) => ApplyAB FLVPair a b where - applyAB FLVPair x = LVPair x +instance (Tagged l a ~ b) => ApplyAB FLVPair a b where + applyAB FLVPair x = Tagged x -- this should not be necessary type family UnHMapFLVPair (a :: [*]) :: [*] -type instance UnHMapFLVPair (LVPair l a ': as) = a ': UnHMapFLVPair as +type instance UnHMapFLVPair (Tagged l a ': as) = a ': UnHMapFLVPair as type instance UnHMapFLVPair '[] = '[] -- | this seems to be a magic number. Corresponds to R 3.0.1 @@ -103,30 +93,42 @@ putDouble = put . (unsafeCoerce :: Double -> Int64) getDouble = fmap (unsafeCoerce :: Int64 -> Double) get +getVectorDouble = do + 14 <- get :: Get Int32 + len <- get :: Get Int32 + VG.replicateM (fromIntegral len) getDouble + +putVectorDouble x = do + put (14 :: Int32) + put (fromIntegral $ VG.length x :: Int32) + VG.mapM_ putDouble x + +getVectorInt = do + 13 <- get :: Get Int32 + len <- get :: Get Int32 + VG.replicateM (fromIntegral len) get + +putVectorInt x = do + put (13 :: Int32) + put (fromIntegral $ VG.length x :: Int32) + VG.mapM_ put x + -- | becomes a numeric vector -instance ToRDS (V.Vector Double) where - toRDS x = do - put (14 :: Int32) - put (fromIntegral $ V.length x :: Int32) - V.mapM_ putDouble x -instance FromRDS (V.Vector Double) where - fromRDS = do - 14 <- get :: Get Int32 - len <- get :: Get Int32 - V.mapM (const getDouble) $ V.replicate (fromIntegral len) () +instance ToRDS (V.Vector Double) where toRDS = putVectorDouble +-- | becomes a numeric vector +instance ToRDS (VS.Vector Double) where toRDS = putVectorDouble + +instance FromRDS (V.Vector Double) where fromRDS = getVectorDouble +instance FromRDS (VS.Vector Double) where fromRDS = getVectorDouble + -- | integer vector -instance ToRDS (V.Vector Int32) where - toRDS x = do - put (13 :: Int32) - put (fromIntegral $ V.length x :: Int32) - V.mapM_ put x -instance FromRDS (V.Vector Int32) where - fromRDS = do - 13 <- get :: Get Int32 - len <- get - V.mapM (const get) $ V.replicate len () +instance ToRDS (V.Vector Int32) where toRDS = putVectorInt +instance FromRDS (V.Vector Int32) where fromRDS = getVectorInt +instance ToRDS (VS.Vector Int32) where toRDS = putVectorInt +instance FromRDS (VS.Vector Int32) where fromRDS = getVectorInt + -- | character vector @c(\'ab\',\'cd\')@ instance ToRDS (V.Vector T.Text) where toRDS x = do @@ -183,7 +185,7 @@ instance (RDSHLIST xs' xs) => ToRDS (LST xs) where toRDS (LST xs) = do put (531::Int32) - let [(len,"")] = reads (drop 1 $ show (proxy :: Proxy (HLength xs))) + let len = hNat2Integral (Proxy :: Proxy (HLength xs)) put (fromIntegral (len - 2 :: Int) :: Int32) hFoldr (HSeq FToRDS) (return () :: Put) xs :: Put put (254::Int32) @@ -198,7 +200,7 @@ instance (RDSHLIST2 ___ __ l) => FromRDS (LST l) where fromRDS = withSelf $ \(self) -> do 531 <- get :: Get Int32 - let [(len,"")] = reads (drop 1 $ show (hLength self)) + let len = hNat2Integral (hLength self) len2 <- get :: Get Int32 when (len /= len2) $ error $ "fromRDS expected length: " ++ show len ++ " rds file has length: " ++ show len2 r <- hSequence (hSequence (hMap FApply $ hReplicate (hLength self) FFromRDS) ()) @@ -223,9 +225,9 @@ type ToRDSRecord __ ___ xs = (RDSHLIST __ ___, ToRDS (LST ___), RecordValues xs, - HList ___ ~ (HList (RecordValuesR xs) `HAppendR` HList '[ListStart, LVPair "names" [String]]), + HList ___ ~ (HList (RecordValuesR xs) `HAppendR` HList '[ListStart, Tagged "names" [String]]), RecordLabelsString (RecordLabels xs), - HAppend (HList (RecordValuesR xs)) (HList '[ ListStart, LVPair "names" [String]])) + HAppend (HList (RecordValuesR xs)) (HList '[ ListStart, Tagged "names" [String]])) @@ -233,7 +235,6 @@ -- functions called type FromRDSRec a b as' as'2 bs' = (HSequence Get b as', HSequence ((->) ()) a b, - -- HMap1 FLVPair as' bs', HMapAux FLVPair as' bs', SameLength as' bs', SameLength bs' as', @@ -245,19 +246,32 @@ HMapOut (HComp FShowLabel FLabelLVPair) bs' String, RecordLabelsString (RecordLabels bs'), HNat2Integral (HLength bs'), - HReplicate2 (HLength bs') FFromRDS as'2) + HReplicate (HLength bs') FFromRDS, + HReplicateR (HLength bs')FFromRDS ~ as'2) +{- | R lists become HList records. @list(x=1,y='b')@ parses to something +like + +> let x = Label :: Label "x" +> y = Label :: Label "y" +> in x .=. 1 +> .*. y .=. "b" +> .*. emptyRecord + +You have to get the result type right +(ie. @Record [Tagged \"x\" Double, Tagged \"y\" String]@) for things to parse +-} instance FromRDSRec a b as' as'2 bs' => FromRDS (Record bs') where fromRDS = do 531 <- get :: Get Int32 - let len = hNat2Integral (proxy :: Proxy (HLength bs')) + let len = hNat2Integral (Proxy :: Proxy (HLength bs')) len2 <- get :: Get Int32 when (len /= len2) $ error $ "fromRDS expected length: " ++ show len ++ " rds file has length: " ++ show len2 r <- hSequence (hSequence (hMap FApply - (hReplicate2 (proxy :: Proxy (HLength bs')) FFromRDS) ) + (hReplicate (Proxy :: Proxy (HLength bs')) FFromRDS) ) ()) getListHdr "names" <- getString @@ -269,7 +283,7 @@ ++ " rds file has names attribute : " ++ show names 254 <- get :: Get Int32 - return (Record (hMap FLVPair (r :: HList as'))) + return (Record (hMap FLVPair (r :: HList as') :: HList bs')) -- this hMap1 can't be replaced by hMap? class RecordLabelsString (a :: [Symbol]) where @@ -280,14 +294,14 @@ instance (ShowLabel x, RecordLabelsString xs) => RecordLabelsString (x ': xs) where - recordLabelsString _ = showLabel (Label :: Label x) : recordLabelsString (proxy :: Proxy xs) + recordLabelsString _ = showLabel (Label :: Label x) : recordLabelsString (Proxy :: Proxy xs) -- same as recordLabelsString, but less lazy recLabs (Record xs) = hMapOut (HComp FShowLabel FLabelLVPair) xs data FLabelLVPair = FLabelLVPair -instance(LVPair l a ~ x, y ~ Label l) => ApplyAB FLabelLVPair x y where - applyAB FLabelLVPair = labelLVPair +instance(Tagged l a ~ x, y ~ Label l) => ApplyAB FLabelLVPair x y where + applyAB FLabelLVPair _ = (Label :: Label l) data FShowLabel = FShowLabel instance (string ~ String, ShowLabel l, ll ~ Label l) => ApplyAB FShowLabel ll string @@ -302,6 +316,8 @@ instance ToRDS Double where toRDS = toRDS . (:[]) instance ToRDS Int32 where toRDS = toRDS . (:[]) +instance ToRDS Integer where toRDS = toRDS . (fromIntegral :: Integer -> Int32) +instance ToRDS Int where toRDS = toRDS . (fromIntegral :: Int -> Int32) instance FromRDS Int32 where fromRDS = do @@ -313,13 +329,30 @@ [x] <- fromRDS return x +instance FromRDS Int where + fromRDS = fromIntegral <$> (fromRDS :: Get Int32) +instance FromRDS Integer where + fromRDS = fromIntegral <$> (fromRDS :: Get Int32) + + instance ToRDS [Int32] where toRDS = toRDS . V.fromList instance FromRDS [Int32] where fromRDS = fmap V.toList $ fromRDS +-- | converts to an 'Int32', which is bad on 64 bit systems where +-- @maxBound :: Int@ is a bigger number than @maxBound :: Int32@ +instance ToRDS [Int] where + toRDS = toRDS . V.fromList . map (fromIntegral :: Int -> Int32) +instance FromRDS [Int] where + fromRDS = map (fromIntegral :: Int32 -> Int) . V.toList <$> fromRDS +-- | converts to an 'Int32' first +instance ToRDS [Integer] where + toRDS = toRDS . V.fromList . map (fromIntegral :: Integer -> Int32) +instance FromRDS [Integer] where + fromRDS = map (fromIntegral :: Int32 -> Integer) . V.toList <$> fromRDS putString s = do @@ -355,12 +388,12 @@ -- | probably internal -instance forall t l. (ToRDS t, ShowLabel l) => ToRDS (LVPair l t) where - toRDS (LVPair x) = do +instance forall t l. (ToRDS t, ShowLabel l) => ToRDS (Tagged l t) where + toRDS (Tagged x) = do putString (showLabel (undefined :: Label l)) toRDS x -- | probably internal -instance forall t l. (FromRDS t, ShowLabel l) => FromRDS (LVPair l t) where +instance forall t l. (FromRDS t, ShowLabel l) => FromRDS (Tagged l t) where fromRDS = do varName <- getString @@ -368,24 +401,24 @@ unless (varName == s) $ fail $ unwords ["FromRDS: expecting label `", s , "', but got: `" , varName , "'"] x <- fromRDS - return (LVPair x) + return (Tagged x) -- | labels are stored with the variables here. compare with the instance for 'Record' / 'LST' which collects -- the labels and saves them as an attribute called \"names\" newtype RDA a = RDA (HList a) -- | internal -instance forall rs l2 t. (ToRDS t, ToRDS (RDA rs), ShowLabel l2) => ToRDS (RDA (LVPair l2 t ': rs)) where +instance forall rs l2 t. (ToRDS t, ToRDS (RDA rs), ShowLabel l2) => ToRDS (RDA (Tagged l2 t ': rs)) where toRDS (RDA (x `HCons` xs)) = do putListHdr toRDS x toRDS (RDA xs) -- | internal -instance forall rs l2 t. (FromRDS t, FromRDS (RDA rs), ShowLabel l2) => FromRDS (RDA (LVPair l2 t ': rs)) where +instance forall rs l2 t. (FromRDS t, FromRDS (RDA rs), ShowLabel l2) => FromRDS (RDA (Tagged l2 t ': rs)) where fromRDS = do getListHdr - x <- fromRDS :: Get (LVPair l2 t) + x <- fromRDS :: Get (Tagged l2 t) RDA xs <- fromRDS :: Get (RDA rs) return (RDA (x `HCons` xs)) @@ -592,7 +625,7 @@ A typical type would be -> Record '[LVPair l1 (LVPair m1 x), LVPair l2 (LVPair m2 x)] +> Record '[Tagged l1 (Tagged m1 x), Tagged l2 (Tagged m2 x)] The outer labels (@l1@, @l2@) are the haskell-side. The inner labels are the @m1@ @m2@ which are the names of the variables on the R side. @@ -608,9 +641,9 @@ hdr' <- fmap (BS.toString) $ getByteString (BS.length (BS.fromString hdr)) unless (hdr == hdr') $ fail "wrong header" [{- 2 , 196609, 131840 -} _, _, _ :: Int32 ] <- replicateM 3 get - fmap (\(RDA a) -> Record (hMap1 FLVPair (a::HList __) )) fromRDS + fmap (\(RDA a) -> Record (hMap FLVPair (a::HList __) )) fromRDS -type FromRDA a r = (HMap1 FLVPair a r, FromRDS (RDA a)) +type FromRDA a r = (HMapCxt FLVPair (HList a) (HList r) a r, FromRDS (RDA a)) -- * tests diff --git a/src/RlangQQ/FN.hs b/src/RlangQQ/FN.hs --- a/src/RlangQQ/FN.hs +++ b/src/RlangQQ/FN.hs @@ -4,7 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} --- | 'hMap' 'FN' drops the inner LVPair, which was +-- | 'hMap' 'FN' drops the inner Tagged, which was -- just used to keep track of the variable name on the -- R side. -- @@ -15,10 +15,10 @@ import GHC.TypeLits data FN = FN -instance (a ~ (LVPair (t :: k) (LVPair (t2::k) x)), b ~LVPair t x) => ApplyAB FN a b where - applyAB _ (LVPair (LVPair x)) = LVPair x +instance (a ~ (Tagged (t :: k) (Tagged (t2::k) x)), b ~Tagged t x) => ApplyAB FN a b where + applyAB _ (Tagged (Tagged x)) = Tagged x data NoLabel = NoLabel -instance (la ~ LVPair "" a) => ApplyAB NoLabel a la where - applyAB _ x = LVPair x +instance (la ~ Tagged "" a) => ApplyAB NoLabel a la where + applyAB _ x = Tagged x diff --git a/src/RlangQQ/Internal.hs b/src/RlangQQ/Internal.hs --- a/src/RlangQQ/Internal.hs +++ b/src/RlangQQ/Internal.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} module RlangQQ.Internal where @@ -23,6 +19,7 @@ import qualified Data.ByteString.Lazy.UTF8 as B import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString.Lazy import qualified Data.ByteString.Lazy.Char8 as B8 import Control.Monad.State @@ -32,12 +29,14 @@ import qualified Data.Map as M import Data.Foldable (foldMap) +import System.FilePath import Paths_Rlang_QQ import RlangQQ.Binary import RlangQQ.Antiquote import RlangQQ.FN +-- import RlangQQ.ParseKnitted import Control.Concurrent.Chan import Control.Concurrent.MVar @@ -51,21 +50,26 @@ -- | going via binary serialization (classes from "RlangQQ.Binary"). This is used in 'RlangQQ.r' quoteRExpression2 i returnChan str0 = do let rawFile, mdFile, rmdFile, inputFile, inputFile2, outputFile, figPath :: String - rawFile = printf "Rtmp/raw%d.R" (i :: Int) - rmdFile = printf "Rtmp/raw%d.Rmd" i - mdFile = printf "Rtmp/raw%d.md" i - figPath = printf "Rtmp/fig%d/" i - inputFile = printf "Rtmp/%d_hs.rdx" i + rawFile = printf "Rtmp/raw%d.R" (i :: Int) + rmdFile = printf "Rtmp/raw%d.Rmd" i + rmdFile2 = printf "Rtmp/raw%d_.Rmd" i + mdFile = printf "Rtmp/raw%d.md" i + figPath = printf "Rtmp/fig%d/" i + inputFile = printf "Rtmp/%d_hs.rdx" i inputFile2 = printf "Rtmp/%d_hs2.rdx" i outputFile = printf "Rtmp/%d_r.rdx" i - (knitrHdr, (str, addAntiquotes)) = fmap withRawFile (splitKnitrHdr str0) + -- the print('') is to fix a bug that somehow drops the first + -- expression sent to R + (knitrHdr, withRawFile -> (("setwd('../');"++) -> str, addAntiquotes)) + = splitKnitrHdr str0 + let inRmdChunk s = unlines ["```{r " ++ knitrHdr ++ "}", s, "```"] variables <- runIO $ do t <- getDataFileName "Tree.R" createDirectoryIfMissing False "Rtmp" writeFile rawFile str - writeFile rmdFile (unlines ["```{r " ++ knitrHdr ++ "}", str, "```"]) + writeFile rmdFile (inRmdChunk str) rt <- readProcess "R" ["--no-save","--quiet"] $ printf "source('%s'); rlangQQ_toTree(parse('%s'))" t rawFile case parseString parseTree mempty rt of @@ -132,26 +136,33 @@ let mapSnd (Record x) = Record (hMap FN x) fixTy x = x `asTypeOf` Record $sampOutput fixTy2 x = x `asTypeOf` Record $sampOutput2 - in fixTy2 . mapSnd . fixTy . fromRDA <$> B.readFile outputFile |] + in do + cts <- B.readFile outputFile + -- lazy IO makes for confusings: possibly better to switch + -- over to strict BS instead of this + Data.ByteString.Lazy.length cts `seq` return () + return . fixTy2 . mapSnd . fixTy $ fromRDA cts |] outVars :: [String] outVars = [ s | (s, intent) <- M.toList variables ++ M.toList chanVars {- necessary? -}, notIn intent ] - - writeOutputFile | [] <- outVars = [| "" |] - | otherwise = stringE (printf "save(%s, file='%s', compress='gzip');" + saveRVars :: String + saveRVars + | [] <- outVars = "" + | otherwise = printf "save(%s, file='%s', compress='gzip');" (intercalate "," $ reverse outVars) - outputFile) + (takeFileName outputFile) + rmd2Content :: String + rmd2Content = inRmdChunk str ++ inRmdChunk saveRVars runRNoChan :: ExpQ runRNoChan = do [| readProcess "R" ["--no-save", "--quiet"] $ concat [ $(stringE (printf "library(knitr);\ - \opts_chunk$set(fig.path='%s');\ + \opts_chunk$set(fig.path='%s',tidy=F);\ \load('%s');" figPath inputFile)), - $(stringE (printf "knit('%s', output='%s', quiet=TRUE);" rmdFile mdFile)), - $writeOutputFile ] + $(stringE (printf "knit('%s', output='%s', quiet=TRUE);" rmdFile2 mdFile))] |] @@ -178,8 +189,8 @@ \ string that will never happen by chance\"" forkIO $ forever $ do withOutputFn <- $writeChanInput - hPutStrLn i $ printf "load('%s'); knit('%s', output='%s', quiet=TRUE); %s %s" - inputFile2 rmdFile mdFile $writeOutputFile + hPutStrLn i $ printf "load('%s'); knit('%s', output='%s', quiet=TRUE); %s" + inputFile2 rmdFile2 mdFile uniqueDoneString hFlush i $(whenOutVars [| putMVar outVar withOutputFn |] ) @@ -200,17 +211,18 @@ -- but that doesn't typecheck here... ) |]) - return chOut |] + runIO $ writeFile rmdFile2 rmd2Content + addAntiquotes [| do {- already done, but Rtmp could have moved since compile time -} createDirectoryIfMissing False "Rtmp" do - f <- doesFileExist rawFile - unless f $ writeFile rawFile str + f <- doesFileExist rmdFile2 + unless f $ writeFile rmdFile2 rmd2Content $writeInputFile $(if M.size chanVars == 0 then [| do diff --git a/src/RlangQQ/MakeRecord.hs b/src/RlangQQ/MakeRecord.hs --- a/src/RlangQQ/MakeRecord.hs +++ b/src/RlangQQ/MakeRecord.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ConstraintKinds, DataKinds,GADTs,FlexibleContexts, FlexibleInstances,KindSignatures,MultiParamTypeClasses #-} -- | functions to help making lists for consumption on the R side module RlangQQ.MakeRecord where @@ -11,7 +10,7 @@ -- | convert a haskell list into a record with labels all of type \"\". The length -- of the list is decided by the (type of the) first argument which is a 'HNat' listToRecN :: ListToRecN __ (n :: HNat) x r => Proxy n -> [x] -> Record r -listToRecN n xs = Record $ hMap2 NoLabel $ flip evalState xs $ hSequence $ hReplicate n comp +listToRecN n xs = Record $ hMap NoLabel $ flip evalState xs $ hSequence $ hReplicate n comp where comp = do x : xs' <- get return () :: State [x] () @@ -20,11 +19,11 @@ type ListToRecN __ (n :: HNat) x r = (HReplicate n (StateT [x] Identity x), HSequence (StateT [x] Identity) (HReplicateR n (StateT [x] Identity x)) __, - HMap2 NoLabel __ r) + HMapCxt NoLabel (HList __) (HList r) __ r) data NoLabel = NoLabel -instance (LVPair "" a ~ la) => ApplyAB NoLabel a la where - applyAB _ x = LVPair x +instance (Tagged "" a ~ la) => ApplyAB NoLabel a la where + applyAB _ x = Tagged x diff --git a/src/RlangQQ/ParseKnitted.hs b/src/RlangQQ/ParseKnitted.hs new file mode 100644 --- /dev/null +++ b/src/RlangQQ/ParseKnitted.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE ViewPatterns #-} +module RlangQQ.ParseKnitted + (parseKnitted, + KnitInteraction(..), + KnitOutput(..)) where +import Data.List.Split hiding (chunk) +import Data.List +import Data.Maybe +import Data.Char + +-- | splits up the contents of the .md file generated by @knitr::knit@ +parseKnitted file = grp . chunk . lines $ file + +data KnitInteraction = KnitInteraction String [KnitOutput] + deriving (Show) + +data KnitOutput + = KnitAsIs String -- ^ has markup to be interpreted + | KnitPrint String + | KnitWarning String + | KnitError String + | KnitImage String FilePath -- ^ @![caption](pathToImage)@ + deriving (Show) + + +chunk ( (stripPrefix "```" -> Just x) : xs) = + let (a,b) = break (isPrefixOf "```") xs + in (x,a) : chunk b +chunk ("" : xs) = chunk xs +chunk [] = [] + +-- | depends on knitr's default opts_chunk$get(comment) = "##" +classify :: [String] -> [KnitOutput] +classify (x:xs) | Just r <- stripPrefix "## Warning: " x = + [KnitWarning (unlines $ r : map (tryStripPrefix "## ") xs)] +classify (x:xs) | Just r <- stripPrefix "## Error: " x = + [KnitError (unlines $ r : map (tryStripPrefix "## ") xs)] +classify xs = splitImg xs + +splitImg (x:xs) | Just r <- stripPrefix "![" x = + let end s = case splitOn "](" s of + [a,b] -> Just (KnitImage a b) + _ -> Nothing + -- plot(lm(y ~ x)) comes out as ![caption1](a) ![caption2](b) + getCaps [] = [] + getCaps s = mapMaybe end $ splitOn ") ![" (r ++ "![") + in getCaps r ++ splitImg xs +splitImg [] = [] +splitImg xs @ (x : _) | "## " `isPrefixOf` x = + let (a,b) = span (isPrefixOf "## ") xs + in KnitPrint (unlines $ map (tryStripPrefix "## ") a) : splitImg b +splitImg xs = + let (a,b) = break (\x -> any (`isPrefixOf` x) ["![","## "]) xs + in KnitAsIs (unlines a) : splitImg b + +tryStripPrefix p x = fromMaybe x $ stripPrefix p x + +grp (((/= "") -> True, a) : xs) = + let (b,c) = span ((== "") . fst) xs + in KnitInteraction (unlines a) (filter notBlank $ concatMap (classify . snd) b) : grp c +grp [] = [] + +notBlank (KnitPrint x) = not (all isSpace x) +notBlank _ = True