packages feed

rethinkdb 1.8.0.4 → 1.8.0.5

raw patch · 10 files changed

+572/−129 lines, 10 filesdep ~base

Dependency ranges changed: base

Files

Database/RethinkDB.hs view
@@ -25,6 +25,7 @@   SuccessCode(..),   ErrorCode(..),   ReQL,+  JSON(..),    -- * Manipulating databases @@ -33,7 +34,7 @@    -- * Manipulating Tables -  Table(..), TableCreateOptions(..),+  Table(..), TableCreateOptions(..), IndexCreateOptions(..),   table, tableCreate, tableDrop, tableList,   indexCreate, indexDrop, indexList, @@ -42,15 +43,16 @@   WriteResponse(..),   insert, upsert,   update, replace, delete,-  returnVals,+  returnVals, nonAtomic,    -- * Selecting data +  Bound(..),   get, filter, between, getAll,    -- * Joins -  innerJoin, outerJoin, eqJoin, mergeRightLeft,+  innerJoin, outerJoin, eqJoin, mergeLeftRight,    -- * Transformations @@ -58,10 +60,10 @@   (!!), slice,   orderBy,  Order(..),   indexesOf, isEmpty, (++), sample,-  +   -- * Aggregation -  reduce, reduce1, distinct, groupBy, member,+  reduce, reduce1, nub, groupBy, elem,    -- * Aggregators @@ -94,7 +96,7 @@      -- * Control structures -  apply, Javascript(js), if', forEach, error,+  apply, js, if', forEach, error,   handle, Expr(..), coerceTo,   asArray, asString, asNumber, asObject, asBool,   typeOf, info, json,
Database/RethinkDB/Driver.hs view
@@ -6,10 +6,14 @@   Result(..),   runOpts,   RunOptions(..),-  WriteResponse(..)+  WriteResponse(..),+  JSON(..)   ) where -import Data.Aeson (Value(..), FromJSON(..), fromJSON, (.:), (.:?))+import Data.Aeson (Value(..), FromJSON(..), fromJSON, (.:), (.:?), encode)+import Data.Aeson.Encode (fromValue)+import Data.Text.Lazy (unpack)+import Data.Text.Lazy.Builder (toLazyText) import qualified Data.Aeson (Result(Error, Success)) import Control.Monad import Control.Concurrent.MVar (MVar, takeMVar)@@ -20,7 +24,7 @@ import Database.RethinkDB.Protobuf.Ql2.Query (Query(..)) import Database.RethinkDB.Protobuf.Ql2.Query.AssocPair (AssocPair(..)) import Database.RethinkDB.Protobuf.Ql2.Term as Term (Term(..))-import Database.RethinkDB.Protobuf.Ql2.Term.TermType+import Database.RethinkDB.Protobuf.Ql2.Term.TermType (TermType(DATUM)) import Database.RethinkDB.Protobuf.Ql2.Datum as Datum import Database.RethinkDB.Protobuf.Ql2.Datum.DatumType import Text.ProtocolBuffers.Basic (uFromString, defaultValue)@@ -59,8 +63,8 @@ run :: (Expr query, Result r) => RethinkDBHandle -> query -> IO r run h = runOpts h [] --- | Run a given query and return a Value-run' :: Expr query => RethinkDBHandle -> query -> IO [Value]+-- | Run a given query and return a JSON+run' :: Expr query => RethinkDBHandle -> query -> IO [JSON] run' h t = do   c <- run h t   collect c@@ -120,3 +124,11 @@     <*> o .:? "old_val"     <*> o .:? "new_val"   parseJSON _ = mzero++data JSON = JSON Value++instance Show JSON where+  show (JSON a) = unpack . toLazyText . fromValue $ a++instance FromJSON JSON where+  parseJSON = fmap JSON . parseJSON
Database/RethinkDB/Functions.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances, OverloadedStrings, GADTs #-}  -- TODO: operator fixity @@ -20,131 +20,284 @@ import Prelude (($), return, Double, Bool, String) import qualified Prelude as P --- | Arithmetic Operator infixl 6 +, - infixl 7 *, /-(+), (-), (*), (/), mod-  :: (Expr a, Expr b) => a -> b -> ReQL++-- | Addition or concatenation+--+-- Use the Num instance, or a qualified operator.+--+-- > >>> run h $ 2 + 5 :: IO (Maybe Int)+-- > Just 7+-- > >>> run h $ 2 R.+ 5 :: IO (Maybe Int)+-- > Just 7+-- > >>> run h $ (str "foo") + (str "bar") :: IO (Just String)+-- > Just "foobar"+(+) :: (Expr a, Expr b) => a -> b -> ReQL (+) a b = op ADD (a, b) ()++-- | Subtraction+--+-- > >>> run h $ 2 - 5 :: IO (Maybe Int)+-- > Just (-3)+(-) :: (Expr a, Expr b) => a -> b -> ReQL (-) a b = op SUB (a, b) ()++-- | Multiplication+--+-- > >>> run h $ 2 * 5 :: IO (Maybe Int)+-- > Just 10+(*) :: (Expr a, Expr b) => a -> b -> ReQL (*) a b = op MUL (a, b) ()++-- | Division+--+-- > >>> run h $ 2 R./ 5 :: IO (Maybe Double)+-- > Just 0.4+(/) :: (Expr a, Expr b) => a -> b -> ReQL (/) a b = op DIV (a, b) ()++-- | Mod+--+-- > >>> run h $ 5 `mod` 2 :: IO (Maybe Int)+-- > Just 1+mod :: (Expr a, Expr b) => a -> b -> ReQL mod a b = op MOD (a, b) () --- | Boolean operator infixr 2 || infixr 3 &&-(||), (&&) :: (Expr a, Expr b) => a -> b -> ReQL++-- | Boolean or+--+-- > >>> run h $ True R.|| False :: IO (Maybe Bool)+-- > Just True+(||) :: (Expr a, Expr b) => a -> b -> ReQL a || b = op ANY (a, b) ()++-- | Boolean and+--+-- > >>> run h $ True R.&& False :: IO (Maybe Bool)+-- > Just False+(&&) :: (Expr a, Expr b) => a -> b -> ReQL a && b = op ALL (a, b) () --- | Comparison operator infix 4 ==, /=-(==), (/=) :: (Expr a, Expr b) => a -> b -> ReQL++-- | Test for equality+--+-- > >>> run h $ obj ["a" := 1] R.== obj ["a" := 1] :: IO (Maybe Bool)+-- > Just True+(==) :: (Expr a, Expr b) => a -> b -> ReQL a == b = op EQ (a, b) ()++-- | Test for inequality+--+-- > >>> run h $ 1 R./= False :: IO (Maybe Bool)+-- > Just True+(/=) :: (Expr a, Expr b) => a -> b -> ReQL a /= b = op NE (a, b) ()  infix 4 >, <, <=, >=--- | Comparison operator-(>), (>=), (<), (<=)-  :: (Expr a, Expr b) => a -> b -> ReQL++-- | Greater than+--+-- > >>> run h $ 3 R.> 2 :: IO (Maybe Bool)+-- > Just True+(>) :: (Expr a, Expr b) => a -> b -> ReQL a > b = op GT (a, b) ()++-- | Lesser than+--+-- > >>> run h $ (str "a") R.< (str "b") :: IO (Maybe Bool)+-- > Just True+(<) :: (Expr a, Expr b) => a -> b -> ReQL a < b = op LT (a, b) ()-a >=b = op GE (a, b) ()-a <=b = op LE (a, b) () +-- | Greater than or equal to+--+-- > >>> run h $ [1] R.>= () :: IO (Maybe Bool)+-- > Just False+(>=) :: (Expr a, Expr b) => a -> b -> ReQL+a >= b = op GE (a, b) ()++-- | Lesser than or equal to+--+-- > >>> run h $ 2 R.<= 2 :: IO (Maybe Bool)+-- > Just True+(<=) :: (Expr a, Expr b) => a -> b -> ReQL+a <= b = op LE (a, b) ()+ -- | Negation+--+-- > >>> run h $ R.not False :: IO (Maybe Bool)+-- > Just True+-- > >>> run h $ R.not () :: IO (Maybe Bool)+-- > Just True not :: (Expr a) => a -> ReQL not a = op NOT [a] ()  -- * Lists and Streams  -- | The size of a sequence or an array.+-- -- Called /count/ in the official drivers+--+-- > >>> run h $ R.length (table "foo") :: IO (Maybe Int)+-- > Just 17 length :: (Expr a) => a -> ReQL length e = op COUNT [e] ()  infixr 5 +++ -- | Join two sequences.+-- -- Called /union/ in the official drivers+--+-- > >>> run h $ [1,2,3] R.++ ["a", "b", "c" :: Text] :: IO (Maybe [JSON])+-- > Just [1.0,2.0,3.0,"a","b","c"] (++) :: (Expr a, Expr b) => a -> b -> ReQL a ++ b = op UNION (a, b) ()  -- | Map a function over a sequence+--+-- > >>> run h $ R.map (!"a") [obj ["a" := 1], obj ["a" := 2]] :: IO (Maybe [Int])+-- > Just [1,2] map :: (Expr a, Expr b) => (ReQL -> b) -> a -> ReQL map f a = op MAP (a, expr P.. f) ()  -- | Filter a sequence given a predicate+--+-- > >>> run h $ R.filter (R.< 4) [3, 1, 4, 1, 5, 9, 2, 6] :: IO (Maybe [Int])+-- > Just [3,1,1,2] filter :: (Expr predicate, Expr seq) => predicate -> seq -> ReQL filter f a = op FILTER (a, f) ()  -- | Query all the documents whose value for the given index is in a given range-between :: (Expr left, Expr right, Expr seq) => Key -> left -> right -> seq -> ReQL-between i a b e = op BETWEEN [e] ["left_bound" := a, "right_bound" := b, "index" := i]+--+-- > >>> run h $ table "users" # between "id" (Closed $ str "a") (Open $ str "n") :: IO [JSON]+-- > [{"post_count":4.0,"name":"bob","id":"b6a9df6a-b92c-46d1-ae43-1d2dd8ec293c"},{"post_count":4.0,"name":"bill","id":"b2908215-1d3c-4ff5-b9ee-1a003fa9690c"}]+between :: (Expr left, Expr right, Expr seq) => Key -> Bound left -> Bound right -> seq -> ReQL+between i a b e =+  op BETWEEN [expr e, expr $ getBound a, expr $ getBound b]+         ["left_bound" := closedOrOpen a, "right_bound" := closedOrOpen b, "index" := i]  -- | Append a datum to a sequence+--+-- > >>> run h $ append 3 [1, 2] :: IO (Maybe [Int])+-- > Just [1,2,3] append :: (Expr a, Expr b) => a -> b -> ReQL append a b = op APPEND (b, a) ()  -- | Map a function of a sequence and concat the results+--+-- > >>> run h $ concatMap id [[1, 2], [3], [4, 5]] :: IO (Maybe [Int])+-- > Just [1,2,3,4,5] concatMap :: (Expr a, Expr b) => (ReQL -> b) -> a -> ReQL concatMap f e = op CONCATMAP (e, expr P.. f) () --- | SQL-like join of two sequences. Returns each pair of rows that satisfy the 2-ary predicate.-innerJoin, outerJoin :: (Expr a, Expr b, Expr c) => (ReQL -> ReQL -> c) -> a -> b -> ReQL+-- | SQL-like inner join of two sequences+--+-- > >>> run' h $ innerJoin (\user post -> user!"id" R.== post!"author") (table "users") (table "posts") # mergeLeftRight # without ["id", "author"]+-- > [[{"name":"bob","message":"lorem ipsum"},{"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!"id" R.== post!"author") (table "users") (table "posts") # mergeLeftRight # without ["id", "author"]+-- > [[{"name":"nancy"},{"name":"bill","message":"hello"},{"name":"bill","message":"hi"},{"name":"bob","message":"lorem ipsum"}]]+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 iner_join that uses a key for the first table and an index for the left table.-eqJoin :: (Expr a, Expr b) => Key -> a -> Key -> b -> ReQL-eqJoin a i k b = op EQ_JOIN (b, k, a) ["index" := i]+-- | 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") "id" # mergeLeftRight # without ["id", "author"]+-- > [[{"name":"bill","message":"hi"},{"name":"bob","message":"lorem ipsum"},{"name":"bill","message":"hello"}]]+eqJoin :: (Expr right, Expr left) => Key -> right -> Key -> left -> ReQL+eqJoin key right index left = op EQ_JOIN (left, key, right) ["index" := index]  -- | Drop elements from the head of a sequence.+-- -- Called /skip/ in the official drivers+--+-- > >>> run h $ R.drop 2 [1, 2, 3, 4] :: IO (Maybe [Int])+-- > Just [3,4] drop :: (Expr a, Expr b) => a -> b -> ReQL drop a b = op SKIP (b, a) ()  -- | Limit the size of a sequence.+-- -- Called /limit/ in the official drivers+--+-- > >>> run h $ R.take 2 [1, 2, 3, 4] :: IO (Maybe [Int])+-- > Just [1,2] take :: (Expr n, Expr seq) => n -> seq -> ReQL take n s = op LIMIT (s, n) ()  -- | Cut out part of a sequence+--+-- > >>> run h $ slice 2 4 [1, 2, 3, 4, 5] :: IO (Maybe [Int])+-- > Just [3,4] slice :: (Expr a, Expr b, Expr c) => a -> b -> c -> ReQL slice n m s = op SLICE (s, n, m) () --- | Get the nth value of a sequence or array infixl 9 !!++-- | Get the nth value of a sequence or array+--+-- > >>> run h $ [1, 2, 3] !! 0 :: IO (Maybe Int)+-- > Just 1 (!!) :: (Expr a) => a -> ReQL -> ReQL s !! n = op NTH (s, n) ()  -- | Reduce a sequence to a single value+--+-- > >>> run h $ reduce (+) 0 [1, 2, 3] :: IO (Maybe Int)+-- > Just 6 reduce :: (Expr base, Expr seq, Expr a) => (ReQL -> ReQL -> a) -> base -> seq -> ReQL reduce f b s = op REDUCE (s, fmap expr P.. f) ["base" := b]  -- | Reduce a non-empty sequence to a single value+--+-- > >>> run h $ reduce1 (+) [1, 2, 3] :: IO (Maybe Int)+-- > Just 6 reduce1 :: (Expr a, Expr s) => (ReQL -> ReQL -> a) -> s -> ReQL reduce1 f s = op REDUCE (s, fmap expr P.. f) ()  -- | Filter out identical elements of the sequence-distinct :: (Expr s) => s -> ReQL-distinct s = op DISTINCT [s] ()+--+-- Called /distint/ in the official drivers+--+-- > >>> run h $ nub (table "posts" ! "flag") :: IO (Maybe [String])+-- > Just ["pinned", "deleted"]+nub :: (Expr s) => s -> ReQL+nub s = op DISTINCT [s] ()  -- | Like map but for write queries+--+-- > >>> run' h $ table "users" # replace (without ["post_count"])+-- > >>> run' h $ forEach (table "posts") $ \post -> table "users" # get (post!"author") # update (\user -> obj ["post_count" := (handle 0 (user!"post_count") + 1)])+-- > [{"skipped":0.0,"inserted":0.0,"unchanged":0.0,"deleted":0.0,"replaced":3.0,"errors":0.0}] forEach :: (Expr s, Expr a) => s -> (ReQL -> a) -> ReQL forEach s f = op FOREACH (s, expr P.. f) ()  -- | Merge the "left" and "right" attributes of the objects in a sequence.+-- -- Called /zip/ in the official drivers-mergeRightLeft :: (Expr a) => a -> ReQL-mergeRightLeft a = op ZIP [a] ()+--+-- > >>> run' h $ table "posts" # eqJoin "author" (table "users") "id" # mergeLeftRight+mergeLeftRight :: (Expr a) => a -> ReQL+mergeLeftRight a = op ZIP [a] () --- | Oredering specification for orderBy+-- | Ordering specification for orderBy data Order =-  Asc { orderAttr :: Key } |-  Desc { orderAttr :: Key }+  Asc { orderAttr :: Key } -- ^ Ascending order+  | Desc { orderAttr :: Key } -- ^ Descending order  -- | Order a sequence by the given keys+--+-- > >>> run' h $ table "users" # orderBy [Desc "post_count", Asc "name"] # pluck ["name", "post_count"]+-- > [[{"post_count":2.0,"name":"bill"},{"post_count":1.0,"name":"bob"},{"name":"nancy"}]] orderBy :: (Expr s) => [Order] -> s -> ReQL orderBy o s = ReQL $ do   s' <- baseReQL (expr s)@@ -155,19 +308,33 @@     buildOrder (Desc k) = op DESC [k] ()  -- | Turn a grouping function and a reduction function into a grouped map reduce operation+--+-- > >>> run' h $ table "posts" # groupBy (!"author") (reduce1 (\a b -> a + "\n" + b) . R.map (!"message"))+    -- > [[{"group":"b2908215-1d3c-4ff5-b9ee-1a003fa9690c","reduction":"hi\nhello"},{"group":"b6a9df6a-b92c-46d1-ae43-1d2dd8ec293c","reduction":"lorem ipsum"}]]+-- > >>> run' h $ table "users" # groupBy (!"level") (\users -> let pc = users!"post_count" in [avg pc, R.sum pc])+-- > [[{"group":1,"reduction":[1.5,3.0]},{"group":2,"reduction":[0.0,0.0]}]] groupBy ::   (Expr group, Expr reduction, Expr seq)   => (ReQL -> group) -> (ReQL -> reduction) -> seq -> ReQL groupBy g mr s = ReQL $ do-  (m, r, f) <- termToMapReduce (expr . mr)-  baseReQL $-    op GROUPED_MAP_REDUCE [expr s, expr $ expr P.. g, expr m, expr r] ()+  (m, r, mf) <- termToMapReduce (expr . mr)+  let gmr = op GROUPED_MAP_REDUCE [expr s, expr $ expr P.. g, expr m, expr r] ()+  baseReQL $ case mf of+    Nothing -> gmr+    Just f -> op MAP [gmr, expr $ \x -> expr $+                      obj ["group" := (x!"group"), "reduction" := f (x!"reduction")]] ()  -- | The sum of a sequence+--+-- > >>> run h $ sum [1, 2, 3] :: IO (Maybe Int)+-- > Just 6 sum :: (Expr s) => s -> ReQL sum = reduce ((+) :: ReQL -> ReQL -> ReQL) (num 0)  -- | The average of a sequence+--+-- > >>> run h $ avg [1, 2, 3, 4] :: IO (Maybe Double)+-- > Just 2.5 avg :: (Expr s) => s -> ReQL avg = (\x -> (x!!0) / (x!!1)) .   reduce (\a b -> [(a!!0) + (b!!0), (a!!1) + (b!!1)]) [num 0, num 0] .@@ -175,86 +342,142 @@  -- * Accessors --- | Get a single field form an object infixl 9 !++-- | Get a single field from an object+--+-- > >>> run h $ (obj ["foo" := True]) ! "foo" :: IO (Maybe Bool)+-- > Just True+--+-- Or a single field from each object in a sequence+--+-- > >>> run h $ [obj ["foo" := True], obj ["foo" := False]] ! "foo" :: IO (Maybe [Bool])+-- > Just [True,False] (!) :: (Expr s) => s -> ReQL -> ReQL s ! k = op GET_FIELD (s, k) ()  -- | Keep only the given attributes+--+-- > >>> run' h $ map obj [["a" := 1, "b" := 2], ["a" := 2, "c" := 7], ["b" := 4]] # pluck ["a"]+-- > [[{"a":1.0},{"a":2.0},{}]] pluck :: (Expr o) => [ReQL] -> o -> ReQL pluck ks e = op PLUCK (cons e $ arr (P.map expr ks)) ()  -- | Remove the given attributes from an object+--+-- > >>> run' h $ map obj [["a" := 1, "b" := 2], ["a" := 2, "c" := 7], ["b" := 4]] # without ["a"]+-- > [[{"b":2.0},{"c":7.0},{"b":4.0}]] without :: (Expr o) => [ReQL] -> o -> ReQL without ks e = op WITHOUT (cons e $ arr (P.map expr ks)) () --- | Test if an object contains the given attribute.--- Called /contains/ in the official drivers-member :: (Expr o) => [ReQL] -> o -> ReQL-member ks o = op CONTAINS (cons o $ arr (P.map expr ks)) ()+-- | Test if a sequence contains a given element+--+-- > >>> run' h $ 1 `R.elem` [1,2,3]+-- > [true]+elem :: (Expr x, Expr seq) => x -> seq -> ReQL+elem x s = op CONTAINS (s, x) ()  -- | Merge two objects together+--+-- > >>> run' h $ merge (obj ["a" := 1, "b" := 1]) (obj ["b" := 2, "c" := 2])+-- > [{"a":1.0,"b":2.0,"c":2.0}] merge :: (Expr a, Expr b) => a -> b -> ReQL merge a b = op MERGE (a, b) () --- | Create a javascript expression-class Javascript r where-  js :: P.String -> r--instance Javascript ReQL where-  js s = op JAVASCRIPT [str s] ()--instance Javascript (ReQL -> ReQL) where-  js s x = op FUNCALL (op JAVASCRIPT [str s] (), x) ()--instance Javascript (ReQL -> ReQL -> ReQL) where-  js s x y = op FUNCALL (op JAVASCRIPT [str s] (), x, y) ()+-- | Evaluate a JavaScript expression+--+-- > >>> run h $ js "Math.random()" :: IO (Maybe Double)+-- > Just 0.9119815775193274+-- > >>> run h $ R.map (\x -> js "Math.sin" `apply` [x]) [pi, pi/2] :: IO (Maybe [Double])+-- > Just [1.2246063538223773e-16,1.0]+js :: ReQL -> ReQL+js s = op JAVASCRIPT [s] ()  -- | Called /branch/ in the official drivers+--+-- > >>> run h $ if' (1 R.< 2) 3 4 :: IO (Maybe Int)+-- > Just 3 if' :: (Expr a, Expr b, Expr c) => a -> b -> c -> ReQL if' a b c = op BRANCH (a, b, c) ()  -- | Abort the query with an error+--+-- > >>> run' h $ R.error (str "haha") R./ 2 + 1+-- > *** Exception: RethinkDBError {errorCode = runtime error, errorTerm = ADD(DIV(ERROR("haha"), 2.0), 1.0), errorMessage = "haha", errorBacktrace = [0,0]} error :: (Expr s) => s -> ReQL error m = op ERROR [m] ()  -- | Create a Database reference+--+-- > >>> run' h $ db "test" # info+-- > [{"name":"test","type":"DB"}] db :: Text -> O.Database db s = O.Database s  -- | Create a database on the server+--+-- > >>> run' h $ dbCreate "dev"+-- > [{"created":1.0}] dbCreate :: P.String -> ReQL dbCreate db_name = op DB_CREATE [str db_name] ()  -- | Drop a database+--+-- > >>> run' h $ dbDrop (db "dev")+-- > [{"dropped":1.0}] dbDrop :: Database -> ReQL dbDrop (O.Database name) = op DB_DROP [name] ()  -- | List the databases on the server+--+-- > >>> run h $ dbList :: IO (Maybe [String])+-- > Just ["test"] dbList :: ReQL dbList = op DB_LIST () ()  -- | Create an index on the table from the given function-indexCreate :: (Expr fun) => P.String -> fun -> Table -> ReQL-indexCreate name f tbl = op INDEX_CREATE (tbl, str name, f) ()+--+-- > >>> run' h $ table "users" # indexCreate "name" (!"name") def+-- > [{"created":1.0}]+indexCreate :: (Expr fun) => P.String -> fun -> IndexCreateOptions -> Table -> ReQL+indexCreate name f opts tbl = op INDEX_CREATE (tbl, str name, f) $ catMaybes [+  ("multi" :=) <$> indexMulti opts]  -- | Drop an index+--+-- > >>> run' h $ table "users" # indexDrop "name"+-- > [{"dropped":1.0}] indexDrop :: Key -> Table -> ReQL indexDrop name tbl = op INDEX_DROP (tbl, name) ()  -- | List the indexes on the table+--+-- > >>> run' h $ indexList (table "users")+-- > [["name"]] indexList :: Table -> ReQL indexList tbl = op INDEX_LIST [tbl] ()  -- | Retreive documents by their indexed value+--+-- > >>> run' h $ table "users" # getAll "name" ["bob"]+-- > [{"post_count":1.0,"name":"bob","id":"b6a9df6a-b92c-46d1-ae43-1d2dd8ec293c"}] getAll :: (Expr value) => Key -> [value] -> Table -> ReQL getAll idx xs tbl = op GET_ALL (expr tbl : P.map expr xs) ["index" := idx] --- | Create a simple table refence with no associated database+-- | A table+--+-- > >>> (mapM_ print =<<) $ run' h $ table "users"+-- > {"post_count":0.0,"name":"nancy","id":"8d674d7a-873c-4c0f-8a4a-32a4bd5bdee8"}+-- > {"post_count":1.0,"name":"bob","id":"b6a9df6a-b92c-46d1-ae43-1d2dd8ec293c"}+-- > {"post_count":2.0,"name":"bill","id":"b2908215-1d3c-4ff5-b9ee-1a003fa9690c"} table :: Text -> Table table n = O.Table Nothing n Nothing  -- | Create a table on the server+--+-- > >>> run' h $ tableCreate (table "posts") def+-- > >>> run' h $ tableCreate (table "users") def+-- > >>> run' h $ tableCreate (Table (db "prod") "bar" (Just "name")) def{ tableDataCenter = Just "cloud", tableCacheSize = Just 10 } tableCreate :: Table -> TableCreateOptions -> ReQL tableCreate (O.Table mdb table_name pkey) opts =   withQuerySettings $ \QuerySettings{ queryDefaultDatabase = ddb } ->@@ -264,147 +487,273 @@       ("primary_key" :=) <$> pkey ]  -- | Drop a table+--+-- > >>> run' h $ tableDrop (table "bar")+-- > [{"dropped":1.0}] tableDrop :: Table -> ReQL tableDrop (O.Table mdb table_name _) =   withQuerySettings $ \QuerySettings{ queryDefaultDatabase = ddb } ->     op TABLE_DROP (fromMaybe ddb mdb, table_name) ()  -- | List the tables in a database+--+-- > >>> run h $ tableList (db "test") :: IO (Maybe [String])+-- > Just ["foo","posts","users"] tableList :: Database -> ReQL-tableList (O.Database name) = op TABLE_LIST [name] ()+tableList name = op TABLE_LIST [name] ()  -- | Get a document by primary key-get :: (Expr s, Expr k) => k -> s -> ReQL+--+-- > >>> run' h $ table "users" # get "8d674d7a-873c-4c0f-8a4a-32a4bd5bdee8"+-- > [{"post_count":0.0,"name":"nancy","id":"8d674d7a-873c-4c0f-8a4a-32a4bd5bdee8"}]+get :: Expr s => ReQL -> s -> ReQL get k e = op GET (e, k) ()  -- | Insert a document or a list of documents into a table-insert :: (Expr table, Expr object) => object -> table -> ReQL+--+-- > >>> Just wr@WriteResponse{} <- run h $ table "users" # insert (map (\x -> obj ["name":=x]) ["bill", "bob", "nancy" :: Text])+-- > >>> let Just [bill, bob, nancy] = writeResponseGeneratedKeys wr+-- > >>> run' h $ table "posts" # insert (obj ["author" := bill, "message" := str "hi"])+-- > >>> run' h $ table "posts" # insert (obj ["author" := bill, "message" := str "hello"])+-- > >>> run' h $ table "posts" # insert (obj ["author" := bob, "message" := str "lorem ipsum"])+insert :: (Expr object) => object -> Table -> ReQL insert a tb = canReturnVals $ op INSERT (tb, a) ()  -- | Like insert, but update existing documents with the same primary key+--+-- > >>> run' h $ table "users" # upsert (obj ["id" := "79bfe377-9593-402a-ad47-f94c76c36a51", "name" := "rupert"])+-- > [{"skipped":0.0,"inserted":0.0,"unchanged":0.0,"deleted":0.0,"replaced":1.0,"errors":0.0}] upsert :: (Expr table, Expr object) => object -> table -> ReQL upsert a tb = canReturnVals $ op INSERT (tb, a) ["upsert" := P.True]  -- | Add to or modify the contents of a document-update :: (Expr selection) => (ReQL -> ReQL) -> selection -> ReQL-update f s = canReturnVals $ op UPDATE (s, f) ()+--+-- > >>> run' h $ table "users" # getAll "name" [str "bob"] # update (const $ obj ["name" := str "benjamin"])+-- > [{"skipped":0.0,"inserted":0.0,"unchanged":0.0,"deleted":0.0,"replaced":1.0,"errors":0.0}]+update :: (Expr selection, Expr a) => (ReQL -> a) -> selection -> ReQL+update f s = canNonAtomic $ canReturnVals $ op UPDATE (s, expr . f) ()  -- | Replace a document with another-replace :: (Expr selection) => (ReQL -> ReQL) -> selection -> ReQL-replace f s = canReturnVals $ op REPLACE (s, f) ()+--+-- > >>> run' h $ replace (\bill -> obj ["name" := str "stoyan", "id" := bill!"id"]) . R.filter ((R.== str "bill") . (!"name")) $ table "users"+-- > [{"skipped":0.0,"inserted":0.0,"unchanged":0.0,"deleted":0.0,"replaced":1.0,"errors":0.0}]+replace :: (Expr selection, Expr a) => (ReQL -> a) -> selection -> ReQL+replace f s = canNonAtomic $ canReturnVals $ op REPLACE (s, expr . f) ()  -- | Delete the documents+--+-- > >>> run' h $ delete . getAll "name" [str "bob"] $ table "users"+-- > [{"skipped":0.0,"inserted":0.0,"unchanged":0.0,"deleted":1.0,"replaced":0.0,"errors":0.0}] delete :: (Expr selection) => selection -> ReQL delete s = canReturnVals $ op DELETE [s] ()  -- | Convert a value to a different type+--+-- > >>> run h $ coerceTo "STRING" 1 :: IO (Maybe String)+-- > Just "1" coerceTo :: (Expr x) => ReQL -> x -> ReQL coerceTo t a = op COERCE_TO (a, t) () --- | Convert a value to a different type-asArray, asString, asNumber, asObject, asBool :: Expr x => x -> ReQL+-- | Convert a value to an array+--+-- > >>> run h $ asArray $ obj ["a" := 1, "b" := 2] :: IO (Maybe [(String, Int)])+-- > Just [("a",1),("b",2)]+asArray :: Expr x => x -> ReQL asArray = coerceTo "ARRAY"++-- | Convert a value to a string+--+-- > >>> run h $ asString $ obj ["a" := 1, "b" := 2] :: IO (Maybe String)+-- > Just "{\n\t\"a\":\t1,\n\t\"b\":\t2\n}"+asString :: Expr x => x -> ReQL asString = coerceTo "STRING"++-- | Convert a value to a number+--+-- > >>> run h $ asNumber (str "34") :: IO (Maybe Int)+-- > Just 34+asNumber :: Expr x => x -> ReQL asNumber = coerceTo "NUMBER"++-- | Convert a value to an object+--+-- > >>> run' h $ asObject $ [(str "a",1),("b",2)]+-- > [{"a":1.0,"b":2.0}]+asObject :: Expr x => x -> ReQL asObject = coerceTo "OBJECT"++-- | Convert a value to a boolean+asBool :: Expr x => x -> ReQL asBool = coerceTo "BOOL"  -- | Like hasFields followed by pluck-withFields :: (Expr paths, Expr seq) => [paths] -> seq -> ReQL+--+-- > >>> run' h $ map obj [["a" := 1, "b" := 2], ["a" := 2, "c" := 7], ["b" := 4]] # withFields ["a"]+-- > [[{"a":1.0},{"a":2.0}]]+withFields :: Expr seq => [ReQL] -> seq -> ReQL withFields p s = op WITH_FIELDS (s, p) ()  -- | The position in the sequence of the elements that match the predicate+--+-- > >>> run h $ indexesOf (=~ "ba.") [str "foo", "bar", "baz"] :: IO (Maybe [Int])+-- > Just [1,2] indexesOf :: (Expr fun, Expr seq) => fun -> seq -> ReQL indexesOf f s = op INDEXES_OF (s, f) ()  -- | Test if a sequence is empty+--+-- > >>> run h $ isEmpty [1] :: IO (Maybe Bool)+-- > Just False isEmpty :: Expr seq => seq -> ReQL isEmpty s = op IS_EMPTY [s] ()  -- | Select a given number of elements from a sequence with uniform random distribution+--+-- > >>> run h $ sample 3 [0,1,2,3,4,5,6,7,8,9] :: IO (Maybe [Int])+-- > Just [4,3,8] sample :: (Expr n, Expr seq) => n -> seq -> ReQL sample n s = op SAMPLE (s, n) ()  -- | Prepend an element to an array+--+-- > >>> run h $ prepend 1 [2,3] :: IO (Maybe [Int])+-- > Just [1,2,3] prepend :: (Expr datum, Expr array) => datum -> array -> ReQL prepend d a = op PREPEND (a, d) () --- | Called /difference/ in the official drivers infixl 9 \\ --++-- | Called /difference/ in the official drivers+--+-- > >>> run h $ [1,2,3,4,5] \\ [2,5] :: IO (Maybe [Int])+-- > Just [1,3,4] (\\) :: (Expr a, Expr b) => a -> b -> ReQL a \\ b = op DIFFERENCE (a, b) ()  -- | Insert a datum into an array if it is not yet present+--+-- > >>> run h $ setInsert 3 [1,2,4,4,5] :: IO (Maybe [Int])+-- > Just [1,2,4,5,3] setInsert :: (Expr datum, Expr array) => datum -> array -> ReQL setInsert d a = op SET_INSERT (a, d) ()  -- | The union of two sets+--+-- > >>> run h $ [1,2] `setUnion` [2,3]  :: IO (Maybe [Int])+-- > Just [2,3,1] setUnion :: (Expr a, Expr b) => a -> b -> ReQL setUnion a b = op SET_UNION (b, a) ()  -- | The intersection of two sets+--+-- > >>> run h $ [1,2] `setIntersection` [2,3]  :: IO (Maybe [Int])+-- > Just [2] setIntersection :: (Expr a, Expr b) => a -> b -> ReQL setIntersection a b = op SET_INTERSECTION (b, a) ()  -- | The difference of two sets+--+-- > >>> run h $ [2,3] # setDifference [1,2]  :: IO (Maybe [Int])+-- > Just [3] setDifference :: (Expr set, Expr remove) => remove -> set -> ReQL setDifference r s = op SET_DIFFERENCE (s, r) ()  -- | Test if an object has the given fields-hasFields :: (Expr obj, Expr paths) => paths -> obj -> ReQL-hasFields p o = op HAS_FIELDS (o, p) ()+--+-- > >>> run h $ hasFields ["a"] $ obj ["a" := 1] :: IO (Maybe Bool)+-- > Just True+hasFields :: (Expr obj) => ReQL -> obj -> ReQL+hasFields p o = op HAS_FIELDS (o, expr p) ()  -- | Insert a datum at the given position in an array+--+-- > >>> run h $ insertAt 1 4 [1,2,3] :: IO (Maybe [Int])+-- > Just [1,4,2,3] insertAt :: (Expr n, Expr datum, Expr array) => n -> datum -> array -> ReQL insertAt n d a = op INSERT_AT (a, n, d) ()  -- | Splice an array at a given position inside another array+--+-- > >>> run h $ spliceAt 2 [4,5] [1,2,3] :: IO (Maybe [Int])+-- > Just [1,2,4,5,3] spliceAt :: (Expr n, Expr replace, Expr array) => n -> replace -> array -> ReQL spliceAt n s a = op SPLICE_AT (a, n, s) ()  -- | Delete an element from an array+--+-- > >>> run h $ deleteAt 1 [1,2,3] :: IO (Maybe [Int])+-- > Just [1,3] deleteAt :: (Expr n, Expr array) => n -> array -> ReQL deleteAt n a = op DELETE_AT (a, n) ()  -- | Change an element in an array+--+-- > >>> run h $ changeAt 1 4 [1,2,3] :: IO (Maybe [Int])+-- > Just [1,4,3] changeAt :: (Expr n, Expr datum, Expr array) => n -> datum -> array -> ReQL changeAt n d a = op CHANGE_AT (a, n, d) ()  -- | The list of keys of the given object+--+-- > >>> run h $ keys (obj ["a" := 1, "b" := 2]) :: IO (Maybe [String])+-- > Just ["a","b"] keys :: Expr obj => obj -> ReQL keys o = op KEYS [o] ()  -- | Match a string to a regular expression.+-- -- Called /match/ in the official drivers+--+-- > >>> run' h $ str "foobar" =~ "f(.)+[bc](.+)"+-- > [{"groups":[{"start":2.0,"end":3.0,"str":"o"},{"start":4.0,"end":6.0,"str":"ar"}],"start":0.0,"end":6.0,"str":"foobar"}] (=~) :: (Expr string) => string -> ReQL -> ReQL s =~ r = op MATCH (s, r) ()  -- | Apply a function to a list of arguments.+-- -- Called /do/ in the official drivers+--+-- > >>> run h $ (\x -> x R.* 2) `apply` [4] :: IO (Maybe Int)+-- > Just 8 apply :: (Expr fun, Expr arg) => fun -> [arg] -> ReQL f `apply` as = op FUNCALL (expr f : P.map expr as) ()  -- | Catch some expections inside the query.+-- -- Called /default/ in the official drivers+--+-- > >>> run h $ handle 0 $ obj ["a" := 1] ! "b" :: IO (Maybe Int)+-- > Just 0+-- > >>> run h $ handle (expr . id) $ obj ["a" := 1] ! "b" :: IO (Maybe String)+-- > Just "No attribute `b` in object:\n{\n\t\"a\":\t1\n}" handle :: (Expr handler, Expr reql) => handler -> reql -> ReQL handle h r = op DEFAULT (r, h) ()  -- | A string representing the type of an expression+--+-- > >>> run h $ typeOf 1 :: IO (Maybe String)+-- > Just "NUMBER" typeOf :: Expr a => a -> ReQL typeOf a = op TYPEOF [a] ()  -- | Get information on a given expression. Useful for tables and databases.+--+-- > >>> run' h $ info $ table "foo"+-- > [{"primary_key":"id","name":"foo","indexes":[],"type":"TABLE","db":{"name":"test","type":"DB"}}] info :: Expr a => a -> ReQL info a = op INFO [a] ()  -- | Parse a json string into an object-json :: Expr string => string -> ReQL+--+-- > >>> run' h $ json "{a:1}"+-- > [{"a":1.0}]+json :: ReQL -> ReQL json s = op JSON [s] () --- | Flipped function composition+-- | Flipped function application infixl 8 #-(#) :: (Expr a, Expr b) =>  a -> (ReQL -> b) -> ReQL-x # f = expr (f (expr x))+(#) :: (Expr a, Expr b) =>  a -> (a -> b) -> ReQL+x # f = expr (f x)  infixr 9 . -- | Specialised function composition
Database/RethinkDB/MapReduce.hs view
@@ -5,6 +5,7 @@ import Control.Monad.State import Control.Monad.Writer import qualified Data.Text as T+import Data.Maybe  import Database.RethinkDB.Protobuf.Ql2.Term.TermType import qualified Database.RethinkDB.Protobuf.Ql2.Datum as Datum@@ -13,16 +14,15 @@ import Database.RethinkDB.Objects  termToMapReduce ::-  (ReQL -> ReQL) -> State QuerySettings (ReQL -> ReQL, ReQL -> ReQL -> ReQL, ReQL -> ReQL)+  (ReQL -> ReQL) -> State QuerySettings (ReQL -> ReQL, ReQL -> ReQL -> ReQL, Maybe (ReQL -> ReQL)) termToMapReduce f = do   v <- newVarId   body <- baseReQL $ f (op VAR [v] ())-  let MapReduce map_ reduce finally = toMapReduce v body-  return (map_, reduce, finally)+  return . toReduce $ toMapReduce v body -toReduce :: MapReduce -> (ReQL -> ReQL, ReQL -> ReQL -> ReQL, ReQL -> ReQL)-toReduce (None t) = (\_ -> expr (), \_ _ -> expr (), const t)-toReduce (Map m) = ((\x -> expr [x]) . m, unionReduce, id)+toReduce :: MapReduce -> (ReQL -> ReQL, ReQL -> ReQL -> ReQL, Maybe (ReQL -> ReQL))+toReduce (None t) = (\_ -> expr (), \_ _ -> expr (), Just $ const t)+toReduce (Map m) = ((\x -> expr [x]) . m, unionReduce, Nothing) toReduce (MapReduce m r f) = (m, r, f)  unionReduce :: ReQL -> ReQL -> ReQL@@ -60,9 +60,9 @@               case (type', args', optargs') of                 (MAP, [Map m, None f], []) -> Map (toFun1 f . m)                 (REDUCE, [Map m, None f], _) | Just mbase <- optargsToBase optargs ->-                  MapReduce m (toFun2 f) (maybe id (toFun2 f) mbase)+                  MapReduce m (toFun2 f) (fmap (toFun2 f) mbase)                 (COUNT, [Map _], []) ->-                  MapReduce (const (num 1)) (\a b -> op ADD (a, b) ()) id+                  MapReduce (const (num 1)) (\a b -> op ADD (a, b) ()) Nothing                 (tt, (Map m : _), _) | tt `elem` mappableTypes ->                   (Map ((\x -> op tt (expr x : map expr (tail args)) (noRecurse : map baseAttrToAttr optargs)) . m))                 _ -> rebuild@@ -84,13 +84,13 @@ data MapReduce =     None ReQL |     Map (ReQL -> ReQL) |-    MapReduce (ReQL -> ReQL) (ReQL -> ReQL -> ReQL) (ReQL -> ReQL)+    MapReduce (ReQL -> ReQL) (ReQL -> ReQL -> ReQL) (Maybe (ReQL -> ReQL))  rebuild0 :: TermType -> [MapReduce] -> [(T.Text, MapReduce)] -> MapReduce rebuild0 ttype args optargs = MapReduce maps reduce finals where   (finally2, [mr]) = extract Nothing ttype args optargs   (maps, reduce, finally1) = toReduce mr-  finals = finally2 . finally1+  finals = Just $ maybe finally2 (finally2 .) finally1  rebuildx :: TermType -> [MapReduce] -> [(Key, MapReduce)] -> MapReduce rebuildx ttype args optargs = MapReduce maps reduces finallys where@@ -99,7 +99,11 @@   triplets = map toReduce mrs   maps x = expr $ map (($ x) . fst3) triplets   reduces a b = expr $ map (uncurry $ mkReduce a b) . index $ map snd3 triplets-  finallys x = finally $ expr $ map (uncurry $ mkFinally x) . index $ map thrd3 triplets+  finallys = let fs = map thrd3 triplets in+    if all isNothing fs+       then Just finally+       else Just $ \x -> finally $ expr $ map (uncurry $ mkFinally x) . index $+                         map (fromMaybe id) fs   mkReduce a b i f = f (op NTH (a, i) ()) (op NTH (b, i) ())   mkFinally x i f = f (op NTH (x, i) ())
Database/RethinkDB/Network.hs view
@@ -10,7 +10,6 @@   makeCursor,   next,   collect,-  stopResponse,   nextResponse,   Response(..),   SuccessCode(..),@@ -28,7 +27,7 @@ import qualified Data.ByteString.UTF8 as BS (fromString) import qualified Data.Text as T import Control.Concurrent (-  writeChan, MVar, Chan, modifyMVar, readMVar, forkIO, readChan,+  writeChan, MVar, Chan, modifyMVar, takeMVar, forkIO, readChan,   myThreadId, newMVar, ThreadId, newChan, killThread,   newEmptyMVar, putMVar, mkWeakMVar) import Data.Bits (shiftL, (.|.), shiftR)@@ -43,6 +42,7 @@ import Control.Monad.Fix (fix) import Data.Int (Int64) import System.IO.Unsafe (unsafeInterleaveIO)+import System.Mem.Weak (finalize)  import Text.ProtocolBuffers.Basic (uToString) import Text.ProtocolBuffers (messagePut, defaultValue, messageGet)@@ -68,7 +68,7 @@   rdbWriteLock :: MVar (Maybe SomeException),   rdbToken :: IORef Token, -- ^ The next token to use   rdbDatabase :: Database,  -- ^ The default database-  rdbWait :: IORef (Map Token (Chan Response, BaseReQL)),+  rdbWait :: IORef (Map Token (Chan Response, BaseReQL, IO ())),   rdbThread :: ThreadId   } @@ -130,7 +130,7 @@ -- | Convert a 4-byte byestring to an int unpackUInt :: ByteString -> Maybe Int unpackUInt s = case unpack s of-  [a,b,c,d] -> Just $ +  [a,b,c,d] -> Just $                fromIntegral a .|.                fromIntegral b `shiftL` 8 .|.                fromIntegral c `shiftL` 16 .|.@@ -205,7 +205,7 @@   where     bt = maybe [] convertBacktrace backtrace     r = toList response-    e = maybe "" uToString $ r_str =<< listToMaybe (toList response) +    e = maybe "" uToString $ r_str =<< listToMaybe (toList response)         -- TODO: nicer backtrace  runQLQuery :: RethinkDBHandle -> Query -> BaseReQL -> IO (MVar Response)@@ -218,12 +218,13 @@ addMBox :: RethinkDBHandle -> Token -> BaseReQL -> IO (MVar Response) addMBox h tok term = do   chan <- newChan-  atomicModifyIORef' (rdbWait h) $ \mboxes -> -    (M.insert tok (chan, term) mboxes, ())   mbox <- newEmptyMVar-  _ <- mkWeakMVar mbox $ do-    atomicModifyIORef' (rdbWait h) $ \mboxes -> +  weak <- mkWeakMVar mbox $ do+    closeToken h tok+    atomicModifyIORef' (rdbWait h) $ \mboxes ->       (M.delete tok mboxes, ())+  atomicModifyIORef' (rdbWait h) $ \mboxes ->+    (M.insert tok (chan, term, finalize weak) mboxes, ())   _ <- forkIO $ fix $ \loop -> do     response <- readChan chan     putMVar mbox response@@ -248,6 +249,7 @@   tid <- myThreadId   let h = h' tid   let handler e@SomeException{} = do+        hClose $ rdbHandle h         modifyMVar (rdbWriteLock h) $ \_ -> return (Just e, ())         writeIORef (rdbWait h) M.empty   flip catch handler $ forever $ readSingleResponse h@@ -264,7 +266,7 @@     Left errMsg -> fail errMsg     Right (response, rest)       | B.null rest -> dispatch (Ql2.token response) response-      | otherwise -> fail "readsingleResponse: invalid reply length"+      | otherwise -> fail "readSingleResponse: invalid reply length"    where   dispatch Nothing _ = return ()@@ -272,11 +274,10 @@     mboxes <- readIORef $ rdbWait h     case M.lookup tok mboxes of       Nothing -> return ()-      Just (mbox, term) -> do+      Just (mbox, term, closetok) -> do         let convertedResponse = convertResponse h term tok response         writeChan mbox convertedResponse-        when (isLastResponse convertedResponse) $-          atomicModifyIORef' (rdbWait h) $ \m -> (M.delete tok m, ())+        when (isLastResponse convertedResponse) $ closetok  isLastResponse :: Response -> Bool isLastResponse ErrorResponse{} = True@@ -309,11 +310,10 @@ convertDatum Datum { type' = Just R_NUM, r_num = Just n } = toJSON n convertDatum d = error ("Invalid Datum: " ++ show d) -stopResponse :: Response -> IO ()-stopResponse SuccessResponse { successCode = SuccessPartial h tok } = do+closeToken :: RethinkDBHandle -> Token -> IO ()+closeToken h tok = do   let query = defaultValue { Query.type' = Just STOP, Query.token = Just tok}   sendQLQuery h query-stopResponse _ = return ()  nextResponse :: Response -> IO () nextResponse SuccessResponse { successCode = SuccessPartial h tok } = do@@ -338,7 +338,7 @@  cursorFetchBatch :: Cursor a -> IO (Either RethinkDBError ([O.Datum], Bool)) cursorFetchBatch c = do-  response <- readMVar (cursorMBox c)+  response <- takeMVar (cursorMBox c)   case response of     ErrorResponse e -> return $ Left e     SuccessResponse Success datums -> return $ Right (datums, True)
Database/RethinkDB/NoClash.hs view
@@ -6,10 +6,12 @@   -- module Prelude, module Data.Time -- Uncomment to let GHC detect clashes   ) where -import Data.Time+-- Uncomment imports to let GHC detect clashes+--import Data.Time  import Database.RethinkDB hiding (   UTCTime, ZonedTime,   (*), (+), (-), (/),   sum, (++), (.), map, mod, (!!), concatMap, drop, length, take, (&&),-  not, (||), (/=), (<), (<=), (>), (>=), error, (==), filter)+  not, (||), (/=), (<), (<=), (>), (>=), error, (==), filter,+  elem)
Database/RethinkDB/Objects.hs view
@@ -1,6 +1,7 @@ module Database.RethinkDB.Objects (   Database(..),   TableCreateOptions(..),+  IndexCreateOptions(..),   Table(..),   Datum,   Key@@ -29,6 +30,14 @@  instance Default TableCreateOptions where   def = TableCreateOptions Nothing Nothing++-- | Options used to create an index+data IndexCreateOptions = IndexCreateOptions {+  indexMulti :: Maybe Bool+  }++instance Default IndexCreateOptions where+  def = IndexCreateOptions Nothing  -- | A table description data Table = Table {
Database/RethinkDB/ReQL.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE ExistentialQuantification, RecordWildCards, ScopedTypeVariables,-             FlexibleInstances, OverloadedStrings, PatternGuards #-}+             FlexibleInstances, OverloadedStrings, PatternGuards, GADTs #-}  -- | Building RQL queries in Haskell module Database.RethinkDB.ReQL (@@ -23,8 +23,12 @@   Object(..),   Obj(..),   returnVals,+  nonAtomic,   canReturnVals,-  reqlToProtobuf+  canNonAtomic,+  reqlToProtobuf,+  Bound(..),+  closedOrOpen   ) where  import qualified Data.Vector as V@@ -76,11 +80,12 @@   queryDefaultDatabase :: Database,   queryVarIndex :: Int,   queryUseOutdated :: Maybe Bool,-  queryReturnVals :: Maybe Bool+  queryReturnVals :: Maybe Bool,+  queryAtomic :: Maybe Bool   }  instance Default QuerySettings where-  def = QuerySettings 0 (Database "") 0 Nothing Nothing+  def = QuerySettings 0 (Database "") 0 Nothing Nothing Nothing  withQuerySettings :: (QuerySettings -> ReQL) -> ReQL withQuerySettings f = ReQL $ (baseReQL . f) =<< get@@ -95,6 +100,16 @@   put state'{ queryReturnVals = queryReturnVals state }   return ret +-- | Allow non-atomic replace+nonAtomic :: ReQL -> ReQL+nonAtomic (ReQL t) = ReQL $ do+  state <- get+  put state{ queryAtomic = Just False }+  ret <- t+  state' <- get+  put state'{ queryAtomic = queryAtomic state }+  return ret+ canReturnVals :: ReQL -> ReQL canReturnVals (ReQL t) = ReQL $ t >>= \ret -> do   qs <- get@@ -103,6 +118,14 @@     Just rv -> return ret{       termOptArgs = BaseAttribute "return_vals" (baseBool rv) : termOptArgs ret } +canNonAtomic :: ReQL -> ReQL+canNonAtomic (ReQL t) = ReQL $ t >>= \ret -> do+  qs <- get+  case queryAtomic qs of+    Nothing -> return ret+    Just atomic -> return ret{+      termOptArgs = BaseAttribute "non_atomic" (baseBool $ not atomic) : termOptArgs ret }+ baseBool :: Bool -> BaseReQL baseBool b = BaseReQL DATUM (Just defaultValue{                                 Datum.type' = Just R_BOOL, r_bool = Just b }) [] []@@ -189,6 +212,8 @@ -- | A list of key/value pairs data Object = Object { baseObject :: State QuerySettings [BaseAttribute] } +infix 0 :=+ -- | A key/value pair used for building objects data Attribute = forall e . (Expr e) => T.Text := e @@ -300,6 +325,8 @@   fromInteger x = datumTerm R_NUM defaultValue { r_num = Just (fromInteger x) }   a + b = op ADD (a, b) ()   a * b = op MUL (a, b) ()+  a - b = op SUB (a, b) ()+  negate a = op SUB (0 :: Double, a) ()   abs n = op BRANCH (op TermType.LT (n, 0 :: Double) (), negate n, n) ()   signum n = op BRANCH (op TermType.LT (n, 0 :: Double) (),                         -1 :: Double,@@ -317,16 +344,16 @@ instance IsString ReQL where   fromString s = datumTerm R_STR defaultValue { r_str = Just (uFromString $ s) } -instance Expr (ReQL -> ReQL) where+instance (a ~ ReQL) => Expr (a -> ReQL) where   expr f = ReQL $ do     v <- newVarId-    baseReQL $ op FUNC (datumNumberArray [v], f (op VAR [v] ())) ()+    baseReQL $ op FUNC (datumNumberArray [v], expr $ f (op VAR [v] ())) () -instance Expr (ReQL -> ReQL -> ReQL) where+instance (a ~ ReQL, b ~ ReQL) => Expr (a -> b -> ReQL) where   expr f = ReQL $ do     a <- newVarId     b <- newVarId-    baseReQL $ op FUNC (datumNumberArray [a, b], f (op VAR [a] ()) (op VAR [b] ())) ()+    baseReQL $ op FUNC (datumNumberArray [a, b], expr $ f (op VAR [a] ()) (op VAR [b] ())) ()  instance Expr Datum.Datum where   expr d = ReQL $ return $ BaseReQL DATUM (Just d) [] []@@ -431,3 +458,24 @@  instance Expr BaseReQL where   expr = ReQL . return++-- | An upper or lower bound for between and during+data Bound a =+  Open { getBound :: a } -- ^ An inclusive bound+  | Closed { getBound :: a } -- ^ An exclusive bound++closedOrOpen :: Bound a -> T.Text+closedOrOpen Open{} = "open"+closedOrOpen Closed{} = "closed"++instance (Expr a, Expr b) => Expr (a, b) where+  expr (a, b) = expr [expr a, expr b]++instance (Expr a, Expr b, Expr c) => Expr (a, b, c) where+  expr (a, b, c) = expr [expr a, expr b, expr c]++instance (Expr a, Expr b, Expr c, Expr d) => Expr (a, b, c, d) where+  expr (a, b, c, d) = expr [expr a, expr b, expr c, expr d]++instance (Expr a, Expr b, Expr c, Expr d, Expr e) => Expr (a, b, c, d, e) where+  expr (a, b, c, d, e) = expr [expr a, expr b, expr c, expr d, expr e]
Database/RethinkDB/Time.hs view
@@ -2,7 +2,6 @@  module Database.RethinkDB.Time where -import Data.Text (Text) import qualified  Data.Time as Time import qualified  Data.Time.Clock.POSIX as Time import Data.Aeson as JSON@@ -15,37 +14,47 @@ import Database.RethinkDB.Protobuf.Ql2.Term.TermType  -- | The time and date when the query is executed+--+-- > >>> run h $ now :: IO (Maybe R.ZonedTime)+-- > Just 2013-10-28 00:01:43.930000066757 +0000 now :: ReQL now = op NOW () ()  -- | Build a time object from the year, month, day, hour, minute, second and timezone fields+--+-- > >>> run h $ time 2011 12 24 23 59 59 "Z" :: IO (Maybe R.ZonedTime)+-- > Just 2011-12-24 23:59:59 +0000 time :: ReQL -> ReQL -> ReQL -> ReQL -> ReQL -> ReQL -> ReQL -> ReQL time y m d hh mm ss tz = op TIME [y, m, d, hh, mm, ss, tz] ()  -- | Build a time object given the number of seconds since the unix epoch+--+-- > >>> run h $ epochTime 1147162826 :: IO (Maybe R.ZonedTime)+-- > Just 2006-05-09 08:20:26 +0000 epochTime :: ReQL -> ReQL epochTime t = op EPOCH_TIME [t] ()  -- | Build a time object given an iso8601 string+--+-- > >>> run h $ iso8601 "2012-01-07T08:34:00-0700" :: IO (Maybe R.UTCTime)+-- > Just 2012-01-07 15:34:00 UTC iso8601 :: ReQL -> ReQL iso8601 t = op ISO8601 [t] ()  -- | The same time in a different timezone+--+-- > >>> run h $ inTimezone "+0800" now :: IO (Maybe R.ZonedTime)+-- > Just 2013-10-28 08:16:39.22000002861 +0800 inTimezone :: Expr time => ReQL -> time -> ReQL inTimezone tz t = op IN_TIMEZONE (t, tz) () -data Bound a =-  Open { boundValue ::  a } |-  Closed { boundValue :: a }--boundString :: Bound a -> Text-boundString Open{} = "open"-boundString Closed{} = "closed"- -- | Test if a time is between two other times+--+-- > >>> run h $ during (Open $ now - (60*60)) (Closed now) $ epochTime 1382919271 :: IO (Maybe Bool)+-- > Just True during :: (Expr left, Expr right, Expr time) => Bound left -> Bound right -> time -> ReQL-during l r t = op DURING (t, boundValue l, boundValue r) [-  "left_bound" := boundString l, "right_bound" := boundString r]+during l r t = op DURING (t, getBound l, getBound r) [+  "left_bound" := closedOrOpen l, "right_bound" := closedOrOpen r]  -- | Extract part of a time value timezone, date, timeOfDay, year, month, day, dayOfWeek, dayOfYear, hours, minutes, seconds ::@@ -68,12 +77,20 @@ toEpochTime t = op TO_EPOCH_TIME [t] ()  -- | Time with no time zone+-- -- The default FromJSON instance for Data.Time.UTCTime is incompatible with ReQL's time type newtype UTCTime = UTCTime Time.UTCTime +instance Show UTCTime where+  show (UTCTime t) = show t+ -- | Time with a time zone+-- -- The default FromJSON instance for Data.Time.ZonedTime is incompatible with ReQL's time type newtype ZonedTime = ZonedTime Time.ZonedTime++instance Show ZonedTime where+  show (ZonedTime t) = show t  instance FromJSON UTCTime where   parseJSON (JSON.Object v) = UTCTime . Time.posixSecondsToUTCTime . fromRational <$> v .: "epoch_time"
rethinkdb.cabal view
@@ -1,5 +1,5 @@ name:                rethinkdb-version:             1.8.0.4+version:             1.8.0.5 description:         RethinkDB is a distributed document store with a powerful query language. synopsis:            RethinkDB driver for Haskell homepage:            http://github.com/atnnn/haskell-rethinkdb