rclient (empty) → 0.1.0.0

raw patch · 31 files changed

+1418/−0 lines, 31 filesdep +QuickCheckdep +basedep +binarysetup-changedbinary-added

Dependencies added: QuickCheck, base, binary, bytestring, data-binary-ieee754, network, split

Files

• .git/HEAD +1/−0
• .git/config +11/−0
• .git/description +1/−0
• .git/hooks/applypatch-msg.sample +15/−0
• .git/hooks/commit-msg.sample +24/−0
• .git/hooks/post-commit.sample +8/−0
• .git/hooks/post-receive.sample +15/−0
• .git/hooks/post-update.sample +8/−0
• .git/hooks/pre-applypatch.sample +14/−0
• .git/hooks/pre-commit.sample +46/−0
• .git/hooks/pre-rebase.sample +169/−0
• .git/hooks/prepare-commit-msg.sample +36/−0
• .git/hooks/update.sample +128/−0
• .git/index binary
• .git/info/exclude +6/−0
• .git/logs/HEAD +1/−0
• .git/logs/refs/heads/master +1/−0
• .git/objects/pack/pack-692007fe248a601ec31a4397d90d0022285297fd.idx binary
• .git/objects/pack/pack-692007fe248a601ec31a4397d90d0022285297fd.pack binary
• .git/packed-refs +2/−0
• .git/refs/heads/master +1/−0
• .git/refs/remotes/origin/HEAD +1/−0
• LICENSE +0/−0
• Main.hs +6/−0
• Network/Rserve/Client.hs +324/−0
• Network/Rserve/Constants.hs +154/−0
• Network/Rserve/Internal.hs +296/−0
• Setup.hs +2/−0
• Tests.hs +90/−0
• examples/Main.hs +26/−0
• rclient.cabal +32/−0

@@ -0,0 +1,1 @@+ref: refs/heads/master

@@ -0,0 +1,11 @@+[core]+	repositoryformatversion = 0+	filemode = true+	bare = false+	logallrefupdates = true+[remote "origin"]+	fetch = +refs/heads/*:refs/remotes/origin/*+	url = git@github.com:tdoris/Rclient.git+[branch "master"]+	remote = origin+	merge = refs/heads/master

@@ -0,0 +1,1 @@+Unnamed repository; edit this file 'description' to name the repository.

@@ -0,0 +1,15 @@+#!/bin/sh+#+# An example hook script to check the commit log message taken by+# applypatch from an e-mail message.+#+# The hook should exit with non-zero status after issuing an+# appropriate message if it wants to stop the commit.  The hook is+# allowed to edit the commit message file.+#+# To enable this hook, rename this file to "applypatch-msg".++. git-sh-setup+test -x "$GIT_DIR/hooks/commit-msg" &&+	exec "$GIT_DIR/hooks/commit-msg" ${1+"$@"}+:

@@ -0,0 +1,24 @@+#!/bin/sh+#+# An example hook script to check the commit log message.+# Called by git-commit with one argument, the name of the file+# that has the commit message.  The hook should exit with non-zero+# status after issuing an appropriate message if it wants to stop the+# commit.  The hook is allowed to edit the commit message file.+#+# To enable this hook, rename this file to "commit-msg".++# Uncomment the below to add a Signed-off-by line to the message.+# Doing this in a hook is a bad idea in general, but the prepare-commit-msg+# hook is more suited to it.+#+# SOB=$(git var GIT_AUTHOR_IDENT | sed -n 's/^\(.*>\).*$/Signed-off-by: \1/p')+# grep -qs "^$SOB" "$1" || echo "$SOB" >> "$1"++# This example catches duplicate Signed-off-by lines.++test "" = "$(grep '^Signed-off-by: ' "$1" |+	 sort | uniq -c | sed -e '/^[ 	]*1[ 	]/d')" || {+	echo >&2 Duplicate Signed-off-by lines.+	exit 1+}

@@ -0,0 +1,8 @@+#!/bin/sh+#+# An example hook script that is called after a successful+# commit is made.+#+# To enable this hook, rename this file to "post-commit".++: Nothing

@@ -0,0 +1,15 @@+#!/bin/sh+#+# An example hook script for the "post-receive" event.+#+# The "post-receive" script is run after receive-pack has accepted a pack+# and the repository has been updated.  It is passed arguments in through+# stdin in the form+#  <oldrev> <newrev> <refname>+# For example:+#  aa453216d1b3e49e7f6f98441fa56946ddcd6a20 68f7abf4e6f922807889f52bc043ecd31b79f814 refs/heads/master+#+# see contrib/hooks/ for a sample, or uncomment the next line and+# rename the file to "post-receive".++#. /usr/share/doc/git-core/contrib/hooks/post-receive-email

@@ -0,0 +1,8 @@+#!/bin/sh+#+# An example hook script to prepare a packed repository for use over+# dumb transports.+#+# To enable this hook, rename this file to "post-update".++exec git-update-server-info

@@ -0,0 +1,14 @@+#!/bin/sh+#+# An example hook script to verify what is about to be committed+# by applypatch from an e-mail message.+#+# The hook should exit with non-zero status after issuing an+# appropriate message if it wants to stop the commit.+#+# To enable this hook, rename this file to "pre-applypatch".++. git-sh-setup+test -x "$GIT_DIR/hooks/pre-commit" &&+	exec "$GIT_DIR/hooks/pre-commit" ${1+"$@"}+:

@@ -0,0 +1,46 @@+#!/bin/sh+#+# An example hook script to verify what is about to be committed.+# Called by git-commit with no arguments.  The hook should+# exit with non-zero status after issuing an appropriate message if+# it wants to stop the commit.+#+# To enable this hook, rename this file to "pre-commit".++if git-rev-parse --verify HEAD >/dev/null 2>&1+then+	against=HEAD+else+	# Initial commit: diff against an empty tree object+	against=4b825dc642cb6eb9a060e54bf8d69288fbee4904+fi++# If you want to allow non-ascii filenames set this variable to true.+allownonascii=$(git config hooks.allownonascii)++# Cross platform projects tend to avoid non-ascii filenames; prevent+# them from being added to the repository. We exploit the fact that the+# printable range starts at the space character and ends with tilde.+if [ "$allownonascii" != "true" ] &&+	# Note that the use of brackets around a tr range is ok here, (it's+	# even required, for portability to Solaris 10's /usr/bin/tr), since+	# the square bracket bytes happen to fall in the designated range.+	test "$(git diff --cached --name-only --diff-filter=A -z $against |+	  LC_ALL=C tr -d '[ -~]\0')"+then+	echo "Error: Attempt to add a non-ascii file name."+	echo+	echo "This can cause problems if you want to work"+	echo "with people on other platforms."+	echo+	echo "To be portable it is advisable to rename the file ..."+	echo+	echo "If you know what you are doing you can disable this"+	echo "check using:"+	echo+	echo "  git config hooks.allownonascii true"+	echo+	exit 1+fi++exec git diff-index --check --cached $against --

@@ -0,0 +1,169 @@+#!/bin/sh+#+# Copyright (c) 2006, 2008 Junio C Hamano+#+# The "pre-rebase" hook is run just before "git-rebase" starts doing+# its job, and can prevent the command from running by exiting with+# non-zero status.+#+# The hook is called with the following parameters:+#+# $1 -- the upstream the series was forked from.+# $2 -- the branch being rebased (or empty when rebasing the current branch).+#+# This sample shows how to prevent topic branches that are already+# merged to 'next' branch from getting rebased, because allowing it+# would result in rebasing already published history.++publish=next+basebranch="$1"+if test "$#" = 2+then+	topic="refs/heads/$2"+else+	topic=`git symbolic-ref HEAD` ||+	exit 0 ;# we do not interrupt rebasing detached HEAD+fi++case "$topic" in+refs/heads/??/*)+	;;+*)+	exit 0 ;# we do not interrupt others.+	;;+esac++# Now we are dealing with a topic branch being rebased+# on top of master.  Is it OK to rebase it?++# Does the topic really exist?+git show-ref -q "$topic" || {+	echo >&2 "No such branch $topic"+	exit 1+}++# Is topic fully merged to master?+not_in_master=`git-rev-list --pretty=oneline ^master "$topic"`+if test -z "$not_in_master"+then+	echo >&2 "$topic is fully merged to master; better remove it."+	exit 1 ;# we could allow it, but there is no point.+fi++# Is topic ever merged to next?  If so you should not be rebasing it.+only_next_1=`git-rev-list ^master "^$topic" ${publish} | sort`+only_next_2=`git-rev-list ^master           ${publish} | sort`+if test "$only_next_1" = "$only_next_2"+then+	not_in_topic=`git-rev-list "^$topic" master`+	if test -z "$not_in_topic"+	then+		echo >&2 "$topic is already up-to-date with master"+		exit 1 ;# we could allow it, but there is no point.+	else+		exit 0+	fi+else+	not_in_next=`git-rev-list --pretty=oneline ^${publish} "$topic"`+	perl -e '+		my $topic = $ARGV[0];+		my $msg = "* $topic has commits already merged to public branch:\n";+		my (%not_in_next) = map {+			/^([0-9a-f]+) /;+			($1 => 1);+		} split(/\n/, $ARGV[1]);+		for my $elem (map {+				/^([0-9a-f]+) (.*)$/;+				[$1 => $2];+			} split(/\n/, $ARGV[2])) {+			if (!exists $not_in_next{$elem->[0]}) {+				if ($msg) {+					print STDERR $msg;+					undef $msg;+				}+				print STDERR " $elem->[1]\n";+			}+		}+	' "$topic" "$not_in_next" "$not_in_master"+	exit 1+fi++exit 0++################################################################++This sample hook safeguards topic branches that have been+published from being rewound.++The workflow assumed here is:++ * Once a topic branch forks from "master", "master" is never+   merged into it again (either directly or indirectly).++ * Once a topic branch is fully cooked and merged into "master",+   it is deleted.  If you need to build on top of it to correct+   earlier mistakes, a new topic branch is created by forking at+   the tip of the "master".  This is not strictly necessary, but+   it makes it easier to keep your history simple.++ * Whenever you need to test or publish your changes to topic+   branches, merge them into "next" branch.++The script, being an example, hardcodes the publish branch name+to be "next", but it is trivial to make it configurable via+$GIT_DIR/config mechanism.++With this workflow, you would want to know:++(1) ... if a topic branch has ever been merged to "next".  Young+    topic branches can have stupid mistakes you would rather+    clean up before publishing, and things that have not been+    merged into other branches can be easily rebased without+    affecting other people.  But once it is published, you would+    not want to rewind it.++(2) ... if a topic branch has been fully merged to "master".+    Then you can delete it.  More importantly, you should not+    build on top of it -- other people may already want to+    change things related to the topic as patches against your+    "master", so if you need further changes, it is better to+    fork the topic (perhaps with the same name) afresh from the+    tip of "master".++Let's look at this example:++		   o---o---o---o---o---o---o---o---o---o "next"+		  /       /           /           /+		 /   a---a---b A     /           /+		/   /               /           /+	       /   /   c---c---c---c B         /+	      /   /   /             \         /+	     /   /   /   b---b C     \       /+	    /   /   /   /             \     /+    ---o---o---o---o---o---o---o---o---o---o---o "master"+++A, B and C are topic branches.++ * A has one fix since it was merged up to "next".++ * B has finished.  It has been fully merged up to "master" and "next",+   and is ready to be deleted.++ * C has not merged to "next" at all.++We would want to allow C to be rebased, refuse A, and encourage+B to be deleted.++To compute (1):++	git-rev-list ^master ^topic next+	git-rev-list ^master        next++	if these match, topic has not merged in next at all.++To compute (2):++	git-rev-list master..topic++	if this is empty, it is fully merged to "master".

@@ -0,0 +1,36 @@+#!/bin/sh+#+# An example hook script to prepare the commit log message.+# Called by git-commit with the name of the file that has the+# commit message, followed by the description of the commit+# message's source.  The hook's purpose is to edit the commit+# message file.  If the hook fails with a non-zero status,+# the commit is aborted.+#+# To enable this hook, rename this file to "prepare-commit-msg".++# This hook includes three examples.  The first comments out the+# "Conflicts:" part of a merge commit.+#+# The second includes the output of "git diff --name-status -r"+# into the message, just before the "git status" output.  It is+# commented because it doesn't cope with --amend or with squashed+# commits.+#+# The third example adds a Signed-off-by line to the message, that can+# still be edited.  This is rarely a good idea.++case "$2,$3" in+  merge,)+    perl -i.bak -ne 's/^/# /, s/^# #/#/ if /^Conflicts/ .. /#/; print' "$1" ;;++# ,|template,)+#   perl -i.bak -pe '+#      print "\n" . `git diff --cached --name-status -r`+#	 if /^#/ && $first++ == 0' "$1" ;;++  *) ;;+esac++# SOB=$(git var GIT_AUTHOR_IDENT | sed -n 's/^\(.*>\).*$/Signed-off-by: \1/p')+# grep -qs "^$SOB" "$1" || echo "$SOB" >> "$1"

@@ -0,0 +1,128 @@+#!/bin/sh+#+# An example hook script to blocks unannotated tags from entering.+# Called by git-receive-pack with arguments: refname sha1-old sha1-new+#+# To enable this hook, rename this file to "update".+#+# Config+# ------+# hooks.allowunannotated+#   This boolean sets whether unannotated tags will be allowed into the+#   repository.  By default they won't be.+# hooks.allowdeletetag+#   This boolean sets whether deleting tags will be allowed in the+#   repository.  By default they won't be.+# hooks.allowmodifytag+#   This boolean sets whether a tag may be modified after creation. By default+#   it won't be.+# hooks.allowdeletebranch+#   This boolean sets whether deleting branches will be allowed in the+#   repository.  By default they won't be.+# hooks.denycreatebranch+#   This boolean sets whether remotely creating branches will be denied+#   in the repository.  By default this is allowed.+#++# --- Command line+refname="$1"+oldrev="$2"+newrev="$3"++# --- Safety check+if [ -z "$GIT_DIR" ]; then+	echo "Don't run this script from the command line." >&2+	echo " (if you want, you could supply GIT_DIR then run" >&2+	echo "  $0 <ref> <oldrev> <newrev>)" >&2+	exit 1+fi++if [ -z "$refname" -o -z "$oldrev" -o -z "$newrev" ]; then+	echo "Usage: $0 <ref> <oldrev> <newrev>" >&2+	exit 1+fi++# --- Config+allowunannotated=$(git config --bool hooks.allowunannotated)+allowdeletebranch=$(git config --bool hooks.allowdeletebranch)+denycreatebranch=$(git config --bool hooks.denycreatebranch)+allowdeletetag=$(git config --bool hooks.allowdeletetag)+allowmodifytag=$(git config --bool hooks.allowmodifytag)++# check for no description+projectdesc=$(sed -e '1q' "$GIT_DIR/description")+case "$projectdesc" in+"Unnamed repository"* | "")+	echo "*** Project description file hasn't been set" >&2+	exit 1+	;;+esac++# --- Check types+# if $newrev is 0000...0000, it's a commit to delete a ref.+zero="0000000000000000000000000000000000000000"+if [ "$newrev" = "$zero" ]; then+	newrev_type=delete+else+	newrev_type=$(git-cat-file -t $newrev)+fi++case "$refname","$newrev_type" in+	refs/tags/*,commit)+		# un-annotated tag+		short_refname=${refname##refs/tags/}+		if [ "$allowunannotated" != "true" ]; then+			echo "*** The un-annotated tag, $short_refname, is not allowed in this repository" >&2+			echo "*** Use 'git tag [ -a | -s ]' for tags you want to propagate." >&2+			exit 1+		fi+		;;+	refs/tags/*,delete)+		# delete tag+		if [ "$allowdeletetag" != "true" ]; then+			echo "*** Deleting a tag is not allowed in this repository" >&2+			exit 1+		fi+		;;+	refs/tags/*,tag)+		# annotated tag+		if [ "$allowmodifytag" != "true" ] && git rev-parse $refname > /dev/null 2>&1+		then+			echo "*** Tag '$refname' already exists." >&2+			echo "*** Modifying a tag is not allowed in this repository." >&2+			exit 1+		fi+		;;+	refs/heads/*,commit)+		# branch+		if [ "$oldrev" = "$zero" -a "$denycreatebranch" = "true" ]; then+			echo "*** Creating a branch is not allowed in this repository" >&2+			exit 1+		fi+		;;+	refs/heads/*,delete)+		# delete branch+		if [ "$allowdeletebranch" != "true" ]; then+			echo "*** Deleting a branch is not allowed in this repository" >&2+			exit 1+		fi+		;;+	refs/remotes/*,commit)+		# tracking branch+		;;+	refs/remotes/*,delete)+		# delete tracking branch+		if [ "$allowdeletebranch" != "true" ]; then+			echo "*** Deleting a tracking branch is not allowed in this repository" >&2+			exit 1+		fi+		;;+	*)+		# Anything else (is there anything else?)+		echo "*** Update hook: unknown type of update to ref $refname of type $newrev_type" >&2+		exit 1+		;;+esac++# --- Finished+exit 0

binary file changed (absent → 760 bytes)

@@ -0,0 +1,6 @@+# git-ls-files --others --exclude-from=.git/info/exclude+# Lines that start with '#' are comments.+# For a project mostly in C, the following would be a good set of+# exclude patterns (uncomment them if you want to use them):+# *.[oa]+# *~

@@ -0,0 +1,1 @@+0000000000000000000000000000000000000000 e0c77b133b8d689d094f5be16e499d44bbf26f61 Tom Doris <tomdoris@gmail.com> 1291459940 +0000	clone: from git@github.com:tdoris/Rclient.git

@@ -0,0 +1,1 @@+0000000000000000000000000000000000000000 e0c77b133b8d689d094f5be16e499d44bbf26f61 Tom Doris <tomdoris@gmail.com> 1291459940 +0000	clone: from git@github.com:tdoris/Rclient.git

binary file changed (absent → 4572 bytes)

binary file changed (absent → 44325 bytes)

@@ -0,0 +1,2 @@+# pack-refs with: peeled +e0c77b133b8d689d094f5be16e499d44bbf26f61 refs/remotes/origin/master

@@ -0,0 +1,1 @@+e0c77b133b8d689d094f5be16e499d44bbf26f61

@@ -0,0 +1,1 @@+ref: refs/remotes/origin/master

@@ -0,0 +1,6 @@+import Rclient++main :: IO()+main = rRepl++

@@ -0,0 +1,324 @@+{-# LANGUAGE FlexibleInstances,TypeSynonymInstances #-}++-- | This module allows you to issue R commands from Haskell to be executed via Rserve and get the results back in Haskell data types. ++module Network.Rserve.Client +  (RConn(..)+  , Result+  , RserveError+  , ResultUnpack(..)+  , RSEXP(..)+  , connect+  , eval+  , voidEval+  , login+  , shutdown+  , openFile+  , createFile+  , closeFile+  , removeFile+  --, Network.Rserve.Client.readFile+  , Network.Rserve.Client.writeFile+  , assign+  , unpackRArrayInt+  , unpackRArrayBool+  , unpackRArrayDouble+  , unpackRArrayComplex+  , unpackRArrayString+  , unpackRInt+  , unpackRBool+  , unpackRDouble+  , unpackRString+  , unpackRSym+  , unpackRVector+  , unpackRListTag+  , unpackRSEXPWithAttrib+  , rRepl+  ) where ++ -- TODO :+ -- handle authenticated connections to Rserve+ -- support LARGE + -- support readFile (if Rserve fixes their bug omitting DT_BYTESTREAM header, and/or someone asks for readFile)++import Network+import System.IO (hSetBuffering, hFlush, BufferMode(NoBuffering), stdout)+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as BL+import Data.Binary+import Data.Bits+import qualified Data.ByteString.Internal as BI+import Network.Rserve.Constants+import Network.Rserve.Internal ++type RserveError = String++type Result = Either RserveError (Maybe RSEXP)++-- | Connect to Rserve server +connect :: String      -- ^ server name, e.g. "localhost"+           ->Int       -- ^ port, e.g. 6311+           ->IO RConn  -- ^ the connection+connect server port = do +  h <- connectTo server (PortNumber (fromIntegral port))+  hSetBuffering h NoBuffering+  idString <- B.hGet h 12+  a <- B.hGetNonBlocking h 10000+  let (sig, rserveVersion, protocol, attributes) = parseIdString (B.append idString a)+  return RConn {rcHandle=h, rcRserveSig=sig, rcRserveVersion=rserveVersion, rcProtocol=protocol, rcAttributes=attributes}++-- | evaluate an R expression+eval :: RConn -> String -> IO Result+eval rconn = eval' cmdEval rconn . DTString ++-- | evaluate an R expression, discarding any result+voidEval :: RConn -> String -> IO ()+voidEval rconn cmd = do _ <- eval' cmdVoidEval rconn (DTString cmd)+                        return ()++-- | login to Rserve, not normally required, for authenticated sessions only+login :: RConn +      -> String  -- ^ user name+      -> String  -- ^ password +      -> IO Result+login rconn name pwd = eval' cmdLogin rconn (DTString (name ++ "\n" ++ pwd))++-- | shutdown the Rserve server+shutdown :: RConn -> IO()+shutdown rconn = do +  _ <- eval' cmdShutdown rconn (DTString "")+  return ()++-- | open a file+openFile :: RConn -> String -> IO Result+openFile rconn = eval' cmdOpenFile rconn . DTString ++-- | write content to a file accessible to the Rserve session+writeFile :: RConn -> B.ByteString -> IO Result+writeFile rconn = eval' cmdWriteFile rconn . DTBytestream . map BI.c2w . B.unpack ++-- | create a file+createFile :: RConn -> String -> IO Result+createFile rconn = eval' cmdCreateFile rconn . DTString ++-- | close a file+closeFile :: RConn -> String -> IO Result+closeFile rconn = eval' cmdCloseFile rconn . DTString ++-- | remove a file+removeFile :: RConn -> String -> IO Result+removeFile rconn = eval' cmdRemoveFile rconn . DTString ++-- read file, Rserve seems not to have ever fixed the bug whereby the response is omits the DT_BYTESTREAM header, so we have to write custom serialisation for this one function.+-- nobody's expressed a need for it, so leaving it out for now+--readFile :: RConn -> String -> IO QAP1Message+--readFile rconn = undefined++-- | assign a RSEXP value to a symbol+assign :: RConn -> String -> RSEXP -> IO Result+assign rconn symbol = eval' cmdSetSexp rconn . DTAssign symbol ++-- | The ResultUnpack instances are used to extract R data structures from the Result container. +class ResultUnpack a where+  unpack :: Result -> Maybe a++-- | unpack RInt+instance ResultUnpack Int where +  unpack (Right (Just (RInt x))) = Just x+  unpack _ = Nothing++-- | unpack RDouble+instance ResultUnpack Double where+  unpack (Right (Just (RDouble x))) = Just x+  unpack _           = Nothing ++-- | unpack RString, RSym+instance ResultUnpack String where+  unpack (Right (Just (RString x))) = Just x+  unpack (Right (Just (RSym x)))    = Just x+  unpack _           = Nothing++-- | unpack RBool+instance ResultUnpack Bool where+  unpack (Right (Just (RBool x))) = Just x+  unpack _         = Nothing++-- | unpack RArrayInt+instance ResultUnpack [Int] where+  unpack (Right (Just (RArrayInt x))) = Just x+  unpack _ = Nothing++-- | unpack RArrayDouble+instance ResultUnpack [Double] where+  unpack (Right (Just (RArrayDouble x))) = Just x+  unpack _ = Nothing++-- | unpack RArrayString+instance ResultUnpack [String] where+  unpack (Right (Just (RArrayString x))) = Just x+  unpack _ = Nothing++-- | unpack RArrayBool+instance ResultUnpack [Bool] where+  unpack (Right (Just (RArrayBool x))) = Just x+  unpack _ = Nothing++-- | unpack RArrayComplex+instance ResultUnpack [(Double, Double)] where+  unpack (Right (Just (RArrayComplex x))) = Just x+  unpack _ = Nothing++-- | unpack RSEXPWithAttrib+instance ResultUnpack (RSEXP, RSEXP) where+  unpack (Right (Just (RSEXPWithAttrib a v))) = Just (a,v)+  unpack _ = Nothing+-- | unpack RVector+instance ResultUnpack [RSEXP] where+  unpack (Right (Just (RVector v))) = Just v+  unpack _ = Nothing++-- | unpack RListTag+instance ResultUnpack [(RSEXP, RSEXP)] where+  unpack (Right (Just (RListTag l))) = Just l+  unpack _ = Nothing+++unpackDT :: DT -> Maybe RSEXP+unpackDT (DTSexp x) = Just x+unpackDT _          = Nothing++-- | unpack a Result containing an RArrayInt+unpackRArrayInt :: Result -> Maybe [Int]+unpackRArrayInt (Right (Just (RArrayInt is))) = Just is+unpackRArrayInt _ = Nothing++-- | unpack a Result containing an RArrayDouble+unpackRArrayDouble :: Result -> Maybe [Double]+unpackRArrayDouble (Right (Just (RArrayDouble ds))) = Just ds+unpackRArrayDouble _ = Nothing++-- | unpack a Result containing an RArrayComplex+unpackRArrayComplex :: Result -> Maybe [(Double, Double)]+unpackRArrayComplex (Right (Just (RArrayComplex cs))) = Just cs+unpackRArrayComplex _ = Nothing++-- | unpack a Result containing an RArrayString+unpackRArrayString :: Result -> Maybe [String]+unpackRArrayString (Right (Just (RArrayString ss))) = Just ss+unpackRArrayString _ = Nothing++-- | unpack a Result containing an RArrayBool+unpackRArrayBool :: Result -> Maybe [Bool]+unpackRArrayBool (Right (Just (RArrayBool bs))) = Just bs+unpackRArrayBool _ = Nothing++-- | unpack a Result containing an RInt+unpackRInt :: Result -> Maybe Int+unpackRInt (Right (Just (RInt i))) = Just i+unpackRInt _        = Nothing++-- | unpack a Result containing an RDouble+unpackRDouble :: Result -> Maybe Double+unpackRDouble (Right (Just (RDouble d))) = Just d+unpackRDouble _ = Nothing++-- | unpack a Result containing an RString+unpackRString :: Result -> Maybe String+unpackRString (Right (Just (RString s))) = Just s+unpackRString _ = Nothing++-- | unpack a Result containing an RSym+unpackRSym :: Result -> Maybe String+unpackRSym (Right (Just (RSym s))) = Just s+unpackRSym _ = Nothing++-- | unpack a Result containing an RBool+unpackRBool :: Result -> Maybe Bool+unpackRBool (Right (Just (RBool b))) = Just b+unpackRBool _ = Nothing++-- | unpack a Result containing an RVector+unpackRVector :: Result -> Maybe [RSEXP]+unpackRVector (Right (Just (RVector v))) = Just v+unpackRVector _ = Nothing++-- | unpack a Result containing an RListTag+unpackRListTag :: Result -> Maybe [(RSEXP, RSEXP)]+unpackRListTag (Right (Just (RListTag ls))) = Just ls+unpackRListTag _ = Nothing++-- | unpack a Result containing an RSEXPWithAttrib+unpackRSEXPWithAttrib :: Result -> Maybe (RSEXP, RSEXP)+unpackRSEXPWithAttrib (Right (Just (RSEXPWithAttrib attrib value)))=Just (attrib, value)+unpackRSEXPWithAttrib _ = Nothing++eval' :: Word32 -> RConn -> DT -> IO Result +eval' rcmd rconn cmd = do+  let msg = createMessage rcmd (Just cmd)+  response <- request rconn msg+  if responseOK response then return (Right (qap1Content response  >>= unpackDT))+                         else return (Left (getError response))++request :: RConn -> QAP1Message -> IO QAP1Message+request rconn msg = do+  let msgContent = encode msg+--  putStrLn ("request:"++ show (lazyByteStringToString msgContent))+  BL.hPut h msgContent+  header <- BL.hGet h 16+  let rheader = decode header :: QAP1Header+--  putStrLn ("header:"++show (lazyByteStringToString header))+  let bodyLength = fromIntegral(headerLen rheader) :: Int+  body <- if bodyLength > 0 then BL.hGet h bodyLength else return (BL.pack "")+--  putStrLn ("bodylen:"++show bodyLength)+  let content = if bodyLength > 0 then Just (decode body :: DT) else Nothing+--  putStrLn ("body:"++show (lazyByteStringToString body))+  return QAP1Message {qap1Header = rheader, qap1Content = content }+  where h = rcHandle rconn++createMessage :: Word32 -> Maybe DT -> QAP1Message+createMessage cmdId content = QAP1Message (QAP1Header cmdId tlen 0 0) content+  where tlen = fromIntegral contentLength :: Word32+        contentLength = case content of +                          Nothing -> 0+                          Just x -> BL.length (encode x)++{- | Read-evaluate-print-loop for interacting with Rserve session. +in ghci, load this module and run this command to test and play with Rserve+this is useful to check the actual types returned by Rserve, e.g.++$ ghci++Prelude>:m Network.Rserve.Client++Prelude Network.Rserve.Client> rRepl++\>c(1,2,3)++Just (RArrayDouble [1.0,2.0,3.0])++\>summary(rnorm(100))++Just (RSEXPWithAttrib (RListTag [(RArrayString [\"Min.\",\"1st Qu.\",\"Median\",\"Mean\",\"3rd Qu.\",\"Max.\"],RSym \"names\"),(RArrayString [\"table\"],RSym \"class\")]) (RArrayDouble [-2.914,-0.5481,0.1618,0.1491,0.9279,3.001]))+-}+rRepl :: IO()+rRepl = connect "localhost" 6311 >>= rReplLoop+    +rReplLoop :: RConn -> IO()+rReplLoop conn = do+  putStr ">"+  hFlush stdout+  cmd <- getLine+  response <- eval conn cmd+  case response of +    Right x -> print x+    Left x -> print ("Error:"++show x)+  rReplLoop conn++responseOK :: QAP1Message -> Bool+responseOK h = headerCmd (qap1Header h) .&. respOK == respOK++getError :: QAP1Message -> String+getError h = if errmatch == [] then show h ++ " cmd stat:"++ show s else snd (head errmatch)+  where s = cmdStat (headerCmd (qap1Header h))+        errmatch = filter (\(c,_) -> c == s) errorStats+

@@ -0,0 +1,154 @@+module Network.Rserve.Constants where++import Data.Binary+import Data.Bits++cmds :: [(String, Word32)]+cmds = [("login", cmdLogin), ("voidEval", cmdVoidEval), ("eval", cmdEval), ("shutdown", cmdShutdown), +        ("openFile", cmdOpenFile), ("createFile", cmdCreateFile), ("closeFile", cmdCloseFile), +        ("readFile", cmdReadFile), ("writeFile", cmdWriteFile), ("removeFile", cmdRemoveFile), ("setSexp", cmdSetSexp), ("assignSexp", cmdAssignSexp), +        ("detachSession", cmdDetachSession), ("detachedVoidEval", cmdDetachedVoidEval), ("attachSession", cmdAttachSession)]++cmdLogin :: Word32+cmdLogin = 0x0001 +cmdVoidEval :: Word32+cmdVoidEval = 0x0002 +cmdEval :: Word32+cmdEval = 0x0003 +cmdShutdown :: Word32+cmdShutdown = 0x0004+cmdOpenFile :: Word32+cmdOpenFile = 0x0010+cmdCreateFile ::Word32+cmdCreateFile = 0x0011+cmdCloseFile :: Word32+cmdCloseFile = 0x0012+cmdReadFile :: Word32+cmdReadFile = 0x0013+cmdWriteFile :: Word32+cmdWriteFile = 0x0014+cmdRemoveFile ::Word32+cmdRemoveFile = 0x0015+cmdSetSexp :: Word32+cmdSetSexp = 0x0020+cmdAssignSexp :: Word32+cmdAssignSexp = 0x0021+cmdDetachSession :: Word32+cmdDetachSession = 0x0030+cmdDetachedVoidEval :: Word32+cmdDetachedVoidEval = 0x0031+cmdAttachSession :: Word32+cmdAttachSession = 0x0032+cmdResp :: Word32+cmdResp = 0x10000++cmdStat :: Word32 -> Word32+cmdStat x = (x `shiftR` 24) .&. 127++respOK :: Word32+respOK = cmdResp .|. 0x0001+respErr :: Word32+respErr = cmdResp .|. 0x0002++errAuthFailed     :: Word32+errAuthFailed      = 0x41+errConnBroken     :: Word32+errConnBroken      = 0x42+errInvCmd         :: Word32+errInvCmd          = 0x43+errInvPar         :: Word32+errInvPar          = 0x44+errRerror          :: Word32+errRerror           = 0x45+errIOerror         :: Word32+errIOerror          = 0x46+errNotOpen         :: Word32+errNotOpen          = 0x47+errAccessDenied    :: Word32+errAccessDenied     = 0x48+errUnsupportedCmd  :: Word32+errUnsupportedCmd   = 0x49+errDataOverflow   :: Word32+errDataOverflow    = 0x4b +errObjectTooBig  :: Word32+errObjectTooBig   = 0x4c+errOutOfMem      :: Word32+errOutOfMem       = 0x4d+errCtrlClosed     :: Word32+errCtrlClosed      = 0x4e+errSessionBusy    :: Word32+errSessionBusy     = 0x50+errDetachFailed   :: Word32+errDetachFailed    = 0x51+errorStats :: [(Word32, String)]+errorStats = [(errAuthFailed,"errAuthFailed"), (errConnBroken,"errConnBroken"), (errInvCmd,"errInvCmd"), (errInvPar,"errInvPar"),+              (errRerror,"errRerror"), (errIOerror,"errIOerror"), (errNotOpen,"errNotOpen"), (errAccessDenied,"errAccessDenied"),+              (errUnsupportedCmd,"errUnsupportedCmd"), (errDataOverflow,"errDataOverflow"), (errObjectTooBig,"errObjectTooBig"),+              (errOutOfMem,"errOutOfMem"), (errCtrlClosed,"errCtrlClosed"), (errSessionBusy,"errSessionBusy"), (errDetachFailed,"errDetachFailed")]++dtInt       :: Word8+dtInt        = 1  +dtChar      :: Word8+dtChar       = 2  +dtDouble    :: Word8+dtDouble     = 3  +dtString    :: Word8+dtString     = 4  +dtBytestream:: Word8+dtBytestream = 5  +dtSexp      :: Word8+dtSexp       = 10 +dtArray     :: Word8+dtArray      = 11 +dtLarge     :: Word8+dtLarge      = 64 ++++xtNull:: Word8+xtNull = 0 +xtInt:: Word8+xtInt = 1 +xtDouble:: Word8+xtDouble = 2 +xtStr:: Word8+xtStr = 3 +xtLang:: Word8+xtLang = 4 +xtSym:: Word8+xtSym = 5 +xtBool:: Word8+xtBool = 6 +xtS4:: Word8+xtS4 = 7 +xtVector:: Word8+xtVector = 16 +xtList:: Word8+xtList = 17 +xtClos:: Word8+xtClos = 18 +xtSymName:: Word8+xtSymName = 19 +xtListNotag:: Word8+xtListNotag = 20 +xtListTag:: Word8+xtListTag = 21  +xtVectorExp:: Word8+xtVectorExp = 26 +xtVectorStr:: Word8+xtVectorStr = 27+xtArrayInt:: Word8+xtArrayInt = 32+xtArrayDouble:: Word8+xtArrayDouble = 33+xtArrayStr:: Word8+xtArrayStr = 34+xtArrayBool:: Word8+xtArrayBool = 36+xtArrayCplx:: Word8+xtArrayCplx = 38+xtHasAttr:: Word8+xtHasAttr = 128+xtUnknown:: Word8+xtUnknown = 48+

@@ -0,0 +1,296 @@+module Network.Rserve.Internal where++import System.IO+import Data.Bits+import Data.Binary+import Data.Binary.Put+import Data.Binary.Get+import Data.Binary.IEEE754+import Data.Char+import Data.List+import Data.List.Split+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.ByteString.Internal as BI+import Control.Monad+import Network.Rserve.Constants++data Len24 = Len24 Word8 Word8 Word8 deriving Show++instance Binary Len24 where+  put (Len24 l1 l2 l3) = putWord8 l1 >> putWord8 l2 >> putWord8 l3+  get = do l1 <- getWord8+           l2 <- getWord8+           l3 <- getWord8+           return (Len24 l1 l2 l3)++data QAP1Header = QAP1Header { headerCmd::Word32, headerLen ::Word32, headerDof::Word32, headerRes::Word32} deriving Show++data QAP1Message = QAP1Message { qap1Header :: QAP1Header, qap1Content :: Maybe DT } deriving Show++instance Binary QAP1Header where+  put r = putWord32le (headerCmd r) >> putWord32le (headerLen r) >> putWord32le (headerDof r) >> putWord32le (headerRes r)+  get = do c <- getWord32le+           l <- getWord32le+           d <- getWord32le+           r <- getWord32le+           return (QAP1Header c l d r)++instance Binary QAP1Message where+  put m = case qap1Content m of +               Just dt -> put (qap1Header m) >> put dt+               Nothing -> put (qap1Header m)++  get = do header <- get+           content <- get+           return (QAP1Message header content)+++data DT = DTInt Int | DTChar Char | DTDouble Double | DTString String | DTBytestream [Word8] | DTSexp RSEXP | DTAssign String RSEXP+  deriving (Show)++instance Binary DT where+  put (DTInt i) = putWord8 dtInt >> put (to24bit 0) >> putWord32le (fromIntegral i::Word32)+  put (DTChar c) = putWord8 dtChar >> put (to24bit 0)>> putWord8 (BI.c2w c)+  put (DTDouble d) = putWord8 dtDouble >> put (to24bit 0) >> putFloat64le d+  put (DTString s) = putWord8 dtString >> put len24 >> mapM_ put paddedString+                        where len24 = to24bit (length paddedString)+                              paddedString = padRstring s +  put (DTBytestream s)= putWord8 dtBytestream >> put len24 >> mapM_ putWord8 s+                          where len24 = to24bit (length s)+  put (DTSexp s) = putWord8 dtSexp >> put len24 >> put s+                     where len24 = to24bit (fromIntegral (BL.length (encode s))::Int)+  put (DTAssign symbol sexp) = put (DTString symbol) >> put (DTSexp sexp)+  get = do t <- getWord8 +           case fromIntegral t::Int of+              1 -> liftM DTInt get+              2 -> liftM DTChar get+              3 -> liftM DTDouble get+              4 -> do len24 <- get+                      let len = (from24Bit len24) +                      chars <- replicateM len getWord8+                      return (DTString (map BI.w2c chars))+              5 -> do len24 <- get+                      let len = (from24Bit len24)+                      ws <- replicateM len getWord8+                      return (DTBytestream ws)+              10 -> do replicateM_ 3 getWord8+                       liftM DTSexp get+              x -> error ("Unsupported DT id:"++show x)++data RConn = RConn {rcHandle::Handle, rcRserveSig:: String, rcRserveVersion::String, rcProtocol::String, rcAttributes::[String]} deriving (Show)++-- | Representations for the types transmitted on the Rserve protocol, refer to Rserve documentation for details+data RSEXP = +   RNULL+  | RInt Int +  | RDouble Double +  | RString String +  | RSym String +  | RBool Bool +  | RVector [RSEXP] +--  | RList RSEXP RSEXP RSEXP -- head vals tag -- I can't find any evidence that this is ever used in Rserve+  | RClos Word32  -- just store the length +  | RListTag [(RSEXP,RSEXP)]+  | RArrayInt [Int]+  | RArrayDouble [Double]+  | RArrayString [String]+  | RArrayBool [Bool]+  | RArrayComplex [(Double, Double)]+  | RSEXPWithAttrib RSEXP RSEXP+  | RUnknown Word32+  deriving (Show,Eq)++getTypeCode :: RSEXP -> Word8+getTypeCode (RNULL)       = xtNull+getTypeCode (RInt _)        = xtInt+getTypeCode (RDouble _)     = xtDouble+getTypeCode (RString _)     = xtStr+getTypeCode (RSym _)        = xtSym+getTypeCode (RBool _)       = xtBool+getTypeCode (RVector _)     = xtVector+getTypeCode (RClos _)     = xtClos+getTypeCode (RListTag _)    = xtListTag+getTypeCode (RArrayInt _)   = xtArrayInt+getTypeCode (RArrayDouble _)= xtArrayDouble+getTypeCode (RArrayString _)= xtArrayStr+getTypeCode (RArrayBool _)  = xtArrayBool+getTypeCode (RArrayComplex _) = xtArrayCplx+getTypeCode (RSEXPWithAttrib _ v) = xtHasAttr .|. getTypeCode v+getTypeCode (RUnknown _) = xtUnknown ++data RTypeCode = RType Word8 | RTypeAttr Word8 deriving Show++to24bit :: Int -> Len24+to24bit i = Len24 x y z +  where x = fromIntegral(i .&. 0xff)::Word8+        y = fromIntegral((i `shiftR` 8) .&. 0xff)::Word8+        z = fromIntegral((i `shiftR` 16) .&. 0xff)::Word8++from24Bit :: Len24 -> Int+from24Bit (Len24 x y z) = (fromIntegral x::Int) + (fromIntegral y ::Int) `shiftL` 8 + (fromIntegral z ::Int) `shiftL` 16++-- TODO add support for large +getCode :: Word8 -> RTypeCode +getCode t | isLarge = error "LARGE" +          | hasAttribute = RTypeAttr code+          | otherwise = RType code+  where hasAttribute = t .&. 128 == 128 +        isLarge = t .&. 64 == 64+        code =  t .&. 63++instance Binary RSEXP where+  put (RNULL) = putWord8 xtNull >> put (to24bit 0) +  put (RInt i) = putWord8 xtInt >> put (to24bit 4) >> putWord32le (fromIntegral i :: Word32)+  put (RDouble d) = putWord8 xtDouble >> put (to24bit 8) >> putFloat64le d+  put (RBool b) = putWord8 xtBool >> put (to24bit 4) >> putWord8 (if b then 1 else 0) >> replicateM_ 3 (putWord8 0)+  put (RString s) = putWord8 xtStr >> put len24 >> mapM_ (putWord8 . BI.c2w) ps+                    where len24 = to24bit (length ps)+                          ps = padRstring s+  put (RSym s) = putWord8 xtSym >> put len24 >> mapM_ (putWord8 . BI.c2w) ps+                    where len24 = to24bit (length ps)+                          ps = padRstring s+  put (RArrayInt arr) = putWord8 xtArrayInt >> put len24  >> mapM_ (putWord32le . fromIntegral) arr+                              where len24 = to24bit (4* length arr)+  put (RArrayDouble arr) = putWord8 xtArrayDouble >> put len24  >> mapM_ putFloat64le arr+                              where len24 = to24bit (length arr *8)+  put (RArrayBool arr) = putWord8 xtArrayBool >> put len24  >> putWord32le (fromIntegral (length arr) :: Word32) >> mapM_ (putWord8 . (\x -> if x then 1 else 0)) arr >> replicateM_ (gapLen (length arr)) (putWord8 255)+                              where len24 = to24bit (4 + length arr + gapLen (length arr))+                                    +  put (RArrayString ss) = putWord8 xtArrayStr >> put len24 >> mapM_ (putWord8 . BI.c2w) ss'+                             where len24 = to24bit (length ss')+                                   ss' = if length ss > 0  then padRstring (intercalate "\0" ss) else [] +  put (RListTag lt) = putWord8 xtListTag >> put len24 >> mapM_ put lt+                         where len24 = to24bit (sum (map encodedLength rsexps))+                               rsexps = detuple lt+  put (RClos v) = putWord8 xtClos >> put (to24bit 4) >> putWord32le v +--  put (RList h vals tag) = putWord8 xtList >> put len24 >> put h >> put vals >> put tag+--                     where len24 = to24bit (encodedLength h + encodedLength vals + encodedLength tag)+  put (RVector v) = putWord8 xtVector  >> put len24 >> mapM_ put v+                       where len24 = to24bit (sum (map encodedLength v))+-- The way Rserve serialises this isn't great, the val header is munged into the header for the entire object and the id bitwised ored with 128 +-- which also means it's impossible to serialise an RSEXPWithAttrib which has an RSEXPWithAttrib as a value+  put (RSEXPWithAttrib attrib val) = putWord8 (fromIntegral code) >> put len24 >> put attrib >> mapM_ (putWord8 . BI.c2w) (BL.unpack (BL.drop 4 (encode val)))+                                   where code = getTypeCode val .|. xtHasAttr +                                         len24 = to24bit (encodedLength attrib + encodedLength val - 4) +  put (RArrayComplex cs) = putWord8 xtArrayCplx >> put len24 >> mapM_ putFloat64le (detuple cs)+                           where len24 = to24bit (16 * length cs)+  put (RUnknown v) = putWord8 xtUnknown >> put (to24bit 4) >> putWord32le v+  get = do t <- getWord8 +           len24 <- get+           let len = from24Bit len24+           let typeCode = getCode t+           case typeCode of +                 (RTypeAttr x) -> do attrib <- get+                                     let remainingLen = len - encodedLength attrib+                                     val <- getRType (RType x) remainingLen+                                     return (RSEXPWithAttrib attrib val)+                 (RType _) -> getRType typeCode len++getRType :: RTypeCode -> Int -> Get RSEXP+getRType typeCode len = +          case typeCode of+                 (RType 0)  -> return RNULL+                 (RType 1)  -> do e <- getWord32le+                                  return (RInt (fromIntegral e))+                 (RType 2)  -> do e <- getFloat64le+                                  return (RDouble e)+                 (RType 3)  -> do chars <- replicateM len getWord8+                                  return (RString (depadRstring (map BI.w2c chars)))+                 (RType 5)  -> do chars <- replicateM len getWord8+                                  return (RSym (depadRstring (map BI.w2c chars)))+                 (RType 6)  -> do b <- getWord32le -- this may be a byte in the spec but it's always padded+                                  return (RBool (b == 1))  -- 1=TRUE, 0=FALSE, 2=NA+                 (RType 16) -> getVector len+                 (RType 18) -> do v <- getWord32le+                                  return (RClos v )+                 (RType 19) -> do chars <- replicateM len getWord8+                                  return (RSym (depadRstring (map BI.w2c chars)))+                 (RType 21) -> getListTag len+                 (RType 22) -> getVector len+                 (RType 23) -> getListTag len+                 (RType 26) -> getVector len+                 (RType 32) -> do ints <- replicateM (len `div` 4) getWord32le+                                  return (RArrayInt (map fromIntegral ints))+                 (RType 33) -> do doubles <- replicateM (len `div` 8) getFloat64le+                                  return (RArrayDouble doubles)+                 (RType 34) -> do stringsBytes <- replicateM len getWord8+                                  let strings = vectorStringDecode (map BI.w2c stringsBytes)+                                  return (RArrayString strings)+                 (RType 36) -> do boolCount <-getWord32le+                                  bools <- replicateM (fromIntegral boolCount::Int) getWord8+                                  replicateM_ (len - 4 - fromIntegral boolCount::Int) getWord8+                                  return (RArrayBool (map (==1) bools))+                 (RType 38) -> do doubles <- replicateM (len `div` 8) getFloat64le+                                  return (RArrayComplex (pairs doubles))+                 (RType 48) -> do v <- getWord32le+                                  return (RUnknown v)+                 (RType x) ->  do br <- bytesRead+                                  error ("unsuppported type code:" ++ show x ++ " bytes read:"++show br)+                 _  -> error ("unsuppported RSEXP type code:"++show typeCode)++getVector :: Int -> Get RSEXP+getVector len = do rsexpsBytes <- replicateM len getWord8+                   let rsexps = vectorRSEXPDecode rsexpsBytes+                   return (RVector rsexps)+                                                                     +getListTag :: Int -> Get RSEXP+getListTag len = do listTagBytes <- replicateM len getWord8+                    let taglist = listTagDecode listTagBytes+                    return (RListTag taglist)++vectorRSEXPDecode :: [Word8] -> [RSEXP]+vectorRSEXPDecode [] = []+vectorRSEXPDecode ws@(_:l1:l2:l3:rws) = if encodingOK then val : vectorRSEXPDecode (drop (from24Bit (Len24 l1 l2 l3)) rws) +                                                      else error ("Encoding error in val:"++show val)+  where content = BL.pack (map BI.w2c ws)+        val = decode content+        encodingOK = encodedLength val == from24Bit (Len24 l1 l2 l3) + 4+vectorRSEXPDecode _ = error "vectorRSEXPDecode: trailing bytes"++-- the serialisation code uses this function anywhere it needs to figure out how much it has written/read by encoding the RSEXP and getting the length +-- obviously this could be a disaster for performance as we're encoding many times for each serialisation+encodedLength :: RSEXP -> Int+encodedLength s = if l `mod` 4 == 0 then l else error ("Encoded length not a multiple of 4" ++ show s)+  where l = fromIntegral(BL.length (encode s))::Int++vectorStringDecode :: String -> [String]+vectorStringDecode = init . splitOn "\0" ++padRstring :: String -> String+padRstring s = padded+  where padded = nullTerminated ++ replicate (gapLen r) '\1'+        nullTerminated = s ++ "\0"+        r = length nullTerminated++gapLen :: Int -> Int+gapLen r = if gap == 0 then 0 else 4 - gap +  where gap = rem r 4++depadRstring :: String -> String+depadRstring = takeWhile (/= '\0') ++pairs :: [a] -> [(a,a)]+pairs [] = []+pairs [_] = []+pairs (x:y:xs) = (x,y) : pairs xs++detuple :: [(a,a)] -> [a]+detuple [] =[]+detuple ((x,y):xs) = x:y: detuple xs++listTagDecode :: [Word8] -> [(RSEXP,RSEXP)]+listTagDecode [] = []+listTagDecode ws = pairs $ vectorRSEXPDecode ws++parseIdString :: B.ByteString -> (String, String, String, [String])+parseIdString b = (sig, h, r, attributes)+  where [sig,h,r] = map B.unpack [(B.take 4 b), (B.take 4 (B.drop 4 b)), (B.take 4 (B.drop 8 b))]+        attributes  = parseAttributes (B.drop 12 b)++parseAttributes :: B.ByteString -> [String]+parseAttributes = filter (=="") . map B.unpack . B.lines ++lazyByteStringToString :: BL.ByteString->String+lazyByteStringToString = show . map ord . BL.unpack +

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,90 @@+import Network.Rserve.Client+import Test.QuickCheck+import Text.Printf+import Data.Maybe+import Data.List+import Data.Binary+import qualified Data.ByteString.Lazy.Char8 as BL+import Control.Monad++normalCharacters = ['A'..'Z'] ++ ['a' .. 'z'] ++ " ~!@#$%^&*()"++--TODO arbitrary RSEXPs are likely to be enormous, limit nesting depth somehow+instance Arbitrary RSEXP where+  arbitrary = oneof [ return RNULL+                    , liftM RInt arbitrary+                    , liftM RDouble arbitrary+                    , liftM RString arbitraryNonemptyString+                    , liftM RSym arbitraryNonemptyString+                    , liftM RBool arbitrary+                    , liftM RVector (listOf primitiveRSEXP)+                    , liftM RClos arbitrary+                    , liftM RListTag primitiveTagList -- TODO this can generate large recursive structures+                    , liftM RArrayInt arbitrary+                    , liftM RArrayDouble arbitrary+                    , liftM RArrayString (listOf arbitraryNonemptyString)+                    , liftM RArrayBool arbitrary+                    , liftM RArrayComplex arbitrary+                    , liftM2 RSEXPWithAttrib arbitrary nonRSEXPWithAttrib -- TODO, can't have a val that is an RSEXPWithAttrib limit recursion here+                    , liftM RUnknown arbitrary+                    , liftM RString arbitraryNonemptyString +                    ]++arbitraryNonemptyString :: Gen String+arbitraryNonemptyString = do +  x <- arbitrary+  let x' = filter (\c -> c `elem` normalCharacters) x+  let s = if x' == "" then "empt" else x'+  return s++nonRSEXPWithAttrib :: Gen RSEXP+nonRSEXPWithAttrib = do+              oneof [ return RNULL+                    , liftM RInt arbitrary+                    , liftM RDouble arbitrary+                    , liftM RString arbitraryNonemptyString+                    , liftM RSym arbitraryNonemptyString+                    , liftM RBool arbitrary+                    , liftM RVector arbitrary+                    , liftM RClos arbitrary+                    , liftM RListTag arbitrary  -- TODO this can generate large recursive structures+                    , liftM RArrayInt arbitrary+                    , liftM RArrayDouble arbitrary+                    , liftM RArrayString (listOf arbitraryNonemptyString)+                    , liftM RArrayBool arbitrary+                    , liftM RArrayComplex arbitrary+                    , liftM RUnknown arbitrary+                    , liftM RString arbitraryNonemptyString +                    ]+primitiveTagList :: Gen [(RSEXP, RSEXP)]+primitiveTagList = do liftM2 zip (listOf primitiveRSEXP) (listOf primitiveRSEXP)++primitiveRSEXP :: Gen RSEXP+primitiveRSEXP = do+              oneof [ return RNULL+                    , liftM RInt arbitrary+                    , liftM RDouble arbitrary+                    , liftM RString arbitraryNonemptyString+                    , liftM RSym arbitraryNonemptyString+                    , liftM RBool arbitrary+                    , liftM RArrayInt arbitrary+                    , liftM RArrayDouble arbitrary+                    , liftM RArrayString (listOf arbitraryNonemptyString)+                    , liftM RArrayBool arbitrary+                    , liftM RArrayComplex arbitrary+                    , liftM RUnknown arbitrary+                    , liftM RString arbitraryNonemptyString +                    ]+propEncodeDecodeIdentity :: RSEXP -> Bool+propEncodeDecodeIdentity r = (decode (encode r)) == r++propEncodedLength ::RSEXP -> Bool+propEncodedLength r = BL.length (encode r) `mod` 4 == 0++tests = [("encodeDecodeIdentity", quickCheck propEncodeDecodeIdentity),+         ("encodedLength", quickCheck propEncodedLength)+        ]++main = do --sample arbitraryNonemptyString+          mapM_ (\(s,a) -> printf "%-25s: " s >> a) tests+

@@ -0,0 +1,26 @@+import qualified Network.Rserve.Client as R+import qualified Data.ByteString.Char8 as B+import Data.Binary++main :: IO ()+main = do +  rc <- R.connect "localhost" 6311+  print ("Rserve version:"++R.rcRserveVersion rc)+  m <- R.eval rc "rnorm(10)" +  print (R.unpack m :: Maybe [Double])+  m1 <- R.assign rc "a" (R.RArrayDouble [1.0,201])+  m2 <- R.eval rc "a"+  print m2+  fileStuff rc++fileStuff :: R.RConn -> IO()+fileStuff rconn = do +  r <- R.createFile rconn fileName +  r2 <- R.writeFile rconn (B.pack "a,b\n1,2\n8,4")+  r4 <- R.closeFile rconn fileName+  r5 <- R.openFile rconn fileName+  r6 <- R.eval rconn ("x <- read.csv(\""++fileName++"\", header=TRUE)")+  r7 <- R.eval rconn "mean(x$a)"+  r8 <- R.removeFile rconn fileName+  print (R.unpackRArrayDouble r7)+    where fileName = "/tmp/rserve_tmp.csv"

@@ -0,0 +1,32 @@+name:                rclient+version:             0.1.0.0+synopsis:            Haskell client for Rserve+description:         This module allows you to issue R commands from Haskell to be executed via Rserve and get the results back in Haskell data types.+category:            Statistics,Math,Network+license:             BSD3+license-file:        LICENSE+author:              TomDoris <tomdoris@gmail.com>+maintainer:          TomDoris <tomdoris@gmail.com>+build-type:          Simple+cabal-version:  >= 1.2++library+  exposed-modules:+    Network.Rserve.Client+  other-modules:+    Network.Rserve.Internal+    Network.Rserve.Constants+  build-depends:     base >= 3.0 && < 5,+                     network >= 2.3,+                     binary >= 0.4.2,+                     bytestring,+                     QuickCheck >= 2.4,+                     split >= 0.1,+                     data-binary-ieee754 >= 0.4+  if impl(ghc >= 6.10) +        build-depends: +              base >= 4 +  if impl(ghc >= 6.8)+        ghc-options: -fwarn-tabs+  ghc-options:         -Wall -O2+