-----------------------------------------------------------------------------
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE AllowAmbiguousTypes        #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -Wno-orphans #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.JSON
-- Copyright   :  (C) 2016-2026 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
--
-- = Overview
--
-- "Miso.JSON" is a JSON library tailored to 'MisoString', modelled after
-- <https://hackage.haskell.org/package/aeson aeson> and inspired by
-- <https://hackage.haskell.org/package/microaeson microaeson>. It provides
-- encoding, decoding, and a Generic-deriving mechanism that mirrors aeson's
-- defaults, making it straightforward to reuse existing aeson-compatible type
-- class instances.
--
-- = Platform behaviour
--
-- * __Client__ (WASM \/ GHC JS backend) — 'encode' calls @JSON.stringify()@ and
--   'decode' calls @JSON.parse()@ via FFI for maximum performance.
-- * __Server__ (@-fssr@ \/ @VANILLA@ build) — a pure Haskell
--   lexer\/parser pipeline ("Miso.JSON.Lexer" + "Miso.JSON.Parser") is used
--   instead, with no JavaScript dependency.
--
-- The same type class instances work on both platforms; only the underlying
-- serialisation primitive differs.
--
-- = Quick start
--
-- @
-- {-\# LANGUAGE DeriveGeneric \#-}
-- import GHC.Generics (Generic)
-- import "Miso.JSON"
-- import "Miso.String" ('MisoString')
--
-- data Person = Person
--   { name :: MisoString
--   , age  :: Int
--   } deriving (Generic, Show, Eq)
--
-- instance 'ToJSON'   Person
-- instance 'FromJSON' Person
--
-- -- Encode to a JSON string:
-- encoded :: 'MisoString'
-- encoded = 'encode' (Person \"Alice\" 30)
-- -- Result: @\"{\\\"name\\\":\\\"Alice\\\",\\\"age\\\":30}\"@
--
-- -- Decode from a JSON string:
-- decoded :: Maybe Person
-- decoded = 'decode' encoded
-- @
--
-- = Constructing JSON values
--
-- Use 'object' and @.=@ to build 'Value' trees without defining a type:
--
-- @
-- point :: 'Value'
-- point = 'object' [ \"x\" @.=@ (10 :: Int), \"y\" @.=@ (20 :: Int) ]
-- @
--
-- = Writing instances by hand
--
-- @
-- data Color = Red | Green | Blue
--
-- instance 'ToJSON' Color where
--   'toJSON' Red   = 'Miso.JSON.Types.String' \"red\"
--   'toJSON' Green = 'Miso.JSON.Types.String' \"green\"
--   'toJSON' Blue  = 'Miso.JSON.Types.String' \"blue\"
--
-- instance 'FromJSON' Color where
--   'parseJSON' = 'withText' \"Color\" $ \\case
--     \"red\"   -> pure Red
--     \"green\" -> pure Green
--     \"blue\"  -> pure Blue
--     t       -> 'typeMismatch' \"Color\" ('Miso.JSON.Types.String' t)
-- @
--
-- = Generic encoding options
--
-- Generic instances follow aeson's default strategy. Customise with t'Options':
--
-- @
-- myOptions :: t'Options'
-- myOptions = 'defaultOptions' { 'fieldLabelModifier' = 'camelTo2' \'_\' }
--
-- instance 'ToJSON' Person where
--   'toJSON' = 'genericToJSON' myOptions
--
-- -- { \"person_name\": \"Alice\", \"person_age\": 30 }
-- @
--
-- = API groups
--
-- * __Core types__ — 'Value', t'Object', 'Pair', 'Result'
-- * __Constructors__ — 'object', @.=@, 'emptyObject', 'emptyArray'
-- * __Accessors__ — @.:@ (required), '.:?' (optional), '.:!' (optional\/nullable), '.!=' (default)
-- * __Encoding__ — 'encode', 'encodePure', 'encodePretty', 'encodePretty''
-- * __Decoding__ — 'decode', 'eitherDecode', 'Parser.decodePure'
-- * __Type classes__ — 'ToJSON', 'FromJSON', t'Parser'
-- * __Prism-style parsers__ — 'withObject', 'withText', 'withArray', 'withNumber', 'withBool'
-- * __Conversion__ — 'fromJSON', 'parseMaybe', 'parseEither'
-- * __Options \/ Generics__ — t'Options', 'defaultOptions', 'genericToJSON', 'genericParseJSON', 'camelTo2'
-- * __FFI__ — 'toJSVal_Value', 'fromJSVal_Value', 'jsonStringify', 'jsonParse'
--
-- = See also
--
-- * "Miso.JSON.Types" — 'Value' and 'Result' type definitions
-- * "Miso.JSON.Lexer" — pure Haskell JSON tokeniser (server build)
-- * "Miso.JSON.Parser" — pure Haskell JSON parser (server build)
-- * "Miso.Event.Decoder" — uses t'Parser' and 'Value' for DOM event decoding
-- * "Miso.String" — 'MisoString', 'ms'
--
----------------------------------------------------------------------------
module Miso.JSON
  ( -- * JSON
    -- ** Core JSON types
    Value(..)
  , Object
  , Pair
  , Result (..)
    -- ** Constructors
  , (.=)
  , object
  , emptyArray
  , emptyObject
    -- ** Accessors
  , (.:)
  , (.:?)
  , (.:!)
  , (.!=)
    -- * Encoding and decoding
  , encode
  , encodePure
  , decode
  , Parser.decodePure
    -- * Prism-style parsers
  , withObject
  , withText
  , withArray
  , withNumber
  , withBool
    -- * Type conversion
  , FromJSON(parseJSON)
#ifdef AESON
  , Parser
#else
  , Parser (..)
#endif
  , parseMaybe
  , ToJSON(..)
  -- * Misc.
  , fromJSON
  , parseEither
  , eitherDecode
  , typeMismatch
  -- * Pretty
  , encodePretty
  , encodePretty'
  , defConfig
  , Config (..)
  -- * FFI
  , fromJSVal_Value
  , toJSVal_Value
  , jsonStringify
  , jsonParse
  -- * Options
  , Options (..)
  , defaultOptions
  -- * Generics
#ifndef AESON
  , GToJSON (..)
  , GToFields (..)
  , GToJSONRep (..)
  , GToJSONSum (..)
  , GToJSONSumNullary (..)
  , GAllNullary (..)
  , Fields (..)
  , GFromJSON (..)
  , GFromFields (..)
  , GFromJSONRep (..)
  , GFromJSONSum (..)
  , GFromJSONSumNullary (..)
#endif
  , genericToJSON
  , genericParseJSON
  -- * Modifiers
  , camelTo2
  ) where
----------------------------------------------------------------------------
#ifdef GHCJS_BOTH
import qualified GHCJS.Marshal as Marshal
#endif
----------------------------------------------------------------------------
import           Control.Monad
#if __GLASGOW_HASKELL__ <= 865
import           Control.Monad.Fail
import           GHC.Natural (Natural)
#endif
#ifdef AESON
import           Data.Aeson.Types
  ( ToJSON (..), FromJSON (..), Parser, Options (..), Key
  , defaultOptions, camelTo2, genericToJSON, genericParseJSON
  , object, emptyArray, emptyObject, parseMaybe, (.!=)
  )
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
import qualified Data.Aeson.Key as Key
import           Data.Bifunctor (first)
import           Data.Scientific (Scientific, toRealFloat, fromFloatDigits)
#ifndef VANILLA
import           Data.Aeson.Types (ToJSONKey (..), FromJSONKey (..), FromJSONKeyFunction (..), toJSONKeyText)
import qualified Data.Aeson.KeyMap as KeyMap
#endif
#else
import           Control.Applicative
import           Data.Char
import qualified Data.Map.Strict as M
import           Data.Map.Strict (Map)
import           Data.Maybe (fromMaybe)
import           Data.Int
import           GHC.Natural (naturalToInteger, naturalFromInteger)
import           GHC.TypeLits
import           Data.Kind
import qualified Data.Text.Lazy as LT
import           Data.Word
import           GHC.Generics
#endif
----------------------------------------------------------------------------
import           Miso.DSL.FFI
#ifdef AESON
import           Miso.String (FromMisoString, ToMisoString, MisoString, ms, pack)
#else
import           Miso.String (FromMisoString, ToMisoString, MisoString, ms, singleton, pack)
#endif
import qualified Miso.String as MS
import           Miso.JSON.Types
import qualified Miso.JSON.Parser as Parser
#ifndef AESON
import           Numeric (showHex)
#endif
----------------------------------------------------------------------------
#ifndef VANILLA
import           Control.Monad.Trans.Maybe
import           Data.Foldable (toList)
import           System.IO.Unsafe (unsafePerformIO)
import qualified Data.Text as T
#endif

----------------------------------------------------------------------------
-- | Construct a JSON key\/value 'Pair'. Infix alias for @\\k v -> (k, 'toJSON' v)@.
--
-- @
-- object [ \"name\" .= (\"Alice\" :: MisoString), \"age\" .= (30 :: Int) ]
-- @
infixr 8 .=
#ifdef AESON
(.=) :: ToJSON v => MisoString -> v -> Pair
k .= v  = (toKey k, toJSON v)
----------------------------------------------------------------------------
-- | Convert a t'MisoString' to an aeson 'Key'.
toKey :: MisoString -> Key
toKey = Key.fromText . MS.fromMisoString
----------------------------------------------------------------------------
-- 'object', 'emptyObject', 'emptyArray', and '.!=' are re-exported from aeson.
----------------------------------------------------------------------------
-- | Look up a required key in a JSON t'Object'.
-- Fails with a parse error if the key is absent.
(.:) :: FromJSON a => Object -> MisoString -> Parser a
m .: k = (Aeson..:) m (toKey k)
----------------------------------------------------------------------------
-- | Look up an optional key in a JSON t'Object'.
-- Returns 'Nothing' if the key is absent; delegates to 'parseJSON' if present.
(.:?) :: FromJSON a => Object -> MisoString -> Parser (Maybe a)
m .:? k = (Aeson..:?) m (toKey k)
----------------------------------------------------------------------------
-- | Like '.:?' but always wraps a present value in 'Just', so a key with a
-- @null@ JSON value decodes to @Just Null@ rather than 'Nothing'.
-- Useful when you need to distinguish a missing key from an explicit null.
(.:!) :: FromJSON a => Object -> MisoString -> Parser (Maybe a)
m .:! k = (Aeson..:!) m (toKey k)
#else
(.=) :: ToJSON v => MisoString -> v -> Pair
MisoString
k .= :: forall v. ToJSON v => MisoString -> v -> (MisoString, Value)
.= v
v  = (MisoString
k, v -> Value
forall a. ToJSON a => a -> Value
toJSON v
v)
----------------------------------------------------------------------------
-- | Create a 'Value' from a list of name\/value 'Pair's.
object :: [Pair] -> Value
object :: [(MisoString, Value)] -> Value
object = Map MisoString Value -> Value
Object (Map MisoString Value -> Value)
-> ([(MisoString, Value)] -> Map MisoString Value)
-> [(MisoString, Value)]
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(MisoString, Value)] -> Map MisoString Value
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
----------------------------------------------------------------------------
-- | The empty JSON t'Object' (i.e. @{}@).
emptyObject :: Value
emptyObject :: Value
emptyObject = Map MisoString Value -> Value
Object Map MisoString Value
forall a. Monoid a => a
mempty
----------------------------------------------------------------------------
-- | The empty JSON 'Array' (i.e. @[]@).
emptyArray :: Value
emptyArray :: Value
emptyArray = [Value] -> Value
Array [Value]
forall a. Monoid a => a
mempty
----------------------------------------------------------------------------
-- | Look up a required key in a JSON t'Object'.
-- Fails with a parse error if the key is absent.
(.:) :: FromJSON a => Object -> MisoString -> Parser a
Map MisoString Value
m .: :: forall a.
FromJSON a =>
Map MisoString Value -> MisoString -> Parser a
.: MisoString
k = Parser a -> (Value -> Parser a) -> Maybe Value -> Parser a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (MisoString -> Parser a
forall a. MisoString -> Parser a
pfail (MisoString
"Key not found: " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
k)) Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON (MisoString -> Map MisoString Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MisoString
k Map MisoString Value
m)
----------------------------------------------------------------------------
-- | Look up an optional key in a JSON t'Object'.
-- Returns 'Nothing' if the key is absent; delegates to 'parseJSON' if present.
(.:?) :: FromJSON a => Object -> MisoString -> Parser (Maybe a)
Map MisoString Value
m .:? :: forall a.
FromJSON a =>
Map MisoString Value -> MisoString -> Parser (Maybe a)
.:? MisoString
k = Parser (Maybe a)
-> (Value -> Parser (Maybe a)) -> Maybe Value -> Parser (Maybe a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe a -> Parser (Maybe a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing) Value -> Parser (Maybe a)
forall a. FromJSON a => Value -> Parser a
parseJSON (MisoString -> Map MisoString Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MisoString
k Map MisoString Value
m)
----------------------------------------------------------------------------
-- | Like '.:?' but always wraps a present value in 'Just', so a key with a
-- @null@ JSON value decodes to @Just Null@ rather than 'Nothing'.
-- Useful when you need to distinguish a missing key from an explicit null.
(.:!) :: FromJSON a => Object -> MisoString -> Parser (Maybe a)
Map MisoString Value
m .:! :: forall a.
FromJSON a =>
Map MisoString Value -> MisoString -> Parser (Maybe a)
.:! MisoString
k = Parser (Maybe a)
-> (Value -> Parser (Maybe a)) -> Maybe Value -> Parser (Maybe a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe a -> Parser (Maybe a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing) ((a -> Maybe a) -> Parser a -> Parser (Maybe a)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (Parser a -> Parser (Maybe a))
-> (Value -> Parser a) -> Value -> Parser (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON) (MisoString -> Map MisoString Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MisoString
k Map MisoString Value
m)
----------------------------------------------------------------------------
-- | Provide a default when a t'Parser' produces 'Nothing'.
-- Typically chained after '.:?':
--
-- @o '.:?' \"count\" '.!=' 0@
(.!=) :: Parser (Maybe a) -> a -> Parser a
Parser (Maybe a)
mv .!= :: forall a. Parser (Maybe a) -> a -> Parser a
.!= a
def = (Maybe a -> a) -> Parser (Maybe a) -> Parser a
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
def) Parser (Maybe a)
mv
#endif
----------------------------------------------------------------------------
#ifdef AESON
#ifndef VANILLA
-- On the JavaScript and WASM backends t'MisoString' is @JSString@, which
-- aeson does not know about; these orphans make it a first-class JSON
-- citizen so code written against "Miso.JSON" keeps compiling.
instance ToJSON MisoString where
  toJSON = String . MS.fromMisoString
----------------------------------------------------------------------------
instance FromJSON MisoString where
  parseJSON = withText "MisoString" pure
----------------------------------------------------------------------------
instance ToJSONKey MisoString where
  toJSONKey = toJSONKeyText MS.fromMisoString
----------------------------------------------------------------------------
instance FromJSONKey MisoString where
  fromJSONKey = FromJSONKeyText ms
#endif
#else
-- | A type that can be serialised to a JSON 'Value'.
--
-- Instances for the most common Haskell types are provided. Derive via
-- 'GHC.Generics' for product\/sum types, or write instances by hand for
-- full control:
--
-- @
-- -- Generic derivation (mirrors aeson defaults):
-- data Point = Point { x :: Double, y :: Double }
--   deriving (Generic, Show, Eq)
-- instance 'ToJSON' Point
--
-- -- Manual instance:
-- instance 'ToJSON' Point where
--   'toJSON' (Point x y) = 'object' [\"x\" @.=@ x, \"y\" @.=@ y]
-- @
class ToJSON a where
  -- | Convert a value to a JSON 'Value'.
  toJSON :: a -> Value
  default toJSON :: (Generic a, GToJSON (Rep a)) => a -> Value
  toJSON = Options -> a -> Value
forall a. (Generic a, GToJSON (Rep a)) => Options -> a -> Value
genericToJSON Options
defaultOptions

  -- | Encode a list of @a@. Defaults to a JSON 'Array'; overridden by the
  -- 'Char' instance so that @[Char]@ (i.e. t'String') serializes as a JSON
  -- string. This mirrors aeson and avoids overlapping @ToJSON [a]@ instances.
  toJSONList :: [a] -> Value
  toJSONList = [Value] -> Value
Array ([Value] -> Value) -> ([a] -> [Value]) -> [a] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> [a] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map a -> Value
forall a. ToJSON a => a -> Value
toJSON
----------------------------------------------------------------------------
-- | Derive 'toJSON' via 'GHC.Generics' with custom t'Options'.
-- Called by the default 'ToJSON' implementation using 'defaultOptions'.
genericToJSON
  :: (Generic a, GToJSON (Rep a))
  => Options
  -- ^ Encoding options (field\/constructor name modifiers, etc.)
  -> a
  -- ^ Value to encode
  -> Value
genericToJSON :: forall a. (Generic a, GToJSON (Rep a)) => Options -> a -> Value
genericToJSON Options
opts = Options -> Rep a (ZonkAny 1) -> Value
forall a. Options -> Rep a a -> Value
forall (f :: * -> *) a. GToJSON f => Options -> f a -> Value
gToJSON Options
opts (Rep a (ZonkAny 1) -> Value)
-> (a -> Rep a (ZonkAny 1)) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a (ZonkAny 1)
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from
----------------------------------------------------------------------------
-- | Configuration for generic JSON encoding and decoding via 'genericToJSON'
-- and 'genericParseJSON'. Mirrors the subset of aeson's @Options@ that is
-- relevant to miso's Generic machinery.
--
-- Construct with 'defaultOptions' and override only the fields you need:
--
-- @
-- myOpts :: t'Options'
-- myOpts = 'defaultOptions' { 'fieldLabelModifier' = 'camelTo2' \'_\' }
-- @
data Options
  = Options
  { Options -> String -> String
fieldLabelModifier    :: String -> String
  -- ^ Applied to each record field name before encoding\/decoding (default: identity).
  , Options -> String -> String
constructorTagModifier :: String -> String
  -- ^ Modify constructor names used as tags before encoding (default: identity).
  , Options -> Bool
allNullaryToStringTag :: Bool
  -- ^ When 'True' (the default, matching aeson) and every constructor of a
  -- sum type is nullary, encode/decode each constructor as a bare JSON
  -- t'String' (e.g. @\"Red\"@) rather than a tagged object
  -- (e.g. @{\"tag\":\"Red\"}@).
  , Options -> Bool
omitNothingFields :: Bool
  -- ^ When 'True', record fields whose value is 'Nothing' are omitted from
  -- the encoded object entirely. When @False@ (the default, matching aeson)
  -- they are encoded as @null@.
  }
----------------------------------------------------------------------------
-- | Default encoding\/decoding options, matching aeson's defaults:
-- no field or constructor name transformation, 'allNullaryToStringTag' enabled,
-- 'omitNothingFields' disabled.
defaultOptions :: Options
defaultOptions :: Options
defaultOptions = Options
  { fieldLabelModifier :: String -> String
fieldLabelModifier     = \String
x -> String
x
  , constructorTagModifier :: String -> String
constructorTagModifier = \String
x -> String
x
  , allNullaryToStringTag :: Bool
allNullaryToStringTag  = Bool
True
  , omitNothingFields :: Bool
omitNothingFields      = Bool
False
  }
----------------------------------------------------------------------------
-- | Convert a camelCase identifier to a separated form using the given delimiter.
--
-- @
-- camelTo2 '_' \"camelCaseField\" == \"camel_case_field\"
-- @
--
-- Commonly used as 'fieldLabelModifier' in a custom t'Options'.
camelTo2
  :: Char
  -- ^ Delimiter character to insert between words (e.g. @\'_\'@ or @\'-\'@)
  -> String
  -- ^ camelCase identifier to transform
  -> String
camelTo2 :: Char -> String -> String
camelTo2 Char
c = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
Prelude.map Char -> Char
toLower (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
go2 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
go1
    where go1 :: String -> String
go1 String
"" = String
""
          go1 (Char
x:Char
u:Char
l:String
xs) | Char -> Bool
isUpper Char
u Bool -> Bool -> Bool
&& Char -> Bool
isLower Char
l = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: Char
u Char -> String -> String
forall a. a -> [a] -> [a]
: Char
l Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go1 String
xs
          go1 (Char
x:String
xs) = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go1 String
xs
          go2 :: String -> String
go2 String
"" = String
""
          go2 (Char
l:Char
u:String
xs) | Char -> Bool
isLower Char
l Bool -> Bool -> Bool
&& Char -> Bool
isUpper Char
u = Char
l Char -> String -> String
forall a. a -> [a] -> [a]
: Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: Char
u Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go2 String
xs
          go2 (Char
x:String
xs) = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go2 String
xs
----------------------------------------------------------------------------
-- | Intermediate representation of a constructor's fields after encoding.
--
-- 'RecordFields' is produced when every selector has a name (record syntax);
-- 'PositionalFields' is produced for all other constructors.
data Fields
  = RecordFields   [(MisoString, Value)]
  -- ^ Named fields (record constructor)
  | PositionalFields [Value]
  -- ^ Positional fields (non-record constructor)
----------------------------------------------------------------------------
combineFields :: Fields -> Fields -> Fields
combineFields :: Fields -> Fields -> Fields
combineFields (RecordFields   [(MisoString, Value)]
xs) (RecordFields   [(MisoString, Value)]
ys) = [(MisoString, Value)] -> Fields
RecordFields   ([(MisoString, Value)]
xs [(MisoString, Value)]
-> [(MisoString, Value)] -> [(MisoString, Value)]
forall a. Semigroup a => a -> a -> a
<> [(MisoString, Value)]
ys)
combineFields (PositionalFields [Value]
xs) (PositionalFields [Value]
ys) = [Value] -> Fields
PositionalFields ([Value]
xs [Value] -> [Value] -> [Value]
forall a. Semigroup a => a -> a -> a
<> [Value]
ys)
combineFields Fields
_ Fields
_ = [Value] -> Fields
PositionalFields []  -- mixed; shouldn't occur in valid GHC Generics
----------------------------------------------------------------------------
-- | Collect a constructor's fields into 'Fields'.
class GToFields (f :: Type -> Type) where
  gToFields :: Options -> f a -> Fields
----------------------------------------------------------------------------
instance GToFields U1 where
  gToFields :: forall a. Options -> U1 a -> Fields
gToFields Options
_ U1 a
_ = [Value] -> Fields
PositionalFields []
----------------------------------------------------------------------------
instance GToFields V1 where
  gToFields :: forall a. Options -> V1 a -> Fields
gToFields Options
_ V1 a
v = V1 a
v V1 a -> Fields -> Fields
forall a b. a -> b -> b
`seq` [Value] -> Fields
PositionalFields []
----------------------------------------------------------------------------
instance (GToFields f, GToFields g) => GToFields (f :*: g) where
  gToFields :: forall a. Options -> (:*:) f g a -> Fields
gToFields Options
opts (f a
x :*: g a
y) = Fields -> Fields -> Fields
combineFields (Options -> f a -> Fields
forall a. Options -> f a -> Fields
forall (f :: * -> *) a. GToFields f => Options -> f a -> Fields
gToFields Options
opts f a
x) (Options -> g a -> Fields
forall a. Options -> g a -> Fields
forall (f :: * -> *) a. GToFields f => Options -> f a -> Fields
gToFields Options
opts g a
y)
----------------------------------------------------------------------------
instance (Selector m, GToFields f) => GToFields (S1 m f) where
  gToFields :: forall a. Options -> S1 m f a -> Fields
gToFields Options
opts (M1 f a
x) =
    let n :: String
n = M1 S m f () -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t m f a -> String
selName (f () -> M1 S m f ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 f ()
forall a. HasCallStack => a
undefined :: S1 m f ())
    in if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
n
       then Options -> f a -> Fields
forall a. Options -> f a -> Fields
forall (f :: * -> *) a. GToFields f => Options -> f a -> Fields
gToFields Options
opts f a
x
       else case Options -> f a -> Fields
forall a. Options -> f a -> Fields
forall (f :: * -> *) a. GToFields f => Options -> f a -> Fields
gToFields Options
opts f a
x of
              PositionalFields [Value
v] -> [(MisoString, Value)] -> Fields
RecordFields [(String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (Options -> String -> String
fieldLabelModifier Options
opts String
n), Value
v)]
              Fields
fs                   -> Fields
fs  -- shouldn't happen
----------------------------------------------------------------------------
instance ToJSON a => GToFields (K1 r a) where
  gToFields :: forall a. Options -> K1 r a a -> Fields
gToFields Options
_ (K1 a
x) = [Value] -> Fields
PositionalFields [a -> Value
forall a. ToJSON a => a -> Value
toJSON a
x]
----------------------------------------------------------------------------
-- | Special 'GToFields' instance for @'Maybe' a@ fields that honours
-- 'omitNothingFields': when the option is 'True' and the value is
-- 'Nothing', the field is omitted from the encoded object entirely.
instance {-# OVERLAPPING #-} (Selector m, ToJSON a)
    => GToFields (S1 m (K1 r (Maybe a))) where
  gToFields :: forall a. Options -> S1 m (K1 r (Maybe a)) a -> Fields
gToFields Options
opts (M1 (K1 Maybe a
mx)) =
    let n :: String
n   = M1 S m (K1 r (Maybe a)) () -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t m f a -> String
selName (K1 r (Maybe a) () -> M1 S m (K1 r (Maybe a)) ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 K1 r (Maybe a) ()
forall a. HasCallStack => a
undefined :: S1 m (K1 r (Maybe a)) ())
        key :: MisoString
key = String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (Options -> String -> String
fieldLabelModifier Options
opts String
n)
    in if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
n
       then [Value] -> Fields
PositionalFields [Maybe a -> Value
forall a. ToJSON a => a -> Value
toJSON Maybe a
mx]
       else case Maybe a
mx of
              Maybe a
Nothing | Options -> Bool
omitNothingFields Options
opts -> [(MisoString, Value)] -> Fields
RecordFields []
              Maybe a
_                                -> [(MisoString, Value)] -> Fields
RecordFields [(MisoString
key, Maybe a -> Value
forall a. ToJSON a => a -> Value
toJSON Maybe a
mx)]
----------------------------------------------------------------------------
-- | Determine at the type level whether every constructor of a sum type
-- is nullary (has no fields). Used to implement 'allNullaryToStringTag'.
class GAllNullary (f :: Type -> Type) where
  gAllNullary :: Bool
----------------------------------------------------------------------------
instance GAllNullary U1 where
  gAllNullary :: Bool
gAllNullary = Bool
True
----------------------------------------------------------------------------
instance GAllNullary (K1 r a) where
  gAllNullary :: Bool
gAllNullary = Bool
False
----------------------------------------------------------------------------
instance (GAllNullary f, GAllNullary g) => GAllNullary (f :*: g) where
  gAllNullary :: Bool
gAllNullary = Bool
False  -- has multiple fields, definitely not nullary
----------------------------------------------------------------------------
instance GAllNullary f => GAllNullary (S1 m f) where
  gAllNullary :: Bool
gAllNullary = forall (f :: * -> *). GAllNullary f => Bool
gAllNullary @f
----------------------------------------------------------------------------
instance GAllNullary f => GAllNullary (C1 m f) where
  gAllNullary :: Bool
gAllNullary = forall (f :: * -> *). GAllNullary f => Bool
gAllNullary @f
----------------------------------------------------------------------------
instance (GAllNullary f, GAllNullary g) => GAllNullary (f :+: g) where
  gAllNullary :: Bool
gAllNullary = forall (f :: * -> *). GAllNullary f => Bool
gAllNullary @f Bool -> Bool -> Bool
&& forall (f :: * -> *). GAllNullary f => Bool
gAllNullary @g
----------------------------------------------------------------------------
-- | Encode a single-constructor (product) type. No tag is added.
--
-- * Record:       @{"field1": v, ...}@
-- * 0 fields:     @[]@
-- * 1 field:      the value itself (unwrapped, like a newtype)
-- * 2+ fields:    @[v1, v2, ...]@
encodeProduct :: Fields -> Value
encodeProduct :: Fields -> Value
encodeProduct = \case
  RecordFields   [(MisoString, Value)]
kvs  -> Map MisoString Value -> Value
Object ([(MisoString, Value)] -> Map MisoString Value
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(MisoString, Value)]
kvs)
  PositionalFields []  -> [Value] -> Value
Array []
  PositionalFields [Value
v] -> Value
v
  PositionalFields [Value]
vs  -> [Value] -> Value
Array [Value]
vs
----------------------------------------------------------------------------
-- | Encode a sum constructor. Adds a @\"tag\"@ key.
--
-- * Record:       @{\"tag\": \"C\", \"field1\": v, ...}@
-- * 0 fields:     @{\"tag\": \"C\"}@
-- * 1 field:      @{\"tag\": \"C\", \"contents\": v}@
-- * 2+ fields:    @{\"tag\": \"C\", \"contents\": [v1, v2, ...]}@
encodeTaggedCon :: MisoString -> Fields -> Value
encodeTaggedCon :: MisoString -> Fields -> Value
encodeTaggedCon MisoString
tag = \case
  RecordFields   [(MisoString, Value)]
kvs  -> Map MisoString Value -> Value
Object ([(MisoString, Value)] -> Map MisoString Value
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ((MisoString
"tag", MisoString -> Value
String MisoString
tag) (MisoString, Value)
-> [(MisoString, Value)] -> [(MisoString, Value)]
forall a. a -> [a] -> [a]
: [(MisoString, Value)]
kvs))
  PositionalFields []  -> Map MisoString Value -> Value
Object (MisoString -> Value -> Map MisoString Value
forall k a. k -> a -> Map k a
M.singleton MisoString
"tag" (MisoString -> Value
String MisoString
tag))
  PositionalFields [Value
v] -> [(MisoString, Value)] -> Value
object [(MisoString
"tag", MisoString -> Value
String MisoString
tag), (MisoString
"contents", Value
v)]
  PositionalFields [Value]
vs  -> [(MisoString, Value)] -> Value
object [(MisoString
"tag", MisoString -> Value
String MisoString
tag), (MisoString
"contents", [Value] -> Value
Array [Value]
vs)]
----------------------------------------------------------------------------
-- | Top-level generic encoding class.
--
-- Encoding rules match aeson's defaults:
--
-- * All-nullary sum + 'allNullaryToStringTag':  @\"C\"@
-- * Single-constructor record:                  @{\"field1\": v1, ...}@
-- * Single-constructor positional:              @v@ (1 field), @[v1,v2,...]@ (n>1), @[]@ (0)
-- * Sum record constructor:                     @{\"tag\": \"C\", \"field1\": v1, ...}@
-- * Sum nullary constructor:                    @{\"tag\": \"C\"}@
-- * Sum positional constructor:                 @{\"tag\": \"C\", \"contents\": v}@ or @[...]@
class GToJSON (f :: Type -> Type) where
  gToJSON :: Options -> f a -> Value
----------------------------------------------------------------------------
instance GToJSONRep f => GToJSON (D1 m f) where
  gToJSON :: forall a. Options -> D1 m f a -> Value
gToJSON Options
opts (M1 f a
x) = Options -> f a -> Value
forall a. Options -> f a -> Value
forall (f :: * -> *) a. GToJSONRep f => Options -> f a -> Value
gToJSONRep Options
opts f a
x
----------------------------------------------------------------------------
-- Internal: dispatches single-constructor vs sum at the child of D1.
-- | Internal: dispatches on the child of @D1@, choosing the
-- single-constructor encoding or the sum encoding. Sits between 'GToJSON' and
-- 'GToFields' \/ 'GToJSONSum'.
--
-- @since 1.13.0.0
class GToJSONRep (f :: Type -> Type) where
  gToJSONRep :: Options -> f a -> Value
-- Single constructor: no tag
instance GToFields f => GToJSONRep (C1 m f) where
  gToJSONRep :: forall a. Options -> C1 m f a -> Value
gToJSONRep Options
opts (M1 f a
x) = Fields -> Value
encodeProduct (Options -> f a -> Fields
forall a. Options -> f a -> Fields
forall (f :: * -> *) a. GToFields f => Options -> f a -> Fields
gToFields Options
opts f a
x)
-- Sum: branch on allNullaryToStringTag
instance (GToJSONSum f, GToJSONSum g, GToJSONSumNullary f, GToJSONSumNullary g, GAllNullary f, GAllNullary g)
    => GToJSONRep (f :+: g) where
  gToJSONRep :: forall a. Options -> (:+:) f g a -> Value
gToJSONRep Options
opts (:+:) f g a
x
    | Options -> Bool
allNullaryToStringTag Options
opts Bool -> Bool -> Bool
&& forall (f :: * -> *). GAllNullary f => Bool
gAllNullary @f Bool -> Bool -> Bool
&& forall (f :: * -> *). GAllNullary f => Bool
gAllNullary @g
    = Options -> (:+:) f g a -> Value
forall a. Options -> (:+:) f g a -> Value
forall (f :: * -> *) a.
GToJSONSumNullary f =>
Options -> f a -> Value
gToJSONSumNullary Options
opts (:+:) f g a
x
    | Bool
otherwise
    = Options -> (:+:) f g a -> Value
forall a. Options -> (:+:) f g a -> Value
forall (f :: * -> *) a. GToJSONSum f => Options -> f a -> Value
gToJSONSum Options
opts (:+:) f g a
x
----------------------------------------------------------------------------
-- | Encode all-nullary sum constructors as bare t'String' values.
class GToJSONSumNullary (f :: Type -> Type) where
  gToJSONSumNullary :: Options -> f a -> Value
----------------------------------------------------------------------------
instance (GToJSONSumNullary f, GToJSONSumNullary g) => GToJSONSumNullary (f :+: g) where
  gToJSONSumNullary :: forall a. Options -> (:+:) f g a -> Value
gToJSONSumNullary Options
opts (L1 f a
x) = Options -> f a -> Value
forall a. Options -> f a -> Value
forall (f :: * -> *) a.
GToJSONSumNullary f =>
Options -> f a -> Value
gToJSONSumNullary Options
opts f a
x
  gToJSONSumNullary Options
opts (R1 g a
x) = Options -> g a -> Value
forall a. Options -> g a -> Value
forall (f :: * -> *) a.
GToJSONSumNullary f =>
Options -> f a -> Value
gToJSONSumNullary Options
opts g a
x
----------------------------------------------------------------------------
instance Constructor m => GToJSONSumNullary (C1 m U1) where
  gToJSONSumNullary :: forall a. Options -> C1 m U1 a -> Value
gToJSONSumNullary Options
opts C1 m U1 a
_ =
    MisoString -> Value
String (String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (Options -> String -> String
constructorTagModifier Options
opts (M1 C m U1 () -> String
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t m f a -> String
conName (M1 C m U1 ()
forall a. HasCallStack => a
undefined :: C1 m U1 ()))))
----------------------------------------------------------------------------
-- | Catch-all for non-nullary constructors — unreachable when 'gAllNullary'
-- guards are in place, but required for instance resolution.
instance {-# OVERLAPPABLE #-} Constructor m => GToJSONSumNullary (C1 m f) where
  gToJSONSumNullary :: forall a. Options -> C1 m f a -> Value
gToJSONSumNullary Options
_ C1 m f a
_ = String -> Value
forall a. HasCallStack => String -> a
error String
"GToJSONSumNullary: non-nullary constructor (impossible)"
----------------------------------------------------------------------------
-- | Encode sum constructors with a @\"tag\"@ key.
class GToJSONSum (f :: Type -> Type) where
  gToJSONSum :: Options -> f a -> Value
----------------------------------------------------------------------------
instance (GToJSONSum f, GToJSONSum g) => GToJSONSum (f :+: g) where
  gToJSONSum :: forall a. Options -> (:+:) f g a -> Value
gToJSONSum Options
opts (L1 f a
x) = Options -> f a -> Value
forall a. Options -> f a -> Value
forall (f :: * -> *) a. GToJSONSum f => Options -> f a -> Value
gToJSONSum Options
opts f a
x
  gToJSONSum Options
opts (R1 g a
x) = Options -> g a -> Value
forall a. Options -> g a -> Value
forall (f :: * -> *) a. GToJSONSum f => Options -> f a -> Value
gToJSONSum Options
opts g a
x
----------------------------------------------------------------------------
instance (Constructor m, GToFields f) => GToJSONSum (C1 m f) where
  gToJSONSum :: forall a. Options -> C1 m f a -> Value
gToJSONSum Options
opts (M1 f a
x) =
    MisoString -> Fields -> Value
encodeTaggedCon
      (String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (Options -> String -> String
constructorTagModifier Options
opts (M1 C m f () -> String
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t m f a -> String
conName (M1 C m f ()
forall a. HasCallStack => a
undefined :: C1 m f ()))))
      (Options -> f a -> Fields
forall a. Options -> f a -> Fields
forall (f :: * -> *) a. GToFields f => Options -> f a -> Fields
gToFields Options
opts f a
x)
----------------------------------------------------------------------------
instance ToJSON () where
  toJSON :: () -> Value
toJSON () = [Value] -> Value
Array []
----------------------------------------------------------------------------
instance ToJSON Value where
  toJSON :: Value -> Value
toJSON = Value -> Value
forall a. a -> a
id
----------------------------------------------------------------------------
instance ToJSON Char where
  toJSON :: Char -> Value
toJSON Char
c = MisoString -> Value
String (Char -> MisoString
singleton Char
c)
  toJSONList :: String -> Value
toJSONList = MisoString -> Value
String (MisoString -> Value) -> (String -> MisoString) -> String -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MisoString
MS.pack
----------------------------------------------------------------------------
instance ToJSON Bool where
  toJSON :: Bool -> Value
toJSON = Bool -> Value
Bool
----------------------------------------------------------------------------
instance ToJSON a => ToJSON [a] where
  toJSON :: [a] -> Value
toJSON = [a] -> Value
forall a. ToJSON a => [a] -> Value
toJSONList
----------------------------------------------------------------------------
instance ToJSON v => ToJSON (M.Map MisoString v) where
  toJSON :: Map MisoString v -> Value
toJSON = Map MisoString Value -> Value
Object (Map MisoString Value -> Value)
-> (Map MisoString v -> Map MisoString Value)
-> Map MisoString v
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v -> Value) -> Map MisoString v -> Map MisoString Value
forall a b k. (a -> b) -> Map k a -> Map k b
M.map v -> Value
forall a. ToJSON a => a -> Value
toJSON
----------------------------------------------------------------------------
instance ToJSON a => ToJSON (Maybe a) where
  toJSON :: Maybe a -> Value
toJSON = \case
    Maybe a
Nothing -> Value
Null
    Just a
a -> a -> Value
forall a. ToJSON a => a -> Value
toJSON a
a
----------------------------------------------------------------------------
instance (ToJSON a,ToJSON b) => ToJSON (a,b) where
  toJSON :: (a, b) -> Value
toJSON (a
a,b
b) = [Value] -> Value
Array [a -> Value
forall a. ToJSON a => a -> Value
toJSON a
a, b -> Value
forall a. ToJSON a => a -> Value
toJSON b
b]
----------------------------------------------------------------------------
instance (ToJSON a,ToJSON b,ToJSON c) => ToJSON (a,b,c) where
  toJSON :: (a, b, c) -> Value
toJSON (a
a,b
b,c
c) = [Value] -> Value
Array [a -> Value
forall a. ToJSON a => a -> Value
toJSON a
a, b -> Value
forall a. ToJSON a => a -> Value
toJSON b
b, c -> Value
forall a. ToJSON a => a -> Value
toJSON c
c]
----------------------------------------------------------------------------
instance (ToJSON a,ToJSON b,ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where
  toJSON :: (a, b, c, d) -> Value
toJSON (a
a,b
b,c
c,d
d) = [Value] -> Value
Array [a -> Value
forall a. ToJSON a => a -> Value
toJSON a
a, b -> Value
forall a. ToJSON a => a -> Value
toJSON b
b, c -> Value
forall a. ToJSON a => a -> Value
toJSON c
c, d -> Value
forall a. ToJSON a => a -> Value
toJSON d
d]
----------------------------------------------------------------------------
instance ToJSON MisoString where
  toJSON :: MisoString -> Value
toJSON = MisoString -> Value
String
----------------------------------------------------------------------------
#ifndef VANILLA
instance ToJSON T.Text where
  toJSON = toJSON . ms
#endif
----------------------------------------------------------------------------
instance ToJSON LT.Text where
  toJSON :: Text -> Value
toJSON = MisoString -> Value
forall a. ToJSON a => a -> Value
toJSON (MisoString -> Value) -> (Text -> MisoString) -> Text -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> MisoString
forall str. ToMisoString str => str -> MisoString
ms
----------------------------------------------------------------------------
instance ToJSON Float where
  toJSON :: Float -> Value
toJSON = Double -> Value
Number (Double -> Value) -> (Float -> Double) -> Float -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac
----------------------------------------------------------------------------
instance ToJSON Double where
  toJSON :: Double -> Value
toJSON = Double -> Value
Number
----------------------------------------------------------------------------
instance ToJSON Int    where  toJSON :: Int -> Value
toJSON = Double -> Value
Number (Double -> Value) -> (Int -> Double) -> Int -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Int8   where  toJSON :: Int8 -> Value
toJSON = Double -> Value
Number (Double -> Value) -> (Int8 -> Double) -> Int8 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int8 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Int16  where  toJSON :: Int16 -> Value
toJSON = Double -> Value
Number (Double -> Value) -> (Int16 -> Double) -> Int16 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Int32  where  toJSON :: Int32 -> Value
toJSON = Double -> Value
Number (Double -> Value) -> (Int32 -> Double) -> Int32 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac
----------------------------------------------------------------------------
instance ToJSON Word   where  toJSON :: Word -> Value
toJSON = Double -> Value
Number (Double -> Value) -> (Word -> Double) -> Word -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Word8  where  toJSON :: Word8 -> Value
toJSON = Double -> Value
Number (Double -> Value) -> (Word8 -> Double) -> Word8 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Word16 where  toJSON :: Word16 -> Value
toJSON = Double -> Value
Number (Double -> Value) -> (Word16 -> Double) -> Word16 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance ToJSON Word32 where  toJSON :: Word32 -> Value
toJSON = Double -> Value
Number (Double -> Value) -> (Word32 -> Double) -> Word32 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac
----------------------------------------------------------------------------
-- | Possibly lossy due to conversion to 'Double'
instance ToJSON Int64  where  toJSON :: Int64 -> Value
toJSON = Double -> Value
Number (Double -> Value) -> (Int64 -> Double) -> Int64 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac
----------------------------------------------------------------------------
-- | Possibly lossy due to conversion to 'Double'
instance ToJSON Word64 where  toJSON :: Word64 -> Value
toJSON = Double -> Value
Number (Double -> Value) -> (Word64 -> Double) -> Word64 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac
----------------------------------------------------------------------------
-- | Possibly lossy due to conversion to 'Double'
instance ToJSON Integer where toJSON :: Integer -> Value
toJSON = Double -> Value
Number (Double -> Value) -> (Integer -> Double) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Double
forall a. Num a => Integer -> a
fromInteger
----------------------------------------------------------------------------
-- | Possibly lossy due to conversion to 'Double'
instance ToJSON Natural where toJSON :: Natural -> Value
toJSON = Double -> Value
Number (Double -> Value) -> (Natural -> Double) -> Natural -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Double
forall a. Num a => Integer -> a
fromInteger (Integer -> Double) -> (Natural -> Integer) -> Natural -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Integer
naturalToInteger
#endif
----------------------------------------------------------------------------
#ifndef AESON
-- | A lightweight JSON parse monad. Wraps @Either MisoString a@ so that
-- parse failures carry a human-readable error message.
--
-- t'Parser' is a 'Functor', 'Applicative', 'Monad', 'MonadFail', and
-- 'Alternative'. The 'Alternative' instance tries the right branch only when
-- the left branch fails — useful for decoding sum types with multiple valid
-- shapes.
--
-- Combine with 'parseJSON' and the accessor operators (@.:@ etc.) to build
-- composite decoders:
--
-- @
-- data Point = Point Double Double
--
-- instance 'FromJSON' Point where
--   'parseJSON' = 'withArray' \"Point\" $ \\xs ->
--     Point \<$\> 'parseJSON' (xs '!!' 0)
--           \<*\> 'parseJSON' (xs '!!' 1)
-- @
newtype Parser a = Parser
  { forall a. Parser a -> Either MisoString a
unParser :: Either MisoString a
  -- ^ The underlying result: @'Left' errMsg@ on failure, @'Right' a@ on success
  } deriving ((forall a b. (a -> b) -> Parser a -> Parser b)
-> (forall a b. a -> Parser b -> Parser a) -> Functor Parser
forall a b. a -> Parser b -> Parser a
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Parser a -> Parser b
fmap :: forall a b. (a -> b) -> Parser a -> Parser b
$c<$ :: forall a b. a -> Parser b -> Parser a
<$ :: forall a b. a -> Parser b -> Parser a
Functor, Functor Parser
Functor Parser =>
(forall a. a -> Parser a)
-> (forall a b. Parser (a -> b) -> Parser a -> Parser b)
-> (forall a b c.
    (a -> b -> c) -> Parser a -> Parser b -> Parser c)
-> (forall a b. Parser a -> Parser b -> Parser b)
-> (forall a b. Parser a -> Parser b -> Parser a)
-> Applicative Parser
forall a. a -> Parser a
forall a b. Parser a -> Parser b -> Parser a
forall a b. Parser a -> Parser b -> Parser b
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall a b c. (a -> b -> c) -> Parser a -> Parser b -> Parser c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Parser a
pure :: forall a. a -> Parser a
$c<*> :: forall a b. Parser (a -> b) -> Parser a -> Parser b
<*> :: forall a b. Parser (a -> b) -> Parser a -> Parser b
$cliftA2 :: forall a b c. (a -> b -> c) -> Parser a -> Parser b -> Parser c
liftA2 :: forall a b c. (a -> b -> c) -> Parser a -> Parser b -> Parser c
$c*> :: forall a b. Parser a -> Parser b -> Parser b
*> :: forall a b. Parser a -> Parser b -> Parser b
$c<* :: forall a b. Parser a -> Parser b -> Parser a
<* :: forall a b. Parser a -> Parser b -> Parser a
Applicative, Applicative Parser
Applicative Parser =>
(forall a b. Parser a -> (a -> Parser b) -> Parser b)
-> (forall a b. Parser a -> Parser b -> Parser b)
-> (forall a. a -> Parser a)
-> Monad Parser
forall a. a -> Parser a
forall a b. Parser a -> Parser b -> Parser b
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Parser a -> (a -> Parser b) -> Parser b
>>= :: forall a b. Parser a -> (a -> Parser b) -> Parser b
$c>> :: forall a b. Parser a -> Parser b -> Parser b
>> :: forall a b. Parser a -> Parser b -> Parser b
$creturn :: forall a. a -> Parser a
return :: forall a. a -> Parser a
Monad)
----------------------------------------------------------------------------
instance MonadFail Parser where
  fail :: forall a. String -> Parser a
fail = MisoString -> Parser a
forall a. MisoString -> Parser a
pfail (MisoString -> Parser a)
-> (String -> MisoString) -> String -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MisoString
pack
----------------------------------------------------------------------------
instance Alternative Parser where
  empty :: forall a. Parser a
empty = Either MisoString a -> Parser a
forall a. Either MisoString a -> Parser a
Parser (MisoString -> Either MisoString a
forall a b. a -> Either a b
Left MisoString
forall a. Monoid a => a
mempty)
  Parser (Left MisoString
_) <|> :: forall a. Parser a -> Parser a -> Parser a
<|> Parser a
r = Parser a
r
  Parser a
l <|> Parser a
_ = Parser a
l
----------------------------------------------------------------------------
instance MonadPlus Parser
----------------------------------------------------------------------------
-- | Run a parser function, returning 'Nothing' on failure instead of an error string.
parseMaybe
  :: (a -> Parser b)
  -- ^ Parser function to apply
  -> a
  -- ^ Input value to parse
  -> Maybe b
parseMaybe :: forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe a -> Parser b
m a
v =
  case (a -> Parser b) -> a -> Either MisoString b
forall a b. (a -> Parser b) -> a -> Either MisoString b
parseEither a -> Parser b
m a
v of
    Left MisoString
_ -> Maybe b
forall a. Maybe a
Nothing
    Right b
r -> b -> Maybe b
forall a. a -> Maybe a
Just b
r
----------------------------------------------------------------------------
-- | Run a parser function, returning @'Left' errMsg@ on failure.
parseEither
  :: (a -> Parser b)
  -- ^ Parser function to apply
  -> a
  -- ^ Input value to parse
  -> Either MisoString b
parseEither :: forall a b. (a -> Parser b) -> a -> Either MisoString b
parseEither a -> Parser b
m a
v = Parser b -> Either MisoString b
forall a. Parser a -> Either MisoString a
unParser (a -> Parser b
m a
v)
----------------------------------------------------------------------------
pfail :: MisoString -> Parser a
pfail :: forall a. MisoString -> Parser a
pfail MisoString
message = Either MisoString a -> Parser a
forall a. Either MisoString a -> Parser a
Parser (MisoString -> Either MisoString a
forall a b. a -> Either a b
Left MisoString
message)
#else
----------------------------------------------------------------------------
-- | Run a parser function, returning @'Left' errMsg@ on failure.
parseEither
  :: (a -> Parser b)
  -- ^ Parser function to apply
  -> a
  -- ^ Input value to parse
  -> Either MisoString b
parseEither m v = first ms (Aeson.parseEither m v)
#endif
----------------------------------------------------------------------------
#ifndef AESON
-- | A type that can be deserialised from a JSON 'Value'.
--
-- Instances for the most common Haskell types are provided. Derive via
-- 'GHC.Generics' for product\/sum types, or write instances by hand:
--
-- @
-- -- Generic derivation:
-- data Point = Point { x :: Double, y :: Double }
--   deriving (Generic, Show, Eq)
-- instance 'FromJSON' Point
--
-- -- Manual instance:
-- instance 'FromJSON' Point where
--   'parseJSON' = 'withObject' \"Point\" $ \\o ->
--     Point \<$\> o @.:@ \"x\" \<*\> o @.:@ \"y\"
-- @
class FromJSON a where
  -- | Parse a JSON 'Value' into @a@, failing with a descriptive error message
  -- via t'Parser' on a type mismatch.
  parseJSON :: Value -> Parser a
  default parseJSON :: (Generic a, GFromJSON (Rep a)) => Value -> Parser a
  parseJSON = Options -> Value -> Parser a
forall a.
(Generic a, GFromJSON (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
defaultOptions
----------------------------------------------------------------------------
-- | Top-level generic decoding class. Symmetric with 'GToJSON'.
--
-- Decoding rules match aeson's defaults (see t'Options' and 'defaultOptions').
class GFromJSON (f :: Type -> Type) where
  gParseJSON :: Options -> Value -> Parser (f a)
----------------------------------------------------------------------------
-- | Derive 'parseJSON' via 'GHC.Generics' with custom t'Options'.
-- Called by the default 'FromJSON' implementation using 'defaultOptions'.
genericParseJSON
  :: (Generic a, GFromJSON (Rep a))
  => Options
  -- ^ Decoding options (field\/constructor name modifiers, etc.)
  -> Value
  -- ^ JSON 'Value' to decode
  -> Parser a
genericParseJSON :: forall a.
(Generic a, GFromJSON (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
opts Value
value = Rep a (ZonkAny 0) -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Rep a (ZonkAny 0) -> a) -> Parser (Rep a (ZonkAny 0)) -> Parser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Value -> Parser (Rep a (ZonkAny 0))
forall a. Options -> Value -> Parser (Rep a a)
forall (f :: * -> *) a.
GFromJSON f =>
Options -> Value -> Parser (f a)
gParseJSON Options
opts Value
value
----------------------------------------------------------------------------
instance GFromJSONRep f => GFromJSON (D1 m f) where
  gParseJSON :: forall a. Options -> Value -> Parser (D1 m f a)
gParseJSON Options
opts Value
v = f a -> M1 D m f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 D m f a) -> Parser (f a) -> Parser (M1 D m f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Value -> Parser (f a)
forall a. Options -> Value -> Parser (f a)
forall (f :: * -> *) a.
GFromJSONRep f =>
Options -> Value -> Parser (f a)
gFromJSONRep Options
opts Value
v
----------------------------------------------------------------------------
-- Internal: dispatches single-constructor vs sum at the child of D1.
-- | Internal: the decoding counterpart of 'GToJSONRep'. Dispatches on the
-- child of @D1@, choosing the single-constructor or sum decoder.
--
-- @since 1.13.0.0
class GFromJSONRep (f :: Type -> Type) where
  gFromJSONRep :: Options -> Value -> Parser (f a)
-- Single constructor
instance GFromFields f => GFromJSONRep (C1 m f) where
  gFromJSONRep :: forall a. Options -> Value -> Parser (C1 m f a)
gFromJSONRep Options
opts Value
v = f a -> M1 C m f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 C m f a) -> Parser (f a) -> Parser (M1 C m f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Value -> Parser (f a)
forall (f :: * -> *) a.
GFromFields f =>
Options -> Value -> Parser (f a)
parseProd Options
opts Value
v
-- Sum type: branch on allNullaryToStringTag
instance (GFromJSONSum f, GFromJSONSum g, GFromJSONSumNullary f, GFromJSONSumNullary g, GAllNullary f, GAllNullary g)
    => GFromJSONRep (f :+: g) where
  gFromJSONRep :: forall a. Options -> Value -> Parser ((:+:) f g a)
gFromJSONRep Options
opts Value
v
    | Options -> Bool
allNullaryToStringTag Options
opts Bool -> Bool -> Bool
&& forall (f :: * -> *). GAllNullary f => Bool
gAllNullary @f Bool -> Bool -> Bool
&& forall (f :: * -> *). GAllNullary f => Bool
gAllNullary @g
    = Options -> Value -> Parser ((:+:) f g a)
forall a. Options -> Value -> Parser ((:+:) f g a)
forall (f :: * -> *) a.
GFromJSONSumNullary f =>
Options -> Value -> Parser (f a)
gFromJSONSumNullary Options
opts Value
v
    | Bool
otherwise
    = Options -> Value -> Parser ((:+:) f g a)
forall a. Options -> Value -> Parser ((:+:) f g a)
forall (f :: * -> *) a.
GFromJSONSum f =>
Options -> Value -> Parser (f a)
gFromJSONSum Options
opts Value
v
----------------------------------------------------------------------------
-- | Parse all-nullary sum constructors from bare t'String' values.
class GFromJSONSumNullary (f :: Type -> Type) where
  gFromJSONSumNullary :: Options -> Value -> Parser (f a)
----------------------------------------------------------------------------
instance (GFromJSONSumNullary f, GFromJSONSumNullary g) => GFromJSONSumNullary (f :+: g) where
  gFromJSONSumNullary :: forall a. Options -> Value -> Parser ((:+:) f g a)
gFromJSONSumNullary Options
opts Value
v =
    (f a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f a -> (:+:) f g a) -> Parser (f a) -> Parser ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Value -> Parser (f a)
forall a. Options -> Value -> Parser (f a)
forall (f :: * -> *) a.
GFromJSONSumNullary f =>
Options -> Value -> Parser (f a)
gFromJSONSumNullary Options
opts Value
v) Parser ((:+:) f g a)
-> Parser ((:+:) f g a) -> Parser ((:+:) f g a)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (g a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (g a -> (:+:) f g a) -> Parser (g a) -> Parser ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Value -> Parser (g a)
forall a. Options -> Value -> Parser (g a)
forall (f :: * -> *) a.
GFromJSONSumNullary f =>
Options -> Value -> Parser (f a)
gFromJSONSumNullary Options
opts Value
v)
----------------------------------------------------------------------------
instance Constructor m => GFromJSONSumNullary (C1 m U1) where
  gFromJSONSumNullary :: forall a. Options -> Value -> Parser (C1 m U1 a)
gFromJSONSumNullary Options
opts Value
v =
    let tag :: MisoString
tag = String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (Options -> String -> String
constructorTagModifier Options
opts (M1 C m U1 () -> String
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t m f a -> String
conName (M1 C m U1 ()
forall a. HasCallStack => a
undefined :: C1 m U1 ())))
    in case Value
v of
         String MisoString
t | MisoString
t MisoString -> MisoString -> Bool
forall a. Eq a => a -> a -> Bool
== MisoString
tag  -> C1 m U1 a -> Parser (C1 m U1 a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (U1 a -> C1 m U1 a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 U1 a
forall k (p :: k). U1 p
U1)
                  | Bool
otherwise -> MisoString -> Parser (C1 m U1 a)
forall a. MisoString -> Parser a
pfail (MisoString
"expected \"" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
tag MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
"\" got \"" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
t MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
"\"")
         Value
_        -> MisoString -> Parser (C1 m U1 a)
forall a. MisoString -> Parser a
pfail (MisoString
"expected String for nullary constructor " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
tag)
----------------------------------------------------------------------------
-- | Catch-all for non-nullary constructors — unreachable when 'gAllNullary'
-- guards are in place, but required for instance resolution.
instance {-# OVERLAPPABLE #-} Constructor m => GFromJSONSumNullary (C1 m f) where
  gFromJSONSumNullary :: forall a. Options -> Value -> Parser (C1 m f a)
gFromJSONSumNullary Options
_ Value
_ = MisoString -> Parser (C1 m f a)
forall a. MisoString -> Parser a
pfail MisoString
"GFromJSONSumNullary: non-nullary constructor (impossible)"
----------------------------------------------------------------------------
-- | Parse sum constructors, trying each branch left-to-right.
class GFromJSONSum (f :: Type -> Type) where
  gFromJSONSum :: Options -> Value -> Parser (f a)
----------------------------------------------------------------------------
instance (GFromJSONSum f, GFromJSONSum g) => GFromJSONSum (f :+: g) where
  gFromJSONSum :: forall a. Options -> Value -> Parser ((:+:) f g a)
gFromJSONSum Options
opts Value
v = (f a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f a -> (:+:) f g a) -> Parser (f a) -> Parser ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Value -> Parser (f a)
forall a. Options -> Value -> Parser (f a)
forall (f :: * -> *) a.
GFromJSONSum f =>
Options -> Value -> Parser (f a)
gFromJSONSum Options
opts Value
v) Parser ((:+:) f g a)
-> Parser ((:+:) f g a) -> Parser ((:+:) f g a)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (g a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (g a -> (:+:) f g a) -> Parser (g a) -> Parser ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Value -> Parser (g a)
forall a. Options -> Value -> Parser (g a)
forall (f :: * -> *) a.
GFromJSONSum f =>
Options -> Value -> Parser (f a)
gFromJSONSum Options
opts Value
v)
----------------------------------------------------------------------------
instance (Constructor m, GFromFields f) => GFromJSONSum (C1 m f) where
  gFromJSONSum :: forall a. Options -> Value -> Parser (C1 m f a)
gFromJSONSum Options
opts Value
v = f a -> M1 C m f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 C m f a) -> Parser (f a) -> Parser (M1 C m f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MisoString -> Options -> Value -> Parser (f a)
forall (f :: * -> *) a.
GFromFields f =>
MisoString -> Options -> Value -> Parser (f a)
parseTaggedCon MisoString
tag Options
opts Value
v
    where tag :: MisoString
tag = String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (Options -> String -> String
constructorTagModifier Options
opts (M1 C m f () -> String
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t m f a -> String
conName (M1 C m f ()
forall a. HasCallStack => a
undefined :: C1 m f ())))
----------------------------------------------------------------------------
-- | Parse a single-constructor (product) type from a 'Value'.
parseProd :: forall f a. GFromFields f => Options -> Value -> Parser (f a)
parseProd :: forall (f :: * -> *) a.
GFromFields f =>
Options -> Value -> Parser (f a)
parseProd Options
opts Value
v
  | forall (f :: * -> *). GFromFields f => Bool
gIsRecord @f = MisoString
-> (Map MisoString Value -> Parser (f a)) -> Value -> Parser (f a)
forall a.
MisoString
-> (Map MisoString Value -> Parser a) -> Value -> Parser a
withObject MisoString
"generic record" (Options -> Map MisoString Value -> Parser (f a)
forall a. Options -> Map MisoString Value -> Parser (f a)
forall (f :: * -> *) a.
GFromFields f =>
Options -> Map MisoString Value -> Parser (f a)
gFromRecord Options
opts) Value
v
  | Bool
otherwise    = case Value
v of
      Array [Value]
vs
        | forall (f :: * -> *). GFromFields f => Int
gFieldCount @f Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> Options -> [Value] -> Parser (f a)
forall a. Options -> [Value] -> Parser (f a)
forall (f :: * -> *) a.
GFromFields f =>
Options -> [Value] -> Parser (f a)
gFromPositional Options
opts [[Value] -> Value
Array [Value]
vs]
        | Bool
otherwise           -> Options -> [Value] -> Parser (f a)
forall a. Options -> [Value] -> Parser (f a)
forall (f :: * -> *) a.
GFromFields f =>
Options -> [Value] -> Parser (f a)
gFromPositional Options
opts [Value]
vs
      Value
_
        | forall (f :: * -> *). GFromFields f => Int
gFieldCount @f Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> MisoString -> Parser (f a)
forall a. MisoString -> Parser a
pfail MisoString
"expected Array [] for 0-field constructor"
        | forall (f :: * -> *). GFromFields f => Int
gFieldCount @f Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> Options -> [Value] -> Parser (f a)
forall a. Options -> [Value] -> Parser (f a)
forall (f :: * -> *) a.
GFromFields f =>
Options -> [Value] -> Parser (f a)
gFromPositional Options
opts [Value
v]  -- single-field shorthand
        | Bool
otherwise           -> MisoString -> Parser (f a)
forall a. MisoString -> Parser a
pfail MisoString
"expected JSON Array for multi-field constructor"
----------------------------------------------------------------------------
-- | Parse a tagged sum constructor from an Object envelope.
parseTaggedCon :: forall f a. GFromFields f => MisoString -> Options -> Value -> Parser (f a)
parseTaggedCon :: forall (f :: * -> *) a.
GFromFields f =>
MisoString -> Options -> Value -> Parser (f a)
parseTaggedCon MisoString
tag Options
opts = \case
  Object Map MisoString Value
o -> do
    t <- case MisoString -> Map MisoString Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MisoString
"tag" Map MisoString Value
o of
           Just (String MisoString
t) -> MisoString -> Parser MisoString
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MisoString
t
           Just Value
_          -> MisoString -> Parser MisoString
forall a. MisoString -> Parser a
pfail MisoString
"\"tag\" field is not a string"
           Maybe Value
Nothing         -> MisoString -> Parser MisoString
forall a. MisoString -> Parser a
pfail MisoString
"missing \"tag\" field"
    if t /= tag
      then pfail ("expected tag " <> ms (show tag) <> ", got " <> ms (show t))
      else if gIsRecord @f
           then gFromRecord opts o
           else case M.lookup "contents" o of
                  Just (Array [Value]
vs)
                    | forall (f :: * -> *). GFromFields f => Int
gFieldCount @f Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> Options -> [Value] -> Parser (f a)
forall a. Options -> [Value] -> Parser (f a)
forall (f :: * -> *) a.
GFromFields f =>
Options -> [Value] -> Parser (f a)
gFromPositional Options
opts [[Value] -> Value
Array [Value]
vs]
                    | Bool
otherwise           -> Options -> [Value] -> Parser (f a)
forall a. Options -> [Value] -> Parser (f a)
forall (f :: * -> *) a.
GFromFields f =>
Options -> [Value] -> Parser (f a)
gFromPositional Options
opts [Value]
vs
                  Just Value
single     -> Options -> [Value] -> Parser (f a)
forall a. Options -> [Value] -> Parser (f a)
forall (f :: * -> *) a.
GFromFields f =>
Options -> [Value] -> Parser (f a)
gFromPositional Options
opts [Value
single]
                  Maybe Value
Nothing         -> Options -> [Value] -> Parser (f a)
forall a. Options -> [Value] -> Parser (f a)
forall (f :: * -> *) a.
GFromFields f =>
Options -> [Value] -> Parser (f a)
gFromPositional Options
opts []
  Value
_ -> MisoString -> Parser (f a)
forall a. MisoString -> Parser a
pfail (MisoString
"expected JSON object for constructor " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (MisoString -> String
forall a. Show a => a -> String
show MisoString
tag))
----------------------------------------------------------------------------
-- | Field-level decoder. Knows whether the constructor is a record and
-- how many fields it has; can decode from a JSON t'Object' (record mode)
-- or a positional '[Value]' list.
class GFromFields (f :: Type -> Type) where
  -- | Is this a record constructor (all selectors have names)?
  gIsRecord      :: Bool
  -- | Number of fields.
  gFieldCount    :: Int
  -- | Decode from a JSON t'Object' (record mode: look up by field name).
  gFromRecord    :: Options -> Object -> Parser (f a)
  -- | Decode from a positional list of 'Value'.
  gFromPositional :: Options -> [Value] -> Parser (f a)
----------------------------------------------------------------------------
instance GFromFields U1 where
  gIsRecord :: Bool
gIsRecord       = Bool
False
  gFieldCount :: Int
gFieldCount     = Int
0
  gFromRecord :: forall a. Options -> Map MisoString Value -> Parser (U1 a)
gFromRecord   Options
_ Map MisoString Value
_ = U1 a -> Parser (U1 a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 a
forall k (p :: k). U1 p
U1
  gFromPositional :: forall a. Options -> [Value] -> Parser (U1 a)
gFromPositional Options
_ [Value]
_ = U1 a -> Parser (U1 a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 a
forall k (p :: k). U1 p
U1
----------------------------------------------------------------------------
instance GFromFields V1 where
  gIsRecord :: Bool
gIsRecord       = Bool
False
  gFieldCount :: Int
gFieldCount     = Int
0
  gFromRecord :: forall a. Options -> Map MisoString Value -> Parser (V1 a)
gFromRecord   Options
_ Map MisoString Value
_ = MisoString -> Parser (V1 a)
forall a. MisoString -> Parser a
pfail MisoString
"V1"
  gFromPositional :: forall a. Options -> [Value] -> Parser (V1 a)
gFromPositional Options
_ [Value]
_ = MisoString -> Parser (V1 a)
forall a. MisoString -> Parser a
pfail MisoString
"V1"
----------------------------------------------------------------------------
instance (GFromFields f, GFromFields g) => GFromFields (f :*: g) where
  gIsRecord :: Bool
gIsRecord       = forall (f :: * -> *). GFromFields f => Bool
gIsRecord @f
  gFieldCount :: Int
gFieldCount     = forall (f :: * -> *). GFromFields f => Int
gFieldCount @f Int -> Int -> Int
forall a. Num a => a -> a -> a
+ forall (f :: * -> *). GFromFields f => Int
gFieldCount @g
  gFromRecord :: forall a. Options -> Map MisoString Value -> Parser ((:*:) f g a)
gFromRecord Options
opts Map MisoString Value
o =
    f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (f a -> g a -> (:*:) f g a)
-> Parser (f a) -> Parser (g a -> (:*:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Map MisoString Value -> Parser (f a)
forall a. Options -> Map MisoString Value -> Parser (f a)
forall (f :: * -> *) a.
GFromFields f =>
Options -> Map MisoString Value -> Parser (f a)
gFromRecord Options
opts Map MisoString Value
o
          Parser (g a -> (:*:) f g a) -> Parser (g a) -> Parser ((:*:) f g a)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Options -> Map MisoString Value -> Parser (g a)
forall a. Options -> Map MisoString Value -> Parser (g a)
forall (f :: * -> *) a.
GFromFields f =>
Options -> Map MisoString Value -> Parser (f a)
gFromRecord Options
opts Map MisoString Value
o
  gFromPositional :: forall a. Options -> [Value] -> Parser ((:*:) f g a)
gFromPositional Options
opts [Value]
vs =
    let n :: Int
n = forall (f :: * -> *). GFromFields f => Int
gFieldCount @f
    in f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (f a -> g a -> (:*:) f g a)
-> Parser (f a) -> Parser (g a -> (:*:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> [Value] -> Parser (f a)
forall a. Options -> [Value] -> Parser (f a)
forall (f :: * -> *) a.
GFromFields f =>
Options -> [Value] -> Parser (f a)
gFromPositional Options
opts (Int -> [Value] -> [Value]
forall a. Int -> [a] -> [a]
take Int
n [Value]
vs)
             Parser (g a -> (:*:) f g a) -> Parser (g a) -> Parser ((:*:) f g a)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Options -> [Value] -> Parser (g a)
forall a. Options -> [Value] -> Parser (g a)
forall (f :: * -> *) a.
GFromFields f =>
Options -> [Value] -> Parser (f a)
gFromPositional Options
opts (Int -> [Value] -> [Value]
forall a. Int -> [a] -> [a]
drop Int
n [Value]
vs)
----------------------------------------------------------------------------
-- | Selector with a 'Maybe' field: uses '.:?' so missing keys decode as Nothing.
instance {-# OVERLAPPING #-} (Selector m, FromJSON a)
    => GFromFields (S1 m (K1 r (Maybe a))) where
  gIsRecord :: Bool
gIsRecord       = Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
name)
    where name :: String
name = M1 S m (K1 r (Maybe a)) () -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t m f a -> String
selName (K1 r (Maybe a) () -> M1 S m (K1 r (Maybe a)) ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 K1 r (Maybe a) ()
forall a. HasCallStack => a
undefined :: S1 m (K1 r (Maybe a)) ())
  gFieldCount :: Int
gFieldCount     = Int
1
  gFromRecord :: forall a.
Options -> Map MisoString Value -> Parser (S1 m (K1 r (Maybe a)) a)
gFromRecord Options
opts Map MisoString Value
o =
    K1 r (Maybe a) a -> M1 S m (K1 r (Maybe a)) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 r (Maybe a) a -> M1 S m (K1 r (Maybe a)) a)
-> (Maybe a -> K1 r (Maybe a) a)
-> Maybe a
-> M1 S m (K1 r (Maybe a)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> K1 r (Maybe a) a
forall k i c (p :: k). c -> K1 i c p
K1 (Maybe a -> M1 S m (K1 r (Maybe a)) a)
-> Parser (Maybe a) -> Parser (M1 S m (K1 r (Maybe a)) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map MisoString Value
o Map MisoString Value -> MisoString -> Parser (Maybe a)
forall a.
FromJSON a =>
Map MisoString Value -> MisoString -> Parser (Maybe a)
.:? String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (Options -> String -> String
fieldLabelModifier Options
opts
                    (M1 S m (K1 r (Maybe a)) () -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t m f a -> String
selName (K1 r (Maybe a) () -> M1 S m (K1 r (Maybe a)) ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 K1 r (Maybe a) ()
forall a. HasCallStack => a
undefined :: S1 m (K1 r (Maybe a)) ())))
  gFromPositional :: forall a. Options -> [Value] -> Parser (S1 m (K1 r (Maybe a)) a)
gFromPositional Options
_ [Value]
vs = case [Value]
vs of
    (Value
v:[Value]
_) -> K1 r (Maybe a) a -> S1 m (K1 r (Maybe a)) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 r (Maybe a) a -> S1 m (K1 r (Maybe a)) a)
-> (Maybe a -> K1 r (Maybe a) a)
-> Maybe a
-> S1 m (K1 r (Maybe a)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> K1 r (Maybe a) a
forall k i c (p :: k). c -> K1 i c p
K1 (Maybe a -> S1 m (K1 r (Maybe a)) a)
-> Parser (Maybe a) -> Parser (S1 m (K1 r (Maybe a)) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (Maybe a)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
    []    -> S1 m (K1 r (Maybe a)) a -> Parser (S1 m (K1 r (Maybe a)) a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (K1 r (Maybe a) a -> S1 m (K1 r (Maybe a)) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Maybe a -> K1 r (Maybe a) a
forall k i c (p :: k). c -> K1 i c p
K1 Maybe a
forall a. Maybe a
Nothing))
----------------------------------------------------------------------------
-- | General selector.
instance {-# OVERLAPPABLE #-} (Selector m, FromJSON a)
    => GFromFields (S1 m (K1 r a)) where
  gIsRecord :: Bool
gIsRecord       = Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
name)
    where name :: String
name = M1 S m (K1 r a) () -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t m f a -> String
selName (K1 r a () -> M1 S m (K1 r a) ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 K1 r a ()
forall a. HasCallStack => a
undefined :: S1 m (K1 r a) ())
  gFieldCount :: Int
gFieldCount     = Int
1
  gFromRecord :: forall a.
Options -> Map MisoString Value -> Parser (S1 m (K1 r a) a)
gFromRecord Options
opts Map MisoString Value
o =
    K1 r a a -> M1 S m (K1 r a) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 r a a -> M1 S m (K1 r a) a)
-> (a -> K1 r a a) -> a -> M1 S m (K1 r a) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> K1 r a a
forall k i c (p :: k). c -> K1 i c p
K1 (a -> M1 S m (K1 r a) a) -> Parser a -> Parser (M1 S m (K1 r a) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map MisoString Value
o Map MisoString Value -> MisoString -> Parser a
forall a.
FromJSON a =>
Map MisoString Value -> MisoString -> Parser a
.: String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (Options -> String -> String
fieldLabelModifier Options
opts
                    (M1 S m (K1 r a) () -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t m f a -> String
selName (K1 r a () -> M1 S m (K1 r a) ()
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 K1 r a ()
forall a. HasCallStack => a
undefined :: S1 m (K1 r a) ())))
  gFromPositional :: forall a. Options -> [Value] -> Parser (S1 m (K1 r a) a)
gFromPositional Options
_ [Value]
vs = case [Value]
vs of
    (Value
v:[Value]
_) -> K1 r a a -> S1 m (K1 r a) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 r a a -> S1 m (K1 r a) a)
-> (a -> K1 r a a) -> a -> S1 m (K1 r a) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> K1 r a a
forall k i c (p :: k). c -> K1 i c p
K1 (a -> S1 m (K1 r a) a) -> Parser a -> Parser (S1 m (K1 r a) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
    []    -> MisoString -> Parser (S1 m (K1 r a) a)
forall a. MisoString -> Parser a
pfail MisoString
"gFromPositional: unexpected end of fields"
----------------------------------------------------------------------------
instance FromJSON Value where
  parseJSON :: Value -> Parser Value
parseJSON = Value -> Parser Value
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
----------------------------------------------------------------------------
instance FromJSON Bool where
  parseJSON :: Value -> Parser Bool
parseJSON = MisoString -> (Bool -> Parser Bool) -> Value -> Parser Bool
forall a. MisoString -> (Bool -> Parser a) -> Value -> Parser a
withBool MisoString
"Bool" Bool -> Parser Bool
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
----------------------------------------------------------------------------
instance FromJSON MisoString where
  parseJSON :: Value -> Parser MisoString
parseJSON = MisoString
-> (MisoString -> Parser MisoString) -> Value -> Parser MisoString
forall a.
MisoString -> (MisoString -> Parser a) -> Value -> Parser a
withText MisoString
"MisoString" MisoString -> Parser MisoString
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
----------------------------------------------------------------------------
#ifndef VANILLA
instance FromJSON T.Text where
  parseJSON = withText "Text" go
    where
      go s =
        case MS.fromMisoStringEither s of
          Right lt -> pure lt
          Left e -> pfail $ ms e
#endif
----------------------------------------------------------------------------
instance FromJSON LT.Text where
  parseJSON :: Value -> Parser Text
parseJSON = MisoString -> (MisoString -> Parser Text) -> Value -> Parser Text
forall a.
MisoString -> (MisoString -> Parser a) -> Value -> Parser a
withText MisoString
"LText" MisoString -> Parser Text
forall {a}. FromMisoString a => MisoString -> Parser a
go
    where
      go :: MisoString -> Parser a
go MisoString
s =
        case MisoString -> Either String a
forall t. FromMisoString t => MisoString -> Either String t
MS.fromMisoStringEither MisoString
s of
          Right a
lt -> a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
lt
          Left String
e -> MisoString -> Parser a
forall a. MisoString -> Parser a
pfail (MisoString -> Parser a) -> MisoString -> Parser a
forall a b. (a -> b) -> a -> b
$ String -> MisoString
forall str. ToMisoString str => str -> MisoString
ms String
e
----------------------------------------------------------------------------
instance {-# OVERLAPPING #-} FromJSON String where
  parseJSON :: Value -> Parser String
parseJSON = MisoString
-> (MisoString -> Parser String) -> Value -> Parser String
forall a.
MisoString -> (MisoString -> Parser a) -> Value -> Parser a
withText MisoString
"String" (String -> Parser String
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Parser String)
-> (MisoString -> String) -> MisoString -> Parser String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MisoString -> String
MS.unpack)
----------------------------------------------------------------------------
instance FromJSON a => FromJSON [a] where
  parseJSON :: Value -> Parser [a]
parseJSON = MisoString -> ([Value] -> Parser [a]) -> Value -> Parser [a]
forall a. MisoString -> ([Value] -> Parser a) -> Value -> Parser a
withArray MisoString
"[a]" ((Value -> Parser a) -> [Value] -> Parser [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON)
----------------------------------------------------------------------------
instance FromJSON Double where
  parseJSON :: Value -> Parser Double
parseJSON Value
Null = Double -> Parser Double
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double
0Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
0)
  parseJSON Value
j    = MisoString -> (Double -> Parser Double) -> Value -> Parser Double
forall a. MisoString -> (Double -> Parser a) -> Value -> Parser a
withNumber MisoString
"Double" Double -> Parser Double
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
j
----------------------------------------------------------------------------
instance FromJSON Float where
  parseJSON :: Value -> Parser Float
parseJSON Value
Null = Float -> Parser Float
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float
0Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
0)
  parseJSON Value
j    = MisoString -> (Double -> Parser Float) -> Value -> Parser Float
forall a. MisoString -> (Double -> Parser a) -> Value -> Parser a
withNumber MisoString
"Float" (Float -> Parser Float
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Parser Float)
-> (Double -> Float) -> Double -> Parser Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac) Value
j
----------------------------------------------------------------------------
instance FromJSON Integer where
  parseJSON :: Value -> Parser Integer
parseJSON = MisoString -> (Double -> Parser Integer) -> Value -> Parser Integer
forall a. MisoString -> (Double -> Parser a) -> Value -> Parser a
withNumber MisoString
"Integer" (Integer -> Parser Integer
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Parser Integer)
-> (Double -> Integer) -> Double -> Parser Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round)
----------------------------------------------------------------------------
instance FromJSON Natural where
  parseJSON :: Value -> Parser Natural
parseJSON = MisoString -> (Double -> Parser Natural) -> Value -> Parser Natural
forall a. MisoString -> (Double -> Parser a) -> Value -> Parser a
withNumber MisoString
"Natural" Double -> Parser Natural
forall {a}. (ToMisoString a, RealFloat a) => a -> Parser Natural
parseNumber
    where parseNumber :: a -> Parser Natural
parseNumber a
d | a
d a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 = MisoString -> Parser Natural
forall a. MisoString -> Parser a
pfail (MisoString
"Cannot parse negative number as Natural: " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> a -> MisoString
forall str. ToMisoString str => str -> MisoString
ms a
d)
                        | a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
d = MisoString -> Parser Natural
forall a. MisoString -> Parser a
pfail (MisoString
"Cannot parse NaN as Natural: " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> a -> MisoString
forall str. ToMisoString str => str -> MisoString
ms a
d)
                        | Bool
otherwise  = Natural -> Parser Natural
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Natural -> Parser Natural) -> Natural -> Parser Natural
forall a b. (a -> b) -> a -> b
$ Integer -> Natural
naturalFromInteger (Integer -> Natural) -> Integer -> Natural
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a. Num a => Integer -> a
fromInteger (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ a -> Integer
forall b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
round a
d
----------------------------------------------------------------------------
instance FromJSON Int where
  parseJSON :: Value -> Parser Int
parseJSON = MisoString -> (Double -> Parser Int) -> Value -> Parser Int
forall a. MisoString -> (Double -> Parser a) -> Value -> Parser a
withNumber MisoString
"Int" (Int -> Parser Int
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Parser Int) -> (Double -> Int) -> Double -> Parser Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> (Double -> Integer) -> Double -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round)
----------------------------------------------------------------------------
instance FromJSON Int8 where
  parseJSON :: Value -> Parser Int8
parseJSON = MisoString -> (Double -> Parser Int8) -> Value -> Parser Int8
forall a. MisoString -> (Double -> Parser a) -> Value -> Parser a
withNumber MisoString
"Int8" (Int8 -> Parser Int8
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int8 -> Parser Int8) -> (Double -> Int8) -> Double -> Parser Int8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int8
forall a. Num a => Integer -> a
fromInteger (Integer -> Int8) -> (Double -> Integer) -> Double -> Int8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round)
----------------------------------------------------------------------------
instance FromJSON Int16 where
  parseJSON :: Value -> Parser Int16
parseJSON = MisoString -> (Double -> Parser Int16) -> Value -> Parser Int16
forall a. MisoString -> (Double -> Parser a) -> Value -> Parser a
withNumber MisoString
"Int16" (Int16 -> Parser Int16
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int16 -> Parser Int16)
-> (Double -> Int16) -> Double -> Parser Int16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int16
forall a. Num a => Integer -> a
fromInteger (Integer -> Int16) -> (Double -> Integer) -> Double -> Int16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round)
----------------------------------------------------------------------------
instance FromJSON Int32 where
  parseJSON :: Value -> Parser Int32
parseJSON = MisoString -> (Double -> Parser Int32) -> Value -> Parser Int32
forall a. MisoString -> (Double -> Parser a) -> Value -> Parser a
withNumber MisoString
"Int32" (Int32 -> Parser Int32
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int32 -> Parser Int32)
-> (Double -> Int32) -> Double -> Parser Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int32
forall a. Num a => Integer -> a
fromInteger (Integer -> Int32) -> (Double -> Integer) -> Double -> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round)
----------------------------------------------------------------------------
instance FromJSON Int64 where
  parseJSON :: Value -> Parser Int64
parseJSON = MisoString -> (Double -> Parser Int64) -> Value -> Parser Int64
forall a. MisoString -> (Double -> Parser a) -> Value -> Parser a
withNumber MisoString
"Int64" (Int64 -> Parser Int64
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int64 -> Parser Int64)
-> (Double -> Int64) -> Double -> Parser Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int64
forall a. Num a => Integer -> a
fromInteger (Integer -> Int64) -> (Double -> Integer) -> Double -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round)
----------------------------------------------------------------------------
instance FromJSON Word where
  parseJSON :: Value -> Parser Word
parseJSON = MisoString -> (Double -> Parser Word) -> Value -> Parser Word
forall a. MisoString -> (Double -> Parser a) -> Value -> Parser a
withNumber MisoString
"Word" (Word -> Parser Word
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word -> Parser Word) -> (Double -> Word) -> Double -> Parser Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Word
forall a. Num a => Integer -> a
fromInteger (Integer -> Word) -> (Double -> Integer) -> Double -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round)
----------------------------------------------------------------------------
instance FromJSON Word8 where
  parseJSON :: Value -> Parser Word8
parseJSON = MisoString -> (Double -> Parser Word8) -> Value -> Parser Word8
forall a. MisoString -> (Double -> Parser a) -> Value -> Parser a
withNumber MisoString
"Word8" (Word8 -> Parser Word8
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word8 -> Parser Word8)
-> (Double -> Word8) -> Double -> Parser Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Word8
forall a. Num a => Integer -> a
fromInteger (Integer -> Word8) -> (Double -> Integer) -> Double -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round)
----------------------------------------------------------------------------
instance FromJSON Word16 where
  parseJSON :: Value -> Parser Word16
parseJSON = MisoString -> (Double -> Parser Word16) -> Value -> Parser Word16
forall a. MisoString -> (Double -> Parser a) -> Value -> Parser a
withNumber MisoString
"Word16" (Word16 -> Parser Word16
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word16 -> Parser Word16)
-> (Double -> Word16) -> Double -> Parser Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Word16
forall a. Num a => Integer -> a
fromInteger (Integer -> Word16) -> (Double -> Integer) -> Double -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round)
----------------------------------------------------------------------------
instance FromJSON Word32 where
  parseJSON :: Value -> Parser Word32
parseJSON = MisoString -> (Double -> Parser Word32) -> Value -> Parser Word32
forall a. MisoString -> (Double -> Parser a) -> Value -> Parser a
withNumber MisoString
"Word32" (Word32 -> Parser Word32
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word32 -> Parser Word32)
-> (Double -> Word32) -> Double -> Parser Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Word32
forall a. Num a => Integer -> a
fromInteger (Integer -> Word32) -> (Double -> Integer) -> Double -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round)
----------------------------------------------------------------------------
instance FromJSON Word64 where
  parseJSON :: Value -> Parser Word64
parseJSON = MisoString -> (Double -> Parser Word64) -> Value -> Parser Word64
forall a. MisoString -> (Double -> Parser a) -> Value -> Parser a
withNumber MisoString
"Word64" (Word64 -> Parser Word64
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> Parser Word64)
-> (Double -> Word64) -> Double -> Parser Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Word64
forall a. Num a => Integer -> a
fromInteger (Integer -> Word64) -> (Double -> Integer) -> Double -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round)
----------------------------------------------------------------------------
instance FromJSON () where
  parseJSON :: Value -> Parser ()
parseJSON = MisoString -> ([Value] -> Parser ()) -> Value -> Parser ()
forall a. MisoString -> ([Value] -> Parser a) -> Value -> Parser a
withArray MisoString
"()" (([Value] -> Parser ()) -> Value -> Parser ())
-> ([Value] -> Parser ()) -> Value -> Parser ()
forall a b. (a -> b) -> a -> b
$ \[Value]
lst ->
    case [Value]
lst of
      [] -> () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      [Value]
_  -> MisoString -> Parser ()
forall a. MisoString -> Parser a
pfail MisoString
"expected ()"
----------------------------------------------------------------------------
instance (FromJSON a, FromJSON b) => FromJSON (a,b) where
  parseJSON :: Value -> Parser (a, b)
parseJSON = MisoString -> ([Value] -> Parser (a, b)) -> Value -> Parser (a, b)
forall a. MisoString -> ([Value] -> Parser a) -> Value -> Parser a
withArray MisoString
"(a,b)" (([Value] -> Parser (a, b)) -> Value -> Parser (a, b))
-> ([Value] -> Parser (a, b)) -> Value -> Parser (a, b)
forall a b. (a -> b) -> a -> b
$ \[Value]
lst ->
    case [Value]
lst of
      [Value
a,Value
b] -> (a -> b -> (a, b)) -> Parser a -> Parser b -> Parser (a, b)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
a) (Value -> Parser b
forall a. FromJSON a => Value -> Parser a
parseJSON Value
b)
      [Value]
_     -> MisoString -> Parser (a, b)
forall a. MisoString -> Parser a
pfail MisoString
"expected (a,b)"
----------------------------------------------------------------------------
instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a,b,c) where
  parseJSON :: Value -> Parser (a, b, c)
parseJSON = MisoString
-> ([Value] -> Parser (a, b, c)) -> Value -> Parser (a, b, c)
forall a. MisoString -> ([Value] -> Parser a) -> Value -> Parser a
withArray MisoString
"(a,b,c)" (([Value] -> Parser (a, b, c)) -> Value -> Parser (a, b, c))
-> ([Value] -> Parser (a, b, c)) -> Value -> Parser (a, b, c)
forall a b. (a -> b) -> a -> b
$ \[Value]
lst ->
    case [Value]
lst of
      [Value
a,Value
b,Value
c] -> (a -> b -> c -> (a, b, c))
-> Parser a -> Parser b -> Parser c -> Parser (a, b, c)
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (,,) (Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
a) (Value -> Parser b
forall a. FromJSON a => Value -> Parser a
parseJSON Value
b) (Value -> Parser c
forall a. FromJSON a => Value -> Parser a
parseJSON Value
c)
      [Value]
_       -> MisoString -> Parser (a, b, c)
forall a. MisoString -> Parser a
pfail MisoString
"expected (a,b,c)"
----------------------------------------------------------------------------
instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON (a,b,c,d) where
  parseJSON :: Value -> Parser (a, b, c, d)
parseJSON = MisoString
-> ([Value] -> Parser (a, b, c, d)) -> Value -> Parser (a, b, c, d)
forall a. MisoString -> ([Value] -> Parser a) -> Value -> Parser a
withArray MisoString
"(a,b,c,d)" (([Value] -> Parser (a, b, c, d)) -> Value -> Parser (a, b, c, d))
-> ([Value] -> Parser (a, b, c, d)) -> Value -> Parser (a, b, c, d)
forall a b. (a -> b) -> a -> b
$ \[Value]
lst ->
    case [Value]
lst of
      [Value
a,Value
b,Value
c,Value
d] -> (a -> b -> c -> d -> (a, b, c, d))
-> Parser a
-> Parser b
-> Parser c
-> Parser d
-> Parser (a, b, c, d)
forall (m :: * -> *) a1 a2 a3 a4 r.
Monad m =>
(a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r
liftM4 (,,,) (Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
a) (Value -> Parser b
forall a. FromJSON a => Value -> Parser a
parseJSON Value
b) (Value -> Parser c
forall a. FromJSON a => Value -> Parser a
parseJSON Value
c) (Value -> Parser d
forall a. FromJSON a => Value -> Parser a
parseJSON Value
d)
      [Value]
_         -> MisoString -> Parser (a, b, c, d)
forall a. MisoString -> Parser a
pfail MisoString
"expected (a,b,c,d)"
----------------------------------------------------------------------------
instance FromJSON a => FromJSON (Maybe a) where
  parseJSON :: Value -> Parser (Maybe a)
parseJSON Value
Null = Maybe a -> Parser (Maybe a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
  parseJSON Value
j    = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Parser a -> Parser (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
j
----------------------------------------------------------------------------
instance FromJSON Ordering where
  parseJSON :: Value -> Parser Ordering
parseJSON = MisoString
-> (MisoString -> Parser Ordering) -> Value -> Parser Ordering
forall a.
MisoString -> (MisoString -> Parser a) -> Value -> Parser a
withText MisoString
"{'LT','EQ','GT'}" ((MisoString -> Parser Ordering) -> Value -> Parser Ordering)
-> (MisoString -> Parser Ordering) -> Value -> Parser Ordering
forall a b. (a -> b) -> a -> b
$ \MisoString
s ->
    case MisoString
s of
      MisoString
"LT" -> Ordering -> Parser Ordering
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ordering
LT
      MisoString
"EQ" -> Ordering -> Parser Ordering
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ordering
EQ
      MisoString
"GT" -> Ordering -> Parser Ordering
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ordering
GT
      MisoString
_    -> MisoString -> Parser Ordering
forall a. MisoString -> Parser a
pfail MisoString
"expected {'LT','EQ','GT'}"
----------------------------------------------------------------------------
instance FromJSON Char where
  parseJSON :: Value -> Parser Char
parseJSON = MisoString -> (MisoString -> Parser Char) -> Value -> Parser Char
forall a.
MisoString -> (MisoString -> Parser a) -> Value -> Parser a
withText MisoString
"Char" ((MisoString -> Parser Char) -> Value -> Parser Char)
-> (MisoString -> Parser Char) -> Value -> Parser Char
forall a b. (a -> b) -> a -> b
$ \MisoString
xs ->
    case MisoString
xs of
     MisoString
x | MisoString -> Int
MS.length MisoString
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> Char -> Parser Char
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HasCallStack => MisoString -> Char
MisoString -> Char
MS.head MisoString
x)
       | Bool
otherwise -> MisoString -> Parser Char
forall a. MisoString -> Parser a
pfail (MisoString
"expected Char, received: " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
x)
----------------------------------------------------------------------------
instance FromJSON v => FromJSON (Map MisoString v) where
  parseJSON :: Value -> Parser (Map MisoString v)
parseJSON = MisoString
-> (Map MisoString Value -> Parser (Map MisoString v))
-> Value
-> Parser (Map MisoString v)
forall a.
MisoString
-> (Map MisoString Value -> Parser a) -> Value -> Parser a
withObject MisoString
"FromJSON v => Map MisoString v" ((Map MisoString Value -> Parser (Map MisoString v))
 -> Value -> Parser (Map MisoString v))
-> (Map MisoString Value -> Parser (Map MisoString v))
-> Value
-> Parser (Map MisoString v)
forall a b. (a -> b) -> a -> b
$ (Value -> Parser v)
-> Map MisoString Value -> Parser (Map MisoString v)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Map MisoString a -> m (Map MisoString b)
mapM Value -> Parser v
forall a. FromJSON a => Value -> Parser a
parseJSON
#endif
----------------------------------------------------------------------------
#ifdef AESON
-- | Succeed only when the 'Value' is a t'Bool'; fail with 'typeMismatch' otherwise.
withBool
  :: MisoString
  -- ^ Expected type name used in the error message (e.g. @\"MyType\"@)
  -> (Bool -> Parser a)
  -- ^ Continuation receiving the unwrapped t'Bool'
  -> Value
  -- ^ JSON value to inspect
  -> Parser a
withBool expected = Aeson.withBool (MS.unpack expected)
----------------------------------------------------------------------------
-- | Succeed only when the 'Value' is a JSON string ('MisoString');
-- fail with 'typeMismatch' otherwise.
withText
  :: MisoString
  -- ^ Expected type name used in the error message
  -> (MisoString -> Parser a)
  -- ^ Continuation receiving the unwrapped string
  -> Value
  -- ^ JSON value to inspect
  -> Parser a
withText expected f = Aeson.withText (MS.unpack expected) (f . ms)
----------------------------------------------------------------------------
-- | Succeed only when the 'Value' is a JSON array; fail with 'typeMismatch' otherwise.
-- The inner parser receives the list of elements.
withArray
  :: MisoString
  -- ^ Expected type name used in the error message
  -> ([Value] -> Parser a)
  -- ^ Continuation receiving the list of array elements
  -> Value
  -- ^ JSON value to inspect
  -> Parser a
withArray expected f = Aeson.withArray (MS.unpack expected) (f . foldr (:) [])
----------------------------------------------------------------------------
-- | Succeed only when the 'Value' is a JSON object; fail with 'typeMismatch' otherwise.
-- The inner parser receives the t'Object' map for key lookups with @.:@ etc.
withObject
  :: MisoString
  -- ^ Expected type name used in the error message
  -> (Object -> Parser a)
  -- ^ Continuation receiving the t'Object' key\/value map
  -> Value
  -- ^ JSON value to inspect
  -> Parser a
withObject expected = Aeson.withObject (MS.unpack expected)
----------------------------------------------------------------------------
-- | Succeed only when the 'Value' is a JSON number; fail with 'typeMismatch' otherwise.
-- The inner parser receives the underlying 'Double'.
withNumber
  :: MisoString
  -- ^ Expected type name used in the error message
  -> (Double -> Parser a)
  -- ^ Continuation receiving the numeric value as a 'Double'
  -> Value
  -- ^ JSON value to inspect
  -> Parser a
withNumber expected f = Aeson.withScientific (MS.unpack expected) (f . toRealFloat)
----------------------------------------------------------------------------
-- | Produce a parse failure describing a type mismatch.
-- Used by the @with*@ combinators and useful in hand-written 'FromJSON' instances.
typeMismatch
  :: MisoString
  -- ^ Human-readable name of the expected type (e.g. @\"Int\"@)
  -> Value
  -- ^ The actual 'Value' that was encountered
  -> Parser a
typeMismatch expected = Aeson.typeMismatch (MS.unpack expected)
#else
-- | Succeed only when the 'Value' is a t'Bool'; fail with 'typeMismatch' otherwise.
withBool
  :: MisoString
  -- ^ Expected type name used in the error message (e.g. @\"MyType\"@)
  -> (Bool -> Parser a)
  -- ^ Continuation receiving the unwrapped t'Bool'
  -> Value
  -- ^ JSON value to inspect
  -> Parser a
withBool :: forall a. MisoString -> (Bool -> Parser a) -> Value -> Parser a
withBool MisoString
_        Bool -> Parser a
f (Bool Bool
arr) = Bool -> Parser a
f Bool
arr
withBool MisoString
expected Bool -> Parser a
_ Value
v          = MisoString -> Value -> Parser a
forall a. MisoString -> Value -> Parser a
typeMismatch MisoString
expected Value
v
----------------------------------------------------------------------------
-- | Succeed only when the 'Value' is a JSON string ('MisoString');
-- fail with 'typeMismatch' otherwise.
withText
  :: MisoString
  -- ^ Expected type name used in the error message
  -> (MisoString -> Parser a)
  -- ^ Continuation receiving the unwrapped string
  -> Value
  -- ^ JSON value to inspect
  -> Parser a
withText :: forall a.
MisoString -> (MisoString -> Parser a) -> Value -> Parser a
withText MisoString
_        MisoString -> Parser a
f (String MisoString
txt) = MisoString -> Parser a
f MisoString
txt
withText MisoString
expected MisoString -> Parser a
_ Value
v            = MisoString -> Value -> Parser a
forall a. MisoString -> Value -> Parser a
typeMismatch MisoString
expected Value
v
----------------------------------------------------------------------------
-- | Succeed only when the 'Value' is a JSON array; fail with 'typeMismatch' otherwise.
-- The inner parser receives the list of elements.
withArray
  :: MisoString
  -- ^ Expected type name used in the error message
  -> ([Value] -> Parser a)
  -- ^ Continuation receiving the list of array elements
  -> Value
  -- ^ JSON value to inspect
  -> Parser a
withArray :: forall a. MisoString -> ([Value] -> Parser a) -> Value -> Parser a
withArray MisoString
_        [Value] -> Parser a
f (Array [Value]
lst) = [Value] -> Parser a
f [Value]
lst
withArray MisoString
expected [Value] -> Parser a
_ Value
v           = MisoString -> Value -> Parser a
forall a. MisoString -> Value -> Parser a
typeMismatch MisoString
expected Value
v
----------------------------------------------------------------------------
-- | Succeed only when the 'Value' is a JSON object; fail with 'typeMismatch' otherwise.
-- The inner parser receives the t'Object' map for key lookups with @.:@ etc.
withObject
  :: MisoString
  -- ^ Expected type name used in the error message
  -> (Object -> Parser a)
  -- ^ Continuation receiving the t'Object' key\/value map
  -> Value
  -- ^ JSON value to inspect
  -> Parser a
withObject :: forall a.
MisoString
-> (Map MisoString Value -> Parser a) -> Value -> Parser a
withObject MisoString
_        Map MisoString Value -> Parser a
f (Object Map MisoString Value
obj) = Map MisoString Value -> Parser a
f Map MisoString Value
obj
withObject MisoString
expected Map MisoString Value -> Parser a
_ Value
v            = MisoString -> Value -> Parser a
forall a. MisoString -> Value -> Parser a
typeMismatch MisoString
expected Value
v
----------------------------------------------------------------------------
-- | Succeed only when the 'Value' is a JSON number; fail with 'typeMismatch' otherwise.
-- The inner parser receives the underlying 'Double'.
withNumber
  :: MisoString
  -- ^ Expected type name used in the error message
  -> (Double -> Parser a)
  -- ^ Continuation receiving the numeric value as a 'Double'
  -> Value
  -- ^ JSON value to inspect
  -> Parser a
withNumber :: forall a. MisoString -> (Double -> Parser a) -> Value -> Parser a
withNumber MisoString
_        Double -> Parser a
f (Number Double
n) = Double -> Parser a
f Double
n
withNumber MisoString
expected Double -> Parser a
_ Value
v          = MisoString -> Value -> Parser a
forall a. MisoString -> Value -> Parser a
typeMismatch MisoString
expected Value
v
----------------------------------------------------------------------------
-- | Produce a parse failure describing a type mismatch.
-- Used by the @with*@ combinators and useful in hand-written 'FromJSON' instances.
typeMismatch
  :: MisoString
  -- ^ Human-readable name of the expected type (e.g. @\"Int\"@)
  -> Value
  -- ^ The actual 'Value' that was encountered
  -> Parser a
typeMismatch :: forall a. MisoString -> Value -> Parser a
typeMismatch MisoString
expected Value
actual =
  MisoString -> Parser a
forall a. MisoString -> Parser a
pfail
    ( MisoString
"typeMismatch: Expected " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
expected MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
" but encountered " MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> case Value
actual of
        Object Map MisoString Value
_ -> MisoString
"Object"
        Array [Value]
_ -> MisoString
"Array"
        String MisoString
_ -> MisoString
"String"
        Number Double
_ -> MisoString
"Number"
        Bool Bool
_ -> MisoString
"Boolean"
        Value
Null -> MisoString
"Null"
    )
#endif
----------------------------------------------------------------------------
-- | Encode a value as a JSON 'MisoString'.
--
-- On the client (WASM \/ GHC JS backend) calls @JSON.stringify()@ via FFI for
-- maximum performance. On the server (@VANILLA@) falls back to 'encodePure'.
#ifdef VANILLA
encode :: ToJSON a => a -> MisoString
encode :: forall a. ToJSON a => a -> MisoString
encode = a -> MisoString
forall a. ToJSON a => a -> MisoString
encodePure
#else
encode :: ToJSON a => a -> MisoString
encode x = unsafePerformIO $ jsonStringify =<< toJSVal_Value (toJSON x)
#endif
----------------------------------------------------------------------------
-- | Relies on the pure implementation of JSON parsing / serialization.
--
-- This can be used on the server or the client, it is more efficient to
-- use 'encode' on the client (since it relies on @JSON.stringify()@).
--
encodePure :: ToJSON a => a -> MisoString
encodePure :: forall a. ToJSON a => a -> MisoString
encodePure = Value -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (Value -> MisoString) -> (a -> Value) -> a -> MisoString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
toJSON
----------------------------------------------------------------------------
instance FromMisoString Value where
  fromMisoStringEither :: MisoString -> Either String Value
fromMisoStringEither = MisoString -> Either String Value
Parser.decodePure
----------------------------------------------------------------------------
#ifdef AESON
instance ToMisoString Value where
  toMisoString = ms . Aeson.encode
#else
-- | Escape special characters in a string for JSON serialization
-- Handles: \, ", and all JSON control characters per RFC 8259
escapeJSONString :: MisoString -> MisoString
escapeJSONString :: MisoString -> MisoString
escapeJSONString = (Char -> MisoString) -> MisoString -> MisoString
MS.concatMap Char -> MisoString
escapeChar
  where
    escapeChar :: Char -> MisoString
    escapeChar :: Char -> MisoString
escapeChar Char
'\\' = MisoString
"\\\\"   -- Backslash
    escapeChar Char
'"'  = MisoString
"\\\""   -- Double quote
    escapeChar Char
'\b' = MisoString
"\\b"    -- Backspace
    escapeChar Char
'\f' = MisoString
"\\f"    -- Form feed
    escapeChar Char
'\n' = MisoString
"\\n"    -- Newline
    escapeChar Char
'\r' = MisoString
"\\r"    -- Carriage return
    escapeChar Char
'\t' = MisoString
"\\t"    -- Tab
    escapeChar Char
c
      | Char -> Bool
isControl Char
c = MisoString -> MisoString
forall str. ToMisoString str => str -> MisoString
ms (MisoString
"\\u" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> Int -> MisoString
padHex (Char -> Int
ord Char
c))  -- Other control chars as \uXXXX
      | Bool
otherwise   = Char -> MisoString
singleton Char
c

    padHex :: Int -> MisoString
    padHex :: Int -> MisoString
padHex Int
n = String -> MisoString
MS.pack (String -> MisoString) -> String -> MisoString
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
h) Char
'0' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
h
      where h :: String
h = Int -> String -> String
forall a. Integral a => a -> String -> String
showHex Int
n String
""
----------------------------------------------------------------------------
instance ToMisoString Value where
  toMisoString :: Value -> MisoString
toMisoString = \case
    String MisoString
s -> MisoString
"\"" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString -> MisoString
escapeJSONString MisoString
s MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
"\""
    Number Double
n
      | (Int
i, Double
0.0) <- Double -> (Int, Double)
forall b. Integral b => Double -> (b, Double)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction Double
n -> forall str. ToMisoString str => str -> MisoString
ms @Int Int
i
      | Bool
otherwise -> Double -> MisoString
forall str. ToMisoString str => str -> MisoString
ms Double
n
    Value
Null ->
      MisoString
"null"
    Array [Value]
xs ->
      MisoString
"[" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString -> [MisoString] -> MisoString
MS.intercalate MisoString
"," ((Value -> MisoString) -> [Value] -> [MisoString]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> MisoString
forall str. ToMisoString str => str -> MisoString
ms [Value]
xs) MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
"]"
    Bool Bool
True ->
      MisoString
"true"
    Bool Bool
False ->
      MisoString
"false"
    Object Map MisoString Value
o ->
      MisoString
"{" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<>
        MisoString -> [MisoString] -> MisoString
MS.intercalate MisoString
"," [ MisoString
"\"" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString -> MisoString
escapeJSONString MisoString
k MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
"\"" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
":" MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> Value -> MisoString
forall str. ToMisoString str => str -> MisoString
ms Value
v | (MisoString
k,Value
v) <- Map MisoString Value -> [(MisoString, Value)]
forall k a. Map k a -> [(k, a)]
M.toList Map MisoString Value
o ]
      MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> MisoString
"}"
#endif
----------------------------------------------------------------------------
-- | Decode a JSON 'MisoString' into a Haskell value, returning 'Nothing' on failure.
--
-- On the client calls @JSON.parse()@ via FFI. On the server uses the pure
-- Haskell parser. For a human-readable error message on failure use 'eitherDecode'.
#ifdef VANILLA
decode :: FromJSON a => MisoString -> Maybe a
decode :: forall a. FromJSON a => MisoString -> Maybe a
decode MisoString
s
  | Right Value
x <- MisoString -> Either String Value
Parser.decodePure MisoString
s
  , Success a
v <- Value -> Result a
forall a. FromJSON a => Value -> Result a
fromJSON Value
x = a -> Maybe a
forall a. a -> Maybe a
Just a
v
  | Bool
otherwise = Maybe a
forall a. Maybe a
Nothing
#else
decode :: FromJSON a => MisoString -> Maybe a
decode s
  | Right x <- eitherDecode s = Just x
  | otherwise = Nothing
#endif
-----------------------------------------------------------------------------
#ifdef GHCJS_OLD
foreign import javascript unsafe
  "$r = JSON.stringify($1, null, $2)"
  encodePretty_ffi :: JSVal -> Int -> IO MisoString
#endif
-----------------------------------------------------------------------------
#ifdef GHCJS_NEW
foreign import javascript unsafe
  "(($1) => { return JSON.stringify($1, null, $2); })"
  encodePretty_ffi :: JSVal -> Int -> IO MisoString
#endif
-----------------------------------------------------------------------------
#ifdef WASM
foreign import javascript unsafe
  "return JSON.stringify($1, null, $2);"
  encodePretty_ffi :: JSVal -> Int -> IO MisoString
#endif
-----------------------------------------------------------------------------
-- | Like 'encodePretty' but with a custom t'Config'.
-- Not available in the @VANILLA@ build.
#ifdef VANILLA
encodePretty' :: ToJSON a => Config -> a -> MisoString
encodePretty' :: forall a. ToJSON a => Config -> a -> MisoString
encodePretty' = String -> Config -> a -> MisoString
forall a. HasCallStack => String -> a
error String
"encodePretty': not implemented"
-----------------------------------------------------------------------------
-- | Encode a value as indented (pretty-printed) JSON using 'defConfig'
-- (4-space indentation). Not available in the @VANILLA@ build.
encodePretty :: ToJSON a => a -> MisoString
encodePretty :: forall a. ToJSON a => a -> MisoString
encodePretty a
_ = String -> MisoString
forall a. HasCallStack => String -> a
error String
"encodePretty: not implemented"
-----------------------------------------------------------------------------
#else
-----------------------------------------------------------------------------
encodePretty' :: ToJSON a => Config -> a -> MisoString
encodePretty' (Config s) x = unsafePerformIO (flip encodePretty_ffi s =<< toJSVal_Value (toJSON x))
-----------------------------------------------------------------------------
encodePretty :: ToJSON a => a -> MisoString
encodePretty = encodePretty' defConfig
#endif
-----------------------------------------------------------------------------
-- | Pretty-printing configuration for 'encodePretty' and 'encodePretty''.
newtype Config
  = Config
  { Config -> Int
spaces :: Int
  -- ^ Number of spaces per indentation level.
  } deriving (Int -> Config -> String -> String
[Config] -> String -> String
Config -> String
(Int -> Config -> String -> String)
-> (Config -> String)
-> ([Config] -> String -> String)
-> Show Config
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Config -> String -> String
showsPrec :: Int -> Config -> String -> String
$cshow :: Config -> String
show :: Config -> String
$cshowList :: [Config] -> String -> String
showList :: [Config] -> String -> String
Show, Config -> Config -> Bool
(Config -> Config -> Bool)
-> (Config -> Config -> Bool) -> Eq Config
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
/= :: Config -> Config -> Bool
Eq)
-----------------------------------------------------------------------------
-- | Default pretty-print config: 4-space indentation.
defConfig :: Config
defConfig :: Config
defConfig = Int -> Config
Config Int
4
-----------------------------------------------------------------------------
-- | Call @JSON.stringify()@ on a JavaScript value, returning a JSON string.
#ifdef GHCJS_OLD
foreign import javascript unsafe
  "$r = JSON.stringify($1)"
  jsonStringify :: JSVal -> IO MisoString
#endif
-----------------------------------------------------------------------------
#ifdef GHCJS_NEW
foreign import javascript unsafe
  "(($1) => { return JSON.stringify($1); })"
  jsonStringify :: JSVal -> IO MisoString
#endif
-----------------------------------------------------------------------------
#ifdef WASM
foreign import javascript unsafe
  "return JSON.stringify($1);"
  jsonStringify :: JSVal -> IO MisoString
#endif
-----------------------------------------------------------------------------
#ifdef VANILLA
jsonStringify :: JSVal -> IO MisoString
jsonStringify :: JSVal -> IO MisoString
jsonStringify JSVal
_ = String -> IO MisoString
forall a. HasCallStack => String -> a
error String
"jsonStringify: not implemented"
#endif
-----------------------------------------------------------------------------
-- | Call @JSON.parse()@ on a JSON string, returning a raw JavaScript value.
#ifdef GHCJS_OLD
foreign import javascript unsafe
  "$r = JSON.parse($1)"
  jsonParse :: MisoString -> IO JSVal
#endif
-----------------------------------------------------------------------------
#ifdef GHCJS_NEW
foreign import javascript unsafe
  "(($1) => { return JSON.parse($1); })"
  jsonParse :: MisoString -> IO JSVal
#endif
-----------------------------------------------------------------------------
#ifdef WASM
foreign import javascript unsafe
  "return JSON.parse($1);"
  jsonParse :: MisoString -> IO JSVal
#endif
-----------------------------------------------------------------------------
#ifdef VANILLA
jsonParse :: MisoString -> IO JSVal
jsonParse :: MisoString -> IO JSVal
jsonParse MisoString
_ = String -> IO JSVal
forall a. HasCallStack => String -> a
error String
"jsonParse: not implemented"
#endif
-----------------------------------------------------------------------------
-- | Decode a JSON 'MisoString', returning @'Left' errMsg@ on failure.
-- Prefer 'decode' when the error message is not needed.
#ifdef VANILLA
eitherDecode :: FromJSON a => MisoString -> Either MisoString a
eitherDecode :: forall a. FromJSON a => MisoString -> Either MisoString a
eitherDecode MisoString
string =
  case MisoString -> Either String Value
Parser.decodePure MisoString
string of
    Left String
s ->
      MisoString -> Either MisoString a
forall a b. a -> Either a b
Left (String -> MisoString
pack String
s)
    Right Value
v ->
      (Value -> Parser a) -> Value -> Either MisoString a
forall a b. (a -> Parser b) -> a -> Either MisoString b
parseEither Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
#else
eitherDecode :: FromJSON a => MisoString -> Either MisoString a
eitherDecode string = unsafePerformIO $ do
  (jsonParse string >>= fromJSVal_Value) >>= \case
    Nothing ->
      pure $ Left ("eitherDecode: " <> string)
    Just result ->
      pure (case fromJSON result of
        Success x -> Right x
        Error err -> Left err)
#endif
----------------------------------------------------------------------------
-- | Convert a JSON 'Value' to a Haskell type, returning a 'Result'.
-- Useful when a 'Value' is already in hand; use 'decode' to parse from a string.
fromJSON :: FromJSON a => Value -> Result a
fromJSON :: forall a. FromJSON a => Value -> Result a
fromJSON Value
value =
  case (Value -> Parser a) -> Value -> Either MisoString a
forall a b. (a -> Parser b) -> a -> Either MisoString b
parseEither Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
value of
    Left MisoString
s -> MisoString -> Result a
forall a. MisoString -> Result a
Error MisoString
s
    Right a
x -> a -> Result a
forall a. a -> Result a
Success a
x
----------------------------------------------------------------------------
#ifndef VANILLA
-- Bridge helpers so the FFI marshalling code below is agnostic to whether
-- 'Value' is miso's own representation or aeson's (Scientific numbers,
-- Text strings, Vector arrays, KeyMap objects).
#ifdef AESON
numberToDouble :: Scientific -> Double
numberToDouble = toRealFloat
-----------------------------------------------------------------------------
doubleToNumber :: Double -> Value
doubleToNumber = Number . fromFloatDigits
-----------------------------------------------------------------------------
stringToMiso :: T.Text -> MisoString
stringToMiso = ms
-----------------------------------------------------------------------------
mkString :: MisoString -> Value
mkString = String . MS.fromMisoString
-----------------------------------------------------------------------------
mkArray :: [Value] -> Value
mkArray = toJSON
-----------------------------------------------------------------------------
mkObject :: [(MisoString, Value)] -> Value
mkObject kvs = Object (KeyMap.fromList [ (toKey k, v) | (k, v) <- kvs ])
-----------------------------------------------------------------------------
objectAssocs :: Object -> [(MisoString, Value)]
objectAssocs o = [ (ms (Key.toText k), v) | (k, v) <- KeyMap.toList o ]
#else
numberToDouble :: Double -> Double
numberToDouble = id
-----------------------------------------------------------------------------
doubleToNumber :: Double -> Value
doubleToNumber = Number
-----------------------------------------------------------------------------
stringToMiso :: MisoString -> MisoString
stringToMiso = id
-----------------------------------------------------------------------------
mkString :: MisoString -> Value
mkString = String
-----------------------------------------------------------------------------
mkArray :: [Value] -> Value
mkArray = Array
-----------------------------------------------------------------------------
mkObject :: [(MisoString, Value)] -> Value
mkObject = Object . M.fromList
-----------------------------------------------------------------------------
objectAssocs :: Object -> [(MisoString, Value)]
objectAssocs = M.toList
#endif
#endif
-----------------------------------------------------------------------------
-- | Convert a Miso JSON 'Value' to a raw JavaScript value via FFI.
#ifdef GHCJS_BOTH
toJSVal_Value :: Value -> IO JSVal
toJSVal_Value = \case
  Null ->
    pure jsNull
  Bool bool_ ->
    Marshal.toJSVal bool_
  String string ->
    Marshal.toJSVal (stringToMiso string)
  Number double ->
    Marshal.toJSVal (numberToDouble double)
  Array arr ->
    toJSVal_List =<< mapM toJSVal_Value (toList arr)
  Object hms -> do
    o <- create_ffi
    forM_ (objectAssocs hms) $ \(k,v) -> do
      v' <- toJSVal_Value v
      setProp_ffi k v' o
    pure o
#endif
-----------------------------------------------------------------------------
-- | Convert a raw JavaScript value to a Miso JSON 'Value' via FFI.
-- Returns 'Nothing' if the JS value cannot be represented as a JSON 'Value'.
#ifdef GHCJS_BOTH
fromJSVal_Value :: JSVal -> IO (Maybe Value)
fromJSVal_Value jsval_ = do
  typeof jsval_ >>= \case
    0 -> return (Just Null)
    1 -> Just . doubleToNumber <$> Marshal.fromJSValUnchecked jsval_
    2 -> Just . mkString <$> Marshal.fromJSValUnchecked jsval_
    3 -> fromJSValUnchecked_Int jsval_ >>= \case
      0 -> pure $ Just (Bool False)
      1 -> pure $ Just (Bool True)
      _ -> pure Nothing
    4 -> do xs <- Marshal.fromJSValUnchecked jsval_
            values <- forM xs fromJSVal_Value
            pure (mkArray <$> sequence values)
    5 -> do keys <- Marshal.fromJSValUnchecked =<< listProps_ffi jsval_
            result <-
              runMaybeT $ forM keys $ \k -> do
                key <- MaybeT (Marshal.fromJSVal k)
                raw <- MaybeT $ Just <$> getProp_ffi key jsval_
                value <- MaybeT (fromJSVal_Value raw)
                pure (key, value)
            pure (toObject <$> result)
    _ -> error "fromJSVal_Value: Unknown JSON type"
  where
    toObject = mkObject
#endif
-----------------------------------------------------------------------------
#ifdef WASM
fromJSVal_Value :: JSVal -> IO (Maybe Value)
fromJSVal_Value jsval = do
  typeof jsval >>= \case
    0 -> return (Just Null)
    1 -> Just . doubleToNumber <$> fromJSValUnchecked_Double jsval
    2 -> pure $ Just $ mkString $ (JSString jsval)
    3 -> fromJSValUnchecked_Int jsval >>= \case
      0 -> pure $ Just (Bool False)
      1 -> pure $ Just (Bool True)
      _ -> pure Nothing
    4 -> do xs <- fromJSValUnchecked_List jsval
            values <- forM xs fromJSVal_Value
            pure (mkArray <$> sequence values)
    5 -> do keys <- fromJSValUnchecked_List =<< listProps_ffi jsval
            result <-
              runMaybeT $ forM keys $ \k -> do
                let key = JSString k
                raw <- MaybeT $ Just <$> getProp_ffi key jsval
                value <- MaybeT (fromJSVal_Value raw)
                pure (key, value)
            pure (toObject <$> result)
    _ -> error "fromJSVal_Value: Unknown JSON type"
  where
    toObject = mkObject
#endif
-----------------------------------------------------------------------------
#ifdef VANILLA
-----------------------------------------------------------------------------
fromJSVal_Value :: JSVal -> IO (Maybe Value)
fromJSVal_Value :: JSVal -> IO (Maybe Value)
fromJSVal_Value = String -> JSVal -> IO (Maybe Value)
forall a. HasCallStack => String -> a
error String
"fromJSVal_Value: not implemented"
-----------------------------------------------------------------------------
-- | Convert a Miso JSON t'Value' to a raw JavaScript value via FFI.
toJSVal_Value :: Value -> IO JSVal
toJSVal_Value :: Value -> IO JSVal
toJSVal_Value = String -> Value -> IO JSVal
forall a. HasCallStack => String -> a
error String
"toJSVal_Value: not implemented"
-----------------------------------------------------------------------------
#endif
-----------------------------------------------------------------------------
#ifdef GHCJS_NEW
foreign import javascript unsafe
  "(($1) => { return globalThis.miso.typeOf($1); })"
  typeof :: JSVal -> IO Int
#endif
-----------------------------------------------------------------------------
#ifdef WASM
foreign import javascript unsafe
 "return globalThis.miso.typeOf($1);"
  typeof :: JSVal -> IO Int
#endif
-----------------------------------------------------------------------------
#ifdef GHCJS_OLD
foreign import javascript unsafe
  "$r = globalThis.miso.typeOf($1);"
  typeof :: JSVal -> IO Int
#endif
-----------------------------------------------------------------------------
#ifdef WASM
-- | Convert a Miso JSON t'Value' to a raw JavaScript value via FFI.
toJSVal_Value :: Value -> IO JSVal
toJSVal_Value = \case
  Null ->
    pure jsNull
  Bool bool_ ->
    toJSVal_Bool bool_
  String string ->
    toJSVal_JSString (stringToMiso string)
  Number double ->
    toJSVal_Double (numberToDouble double)
  Array arr ->
    toJSVal_List =<< mapM toJSVal_Value (toList arr)
  Object hms -> do
    o <- create_ffi
    forM_ (objectAssocs hms) $ \(k,v) -> do
      v' <- toJSVal_Value v
      setProp_ffi k v' o
    pure o
#endif
-----------------------------------------------------------------------------