module Web.Slack.AesonUtils where

import Data.Aeson
import Data.Aeson qualified as J
import Data.Aeson.Types (Pair, parseFail)
import Data.Char qualified as Char
import Data.List (dropWhileEnd)
import Data.Text qualified as T
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Web.FormUrlEncoded qualified as F
import Web.Slack.Prelude

-- | Checks that a record's field labels each start with the given 'prefix',
-- then uses a given 'drop (length prefix)' derivingStrategy to drop that prefix from generated JSON.
--
-- If used in a Template Haskell splice, gives a compile-time error if the prefixes don't match up.
-- Warning: This function should not be used outside of a Template Haskell splice, as it calls `error` in the case that the prefixes don't match up!
--
-- Example usage:
--
-- data PrefixedRecord = PrefixedRecord { prefixedRecordOne :: Int, prefixedRecordTwo :: Char }

-- $(deriveFromJSON (jsonDeriveWithAffix "prefixedRecord" jsonDeriveOptionsSnakeCase) ''PrefixedRecord)

jsonDeriveWithAffix :: Text -> (Int -> Options) -> Options
jsonDeriveWithAffix :: Text -> (Int -> Options) -> Options
jsonDeriveWithAffix Text
prefix Int -> Options
derivingStrategy =
  Options
originalOptions
    { fieldLabelModifier = \String
fieldLabel ->
        if Text
prefix Text -> Text -> Bool
forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Bool
`isPrefixOf` String -> Text
T.pack String
fieldLabel
          then String -> String
originalModifier String
fieldLabel
          else String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"Prefixes don't match: `" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"` isn't a prefix of `" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
fieldLabel String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"`. Search for jsonDeriveWithAffix to learn more."
    }
  where
    originalOptions :: Options
originalOptions = Int -> Options
derivingStrategy (Int -> Options) -> Int -> Options
forall a b. (a -> b) -> a -> b
$ Text -> Int
T.length Text
prefix
    originalModifier :: String -> String
originalModifier = Options -> String -> String
fieldLabelModifier Options
originalOptions

camelToSnake :: String -> String
camelToSnake :: String -> String
camelToSnake = Char -> String -> String
camelTo2 Char
'_'

lowerFirst :: String -> String
lowerFirst :: String -> String
lowerFirst [] = []
lowerFirst (Char
c : String
chars) = Char -> Char
Char.toLower Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
chars

jsonDeriveOptionsSnakeCase :: Int -> Options
jsonDeriveOptionsSnakeCase :: Int -> Options
jsonDeriveOptionsSnakeCase Int
n =
  Options
defaultOptions
    { fieldLabelModifier = camelToSnake . lowerFirst . drop n
    , omitNothingFields = True
    , constructorTagModifier = camelToSnake . lowerFirst . drop n
    }

-- | Create a 'Value' from a list of name\/value @Maybe Pair@'s.
-- For 'Nothing', instead of outputting @null@, that field will not be output at all.
-- If duplicate keys arise, later keys and their associated values win.
--
-- Example:
--
-- @
-- objectOptional
--   [ "always" .=! 1
--   , "just" .=? Just 2
--   , "nothing" .=? Nothing
--   ]
-- @
--
-- will result in the JSON
--
-- @
-- {
--   "always": 1,
--   "just": 2
-- }
-- @
--
-- The field @nothing@ is ommited because it was 'Nothing'.
objectOptional :: [Maybe Pair] -> Value
objectOptional :: [Maybe Pair] -> Value
objectOptional = [Pair] -> Value
J.object ([Pair] -> Value)
-> ([Maybe Pair] -> [Pair]) -> [Maybe Pair] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Maybe Pair] -> [Pair]
forall (f :: * -> *) t.
(IsSequence (f (Maybe t)), Functor f,
 Element (f (Maybe t)) ~ Maybe t) =>
f (Maybe t) -> f t
catMaybes

-- | Encode a value for 'objectOptional'
(.=!) :: (ToJSON v) => Key -> v -> Maybe Pair
Key
key .=! :: forall v. ToJSON v => Key -> v -> Maybe Pair
.=! v
val = Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Key
key Key -> v -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= v
val)

infixr 8 .=!

-- | Encode a Maybe value for 'objectOptional'
(.=?) :: (ToJSON v) => Key -> Maybe v -> Maybe Pair
Key
key .=? :: forall v. ToJSON v => Key -> Maybe v -> Maybe Pair
.=? Maybe v
mVal = (v -> Pair) -> Maybe v -> Maybe Pair
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key
key Key -> v -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=) Maybe v
mVal

infixr 8 .=?

-- | Conditionally encode a value for 'objectOptional'
(?.>) :: Bool -> Pair -> Maybe Pair
Bool
True ?.> :: Bool -> Pair -> Maybe Pair
?.> Pair
pair = Pair -> Maybe Pair
forall a. a -> Maybe a
Just Pair
pair
Bool
False ?.> Pair
_ = Maybe Pair
forall a. Maybe a
Nothing

infixr 7 ?.>

-- | Conditionally express a pair in a JSON series
thenPair :: Bool -> J.Series -> J.Series
thenPair :: Bool -> Series -> Series
thenPair Bool
True Series
s = Series
s
thenPair Bool
False Series
_ = Series
forall a. Monoid a => a
mempty

infixr 7 `thenPair`

snakeCaseOptions :: Options
snakeCaseOptions :: Options
snakeCaseOptions =
  Options
defaultOptions
    { fieldLabelModifier = camelTo2 '_'
    , constructorTagModifier = camelTo2 '_'
    }

-- | 'snakeCaseOptions' that eats trailing underscores. This is so that you can
-- have a field called "type_".
snakeCaseOptionsEatTrailingUnderscore :: Options
snakeCaseOptionsEatTrailingUnderscore :: Options
snakeCaseOptionsEatTrailingUnderscore =
  Options
defaultOptions
    { fieldLabelModifier = camelTo2 '_' . dropWhileEnd (== '_')
    , constructorTagModifier = camelTo2 '_'
    }

snakeCaseFormOptions :: F.FormOptions
snakeCaseFormOptions :: FormOptions
snakeCaseFormOptions =
  FormOptions
F.defaultFormOptions
    { F.fieldLabelModifier = camelTo2 '_'
    }

newtype UnixTimestamp = UnixTimestamp {UnixTimestamp -> UTCTime
unUnixTimestamp :: UTCTime}
  deriving newtype (Int -> UnixTimestamp -> String -> String
[UnixTimestamp] -> String -> String
UnixTimestamp -> String
(Int -> UnixTimestamp -> String -> String)
-> (UnixTimestamp -> String)
-> ([UnixTimestamp] -> String -> String)
-> Show UnixTimestamp
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> UnixTimestamp -> String -> String
showsPrec :: Int -> UnixTimestamp -> String -> String
$cshow :: UnixTimestamp -> String
show :: UnixTimestamp -> String
$cshowList :: [UnixTimestamp] -> String -> String
showList :: [UnixTimestamp] -> String -> String
Show, UnixTimestamp -> UnixTimestamp -> Bool
(UnixTimestamp -> UnixTimestamp -> Bool)
-> (UnixTimestamp -> UnixTimestamp -> Bool) -> Eq UnixTimestamp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnixTimestamp -> UnixTimestamp -> Bool
== :: UnixTimestamp -> UnixTimestamp -> Bool
$c/= :: UnixTimestamp -> UnixTimestamp -> Bool
/= :: UnixTimestamp -> UnixTimestamp -> Bool
Eq)

instance FromJSON UnixTimestamp where
  parseJSON :: Value -> Parser UnixTimestamp
parseJSON Value
a = UTCTime -> UnixTimestamp
UnixTimestamp (UTCTime -> UnixTimestamp)
-> (POSIXTime -> UTCTime) -> POSIXTime -> UnixTimestamp
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UnixTimestamp)
-> Parser POSIXTime -> Parser UnixTimestamp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser POSIXTime
forall a. FromJSON a => Value -> Parser a
parseJSON Value
a

instance ToJSON UnixTimestamp where
  toJSON :: UnixTimestamp -> Value
toJSON (UnixTimestamp UTCTime
a) = POSIXTime -> Value
forall a. ToJSON a => a -> Value
toJSON (UTCTime -> POSIXTime
utcTimeToPOSIXSeconds UTCTime
a)

-- | Expected a given value as a string. Useful for @type@ fields in json.
data Expected (lit :: Symbol) = Expected

type role Expected phantom

instance (KnownSymbol lit) => Eq (Expected lit) where
  -- If the types match the values are always equal
  Expected lit
_ == :: Expected lit -> Expected lit -> Bool
== Expected lit
_ = Bool
True

instance (KnownSymbol lit) => FromJSON (Expected lit) where
  parseJSON :: Value -> Parser (Expected lit)
parseJSON = String
-> (Text -> Parser (Expected lit))
-> Value
-> Parser (Expected lit)
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Expected" \Text
s -> do
    Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
s Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Text
T.pack (Proxy lit -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @lit))) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ String -> Parser ()
forall a. String -> Parser a
parseFail (String
"should be " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Proxy lit -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @lit))
    Expected lit -> Parser (Expected lit)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expected lit
forall (lit :: Symbol). Expected lit
Expected

instance (KnownSymbol lit) => ToJSON (Expected lit) where
  toJSON :: Expected lit -> Value
toJSON Expected lit
_ = Text -> Value
String (Text -> Value) -> (String -> Text) -> String -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
T.pack (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ Proxy lit -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @lit)

instance (KnownSymbol lit) => Show (Expected lit) where
  show :: Expected lit -> String
show Expected lit
_ = String -> String
forall a. Show a => a -> String
show (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Proxy lit -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @lit)