content: {-# LANGUAGE OverloadedStrings, FlexibleInstances, DefaultSignatures, GADTs, CPP #-}
  
  module Database.RethinkDB.Driver (
    run,
    run',
    Result(..),
    runOpts,
    RunFlag(..),
    Durability(..),
    durability,
    WriteResponse(..),
    Change(..)
    ) where
  
  import qualified Data.Aeson as J
  import Control.Monad
  import Control.Concurrent.MVar (MVar, takeMVar)
  import Data.Text (Text)
  #if __GLASGOW_HASKELL__ < 710
  import Control.Applicative ((<$>), (<*>))
  #endif
  import Data.List
  import Data.Maybe
  import Control.Exception (throwIO)
  import qualified Data.Map as Map
  import qualified Data.Set as Set
  import Data.Time
  import qualified Data.Text as ST
  import qualified Data.Text.Lazy as LT
  import qualified Data.ByteString as SB
  import qualified Data.ByteString.Lazy as LB
  import Data.Int
  import Data.Word
  import qualified Data.HashMap.Strict as HM
  import Data.Ratio
  import qualified Data.Vector as V
  
  import Database.RethinkDB.Datum hiding (Result)
  import Database.RethinkDB.Network
  import Database.RethinkDB.ReQL
  
  -- $setup
  -- >>> :set -XOverloadedStrings
  -- >>> :load Database.RethinkDB.NoClash
  -- >>> import qualified Database.RethinkDB as R
  -- >>> import Control.Exception
  -- >>> import Data.Text
  -- >>> let try' x = (try x `asTypeOf` return (Left (undefined :: SomeException))) >> return ()
  -- >>> h <- fmap (use "doctests") $ connect "localhost" 28015 def
  -- >>> try' $ run' h $ dbCreate "doctests"
  -- >>> try' $ run' h $ tableCreate (table "users"){ tablePrimaryKey = Just "name" }
  -- >>> try' $ run' h $ delete $ table "users"
  -- >>> run h $ table "users" # insert (R.map (\x -> ["name":=x]) ["bill", "bob", "nancy" :: Text]) :: IO WriteResponse
  -- {inserted:3}
  
  
  -- | Per-query settings
  data RunFlag =
    UseOutdated | -- ^ Deprecated. Use `ReadMode Outdated` instead
    ReadMode ReadMode |
    NoReply |
    Durability Durability |
    Profile |
    ArrayLimit Int
  
  data ReadMode = Majority | Single | Outdated
  
  data Durability = Hard | Soft
  
  instance Expr Durability where
    expr Hard = "hard"
    expr Soft = "soft"
  
  -- | Optional argument for soft durability writes
  durability :: Durability -> Attribute a
  durability d = "durability" := d
  
  renderOption :: RunFlag -> (Text, Datum)
  renderOption UseOutdated = "read_mode" .= ("outdated" :: String)
  renderOption (ReadMode Majority) = "read_mode" .= ("majority" :: String)
  renderOption (ReadMode Single) = "read_mode" .= ("single" :: String)
  renderOption (ReadMode Outdated) = "read_mode" .= ("outdated" :: String)
  renderOption NoReply = "noreply" .= True
  renderOption (Durability Soft) = "durability" .= ("soft" :: String)
  renderOption (Durability Hard) = "durability" .= ("hard" :: String)
  renderOption Profile = "profile" .= True
  renderOption (ArrayLimit n) = "array_limit" .= n
  
  -- | Run a query with the given options
  runOpts :: (Expr query, Result r) => RethinkDBHandle -> [RunFlag] -> query -> IO r
  runOpts h opts t = do
    let (q, bt) = buildQuery (expr t) 0 (rdbDatabase h) (map renderOption opts)
    r <- runQLQuery h q bt
    convertResult r
  
  -- | Run a given query and return a Result
  --
  -- >>> run h $ num 1 :: IO Int
  -- 1
  --
  -- > >>> run h $ str "foo" :: IO (Either RethinkDBError Int)
  -- *** Exception: RethinkDB: Unexpected response: "expected Int, encountered String"
  --
  -- >>> run h $ str "foo" :: IO (Maybe Int)
  -- Nothing
  --
  -- > >>> run h $ str "foo" :: IO Int
  -- *** Exception: RethinkDB: Unexpected response: "expected Int, encountered String"
  --
  -- >>> c <- run h $ table "users" # orderBy [asc "name"] # (!"name"):: IO (Cursor Datum)
  -- >>> next c
  -- Just "bill"
  -- >>> collect c
  -- ["bob","nancy"]
  run :: (Expr query, Result r) => RethinkDBHandle -> query -> IO r
  run h = runOpts h []
  
  -- | Run a given query and return a Datum
  run' :: Expr query => RethinkDBHandle -> query -> IO Datum
  run' = run
  
  -- | Convert the raw query response into useful values
  class Result r where
    convertResult :: MVar Response -> IO r
    default convertResult :: FromDatum r => MVar Response -> IO r
    convertResult = unsafeFromDatum <=< convertResult
  
  instance Result Response where
    convertResult = takeMVar
  
  instance FromDatum a => Result (Cursor a) where
    convertResult r = do
      c <- makeCursor r
      return c { cursorMap = unsafeFromDatum }
  
  unsafeFromDatum :: FromDatum a => Datum -> IO a
  unsafeFromDatum val = case fromDatum val of
    Error e -> throwIO (RethinkDBError ErrorUnexpectedResponse (Datum Null) e [])
    Success a -> return a
  
  instance FromDatum a => Result [a] where
    convertResult = collect <=< convertResult
  
  instance (FromDatum b, a ~ RethinkDBError) => Result (Either a b) where
    convertResult v = do
      r <- takeMVar v
      ed <- case r of
                 ResponseSingle Null -> return $ Right Null
                 ResponseSingle b -> return $ Right b
                 ResponseError a -> return $ Left a
                 ResponseBatch Nothing batch -> return $ Right $ toDatum batch
                 ResponseBatch (Just _more) batch -> do
                        rest <- collect' =<< convertResult v
                        return $ Right $ toDatum $ batch ++ rest
      case ed of
        Left a -> return $ Left a
        Right d -> case fromDatum d of
          Success b -> return $ Right b
          Error a -> return $ Left $ RethinkDBError ErrorUnexpectedResponse (Datum Null) a []
  
  instance FromDatum a => Result (Maybe a) where
    convertResult v = do
        ed <- convertResult v
        case ed of
          Left _ -> return Nothing
          Right Null -> return Nothing
          Right d -> case fromDatum d of
                       Success a -> return $ Just a
                       Error _ -> return $ Nothing
  
  instance Result Int
  instance Result Double
  instance Result Bool
  
  instance Result () where
    convertResult m = do
      _ <- takeMVar m
      return ()
  
  instance Result J.Value
  instance Result Char
  instance Result Float
  instance Result Int8
  instance Result Int16
  instance Result Int32
  instance Result Int64
  instance Result Word
  instance Result Word8
  instance Result Word16
  instance Result Word32
  instance Result Word64
  instance Result Integer
  instance Result LB.ByteString
  instance Result SB.ByteString
  instance Result LT.Text
  instance Result ST.Text
  instance Result ZonedTime
  instance Result UTCTime
  instance (Ord a, FromDatum a) => Result (Set.Set a)
  instance FromDatum a => Result (V.Vector a)
  instance FromDatum a => Result (HM.HashMap [Char] a)
  instance FromDatum a => Result (HM.HashMap ST.Text a)
  instance FromDatum a => Result (Map.Map [Char] a)
  instance FromDatum a => Result (Map.Map ST.Text a)
  instance Result (Ratio Integer)
  instance Result LonLat
  
  nextFail :: FromDatum a => Cursor Datum -> IO a
  nextFail c = do
    x <- next c
    case x of
      Nothing -> throwIO $ RethinkDBError ErrorUnexpectedResponse (Datum Null) "Not enough data" []
      Just a -> case fromDatum a of
        Success b -> return b
        Error e -> throwIO $ RethinkDBError ErrorUnexpectedResponse (Datum Null) e []
  
  assertEnd :: Cursor a -> IO ()
  assertEnd c = do
    x <- next c
    case x of
      Nothing -> return ()
      Just _ -> throwIO $ RethinkDBError ErrorUnexpectedResponse (Datum Null) "Too much data" []
  
  instance (FromDatum a, FromDatum b) => Result (a, b) where
    convertResult r = do
      c <- convertResult r
      a <- nextFail c
      b <- nextFail c
      assertEnd c
      return (a, b)
  
  instance (FromDatum a, FromDatum b, FromDatum c) => Result (a, b, c) where
    convertResult r = do
      c <- convertResult r
      a <- nextFail c
      b <- nextFail c
      c_ <- nextFail c
      assertEnd c
      return (a, b, c_)
  
  instance (FromDatum a, FromDatum b, FromDatum c, FromDatum d) => Result (a, b, c, d) where
    convertResult r = do
      c <- convertResult r
      a <- nextFail c
      b <- nextFail c
      c_ <- nextFail c
      d <- nextFail c
      assertEnd c
      return (a, b, c_, d)
  
  instance (FromDatum a, FromDatum b, FromDatum c, FromDatum d, FromDatum e) => Result (a, b, c, d, e) where
    convertResult r = do
      c <- convertResult r
      a <- nextFail c
      b <- nextFail c
      c_ <- nextFail c
      d <- nextFail c
      e <- nextFail c
      assertEnd c
      return (a, b, c_, d, e)
  
  instance Result Datum where
    convertResult v = do
      r <- takeMVar v
      case r of
        ResponseSingle datum -> return datum
        ResponseError e -> throwIO e
        ResponseBatch Nothing batch -> return $ toDatum batch
        ResponseBatch (Just _more) batch -> do
          rest <- collect' =<< convertResult v
          return . toDatum $ batch ++ rest
  
  instance Result WriteResponse
  
  data WriteResponse = WriteResponse {
    writeResponseInserted :: Int,
    writeResponseDeleted :: Int,
    writeResponseReplaced :: Int,
    writeResponseUnchanged :: Int,
    writeResponseSkipped :: Int,
    writeResponseErrors :: Int,
    writeResponseFirstError :: Maybe Text,
    writeResponseGeneratedKeys :: Maybe [Text],
    writeResponseChanges :: Maybe [Change]
    }
  
  data Change = Change { oldVal, newVal :: Datum }
  
  instance Show Change where
    show (Change old new) = "{\"old_val\":" ++ show old ++ ",\"new_val\":" ++ show new ++ "}"
  
  instance FromDatum Change where
    parseDatum (Object o) =
      Change <$> o .: "old_val" <*> o .: "new_val"
    parseDatum _ = mzero
  
  instance FromDatum WriteResponse where
    parseDatum (Object o) =
      WriteResponse
      <$> o .: "inserted"
      <*> o .: "deleted"
      <*> o .: "replaced"
      <*> o .: "unchanged"
      <*> o .: "skipped"
      <*> o .: "errors"
      <*> o .:? "first_error"
      <*> o .:? "generated_keys"
      <*> o .:? "changes"
    parseDatum _ = mzero
  
  instance Show WriteResponse where
    show wr = "{" ++
              intercalate "," (catMaybes [
                zero "inserted" writeResponseInserted,
                zero "deleted" writeResponseDeleted,
                zero "replaced" writeResponseReplaced,
                zero "unchanged" writeResponseUnchanged,
                zero "skipped" writeResponseSkipped,
                zero "errors" writeResponseErrors,
                nothing "first_error" writeResponseFirstError,
                nothing "generated_keys" writeResponseGeneratedKeys,
                nothing "changes" writeResponseChanges ]) ++
              "}"
      where
        go :: Show a => String -> a -> Maybe String
        go k v = Just $ k ++ ":" ++ show v
        zero k f = if f wr == 0 then Nothing else go k (f wr)
        nothing :: Show a => String -> (WriteResponse -> Maybe a) -> Maybe String
        nothing k f = maybe Nothing (go k) (f wr)
  
  -- TODO: profile
  