rethinkdb 1.15.2.1 → 1.16.0.0

raw patch · 13 files changed

+370/−83 lines, 13 filesdep +attoparsecdep ~basedep ~textnew-component:exe:proto2hsPVP ok

version bump matches the API change (PVP)

Dependencies added: attoparsec

Dependency ranges changed: base, text

API changes (from Hackage documentation)

Files

• Database/RethinkDB.hs +27/−18
• Database/RethinkDB/Doctest.hs +30/−0
• Database/RethinkDB/Functions.hs +108/−28
• Database/RethinkDB/Geospatial.hs +2/−2
• Database/RethinkDB/MapReduce.hs +2/−2
• Database/RethinkDB/Network.hs +20/−13
• Database/RethinkDB/NoClash.hs +1/−1
• Database/RethinkDB/ReQL.hs +32/−4
• Database/RethinkDB/Wire/Response.hs +3/−1
• Database/RethinkDB/Wire/Term.hs +23/−9
• bench/Bench.hs +0/−2
• proto2hs.hs +112/−0
• rethinkdb.cabal +10/−3

@@ -1,4 +1,4 @@--- | Haskell client driver for RethinkDB +-- | Haskell client driver for RethinkDB -- -- Based upon the official Javascript, Python and Ruby API: <http://www.rethinkdb.com/api/> --@@ -9,7 +9,7 @@ -- > import qualified Database.RethinkDB.NoClash  module Database.RethinkDB (-  +   -- * Accessing RethinkDB    connect,@@ -26,12 +26,12 @@   ErrorCode(..),   Response,   Result(..),-  +   -- * Cursors-  +   next, collect, collect', each,   Cursor,-  +   -- * Manipulating databases    Database(..),@@ -70,7 +70,8 @@    -- * Transformations -  map, withFields, concatMap,+  map, zipWith, zipWithN,+  withFields, concatMap,   orderBy, asc, desc,   skip, limit, slice,   indexesOf, isEmpty, union, sample,@@ -96,15 +97,15 @@   setInsert, setUnion, setIntersection, setDifference,   (!), (!?),   hasFields,-  insertAt, spliceAt, deleteAt, changeAt, keys,  +  insertAt, spliceAt, deleteAt, changeAt, keys,   literal, remove,   Attribute(..),    -- * String manipulation-  +   match, upcase, downcase,   split, splitOn, splitMax,-  +   -- * Math and logic    (+), (-), (*), (/), mod,@@ -112,26 +113,28 @@   (==), (/=), (>), (>=), (<), (<=),   not,   random, randomTo, randomFromTo,-  +   -- * Dates and times-  +   now, time, epochTime, iso8601, inTimezone, during,   timezone, date, timeOfDay, year, month, day, dayOfWeek,   dayOfYear, hours, minutes, seconds,   toIso8601, toEpochTime,-  +   -- * Control structures -  args, apply, js, branch, forEach, error,+  args, apply, js, branch, forEach,+  range, rangeFromTo, rangeAll,+  error,   handle, Expr(..), coerceTo,   asArray, asString, asNumber, asObject, asBool,-  typeOf, info, json, uuid,+  typeOf, info, json, toJSON, uuid,   http,   HttpOptions(..), HttpResultFormat(..),   HttpMethod(..), PaginationStrategy(..),-  +   -- * Geospatial commands-  +   circle, distance, fill, geoJSON,   toGeoJSON, getIntersecting,   getNearest, includes, intersects,@@ -139,12 +142,18 @@   LonLat(..), Line, Polygon,   maxResults, maxDist, unit, numVertices,   Unit(..),-  ++  -- * Administration++  config, rebalance, reconfigure,+  status, wait,++   -- * Helpers    ex, str, num, (#), note, empty,   def-  +   ) where  import Prelude ()

@@ -0,0 +1,30 @@+{-# LANGUAGE OverloadedStrings #-}++module Database.RethinkDB.Doctest (+  module Export,+  module Database.RethinkDB.Doctest+) where++-- default (Datum, ReQL, String, Int, Double)+-- import qualified Database.RethinkDB as R++import Database.RethinkDB.NoClash as Export+import Prelude as Export+import Data.Text as Export (Text)+import Data.Maybe as Export++import Control.Exception+import qualified Data.Vector as V+import Data.List (sort)++try' :: IO a -> IO ()+try' x = (try x `asTypeOf` return (Left (undefined :: SomeException))) >> return ()++doctestConnect :: IO RethinkDBHandle+doctestConnect = fmap (use "doctests") $ connect "localhost" 28015 def++sorted :: IO Datum -> IO Datum+sorted m = fmap s m where+  s (Array a) = Array $ fmap s $ V.fromList $ sort $ V.toList a+  s (Object o) = Object $ fmap s o+  s d = d

@@ -35,19 +35,11 @@ -- -- Get the doctests ready ----- >>> :load Database.RethinkDB.NoClash+-- >>> :load Database.RethinkDB.Doctest -- >>> import qualified Database.RethinkDB as R--- >>> default (Datum, ReQL, String, Int, Double)--- >>> import Prelude--- >>> import Data.Text (Text)--- >>> import Data.Maybe--- >>> import Control.Exception--- >>> import Database.RethinkDB.Functions ()--- >>> import Database.RethinkDB ()--- >>> import Data.List (sort) -- >>> :set -XOverloadedStrings--- >>> let try' x = (try x `asTypeOf` return (Left (undefined :: SomeException))) >> return ()--- >>> h <- fmap (use "doctests") $ connect "localhost" 28015 def+-- >>> default (Datum, ReQL, String, Int, Double)+-- >>> h <- doctestConnect   -- $init_doctests -- >>> try' $ run' h $ dbCreate "doctests"@@ -58,6 +50,8 @@ -- >>> try' $ run' h $ tableDrop "bar" -- >>> try' $ run' h $ tableCreate (table "posts") -- >>> try' $ run' h $ delete $ table "posts"+-- >>> try' $ run' h $ tableCreate (table "places")+-- >>> try' $ run' h $ delete $ table "places" -- >>> try' $ run' h $ tableCreate (table "users"){ tablePrimaryKey = Just "name" } -- >>> try' $ run' h $ delete $ table "users" -- >>> try' $ run' h $ table "users" # indexDrop "occupation"@@ -120,7 +114,7 @@ -- >>> run h $ forEach (table "users") (\user -> table "users" # get (user!"name") # ex update [nonAtomic] (const ["post_count" := R.count (table "posts" # R.filter (\post -> post!"author" R.== user!"name"))])) :: IO WriteResponse -- {replaced:2} forEach :: (Expr s, Expr a) => s -> (ReQL -> a) -> ReQL-forEach s f = op FOREACH (s, expr P.. f)+forEach s f = op FOR_EACH (s, expr P.. f)  -- | A table --@@ -132,7 +126,7 @@ -- | Drop a table -- -- >>> run' h $ tableDrop (table "foo")--- {"dropped":1}+-- {"config_changes":[{"new_val":null,"old_val":{"primary_key":"id","write_acks":"majority","durability":"hard","name":"foo","shards":...,"id":...,"db":"doctests"}}],"tables_dropped":1} tableDrop :: Table -> ReQL tableDrop (Table mdb table_name _) =   withQuerySettings $ \QuerySettings{ queryDefaultDatabase = ddb } ->@@ -311,26 +305,26 @@ -- >>> run h $ concatMap id [[1, 2], [3], [4, 5]] -- [1,2,3,4,5] concatMap :: (Expr a, Expr b) => (ReQL -> b) -> a -> ReQL-concatMap f e = op CONCATMAP (e, expr P.. f)+concatMap f e = op CONCAT_MAP (e, expr P.. f)  -- | SQL-like inner join of two sequences ----- >>> run' h $ innerJoin (\user post -> user!"name" R.== post!"author") (table "users") (table "posts") # R.zip # orderBy [asc "id"] # pluck ["name", "message"]--- [{"name":"bill","message":"hi"},{"name":"bill","message":"hello"}]+-- >>> sorted $ run' h $ innerJoin (\user post -> user!"name" R.== post!"author") (table "users") (table "posts") # R.zip # orderBy [asc "id"] # pluck ["name", "message"]+-- [{"name":"bill","message":"hello"},{"name":"bill","message":"hi"}] innerJoin :: (Expr a, Expr b, Expr c) => (ReQL -> ReQL -> c) -> a -> b -> ReQL innerJoin f a b = op INNER_JOIN (a, b, fmap expr P.. f)  -- | SQL-like outer join of two sequences ----- >>> run' h $ outerJoin (\user post -> user!"name" R.== post!"author") (table "users") (table "posts") # R.zip # orderBy [asc "id", asc "name"] # pluck ["name", "message"]--- [{"name":"nancy"},{"name":"bill","message":"hi"},{"name":"bill","message":"hello"}]+-- >>> sorted $ run' h $ outerJoin (\user post -> user!"name" R.== post!"author") (table "users") (table "posts") # R.zip # orderBy [asc "id", asc "name"] # pluck ["name", "message"]+-- [{"name":"bill","message":"hello"},{"name":"bill","message":"hi"},{"name":"nancy"}] outerJoin :: (Expr a, Expr b, Expr c) => (ReQL -> ReQL -> c) -> a -> b -> ReQL outerJoin f a b = op OUTER_JOIN (a, b, fmap expr P.. f)  -- | An efficient inner_join that uses a key for the left table and an index for the right table. ----- >>> run' h $ table "posts" # eqJoin "author" (table "users") "name" # R.zip # orderBy [asc "id"] # pluck ["name", "message"]--- [{"name":"bill","message":"hi"},{"name":"bill","message":"hello"}]+-- >>> sorted $ run' h $ table "posts" # eqJoin "author" (table "users") "name" # R.zip # orderBy [asc "id"] # pluck ["name", "message"]+-- [{"name":"bill","message":"hello"},{"name":"bill","message":"hi"}] eqJoin :: (Expr fun, Expr right, Expr left) => fun -> right -> Index -> left -> ReQL eqJoin key right (Index idx) left = op' EQ_JOIN (left, key, right) ["index" := idx] eqJoin key right PrimaryKey left = op EQ_JOIN (left, key, right)@@ -392,7 +386,7 @@ -- >>> run' h $ table "users" # ex orderBy ["index":="name"] [] # pluck ["name"] -- [{"name":"bill"},{"name":"nancy"}] orderBy :: (Expr s) => [ReQL] -> s -> ReQL-orderBy o s = op ORDERBY (expr s : P.map expr o)+orderBy o s = op ORDER_BY (expr s : P.map expr o)  -- | Ascending order asc :: ReQL -> ReQL@@ -404,7 +398,7 @@  -- | Turn a grouping function and a reduction function into a grouped map reduce operation ----- >>> run' h $ table "posts" # group (!"author") (reduce (\a b -> a + "\n" + b) . R.map (!"message"))+-- >>> run' h $ table "posts" # orderBy [asc "id"] # group (!"author") (reduce (\a b -> a + "\n" + b) . R.map (!"message")) -- [{"group":"bill","reduction":"hi\nhello"},{"group":"bob","reduction":"lorem ipsum"}] -- >>> run' h $ table "users" # group ((!0) . splitOn "" . (!"name")) (\users -> let pc = users!"post_count" in [avg pc, R.sum pc]) -- [{"group":"b","reduction":[2,2]},{"group":"n","reduction":[0,0]}]@@ -525,7 +519,7 @@ -- 3.141592653589793 -- >>> let r_sin x = js "Math.sin" `apply` [x] -- >>> run h $ R.map r_sin [pi, pi/2]--- [1.2246063538223773e-16,1]+-- [1.2246...,1] js :: ReQL -> ReQL js s = op JAVASCRIPT [s] @@ -547,21 +541,21 @@ -- | Create a Database reference -- -- >>> run' h $ db "test" # info--- {"name":"test","type":"DB"}+-- {"name":"test","id":...,"type":"DB"} db :: Text -> Database db = Database  -- | Create a database on the server -- -- >>> run' h $ dbCreate "dev"--- {"created":1}+-- {"config_changes":[{"new_val":{"name":"dev","id":...},"old_val":null}],"dbs_created":1} dbCreate :: P.String -> ReQL dbCreate db_name = op DB_CREATE [str db_name]  -- | Drop a database -- -- >>> run' h $ dbDrop (db "dev")--- {"dropped":1}+-- {"config_changes":[{"new_val":null,"old_val":{"name":"dev","id":...}}],"tables_dropped":0,"dbs_dropped":1} dbDrop :: Database -> ReQL dbDrop (Database name) = op DB_DROP [name] @@ -818,12 +812,12 @@ -- >>> run h $ typeOf 1 -- "NUMBER" typeOf :: Expr a => a -> ReQL-typeOf a = op TYPEOF [a]+typeOf a = op TYPE_OF [a]  -- | Get information on a given expression. Useful for tables and databases. -- -- >>> run h $ info $ table "users"--- {"primary_key":"name","name":"users","indexes":["friends","location"],"type":"TABLE","db":{"name":"doctests","type":"DB"}}+-- {"primary_key":"name","doc_count_estimates":...,"name":"users","id":...,"indexes":["friends","location"],"type":"TABLE","db":{"name":"doctests","id":...,"type":"DB"}} info :: Expr a => a -> ReQL info a = op INFO [a] @@ -1033,5 +1027,91 @@ conflict :: ConflictResolution -> Attribute a conflict cr = "conflict" := cr +-- | Generate a UUID+--+-- >>> run h uuid+-- "...-...-...-..." uuid :: ReQL uuid = op UUID ()++-- * New in 1.16++-- | Generate numbers starting from 0+--+-- >>> run h $ range 10+-- [0,1,2,3,4,5,6,7,8,9]+range :: ReQL -> ReQL+range n = op RANGE [n]++-- | Generate numbers within a range+--+-- >>> run h $ rangeFromTo 2 4+-- [2,3]+rangeFromTo :: ReQL -> ReQL -> ReQL+rangeFromTo a b = op RANGE (a, b)++-- | Generate numbers starting from 0+--+-- >>> run' h $ rangeAll # limit 4+-- [0,1,2,3]+rangeAll :: ReQL+rangeAll = op RANGE ()++-- | Wait for tables to be ready+--+-- >>> run h $ table "users" # wait+-- {"ready":1,"status_changes":[{"new_val":{"status":{"all_replicas_ready":true,"ready_for_outdated_reads":true,"ready_for_writes":true,"ready_for_reads":true},"name":"users","shards":...,"id":...,"db":"doctests"},"old_val":...}]}+wait :: Expr table => table -> ReQL+wait t = op WAIT [t]++-- | Convert an object or value to a JSON string+--+-- >>> run h $ toJSON "a"+-- "\"a\""+toJSON :: Expr a => a -> ReQL+toJSON a = op TO_JSON_STRING [a]++-- | Map over two sequences+--+-- >>> run h $ zipWith (+) [1,2] [3,4]+-- [4,6]+zipWith :: (Expr left, Expr right, Expr b)+        => (ReQL -> ReQL -> b) -> left -> right -> ReQL+zipWith f a b = op MAP (a, b, \x y -> expr (f x y))++-- | Map over multiple sequences+--+-- >>> run' h $ zipWithN (\a b c -> expr $ a + b * c) [[1,2],[3,4],[5,6]]+-- [16,26]+zipWithN :: (Arr a, Expr f)+         => f -> a -> ReQL+zipWithN f s = op MAP $ arr s <> arr [f]++-- | Change a table's configuration+--+-- >>> run h $ table "users" # reconfigure 2 1+-- {"config_changes":[{"new_val":{"primary_key":"name","write_acks":"majority","durability":"hard","name":"users","shards":...,"id":...,"db":"doctests"},"old_val":...}],"reconfigured":1,"status_changes":[{"new_val":{"status":{"all_replicas_ready":...,"ready_for_outdated_reads":...,"ready_for_writes":...,"ready_for_reads":...},"name":"users","shards":...,"id":...,"db":"doctests"},"old_val":...}]}+reconfigure :: (Expr table, Expr replicas)+            => ReQL -> replicas -> table -> ReQL+reconfigure shards replicas t = op' RECONFIGURE [t] ["shards" := shards, "replicas" := replicas]++-- | Rebalance a table's shards+--+-- >>> run h $ table "users" # rebalance+-- {"rebalanced":1,"status_changes":[{"new_val":{"status":{"all_replicas_ready":...,"ready_for_outdated_reads":...,"ready_for_writes":...,"ready_for_reads":...},"name":"users","shards":...,"id":...,"db":"doctests"},"old_val":...}]}+rebalance :: Expr table => table -> ReQL+rebalance t = op REBALANCE [t]++-- | Get the config for a table or database+--+-- >>> run h $ table "users" # config+-- {"primary_key":"name","write_acks":"majority","durability":"hard","name":"users","shards":...,"id":...,"db":"doctests"}+config :: Expr table => table -> ReQL+config t = op CONFIG [t]++-- | Get the status of a table+--+-- >>> run h $ table "users" # status+-- {"status":{"all_replicas_ready":true,"ready_for_outdated_reads":true,"ready_for_writes":true,"ready_for_reads":true},"name":"users","shards":...,"id":...,"db":"doctests"}+status :: Expr table => table -> ReQL+status t = op STATUS [t]

@@ -120,9 +120,9 @@  -- | Distance between a point and another geometry object ----- >>> run' h $ distance (point (-73) 40) (point (-122) 37)+-- > run' h $ distance (point (-73) 40) (point (-122) 37) -- 4233453.467303546--- >>> run' h $ ex distance [unit Mile] (point (-73) 40) (point (-122) 37)+-- > run' h $ ex distance [unit Mile] (point (-73) 40) (point (-122) 37) -- 2630.5460282596796 distance :: (Expr a, Expr b) => a -> b -> ReQL distance a b = op DISTANCE (a,b)

@@ -243,7 +243,7 @@     Just . MapFun $ \s -> op' WITHOUT (s : map wrap ks) [noRecurse] mapMRF MERGE [b] [] =   Just . MapFun $ \s -> op' MERGE [s,  wrap b] [noRecurse]-mapMRF CONCATMAP [f] [] = Just . ConcatMapFun $ toFun1 f+mapMRF CONCAT_MAP [f] [] = Just . ConcatMapFun $ toFun1 f mapMRF FILTER [f] [] =   Just . ConcatMapFun $ \x -> branch (toFun1 f x # handle (const False)) x () mapMRF FILTER [f] [TermAttribute "default" defval] =@@ -344,7 +344,7 @@   args' <- sequence $ map extractOne args   optargvs' <- sequence $ map extractOne (map snd optargs)   let optargks = map fst optargs-  return $ \v -> op' tt (map ($ v) args') (zipWith (:=) optargks $ map ($ v) optargvs')+  return $ \v -> op' tt (map ($ v) args') (Prelude.zipWith (:=) optargks $ map ($ v) optargvs')     where       extractOne chain = either (return . const) go $ chainToMRF chain       

@@ -28,10 +28,10 @@ import Data.Typeable (Typeable) import Network (HostName) import Network.Socket (-  socket, Family(AF_INET), SocketType(Stream), sClose, SockAddr(SockAddrInet), setSocketOption, SocketOption(NoDelay),-  Socket)+  socket, Family(AF_INET, AF_INET6), SocketType(Stream), sClose, setSocketOption, SocketOption(NoDelay),+  Socket, AddrInfo(AddrInfo, addrAddress, addrFamily)) import qualified Network.Socket as Socket-import Network.BSD (getProtocolNumber, getHostByName, hostAddress)+import Network.BSD (getProtocolNumber) import Network.Socket.ByteString.Lazy (sendAll) import Network.Socket.ByteString (recv) import Data.ByteString.Lazy (ByteString)@@ -42,7 +42,7 @@   writeChan, MVar, Chan, modifyMVar, takeMVar, forkIO, readChan,   myThreadId, newMVar, ThreadId, newChan, killThread,   newEmptyMVar, putMVar, mkWeakMVar)-import Control.Exception (catch, Exception, throwIO, SomeException(..))+import Control.Exception (catch, Exception, throwIO, SomeException(..), bracketOnError) import Data.IORef (IORef, newIORef, atomicModifyIORef', readIORef, writeIORef) import Data.Map (Map) import qualified Data.Map as M@@ -52,9 +52,8 @@ import System.Mem.Weak (finalize) import Data.Binary.Get (runGet, getWord32le, getWord64le) import Data.Binary.Put (runPut, putWord32le, putWord64le, putLazyByteString)-import Data.Word (Word64, Word32, Word16)+import Data.Word (Word64, Word32) import qualified Data.HashMap.Strict as HM-import Control.Exception (bracketOnError)  import Database.RethinkDB.Wire import Database.RethinkDB.Wire.Response@@ -109,26 +108,33 @@   deriving (Show, Typeable) instance Exception RethinkDBConnectionError -connectTo :: HostName -> Word16 -> IO Socket+getAddrFamily :: AddrInfo -> Family+getAddrFamily addrInfo = case addrInfo of+    AddrInfo { addrFamily = AF_INET6 } -> AF_INET6+    _                                  -> AF_INET++connectTo :: HostName -> Integer -> IO Socket connectTo host port = do+  h <- Socket.getAddrInfo Nothing (Just host) (Just $ show port)+  let addrI = head h+  let addrF = getAddrFamily addrI   proto <- getProtocolNumber "tcp"-  bracketOnError (socket AF_INET Stream proto) sClose $ \sock -> do-    -- TODO: ipv6-    he <- getHostByName host-    Socket.connect sock (SockAddrInet (fromIntegral port) (hostAddress he))+  bracketOnError (socket addrF Stream proto) sClose $ \sock -> do+    Socket.connect sock (addrAddress addrI)     setSocketOption sock NoDelay 1     return sock  -- | Create a new connection to the database server ----- /Example:/ connect using the default port with no passphrase+-- /Example:/ connect using the default port with no passphrase (/note:/ IPv4 and IPv6 supported) -- -- >>> h <- connect "localhost" 28015 Nothing+-- >>> h <- connect "::1" 28015 Nothing  connect :: HostName -> Integer -> Maybe String -> IO RethinkDBHandle connect host port mauth = do   let auth = B.fromChunks . return . BS.fromString $ fromMaybe "" mauth-  s <- connectTo host (fromInteger port)+  s <- connectTo host port   sendAll s $ runPut $ do     putWord32le magicNumber     putWord32le (fromIntegral $ B.length auth)@@ -258,6 +264,7 @@   Just SUCCESS_ATOM -> ResponseSingle <!< atom   Just SUCCESS_PARTIAL -> ResponseBatch (Just $ More False h t) <!< results   Just SUCCESS_FEED -> ResponseBatch (Just $ More True h t) <!< results+  Just SUCCESS_ATOM_FEED -> ResponseBatch (Just $ More True h t) <!< results   Just SUCCESS_SEQUENCE -> ResponseBatch Nothing <!< results   Just CLIENT_ERROR -> ResponseError $ RethinkDBError ErrorBrokenClient q e bt   Just COMPILE_ERROR -> ResponseError $ RethinkDBError ErrorBadQuery q e bt

@@ -11,4 +11,4 @@   sum, map, mod, concatMap, (&&),   not, (||), (/=), (<), (<=), (>), (>=), error, (==), filter,   max, min,-  zip)+  zip, zipWith)

@@ -20,7 +20,6 @@   Static, Dynamic, OptArg,   OptArgs(..),   cons,-  arr,   baseArray,   withQuerySettings,   reqlToDatum,@@ -31,7 +30,8 @@   WireQuery(..),   WireBacktrace(..),   note,-  (?:=)+  (?:=),+  Arr(arr)   ) where  import qualified Data.Aeson as J@@ -45,7 +45,7 @@ import Data.String (IsString(..)) import Data.List (intercalate) import Control.Monad.State (State, get, put, runState)-import Control.Applicative ((<$>))+import Control.Applicative ((<$>), (<*>)) import Data.Default (Default, def) import qualified Data.Text as T import qualified Data.ByteString as SB@@ -168,6 +168,10 @@ -- | A list of terms data ArgList = ArgList { baseArray :: State QuerySettings [Term] } +instance Monoid ArgList where+  mempty = ArgList $ return []+  mappend (ArgList a) (ArgList b) = ArgList $ (++) <$> a <*> b+ -- | Build arrays of exprs class Arr a where   arr :: a -> ArgList@@ -401,6 +405,30 @@     b <- newVarId     runReQL $ op FUNC ([a, b], expr $ f (op VAR [a]) (op VAR [b])) +instance (a ~ ReQL, b ~ ReQL, c ~ ReQL) => Expr (a -> b -> c -> ReQL) where+  expr f = ReQL $ do+    a <- newVarId+    b <- newVarId+    c <- newVarId+    runReQL $ op FUNC ([a, b, c], expr $ f (op VAR [a]) (op VAR [b]) (op VAR [c]))++instance (a ~ ReQL, b ~ ReQL, c ~ ReQL, d ~ ReQL) => Expr (a -> b -> c -> d -> ReQL) where+  expr f = ReQL $ do+    a <- newVarId+    b <- newVarId+    c <- newVarId+    d <- newVarId+    runReQL $ op FUNC ([a, b, c], expr $ f (op VAR [a]) (op VAR [b]) (op VAR [c]) (op VAR [d]))++instance (a ~ ReQL, b ~ ReQL, c ~ ReQL, d ~ ReQL, e ~ ReQL) => Expr (a -> b -> c -> d -> e -> ReQL) where+  expr f = ReQL $ do+    a <- newVarId+    b <- newVarId+    c <- newVarId+    d <- newVarId+    e <- newVarId+    runReQL $ op FUNC ([a, b, c], expr $ f (op VAR [a]) (op VAR [b]) (op VAR [c]) (op VAR [d]) (op VAR [e]))+ instance Expr Table where   expr (Table mdb name _) = withQuerySettings $ \QuerySettings {..} ->     op' TABLE (fromMaybe queryDefaultDatabase mdb, name) $ catMaybes [@@ -444,7 +472,7 @@ buildAttributes ts = toDatum $ M.fromList $ map toPair ts  where toPair (TermAttribute a b) = (a, termJSON $ buildTerm b) -newtype WireQuery = WireQuery { queryJSON :: Datum } -- TODO: rename+newtype WireQuery = WireQuery { queryJSON :: Datum }                   deriving Show  buildQuery :: ReQL -> Int64 -> Database -> [(T.Text, Datum)] -> (WireQuery, Term)

@@ -1,7 +1,7 @@ module Database.RethinkDB.Wire.Response where import Prelude (Maybe(..), Eq, Show) import Database.RethinkDB.Wire-data ResponseType = SUCCESS_ATOM | SUCCESS_SEQUENCE | SUCCESS_PARTIAL | SUCCESS_FEED | WAIT_COMPLETE | CLIENT_ERROR | COMPILE_ERROR | RUNTIME_ERROR+data ResponseType = SUCCESS_ATOM | SUCCESS_SEQUENCE | SUCCESS_PARTIAL | SUCCESS_FEED | WAIT_COMPLETE | SUCCESS_ATOM_FEED | CLIENT_ERROR | COMPILE_ERROR | RUNTIME_ERROR   deriving (Eq, Show) instance WireValue ResponseType where   toWire SUCCESS_ATOM = 1@@ -9,6 +9,7 @@   toWire SUCCESS_PARTIAL = 3   toWire SUCCESS_FEED = 5   toWire WAIT_COMPLETE = 4+  toWire SUCCESS_ATOM_FEED = 6   toWire CLIENT_ERROR = 16   toWire COMPILE_ERROR = 17   toWire RUNTIME_ERROR = 18@@ -17,6 +18,7 @@   fromWire 3 = Just SUCCESS_PARTIAL   fromWire 5 = Just SUCCESS_FEED   fromWire 4 = Just WAIT_COMPLETE+  fromWire 6 = Just SUCCESS_ATOM_FEED   fromWire 16 = Just CLIENT_ERROR   fromWire 17 = Just COMPILE_ERROR   fromWire 18 = Just RUNTIME_ERROR

@@ -1,7 +1,7 @@ module Database.RethinkDB.Wire.Term where import Prelude (Maybe(..), Eq, Show) import Database.RethinkDB.Wire-data TermType = DATUM | MAKE_ARRAY | MAKE_OBJ | VAR | JAVASCRIPT | UUID | HTTP | ERROR | IMPLICIT_VAR | DB | TABLE | GET | GET_ALL | EQ | NE | LT | LE | GT | GE | NOT | ADD | SUB | MUL | DIV | MOD | APPEND | PREPEND | DIFFERENCE | SET_INSERT | SET_INTERSECTION | SET_UNION | SET_DIFFERENCE | SLICE | SKIP | LIMIT | INDEXES_OF | CONTAINS | GET_FIELD | KEYS | OBJECT | HAS_FIELDS | WITH_FIELDS | PLUCK | WITHOUT | MERGE | BETWEEN | REDUCE | MAP | FILTER | CONCATMAP | ORDERBY | DISTINCT | COUNT | IS_EMPTY | UNION | NTH | BRACKET | INNER_JOIN | OUTER_JOIN | EQ_JOIN | ZIP | INSERT_AT | DELETE_AT | CHANGE_AT | SPLICE_AT | COERCE_TO | TYPEOF | UPDATE | DELETE | REPLACE | INSERT | DB_CREATE | DB_DROP | DB_LIST | TABLE_CREATE | TABLE_DROP | TABLE_LIST | SYNC | INDEX_CREATE | INDEX_DROP | INDEX_LIST | INDEX_STATUS | INDEX_WAIT | INDEX_RENAME | FUNCALL | BRANCH | ANY | ALL | FOREACH | FUNC | ASC | DESC | INFO | MATCH | UPCASE | DOWNCASE | SAMPLE | DEFAULT | JSON | ISO8601 | TO_ISO8601 | EPOCH_TIME | TO_EPOCH_TIME | NOW | IN_TIMEZONE | DURING | DATE | TIME_OF_DAY | TIMEZONE | YEAR | MONTH | DAY | DAY_OF_WEEK | DAY_OF_YEAR | HOURS | MINUTES | SECONDS | TIME | MONDAY | TUESDAY | WEDNESDAY | THURSDAY | FRIDAY | SATURDAY | SUNDAY | JANUARY | FEBRUARY | MARCH | APRIL | MAY | JUNE | JULY | AUGUST | SEPTEMBER | OCTOBER | NOVEMBER | DECEMBER | LITERAL | GROUP | SUM | AVG | MIN | MAX | SPLIT | UNGROUP | RANDOM | CHANGES | ARGS | BINARY | GEOJSON | TO_GEOJSON | POINT | LINE | POLYGON | DISTANCE | INTERSECTS | INCLUDES | CIRCLE | GET_INTERSECTING | FILL | GET_NEAREST | POLYGON_SUB+data TermType = DATUM | MAKE_ARRAY | MAKE_OBJ | VAR | JAVASCRIPT | UUID | HTTP | ERROR | IMPLICIT_VAR | DB | TABLE | GET | GET_ALL | EQ | NE | LT | LE | GT | GE | NOT | ADD | SUB | MUL | DIV | MOD | APPEND | PREPEND | DIFFERENCE | SET_INSERT | SET_INTERSECTION | SET_UNION | SET_DIFFERENCE | SLICE | SKIP | LIMIT | INDEXES_OF | CONTAINS | GET_FIELD | KEYS | OBJECT | HAS_FIELDS | WITH_FIELDS | PLUCK | WITHOUT | MERGE | BETWEEN | REDUCE | MAP | FILTER | CONCAT_MAP | ORDER_BY | DISTINCT | COUNT | IS_EMPTY | UNION | NTH | BRACKET | INNER_JOIN | OUTER_JOIN | EQ_JOIN | ZIP | RANGE | INSERT_AT | DELETE_AT | CHANGE_AT | SPLICE_AT | COERCE_TO | TYPE_OF | UPDATE | DELETE | REPLACE | INSERT | DB_CREATE | DB_DROP | DB_LIST | TABLE_CREATE | TABLE_DROP | TABLE_LIST | CONFIG | STATUS | WAIT | RECONFIGURE | REBALANCE | SYNC | INDEX_CREATE | INDEX_DROP | INDEX_LIST | INDEX_STATUS | INDEX_WAIT | INDEX_RENAME | FUNCALL | BRANCH | ANY | ALL | FOR_EACH | FUNC | ASC | DESC | INFO | MATCH | UPCASE | DOWNCASE | SAMPLE | DEFAULT | JSON | TO_JSON_STRING | ISO8601 | TO_ISO8601 | EPOCH_TIME | TO_EPOCH_TIME | NOW | IN_TIMEZONE | DURING | DATE | TIME_OF_DAY | TIMEZONE | YEAR | MONTH | DAY | DAY_OF_WEEK | DAY_OF_YEAR | HOURS | MINUTES | SECONDS | TIME | MONDAY | TUESDAY | WEDNESDAY | THURSDAY | FRIDAY | SATURDAY | SUNDAY | JANUARY | FEBRUARY | MARCH | APRIL | MAY | JUNE | JULY | AUGUST | SEPTEMBER | OCTOBER | NOVEMBER | DECEMBER | LITERAL | GROUP | SUM | AVG | MIN | MAX | SPLIT | UNGROUP | RANDOM | CHANGES | ARGS | BINARY | GEOJSON | TO_GEOJSON | POINT | LINE | POLYGON | DISTANCE | INTERSECTS | INCLUDES | CIRCLE | GET_INTERSECTING | FILL | GET_NEAREST | POLYGON_SUB   deriving (Eq, Show) instance WireValue TermType where   toWire DATUM = 1@@ -53,8 +53,8 @@   toWire REDUCE = 37   toWire MAP = 38   toWire FILTER = 39-  toWire CONCATMAP = 40-  toWire ORDERBY = 41+  toWire CONCAT_MAP = 40+  toWire ORDER_BY = 41   toWire DISTINCT = 42   toWire COUNT = 43   toWire IS_EMPTY = 86@@ -65,12 +65,13 @@   toWire OUTER_JOIN = 49   toWire EQ_JOIN = 50   toWire ZIP = 72+  toWire RANGE = 173   toWire INSERT_AT = 82   toWire DELETE_AT = 83   toWire CHANGE_AT = 84   toWire SPLICE_AT = 85   toWire COERCE_TO = 51-  toWire TYPEOF = 52+  toWire TYPE_OF = 52   toWire UPDATE = 53   toWire DELETE = 54   toWire REPLACE = 55@@ -81,6 +82,11 @@   toWire TABLE_CREATE = 60   toWire TABLE_DROP = 61   toWire TABLE_LIST = 62+  toWire CONFIG = 174+  toWire STATUS = 175+  toWire WAIT = 177+  toWire RECONFIGURE = 176+  toWire REBALANCE = 179   toWire SYNC = 138   toWire INDEX_CREATE = 75   toWire INDEX_DROP = 76@@ -92,7 +98,7 @@   toWire BRANCH = 65   toWire ANY = 66   toWire ALL = 67-  toWire FOREACH = 68+  toWire FOR_EACH = 68   toWire FUNC = 69   toWire ASC = 73   toWire DESC = 74@@ -103,6 +109,7 @@   toWire SAMPLE = 81   toWire DEFAULT = 92   toWire JSON = 98+  toWire TO_JSON_STRING = 172   toWire ISO8601 = 99   toWire TO_ISO8601 = 100   toWire EPOCH_TIME = 101@@ -215,8 +222,8 @@   fromWire 37 = Just REDUCE   fromWire 38 = Just MAP   fromWire 39 = Just FILTER-  fromWire 40 = Just CONCATMAP-  fromWire 41 = Just ORDERBY+  fromWire 40 = Just CONCAT_MAP+  fromWire 41 = Just ORDER_BY   fromWire 42 = Just DISTINCT   fromWire 43 = Just COUNT   fromWire 86 = Just IS_EMPTY@@ -227,12 +234,13 @@   fromWire 49 = Just OUTER_JOIN   fromWire 50 = Just EQ_JOIN   fromWire 72 = Just ZIP+  fromWire 173 = Just RANGE   fromWire 82 = Just INSERT_AT   fromWire 83 = Just DELETE_AT   fromWire 84 = Just CHANGE_AT   fromWire 85 = Just SPLICE_AT   fromWire 51 = Just COERCE_TO-  fromWire 52 = Just TYPEOF+  fromWire 52 = Just TYPE_OF   fromWire 53 = Just UPDATE   fromWire 54 = Just DELETE   fromWire 55 = Just REPLACE@@ -243,6 +251,11 @@   fromWire 60 = Just TABLE_CREATE   fromWire 61 = Just TABLE_DROP   fromWire 62 = Just TABLE_LIST+  fromWire 174 = Just CONFIG+  fromWire 175 = Just STATUS+  fromWire 177 = Just WAIT+  fromWire 176 = Just RECONFIGURE+  fromWire 179 = Just REBALANCE   fromWire 138 = Just SYNC   fromWire 75 = Just INDEX_CREATE   fromWire 76 = Just INDEX_DROP@@ -254,7 +267,7 @@   fromWire 65 = Just BRANCH   fromWire 66 = Just ANY   fromWire 67 = Just ALL-  fromWire 68 = Just FOREACH+  fromWire 68 = Just FOR_EACH   fromWire 69 = Just FUNC   fromWire 73 = Just ASC   fromWire 74 = Just DESC@@ -265,6 +278,7 @@   fromWire 81 = Just SAMPLE   fromWire 92 = Just DEFAULT   fromWire 98 = Just JSON+  fromWire 172 = Just TO_JSON_STRING   fromWire 99 = Just ISO8601   fromWire 100 = Just TO_ISO8601   fromWire 101 = Just EPOCH_TIME

@@ -1,7 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} --- TODO: find the cause of the bad performance reported by these benchmarks- module Main where  import Control.Exception

@@ -0,0 +1,112 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Prelude hiding (+  readFile, putStr, putStrLn, takeWhile, hPutStrLn, writeFile,+  unlines, unwords)+import Data.Attoparsec.Text+import Data.Text.IO+import Data.Text (unwords, unlines, pack, unpack)+import System.Exit+import System.IO (stderr)+import Data.Maybe+import Control.Applicative+import Data.Monoid+import Data.List (intersperse)+import Data.Char+import Control.Monad++import Debug.Trace++main = do+  proto <- readFile "ql2.proto"+  case parseOnly protoFile proto of+    Left err -> hPutStrLn stderr ("Error: " <> pack err) >> exitWith ExitSuccess+    Right mod -> do+      writeFile "Database/RethinkDB/Wire.hs" genRaw+      forM_ mod $ \(name, enums) ->+        maybe (return ()) (writeFile (unpack $ "Database/RethinkDB/Wire/" <> name <> ".hs"))+        (renderMessage (name, enums))++protoFile = tr "protoFile" $ do+  many message++message = tr "message" $ do+  token "message"+  n <- name+  token "{"+  body <- catMaybes <$> many justEnums+  token "}"+  return (n, body)++justEnums = tr "justEnums" $ choice [+  Just <$> enum,+  const Nothing <$> field,+  const Nothing <$> message+  ]++field = tr "field" $ do+  choice [token "repeated", token "optional", token "extensions"]+  skipWhile (/=';')+  string ";"++enum = tr "enum" $ do+  token "enum"+  n <- name+  token "{"+  d <- many decl+  token "}"+  return (n,d)++decl = tr "decl" $ do+  n <- name+  token "="+  v <- value+  choice [token ";", string ";"]+  return (n,v)++value = tr "value" $ whitespace >> takeWhile (\c -> not (isSpace c) && c /= ';')++name = tr "name" $ whitespace >> takeWhile1 (`elem` alphanum)++alphanum = "_" <> ['a'..'z'] <> ['A'..'Z'] <> ['0'..'9']++token s = tr ("token " ++ show s) $ whitespace >> string s++whitespace = do+  many1 $ choice [+    satisfy isSpace >> skipWhile isSpace,+    string "//" >> skipWhile (not . isEndOfLine) ]+  return ()++genRaw = unlines $ [+  "module Database.RethinkDB.Wire where",+  "class WireValue a where",+  "  toWire :: a -> Int",+  "  fromWire :: Int -> Maybe a"+  ]++renderMessage (name, []) = Nothing+renderMessage (name, enums) = Just $ unlines $ [+  unwords ["module", "Database.RethinkDB.Wire." <> name, "where"],+  "import Prelude (Maybe(..), Eq, Show)",+  "import Database.RethinkDB.Wire"+  ] ++ map renderEnum enums++renderEnum (name, decls) = unlines $ [+  unwords $ ["data", name, "="] <> intersperse "|" (map fst decls),+  "  deriving (Eq, Show)",+  unwords ["instance WireValue", name, "where"],+  indent $+  (for decls $ \(var, val) -> "toWire " <> var <> " = " <> val) <>+  (for decls $ \(var, val) -> "fromWire " <> val <> " = Just " <> var) <>+  ["fromWire _ = Nothing"]+  ]+++indent = unlines . map ("  " <>)++for = flip map++tr s p = p <?> s

@@ -1,16 +1,16 @@ name: rethinkdb-version: 1.15.2.1+version: 1.16.0.0 cabal-version: >=1.8 build-type: Simple license: Apache license-file: LICENSE maintainer: Etienne Laurin <etienne@atnnn.com> homepage: http://github.com/atnnn/haskell-rethinkdb-synopsis: A driver for RethinkDB 1.15+synopsis: A driver for RethinkDB 1.16 description:     A driver for the RethinkDB database server category: Database-author: Etienne Laurin+author: Etienne Laurin, Brandon Martin  source-repository head     type: git@@ -62,6 +62,7 @@         Database.RethinkDB.Wire.Response         Database.RethinkDB.Wire.Term         Database.RethinkDB.Wire.VersionDummy+        Database.RethinkDB.Doctest     exposed: True     buildable: True     ghc-options: -Wall@@ -89,3 +90,9 @@     main-is: Bench.hs     ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N     ghc-prof-options: "-with-rtsopts=-p -s -h -i0.1 -N"++executable proto2hs+  if flag(dev)+    buildable: True+  main-is: proto2hs.hs+  build-depends: base, text, attoparsec