{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# OPTIONS_GHC -fno-warn-partial-type-signatures -fno-warn-orphans #-}

module Autodocodec.Aeson.Decode
  ( -- * Decoding JSON Values
    parseJSONViaCodec,
    parseJSONVia,

    -- ** Decoding JSON Objects
    parseJSONObjectViaCodec,
    parseJSONObjectVia,

    -- ** Internal
    parseJSONContextVia,
  )
where

import qualified Autodocodec.Aeson.Compat as Compat
import Autodocodec.Class
import Autodocodec.Codec
import Autodocodec.DerivingVia
import Control.Monad
import Data.Aeson as JSON
import Data.Aeson.Types as JSON
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Map (Map)
import qualified Data.Text as T
import Data.Vector (Vector)
import qualified Data.Vector as V

-- | Implement 'JSON.parseJSON' via a type's codec.
parseJSONViaCodec :: (HasCodec a) => JSON.Value -> JSON.Parser a
parseJSONViaCodec :: forall a. HasCodec a => Value -> Parser a
parseJSONViaCodec = ValueCodec a a -> Value -> Parser a
forall void a. ValueCodec void a -> Value -> Parser a
parseJSONVia ValueCodec a a
forall value. HasCodec value => JSONCodec value
codec

-- | Implement 'JSON.parseJSON' via a given codec.
parseJSONVia :: ValueCodec void a -> JSON.Value -> JSON.Parser a
parseJSONVia :: forall void a. ValueCodec void a -> Value -> Parser a
parseJSONVia = Codec Value void a -> Value -> Parser a
forall context void a. Codec context void a -> context -> Parser a
parseJSONContextVia

parseJSONObjectViaCodec :: (HasObjectCodec a) => JSON.Object -> JSON.Parser a
parseJSONObjectViaCodec :: forall a. HasObjectCodec a => Object -> Parser a
parseJSONObjectViaCodec = ObjectCodec a a -> Object -> Parser a
forall void a. ObjectCodec void a -> Object -> Parser a
parseJSONObjectVia ObjectCodec a a
forall object. HasObjectCodec object => JSONObjectCodec object
objectCodec

parseJSONObjectVia :: ObjectCodec void a -> JSON.Object -> JSON.Parser a
parseJSONObjectVia :: forall void a. ObjectCodec void a -> Object -> Parser a
parseJSONObjectVia = Codec Object void a -> Object -> Parser a
forall context void a. Codec context void a -> context -> Parser a
parseJSONContextVia

-- | Parse via a general codec.
--
-- You probably won't need this. See 'eitherDecodeViaCodec', 'parseJSONViaCodec' and 'parseJSONVia' instead.
parseJSONContextVia :: Codec context void a -> context -> JSON.Parser a
parseJSONContextVia :: forall context void a. Codec context void a -> context -> Parser a
parseJSONContextVia Codec context void a
codec_ context
context_ =
  ([Char] -> [Char]) -> Parser a -> Parser a
forall a. ([Char] -> [Char]) -> Parser a -> Parser a
modifyFailure (\[Char]
s -> if Char
'\n' Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
s then [Char]
"\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s else [Char]
s) (Parser a -> Parser a) -> Parser a -> Parser a
forall a b. (a -> b) -> a -> b
$
    context -> Codec context void a -> Parser a
forall context void a. context -> Codec context void a -> Parser a
go context
context_ Codec context void a
codec_
  where
    -- We use type-annotations here for readability of type information that is
    -- gathered to case-matching on GADTs, they aren't strictly necessary.
    go :: context -> Codec context void a -> JSON.Parser a
    go :: forall context void a. context -> Codec context void a -> Parser a
go context
value = \case
      Codec context void a
NullCodec -> case (context
Value
value :: JSON.Value) of
        Value
Null -> a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Value
_ -> [Char] -> Value -> Parser a
forall a. [Char] -> Value -> Parser a
typeMismatch [Char]
"Null" context
Value
value
      BoolCodec Maybe Text
mname -> case Maybe Text
mname of
        Maybe Text
Nothing -> Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON context
Value
value
        Just Text
name -> [Char] -> (Bool -> Parser a) -> Value -> Parser a
forall a. [Char] -> (Bool -> Parser a) -> Value -> Parser a
withBool (Text -> [Char]
T.unpack Text
name) Bool -> Parser a
Bool -> Parser Bool
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure context
Value
value
      StringCodec Maybe Text
mname -> case Maybe Text
mname of
        Maybe Text
Nothing -> Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON context
Value
value
        Just Text
name -> [Char] -> (Text -> Parser a) -> Value -> Parser a
forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText (Text -> [Char]
T.unpack Text
name) Text -> Parser a
Text -> Parser Text
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure context
Value
value
      NumberCodec Maybe Text
mname Maybe NumberBounds
mBounds ->
        ( \Scientific -> Parser a
f -> case Maybe Text
mname of
            Maybe Text
Nothing -> Value -> Parser Scientific
forall a. FromJSON a => Value -> Parser a
parseJSON context
Value
value Parser Scientific -> (Scientific -> Parser a) -> Parser a
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Scientific -> Parser a
f
            Just Text
name -> [Char] -> (Scientific -> Parser a) -> Value -> Parser a
forall a. [Char] -> (Scientific -> Parser a) -> Value -> Parser a
withScientific (Text -> [Char]
T.unpack Text
name) Scientific -> Parser a
f context
Value
value
        )
          ( \Scientific
s -> case (Scientific -> Either [Char] Scientific)
-> (NumberBounds -> Scientific -> Either [Char] Scientific)
-> Maybe NumberBounds
-> Scientific
-> Either [Char] Scientific
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Scientific -> Either [Char] Scientific
forall a b. b -> Either a b
Right NumberBounds -> Scientific -> Either [Char] Scientific
checkNumberBounds Maybe NumberBounds
mBounds Scientific
s of
              Left [Char]
err -> [Char] -> Parser a
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
err
              Right Scientific
s' -> a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
Scientific
s'
          )
      ArrayOfCodec Maybe Text
mname ValueCodec input1 output1
c ->
        ( \Array -> Parser a
f -> case Maybe Text
mname of
            Maybe Text
Nothing -> Value -> Parser Array
forall a. FromJSON a => Value -> Parser a
parseJSON context
Value
value Parser Array -> (Array -> Parser a) -> Parser a
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Array -> Parser a
f
            Just Text
name -> [Char] -> (Array -> Parser a) -> Value -> Parser a
forall a. [Char] -> (Array -> Parser a) -> Value -> Parser a
withArray (Text -> [Char]
T.unpack Text
name) Array -> Parser a
f context
Value
value
        )
          ( \Array
vector ->
              Vector (Int, Value)
-> ((Int, Value) -> Parser output1) -> Parser (Vector output1)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM
                (Array -> Vector (Int, Value)
forall a. Vector a -> Vector (Int, a)
V.indexed (Array
vector :: Vector JSON.Value))
                ( \(Int
ix, Value
v) ->
                    Value -> ValueCodec input1 output1 -> Parser output1
forall context void a. context -> Codec context void a -> Parser a
go Value
v ValueCodec input1 output1
c Parser output1 -> JSONPathElement -> Parser output1
forall a. Parser a -> JSONPathElement -> Parser a
JSON.<?> Int -> JSONPathElement
Index Int
ix
                )
          )
      ObjectOfCodec Maybe Text
mname ObjectCodec void a
c ->
        ( \Object -> Parser a
f -> case Maybe Text
mname of
            Maybe Text
Nothing -> Value -> Parser Object
forall a. FromJSON a => Value -> Parser a
parseJSON context
Value
value Parser Object -> (Object -> Parser a) -> Parser a
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Object -> Parser a
f
            Just Text
name -> [Char] -> (Object -> Parser a) -> Value -> Parser a
forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject (Text -> [Char]
T.unpack Text
name) Object -> Parser a
f context
Value
value
        )
          (\Object
object_ -> (Object -> ObjectCodec void a -> Parser a
forall context void a. context -> Codec context void a -> Parser a
`go` ObjectCodec void a
c) (Object
object_ :: JSON.Object))
      HashMapCodec JSONCodec v
c -> (Value -> Parser v)
-> (Value -> Parser [v]) -> Value -> Parser (HashMap k v)
forall (f :: * -> *) a.
FromJSON1 f =>
(Value -> Parser a)
-> (Value -> Parser [a]) -> Value -> Parser (f a)
Compat.liftParseJSON (Value -> JSONCodec v -> Parser v
forall context void a. context -> Codec context void a -> Parser a
`go` JSONCodec v
c) (Value -> Codec Value [v] [v] -> Parser [v]
forall context void a. context -> Codec context void a -> Parser a
`go` JSONCodec v -> Codec Value [v] [v]
forall input output.
ValueCodec input output -> ValueCodec [input] [output]
listCodec JSONCodec v
c) context
Value
value :: JSON.Parser (HashMap _ _)
      MapCodec JSONCodec v
c -> (Value -> Parser v)
-> (Value -> Parser [v]) -> Value -> Parser (Map k v)
forall (f :: * -> *) a.
FromJSON1 f =>
(Value -> Parser a)
-> (Value -> Parser [a]) -> Value -> Parser (f a)
Compat.liftParseJSON (Value -> JSONCodec v -> Parser v
forall context void a. context -> Codec context void a -> Parser a
`go` JSONCodec v
c) (Value -> Codec Value [v] [v] -> Parser [v]
forall context void a. context -> Codec context void a -> Parser a
`go` JSONCodec v -> Codec Value [v] [v]
forall input output.
ValueCodec input output -> ValueCodec [input] [output]
listCodec JSONCodec v
c) context
Value
value :: JSON.Parser (Map _ _)
      Codec context void a
ValueCodec -> a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (context
Value
value :: JSON.Value)
      EqCodec void
expected JSONCodec void
c -> do
        void
actual <- context -> Codec context void void -> Parser void
forall context void a. context -> Codec context void a -> Parser a
go context
value Codec context void void
JSONCodec void
c
        if void
expected void -> void -> Bool
forall a. Eq a => a -> a -> Bool
== void
actual
          then a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure void
a
actual
          else [Char] -> Parser a
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser a) -> [Char] -> Parser a
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [[Char]
"Expected", void -> [Char]
forall a. Show a => a -> [Char]
show void
expected, [Char]
"but got", void -> [Char]
forall a. Show a => a -> [Char]
show void
actual]
      BimapCodec oldOutput -> Either [Char] a
f void -> oldInput
_ Codec context oldInput oldOutput
c -> do
        oldOutput
old <- context -> Codec context oldInput oldOutput -> Parser oldOutput
forall context void a. context -> Codec context void a -> Parser a
go context
value Codec context oldInput oldOutput
c
        case oldOutput -> Either [Char] a
f oldOutput
old of
          Left [Char]
err -> [Char] -> Parser a
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
err
          Right a
new -> a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
new
      EitherCodec Union
u Codec context input1 output1
c1 Codec context input2 output2
c2 ->
        let leftParser :: context -> Parser (Either output1 output2)
leftParser context
v = output1 -> Either output1 output2
forall a b. a -> Either a b
Left (output1 -> Either output1 output2)
-> Parser output1 -> Parser (Either output1 output2)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> context -> Codec context input1 output1 -> Parser output1
forall context void a. context -> Codec context void a -> Parser a
go context
v Codec context input1 output1
c1
            rightParser :: context -> Parser (Either output1 output2)
rightParser context
v = output2 -> Either output1 output2
forall a b. b -> Either a b
Right (output2 -> Either output1 output2)
-> Parser output2 -> Parser (Either output1 output2)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> context -> Codec context input2 output2 -> Parser output2
forall context void a. context -> Codec context void a -> Parser a
go context
v Codec context input2 output2
c2
         in case Union
u of
              Union
PossiblyJointUnion ->
                case (context -> Parser (Either output1 output2))
-> context -> Either [Char] (Either output1 output2)
forall a b. (a -> Parser b) -> a -> Either [Char] b
parseEither context -> Parser (Either output1 output2)
leftParser context
value of
                  Right Either output1 output2
l -> a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
Either output1 output2
l
                  Left [Char]
err -> [Char] -> Parser a -> Parser a
forall a. [Char] -> Parser a -> Parser a
prependFailure ([Char]
"  Previous branch failure: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
err [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"\n") (context -> Parser (Either output1 output2)
rightParser context
value)
              Union
DisjointUnion ->
                case ((context -> Parser (Either output1 output2))
-> context -> Either [Char] (Either output1 output2)
forall a b. (a -> Parser b) -> a -> Either [Char] b
parseEither context -> Parser (Either output1 output2)
leftParser context
value, (context -> Parser (Either output1 output2))
-> context -> Either [Char] (Either output1 output2)
forall a b. (a -> Parser b) -> a -> Either [Char] b
parseEither context -> Parser (Either output1 output2)
rightParser context
value) of
                  (Left [Char]
_, Right Either output1 output2
r) -> a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
Either output1 output2
r
                  (Right Either output1 output2
l, Left [Char]
_) -> a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
Either output1 output2
l
                  (Right Either output1 output2
_, Right Either output1 output2
_) -> [Char] -> Parser a
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Both branches of a disjoint union succeeded."
                  (Left [Char]
lErr, Left [Char]
rErr) ->
                    [Char] -> Parser a
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser a) -> [Char] -> Parser a
forall a b. (a -> b) -> a -> b
$
                      [[Char]] -> [Char]
unlines
                        [ [Char]
"Both branches of a disjoint union failed: ",
                          [[Char]] -> [Char]
unwords [[Char]
"Left:  ", [Char]
lErr],
                          [[Char]] -> [Char]
unwords [[Char]
"Right: ", [Char]
rErr]
                        ]
      DiscriminatedUnionCodec Text
propertyName void -> (Text, ObjectCodec void ())
_ HashMap Text (Text, ObjectCodec Void a)
m -> do
        Text
discriminatorValue <- (context
Object
value :: JSON.Object) Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
JSON..: Text -> Key
Compat.toKey Text
propertyName
        case Text
-> HashMap Text (Text, ObjectCodec Void a)
-> Maybe (Text, ObjectCodec Void a)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
discriminatorValue HashMap Text (Text, ObjectCodec Void a)
m of
          Maybe (Text, ObjectCodec Void a)
Nothing -> [Char] -> Parser a
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser a) -> [Char] -> Parser a
forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected discriminator value: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show Text
discriminatorValue
          Just (Text
_, ObjectCodec Void a
c) ->
            context -> Codec context Void a -> Parser a
forall context void a. context -> Codec context void a -> Parser a
go context
value Codec context Void a
ObjectCodec Void a
c
      CommentCodec Text
_ ValueCodec void a
c -> context -> Codec context void a -> Parser a
forall context void a. context -> Codec context void a -> Parser a
go context
value Codec context void a
ValueCodec void a
c
      ReferenceCodec Text
_ ValueCodec void a
c -> context -> Codec context void a -> Parser a
forall context void a. context -> Codec context void a -> Parser a
go context
value Codec context void a
ValueCodec void a
c
      RequiredKeyCodec Text
k ValueCodec void a
c Maybe Text
_ -> do
        Value
valueAtKey <- (context
Object
value :: JSON.Object) Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
JSON..: Text -> Key
Compat.toKey Text
k
        Value -> ValueCodec void a -> Parser a
forall context void a. context -> Codec context void a -> Parser a
go Value
valueAtKey ValueCodec void a
c Parser a -> JSONPathElement -> Parser a
forall a. Parser a -> JSONPathElement -> Parser a
JSON.<?> Key -> JSONPathElement
Key (Text -> Key
Compat.toKey Text
k)
      OptionalKeyCodec Text
k ValueCodec input1 output1
c Maybe Text
_ -> do
        let key :: Key
key = Text -> Key
Compat.toKey Text
k
            mValueAtKey :: Maybe Value
mValueAtKey = Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
Compat.lookupKey Key
key (context
Object
value :: JSON.Object)
        Maybe Value -> (Value -> Parser output1) -> Parser (Maybe output1)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Value
mValueAtKey ((Value -> Parser output1) -> Parser (Maybe output1))
-> (Value -> Parser output1) -> Parser (Maybe output1)
forall a b. (a -> b) -> a -> b
$ \Value
valueAtKey -> Value -> ValueCodec input1 output1 -> Parser output1
forall context void a. context -> Codec context void a -> Parser a
go (Value
valueAtKey :: JSON.Value) ValueCodec input1 output1
c Parser output1 -> JSONPathElement -> Parser output1
forall a. Parser a -> JSONPathElement -> Parser a
JSON.<?> Key -> JSONPathElement
Key Key
key
      OptionalKeyWithDefaultCodec Text
k JSONCodec void
c void
defaultValue Maybe Text
_ -> do
        let key :: Key
key = Text -> Key
Compat.toKey Text
k
            mValueAtKey :: Maybe Value
mValueAtKey = Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
Compat.lookupKey Key
key (context
Object
value :: JSON.Object)
        case Maybe Value
mValueAtKey of
          Maybe Value
Nothing -> a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure void
a
defaultValue
          Just Value
valueAtKey -> Value -> ValueCodec void a -> Parser a
forall context void a. context -> Codec context void a -> Parser a
go (Value
valueAtKey :: JSON.Value) JSONCodec void
ValueCodec void a
c Parser a -> JSONPathElement -> Parser a
forall a. Parser a -> JSONPathElement -> Parser a
JSON.<?> Key -> JSONPathElement
Key Key
key
      OptionalKeyWithOmittedDefaultCodec Text
k JSONCodec void
c void
defaultValue Maybe Text
mDoc -> context -> Codec context a a -> Parser a
forall context void a. context -> Codec context void a -> Parser a
go context
value (Codec context a a -> Parser a) -> Codec context a a -> Parser a
forall a b. (a -> b) -> a -> b
$ Text -> ValueCodec a a -> a -> Maybe Text -> Codec Object a a
forall input.
Text
-> ValueCodec input input
-> input
-> Maybe Text
-> Codec Object input input
OptionalKeyWithDefaultCodec Text
k JSONCodec void
ValueCodec a a
c void
a
defaultValue Maybe Text
mDoc
      PureCodec a
a -> a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
      ApCodec ObjectCodec void (output1 -> a)
ocf ObjectCodec void output1
oca -> Object -> ObjectCodec void (output1 -> a) -> Parser (output1 -> a)
forall context void a. context -> Codec context void a -> Parser a
go (context
Object
value :: JSON.Object) ObjectCodec void (output1 -> a)
ocf Parser (output1 -> a) -> Parser output1 -> Parser a
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> ObjectCodec void output1 -> Parser output1
forall context void a. context -> Codec context void a -> Parser a
go (context
Object
value :: JSON.Object) ObjectCodec void output1
oca

instance (HasCodec a) => JSON.FromJSON (Autodocodec a) where
  parseJSON :: Value -> Parser (Autodocodec a)
parseJSON = (a -> Autodocodec a) -> Parser a -> Parser (Autodocodec a)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Autodocodec a
forall a. a -> Autodocodec a
Autodocodec (Parser a -> Parser (Autodocodec a))
-> (Value -> Parser a) -> Value -> Parser (Autodocodec a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
forall a. HasCodec a => Value -> Parser a
parseJSONViaCodec