miso-1.12.0.0: src/Miso/JSON.hs
-----------------------------------------------------------------------------
{-# 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 'Options':
--
-- @
-- myOptions :: 'Options'
-- myOptions = 'defaultOptions' { 'fieldLabelModifier' = 'camelTo2' \'_\' }
--
-- instance 'ToJSON' Person where
-- 'toJSON' = 'genericToJSON' myOptions
--
-- -- { \"person_name\": \"Alice\", \"person_age\": 30 }
-- @
--
-- = API groups
--
-- * __Core types__ — 'Value', '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', 'Parser'
-- * __Prism-style parsers__ — 'withObject', 'withText', 'withArray', 'withNumber', 'withBool'
-- * __Conversion__ — 'fromJSON', 'parseMaybe', 'parseEither'
-- * __Options \/ Generics__ — '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 '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)
, Parser (..)
, parseMaybe
, ToJSON(toJSON)
-- * Misc.
, fromJSON
, parseEither
, eitherDecode
, typeMismatch
-- * Pretty
, encodePretty
, encodePretty'
, defConfig
, Config (..)
-- * FFI
, fromJSVal_Value
, toJSVal_Value
, jsonStringify
, jsonParse
-- * Options
, Options (..)
, defaultOptions
-- * Generics
, GToJSON (..)
, GToFields (..)
, GToJSONSum (..)
, GAllNullary (..)
, Fields (..)
, GFromJSON (..)
, GFromFields (..)
, GFromJSONSum (..)
, genericToJSON
, genericParseJSON
-- * Modifiers
, camelTo2
) where
----------------------------------------------------------------------------
#ifdef GHCJS_BOTH
import qualified GHCJS.Marshal as Marshal
#endif
----------------------------------------------------------------------------
import Control.Applicative
import Control.Monad
#if __GLASGOW_HASKELL__ <= 865
import Control.Monad.Fail
import GHC.Natural (Natural)
#endif
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
----------------------------------------------------------------------------
import Miso.DSL.FFI
import Miso.String (FromMisoString, ToMisoString, MisoString, ms, singleton, pack)
import qualified Miso.String as MS
import Miso.JSON.Types
import qualified Miso.JSON.Parser as Parser
import Numeric (showHex)
----------------------------------------------------------------------------
#ifndef VANILLA
import Control.Monad.Trans.Maybe
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 .=
(.=) :: ToJSON v => MisoString -> v -> Pair
k .= v = (k, toJSON v)
----------------------------------------------------------------------------
-- | Create a 'Value' from a list of name\/value 'Pair's.
object :: [Pair] -> Value
object = Object . M.fromList
----------------------------------------------------------------------------
-- | The empty JSON 'Object' (i.e. @{}@).
emptyObject :: Value
emptyObject = Object mempty
----------------------------------------------------------------------------
-- | The empty JSON 'Array' (i.e. @[]@).
emptyArray :: Value
emptyArray = Array mempty
----------------------------------------------------------------------------
-- | Look up a required key in a JSON 'Object'.
-- Fails with a parse error if the key is absent.
(.:) :: FromJSON a => Object -> MisoString -> Parser a
m .: k = maybe (pfail ("Key not found: " <> k)) parseJSON (M.lookup k m)
----------------------------------------------------------------------------
-- | Look up an optional key in a JSON 'Object'.
-- Returns 'Nothing' if the key is absent; delegates to 'parseJSON' if present.
(.:?) :: FromJSON a => Object -> MisoString -> Parser (Maybe a)
m .:? k = maybe (pure Nothing) parseJSON (M.lookup k 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)
m .:! k = maybe (pure Nothing) (fmap Just . parseJSON) (M.lookup k m)
----------------------------------------------------------------------------
-- | Provide a default when a 'Parser' produces 'Nothing'.
-- Typically chained after '.:?':
--
-- @o '.:?' \"count\" '.!=' 0@
(.!=) :: Parser (Maybe a) -> a -> Parser a
mv .!= def = fmap (fromMaybe def) mv
----------------------------------------------------------------------------
-- | 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 = genericToJSON defaultOptions
-- | Encode a list of @a@. Defaults to a JSON 'Array'; overridden by the
-- 'Char' instance so that @[Char]@ (i.e. 'String') serializes as a JSON
-- string. This mirrors aeson and avoids overlapping @ToJSON [a]@ instances.
toJSONList :: [a] -> Value
toJSONList = Array . Prelude.map toJSON
----------------------------------------------------------------------------
-- | Derive 'toJSON' via 'GHC.Generics' with custom '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 opts = gToJSON opts . 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 :: 'Options'
-- myOpts = 'defaultOptions' { 'fieldLabelModifier' = 'camelTo2' \'_\' }
-- @
data Options
= Options
{ fieldLabelModifier :: String -> String
-- ^ Applied to each record field name before encoding\/decoding (default: identity).
, constructorTagModifier :: String -> String
-- ^ Modify constructor names used as tags before encoding (default: identity).
, 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
-- 'String' (e.g. @\"Red\"@) rather than a tagged object
-- (e.g. @{\"tag\":\"Red\"}@).
, 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
{ fieldLabelModifier = \x -> x
, constructorTagModifier = \x -> x
, allNullaryToStringTag = True
, omitNothingFields = 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 'Options'.
camelTo2
:: Char
-- ^ Delimiter character to insert between words (e.g. @\'_\'@ or @\'-\'@)
-> String
-- ^ camelCase identifier to transform
-> String
camelTo2 c = Prelude.map toLower . go2 . go1
where go1 "" = ""
go1 (x:u:l:xs) | isUpper u && isLower l = x : c : u : l : go1 xs
go1 (x:xs) = x : go1 xs
go2 "" = ""
go2 (l:u:xs) | isLower l && isUpper u = l : c : u : go2 xs
go2 (x:xs) = x : go2 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 (RecordFields xs) (RecordFields ys) = RecordFields (xs <> ys)
combineFields (PositionalFields xs) (PositionalFields ys) = PositionalFields (xs <> ys)
combineFields _ _ = 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 _ _ = PositionalFields []
----------------------------------------------------------------------------
instance GToFields V1 where
gToFields _ v = v `seq` PositionalFields []
----------------------------------------------------------------------------
instance (GToFields f, GToFields g) => GToFields (f :*: g) where
gToFields opts (x :*: y) = combineFields (gToFields opts x) (gToFields opts y)
----------------------------------------------------------------------------
instance (Selector m, GToFields f) => GToFields (S1 m f) where
gToFields opts (M1 x) =
let n = selName (M1 undefined :: S1 m f ())
in if null n
then gToFields opts x
else case gToFields opts x of
PositionalFields [v] -> RecordFields [(ms (fieldLabelModifier opts n), v)]
fs -> fs -- shouldn't happen
----------------------------------------------------------------------------
instance ToJSON a => GToFields (K1 r a) where
gToFields _ (K1 x) = PositionalFields [toJSON 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 opts (M1 (K1 mx)) =
let n = selName (M1 undefined :: S1 m (K1 r (Maybe a)) ())
key = ms (fieldLabelModifier opts n)
in if null n
then PositionalFields [toJSON mx]
else case mx of
Nothing | omitNothingFields opts -> RecordFields []
_ -> RecordFields [(key, toJSON 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 = True
----------------------------------------------------------------------------
instance GAllNullary (K1 r a) where
gAllNullary = False
----------------------------------------------------------------------------
instance (GAllNullary f, GAllNullary g) => GAllNullary (f :*: g) where
gAllNullary = False -- has multiple fields, definitely not nullary
----------------------------------------------------------------------------
instance GAllNullary f => GAllNullary (S1 m f) where
gAllNullary = gAllNullary @f
----------------------------------------------------------------------------
instance GAllNullary f => GAllNullary (C1 m f) where
gAllNullary = gAllNullary @f
----------------------------------------------------------------------------
instance (GAllNullary f, GAllNullary g) => GAllNullary (f :+: g) where
gAllNullary = gAllNullary @f && 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 = \case
RecordFields kvs -> Object (M.fromList kvs)
PositionalFields [] -> Array []
PositionalFields [v] -> v
PositionalFields vs -> Array 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 tag = \case
RecordFields kvs -> Object (M.fromList (("tag", String tag) : kvs))
PositionalFields [] -> Object (M.singleton "tag" (String tag))
PositionalFields [v] -> object [("tag", String tag), ("contents", v)]
PositionalFields vs -> object [("tag", String tag), ("contents", Array 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 opts (M1 x) = gToJSONRep opts x
----------------------------------------------------------------------------
-- Internal: dispatches single-constructor vs sum at the child of D1.
class GToJSONRep (f :: Type -> Type) where
gToJSONRep :: Options -> f a -> Value
-- Single constructor: no tag
instance GToFields f => GToJSONRep (C1 m f) where
gToJSONRep opts (M1 x) = encodeProduct (gToFields opts x)
-- Sum: branch on allNullaryToStringTag
instance (GToJSONSum f, GToJSONSum g, GToJSONSumNullary f, GToJSONSumNullary g, GAllNullary f, GAllNullary g)
=> GToJSONRep (f :+: g) where
gToJSONRep opts x
| allNullaryToStringTag opts && gAllNullary @f && gAllNullary @g
= gToJSONSumNullary opts x
| otherwise
= gToJSONSum opts x
----------------------------------------------------------------------------
-- | Encode all-nullary sum constructors as bare 'String' values.
class GToJSONSumNullary (f :: Type -> Type) where
gToJSONSumNullary :: Options -> f a -> Value
----------------------------------------------------------------------------
instance (GToJSONSumNullary f, GToJSONSumNullary g) => GToJSONSumNullary (f :+: g) where
gToJSONSumNullary opts (L1 x) = gToJSONSumNullary opts x
gToJSONSumNullary opts (R1 x) = gToJSONSumNullary opts x
----------------------------------------------------------------------------
instance Constructor m => GToJSONSumNullary (C1 m U1) where
gToJSONSumNullary opts _ =
String (ms (constructorTagModifier opts (conName (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 _ _ = error "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 opts (L1 x) = gToJSONSum opts x
gToJSONSum opts (R1 x) = gToJSONSum opts x
----------------------------------------------------------------------------
instance (Constructor m, GToFields f) => GToJSONSum (C1 m f) where
gToJSONSum opts (M1 x) =
encodeTaggedCon
(ms (constructorTagModifier opts (conName (undefined :: C1 m f ()))))
(gToFields opts x)
----------------------------------------------------------------------------
instance ToJSON () where
toJSON () = Array []
----------------------------------------------------------------------------
instance ToJSON Value where
toJSON = id
----------------------------------------------------------------------------
instance ToJSON Char where
toJSON c = String (singleton c)
toJSONList = String . MS.pack
----------------------------------------------------------------------------
instance ToJSON Bool where
toJSON = Bool
----------------------------------------------------------------------------
instance ToJSON a => ToJSON [a] where
toJSON = toJSONList
----------------------------------------------------------------------------
instance ToJSON v => ToJSON (M.Map MisoString v) where
toJSON = Object . M.map toJSON
----------------------------------------------------------------------------
instance ToJSON a => ToJSON (Maybe a) where
toJSON = \case
Nothing -> Null
Just a -> toJSON a
----------------------------------------------------------------------------
instance (ToJSON a,ToJSON b) => ToJSON (a,b) where
toJSON (a,b) = Array [toJSON a, toJSON b]
----------------------------------------------------------------------------
instance (ToJSON a,ToJSON b,ToJSON c) => ToJSON (a,b,c) where
toJSON (a,b,c) = Array [toJSON a, toJSON b, toJSON c]
----------------------------------------------------------------------------
instance (ToJSON a,ToJSON b,ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where
toJSON (a,b,c,d) = Array [toJSON a, toJSON b, toJSON c, toJSON d]
----------------------------------------------------------------------------
instance ToJSON MisoString where
toJSON = String
----------------------------------------------------------------------------
#ifndef VANILLA
instance ToJSON T.Text where
toJSON = toJSON . ms
#endif
----------------------------------------------------------------------------
instance ToJSON LT.Text where
toJSON = toJSON . ms
----------------------------------------------------------------------------
instance ToJSON Float where
toJSON = Number . realToFrac
----------------------------------------------------------------------------
instance ToJSON Double where
toJSON = Number
----------------------------------------------------------------------------
instance ToJSON Int where toJSON = Number . realToFrac
instance ToJSON Int8 where toJSON = Number . realToFrac
instance ToJSON Int16 where toJSON = Number . realToFrac
instance ToJSON Int32 where toJSON = Number . realToFrac
----------------------------------------------------------------------------
instance ToJSON Word where toJSON = Number . realToFrac
instance ToJSON Word8 where toJSON = Number . realToFrac
instance ToJSON Word16 where toJSON = Number . realToFrac
instance ToJSON Word32 where toJSON = Number . realToFrac
----------------------------------------------------------------------------
-- | Possibly lossy due to conversion to 'Double'
instance ToJSON Int64 where toJSON = Number . realToFrac
----------------------------------------------------------------------------
-- | Possibly lossy due to conversion to 'Double'
instance ToJSON Word64 where toJSON = Number . realToFrac
----------------------------------------------------------------------------
-- | Possibly lossy due to conversion to 'Double'
instance ToJSON Integer where toJSON = Number . fromInteger
----------------------------------------------------------------------------
-- | Possibly lossy due to conversion to 'Double'
instance ToJSON Natural where toJSON = Number . fromInteger . naturalToInteger
----------------------------------------------------------------------------
-- | A lightweight JSON parse monad. Wraps @Either MisoString a@ so that
-- parse failures carry a human-readable error message.
--
-- '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
{ unParser :: Either MisoString a
-- ^ The underlying result: @'Left' errMsg@ on failure, @'Right' a@ on success
} deriving (Functor, Applicative, Monad)
----------------------------------------------------------------------------
instance MonadFail Parser where
fail = pfail . pack
----------------------------------------------------------------------------
instance Alternative Parser where
empty = Parser (Left mempty)
Parser (Left _) <|> r = r
l <|> _ = 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 m v =
case parseEither m v of
Left _ -> Nothing
Right r -> Just 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 m v = unParser (m v)
----------------------------------------------------------------------------
pfail :: MisoString -> Parser a
pfail message = Parser (Left message)
----------------------------------------------------------------------------
-- | 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 'Parser' on a type mismatch.
parseJSON :: Value -> Parser a
default parseJSON :: (Generic a, GFromJSON (Rep a)) => Value -> Parser a
parseJSON = genericParseJSON defaultOptions
----------------------------------------------------------------------------
-- | Top-level generic decoding class. Symmetric with 'GToJSON'.
--
-- Decoding rules match aeson's defaults (see 'Options' and 'defaultOptions').
class GFromJSON (f :: Type -> Type) where
gParseJSON :: Options -> Value -> Parser (f a)
----------------------------------------------------------------------------
-- | Derive 'parseJSON' via 'GHC.Generics' with custom '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 opts value = to <$> gParseJSON opts value
----------------------------------------------------------------------------
instance GFromJSONRep f => GFromJSON (D1 m f) where
gParseJSON opts v = M1 <$> gFromJSONRep opts v
----------------------------------------------------------------------------
-- Internal: dispatches single-constructor vs sum at the child of D1.
class GFromJSONRep (f :: Type -> Type) where
gFromJSONRep :: Options -> Value -> Parser (f a)
-- Single constructor
instance GFromFields f => GFromJSONRep (C1 m f) where
gFromJSONRep opts v = M1 <$> parseProd opts v
-- Sum type: branch on allNullaryToStringTag
instance (GFromJSONSum f, GFromJSONSum g, GFromJSONSumNullary f, GFromJSONSumNullary g, GAllNullary f, GAllNullary g)
=> GFromJSONRep (f :+: g) where
gFromJSONRep opts v
| allNullaryToStringTag opts && gAllNullary @f && gAllNullary @g
= gFromJSONSumNullary opts v
| otherwise
= gFromJSONSum opts v
----------------------------------------------------------------------------
-- | Parse all-nullary sum constructors from bare 'String' values.
class GFromJSONSumNullary (f :: Type -> Type) where
gFromJSONSumNullary :: Options -> Value -> Parser (f a)
----------------------------------------------------------------------------
instance (GFromJSONSumNullary f, GFromJSONSumNullary g) => GFromJSONSumNullary (f :+: g) where
gFromJSONSumNullary opts v =
(L1 <$> gFromJSONSumNullary opts v) <|> (R1 <$> gFromJSONSumNullary opts v)
----------------------------------------------------------------------------
instance Constructor m => GFromJSONSumNullary (C1 m U1) where
gFromJSONSumNullary opts v =
let tag = ms (constructorTagModifier opts (conName (undefined :: C1 m U1 ())))
in case v of
String t | t == tag -> pure (M1 U1)
| otherwise -> pfail ("expected \"" <> tag <> "\" got \"" <> t <> "\"")
_ -> pfail ("expected String for nullary constructor " <> 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 _ _ = pfail "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 opts v = (L1 <$> gFromJSONSum opts v) <|> (R1 <$> gFromJSONSum opts v)
----------------------------------------------------------------------------
instance (Constructor m, GFromFields f) => GFromJSONSum (C1 m f) where
gFromJSONSum opts v = M1 <$> parseTaggedCon tag opts v
where tag = ms (constructorTagModifier opts (conName (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 opts v
| gIsRecord @f = withObject "generic record" (gFromRecord opts) v
| otherwise = case v of
Array vs
| gFieldCount @f == 1 -> gFromPositional opts [Array vs]
| otherwise -> gFromPositional opts vs
_
| gFieldCount @f == 0 -> pfail "expected Array [] for 0-field constructor"
| gFieldCount @f == 1 -> gFromPositional opts [v] -- single-field shorthand
| otherwise -> pfail "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 tag opts = \case
Object o -> do
t <- case M.lookup "tag" o of
Just (String t) -> pure t
Just _ -> pfail "\"tag\" field is not a string"
Nothing -> pfail "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 vs)
| gFieldCount @f == 1 -> gFromPositional opts [Array vs]
| otherwise -> gFromPositional opts vs
Just single -> gFromPositional opts [single]
Nothing -> gFromPositional opts []
_ -> pfail ("expected JSON object for constructor " <> ms (show tag))
----------------------------------------------------------------------------
-- | Field-level decoder. Knows whether the constructor is a record and
-- how many fields it has; can decode from a JSON '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 '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 = False
gFieldCount = 0
gFromRecord _ _ = pure U1
gFromPositional _ _ = pure U1
----------------------------------------------------------------------------
instance GFromFields V1 where
gIsRecord = False
gFieldCount = 0
gFromRecord _ _ = pfail "V1"
gFromPositional _ _ = pfail "V1"
----------------------------------------------------------------------------
instance (GFromFields f, GFromFields g) => GFromFields (f :*: g) where
gIsRecord = gIsRecord @f
gFieldCount = gFieldCount @f + gFieldCount @g
gFromRecord opts o =
(:*:) <$> gFromRecord opts o
<*> gFromRecord opts o
gFromPositional opts vs =
let n = gFieldCount @f
in (:*:) <$> gFromPositional opts (take n vs)
<*> gFromPositional opts (drop n 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 = not (null name)
where name = selName (M1 undefined :: S1 m (K1 r (Maybe a)) ())
gFieldCount = 1
gFromRecord opts o =
M1 . K1 <$> o .:? ms (fieldLabelModifier opts
(selName (M1 undefined :: S1 m (K1 r (Maybe a)) ())))
gFromPositional _ vs = case vs of
(v:_) -> M1 . K1 <$> parseJSON v
[] -> pure (M1 (K1 Nothing))
----------------------------------------------------------------------------
-- | General selector.
instance {-# OVERLAPPABLE #-} (Selector m, FromJSON a)
=> GFromFields (S1 m (K1 r a)) where
gIsRecord = not (null name)
where name = selName (M1 undefined :: S1 m (K1 r a) ())
gFieldCount = 1
gFromRecord opts o =
M1 . K1 <$> o .: ms (fieldLabelModifier opts
(selName (M1 undefined :: S1 m (K1 r a) ())))
gFromPositional _ vs = case vs of
(v:_) -> M1 . K1 <$> parseJSON v
[] -> pfail "gFromPositional: unexpected end of fields"
----------------------------------------------------------------------------
instance FromJSON Value where
parseJSON = pure
----------------------------------------------------------------------------
instance FromJSON Bool where
parseJSON = withBool "Bool" pure
----------------------------------------------------------------------------
instance FromJSON MisoString where
parseJSON = withText "MisoString" 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 = withText "LText" go
where
go s =
case MS.fromMisoStringEither s of
Right lt -> pure lt
Left e -> pfail $ ms e
----------------------------------------------------------------------------
instance {-# OVERLAPPING #-} FromJSON String where
parseJSON = withText "String" (pure . MS.unpack)
----------------------------------------------------------------------------
instance FromJSON a => FromJSON [a] where
parseJSON = withArray "[a]" (mapM parseJSON)
----------------------------------------------------------------------------
instance FromJSON Double where
parseJSON Null = pure (0/0)
parseJSON j = withNumber "Double" pure j
----------------------------------------------------------------------------
instance FromJSON Float where
parseJSON Null = pure (0/0)
parseJSON j = withNumber "Float" (pure . realToFrac) j
----------------------------------------------------------------------------
instance FromJSON Integer where
parseJSON = withNumber "Integer" (pure . round)
----------------------------------------------------------------------------
instance FromJSON Natural where
parseJSON = withNumber "Natural" parseNumber
where parseNumber d | d < 0 = pfail ("Cannot parse negative number as Natural: " <> ms d)
| isNaN d = pfail ("Cannot parse NaN as Natural: " <> ms d)
| otherwise = pure $ naturalFromInteger $ fromInteger $ round d
----------------------------------------------------------------------------
instance FromJSON Int where
parseJSON = withNumber "Int" (pure . fromInteger . round)
----------------------------------------------------------------------------
instance FromJSON Int8 where
parseJSON = withNumber "Int8" (pure . fromInteger . round)
----------------------------------------------------------------------------
instance FromJSON Int16 where
parseJSON = withNumber "Int16" (pure . fromInteger . round)
----------------------------------------------------------------------------
instance FromJSON Int32 where
parseJSON = withNumber "Int32" (pure . fromInteger . round)
----------------------------------------------------------------------------
instance FromJSON Int64 where
parseJSON = withNumber "Int64" (pure . fromInteger . round)
----------------------------------------------------------------------------
instance FromJSON Word where
parseJSON = withNumber "Word" (pure . fromInteger . round)
----------------------------------------------------------------------------
instance FromJSON Word8 where
parseJSON = withNumber "Word8" (pure . fromInteger . round)
----------------------------------------------------------------------------
instance FromJSON Word16 where
parseJSON = withNumber "Word16" (pure . fromInteger . round)
----------------------------------------------------------------------------
instance FromJSON Word32 where
parseJSON = withNumber "Word32" (pure . fromInteger . round)
----------------------------------------------------------------------------
instance FromJSON Word64 where
parseJSON = withNumber "Word64" (pure . fromInteger . round)
----------------------------------------------------------------------------
instance FromJSON () where
parseJSON = withArray "()" $ \lst ->
case lst of
[] -> pure ()
_ -> pfail "expected ()"
----------------------------------------------------------------------------
instance (FromJSON a, FromJSON b) => FromJSON (a,b) where
parseJSON = withArray "(a,b)" $ \lst ->
case lst of
[a,b] -> liftM2 (,) (parseJSON a) (parseJSON b)
_ -> pfail "expected (a,b)"
----------------------------------------------------------------------------
instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a,b,c) where
parseJSON = withArray "(a,b,c)" $ \lst ->
case lst of
[a,b,c] -> liftM3 (,,) (parseJSON a) (parseJSON b) (parseJSON c)
_ -> pfail "expected (a,b,c)"
----------------------------------------------------------------------------
instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON (a,b,c,d) where
parseJSON = withArray "(a,b,c,d)" $ \lst ->
case lst of
[a,b,c,d] -> liftM4 (,,,) (parseJSON a) (parseJSON b) (parseJSON c) (parseJSON d)
_ -> pfail "expected (a,b,c,d)"
----------------------------------------------------------------------------
instance FromJSON a => FromJSON (Maybe a) where
parseJSON Null = pure Nothing
parseJSON j = Just <$> parseJSON j
----------------------------------------------------------------------------
instance FromJSON Ordering where
parseJSON = withText "{'LT','EQ','GT'}" $ \s ->
case s of
"LT" -> pure LT
"EQ" -> pure EQ
"GT" -> pure GT
_ -> pfail "expected {'LT','EQ','GT'}"
----------------------------------------------------------------------------
instance FromJSON Char where
parseJSON = withText "Char" $ \xs ->
case xs of
x | MS.length x == 1 -> pure (MS.head x)
| otherwise -> pfail ("expected Char, received: " <> x)
----------------------------------------------------------------------------
instance FromJSON v => FromJSON (Map MisoString v) where
parseJSON = withObject "FromJSON v => Map MisoString v" $ mapM parseJSON
----------------------------------------------------------------------------
-- | Succeed only when the 'Value' is a '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 'Bool'
-> Value
-- ^ JSON value to inspect
-> Parser a
withBool _ f (Bool arr) = f arr
withBool expected _ v = typeMismatch expected 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 _ f (String txt) = f txt
withText expected _ v = typeMismatch expected 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 _ f (Array lst) = f lst
withArray expected _ v = typeMismatch expected v
----------------------------------------------------------------------------
-- | Succeed only when the 'Value' is a JSON object; fail with 'typeMismatch' otherwise.
-- The inner parser receives the 'Object' map for key lookups with '.:' etc.
withObject
:: MisoString
-- ^ Expected type name used in the error message
-> (Object -> Parser a)
-- ^ Continuation receiving the 'Object' key\/value map
-> Value
-- ^ JSON value to inspect
-> Parser a
withObject _ f (Object obj) = f obj
withObject expected _ v = typeMismatch expected 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 _ f (Number n) = f n
withNumber expected _ v = typeMismatch expected 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 expected actual =
pfail
( "typeMismatch: Expected " <> expected <> " but encountered " <> case actual of
Object _ -> "Object"
Array _ -> "Array"
String _ -> "String"
Number _ -> "Number"
Bool _ -> "Boolean"
Null -> "Null"
)
----------------------------------------------------------------------------
-- | 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 = 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 = ms . toJSON
----------------------------------------------------------------------------
instance FromMisoString Value where
fromMisoStringEither = Parser.decodePure
----------------------------------------------------------------------------
-- | Escape special characters in a string for JSON serialization
-- Handles: \, ", and all JSON control characters per RFC 8259
escapeJSONString :: MisoString -> MisoString
escapeJSONString = MS.concatMap escapeChar
where
escapeChar :: Char -> MisoString
escapeChar '\\' = "\\\\" -- Backslash
escapeChar '"' = "\\\"" -- Double quote
escapeChar '\b' = "\\b" -- Backspace
escapeChar '\f' = "\\f" -- Form feed
escapeChar '\n' = "\\n" -- Newline
escapeChar '\r' = "\\r" -- Carriage return
escapeChar '\t' = "\\t" -- Tab
escapeChar c
| isControl c = ms ("\\u" <> padHex (ord c)) -- Other control chars as \uXXXX
| otherwise = singleton c
padHex :: Int -> MisoString
padHex n = MS.pack $ replicate (4 - length h) '0' ++ h
where h = showHex n ""
----------------------------------------------------------------------------
instance ToMisoString Value where
toMisoString = \case
String s -> "\"" <> escapeJSONString s <> "\""
Number n
| (i, 0.0) <- properFraction n -> ms @Int i
| otherwise -> ms n
Null ->
"null"
Array xs ->
"[" <> MS.intercalate "," (fmap ms xs) <> "]"
Bool True ->
"true"
Bool False ->
"false"
Object o ->
"{" <>
MS.intercalate "," [ "\"" <> escapeJSONString k <> "\"" <> ":" <> ms v | (k,v) <- M.toList o ]
<> "}"
----------------------------------------------------------------------------
-- | 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 s
| Right x <- Parser.decodePure s
, Success v <- fromJSON x = Just v
| otherwise = 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 'Config'.
-- Not available in the @VANILLA@ build.
#ifdef VANILLA
encodePretty' :: ToJSON a => Config -> a -> MisoString
encodePretty' = error "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 _ = error "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
{ spaces :: Int
-- ^ Number of spaces per indentation level.
} deriving (Show, Eq)
-----------------------------------------------------------------------------
-- | Default pretty-print config: 4-space indentation.
defConfig :: Config
defConfig = Config 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 _ = error "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 _ = error "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 string =
case Parser.decodePure string of
Left s ->
Left (pack s)
Right v ->
parseEither parseJSON 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 value =
case parseEither parseJSON value of
Left s -> Error s
Right x -> Success x
----------------------------------------------------------------------------
-- | 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 string
Number double ->
Marshal.toJSVal double
Array arr ->
toJSVal_List =<< mapM toJSVal_Value arr
Object hms -> do
o <- create_ffi
forM_ (M.toList 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 . Number <$> Marshal.fromJSValUnchecked jsval_
2 -> Just . String <$> 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 (Array <$> 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 = Object . M.fromList
#endif
-----------------------------------------------------------------------------
#ifdef WASM
fromJSVal_Value :: JSVal -> IO (Maybe Value)
fromJSVal_Value jsval = do
typeof jsval >>= \case
0 -> return (Just Null)
1 -> Just . Number <$> fromJSValUnchecked_Double jsval
2 -> pure $ Just $ String $ (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 (Array <$> 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 = Object . M.fromList
#endif
-----------------------------------------------------------------------------
#ifdef VANILLA
-----------------------------------------------------------------------------
fromJSVal_Value :: JSVal -> IO (Maybe Value)
fromJSVal_Value = error "fromJSVal_Value: not implemented"
-----------------------------------------------------------------------------
toJSVal_Value :: Value -> IO JSVal
toJSVal_Value = error "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
toJSVal_Value :: Value -> IO JSVal
toJSVal_Value = \case
Null ->
pure jsNull
Bool bool_ ->
toJSVal_Bool bool_
String string ->
toJSVal_JSString string
Number double ->
toJSVal_Double double
Array arr ->
toJSVal_List =<< mapM toJSVal_Value arr
Object hms -> do
o <- create_ffi
forM_ (M.toList hms) $ \(k,v) -> do
v' <- toJSVal_Value v
setProp_ffi k v' o
pure o
#endif
-----------------------------------------------------------------------------