{-# 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 (Value, just, val)
import Database.Esqueleto.Internal.PersistentImport
import Database.Esqueleto.Internal.Sql (SqlExpr)
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
    ]