content: {-# LANGUAGE DeriveFoldable #-}
  {-# LANGUAGE DeriveFunctor #-}
  {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE DeriveTraversable #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# language DerivingStrategies #-}
  
  module Database.Esqueleto.PostgreSQL.JSON.Instances where
  
  import Data.Aeson (FromJSON(..), ToJSON(..), encode, eitherDecodeStrict)
  import Data.Bifunctor (first)
  import qualified Data.ByteString.Lazy as BSL (toStrict)
  import Data.String (IsString(..))
  import Data.Text (Text)
  import qualified Data.Text as T (concat, pack)
  import qualified Data.Text.Encoding as TE (decodeUtf8, encodeUtf8)
  import Database.Esqueleto.Internal.PersistentImport
  import Database.Esqueleto.Internal.Internal (SqlExpr, Value, just, val)
  import GHC.Generics (Generic)
  
  -- | Newtype wrapper around any type with a JSON representation.
  --
  -- @since 3.1.0
  newtype JSONB a = JSONB { unJSONB :: a }
      deriving stock
          ( Generic
          , Eq
          , Foldable
          , Functor
          , Ord
          , Read
          , Show
          , Traversable
          )
      deriving newtype
          ( FromJSON
          , ToJSON
          )
  
  -- | 'SqlExpr' of a NULL-able 'JSONB' value. Hence the 'Maybe'.
  --
  -- Note: NULL here is a PostgreSQL NULL, not a JSON 'null'
  type JSONBExpr a = SqlExpr (Value (Maybe (JSONB a)))
  
  -- | Convenience function to lift a regular value into
  -- a 'JSONB' expression.
  jsonbVal :: (FromJSON a, ToJSON a) => a -> JSONBExpr a
  jsonbVal = just . val . JSONB
  
  -- | Used with certain JSON operators.
  --
  -- This data type has 'Num' and 'IsString' instances
  -- for ease of use by using integer and string literals.
  --
  -- >>> 3 :: JSONAccessor
  -- JSONIndex 3
  -- >>> -3 :: JSONAccessor
  -- JSONIndex -3
  --
  -- >>> "name" :: JSONAccessor
  -- JSONKey "name"
  --
  -- NOTE: DO NOT USE ANY OF THE 'Num' METHODS ON THIS TYPE!
  data JSONAccessor
      = JSONIndex Int
      | JSONKey Text
      deriving (Generic, Eq, Show)
  
  -- | I repeat, DO NOT use any method other than 'fromInteger'!
  instance Num JSONAccessor where
      fromInteger = JSONIndex . fromInteger
      negate (JSONIndex i) = JSONIndex $ negate i
      negate (JSONKey _) = error "Can not negate a JSONKey"
      (+) = numErr
      (-) = numErr
      (*) = numErr
      abs = numErr
      signum = numErr
  
  numErr :: a
  numErr = error "Do not use 'Num' methods on JSONAccessors"
  
  instance IsString JSONAccessor where
      fromString = JSONKey . T.pack
  
  -- | @since 3.1.0
  instance (FromJSON a, ToJSON a) => PersistField (JSONB a) where
      toPersistValue = PersistLiteralEscaped . BSL.toStrict . encode . unJSONB
      fromPersistValue pVal = fmap JSONB $ case pVal of
          PersistByteString bs -> first (badParse $ TE.decodeUtf8 bs) $ eitherDecodeStrict bs
          PersistText t -> first (badParse t) $ eitherDecodeStrict (TE.encodeUtf8 t)
          x -> Left $ fromPersistValueError "string or bytea" x
  
  -- | jsonb
  --
  -- @since 3.1.0
  instance (FromJSON a, ToJSON a) => PersistFieldSql (JSONB a) where
      sqlType _ = SqlOther "JSONB"
  
  badParse :: Text -> String -> Text
  badParse t = fromPersistValueParseError t . T.pack
  
  fromPersistValueError
      :: Text -- ^ Database type(s), should appear different from Haskell name, e.g. "integer" or "INT", not "Int".
      -> PersistValue -- ^ Incorrect value
      -> Text -- ^ Error message
  fromPersistValueError databaseType received = T.concat
      [ "Failed to parse Haskell newtype `JSONB a`; "
      , "expected ", databaseType
      , " from database, but received: ", T.pack (show received)
      , ". Potential solution: Check that your database schema matches your Persistent model definitions."
      ]
  
  fromPersistValueParseError
      :: Text -- ^ Received value
      -> Text -- ^ Additional error
      -> Text -- ^ Error message
  fromPersistValueParseError received err = T.concat
      [ "Failed to parse Haskell type `JSONB a`, "
      , "but received ", received
      , " | with error: ", err
      ]
  