{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Data.Validity.Aeson where

import Data.Aeson
#if MIN_VERSION_aeson(2,0,0)
import Data.Aeson.KeyMap (KeyMap)
import qualified Data.Aeson.KeyMap as KM
import qualified Data.Aeson.Key as K
#endif
import Data.Aeson.Types
import Data.Validity
import Data.Validity.HashMap ()
import Data.Validity.Scientific ()
import Data.Validity.Text ()
import Data.Validity.Vector ()

#if MIN_VERSION_aeson(2,0,0)
instance Validity v => Validity (KeyMap v) where
  validate :: KeyMap v -> Validation
validate KeyMap v
m = HashMap Key v -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate (KeyMap v -> HashMap Key v
forall v. KeyMap v -> HashMap Key v
KM.toHashMap KeyMap v
m) String
"KeyMap"

instance Validity Key where
  validate :: Key -> Validation
validate Key
k = Text -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate (Key -> Text
K.toText Key
k) String
"Key"
#endif

-- | A 'Value' is valid if the recursive components are valid.
instance Validity Value where
  validate :: Value -> Validation
validate (Object Object
o) = Object -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate Object
o String
"Object"
  validate (Array Array
a) = Array -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate Array
a String
"Array"
  validate (String Text
t) = Text -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate Text
t String
"String"
  validate (Number Scientific
s) = Scientific -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate Scientific
s String
"Number"
  validate (Bool Bool
b) = Bool -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate Bool
b String
"Bool"
  validate Value
Null = Validation
valid

-- | Modify a parser to fail on invalid results.
parseJSONValid :: Validity a => Parser a -> Parser a
parseJSONValid :: Parser a -> Parser a
parseJSONValid Parser a
p = do
  a
r <- Parser a
p
  case a -> Either String a
forall a. Validity a => a -> Either String a
prettyValidate a
r of
    Left String
err -> 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
"Parsed value is not valid:", String
err]
    Right a
r' -> a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r'

-- | Modify a parsing function to fail on invalid results.
--
-- Easy to use with the `withX` helper functions:
--
-- > parseJSON = parseJSONValidWith . withObject "MyThing" $ \o ->
-- >   MyThing <$> ...
parseJSONValidWith :: Validity a => (value -> Parser a) -> (value -> Parser a)
parseJSONValidWith :: (value -> Parser a) -> value -> Parser a
parseJSONValidWith value -> Parser a
func value
v = Parser a -> Parser a
forall a. Validity a => Parser a -> Parser a
parseJSONValid (Parser a -> Parser a) -> Parser a -> Parser a
forall a b. (a -> b) -> a -> b
$ value -> Parser a
func value
v