{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Database.RethinkDB.Types where


import           Control.Applicative
import           Control.Monad
import           Control.Monad.State (State, gets, modify, evalState)

import           Data.Function
import           Data.Word
import           Data.String
import           Data.Text           (Text)
import           Data.Time
import           System.Locale       (defaultTimeLocale)
import           Data.Time.Clock.POSIX

import           Data.Aeson          ((.:), (.=), FromJSON, parseJSON, toJSON)
import           Data.Aeson.Types    (Parser, Value)
import qualified Data.Aeson          as A

import           Data.Vector         (Vector)
import qualified Data.Vector         as V
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HMS

import           GHC.Generics



------------------------------------------------------------------------------
-- | A Term is a JSON expression which can be sent to the server. Building a
-- term is a stateful operation, so the whole process happens inside a 'State'
-- monad.

class Term a where
    toTerm :: a -> State Context A.Value

instance Term A.Value where
    toTerm = return



------------------------------------------------------------------------------
-- | A class describing a type which can be converted to the RethinkDB-specific
-- wire protocol. It is based on JSON, but certain types use a presumably more
-- efficient encoding.

class FromRSON a where
    parseRSON :: A.Value -> Parser a

------------------------------------------------------------------------------
-- | See 'FromRSON'.

class ToRSON a where
    toRSON :: a -> A.Value



------------------------------------------------------------------------------
-- | Building a RethinkDB query from an expression is a stateful process, and
-- is done using this as the context.

data Context = Context
    { varCounter :: Int
      -- ^ How many 'Var's have been allocated. See 'newVar'.
    }


compileTerm :: State Context A.Value -> A.Value
compileTerm e = evalState e (Context 0)


-- | Allocate a new var index from the context.
newVar :: State Context Int
newVar = do
    ix <- gets varCounter
    modify $ \s -> s { varCounter = ix + 1 }
    return ix



------------------------------------------------------------------------------
-- | A sumtype covering all the primitive types which can appear in queries
-- or responses.

data Datum
    = Null
    | Bool   !Bool
    | Number !Double
    | String !Text
    | Array  !(Array Datum)
    | Object !Object
    | Time   !ZonedTime
    deriving (Show, Generic)


class (Term a) => IsDatum a


instance IsDatum Datum

-- | We can't automatically derive 'Eq' because 'ZonedTime' does not have an
-- instance of 'Eq'. See the 'eqTime' function for why we can compare times.
instance Eq Datum where
    (Null    ) == (Null    ) = True
    (Bool   x) == (Bool   y) = x == y
    (Number x) == (Number y) = x == y
    (String x) == (String y) = x == y
    (Array  x) == (Array  y) = x == y
    (Object x) == (Object y) = x == y
    (Time   x) == (Time   y) = x `eqTime` y
    _          == _          = False

instance ToRSON Datum where
    toRSON (Null    ) = A.Null
    toRSON (Bool   x) = toRSON x
    toRSON (Number x) = toRSON x
    toRSON (String x) = toRSON x
    toRSON (Array  x) = toRSON x
    toRSON (Object x) = toRSON x
    toRSON (Time   x) = toRSON x

instance FromRSON Datum where
    parseRSON   (A.Null    ) = pure Null
    parseRSON   (A.Bool   x) = pure $ Bool x
    parseRSON   (A.Number x) = pure $ Number (realToFrac x)
    parseRSON   (A.String x) = pure $ String x
    parseRSON   (A.Array  x) = Array <$> V.mapM parseRSON x
    parseRSON a@(A.Object x) = (Time <$> parseRSON a) <|> do
        -- HashMap does not provide a mapM, what a shame :(
        items <- mapM (\(k, v) -> (,) <$> pure k <*> parseRSON v) $ HMS.toList x
        return $ Object $ HMS.fromList items

instance Term Datum where
    toTerm = return . toRSON

instance FromResponse Datum where
    parseResponse = responseAtomParser



------------------------------------------------------------------------------
-- | For a boolean type, we're reusing the standard Haskell 'Bool' type.

instance IsDatum Bool

instance FromResponse Bool where
    parseResponse = responseAtomParser

instance FromRSON Bool where
    parseRSON = parseJSON

instance ToRSON Bool where
    toRSON = toJSON

instance Term Bool where
    toTerm = return . toRSON



------------------------------------------------------------------------------
-- | Numbers are 'Double' (unlike 'Aeson', which uses 'Scientific'). No
-- particular reason.

instance IsDatum Double

instance FromResponse Double where
    parseResponse = responseAtomParser

instance FromRSON Double where
    parseRSON = parseJSON

instance ToRSON Double where
    toRSON = toJSON

instance Term Double where
    toTerm = return . toRSON



------------------------------------------------------------------------------
-- | For strings, we're using the Haskell 'Text' type.

instance IsDatum Text

instance FromResponse Text where
    parseResponse = responseAtomParser

instance FromRSON Text where
    parseRSON = parseJSON

instance ToRSON Text where
    toRSON = toJSON

instance Term Text where
    toTerm = return . toRSON



------------------------------------------------------------------------------
-- | Arrays are vectors of 'Datum'.

type Array a = Vector a

instance (IsDatum a) => IsDatum    (Array a)
instance (IsDatum a) => IsSequence (Array a)

instance (FromRSON a) => FromResponse (Array a) where
    parseResponse = responseAtomParser

-- Arrays are encoded as a term MAKE_ARRAY (2).
instance (ToRSON a) => ToRSON (Array a) where
    toRSON v = A.Array $ V.fromList $
        [ A.Number 2
        , toJSON $ map toRSON (V.toList v)
        , toJSON $ toRSON emptyOptions
        ]

instance (FromRSON a) => FromRSON (Array a) where
    parseRSON (A.Array v) = V.mapM parseRSON v
    parseRSON _           = fail "Array"

instance (Term a) => Term (Array a) where
    toTerm v = do
        vals    <- mapM toTerm (V.toList v)
        options <- toTerm emptyOptions
        return $ A.Array $ V.fromList $
            [ A.Number 2
            , toJSON vals
            , toJSON $ options
            ]



------------------------------------------------------------------------------
-- | Objects are maps from 'Text' to 'Datum'. Like 'Aeson', we're using
-- 'HashMap'.

type Object = HashMap Text Datum


class (Term a, IsDatum a) => IsObject a


instance IsDatum  Object
instance IsObject Object

instance FromResponse Object where
    parseResponse = responseAtomParser

instance FromRSON Object where
    parseRSON (A.Object o) = do
        -- HashMap does not provide a mapM, what a shame :(
        items <- mapM (\(k, v) -> (,) <$> pure k <*> parseRSON v) $ HMS.toList o
        return $ HMS.fromList items

    parseRSON _            = fail "Object"

instance ToRSON Object where
    toRSON = A.Object . HMS.map toRSON

instance Term Object where
    toTerm = return . toRSON



------------------------------------------------------------------------------
-- | Time in RethinkDB is represented similar to the 'ZonedTime' type. Except
-- that the JSON representation on the wire looks different from the default
-- used by 'Aeson'. Therefore we have a custom 'FromRSON' and 'ToRSON'
-- instances.

instance IsDatum  ZonedTime
instance IsObject ZonedTime

instance FromResponse ZonedTime where
    parseResponse = responseAtomParser

instance ToRSON ZonedTime where
    toRSON t = A.object
        [ "$reql_type$" .= ("TIME" :: Text)
        , "timezone"    .= (timeZoneOffsetString $ zonedTimeZone t)
        , "epoch_time"  .= (realToFrac $ utcTimeToPOSIXSeconds $ zonedTimeToUTC t :: Double)
        ]

instance FromRSON ZonedTime where
    parseRSON (A.Object o) = do
        reqlType <- o .: "$reql_type$"
        guard $ reqlType == ("TIME" :: Text)

        -- Parse the timezone using 'parseTime'. This overapproximates the
        -- possible responses from the server, but better than rolling our
        -- own timezone parser.
        tz <- o .: "timezone" >>= \tz -> case parseTime defaultTimeLocale "%Z" tz of
            Just d -> pure d
            _      -> fail "Could not parse TimeZone"

        t <- o .: "epoch_time" :: Parser Double
        return $ utcToZonedTime tz $ posixSecondsToUTCTime $ realToFrac t

    parseRSON _           = fail "Time"

instance Term ZonedTime where
    toTerm = return . toRSON



-- | Comparing two times is done on the local time, regardless of the timezone.
-- This is exactly how the RethinkDB server does it.
eqTime :: ZonedTime -> ZonedTime -> Bool
eqTime = (==) `on` zonedTimeToUTC



------------------------------------------------------------------------------
-- UTCTime

instance IsDatum  UTCTime
instance IsObject UTCTime

instance FromResponse UTCTime where
    parseResponse = responseAtomParser

instance ToRSON UTCTime where
    toRSON = toRSON . utcToZonedTime utc

instance FromRSON UTCTime where
    parseRSON v = zonedTimeToUTC <$> parseRSON v

instance Term UTCTime where
    toTerm = return . toRSON

instance Lift Exp UTCTime where
    type Simplified UTCTime = ZonedTime
    lift = Constant . utcToZonedTime utc



------------------------------------------------------------------------------
-- | Tables are something you can select objects from.
--
-- This type is not exported, and merely serves as a sort of phantom type. On
-- the client tables are converted to a 'Sequence'.

data Table = MkTable

instance IsSequence Table

instance ToRSON Table where
    toRSON = error "toRSON Table: Server-only type"

instance Term Table where
    toTerm = error "toTerm Table: Server-only type"



------------------------------------------------------------------------------
-- | 'SingleSelection' is essentially a 'Maybe Object', where 'Nothing' is
-- represented with 'Null' in the network protocol.

data SingleSelection = SingleSelection
    deriving (Show)

instance Term SingleSelection where
    toTerm = error "toTerm SingleSelection: Server-only type"

instance IsDatum  SingleSelection
instance IsObject SingleSelection



------------------------------------------------------------------------------
-- | A 'Database' is something which contains tables. It is a server-only
-- type.

data Database = MkDatabase

instance Term Database where
    toTerm = error "toTerm Database: Server-only type"



------------------------------------------------------------------------------
-- | Bounds are used in 'Between'.

data Bound = Open !Datum | Closed !Datum

boundDatum :: Bound -> Datum
boundDatum (Open   x) = x
boundDatum (Closed x) = x

boundString :: Bound -> Text
boundString (Open   _) = "open"
boundString (Closed _) = "closed"



------------------------------------------------------------------------------
-- | Used in 'OrderBy'.

data Order = Ascending !Text | Descending !Text

instance Term Order where
    toTerm (Ascending  key) = simpleTerm 73 [SomeExp $ Constant $ String key]
    toTerm (Descending key) = simpleTerm 74 [SomeExp $ Constant $ String key]



------------------------------------------------------------------------------
-- | Sequences are a bounded list of items. The server may split the sequence
-- into multiple chunks when sending it to the client. When the response is
-- a partial sequence, the client may request additional chunks until it gets
-- a 'Done'.

data Sequence a
    = Done    !(Vector a)
    | Partial !Token !(Vector a)


class (Term a) => IsSequence a


instance Show (Sequence a) where
    show (Done      v) = "Done " ++ (show $ V.length v)
    show (Partial _ v) = "Partial " ++ (show $ V.length v)

instance (FromRSON a) => FromResponse (Sequence a) where
    parseResponse = responseSequenceParser

instance ToRSON (Sequence a) where
    toRSON = error "toRSON Sequence: Server-only type"

instance Term (Sequence a) where
    toTerm = error "toTerm Sequence: Server-only type"

instance IsSequence (Sequence a)



------------------------------------------------------------------------------

data Exp a where
    Constant :: (ToRSON a) => a -> Exp a
    -- Any object which can be converted to RSON can be treated as a constant.
    -- Furthermore, many basic Haskell types have a 'Lift' instance which turns
    -- their values into constants.


    --------------------------------------------------------------------------
    -- Database administration

    ListDatabases  :: Exp (Array Text)
    CreateDatabase :: Exp Text -> Exp Object
    DropDatabase   :: Exp Text -> Exp Object


    --------------------------------------------------------------------------
    -- Table administration

    ListTables     :: Exp Database -> Exp (Array Text)
    CreateTable    :: Exp Database -> Exp Text -> Exp Object
    DropTable      :: Exp Database -> Exp Text -> Exp Object


    --------------------------------------------------------------------------
    -- Index administration

    ListIndices    :: Exp Table -> Exp (Array Text)

    CreateIndex    :: Exp Table -> Exp Text -> (Exp Object -> Exp Datum) -> Exp Object
    -- Create a new secondary index on the table. The index has a name and a
    -- projection function which is applied to every object which is added to the table.

    DropIndex      :: Exp Table -> Exp Text -> Exp Object
    IndexStatus    :: Exp Table -> [Exp Text] -> Exp (Array Object)
    WaitIndex      :: Exp Table -> [Exp Text] -> Exp Object


    Database       :: Exp Text -> Exp Database
    Table          :: Exp Text -> Exp Table

    Coerce         :: (Term a, Term b) => Exp a -> Exp Text -> Exp b
    Eq             :: (IsDatum a, IsDatum b) => Exp a -> Exp b -> Exp Bool
    Ne             :: (IsDatum a, IsDatum b) => Exp a -> Exp b -> Exp Bool
    Match          :: Exp Text -> Exp Text -> Exp Datum
    Get            :: Exp Table -> Exp Text -> Exp SingleSelection
    GetAll         :: (IsDatum a) => Exp Table -> [Exp a] -> Exp (Array Datum)
    GetAllIndexed  :: (IsDatum a) => Exp Table -> [Exp a] -> Text -> Exp (Sequence Datum)

    Add            :: (Num a) => [Exp a] -> Exp a
    Multiply       :: (Num a) => [Exp a] -> Exp a

    All :: [Exp Bool] -> Exp Bool
    -- True if all the elements in the input are True.

    Any :: [Exp Bool] -> Exp Bool
    -- True if any element in the input is True.

    ObjectField :: (IsObject a, IsDatum r) => Exp a -> Exp Text -> Exp r
    -- Get a particular field from an object (or SingleSelection).

    ExtractField :: (IsSequence a) => Exp a -> Exp Text -> Exp a
    -- Like 'ObjectField' but over a sequence.

    Take           :: (IsSequence s) => Exp Double -> Exp s -> Exp s
    Append         :: (IsDatum a) => Exp (Array a) -> Exp a -> Exp (Array a)
    Prepend        :: (IsDatum a) => Exp (Array a) -> Exp a -> Exp (Array a)
    IsEmpty        :: (IsSequence a) => Exp a -> Exp Bool
    Delete         :: (Term a) => Exp a -> Exp Object

    InsertObject   :: Exp Table -> Object -> Exp Object
    -- Insert a single object into the table.

    InsertSequence :: (IsSequence s) => Exp Table -> Exp s -> Exp Object
    -- Insert a sequence into the table.

    Filter :: (IsSequence s, Term a) => (Exp a -> Exp Bool) -> Exp s -> Exp s
    Map :: (IsSequence s, Term a, Term b) => (Exp a -> Exp b) -> Exp s -> Exp s

    Between :: (IsSequence s) => Exp s -> (Bound, Bound) -> Exp s
    -- Select all elements whose primary key is between the two bounds.

    BetweenIndexed :: (IsSequence s) => Exp s -> (Bound, Bound) -> Text -> Exp s
    -- Select all elements whose secondary index is between the two bounds.

    OrderBy :: (IsSequence s) => [Order] -> Exp s -> Exp s
    -- Order a sequence based on the given order specificiation.

    Keys :: (IsObject a) => Exp a -> Exp (Array Text)

    Var :: Int -> Exp a
    -- A 'Var' is used as a placeholder in input to functions.

    Function :: (Term a) => State Context ([Int], Exp a) -> Exp f
    -- Creates a function. The action should take care of allocating an
    -- appropriate number of variables from the context. Note that you should
    -- not use this constructor directly. There are 'Lift' instances for all
    -- commonly used functions.

    Call :: (Term f) => Exp f -> [SomeExp] -> Exp r
    -- Call the given function. The function should take the same number of
    -- arguments as there are provided.


instance (Term a) => Term (Exp a) where
    toTerm (Constant datum) =
        toTerm datum


    toTerm ListDatabases =
        simpleTerm 59 []

    toTerm (CreateDatabase name) =
        simpleTerm 57 [SomeExp name]

    toTerm (DropDatabase name) =
        simpleTerm 58 [SomeExp name]


    toTerm (ListTables db) =
        simpleTerm 62 [SomeExp db]

    toTerm (CreateTable db name) =
        simpleTerm 60 [SomeExp db, SomeExp name]

    toTerm (DropTable db name) =
        simpleTerm 61 [SomeExp db, SomeExp name]


    toTerm (ListIndices table) =
        simpleTerm 77 [SomeExp table]

    toTerm (CreateIndex table name f) =
        simpleTerm 75 [SomeExp table, SomeExp name, SomeExp (lift f)]

    toTerm (DropIndex table name) =
        simpleTerm 76 [SomeExp table, SomeExp name]

    toTerm (IndexStatus table indices) =
        simpleTerm 139 ([SomeExp table] ++ map SomeExp indices)

    toTerm (WaitIndex table indices) =
        simpleTerm 140 ([SomeExp table] ++ map SomeExp indices)


    toTerm (Database name) =
        simpleTerm 14 [SomeExp name]

    toTerm (Table name) =
        simpleTerm 15 [SomeExp name]

    toTerm (Filter f s) =
        simpleTerm 39 [SomeExp s, SomeExp (lift f)]

    toTerm (Map f s) =
        simpleTerm 38 [SomeExp s, SomeExp (lift f)]

    toTerm (Between s (l, u)) =
        termWithOptions 36 [SomeExp s, SomeExp $ lift (boundDatum l), SomeExp $ lift (boundDatum u)] $
            HMS.fromList
                [ ("left_bound",  String (boundString l))
                , ("right_bound", String (boundString u))
                ]

    toTerm (BetweenIndexed s (l, u) index) =
        termWithOptions 36 [SomeExp s, SomeExp $ lift (boundDatum l), SomeExp $ lift (boundDatum u)] $
            HMS.fromList
                [ ("left_bound",  String (boundString l))
                , ("right_bound", String (boundString u))
                , ("index",       String index)
                ]

    toTerm (OrderBy spec s) = do
        s'    <- toTerm s
        spec' <- mapM toTerm spec
        simpleTerm2 41 ([s'] ++ spec')

    toTerm (InsertObject table object) =
        termWithOptions 56 [SomeExp table, SomeExp (lift object)] emptyOptions

    toTerm (InsertSequence table s) =
        termWithOptions 56 [SomeExp table, SomeExp s] emptyOptions

    toTerm (Delete selection) =
        simpleTerm 54 [SomeExp selection]

    toTerm (ObjectField object field) =
        simpleTerm 31 [SomeExp object, SomeExp field]

    toTerm (ExtractField object field) =
        simpleTerm 31 [SomeExp object, SomeExp field]

    toTerm (Coerce value typeName) =
        simpleTerm 51 [SomeExp value, SomeExp typeName]

    toTerm (Add values) =
        simpleTerm 24 (map SomeExp values)

    toTerm (Multiply values) =
        simpleTerm 26 (map SomeExp values)

    toTerm (All values) =
        simpleTerm 67 (map SomeExp values)

    toTerm (Any values) =
        simpleTerm 66 (map SomeExp values)

    toTerm (Eq a b) =
        simpleTerm 17 [SomeExp a, SomeExp b]

    toTerm (Ne a b) =
        simpleTerm 18 [SomeExp a, SomeExp b]

    toTerm (Match a b) =
        simpleTerm 97 [SomeExp a, SomeExp b]

    toTerm (Get table key) =
        simpleTerm 16 [SomeExp table, SomeExp key]

    toTerm (GetAll table keys) =
        simpleTerm 78 ([SomeExp table] ++ map SomeExp keys)

    toTerm (GetAllIndexed table keys index) =
        termWithOptions 78 ([SomeExp table] ++ map SomeExp keys)
            (HMS.singleton "index" (String index))

    toTerm (Take n s) =
        simpleTerm 71 [SomeExp s, SomeExp n]

    toTerm (Append array value) =
        simpleTerm 29 [SomeExp array, SomeExp value]

    toTerm (Prepend array value) =
        simpleTerm 80 [SomeExp array, SomeExp value]

    toTerm (IsEmpty s) =
        simpleTerm 86 [SomeExp s]

    toTerm (Keys a) =
        simpleTerm 94 [SomeExp a]

    toTerm (Var a) =
        simpleTerm 10 [SomeExp $ lift $ (fromIntegral a :: Double)]

    toTerm (Function a) = do
        (vars, f) <- a
        simpleTerm 69 [SomeExp $ Constant $ V.fromList $ map (Number . fromIntegral) vars, SomeExp f]

    toTerm (Call f args) =
        simpleTerm 64 ([SomeExp f] ++ args)


simpleTerm :: Int -> [SomeExp] -> State Context A.Value
simpleTerm termType args = do
    args' <- mapM toTerm args
    return $ A.Array $ V.fromList [toJSON termType, toJSON args']

simpleTerm2 :: (Term a) => Int -> [a] -> State Context A.Value
simpleTerm2 termType args = do
    args' <- mapM toTerm args
    return $ A.Array $ V.fromList [toJSON termType, toJSON args']

termWithOptions :: Int -> [SomeExp] -> Object -> State Context A.Value
termWithOptions termType args options = do
    args'    <- mapM toTerm args
    options' <- toTerm options

    return $ A.Array $ V.fromList [toJSON termType, toJSON args', toJSON options']


-- | Convenience to for automatically converting a 'Text' to a constant
-- expression.
instance IsString (Exp Text) where
    fromString = lift . (fromString :: String -> Text)


instance Num (Exp Double) where
    fromInteger = Constant . fromInteger

    a + b = Add [a, b]
    a * b = Multiply [a, b]

    abs _    = error "Num (Exp a): abs not implemented"
    signum _ = error "Num (Exp a): signum not implemented"



------------------------------------------------------------------------------
-- | The class of types e which can be lifted into c. All basic Haskell types
-- which can be represented as 'Exp' are instances of this, as well as certain
-- types of functions (unary and binary).

class Lift c e where
    -- | Type-level function which simplifies the type of @e@ once it is lifted
    -- into @c@. This is used for functions where we strip the signature so
    -- that we don't have to define dummy 'Term' instances for those.
    type Simplified e

    lift :: e -> c (Simplified e)


instance Lift Exp Bool where
    type Simplified Bool = Bool
    lift = Constant

instance Lift Exp Double where
    type Simplified Double = Double
    lift = Constant

instance Lift Exp Text where
    type Simplified Text = Text
    lift = Constant

instance Lift Exp Object where
    type Simplified Object = Object
    lift = Constant

instance Lift Exp Datum where
    type Simplified Datum = Datum
    lift = Constant

instance Lift Exp ZonedTime where
    type Simplified ZonedTime = ZonedTime
    lift = Constant

instance Lift Exp (Array Datum) where
    type Simplified (Array Datum) = (Array Datum)
    lift = Constant

instance (Term r) => Lift Exp (Exp a -> Exp r) where
    type Simplified (Exp a -> Exp r) = Exp r
    lift f = Function $ do
        v1 <- newVar
        return $ ([v1], f (Var v1))

instance (Term r) => Lift Exp (Exp a -> Exp b -> Exp r) where
    type Simplified (Exp a -> Exp b -> Exp r) = Exp r
    lift f = Function $ do
        v1 <- newVar
        v2 <- newVar
        return $ ([v1, v2], f (Var v1) (Var v2))



------------------------------------------------------------------------------
-- 'call1', 'call2' etc generate a function call expression. These should be
-- used instead of the 'Call' constructor because they provide type safety.

-- | Call an unary function with the given argument.
call1 :: (Term a, Term r)
      => (Exp a -> Exp r)
      -> Exp a
      -> Exp r
call1 f a = Call (lift f) [SomeExp a]


-- | Call an binary function with the given arguments.
call2 :: (Term a, Term b, Term r)
      => (Exp a -> Exp b -> Exp r)
      -> Exp a -> Exp b
      -> Exp r
call2 f a b = Call (lift f) [SomeExp a, SomeExp b]


emptyOptions :: Object
emptyOptions = HMS.empty



------------------------------------------------------------------------------
-- | Because the arguments to functions are polymorphic (the individual
-- arguments can, and often have, different types).

data SomeExp where
     SomeExp :: (Term a) => Exp a -> SomeExp

instance Term SomeExp where
    toTerm (SomeExp e) = toTerm e



------------------------------------------------------------------------------
-- | The type of result you get when executing a query of 'Exp a'.
type family Result a

type instance Result Text            = Text
type instance Result Double          = Double
type instance Result Bool            = Bool
type instance Result ZonedTime       = ZonedTime

type instance Result Table           = Sequence Datum
type instance Result Datum           = Datum
type instance Result Object          = Object
type instance Result (Array a)       = Array a
type instance Result SingleSelection = Maybe Datum
type instance Result (Sequence a)    = Sequence a



------------------------------------------------------------------------------
-- | The result of a query. It is either an error or a result (which depends
-- on the type of the query expression). This type is named to be symmetrical
-- to 'Exp', so we get this nice type for 'run'.
--
-- > run :: Handle -> Exp a -> IO (Res a)

type Res a = Either Error (Result a)



------------------------------------------------------------------------------
-- | A value which can be converted from a 'Response'. All types which are
-- defined as being a 'Result a' should have a 'FromResponse a'. Because,
-- uhm.. you really want to be able to extract the result from the response.
--
-- There are two parsers defined here, one for atoms and the other for
-- sequences. These are the only two implementations of parseResponse which
-- should be used.

class FromResponse a where
    parseResponse :: Response -> Parser a


responseAtomParser :: (FromRSON a) => Response -> Parser a
responseAtomParser r = case (responseType r, V.toList (responseResult r)) of
    (SuccessAtom, [a]) -> parseRSON a
    _                  -> fail $ "responseAtomParser: Not a single-element vector " ++ show (responseResult r)

responseSequenceParser :: (FromRSON a) => Response -> Parser (Sequence a)
responseSequenceParser r = case responseType r of
    SuccessSequence -> Done    <$> values
    SuccessPartial  -> Partial <$> pure (responseToken r) <*> values
    _               -> fail "responseSequenceParser: Unexpected type"
  where
    values = V.mapM parseRSON (responseResult r)



------------------------------------------------------------------------------
-- | A token is used to refer to queries and the corresponding responses. This
-- driver uses a monotonically increasing counter.

type Token = Word64



data ResponseType
    = SuccessAtom | SuccessSequence | SuccessPartial | SuccessFeed
    | WaitComplete
    | ClientErrorType | CompileErrorType | RuntimeErrorType
    deriving (Show, Eq)


instance FromJSON ResponseType where
    parseJSON (A.Number  1) = pure SuccessAtom
    parseJSON (A.Number  2) = pure SuccessSequence
    parseJSON (A.Number  3) = pure SuccessPartial
    parseJSON (A.Number  4) = pure WaitComplete
    parseJSON (A.Number  5) = pure SuccessFeed
    parseJSON (A.Number 16) = pure ClientErrorType
    parseJSON (A.Number 17) = pure CompileErrorType
    parseJSON (A.Number 18) = pure RuntimeErrorType
    parseJSON _           = fail "ResponseType"



data Response = Response
    { responseToken     :: !Token
    , responseType      :: !ResponseType
    , responseResult    :: !(Vector Value)
    --, responseBacktrace :: ()
    --, responseProfile   :: ()
    } deriving (Show, Eq)



responseParser :: Token -> Value -> Parser Response
responseParser token (A.Object o) =
    Response <$> pure token <*> o .: "t" <*> o .: "r"
responseParser _     _          =
    fail "Response: Unexpected JSON value"



------------------------------------------------------------------------------
-- | Errors include a plain-text description which includes further details.
-- The RethinkDB protocol also includes a backtrace which we currently don't
-- parse.

data Error

    = ProtocolError !Text
      -- ^ An error on the protocol level. Perhaps the socket was closed
      -- unexpectedly, or the server sent a message which the driver could not
      -- parse.

    | ClientError !Text
      -- ^ Means the client is buggy. An example is if the client sends
      -- a malformed protobuf, or tries to send [CONTINUE] for an unknown
      -- token.

    | CompileError !Text
      -- ^ Means the query failed during parsing or type checking. For example,
      -- if you pass too many arguments to a function.

    | RuntimeError !Text
      -- ^ Means the query failed at runtime. An example is if you add
      -- together two values from a table, but they turn out at runtime to be
      -- booleans rather than numbers.

    deriving (Eq, Show)