    {-# LANGUAGE OverloadedStrings #-}
    {-# OPTIONS_GHC -fno-warn-orphans #-}

    -- | Filter operators for JSON values added to PostgreSQL 9.4
    module Database.Persist.Postgresql.JSON
      ( (@>.)
      , (<@.)
      , (?.)
      , (?|.)
      , (?&.)
      , Value()
      ) where

    import Data.Aeson (FromJSON, ToJSON, Value, encode, eitherDecodeStrict)
    import qualified Data.ByteString.Lazy as BSL
    import Data.Proxy (Proxy)
    import Data.Text (Text)
    import qualified Data.Text as T
    import Data.Text.Encoding as TE (encodeUtf8)

    import Database.Persist (EntityField, Filter(..), PersistValue(..), PersistField(..), PersistFilter(..))
    import Database.Persist.Sql (PersistFieldSql(..), SqlType(..))
    import Database.Persist.Types (FilterValue(..))

    infix 4 @>., <@., ?., ?|., ?&.

    -- | This operator checks inclusion of the JSON value
    -- on the right hand side in the JSON value on the left
    -- hand side.
    --
    -- === __Objects__
    --
    -- An empty Object matches any object
    --
    -- @
    -- {}                \@> {} == True
    -- {"a":1,"b":false} \@> {} == True
    -- @
    --
    -- Any key-value will be matched top-level
    --
    -- @
    -- {"a":1,"b":{"c":true"}} \@> {"a":1}         == True
    -- {"a":1,"b":{"c":true"}} \@> {"b":1}         == False
    -- {"a":1,"b":{"c":true"}} \@> {"b":{}}        == True
    -- {"a":1,"b":{"c":true"}} \@> {"c":true}      == False
    -- {"a":1,"b":{"c":true"}} \@> {"b":{c":true}} == True
    -- @
    --
    -- === __Arrays__
    --
    -- An empty Array matches any array
    --
    -- @
    -- []                    \@> [] == True
    -- [1,2,"hi",false,null] \@> [] == True
    -- @
    --
    -- Any array has to be a sub-set.
    -- Any object or array will also be compared as being a subset of.
    --
    -- @
    -- [1,2,"hi",false,null] \@> [1]                       == True
    -- [1,2,"hi",false,null] \@> [null,"hi"]               == True
    -- [1,2,"hi",false,null] \@> ["hi",true]               == False
    -- [1,2,"hi",false,null] \@> ["hi",2,null,false,1]     == True
    -- [1,2,"hi",false,null] \@> [1,2,"hi",false,null,{}]  == False
    -- @
    --
    -- Arrays and objects inside arrays match the same way they'd
    -- be matched as being on their own.
    --
    -- @
    -- [1,"hi",[false,3],{"a":[null]}] \@> [{}]            == True
    -- [1,"hi",[false,3],{"a":[null]}] \@> [{"a":[]}]      == True
    -- [1,"hi",[false,3],{"a":[null]}] \@> [{"b":[null]}]  == False
    -- [1,"hi",[false,3],{"a":[null]}] \@> [[]]            == True
    -- [1,"hi",[false,3],{"a":[null]}] \@> [[3]]           == True
    -- [1,"hi",[false,3],{"a":[null]}] \@> [[true,3]]      == False
    -- @
    --
    -- A regular value has to be a member
    --
    -- @
    -- [1,2,"hi",false,null] \@> 1      == True
    -- [1,2,"hi",false,null] \@> 5      == False
    -- [1,2,"hi",false,null] \@> "hi"   == True
    -- [1,2,"hi",false,null] \@> false  == True
    -- [1,2,"hi",false,null] \@> "2"    == False
    -- @
    --
    -- An object will never match with an array
    --
    -- @
    -- [1,2,"hi",[false,3],{"a":null}] \@> {}          == False
    -- [1,2,"hi",[false,3],{"a":null}] \@> {"a":null}  == False
    -- @
    --
    -- === __Other values__
    --
    -- For any other JSON values the `(\@>.)` operator
    -- functions like an equivalence operator.
    --
    -- @
    -- "hello" \@> "hello"     == True
    -- "hello" \@> \"Hello"     == False
    -- "hello" \@> "h"         == False
    -- "hello" \@> {"hello":1} == False
    -- "hello" \@> ["hello"]   == False
    --
    -- 5       \@> 5       == True
    -- 5       \@> 5.00    == True
    -- 5       \@> 1       == False
    -- 5       \@> 7       == False
    -- 12345   \@> 1234    == False
    -- 12345   \@> 2345    == False
    -- 12345   \@> "12345" == False
    -- 12345   \@> [1,2,3,4,5] == False
    --
    -- true    \@> true    == True
    -- true    \@> false   == False
    -- false   \@> true    == False
    -- true    \@> "true"  == False
    --
    -- null    \@> null    == True
    -- null    \@> 23      == False
    -- null    \@> "null"  == False
    -- null    \@> {}      == False
    -- @
    --
    -- @since 2.8.2
    (@>.) :: EntityField record Value -> Value -> Filter record
    @>. :: forall record. EntityField record Value -> Value -> Filter record
    (@>.) EntityField record Value
    field Value
    val = EntityField record Value
    -> FilterValue Value -> PersistFilter -> Filter record
    forall record typ.
    PersistField typ =>
    EntityField record typ
    -> FilterValue typ -> PersistFilter -> Filter record
    Filter EntityField record Value
    field (Value -> FilterValue Value
    forall typ. typ -> FilterValue typ
    FilterValue Value
    val) (PersistFilter -> Filter record) -> PersistFilter -> Filter record
    forall a b. (a -> b) -> a -> b
    $ Text -> PersistFilter
    BackendSpecificFilter Text
    " @> "

    -- | Same as '@>.' except the inclusion check is reversed.
    -- i.e. is the JSON value on the left hand side included
    -- in the JSON value of the right hand side.
    --
    -- @since 2.8.2
    (<@.) :: EntityField record Value -> Value -> Filter record
    <@. :: forall record. EntityField record Value -> Value -> Filter record
    (<@.) EntityField record Value
    field Value
    val = EntityField record Value
    -> FilterValue Value -> PersistFilter -> Filter record
    forall record typ.
    PersistField typ =>
    EntityField record typ
    -> FilterValue typ -> PersistFilter -> Filter record
    Filter EntityField record Value
    field (Value -> FilterValue Value
    forall typ. typ -> FilterValue typ
    FilterValue Value
    val) (PersistFilter -> Filter record) -> PersistFilter -> Filter record
    forall a b. (a -> b) -> a -> b
    $ Text -> PersistFilter
    BackendSpecificFilter Text
    " <@ "

    -- | This operator takes a column and a string to find a
    -- top-level key/field in an object.
    --
    -- @column ?. string@
    --
    -- N.B. This operator might have some unexpected interactions
    -- with non-object values. Please reference the examples.
    --
    -- === __Objects__
    --
    -- @
    -- {"a":null}             ? "a"  == True
    -- {"test":false,"a":500} ? "a"  == True
    -- {"b":{"a":[]}}         ? "a"  == False
    -- {}                     ? "a"  == False
    -- {}                     ? "{}" == False
    -- {}                     ? ""   == False
    -- {"":9001}              ? ""   == True
    -- @
    --
    -- === __Arrays__
    --
    -- This operator will match an array if the string to be matched
    -- is an element of that array, but nothing else.
    --
    -- @
    -- ["a"]              ? "a"   == True
    -- [["a"]]            ? "a"   == False
    -- [9,false,"1",null] ? "1"   == True
    -- []                 ? "[]"  == False
    -- [{"a":true}]       ? "a"   == False
    -- @
    --
    -- === __Other values__
    --
    -- This operator functions like an equivalence operator on strings only.
    -- Any other value does not match.
    --
    -- @
    -- "a"  ? "a"    == True
    -- "1"  ? "1"    == True
    -- "ab" ? "a"    == False
    -- 1    ? "1"    == False
    -- null ? "null" == False
    -- true ? "true" == False
    -- 1.5  ? "1.5"  == False
    -- @
    --
    -- @since 2.10.0
    (?.) :: EntityField record Value -> Text -> Filter record
    ?. :: forall record. EntityField record Value -> Text -> Filter record
    (?.) = Text -> EntityField record Value -> Text -> Filter record
    forall a record.
    PersistField a =>
    Text -> EntityField record Value -> a -> Filter record
    jsonFilter Text
    " ?? "

    -- | This operator takes a column and a list of strings to
    -- test whether ANY of the elements of the list are top
    -- level fields in an object.
    --
    -- @column ?|. list@
    --
    -- /N.B. An empty list __will never match anything__. Also, this/
    -- /operator might have some unexpected interactions with/
    -- /non-object values. Please reference the examples./
    --
    -- === __Objects__
    --
    -- @
    -- {"a":null}                 ?| ["a","b","c"] == True
    -- {"test":false,"a":500}     ?| ["a","b","c"] == True
    -- {}                         ?| ["a","{}"]    == False
    -- {"b":{"a":[]}}             ?| ["a","c"]     == False
    -- {"b":{"a":[]},"test":null} ?| []            == False
    -- @
    --
    -- === __Arrays__
    --
    -- This operator will match an array if __any__ of the elements
    -- of the list are matching string elements of the array.
    --
    -- @
    -- ["a"]              ?| ["a","b","c"] == True
    -- [["a"]]            ?| ["a","b","c"] == False
    -- [9,false,"1",null] ?| ["a","false"] == False
    -- []                 ?| ["a","b","c"] == False
    -- []                 ?| []            == False
    -- [{"a":true}]       ?| ["a","b","c"] == False
    -- [null,4,"b",[]]    ?| ["a","b","c"] == True
    -- @
    --
    -- === __Other values__
    --
    -- This operator functions much like an equivalence operator
    -- on strings only. If a string matches with __any__ element of
    -- the given list, the comparison matches. No other values match.
    --
    -- @
    -- "a"  ?| ["a","b","c"] == True
    -- "1"  ?| ["a","b","1"] == True
    -- "ab" ?| ["a","b","c"] == False
    -- 1    ?| ["a","1"]     == False
    -- null ?| ["a","null"]  == False
    -- true ?| ["a","true"]  == False
    -- "a"  ?| []            == False
    -- @
    --
    -- @since 2.10.0
    (?|.) :: EntityField record Value -> [Text] -> Filter record
    ?|. :: forall record. EntityField record Value -> [Text] -> Filter record
    (?|.) EntityField record Value
    field = Text
    -> EntityField record Value -> PostgresArray Text -> Filter record
    forall a record.
    PersistField a =>
    Text -> EntityField record Value -> a -> Filter record
    jsonFilter Text
    " ??| " EntityField record Value
    field (PostgresArray Text -> Filter record)
    -> ([Text] -> PostgresArray Text) -> [Text] -> Filter record
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Text] -> PostgresArray Text
    forall a. [a] -> PostgresArray a
    PostgresArray

    -- | This operator takes a column and a list of strings to
    -- test whether ALL of the elements of the list are top
    -- level fields in an object.
    --
    -- @column ?&. list@
    --
    -- /N.B. An empty list __will match anything__. Also, this/
    -- /operator might have some unexpected interactions with/
    -- /non-object values. Please reference the examples./
    --
    -- === __Objects__
    --
    -- @
    -- {"a":null}                 ?& ["a"]         == True
    -- {"a":null}                 ?& ["a","a"]     == True
    -- {"test":false,"a":500}     ?& ["a"]         == True
    -- {"test":false,"a":500}     ?& ["a","b"]     == False
    -- {}                         ?& ["{}"]        == False
    -- {"b":{"a":[]}}             ?& ["a"]         == False
    -- {"b":{"a":[]},"c":false}   ?& ["a","c"]     == False
    -- {"a":1,"b":2,"c":3,"d":4}  ?& ["b","d"]     == True
    -- {}                         ?& []            == True
    -- {"b":{"a":[]},"test":null} ?& []            == True
    -- @
    --
    -- === __Arrays__
    --
    -- This operator will match an array if __all__ of the elements
    -- of the list are matching string elements of the array.
    --
    -- @
    -- ["a"]                   ?& ["a"]         == True
    -- ["a"]                   ?& ["a","a"]     == True
    -- [["a"]]                 ?& ["a"]         == False
    -- ["a","b","c"]           ?& ["a","b","d"] == False
    -- [9,"false","1",null]    ?& ["1","false"] == True
    -- []                      ?& ["a","b"]     == False
    -- [{"a":true}]            ?& ["a"]         == False
    -- ["a","b","c","d"]       ?& ["b","c","d"] == True
    -- [null,4,{"test":false}] ?& []            == True
    -- []                      ?& []            == True
    -- @
    --
    -- === __Other values__
    --
    -- This operator functions much like an equivalence operator
    -- on strings only. If a string matches with all elements of
    -- the given list, the comparison matches.
    --
    -- @
    -- "a"   ?& ["a"]     == True
    -- "1"   ?& ["a","1"] == False
    -- "b"   ?& ["b","b"] == True
    -- "ab"  ?& ["a","b"] == False
    -- 1     ?& ["1"]     == False
    -- null  ?& ["null"]  == False
    -- true  ?& ["true"]  == False
    -- 31337 ?& []        == True
    -- true  ?& []        == True
    -- null  ?& []        == True
    -- @
    --
    -- @since 2.10.0
    (?&.) :: EntityField record Value -> [Text] -> Filter record
    ?&. :: forall record. EntityField record Value -> [Text] -> Filter record
    (?&.) EntityField record Value
    field = Text
    -> EntityField record Value -> PostgresArray Text -> Filter record
    forall a record.
    PersistField a =>
    Text -> EntityField record Value -> a -> Filter record
    jsonFilter Text
    " ??& " EntityField record Value
    field (PostgresArray Text -> Filter record)
    -> ([Text] -> PostgresArray Text) -> [Text] -> Filter record
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Text] -> PostgresArray Text
    forall a. [a] -> PostgresArray a
    PostgresArray

    jsonFilter :: PersistField a => Text -> EntityField record Value -> a -> Filter record
    jsonFilter :: forall a record.
    PersistField a =>
    Text -> EntityField record Value -> a -> Filter record
    jsonFilter Text
    op EntityField record Value
    field a
    a = EntityField record Value
    -> FilterValue Value -> PersistFilter -> Filter record
    forall record typ.
    PersistField typ =>
    EntityField record typ
    -> FilterValue typ -> PersistFilter -> Filter record
    Filter EntityField record Value
    field (a -> FilterValue Value
    forall a typ. PersistField a => a -> FilterValue typ
    UnsafeValue a
    a) (PersistFilter -> Filter record) -> PersistFilter -> Filter record
    forall a b. (a -> b) -> a -> b
    $ Text -> PersistFilter
    BackendSpecificFilter Text
    op

    -----------------
    -- AESON VALUE --
    -----------------

    instance PersistField Value where
      toPersistValue :: Value -> PersistValue
    toPersistValue = Value -> PersistValue
    forall a. ToJSON a => a -> PersistValue
    toPersistValueJsonB
      fromPersistValue :: PersistValue -> Either Text Value
    fromPersistValue = PersistValue -> Either Text Value
    forall a. FromJSON a => PersistValue -> Either Text a
    fromPersistValueJsonB

    instance PersistFieldSql Value where
      sqlType :: Proxy Value -> SqlType
    sqlType = Proxy Value -> SqlType
    forall a. (ToJSON a, FromJSON a) => Proxy a -> SqlType
    sqlTypeJsonB

    -- FIXME: PersistText might be a bit more efficient,
    -- but needs testing/profiling before changing it.
    -- (When entering into the DB the type isn't as important as fromPersistValue)
    toPersistValueJsonB :: ToJSON a => a -> PersistValue
    toPersistValueJsonB :: forall a. ToJSON a => a -> PersistValue
    toPersistValueJsonB = ByteString -> PersistValue
    PersistLiteralEscaped (ByteString -> PersistValue)
    -> (a -> ByteString) -> a -> PersistValue
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . LazyByteString -> ByteString
    BSL.toStrict (LazyByteString -> ByteString)
    -> (a -> LazyByteString) -> a -> ByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> LazyByteString
    forall a. ToJSON a => a -> LazyByteString
    encode

    fromPersistValueJsonB :: FromJSON a => PersistValue -> Either Text a
    fromPersistValueJsonB :: forall a. FromJSON a => PersistValue -> Either Text a
    fromPersistValueJsonB (PersistText Text
    t) =
        case ByteString -> Either String a
    forall a. FromJSON a => ByteString -> Either String a
    eitherDecodeStrict (ByteString -> Either String a) -> ByteString -> Either String a
    forall a b. (a -> b) -> a -> b
    $ Text -> ByteString
    TE.encodeUtf8 Text
    t of
          Left String
    str -> Text -> Either Text a
    forall a b. a -> Either a b
    Left (Text -> Either Text a) -> Text -> Either Text a
    forall a b. (a -> b) -> a -> b
    $ Text -> Text -> Text -> Text
    forall a. Show a => Text -> a -> Text -> Text
    fromPersistValueParseError Text
    "FromJSON" Text
    t (Text -> Text) -> Text -> Text
    forall a b. (a -> b) -> a -> b
    $ String -> Text
    T.pack String
    str
          Right a
    v -> a -> Either Text a
    forall a b. b -> Either a b
    Right a
    v
    fromPersistValueJsonB (PersistByteString ByteString
    bs) =
        case ByteString -> Either String a
    forall a. FromJSON a => ByteString -> Either String a
    eitherDecodeStrict ByteString
    bs of
          Left String
    str -> Text -> Either Text a
    forall a b. a -> Either a b
    Left (Text -> Either Text a) -> Text -> Either Text a
    forall a b. (a -> b) -> a -> b
    $ Text -> ByteString -> Text -> Text
    forall a. Show a => Text -> a -> Text -> Text
    fromPersistValueParseError Text
    "FromJSON" ByteString
    bs (Text -> Text) -> Text -> Text
    forall a b. (a -> b) -> a -> b
    $ String -> Text
    T.pack String
    str
          Right a
    v -> a -> Either Text a
    forall a b. b -> Either a b
    Right a
    v
    fromPersistValueJsonB PersistValue
    x = Text -> Either Text a
    forall a b. a -> Either a b
    Left (Text -> Either Text a) -> Text -> Either Text a
    forall a b. (a -> b) -> a -> b
    $ Text -> Text -> PersistValue -> Text
    fromPersistValueError Text
    "FromJSON" Text
    "string or bytea" PersistValue
    x

    -- Constraints on the type might not be necessary,
    -- but better to leave them in.
    sqlTypeJsonB :: (ToJSON a, FromJSON a) => Proxy a -> SqlType
    sqlTypeJsonB :: forall a. (ToJSON a, FromJSON a) => Proxy a -> SqlType
    sqlTypeJsonB Proxy a
    _ = Text -> SqlType
    SqlOther Text
    "JSONB"

    fromPersistValueError :: Text -- ^ Haskell type, should match Haskell name exactly, e.g. "Int64"
                          -> Text -- ^ Database type(s), should appear different from Haskell name, e.g. "integer" or "INT", not "Int".
                          -> PersistValue -- ^ Incorrect value
                          -> Text -- ^ Error message
    fromPersistValueError :: Text -> Text -> PersistValue -> Text
    fromPersistValueError Text
    haskellType Text
    databaseType PersistValue
    received = [Text] -> Text
    T.concat
        [ Text
    "Failed to parse Haskell type `"
        , Text
    haskellType
        , Text
    "`; expected "
        , Text
    databaseType
        , Text
    " from database, but received: "
        , String -> Text
    T.pack (PersistValue -> String
    forall a. Show a => a -> String
    show PersistValue
    received)
        , Text
    ". Potential solution: Check that your database schema matches your Persistent model definitions."
        ]

    fromPersistValueParseError :: (Show a)
                               => Text -- ^ Haskell type, should match Haskell name exactly, e.g. "Int64"
                               -> a -- ^ Received value
                               -> Text -- ^ Additional error
                               -> Text -- ^ Error message
    fromPersistValueParseError :: forall a. Show a => Text -> a -> Text -> Text
    fromPersistValueParseError Text
    haskellType a
    received Text
    err = [Text] -> Text
    T.concat
        [ Text
    "Failed to parse Haskell type `"
        , Text
    haskellType
        , Text
    "`, but received "
        , String -> Text
    T.pack (a -> String
    forall a. Show a => a -> String
    show a
    received)
        , Text
    " | with error: "
        , Text
    err
        ]

    newtype PostgresArray a = PostgresArray [a]

    instance PersistField a => PersistField (PostgresArray a) where
      toPersistValue :: PostgresArray a -> PersistValue
    toPersistValue (PostgresArray [a]
    ts) = [PersistValue] -> PersistValue
    PersistArray ([PersistValue] -> PersistValue) -> [PersistValue] -> PersistValue
    forall a b. (a -> b) -> a -> b
    $ a -> PersistValue
    forall a. PersistField a => a -> PersistValue
    toPersistValue (a -> PersistValue) -> [a] -> [PersistValue]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [a]
    ts
      fromPersistValue :: PersistValue -> Either Text (PostgresArray a)
    fromPersistValue (PersistArray [PersistValue]
    as) = [a] -> PostgresArray a
    forall a. [a] -> PostgresArray a
    PostgresArray ([a] -> PostgresArray a)
    -> Either Text [a] -> Either Text (PostgresArray a)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (PersistValue -> Either Text a)
    -> [PersistValue] -> Either Text [a]
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> [a] -> f [b]
    traverse PersistValue -> Either Text a
    forall a. PersistField a => PersistValue -> Either Text a
    fromPersistValue [PersistValue]
    as
      fromPersistValue PersistValue
    wat = Text -> Either Text (PostgresArray a)
    forall a b. a -> Either a b
    Left (Text -> Either Text (PostgresArray a))
    -> Text -> Either Text (PostgresArray a)
    forall a b. (a -> b) -> a -> b
    $ Text -> Text -> PersistValue -> Text
    fromPersistValueError Text
    "PostgresArray" Text
    "array" PersistValue
    wat