<commit_before>{-# 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<commit_msg>Add FromResponse (Maybe Datum)<commit_after>{-# 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


instance FromResponse (Maybe Datum) where
    parseResponse r = case (responseType r, V.toList (responseResult r)) of
        (SuccessAtom, [a]) -> do
            res0 <- parseRSON a
            case res0 of
                Null -> return Nothing
                res  -> return $ Just res
        _                  -> fail $ "responseAtomParser: Not a single-element vector " ++ show (responseResult r)




------------------------------------------------------------------------------
-- | 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
{'fraction_non_alphanumeric': 0.18714662646061064, 'fraction_numerical': 0.0005653976630229929, 'mean_word_length': 1.658567134268537, 'pattern_counts': {'":': 0, '<': 18, '<?xml version=': 0, '>': 31, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1055932', 'n_tokens_mistral': 3046, 'n_tokens_neox': 2944, 'n_words': 1085}