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

module Json where

import Data.Aeson (FromJSON (parseJSON), ToJSON (toEncoding, toJSON), Value (..), withObject)
import Data.Aeson.BetterErrors qualified as Json
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Error.Tree
import Data.Maybe (catMaybes)
import Data.Text qualified as Text
import Data.Vector qualified as Vector
import Label
import PossehlAnalyticsPrelude
import Test.Hspec.Core.Spec (describe, it)
import Test.Hspec.Core.Spec qualified as Hspec
import Test.Hspec.Expectations (shouldBe)

-- | 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

-- | 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

-- | 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

test_keyRenamed :: Hspec.Spec
test_keyRenamed :: Spec
test_keyRenamed = do
  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"keyRenamed" forall a b. (a -> b) -> a -> b
$ do
    let parser :: ParseT err Identity Text
parser = forall (m :: Type -> Type) err a.
Monad m =>
NonEmpty Text -> ParseT err m a -> ParseT err m a
keyRenamed (Text
"new" forall a. a -> [a] -> NonEmpty a
:| [Text
"old"]) forall (m :: Type -> Type) err.
(Functor m, Monad m) =>
ParseT err m Text
Json.asText
    let p :: Value -> Either (ParseError ()) Text
p = forall err a. Parse err a -> Value -> Either (ParseError err) a
Json.parseValue @() forall {err}. ParseT err Identity Text
parser
    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"accepts the new key and the old key" forall a b. (a -> b) -> a -> b
$ do
      Value -> Either (ParseError ()) Text
p (Object -> Value
Object (forall v. Key -> v -> KeyMap v
KeyMap.singleton Key
"new" (Text -> Value
String Text
"text")))
        forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` (forall a b. b -> Either a b
Right Text
"text")
      Value -> Either (ParseError ()) Text
p (Object -> Value
Object (forall v. Key -> v -> KeyMap v
KeyMap.singleton Key
"old" (Text -> Value
String Text
"text")))
        forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` (forall a b. b -> Either a b
Right Text
"text")
    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"fails with the old key in the error if the inner parser is wrong" forall a b. (a -> b) -> a -> b
$ do
      Value -> Either (ParseError ()) Text
p (Object -> Value
Object (forall v. Key -> v -> KeyMap v
KeyMap.singleton Key
"old" Value
Null))
        forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` (forall a b. a -> Either a b
Left (forall err. [PathPiece] -> ErrorSpecifics err -> ParseError err
Json.BadSchema [Text -> PathPiece
Json.ObjectKey Text
"old"] (forall err. JSONType -> Value -> ErrorSpecifics err
Json.WrongType JSONType
Json.TyString Value
Null)))
    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"fails with the new key in the error if the inner parser is wrong" forall a b. (a -> b) -> a -> b
$ do
      Value -> Either (ParseError ()) Text
p (Object -> Value
Object (forall v. Key -> v -> KeyMap v
KeyMap.singleton Key
"new" Value
Null))
        forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` (forall a b. a -> Either a b
Left (forall err. [PathPiece] -> ErrorSpecifics err -> ParseError err
Json.BadSchema [Text -> PathPiece
Json.ObjectKey Text
"new"] (forall err. JSONType -> Value -> ErrorSpecifics err
Json.WrongType JSONType
Json.TyString Value
Null)))
    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"fails if the key is missing" forall a b. (a -> b) -> a -> b
$ do
      Value -> Either (ParseError ()) Text
p (Object -> Value
Object forall v. KeyMap v
KeyMap.empty)
        forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` (forall a b. a -> Either a b
Left (forall err. [PathPiece] -> ErrorSpecifics err -> ParseError err
Json.BadSchema [] (forall err. Text -> ErrorSpecifics err
Json.KeyMissing Text
"new")))
  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"keyRenamedMay" forall a b. (a -> b) -> a -> b
$ do
    let parser :: ParseT err Identity (Maybe Text)
parser = forall (m :: Type -> Type) err a.
Monad m =>
NonEmpty Text -> ParseT err m a -> ParseT err m (Maybe a)
keyRenamedMay (Text
"new" forall a. a -> [a] -> NonEmpty a
:| [Text
"old"]) forall (m :: Type -> Type) err.
(Functor m, Monad m) =>
ParseT err m Text
Json.asText
    let p :: Value -> Either (ParseError ()) (Maybe Text)
p = forall err a. Parse err a -> Value -> Either (ParseError err) a
Json.parseValue @() forall {err}. ParseT err Identity (Maybe Text)
parser
    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"accepts the new key and the old key" forall a b. (a -> b) -> a -> b
$ do
      Value -> Either (ParseError ()) (Maybe Text)
p (Object -> Value
Object (forall v. Key -> v -> KeyMap v
KeyMap.singleton Key
"new" (Text -> Value
String Text
"text")))
        forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` (forall a b. b -> Either a b
Right (forall a. a -> Maybe a
Just Text
"text"))
      Value -> Either (ParseError ()) (Maybe Text)
p (Object -> Value
Object (forall v. Key -> v -> KeyMap v
KeyMap.singleton Key
"old" (Text -> Value
String Text
"text")))
        forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` (forall a b. b -> Either a b
Right (forall a. a -> Maybe a
Just Text
"text"))
    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"allows the old and new key to be missing" forall a b. (a -> b) -> a -> b
$ do
      Value -> Either (ParseError ()) (Maybe Text)
p (Object -> Value
Object forall v. KeyMap v
KeyMap.empty)
        forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` (forall a b. b -> Either a b
Right 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.
jsonArray :: [Value] -> Value
jsonArray :: [Value] -> Value
jsonArray [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