diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Adam Vogt + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Adam Vogt nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Rlang-QQ.cabal b/Rlang-QQ.cabal new file mode 100644 --- /dev/null +++ b/Rlang-QQ.cabal @@ -0,0 +1,39 @@ +name: Rlang-QQ +version: 0.0.0.0 +cabal-version: >=1.8 +build-type: Simple +license: BSD3 +license-file: LICENSE +maintainer: Adam Vogt +homepage: http://code.haskell.org/~aavogt/Rlang-QQ +synopsis: quasiquoter for inline-R code +description: This quasiquoter calls R (www.r-project.org/) from ghc. + Variables from the haskell-side are passed in. In the future, + variables created (or modified) could be returned as the value + of the quasiquote. +category: Development +author: Adam Vogt +data-dir: rsrc +data-files: Tree.R parseTreeExample.R +extra-source-files: examples/test.hs + +source-repository head + type: darcs + location: http://code.haskell.org/~aavogt/Rlang-QQ + +library + hs-source-dirs: src + + build-depends: base ==4.*, containers, + template-haskell ==2.8.*, directory, process, + trifecta ==1.1.*, utf8-string ==0.3.*, bytestring, + Cabal + + exposed-modules: RlangQQ.Internal + RlangQQ + + other-modules: Paths_Rlang_QQ + + exposed: True + buildable: True + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/test.hs b/examples/test.hs new file mode 100644 --- /dev/null +++ b/examples/test.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE QuasiQuotes #-} +import RlangQQ + +x = [0 .. 10 :: Double] +y = map (sin . (*pi) . (/10)) x + +main = do + [r| + library(ggplot2) + png(file='test.png') + plot(qplot( hs_x, hs_y )) + dev.off() + |] + diff --git a/rsrc/Tree.R b/rsrc/Tree.R new file mode 100644 --- /dev/null +++ b/rsrc/Tree.R @@ -0,0 +1,10 @@ + +rlangQQ_toTree <- function(e) + if (is.symbol(e)) paste('Node', show2(e), '[]') else { + + + paste('Node', + show2(e[[1]]), + if (length(e) < 2) '[]' else + paste('[', paste(sapply(2:length(e), function(i) rlangQQ_toTree(e[[i]])), collapse=', '), ']') ) + } diff --git a/rsrc/parseTreeExample.R b/rsrc/parseTreeExample.R new file mode 100644 --- /dev/null +++ b/rsrc/parseTreeExample.R @@ -0,0 +1,6 @@ +library(ggplot2) + +d <- data.frame(x=c(1,2,3), y=c(3,2,3), z = hs_z) + +d$x+d$y + diff --git a/src/RlangQQ.hs b/src/RlangQQ.hs new file mode 100644 --- /dev/null +++ b/src/RlangQQ.hs @@ -0,0 +1,53 @@ +{- | A quasiquoter to help with calling R () from ghc. + +-} +module RlangQQ ( + -- * the quasiquoter + r, + + ToRVal, + + -- ** TODO + -- $TODO + ) where + +import RlangQQ.Internal +import Language.Haskell.TH.Quote + + +{- $TODO + +[R -> haskell] + +Currently nothing is done to the output. It should be possible to return the +original hs_foo variables in an extensible record, (possibly limited to the +case where they have been modified?). + +ie.if there is a @[r| hs_foo <- \"abc\" |]@, then at the very bottom of the +generated R file we should have be calling an R function like +@serialize(hs_foo)@. then on the haskell side we have: + +> return (label foo $ deserialize "hs_foo" `asTypeOf` hs_foo, +> label abc $ deserialize "hs_abc" `asTypeOf` hs_abc, +> ... ) + +Where the tuple is an extensible record, and the IO needed to +get the result is also sequenced. + +Variables whose first occurence is an assignment do not need a corresponding +variable to be sent into R: + +> [r| hs_x <- rnorm(5); hs_x <- sum(hs_x) |] + + +[better IPC] + +perhaps communicating through files is not the best idea. When there are +multiple quasi quotes, maybe they should be connecting to the same session. + +Marshalling other types (Vector, Array, Map etc.). + +Use 'FromRVal' + +-} + diff --git a/src/RlangQQ/Internal.hs b/src/RlangQQ/Internal.hs new file mode 100644 --- /dev/null +++ b/src/RlangQQ/Internal.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +module RlangQQ.Internal where + +import Data.Char +import Data.List +import Data.Maybe +import Data.Monoid +import Data.Tree +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import qualified Data.Foldable as F +import System.Directory +import System.Process +import Text.Printf +import Text.Trifecta + +import Data.ByteString.Lazy.UTF8 as B +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString.Lazy.Char8 as B8 + + +import Paths_Rlang_QQ + +{- | 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 the class 'ToRVal'. + +For example, when this file is run + +> {-# LANGUAGE QuasiQuotes #-} +> import RlangQQ +> +> x = [0 .. 10 :: Double] +> y = map (sin . (*pi) . (/10)) x +> +> main = do +> [r| +> library(ggplot2) +> png(file='test.png') +> plot(qplot( hs_x, hs_y )) +> dev.off() +> |] + +The file is produced <> + +-} +r = QuasiQuoter { quoteExp = quoteRExpression 1 } + +quoteRExpression i str = do + let rawFile = printf "Rtmp/raw%d.R" (i::Int) :: String + let hdrFile = printf "Rtmp/new%d.R" (i::Int) :: String + + variablesToInput <- runIO $ do + t <- getDataFileName "Tree.R" + createDirectoryIfMissing False "Rtmp" + writeFile rawFile str + rt <- readProcess "R" ["--no-save","--quiet"] + $ printf "source('%s'); rlangQQ_toTree(parse('%s'))" t rawFile + case parseString parseTree mempty rt of + Success a -> return $ hsVars a + Failure a -> do + print a + error "parse failure" + let varFiles = map (stringE . printf "Rtmp/%d_hs_%s" i) variablesToInput + + writeVarFiles = [| + mapM_ (\(file,varName, value) -> B.writeFile file (toRVal varName value)) $ + $(listE $ zipWith3 (\x y z -> [| ($x, $y, $z) |]) + varFiles + (map (stringE . ("hs_"++)) variablesToInput) + (map (varE . mkName) variablesToInput)) + + |] + + runR = [| readProcess "R" ["--no-save", "--quiet"] + $ concat + $ map (printf "source('%s');") $(listE varFiles) + ++ [ printf "source('%s')" rawFile] |] + [| do + writeFile hdrFile $ concatMap (printf "source('%s');") variablesToInput + $writeVarFiles + $runR + |] + + + + +-- * converting R\'s AST + +parseTree' = do + symbol "Node" + nl <- stringLiteral' + children <- brackets $ commaSep parseTree' + return (Node nl children) + +parseTree = do + manyTill anyChar (try (string "[1]")) + manyTill (noneOf "\n") space + between (oneOf "\"") (oneOf "\"") parseTree' + + +parseTreeTest = do + t <- getDataFileName "Tree.R" + inputFile <- getDataFileName "parseTreeExample.R" + rt <- readProcess "R" ["--no-save","--quiet"] $ "source('"++ t ++ "'); rlangQQ_toTree(parse('"++ inputFile ++ "'))" + print rt + let r = parseString parseTree mempty rt :: Result (Tree String) + + print (fmap hsVars r) + +-- | gets variables like @abc@ provided the R file contained @hs_abc@ +hsVars :: Tree String -> [String] +hsVars = mapMaybe (stripPrefix "hs_") . F.toList + + + +-- * classes for marshalling data + + +-- ** haskell -> R +class ToRVal a where + toRVal :: String -- ^ variable name + -> a + -> B.ByteString + +instance ToRVal Int where toRVal x n = B.fromString $ x ++ "<-" ++ show n +instance ToRVal Integer where toRVal x n = B.fromString $ x ++ "<-" ++ show n +instance ToRVal Double where toRVal x n = B.fromString $ x ++ "<-" ++ show n +instance ToRVal String where toRVal x n = B.fromString $ x ++ "<-" ++ show n +instance ToRVal [Int] where toRVal = listToVec +instance ToRVal [Integer] where toRVal = listToVec +instance ToRVal [Double] where toRVal = listToVec +instance ToRVal [String] where toRVal = listToVec + +listToVec x n = B8.unwords $ + [B.fromString x, + B.fromString "<- c(", + B8.intercalate (B.fromString ",") (map (B.fromString . show) n), + B.fromString ")"] + +-- ** R -> haskell + +-- | not used yet +class FromRVal a where fromRVal :: B.ByteString -> a +instance FromRVal Double where fromRVal = fromRValp double + + +fromRValp p s = + case parseByteString p mempty (B.toStrict s) of + Success a -> a + Failure a -> error (show a)