{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE UndecidableInstances #-}

module Json where

import Data.Aeson (FromJSON (parseJSON), ToJSON (toEncoding, toJSON), Value (..), withObject)
import Data.Aeson qualified as Json
import Data.Aeson.BetterErrors qualified as Json
import Data.Aeson.Types qualified
import Data.Error.Tree
import Data.Map.Strict qualified as Map
import Data.Maybe (catMaybes)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Time (UTCTime)
import Data.Vector qualified as Vector
import FieldParser (FieldParser)
import FieldParser qualified as Field
import Label
import PossehlAnalyticsPrelude

-- | Use a "Data.Aeson.BetterErrors" parser to implement 'FromJSON'’s 'parseJSON' method.
--
-- @
-- instance FromJSON Foo where
--   parseJSON = Json.toParseJSON parseFoo
-- @
toParseJSON ::
  -- | the error type is 'Error', if you need 'ErrorTree' use 'toParseJSONErrorTree'
  Json.Parse Error a ->
  Value ->
  Data.Aeson.Types.Parser a
toParseJSON :: forall a. Parse Error a -> Value -> Parser a
toParseJSON = forall err a. (err -> Text) -> Parse err a -> Value -> Parser a
Json.toAesonParser Error -> Text
prettyError

-- | Use a "Data.Aeson.BetterErrors" parser to implement 'FromJSON'’s 'parseJSON' method.
--
-- @
-- instance FromJSON Foo where
--   parseJSON = Json.toParseJSON parseFoo
-- @
toParseJSONErrorTree ::
  -- | the error type is 'ErrorTree', if you need 'Error' use 'toParseJSON'
  Json.Parse ErrorTree a ->
  Value ->
  Data.Aeson.Types.Parser a
toParseJSONErrorTree :: forall a. Parse ErrorTree a -> Value -> Parser a
toParseJSONErrorTree = forall err a. (err -> Text) -> Parse err a -> Value -> Parser a
Json.toAesonParser ErrorTree -> Text
prettyErrorTree

-- | Convert a 'Json.ParseError' to a corresponding 'ErrorTree'
--
-- TODO: build a different version of 'Json.displayError' so that we can nest 'ErrorTree' as well
parseErrorTree :: Error -> Json.ParseError ErrorTree -> ErrorTree
parseErrorTree :: Error -> ParseError ErrorTree -> ErrorTree
parseErrorTree Error
contextMsg ParseError ErrorTree
errs =
  ParseError ErrorTree
errs
    forall a b. a -> (a -> b) -> b
& forall err. (err -> Text) -> ParseError err -> [Text]
Json.displayError ErrorTree -> Text
prettyErrorTree
    forall a b. a -> (a -> b) -> b
& Text -> [Text] -> Text
Text.intercalate Text
"\n"
    forall a b. a -> (a -> b) -> b
& Text -> Error
newError
    -- We nest this here because the json errors is multiline, so the result looks like
    --
    -- @
    -- contextMsg
    -- \|
    -- `- At the path: ["foo"]["bar"]
    --   Type mismatch:
    --   Expected a value of type object
    --   Got: true
    -- @
    forall a b. a -> (a -> b) -> b
& Error -> ErrorTree
singleError
    forall a b. a -> (a -> b) -> b
& Error -> ErrorTree -> ErrorTree
nestedError Error
contextMsg

-- | Lift the parser error to an error tree
asErrorTree :: (Functor m) => Json.ParseT Error m a -> Json.ParseT ErrorTree m a
asErrorTree :: forall (m :: Type -> Type) a.
Functor m =>
ParseT Error m a -> ParseT ErrorTree m a
asErrorTree = forall (m :: Type -> Type) err err' a.
Functor m =>
(err -> err') -> ParseT err m a -> ParseT err' m a
Json.mapError Error -> ErrorTree
singleError

-- | Parse the json array into a 'Set'.
asArraySet ::
  (Ord a, Monad m) =>
  Json.ParseT err m a ->
  Json.ParseT err m (Set a)
asArraySet :: forall a (m :: Type -> Type) err.
(Ord a, Monad m) =>
ParseT err m a -> ParseT err m (Set a)
asArraySet ParseT err m a
inner = forall a. Ord a => [a] -> Set a
Set.fromList forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: Type -> Type) err a.
(Functor m, Monad m) =>
ParseT err m a -> ParseT err m [a]
Json.eachInArray ParseT err m a
inner

-- | Parse the json object into a 'Map'.
asObjectMap ::
  (Monad m) =>
  Json.ParseT err m a ->
  Json.ParseT err m (Map Text a)
asObjectMap :: forall (m :: Type -> Type) err a.
Monad m =>
ParseT err m a -> ParseT err m (Map Text a)
asObjectMap ParseT err m a
inner = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: Type -> Type) err a.
(Functor m, Monad m) =>
ParseT err m a -> ParseT err m [(Text, a)]
Json.eachInObject ParseT err m a
inner

-- | Parse as json array and count the number of elements in the array.
countArrayElements :: (Monad m) => Json.ParseT Error m Natural
countArrayElements :: forall (m :: Type -> Type). Monad m => ParseT Error m Natural
countArrayElements = forall (m :: Type -> Type) err to.
Monad m =>
FieldParser' err Value to -> ParseT err m to
Field.toJsonParser ((FieldParser Value (Vector Value)
jsonArray forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a. Vector a -> Int
Vector.length) forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall i. Integral i => FieldParser i Natural
Field.integralToNatural)
  where
    -- I don’t want to add this to the FieldParser module, cause users should not be dealing with arrays manually.
    jsonArray :: FieldParser Json.Value (Vector Json.Value)
    jsonArray :: FieldParser Value (Vector Value)
jsonArray = forall err from to.
(from -> Either err to) -> FieldParser' err from to
Field.FieldParser forall a b. (a -> b) -> a -> b
$ \case
      Json.Array Vector Value
vec -> forall a b. b -> Either a b
Right Vector Value
vec
      Value
_ -> forall a b. a -> Either a b
Left Error
"Not a json array"

-- | Json string containing a UTC timestamp,
-- @yyyy-mm-ddThh:mm:ss[.sss]Z@ (ISO 8601:2004(E) sec. 4.3.2 extended format)
asUtcTime :: (Monad m) => Json.ParseT Error m UTCTime
asUtcTime :: forall (m :: Type -> Type). Monad m => ParseT Error m UTCTime
asUtcTime = forall (m :: Type -> Type) err to.
Monad m =>
FieldParser' err Value to -> ParseT err m to
Field.toJsonParser (FieldParser Value Text
Field.jsonString forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> FieldParser Text UTCTime
Field.utcTime)

-- | Json string containing a UTC timestamp.
-- | Accepts multiple timezone formats.
-- Do not use this if you can force the input to use the `Z` UTC notation (e.g. in a CSV), use 'utcTime' instead.
--
-- Accepts
--
-- * UTC timestamps: @yyyy-mm-ddThh:mm:ss[.sss]Z@
-- * timestamps with time zone: @yyyy-mm-ddThh:mm:ss[.sss]±hh:mm@
--
-- ( both ISO 8601:2004(E) sec. 4.3.2 extended format)
--
-- The time zone of the second kind of timestamp is taken into account, but normalized to UTC (it’s not preserved what the original time zone was)
asUtcTimeLenient :: (Monad m) => Json.ParseT Error m UTCTime
asUtcTimeLenient :: forall (m :: Type -> Type). Monad m => ParseT Error m UTCTime
asUtcTimeLenient = forall (m :: Type -> Type) err to.
Monad m =>
FieldParser' err Value to -> ParseT err m to
Field.toJsonParser (FieldParser Value Text
Field.jsonString forall {k} (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> FieldParser Text UTCTime
Field.utcTimeLenient)

-- | Parse a key from the object, à la 'Json.key', return a labelled value.
--
-- We don’t provide a version that infers the json object key,
-- since that conflates internal naming with the external API, which is dangerous.
--
-- @@
-- do
--   txt <- keyLabel @"myLabel" "jsonKeyName" Json.asText
--   pure (txt :: Label "myLabel" Text)
-- @@
keyLabel ::
  forall label err m a.
  (Monad m) =>
  Text ->
  Json.ParseT err m a ->
  Json.ParseT err m (Label label a)
keyLabel :: forall (label :: Symbol) err (m :: Type -> Type) a.
Monad m =>
Text -> ParseT err m a -> ParseT err m (Label label a)
keyLabel = do
  forall (label :: Symbol) err (m :: Type -> Type) a.
Monad m =>
Proxy label
-> Text -> ParseT err m a -> ParseT err m (Label label a)
keyLabel' (forall {k} (t :: k). Proxy t
Proxy @label)

-- | Parse a key from the object, à la 'Json.key', return a labelled value.
-- Version of 'keyLabel' that requires a proxy.
--
-- @@
-- do
--   txt <- keyLabel' (Proxy @"myLabel") "jsonKeyName" Json.asText
--   pure (txt :: Label "myLabel" Text)
-- @@
keyLabel' ::
  forall label err m a.
  (Monad m) =>
  Proxy label ->
  Text ->
  Json.ParseT err m a ->
  Json.ParseT err m (Label label a)
keyLabel' :: forall (label :: Symbol) err (m :: Type -> Type) a.
Monad m =>
Proxy label
-> Text -> ParseT err m a -> ParseT err m (Label label a)
keyLabel' Proxy label
Proxy Text
key ParseT err m a
parser = forall (label :: Symbol) value. value -> Label label value
label @label forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: Type -> Type) err a.
(Functor m, Monad m) =>
Text -> ParseT err m a -> ParseT err m a
Json.key Text
key ParseT err m a
parser

-- | Parse an optional key from the object, à la 'Json.keyMay', return a labelled value.
--
-- We don’t provide a version that infers the json object key,
-- since that conflates internal naming with the external API, which is dangerous.
--
-- @@
-- do
--   txt <- keyLabelMay @"myLabel" "jsonKeyName" Json.asText
--   pure (txt :: Label "myLabel" (Maybe Text))
-- @@
keyLabelMay ::
  forall label err m a.
  (Monad m) =>
  Text ->
  Json.ParseT err m a ->
  Json.ParseT err m (Label label (Maybe a))
keyLabelMay :: forall (label :: Symbol) err (m :: Type -> Type) a.
Monad m =>
Text -> ParseT err m a -> ParseT err m (Label label (Maybe a))
keyLabelMay = do
  forall (label :: Symbol) err (m :: Type -> Type) a.
Monad m =>
Proxy label
-> Text -> ParseT err m a -> ParseT err m (Label label (Maybe a))
keyLabelMay' (forall {k} (t :: k). Proxy t
Proxy @label)

-- | Parse an optional key from the object, à la 'Json.keyMay', return a labelled value.
-- Version of 'keyLabelMay' that requires a proxy.
--
-- @@
-- do
--   txt <- keyLabelMay' (Proxy @"myLabel") "jsonKeyName" Json.asText
--   pure (txt :: Label "myLabel" (Maybe Text))
-- @@
keyLabelMay' ::
  forall label err m a.
  (Monad m) =>
  Proxy label ->
  Text ->
  Json.ParseT err m a ->
  Json.ParseT err m (Label label (Maybe a))
keyLabelMay' :: forall (label :: Symbol) err (m :: Type -> Type) a.
Monad m =>
Proxy label
-> Text -> ParseT err m a -> ParseT err m (Label label (Maybe a))
keyLabelMay' Proxy label
Proxy Text
key ParseT err m a
parser = forall (label :: Symbol) value. value -> Label label value
label @label forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: Type -> Type) err a.
(Functor m, Monad m) =>
Text -> ParseT err m a -> ParseT err m (Maybe a)
Json.keyMay Text
key ParseT err m a
parser

-- NOTE: keyRenamed Test in "Json.JsonTest", due to import cycles.

-- | Like 'Json.key', but allows a list of keys that are tried in order.
--
-- This is intended for renaming keys in an object.
-- The first key is the most up-to-date version of a key, the others are for backward-compatibility.
--
-- If a key (new or old) exists, the inner parser will always be executed for that key.
keyRenamed :: (Monad m) => NonEmpty Text -> Json.ParseT err m a -> Json.ParseT err m a
keyRenamed :: forall (m :: Type -> Type) err a.
Monad m =>
NonEmpty Text -> ParseT err m a -> ParseT err m a
keyRenamed (Text
newKey :| [Text]
oldKeys) ParseT err m a
inner =
  forall (m :: Type -> Type) err a.
Monad m =>
[Text] -> ParseT err m a -> ParseT err m (Maybe (ParseT err m a))
keyRenamedTryOldKeys [Text]
oldKeys ParseT err m a
inner forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (ParseT err m a)
Nothing -> forall (m :: Type -> Type) err a.
(Functor m, Monad m) =>
Text -> ParseT err m a -> ParseT err m a
Json.key Text
newKey ParseT err m a
inner
    Just ParseT err m a
parse -> ParseT err m a
parse

-- | Like 'Json.keyMay', but allows a list of keys that are tried in order.
--
-- This is intended for renaming keys in an object.
-- The first key is the most up-to-date version of a key, the others are for backward-compatibility.
--
-- If a key (new or old) exists, the inner parser will always be executed for that key.
keyRenamedMay :: (Monad m) => NonEmpty Text -> Json.ParseT err m a -> Json.ParseT err m (Maybe a)
keyRenamedMay :: forall (m :: Type -> Type) err a.
Monad m =>
NonEmpty Text -> ParseT err m a -> ParseT err m (Maybe a)
keyRenamedMay (Text
newKey :| [Text]
oldKeys) ParseT err m a
inner =
  forall (m :: Type -> Type) err a.
Monad m =>
[Text] -> ParseT err m a -> ParseT err m (Maybe (ParseT err m a))
keyRenamedTryOldKeys [Text]
oldKeys ParseT err m a
inner forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (ParseT err m a)
Nothing -> forall (m :: Type -> Type) err a.
(Functor m, Monad m) =>
Text -> ParseT err m a -> ParseT err m (Maybe a)
Json.keyMay Text
newKey ParseT err m a
inner
    Just ParseT err m a
parse -> forall a. a -> Maybe a
Just forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseT err m a
parse

-- | Helper function for 'keyRenamed' and 'keyRenamedMay' that returns the parser for the first old key that exists, if any.
keyRenamedTryOldKeys :: (Monad m) => [Text] -> Json.ParseT err m a -> Json.ParseT err m (Maybe (Json.ParseT err m a))
keyRenamedTryOldKeys :: forall (m :: Type -> Type) err a.
Monad m =>
[Text] -> ParseT err m a -> ParseT err m (Maybe (ParseT err m a))
keyRenamedTryOldKeys [Text]
oldKeys ParseT err m a
inner = do
  [Text]
oldKeys forall a b. a -> (a -> b) -> b
& forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {m :: Type -> Type} {err}.
Monad m =>
Text -> ParseT err m (Maybe (ParseT err m a))
tryOld forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a. [Maybe a] -> [a]
catMaybes forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Maybe (NonEmpty (ParseT err m a))
Nothing -> forall a. Maybe a
Nothing
    Just (ParseT err m a
old :| [ParseT err m a]
_moreOld) -> forall a. a -> Maybe a
Just ParseT err m a
old
  where
    tryOld :: Text -> ParseT err m (Maybe (ParseT err m a))
tryOld Text
key =
      forall (m :: Type -> Type) err a.
(Functor m, Monad m) =>
Text -> ParseT err m a -> ParseT err m (Maybe a)
Json.keyMay Text
key (forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()) forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        Just () -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type) err a.
(Functor m, Monad m) =>
Text -> ParseT err m a -> ParseT err m a
Json.key Text
key ParseT err m a
inner
        Maybe ()
Nothing -> forall a. Maybe a
Nothing

-- | A simple type isomorphic to `()` that that transforms to an empty json object and parses
data EmptyObject = EmptyObject
  deriving stock (Int -> EmptyObject -> ShowS
[EmptyObject] -> ShowS
EmptyObject -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EmptyObject] -> ShowS
$cshowList :: [EmptyObject] -> ShowS
show :: EmptyObject -> String
$cshow :: EmptyObject -> String
showsPrec :: Int -> EmptyObject -> ShowS
$cshowsPrec :: Int -> EmptyObject -> ShowS
Show, EmptyObject -> EmptyObject -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EmptyObject -> EmptyObject -> Bool
$c/= :: EmptyObject -> EmptyObject -> Bool
== :: EmptyObject -> EmptyObject -> Bool
$c== :: EmptyObject -> EmptyObject -> Bool
Eq)

instance FromJSON EmptyObject where
  -- allow any fields, as long as its an object
  parseJSON :: Value -> Parser EmptyObject
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"EmptyObject" (\Object
_ -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure EmptyObject
EmptyObject)

instance ToJSON EmptyObject where
  toJSON :: EmptyObject -> Value
toJSON EmptyObject
EmptyObject = Object -> Value
Object forall a. Monoid a => a
mempty
  toEncoding :: EmptyObject -> Encoding
toEncoding EmptyObject
EmptyObject = forall a. ToJSON a => a -> Encoding
toEncoding forall a b. (a -> b) -> a -> b
$ Object -> Value
Object forall a. Monoid a => a
mempty

-- | Create a json array from a list of json values.
mkJsonArray :: [Value] -> Value
mkJsonArray :: [Value] -> Value
mkJsonArray [Value]
xs = [Value]
xs forall a b. a -> (a -> b) -> b
& forall a. [a] -> Vector a
Vector.fromList forall a b. a -> (a -> b) -> b
& Vector Value -> Value
Array