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
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
|]
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)
hsVars :: Tree String -> [String]
hsVars = mapMaybe (stripPrefix "hs_") . F.toList
class ToRVal a where
toRVal :: String
-> 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 ")"]
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)