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

module Autodocodec.Aeson.Decode 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 :: 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 :: ValueCodec void a -> Value -> Parser a
parseJSONVia = ValueCodec void a -> Value -> 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 :: Codec context void a -> context -> Parser a
parseJSONContextVia Codec context void a
codec_ context
context_ =
  (String -> String) -> Parser a -> Parser a
forall a. (String -> String) -> Parser a -> Parser a
modifyFailure (\String
s -> if Char
'\n' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
s then String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s else String
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 :: 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 -> () -> Parser ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Value
_ -> String -> Value -> Parser a
forall a. String -> Value -> Parser a
typeMismatch String
"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 -> String -> (Bool -> Parser Bool) -> Value -> Parser Bool
forall a. String -> (Bool -> Parser a) -> Value -> Parser a
withBool (Text -> String
T.unpack Text
name) Bool -> Parser Bool
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 -> String -> (Text -> Parser Text) -> Value -> Parser Text
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText (Text -> String
T.unpack Text
name) Text -> Parser Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure context
Value
value
      NumberCodec Maybe Text
mname Maybe NumberBounds
mBounds ->
        ( \Scientific -> Parser Scientific
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 Scientific) -> Parser Scientific
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Scientific -> Parser Scientific
f
            Just Text
name -> String
-> (Scientific -> Parser Scientific) -> Value -> Parser Scientific
forall a. String -> (Scientific -> Parser a) -> Value -> Parser a
withScientific (Text -> String
T.unpack Text
name) Scientific -> Parser Scientific
f context
Value
value
        )
          ( \Scientific
s -> case (Scientific -> Either String Scientific)
-> (NumberBounds -> Scientific -> Either String Scientific)
-> Maybe NumberBounds
-> Scientific
-> Either String Scientific
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Scientific -> Either String Scientific
forall a b. b -> Either a b
Right NumberBounds -> Scientific -> Either String Scientific
checkNumberBounds Maybe NumberBounds
mBounds Scientific
s of
              Left String
err -> String -> Parser Scientific
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
              Right Scientific
s' -> Scientific -> Parser Scientific
forall (f :: * -> *) a. Applicative f => a -> f a
pure Scientific
s'
          )
      ArrayOfCodec Maybe Text
mname ValueCodec input output
c ->
        ( \Array -> Parser (Vector output)
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 (Vector output)) -> Parser (Vector output)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Array -> Parser (Vector output)
f
            Just Text
name -> String
-> (Array -> Parser (Vector output))
-> Value
-> Parser (Vector output)
forall a. String -> (Array -> Parser a) -> Value -> Parser a
withArray (Text -> String
T.unpack Text
name) Array -> Parser (Vector output)
f context
Value
value
        )
          ( \Array
vector ->
              Vector (Int, Value)
-> ((Int, Value) -> Parser output) -> Parser (Vector output)
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 input output -> Parser output
forall context void a. context -> Codec context void a -> Parser a
go Value
v ValueCodec input output
c Parser output -> JSONPathElement -> Parser output
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Object -> Parser a
f
            Just Text
name -> String -> (Object -> Parser a) -> Value -> Parser a
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject (Text -> String
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)
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)
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 -> Value -> Parser Value
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 void -> Parser void
forall (f :: * -> *) a. Applicative f => a -> f a
pure void
actual
          else String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser a) -> String -> Parser a
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"Expected", void -> String
forall a. Show a => a -> String
show void
expected, String
"but got", void -> String
forall a. Show a => a -> String
show void
actual]
      BimapCodec oldOutput -> Either String 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 String a
f oldOutput
old of
          Left String
err -> String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
          Right a
new -> 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 String (Either output1 output2)
forall a b. (a -> Parser b) -> a -> Either String b
parseEither context -> Parser (Either output1 output2)
leftParser context
value of
                  Right Either output1 output2
l -> Either output1 output2 -> Parser (Either output1 output2)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either output1 output2
l
                  Left String
err -> String
-> Parser (Either output1 output2)
-> Parser (Either output1 output2)
forall a. String -> Parser a -> Parser a
prependFailure (String
"  Previous branch failure: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n") (context -> Parser (Either output1 output2)
rightParser context
value)
              Union
DisjointUnion ->
                case ((context -> Parser (Either output1 output2))
-> context -> Either String (Either output1 output2)
forall a b. (a -> Parser b) -> a -> Either String b
parseEither context -> Parser (Either output1 output2)
leftParser context
value, (context -> Parser (Either output1 output2))
-> context -> Either String (Either output1 output2)
forall a b. (a -> Parser b) -> a -> Either String b
parseEither context -> Parser (Either output1 output2)
rightParser context
value) of
                  (Left String
_, Right Either output1 output2
r) -> Either output1 output2 -> Parser (Either output1 output2)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either output1 output2
r
                  (Right Either output1 output2
l, Left String
_) -> Either output1 output2 -> Parser (Either output1 output2)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either output1 output2
l
                  (Right Either output1 output2
_, Right Either output1 output2
_) -> String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Both branches of a disjoint union succeeded."
                  (Left String
lErr, Left String
rErr) ->
                    String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser a) -> String -> Parser a
forall a b. (a -> b) -> a -> b
$
                      [String] -> String
unlines
                        [ String
"Both branches of a disjoint union failed: ",
                          [String] -> String
unwords [String
"Left:  ", String
lErr],
                          [String] -> String
unwords [String
"Right: ", String
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 -> String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser a) -> String -> Parser a
forall a b. (a -> b) -> a -> b
$ String
"Unexpected discriminator value: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack 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 input output
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 output) -> Parser (Maybe output)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe Value
mValueAtKey ((Value -> Parser output) -> Parser (Maybe output))
-> (Value -> Parser output) -> Parser (Maybe output)
forall a b. (a -> b) -> a -> b
$ \Value
valueAtKey -> Value -> ValueCodec input output -> Parser output
forall context void a. context -> Codec context void a -> Parser a
go (Value
valueAtKey :: JSON.Value) ValueCodec input output
c Parser output -> JSONPathElement -> Parser output
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 -> void -> Parser void
forall (f :: * -> *) a. Applicative f => a -> f a
pure void
defaultValue
          Just Value
valueAtKey -> Value -> JSONCodec void -> Parser void
forall context void a. context -> Codec context void a -> Parser a
go (Value
valueAtKey :: JSON.Value) JSONCodec void
c Parser void -> JSONPathElement -> Parser void
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 void void -> Parser void
forall context void a. context -> Codec context void a -> Parser a
go context
value (Codec context void void -> Parser void)
-> Codec context void void -> Parser void
forall a b. (a -> b) -> a -> b
$ Text
-> JSONCodec void -> void -> Maybe Text -> ObjectCodec void void
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 -> a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
      ApCodec ObjectCodec void (output -> a)
ocf ObjectCodec void output
oca -> Object -> ObjectCodec void (output -> a) -> Parser (output -> a)
forall context void a. context -> Codec context void a -> Parser a
go (context
Object
value :: JSON.Object) ObjectCodec void (output -> a)
ocf Parser (output -> a) -> Parser output -> Parser a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> ObjectCodec void output -> Parser output
forall context void a. context -> Codec context void a -> Parser a
go (context
Object
value :: JSON.Object) ObjectCodec void output
oca

instance HasCodec a => JSON.FromJSON (Autodocodec a) where
  parseJSON :: Value -> Parser (Autodocodec a)
parseJSON = (a -> Autodocodec a) -> Parser a -> Parser (Autodocodec a)
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