{-# 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 = forall void a. ValueCodec void a -> Value -> Parser a
parseJSONVia 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 = 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 = forall void a. ObjectCodec void a -> Object -> Parser a
parseJSONObjectVia 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 = 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_ =
  forall a. ([Char] -> [Char]) -> Parser a -> Parser a
modifyFailure (\[Char]
s -> if Char
'\n' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
s then [Char]
"\n" forall a. [a] -> [a] -> [a]
++ [Char]
s else [Char]
s) forall a b. (a -> b) -> a -> b
$
    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 :: JSON.Value) of
        Value
Null -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Value
_ -> forall a. [Char] -> Value -> Parser a
typeMismatch [Char]
"Null" context
value
      BoolCodec Maybe Text
mname -> case Maybe Text
mname of
        Maybe Text
Nothing -> forall a. FromJSON a => Value -> Parser a
parseJSON context
value
        Just Text
name -> forall a. [Char] -> (Bool -> Parser a) -> Value -> Parser a
withBool (Text -> [Char]
T.unpack Text
name) forall (f :: * -> *) a. Applicative f => a -> f a
pure context
value
      StringCodec Maybe Text
mname -> case Maybe Text
mname of
        Maybe Text
Nothing -> forall a. FromJSON a => Value -> Parser a
parseJSON context
value
        Just Text
name -> forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText (Text -> [Char]
T.unpack Text
name) forall (f :: * -> *) a. Applicative f => a -> f a
pure context
value
      NumberCodec Maybe Text
mname Maybe NumberBounds
mBounds ->
        ( \Scientific -> Parser a
f -> case Maybe Text
mname of
            Maybe Text
Nothing -> forall a. FromJSON a => Value -> Parser a
parseJSON context
value forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Scientific -> Parser a
f
            Just Text
name -> forall a. [Char] -> (Scientific -> Parser a) -> Value -> Parser a
withScientific (Text -> [Char]
T.unpack Text
name) Scientific -> Parser a
f context
value
        )
          ( \Scientific
s -> case forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a b. b -> Either a b
Right NumberBounds -> Scientific -> Either [Char] Scientific
checkNumberBounds Maybe NumberBounds
mBounds Scientific
s of
              Left [Char]
err -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
err
              Right Scientific
s' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Scientific
s'
          )
      ArrayOfCodec Maybe Text
mname ValueCodec input output
c ->
        ( \Array -> Parser a
f -> case Maybe Text
mname of
            Maybe Text
Nothing -> forall a. FromJSON a => Value -> Parser a
parseJSON context
value forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Array -> Parser a
f
            Just Text
name -> forall a. [Char] -> (Array -> Parser a) -> Value -> Parser a
withArray (Text -> [Char]
T.unpack Text
name) Array -> Parser a
f context
value
        )
          ( \Array
vector ->
              forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM
                (forall a. Vector a -> Vector (Int, a)
V.indexed (Array
vector :: Vector JSON.Value))
                ( \(Int
ix, Value
v) ->
                    forall context void a. context -> Codec context void a -> Parser a
go Value
v ValueCodec input output
c 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 -> forall a. FromJSON a => Value -> Parser a
parseJSON context
value forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Object -> Parser a
f
            Just Text
name -> forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject (Text -> [Char]
T.unpack Text
name) Object -> Parser a
f context
value
        )
          (\Object
object_ -> (forall context void a. context -> Codec context void a -> Parser a
`go` ObjectCodec void a
c) (Object
object_ :: JSON.Object))
      HashMapCodec JSONCodec v
c -> forall (f :: * -> *) a.
FromJSON1 f =>
(Value -> Parser a)
-> (Value -> Parser [a]) -> Value -> Parser (f a)
Compat.liftParseJSON (forall context void a. context -> Codec context void a -> Parser a
`go` JSONCodec v
c) (forall context void a. context -> Codec context void a -> Parser a
`go` forall input output.
ValueCodec input output -> ValueCodec [input] [output]
listCodec JSONCodec v
c) context
value :: JSON.Parser (HashMap _ _)
      MapCodec JSONCodec v
c -> forall (f :: * -> *) a.
FromJSON1 f =>
(Value -> Parser a)
-> (Value -> Parser [a]) -> Value -> Parser (f a)
Compat.liftParseJSON (forall context void a. context -> Codec context void a -> Parser a
`go` JSONCodec v
c) (forall context void a. context -> Codec context void a -> Parser a
`go` forall input output.
ValueCodec input output -> ValueCodec [input] [output]
listCodec JSONCodec v
c) context
value :: JSON.Parser (Map _ _)
      Codec context void a
ValueCodec -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (context
value :: JSON.Value)
      EqCodec void
expected JSONCodec void
c -> do
        void
actual <- forall context void a. context -> Codec context void a -> Parser a
go context
value JSONCodec void
c
        if void
expected forall a. Eq a => a -> a -> Bool
== void
actual
          then forall (f :: * -> *) a. Applicative f => a -> f a
pure void
actual
          else forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [[Char]
"Expected", forall a. Show a => a -> [Char]
show void
expected, [Char]
"but got", 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 <- 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 -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
err
          Right a
new -> 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 = forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Either output1 output2
l
                  Left [Char]
err -> forall a. [Char] -> Parser a -> Parser a
prependFailure ([Char]
"  Previous branch failure: " forall a. Semigroup a => a -> a -> a
<> [Char]
err forall a. Semigroup a => a -> a -> a
<> [Char]
"\n") (context -> Parser (Either output1 output2)
rightParser context
value)
              Union
DisjointUnion ->
                case (forall a b. (a -> Parser b) -> a -> Either [Char] b
parseEither context -> Parser (Either output1 output2)
leftParser context
value, 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) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Either output1 output2
r
                  (Right Either output1 output2
l, Left [Char]
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Either output1 output2
l
                  (Right Either output1 output2
_, Right Either output1 output2
_) -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Both branches of a disjoint union succeeded."
                  (Left [Char]
lErr, Left [Char]
rErr) ->
                    forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail 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
value :: JSON.Object) forall a. FromJSON a => Object -> Key -> Parser a
JSON..: Text -> Key
Compat.toKey Text
propertyName
        case 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 -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected discriminator value: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Text
discriminatorValue
          Just (Text
_, ObjectCodec Void a
c) ->
            forall context void a. context -> Codec context void a -> Parser a
go context
value ObjectCodec Void a
c
      CommentCodec Text
_ ValueCodec void a
c -> forall context void a. context -> Codec context void a -> Parser a
go context
value ValueCodec void a
c
      ReferenceCodec Text
_ ValueCodec void a
c -> forall context void a. context -> Codec context void a -> Parser a
go context
value ValueCodec void a
c
      RequiredKeyCodec Text
k ValueCodec void a
c Maybe Text
_ -> do
        Value
valueAtKey <- (context
value :: JSON.Object) forall a. FromJSON a => Object -> Key -> Parser a
JSON..: Text -> Key
Compat.toKey Text
k
        forall context void a. context -> Codec context void a -> Parser a
go Value
valueAtKey ValueCodec void a
c forall a. Parser a -> JSONPathElement -> Parser a
JSON.<?> Key -> JSONPathElement
Key (Text -> Key
Compat.toKey Text
k)
      OptionalKeyCodec Text
k ValueCodec input output
c Maybe Text
_ -> do
        let key :: Key
key = Text -> Key
Compat.toKey Text
k
            mValueAtKey :: Maybe Value
mValueAtKey = forall v. Key -> KeyMap v -> Maybe v
Compat.lookupKey Key
key (context
value :: JSON.Object)
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Value
mValueAtKey forall a b. (a -> b) -> a -> b
$ \Value
valueAtKey -> forall context void a. context -> Codec context void a -> Parser a
go (Value
valueAtKey :: JSON.Value) ValueCodec input output
c 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 = forall v. Key -> KeyMap v -> Maybe v
Compat.lookupKey Key
key (context
value :: JSON.Object)
        case Maybe Value
mValueAtKey of
          Maybe Value
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure void
defaultValue
          Just Value
valueAtKey -> forall context void a. context -> Codec context void a -> Parser a
go (Value
valueAtKey :: JSON.Value) JSONCodec void
c forall a. Parser a -> JSONPathElement -> Parser a
JSON.<?> Key -> JSONPathElement
Key Key
key
      OptionalKeyWithOmittedDefaultCodec Text
k JSONCodec void
c void
defaultValue Maybe Text
mDoc -> forall context void a. context -> Codec context void a -> Parser a
go context
value forall a b. (a -> b) -> a -> b
$ forall value.
Text
-> ValueCodec value value
-> value
-> Maybe Text
-> ObjectCodec value value
OptionalKeyWithDefaultCodec Text
k JSONCodec void
c void
defaultValue Maybe Text
mDoc
      PureCodec a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
      ApCodec ObjectCodec void (output -> a)
ocf ObjectCodec void output
oca -> forall context void a. context -> Codec context void a -> Parser a
go (context
value :: JSON.Object) ObjectCodec void (output -> a)
ocf forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall context void a. context -> Codec context void a -> Parser a
go (context
value :: JSON.Object) ObjectCodec void output
oca

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