autodocodec-0.4.2.2: src/Autodocodec/Codec.hs
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeApplications #-}
-- Because Eq is a superclass of Hashable in newer versions.
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Autodocodec.Codec where
import Control.Monad
import Control.Monad.State
import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON
import Data.Coerce (Coercible)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Hashable
import Data.List (intersperse)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Map (Map)
import Data.Scientific as Scientific
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Data.Validity
import Data.Validity.Scientific ()
import Data.Vector (Vector)
import qualified Data.Vector as V
import Data.Void
import Data.Word
import GHC.Generics (Generic)
import Numeric.Natural
#if MIN_VERSION_aeson(2,0,0)
import Data.Aeson.KeyMap (KeyMap)
import qualified Data.Aeson.KeyMap as KM
#endif
-- $setup
-- >>> import Autodocodec.Aeson (toJSONVia, toJSONViaCodec, toJSONObjectVia, toJSONObjectViaCodec, parseJSONVia, parseJSONViaCodec, parseJSONObjectVia, parseJSONObjectViaCodec)
-- >>> import qualified Autodocodec.Aeson.Compat as Compat
-- >>> import Autodocodec.Class (HasCodec(codec), requiredField)
-- >>> import qualified Data.Aeson as JSON
-- >>> import qualified Data.HashMap.Strict as HM
-- >>> import Data.Aeson (Value(..))
-- >>> import qualified Data.Vector as Vector
-- >>> import Data.Int
-- >>> import Data.Word
-- >>> :set -XOverloadedStrings
-- >>> :set -XOverloadedLists
-- >>> :set -XLambdaCase
-- | A Self-documenting encoder and decoder,
--
-- also called an "Autodocodec".
--
-- In an ideal situation, this type would have only one type parameter: 'Codec value'.
-- This does not work very well because we want to be able to implement 'Functor' and 'Applicative', which each require a kind '* -> *'.
-- So instead we use two type parameters.
--
-- The two type parameters correspond to the phase in which they are used:
--
-- * The @input@ parameter is used for the type that is used during encoding of a value, so it's the @input@ to the codec.
-- * The @output@ parameter is used for the type that is used during decoding of a value, so it's the @output@ of the codec.
-- * Both parameters are unused during documentation.
type role Codec _ representational representational
data Codec context input output where
-- | Encode '()' to the @null@ value, and decode @null@ as '()'.
NullCodec ::
(Coercible a (), Coercible b ()) =>
ValueCodec a b
-- | Encode a 'Bool' to a @boolean@ value, and decode a @boolean@ value as a 'Bool'.
BoolCodec ::
(Coercible a Bool, Coercible b Bool) =>
-- | Name of the @bool@, for error messages and documentation.
Maybe Text ->
ValueCodec a b
-- | Encode 'Text' to a @string@ value, and decode a @string@ value as a 'Text'.
--
-- This is named after the primitive type "String" in json, not after the haskell type string.
StringCodec ::
(Coercible a Text, Coercible b Text) =>
-- | Name of the @string@, for error messages and documentation.
Maybe Text ->
ValueCodec a b
-- | Encode 'Integer' to a @number@ value, and decode a @number@ value as an 'Integer'.
--
-- The number has 'Bounds Integer'.
-- These are only enforced at decoding time, not at encoding-time.
--
-- NOTE: Decoding 'Integer's is dangerous so decoding may fail for enormous numbers.
-- API NOTE: This is separate from 'NumberCodec' so that we can produce
-- more precise documentation about whether the numbers are integers.
IntegerCodec ::
(Coercible a Integer, Coercible b Integer) =>
-- | Name of the @integer@, for error messages and documentation.
Maybe Text ->
-- | Bounds for the integer, these are checked and documented
Bounds Integer ->
ValueCodec a b
-- | Encode 'Scientific' to a @number@ value, and decode a @number@ value as a 'Scientific'.
--
-- The number has 'Bounds Scientific'.
-- These are only enforced at decoding time, not at encoding-time.
--
-- NOTE: We use 'Scientific' here because that is what aeson uses.
NumberCodec ::
(Coercible a Scientific, Coercible b Scientific) =>
-- | Name of the @number@, for error messages and documentation.
Maybe Text ->
-- | Bounds for the number, these are checked and documented
Bounds Scientific ->
ValueCodec a b
-- | Encode a 'HashMap', and decode any 'HashMap'.
HashMapCodec ::
(Eq k, Hashable k, FromJSONKey k, ToJSONKey k, Coercible a (HashMap k v), Coercible b (HashMap k v)) =>
JSONCodec v ->
ValueCodec a b
-- | Encode a 'Map', and decode any 'Map'.
MapCodec ::
(Ord k, FromJSONKey k, ToJSONKey k, Coercible a (Map k v), Coercible b (Map k v)) =>
JSONCodec v ->
ValueCodec a b
-- | Encode a 'JSON.Value', and decode any 'JSON.Value'.
ValueCodec ::
(Coercible JSON.Value a, Coercible JSON.Value b) =>
ValueCodec a b
-- | Encode a 'Vector' of values as an @array@ value, and decode an @array@ value as a 'Vector' of values.
ArrayOfCodec ::
(Coercible a (Vector input), Coercible b (Vector output)) =>
-- | Name of the @array@, for error messages and documentation.
Maybe Text ->
ValueCodec input output ->
ValueCodec a b
-- | Encode a value as a an @object@ value using the given 'ObjectCodec', and decode an @object@ value as a value using the given 'ObjectCodec'.
ObjectOfCodec ::
-- | Name of the @object@, for error messages and documentation.
Maybe Text ->
ObjectCodec input output ->
ValueCodec input output
-- | Match a given value using its 'Eq' instance during decoding, and encode exactly that value during encoding.
EqCodec ::
(Show value, Eq value, Coercible a value, Coercible b value) =>
-- | Value to match
value ->
-- | Codec for the value
JSONCodec value ->
ValueCodec a b
-- | Map a codec in both directions.
--
-- This is not strictly dimap, because the decoding function is allowed to fail,
-- but we can implement dimap using this function by using a decoding function that does not fail.
-- Otherwise we would have to have another constructor here.
BimapCodec ::
(oldOutput -> Either String newOutput) ->
(newInput -> oldInput) ->
Codec context oldInput oldOutput ->
Codec context newInput newOutput
-- | Encode/Decode an 'Either' value
--
-- During encoding, encode either value of an 'Either' using their own codec.
-- During decoding, try to parse the 'Left' side first, and the 'Right' side only when that fails.
--
--
-- This codec is used to implement choice.
--
-- Note that this codec works for both values and objects.
-- However: due to the complex nature of documentation, the documentation may
-- not be as good as you would hope when you use this codec.
-- In particular, you should prefer using it for values rather than objects,
-- because those docs are easier to generate.
EitherCodec ::
(Coercible a (Either input1 input2), Coercible b (Either output1 output2)) =>
-- | What type of union we encode and decode
!Union ->
-- | Codec for the 'Left' side
Codec context input1 output1 ->
-- | Codec for the 'Right' side
Codec context input2 output2 ->
Codec context a b
-- | Encode/decode a discriminated union of objects
--
-- The type of object being encoded/decoded is discriminated by
-- a designated "discriminator" property on the object which takes a string value.
--
-- When encoding, the provided function is applied to the input to obtain a new encoder
-- for the input. The function 'mapToEncoder' is provided to assist with building these
-- encoders.
--
-- When decoding, the value of the discriminator property is looked up in the `HashMap`
-- to obtain a decoder for the output. The function `mapToDecoder' is provided
-- to assist with building these decoders. See examples in 'Usage.hs'.
--
-- The 'HashMap' is also used to generate schemas for the type.
-- In particular, for OpenAPI 3, it will generate a schema with a 'discriminator', as defined
-- by https://swagger.io/docs/specification/data-models/inheritance-and-polymorphism/
DiscriminatedUnionCodec ::
-- | propertyName to use for discrimination
Text ->
-- | how to encode the input
(input -> (Discriminator, ObjectCodec input ())) ->
-- | how to decode the output
-- The 'Text' field is the name to use for the object schema.
HashMap Discriminator (Text, ObjectCodec Void output) ->
ObjectCodec input output
-- | A comment codec
--
-- This is used to add implementation-irrelevant but human-relevant information.
CommentCodec ::
-- | Comment
Text ->
ValueCodec input output ->
ValueCodec input output
-- | A reference codec
--
-- This is used for naming a codec, so that recursive codecs can have a finite schema.
--
-- It doesn't _need_ to be recursive, and you may just have wanted to name the codec, but it _may_ be recursive from here downward.
--
-- This value MUST be lazy, otherwise we can never define recursive codecs.
ReferenceCodec ::
-- | Name
Text ->
~(ValueCodec input output) ->
ValueCodec input output
RequiredKeyCodec ::
-- | Key
Text ->
-- | Codec for the value
ValueCodec input output ->
-- | Documentation
Maybe Text ->
ObjectCodec input output
OptionalKeyCodec ::
(Coercible a (Maybe input), Coercible b (Maybe output)) =>
-- | Key
Text ->
-- | Codec for the value
ValueCodec input output ->
-- | Documentation
Maybe Text ->
ObjectCodec a b
OptionalKeyWithDefaultCodec ::
(Coercible b value) =>
-- | Key
Text ->
-- | Codec for the value
ValueCodec value value ->
-- | Default value
value ->
-- | Documentation
Maybe Text ->
ObjectCodec value b
OptionalKeyWithOmittedDefaultCodec ::
(Eq value, Coercible a value, Coercible b value) =>
-- | Key
Text ->
-- | Codec for the value
ValueCodec value value ->
-- | Default value
value ->
-- | Documentation
Maybe Text ->
ObjectCodec a b
-- | To implement 'pure' from 'Applicative'.
--
-- Pure is not available for non-object codecs because there is no 'mempty' for 'JSON.Value', which we would need during encoding.
PureCodec ::
output ->
-- |
--
-- We have to use 'void' instead of 'Void' here to be able to implement 'Applicative'.
ObjectCodec void output
-- | To implement '<*>' from 'Applicative'.
--
-- Ap is not available for non-object codecs because we cannot combine ('mappend') two encoded 'JSON.Value's
ApCodec ::
ObjectCodec input (output -> newOutput) ->
ObjectCodec input output ->
ObjectCodec input newOutput
data Bounds a = Bounds
{ -- | Lower bound, inclusive
boundsLower :: !(Maybe a),
-- Upper bound, inclusive
boundsUpper :: !(Maybe a)
}
deriving (Show, Eq, Ord, Generic, Functor)
instance (Validity a) => Validity (Bounds a)
emptyBounds :: Bounds a
emptyBounds = Bounds Nothing Nothing
boundedBounds :: (Bounded a) => Bounds a
boundedBounds =
Bounds
{ boundsLower = Just minBound,
boundsUpper = Just maxBound
}
-- | Check if a number falls within given 'NumberBounds'.
checkBounds :: (Show a, Ord a) => Bounds a -> a -> Either String a
checkBounds Bounds {..} s =
case boundsLower of
Just lo | s < lo -> Left $ unwords ["Number", show s, "is smaller than the lower bound", show lo]
_ -> case boundsUpper of
Just hi | s > hi -> Left $ unwords ["Number", show s, "is bigger than the upper bound", show hi]
_ -> Right s
data IntegerBoundsSymbolic
= BitUInt !Word8 -- w bit unsigned int
| BitSInt !Word8 -- w bit signed int
| OtherIntegerBounds !(Maybe IntegerSymbolic) !(Maybe IntegerSymbolic)
guessIntegerBoundsSymbolic :: Bounds Integer -> IntegerBoundsSymbolic
guessIntegerBoundsSymbolic Bounds {..} =
case (guessIntegerSymbolic <$> boundsLower, guessIntegerSymbolic <$> boundsUpper) of
(Just Zero, Just (PowerOf2MinusOne w)) -> BitUInt w
(Just (MinusPowerOf2 w1), Just (PowerOf2MinusOne w2)) | w1 == w2 -> BitSInt (succ w1)
(l, u) -> OtherIntegerBounds l u
data IntegerSymbolic
= Zero
| PowerOf2 !Word8 -- 2^w
| PowerOf2MinusOne !Word8 -- 2^w -1
| MinusPowerOf2 !Word8 -- - 2^w
| MinusPowerOf2MinusOne !Word8 -- - (2^w -1)
| OtherInteger !Integer
guessIntegerSymbolic :: Integer -> IntegerSymbolic
guessIntegerSymbolic i =
let log2Rounded :: Word8
log2Rounded = round (logBase 2 (fromInteger (abs i)) :: Double)
guess :: Integer
guess = 2 ^ log2Rounded
in if
| i == 0 -> Zero
| guess == i -> PowerOf2 log2Rounded
| (guess - 1) == i -> PowerOf2MinusOne log2Rounded
| -guess == i -> MinusPowerOf2 log2Rounded
| -(guess - 1) == i -> MinusPowerOf2MinusOne log2Rounded
| otherwise -> OtherInteger i
-- | What type of union the encoding uses
data Union
= -- | Not disjoint, see 'possiblyJointEitherCodec'.
PossiblyJointUnion
| -- | Disjoint, see 'disjointEitherCodec'.
DisjointUnion
deriving (Show, Eq, Generic)
instance Validity Union
-- | A codec within the 'JSON.Value' context.
--
-- An 'ValueCodec' can be used to turn a Haskell value into a 'JSON.Value' or to parse a 'JSON.Value' into a haskell value.
--
-- This cannot be used in certain places where 'ObjectCodec' could be used, and vice versa.
type ValueCodec = Codec JSON.Value
-- | A codec within the 'JSON.Object' context.
--
-- An 'Object' can be used to turn a Haskell value into a 'JSON.Object' or to parse a 'JSON.Object' into a haskell value.
--
-- This cannot be used in certain places where 'ValueCodec' could be used, and vice versa.
type ObjectCodec = Codec JSON.Object
-- | A completed autodocodec for parsing and rendering a 'JSON.Value'.
--
-- You can use a value of this type to get everything else for free:
--
-- * Encode values to JSON using 'toJSONViaCodec' or 'toJSONVia'
-- * Decode values from JSON using 'parseJSONViaCodec' or 'parseJSONVia'
-- * Produce a JSON Schema using 'jsonSchemaViaCodec' or 'jsonSchemaVia' from @autodocodec-schema@
-- * Encode to and decode from Yaml using @autodocodec-yaml@
-- * Produce a human-readible YAML schema using @renderColouredSchemaViaCodec@ from @autodocodec-yaml@
-- * Produce a Swagger2 schema using @autodocodec-swagger2@
-- * Produce a OpenAPI3 schema using @autodocodec-openapi3@
type JSONCodec a = ValueCodec a a
-- | A completed autodocodec for parsing and rendering a 'JSON.Object'.
type JSONObjectCodec a = ObjectCodec a a
-- | Show a codec to a human.
--
-- This function exists for codec debugging.
-- It omits any unshowable information from the output.
showCodecABit :: Codec context input output -> String
showCodecABit = ($ "") . (`evalState` S.empty) . go 0
where
go :: Int -> Codec context input output -> State (Set Text) ShowS
go d = \case
NullCodec -> pure $ showString "NullCodec"
BoolCodec mName -> pure $ showParen (d > 10) $ showString "BoolCodec " . showsPrec 11 mName
StringCodec mName -> pure $ showParen (d > 10) $ showString "StringCodec " . showsPrec 11 mName
IntegerCodec mName mbs -> pure $ showParen (d > 10) $ showString "IntegerCodec " . showsPrec 11 mName . showString " " . showsPrec 11 mbs
NumberCodec mName mbs -> pure $ showParen (d > 10) $ showString "NumberCodec " . showsPrec 11 mName . showString " " . showsPrec 11 mbs
ArrayOfCodec mName c -> (\s -> showParen (d > 10) $ showString "ArrayOfCodec " . showsPrec 11 mName . showString " " . s) <$> go 11 c
ObjectOfCodec mName oc -> (\s -> showParen (d > 10) $ showString "ObjectOfCodec " . showsPrec 11 mName . showString " " . s) <$> go 11 oc
ValueCodec -> pure $ showString "ValueCodec"
MapCodec c -> (\s -> showParen (d > 10) $ showString "MapCodec" . s) <$> go 11 c
HashMapCodec c -> (\s -> showParen (d > 10) $ showString "HashMapCodec" . s) <$> go 11 c
EqCodec value c -> (\s -> showParen (d > 10) $ showString "EqCodec " . showsPrec 11 value . showString " " . s) <$> go 11 c
BimapCodec _ _ c -> (\s -> showParen (d > 10) $ showString "BimapCodec _ _ " . s) <$> go 11 c
EitherCodec u c1 c2 -> (\s1 s2 -> showParen (d > 10) $ showString "EitherCodec " . showsPrec 11 u . showString " " . s1 . showString " " . s2) <$> go 11 c1 <*> go 11 c2
DiscriminatedUnionCodec propertyName _ mapping -> do
cs <- traverse (\(n, (_, c)) -> (\s -> showParen True $ shows n . showString ", " . s) <$> go 11 c) $ HashMap.toList mapping
let csList = showString "[" . foldr (.) id (intersperse (showString ", ") cs) . showString "]"
pure $ showParen (d > 10) $ showString "DiscriminatedUnionCodec " . showsPrec 11 propertyName . showString " _ " . csList
CommentCodec comment c -> (\s -> showParen (d > 10) $ showString "CommentCodec " . showsPrec 11 comment . showString " " . s) <$> go 11 c
ReferenceCodec name c -> do
alreadySeen <- gets (S.member name)
if alreadySeen
then pure $ showParen (d > 10) $ showString "ReferenceCodec " . showsPrec 11 name
else do
modify (S.insert name)
s <- go 11 c
pure $ showParen (d > 10) $ showString "ReferenceCodec " . showsPrec 11 name . showString " " . s
RequiredKeyCodec k c mdoc -> (\s -> showParen (d > 10) $ showString "RequiredKeyCodec " . showsPrec 11 k . showString " " . showsPrec 11 mdoc . showString " " . s) <$> go 11 c
OptionalKeyCodec k c mdoc -> (\s -> showParen (d > 10) $ showString "OptionalKeyCodec " . showsPrec 11 k . showString " " . showsPrec 11 mdoc . showString " " . s) <$> go 11 c
OptionalKeyWithDefaultCodec k c _ mdoc -> (\s -> showParen (d > 10) $ showString "OptionalKeyWithDefaultCodec " . showsPrec 11 k . showString " " . s . showString " _ " . showsPrec 11 mdoc) <$> go 11 c
OptionalKeyWithOmittedDefaultCodec k c _ mdoc -> (\s -> showParen (d > 10) $ showString "OptionalKeyWithOmittedDefaultCodec " . showsPrec 11 k . showString " " . s . showString " _ " . showsPrec 11 mdoc) <$> go 11 c
PureCodec _ -> pure $ showString "PureCodec _"
ApCodec oc1 oc2 -> (\s1 s2 -> showParen (d > 10) $ showString "ApCodec " . s1 . showString " " . s2) <$> go 11 oc1 <*> go 11 oc2
-- | Map the output part of a codec
--
-- You can use this function if you only need to map the parsing-side of a codec.
-- This function is probably only useful if the function you map does not change the codec type.
--
-- WARNING: This can be used to produce a codec that does not roundtrip.
--
-- >>> JSON.parseMaybe (parseJSONVia (rmapCodec (*2) codec)) (Number 5) :: Maybe Int
-- Just 10
rmapCodec ::
(oldOutput -> newOutput) ->
Codec context input oldOutput ->
Codec context input newOutput
rmapCodec f = dimapCodec f id
instance Functor (Codec context input) where
fmap = rmapCodec
-- | Map the input part of a codec
--
-- You can use this function if you only need to map the rendering-side of a codec.
-- This function is probably only useful if the function you map does not change the codec type.
--
-- WARNING: This can be used to produce a codec that does not roundtrip.
--
-- >>> toJSONVia (lmapCodec (*2) (codec :: JSONCodec Int)) 5
-- Number 10.0
lmapCodec ::
(newInput -> oldInput) ->
Codec context oldInput output ->
Codec context newInput output
lmapCodec g = dimapCodec id g
-- | Infix version of 'lmapCodec'
--
-- Use this function to supply the rendering side of a codec.
--
-- > (.=) = flip lmapCodec
--
-- === Example usage
--
-- > data Example = Example
-- > { exampleText :: !Text,
-- > exampleBool :: !Bool
-- > }
-- > instance HasCodec Example where
-- > codec =
-- > object "Example" $
-- > Example
-- > <$> requiredField "text" .= exampleText
-- > <*> requiredField "bool" .= exampleBool
(.=) :: ObjectCodec oldInput output -> (newInput -> oldInput) -> ObjectCodec newInput output
(.=) = flip lmapCodec
-- | Map both directions of a codec
--
-- You can use this function to change the type of a codec as long as the two
-- functions are inverses.
--
-- === 'HasCodec' instance for newtypes
--
-- A good use-case is implementing 'HasCodec' for newtypes:
--
-- > newtype MyInt = MyInt { unMyInt :: Int }
-- > instance HasCodec MyInt where
-- > codec = dimapCodec MyInt unMyInt codec
dimapCodec ::
-- | Function to make __to__ the new type
(oldOutput -> newOutput) ->
-- | Function to make __from__ the new type
(newInput -> oldInput) ->
-- | Codec for the old type
Codec context oldInput oldOutput ->
Codec context newInput newOutput
dimapCodec f g = bimapCodec (Right . f) g
-- | Produce a value without parsing any part of an 'Object'.
--
-- This function exists to implement @Applicative (ObjectCodec input)@.
--
--
-- ==== API Note
--
-- This is a forward-compatible version of 'PureCodec'.
--
-- > pureCodec = PureCodec
pureCodec :: output -> ObjectCodec input output
pureCodec = PureCodec
-- | Sequentially apply two codecs that parse part of an 'Object'.
--
-- This function exists to implement @Applicative (ObjectCodec input)@.
--
--
-- ==== API Note
--
-- This is a forward-compatible version of 'ApCodec'.
--
-- > apCodec = ApCodec
apCodec :: ObjectCodec input (output -> newOutput) -> ObjectCodec input output -> ObjectCodec input newOutput
apCodec = ApCodec
instance Applicative (ObjectCodec input) where
pure = pureCodec
(<*>) = apCodec
-- | Maybe codec
--
-- This can be used to also allow @null@ during decoding of a 'Maybe' value.
--
-- During decoding, also accept a @null@ value as 'Nothing'.
-- During encoding, encode as usual.
--
--
-- === Example usage
--
-- >>> toJSONVia (maybeCodec codec) (Just 'a')
-- String "a"
-- >>> toJSONVia (maybeCodec codec) (Nothing :: Maybe Char)
-- Null
maybeCodec :: ValueCodec input output -> ValueCodec (Maybe input) (Maybe output)
maybeCodec =
-- We must use 'possiblyJointEitherCodec' here, otherwise a codec for (Maybe
-- (Maybe Text)) will fail to parse.
dimapCodec f g
. possiblyJointEitherCodec nullCodec
where
f = \case
Left () -> Nothing
Right r -> Just r
g = \case
Nothing -> Left ()
Just r -> Right r
-- | Either codec
--
-- During encoding, parse a value according to either codec.
-- During encoding, use the corresponding codec to encode either value.
--
-- === 'HasCodec' instance for sum types
--
-- To write a 'HasCodec' instance for sum types, you will need to decide whether encoding is disjoint or not.
-- The default, so also the implementation of this function, is 'possiblyJointEitherCodec', but you may want to use 'disjointEitherCodec' instead.
--
-- Ask yourself: Can the encoding of a 'Left' value be decoded as 'Right' value (or vice versa)?
--
-- @Yes ->@ use 'possiblyJointEitherCodec'.
--
-- @No ->@ use 'disjointEitherCodec'.
--
--
-- === Example usage
--
-- >>> let c = eitherCodec codec codec :: JSONCodec (Either Int String)
-- >>> toJSONVia c (Left 5)
-- Number 5.0
-- >>> toJSONVia c (Right "hello")
-- String "hello"
-- >>> JSON.parseMaybe (parseJSONVia c) (String "world") :: Maybe (Either Int String)
-- Just (Right "world")
--
--
-- ==== API Note
--
-- This is a forward-compatible version of 'possiblyJointEitherCodec'.
--
-- > eitherCodec = possiblyJointEitherCodec
eitherCodec ::
Codec context input1 output1 ->
Codec context input2 output2 ->
Codec context (Either input1 input2) (Either output1 output2)
eitherCodec = possiblyJointEitherCodec
-- | Possibly joint either codec
--
-- During encoding, parse a value according to either codec.
-- During encoding, use the corresponding codec to encode either value.
--
-- This codec is for the case in which parsing must be disjoint.
--
-- === 'HasCodec' instance for sum types with an encoding that is definitely disjoint.
--
-- The 'eitherCodec' can be used to implement 'HasCodec' instances for sum types
-- for which the encoding is definitely disjoint.
--
-- >>> data War = WorldWar Word8 | OtherWar Text deriving (Show, Eq)
-- >>> :{
-- instance HasCodec War where
-- codec =
-- dimapCodec f g $
-- disjointEitherCodec
-- (codec :: JSONCodec Word8)
-- (codec :: JSONCodec Text)
-- where
-- f = \case
-- Left w -> WorldWar w
-- Right t -> OtherWar t
-- g = \case
-- WorldWar w -> Left w
-- OtherWar t -> Right t
-- :}
--
-- Note that this incoding is indeed disjoint because an encoded 'String' can
-- never be parsed as an 'Word8' and vice versa.
--
-- >>> toJSONViaCodec (WorldWar 2)
-- Number 2.0
-- >>> toJSONViaCodec (OtherWar "OnDrugs")
-- String "OnDrugs"
-- >>> JSON.parseMaybe parseJSONViaCodec (String "of the roses") :: Maybe War
-- Just (OtherWar "of the roses")
--
--
-- === WARNING
--
-- If it turns out that the encoding of a value is not disjoint, decoding may
-- fail and documentation may be wrong.
--
-- >>> let c = disjointEitherCodec (codec :: JSONCodec Int) (codec :: JSONCodec Int)
-- >>> JSON.parseMaybe (parseJSONVia c) (Number 5) :: Maybe (Either Int Int)
-- Nothing
--
-- Encoding still works as expected, however:
--
-- >>> toJSONVia c (Left 5)
-- Number 5.0
-- >>> toJSONVia c (Right 6)
-- Number 6.0
--
--
-- === Example usage
--
-- >>> toJSONVia (disjointEitherCodec (codec :: JSONCodec Int) (codec :: JSONCodec String)) (Left 5)
-- Number 5.0
-- >>> toJSONVia (disjointEitherCodec (codec :: JSONCodec Int) (codec :: JSONCodec String)) (Right "hello")
-- String "hello"
--
--
-- ==== API Note
--
-- This is a forward-compatible version of 'EitherCodec DisjointUnion'.
--
-- > disjointEitherCodec = EitherCodec DisjointUnion
disjointEitherCodec ::
Codec context input1 output1 ->
Codec context input2 output2 ->
Codec context (Either input1 input2) (Either output1 output2)
disjointEitherCodec = EitherCodec DisjointUnion
-- | Possibly joint either codec
--
-- During encoding, parse a value according to either codec.
-- During encoding, use the corresponding codec to encode either value.
--
-- This codec is for the case in which parsing may not be disjoint.
--
-- === 'HasCodec' instance for sum types with an encoding that is not disjoint.
--
-- The 'eitherCodec' can be used to implement 'HasCodec' instances for sum types.
-- If you just have two codecs that you want to try in order, while parsing, you can do this:
--
-- >>> :{
-- data Ainur
-- = Valar Text Text
-- | Maiar Text
-- deriving (Show, Eq)
-- :}
--
-- >>> :{
-- instance HasCodec Ainur where
-- codec =
-- dimapCodec f g $
-- possiblyJointEitherCodec
-- (object "Valar" $
-- (,)
-- <$> requiredField "domain" "Domain which the Valar rules over" .= fst
-- <*> requiredField "name" "Name of the Valar" .= snd)
-- (object "Maiar" $ requiredField "name" "Name of the Maiar")
-- where
-- f = \case
-- Left (domain, name) -> Valar domain name
-- Right name -> Maiar name
-- g = \case
-- Valar domain name -> Left (domain, name)
-- Maiar name -> Right name
-- :}
--
-- Note that this encoding is indeed not disjoint, because a @Valar@ object can
-- parse as a @Maiar@ value.
--
-- >>> toJSONViaCodec (Valar "Stars" "Varda")
-- Object (fromList [("domain",String "Stars"),("name",String "Varda")])
-- >>> toJSONViaCodec (Maiar "Sauron")
-- Object (fromList [("name",String "Sauron")])
-- >>> JSON.parseMaybe parseJSONViaCodec (Object (Compat.fromList [("name",String "Olorin")])) :: Maybe Ainur
-- Just (Maiar "Olorin")
--
--
-- === WARNING
--
-- The order of the codecs in a 'possiblyJointEitherCodec' matters.
--
-- In the above example, decoding works as expected because the @Valar@ case is parsed first.
-- If the @Maiar@ case were first in the 'possiblyJointEitherCodec', then
-- @Valar@ could never be parsed.
--
--
-- ==== API Note
--
-- This is a forward-compatible version of 'EitherCodec PossiblyJointUnion'.
--
-- > possiblyJointEitherCodec = EitherCodec PossiblyJointUnion
possiblyJointEitherCodec ::
Codec context input1 output1 ->
Codec context input2 output2 ->
Codec context (Either input1 input2) (Either output1 output2)
possiblyJointEitherCodec = EitherCodec PossiblyJointUnion
-- | Discriminator value used in 'DiscriminatedUnionCodec'
type Discriminator = Text
-- | Wrap up a value of type 'b' with its codec to produce
-- and encoder for 'a's that ignores its input and instead encodes
-- the value 'b'.
-- This is useful for building 'discriminatedUnionCodec's.
mapToEncoder :: b -> Codec context b any -> Codec context a ()
mapToEncoder b = dimapCodec (const ()) (const b)
-- | Map a codec for decoding 'b's into a decoder for 'a's.
-- This is useful for building 'discriminatedUnionCodec's.
mapToDecoder :: (b -> a) -> Codec context any b -> Codec context Void a
mapToDecoder f = dimapCodec f absurd
-- | Encode/decode a discriminated union of objects
--
-- The type of object being encoded/decoded is discriminated by
-- a designated "discriminator" property on the object which takes a string value.
--
-- When encoding, the provided function is applied to the input to obtain a new encoder
-- for the input. The function 'mapToEncoder' is provided to assist with building these
-- encoders. See examples in 'Usage.hs'.
--
-- When decoding, the value of the discriminator property is looked up in the `HashMap`
-- to obtain a decoder for the output. The function `mapToDecoder' is provided
-- to assist with building these decoders. See examples in 'Usage.hs'.
--
-- The 'HashMap' is also used to generate schemas for the type.
-- In particular, for OpenAPI 3, it will generate a schema with a 'discriminator', as defined
-- by https://swagger.io/docs/specification/data-models/inheritance-and-polymorphism/
--
--
-- ==== API Note
--
-- This is a forward-compatible version of 'DiscriminatedUnionCodec'.
--
-- > discriminatedUnionCodec = 'DiscriminatedUnionCodec'
discriminatedUnionCodec ::
-- | propertyName
Text ->
-- | how to encode the input
--
-- Use 'mapToEncoder' to produce the 'ObjectCodec's.
(input -> (Discriminator, ObjectCodec input ())) ->
-- | how to decode the output
--
-- The 'Text' field is the name to use for the object schema.
--
-- Use 'mapToDecoder' to produce the 'ObjectCodec's.
HashMap Discriminator (Text, ObjectCodec Void output) ->
ObjectCodec input output
discriminatedUnionCodec = DiscriminatedUnionCodec
-- | Map a codec's input and output types.
--
-- This function allows you to have the parsing fail in a new way.
--
-- If you use this function, then you will most likely want to add documentation about how not every value that the schema specifies will be accepted.
--
-- This function is like 'BimapCodec' except it also combines one level of a nested 'BimapCodec's.
--
--
-- === Example usage
--
-- logLevelCodec :: JSONCodec LogLevel
-- logLevelCodec = bimapCodec parseLogLevel renderLogLevel codec <?> "Valid values include DEBUG, INFO, WARNING, ERROR."
bimapCodec ::
(oldOutput -> Either String newOutput) ->
(newInput -> oldInput) ->
Codec context oldInput oldOutput ->
Codec context newInput newOutput
bimapCodec f g =
-- We distinguish between a 'BimapCodec' and a non-'BimapCodec' just so that
-- we don't introduce additional layers that we can already combine anyway.
\case
BimapCodec f' g' c -> BimapCodec (f' >=> f) (g' . g) c
c -> BimapCodec f g c
-- | Vector codec
--
-- Build a codec for vectors of values from a codec for a single value.
--
--
-- === Example usage
--
-- >>> toJSONVia (vectorCodec codec) (Vector.fromList ['a','b'])
-- Array [String "a",String "b"]
--
--
-- ==== API Note
--
-- This is a forward-compatible version of 'ArrayOfCodec' without a name.
--
-- > vectorCodec = ArrayOfCodec Nothing
vectorCodec :: ValueCodec input output -> ValueCodec (Vector input) (Vector output)
vectorCodec = ArrayOfCodec Nothing
-- | List codec
--
-- Build a codec for lists of values from a codec for a single value.
--
--
-- === Example usage
--
-- >>> toJSONVia (listCodec codec) ['a','b']
-- Array [String "a",String "b"]
--
--
-- ==== API Note
--
-- This is the list version of 'vectorCodec'.
listCodec :: ValueCodec input output -> ValueCodec [input] [output]
listCodec = dimapCodec V.toList V.fromList . vectorCodec
-- Some restricted constructors
optionalKeyCodec :: Text -> ValueCodec input output -> Maybe Text -> ObjectCodec (Maybe input) (Maybe output)
optionalKeyCodec = OptionalKeyCodec
optionalKeyWithDefaultCodec ::
-- | Key
Text ->
-- | Codec for the value
ValueCodec value value ->
-- | Default value
value ->
-- | Documentation
Maybe Text ->
ObjectCodec value value
optionalKeyWithDefaultCodec = OptionalKeyWithDefaultCodec
-- | Build a codec for nonempty lists of values from a codec for a single value.
--
--
-- === Example usage
--
-- >>> toJSONVia (nonEmptyCodec codec) ('a' :| ['b'])
-- Array [String "a",String "b"]
--
--
-- ==== API Note
--
-- This is the non-empty list version of 'vectorCodec'.
nonEmptyCodec :: ValueCodec input output -> ValueCodec (NonEmpty input) (NonEmpty output)
nonEmptyCodec = bimapCodec parseNonEmptyList NE.toList . listCodec
where
parseNonEmptyList l = case NE.nonEmpty l of
Nothing -> Left "Expected a nonempty list, but got an empty list."
Just ne -> Right ne
-- | Single or list codec
--
-- This codec behaves like 'listCodec', except the values may also be
-- simplified as a single value.
--
-- During parsing, a single element may be parsed as the list of just that element.
-- During rendering, a list with only one element will be rendered as just that element.
--
--
-- === Example usage
--
-- >>> let c = singleOrListCodec codec :: JSONCodec [Int]
-- >>> toJSONVia c [5]
-- Number 5.0
-- >>> toJSONVia c [5,6]
-- Array [Number 5.0,Number 6.0]
-- >>> JSON.parseMaybe (parseJSONVia c) (Number 5) :: Maybe [Int]
-- Just [5]
-- >>> JSON.parseMaybe (parseJSONVia c) (Array [Number 5, Number 6]) :: Maybe [Int]
-- Just [5,6]
--
--
-- === WARNING
--
-- If you use nested lists, for example when the given value codec is also a
-- 'listCodec', you may get in trouble with ambiguities during parsing.
singleOrListCodec :: ValueCodec input output -> ValueCodec [input] [output]
singleOrListCodec c = dimapCodec f g $ eitherCodec c $ listCodec c
where
f = \case
Left v -> [v]
Right vs -> vs
g = \case
[v] -> Left v
vs -> Right vs
-- | Single or nonempty list codec
--
-- This codec behaves like 'nonEmptyCodec', except the values may also be
-- simplified as a single value.
--
-- During parsing, a single element may be parsed as the list of just that element.
-- During rendering, a list with only one element will be rendered as just that element.
--
--
-- === Example usage
--
-- >>> let c = singleOrNonEmptyCodec codec :: JSONCodec (NonEmpty Int)
-- >>> toJSONVia c (5 :| [])
-- Number 5.0
-- >>> toJSONVia c (5 :| [6])
-- Array [Number 5.0,Number 6.0]
-- >>> JSON.parseMaybe (parseJSONVia c) (Number 5) :: Maybe (NonEmpty Int)
-- Just (5 :| [])
-- >>> JSON.parseMaybe (parseJSONVia c) (Array [Number 5, Number 6]) :: Maybe (NonEmpty Int)
-- Just (5 :| [6])
--
--
-- === WARNING
--
-- If you use nested lists, for example when the given value codec is also a
-- 'nonEmptyCodec', you may get in trouble with ambiguities during parsing.
--
-- ==== API Note
--
-- This is a nonempty version of 'singleOrListCodec'.
singleOrNonEmptyCodec :: ValueCodec input output -> ValueCodec (NonEmpty input) (NonEmpty output)
singleOrNonEmptyCodec c = dimapCodec f g $ eitherCodec c $ nonEmptyCodec c
where
f = \case
Left v -> v :| []
Right vs -> vs
g = \case
v :| [] -> Left v
vs -> Right vs
-- | A required field
--
-- During decoding, the field must be in the object.
--
-- During encoding, the field will always be in the object.
requiredFieldWith ::
-- | Key
Text ->
-- | Codec for the value
ValueCodec input output ->
-- | Documentation
Text ->
ObjectCodec input output
requiredFieldWith key c doc = RequiredKeyCodec key c (Just doc)
-- | Like 'requiredFieldWith', but without documentation.
requiredFieldWith' ::
-- | Key
Text ->
-- | Codec for the value
ValueCodec input output ->
ObjectCodec input output
requiredFieldWith' key c = RequiredKeyCodec key c Nothing
-- | An optional field
--
-- During decoding, the field may be in the object. 'Nothing' will be parsed otherwise.
--
-- During encoding, the field will be omitted from the object if it is 'Nothing'.
optionalFieldWith ::
-- | Key
Text ->
-- | Codec for the value
ValueCodec input output ->
-- | Documentation
Text ->
ObjectCodec (Maybe input) (Maybe output)
optionalFieldWith key c doc = OptionalKeyCodec key c (Just doc)
-- | Like 'optionalFieldWith', but without documentation.
optionalFieldWith' ::
-- | Key
Text ->
-- | Codec for the value
ValueCodec input output ->
ObjectCodec (Maybe input) (Maybe output)
optionalFieldWith' key c = OptionalKeyCodec key c Nothing
-- | An optional field with default value
--
-- During decoding, the field may be in the object. The default value will be parsed otherwise.
--
-- During encoding, the field will always be in the object. The default value is ignored.
--
-- The shown version of the default value will appear in the documentation.
optionalFieldWithDefaultWith ::
-- | Key
Text ->
-- | Codec for the value
JSONCodec output ->
-- | Default value
output ->
-- | Documentation
Text ->
ObjectCodec output output
optionalFieldWithDefaultWith key c defaultValue doc = OptionalKeyWithDefaultCodec key c defaultValue (Just doc)
-- | Like 'optionalFieldWithDefaultWith', but without documentation.
optionalFieldWithDefaultWith' ::
-- | Key
Text ->
-- | Codec for the value
JSONCodec output ->
-- | Default value
output ->
ObjectCodec output output
optionalFieldWithDefaultWith' key c defaultValue = OptionalKeyWithDefaultCodec key c defaultValue Nothing
-- | Like 'optionalFieldWithDefaultWith', but also interpret @null@ as the
-- default value.
optionalFieldOrNullWithDefaultWith ::
(Eq output) =>
-- | Key
Text ->
-- | Codec for the value
JSONCodec output ->
-- | Default value
output ->
-- | Documentation
Text ->
ObjectCodec output output
optionalFieldOrNullWithDefaultWith key c defaultValue doc = dimapCodec f g $ optionalFieldWithDefaultWith key (maybeCodec c) (Just defaultValue) doc
where
f = \case
Just v -> v
Nothing -> defaultValue
g v = if v == defaultValue then Nothing else Just v
-- | Like 'optionalFieldOrNullWithDefaultWith', but without documentation.
optionalFieldOrNullWithDefaultWith' ::
(Eq output) =>
-- | Key
Text ->
-- | Codec for the value
JSONCodec output ->
-- | Default value
output ->
ObjectCodec output output
optionalFieldOrNullWithDefaultWith' key c defaultValue = dimapCodec f g $ optionalFieldWithDefaultWith' key (maybeCodec c) (Just defaultValue)
where
f = \case
Just v -> v
Nothing -> defaultValue
g v = if v == defaultValue then Nothing else Just v
-- | An optional field with default value that can be omitted when encoding
--
-- During decoding, the field may be in the object. The default value will be parsed otherwise.
--
-- During encoding, the field will be omitted from the object if it is equal to the default value.
--
-- The shown version of the default value will appear in the documentation.
optionalFieldWithOmittedDefaultWith ::
(Eq output) =>
-- | Key
Text ->
-- | Codec for the value
JSONCodec output ->
-- | Default value
output ->
-- | Documentation
Text ->
ObjectCodec output output
optionalFieldWithOmittedDefaultWith key c defaultValue doc = OptionalKeyWithOmittedDefaultCodec key c defaultValue (Just doc)
-- | Like 'optionalFieldWithOmittedDefaultWith', but without documentation.
optionalFieldWithOmittedDefaultWith' ::
(Eq output) =>
-- | Key
Text ->
-- | Codec for the value
JSONCodec output ->
-- | Default value
output ->
ObjectCodec output output
optionalFieldWithOmittedDefaultWith' key c defaultValue = OptionalKeyWithOmittedDefaultCodec key c defaultValue Nothing
-- | Like 'optionalFieldWithOmittedDefaultWith', but the value may also be
-- @null@ and that will be interpreted as the default value.
optionalFieldOrNullWithOmittedDefaultWith ::
(Eq output) =>
-- | Key
Text ->
-- | Codec for the value
JSONCodec output ->
-- | Default value
output ->
-- | Documentation
Text ->
ObjectCodec output output
optionalFieldOrNullWithOmittedDefaultWith key c defaultValue doc = dimapCodec f g $ optionalFieldWithOmittedDefaultWith key (maybeCodec c) (Just defaultValue) doc
where
f = \case
Just v -> v
Nothing -> defaultValue
g v = if v == defaultValue then Nothing else Just v
-- | Like 'optionalFieldWithOmittedDefaultWith'', but the value may also be
-- @null@ and that will be interpreted as the default value.
optionalFieldOrNullWithOmittedDefaultWith' ::
(Eq output) =>
-- | Key
Text ->
-- | Codec for the value
JSONCodec output ->
-- | Default value
output ->
ObjectCodec output output
optionalFieldOrNullWithOmittedDefaultWith' key c defaultValue = dimapCodec f g $ optionalFieldWithOmittedDefaultWith' key (maybeCodec c) (Just defaultValue)
where
f = \case
Just v -> v
Nothing -> defaultValue
g v = if v == defaultValue then Nothing else Just v
-- | An optional, or null, field
--
-- During decoding, the field may be in the object. 'Nothing' will be parsed if it is not.
-- If the field is @null@, then it will be parsed as 'Nothing' as well.
--
-- During encoding, the field will be omitted from the object if it is 'Nothing'.
optionalFieldOrNullWith ::
-- | Key
Text ->
-- | Codec for the value
ValueCodec input output ->
-- | Documentation
Text ->
ObjectCodec (Maybe input) (Maybe output)
optionalFieldOrNullWith key c doc = orNullHelper $ OptionalKeyCodec key (maybeCodec c) (Just doc)
-- | Like 'optionalFieldOrNullWith', but without documentation
optionalFieldOrNullWith' ::
-- | Key
Text ->
-- | Codec for the value
ValueCodec input output ->
ObjectCodec (Maybe input) (Maybe output)
optionalFieldOrNullWith' key c = orNullHelper $ OptionalKeyCodec key (maybeCodec c) Nothing
-- | Add a comment to a codec
--
-- This is an infix version of 'CommentCodec'
-- > (<?>) = flip CommentCodec
(<?>) ::
ValueCodec input output ->
-- | Comment
Text ->
ValueCodec input output
(<?>) = flip CommentCodec
-- | A version of '<?>' that lets you supply a list of lines of text instead of a single text.
--
-- This helps when you use an automated formatter that deals with lists more nicely than with multi-line strings.
(<??>) ::
ValueCodec input output ->
-- | Lines of comments
[Text] ->
ValueCodec input output
(<??>) c ls = CommentCodec (T.unlines ls) c
-- | Encode a 'HashMap', and decode any 'HashMap'.
--
--
-- ==== API Note
--
-- This is a forward-compatible version of 'HashMapCodec'.
--
-- > hashMapCodec = HashMapCodec
hashMapCodec ::
(Eq k, Hashable k, FromJSONKey k, ToJSONKey k) =>
JSONCodec v ->
JSONCodec (HashMap k v)
hashMapCodec = HashMapCodec
-- | Encode a 'Map', and decode any 'Map'.
--
--
-- ==== API Note
--
-- This is a forward-compatible version of 'MapCodec'.
--
-- > mapCodec = MapCodec
mapCodec ::
(Ord k, FromJSONKey k, ToJSONKey k) =>
JSONCodec v ->
JSONCodec (Map k v)
mapCodec = MapCodec
#if MIN_VERSION_aeson(2,0,0)
-- | Encode a 'KeyMap', and decode any 'KeyMap'.
--
-- This chooses 'hashMapCodec' or 'mapCodec' based on @ordered-keymap@ flag in aeson.
keyMapCodec ::
-- |
JSONCodec v ->
-- |
JSONCodec (KeyMap v)
keyMapCodec = case KM.coercionToMap of
-- Can coerce to Map, use
Just _ -> dimapCodec KM.fromMap KM.toMap . mapCodec
-- Cannot coerce to Map, use HashMap instead.
Nothing -> dimapCodec KM.fromHashMap KM.toHashMap . hashMapCodec
#endif
-- | Codec for a 'JSON.Value'
--
-- This is essentially your escape-hatch for when you would normally need a monad instance for 'Codec'.
-- You can build monad parsing by using 'valueCodec' together with 'bimapCodec' and supplying your own parsing function.
--
-- Note that this _does_ mean that the documentation will just say that you are parsing and rendering a value, so you may want to document the extra parsing further using '<?>'.
--
-- ==== API Note
--
-- This is a forward-compatible version of 'ValueCodec'.
--
-- > valueCodec = ValueCodec
valueCodec :: JSONCodec JSON.Value
valueCodec = ValueCodec
-- | Codec for @null@
--
--
-- === Example usage
--
-- >>> toJSONVia nullCodec ()
-- Null
-- >>> JSON.parseMaybe (parseJSONVia nullCodec) Null
-- Just ()
-- >>> JSON.parseMaybe (parseJSONVia nullCodec) (Number 5)
-- Nothing
--
--
-- ==== API Note
--
-- This is a forward-compatible version of 'NullCodec'.
--
-- > nullCodec = NullCodec
nullCodec :: JSONCodec ()
nullCodec = NullCodec
-- | Codec for boolean values
--
--
-- === Example usage
--
-- >>> toJSONVia boolCodec True
-- Bool True
--
--
-- ==== API Note
--
-- This is a forward-compatible version of 'BoolCodec' without a name.
--
-- > boolCodec = BoolCodec Nothing
boolCodec :: JSONCodec Bool
boolCodec = BoolCodec Nothing
-- | Codec for text values
--
--
-- === Example usage
--
-- >>> toJSONVia textCodec "hello"
-- String "hello"
--
--
-- ==== API Note
--
-- This is a forward-compatible version of 'StringCodec' without a name.
--
-- > textCodec = StringCodec Nothing
textCodec :: JSONCodec Text
textCodec = StringCodec Nothing
-- | Codec for 'String' values
--
--
-- === Example usage
--
-- >>> toJSONVia stringCodec "hello"
-- String "hello"
--
--
-- === WARNING
--
-- This codec uses 'T.unpack' and 'T.pack' to dimap a 'textCodec', so it __does not roundtrip__.
--
-- >>> toJSONVia stringCodec "\55296"
-- String "\65533"
--
--
-- ==== API Note
--
-- This is a 'String' version of 'textCodec'.
stringCodec :: JSONCodec String
stringCodec = dimapCodec T.unpack T.pack textCodec
-- | Codec for 'Scientific' values
--
--
-- === Example usage
--
-- >>> toJSONVia scientificCodec 5
-- Number 5.0
-- >>> JSON.parseMaybe (parseJSONVia scientificCodec) (Number 3)
-- Just 3.0
--
--
-- === WARNING
--
-- 'Scientific' is a type that is only for JSON parsing and rendering.
-- Do not use it for any calculations.
-- Instead, convert to another number type before doing any calculations.
--
-- @
-- λ> (1 / 3) :: Scientific
-- *** Exception: fromRational has been applied to a repeating decimal which can't be represented as a Scientific! It's better to avoid performing fractional operations on Scientifics and convert them to other fractional types like Double as early as possible.
-- @
--
--
-- ==== API Note
--
-- This is a forward-compatible version of 'NumberCodec' without a name.
--
-- > scientificCodec = NumberCodec Nothing Nothing
scientificCodec :: JSONCodec Scientific
scientificCodec = NumberCodec Nothing emptyBounds
-- | Codec for 'Integer' values
--
-- This codec does a bounds check for the range [-10^1024, 10^1024] it can safely parse very large numbers.
--
--
-- === Example usage
--
-- >>> toJSONVia integerCodec 5
-- Number 5.0
-- >>> toJSONVia integerCodec (-1000000000000)
-- Number (-1.0e12)
-- >>> JSON.parseMaybe (parseJSONVia integerCodec) (Number (-4.0))
-- Just (-4)
-- >>> JSON.parseMaybe (parseJSONVia integerCodec) (Number (scientific 1 100000000))
-- Nothing
--
--
-- ==== API Note
--
-- This is a forward-compatible version of 'IntegerCodec' without a name.
--
-- > scientificCodec = IntegerCodec Nothing Nothing
--
-- For a codec without this protection, see 'unsafeUnboundedIntegerCodec'.
integerCodec :: JSONCodec Integer
integerCodec = IntegerCodec Nothing emptyBounds
-- | A codec for 'Natural' values.
--
-- This codec does a bounds check for the range [0, 10^1024] it can safely parse very large numbers.
--
-- For a codec without this protection, see 'unsafeUnboundedNaturalCodec'.
--
-- === Example usage
--
-- >>> toJSONVia naturalCodec 5
-- Number 5.0
-- >>> toJSONVia naturalCodec (1000000000000)
-- Number 1.0e12
-- >>> JSON.parseMaybe (parseJSONVia naturalCodec) (Number 4.0)
-- Just 4
-- >>> JSON.parseMaybe (parseJSONVia naturalCodec) (Number (scientific 1 100000000))
-- Nothing
naturalCodec :: JSONCodec Natural
naturalCodec =
dimapCodec fromIntegral fromIntegral $
integerWithBoundsCodec
( Bounds
{ boundsLower = Just 0,
boundsUpper = Nothing
}
)
-- | Codec for 'Scientific' values with bounds
--
--
-- === Example usage
--
-- >>> let c = scientificWithBoundsCodec Bounds {boundsLower = Just 2, boundsUpper = Just 4}
-- >>> toJSONVia c 3
-- Number 3.0
-- >>> toJSONVia c 5
-- Number 5.0
-- >>> JSON.parseMaybe (parseJSONVia c) (Number 3)
-- Just 3.0
-- >>> JSON.parseMaybe (parseJSONVia c) (Number 5)
-- Nothing
--
--
-- === WARNING
--
-- 'Scientific' is a type that is only for JSON parsing and rendering.
-- Do not use it for any calculations.
-- Instead, convert to another number type before doing any calculations.
--
-- @
-- λ> (1 / 3) :: Scientific
-- *** Exception: fromRational has been applied to a repeating decimal which can't be represented as a Scientific! It's better to avoid performing fractional operations on Scientifics and convert them to other fractional types like Double as early as possible.
-- @
--
--
-- ==== API Note
--
-- This is a forward-compatible version of 'NumberCodec' without a name.
--
-- > scientificWithBoundsCodec bounds = NumberCodec Nothing bounds
scientificWithBoundsCodec :: Bounds Scientific -> JSONCodec Scientific
scientificWithBoundsCodec bounds = NumberCodec Nothing bounds
-- | Codec for 'Integer' values with bounds
--
--
-- === Example usage
--
-- >>> let c = integerWithBoundsCodec Bounds {boundsLower = Just 2, boundsUpper = Just 4}
-- >>> toJSONVia c 3
-- Number 3.0
-- >>> toJSONVia c 5
-- Number 5.0
-- >>> JSON.parseMaybe (parseJSONVia c) (Number 3)
-- Just 3
-- >>> JSON.parseMaybe (parseJSONVia c) (Number 5)
-- Nothing
--
-- ==== API Note
--
-- This is a forward-compatible version of 'IntegerCodec' without a name.
--
-- > integerWithBoundsCodec bounds = IntegerCodec Nothing bounds
integerWithBoundsCodec :: Bounds Integer -> JSONCodec Integer
integerWithBoundsCodec bounds = IntegerCodec Nothing bounds
-- | An object codec with a given name
--
--
-- === Example usage
--
-- > data Example = Example
-- > { exampleText :: !Text,
-- > exampleBool :: !Bool
-- > }
-- >
-- > instance HasCodec Example where
-- > codec =
-- > object "Example" $
-- > Example
-- > <$> requiredField "text" "a text" .= exampleText
-- > <*> requiredField "bool" "a bool" .= exampleBool
--
--
-- ==== API Note
--
-- This is a forward-compatible version 'ObjectOfCodec' with a name.
--
-- > object name = ObjectOfCodec (Just name)
object :: Text -> ObjectCodec input output -> ValueCodec input output
object name = ObjectOfCodec (Just name)
-- | A codec for bounded integers like 'Int', 'Int8', and 'Word'.
--
-- This codec will not have a name, and it will use the 'boundedNumberBounds' to add number bounds.
--
-- >>> let c = boundedIntegralCodec :: JSONCodec Int8
-- >>> toJSONVia c 5
-- Number 5.0
-- >>> JSON.parseMaybe (parseJSONVia c) (Number 100)
-- Just 100
-- >>> JSON.parseMaybe (parseJSONVia c) (Number 200)
-- Nothing
boundedIntegralCodec :: forall i. (Integral i, Bounded i) => JSONCodec i
boundedIntegralCodec =
dimapCodec fromIntegral fromIntegral $ integerWithBoundsCodec (boundedIntegralBounds @i)
-- | 'NumberBounds' for a bounded integral type.
--
-- You can call this using @TypeApplications@: @boundedIntegralBounds @Word@
boundedIntegralBounds :: forall i. (Integral i, Bounded i) => Bounds Integer
boundedIntegralBounds = fromIntegral <$> boundedBounds @i
-- | This is an unsafe (unchecked) version of 'integerCodec'.
unsafeUnboundedIntegerCodec :: JSONCodec Integer
unsafeUnboundedIntegerCodec =
bimapCodec go fromIntegral scientificCodec
where
go s = case Scientific.floatingOrInteger s :: Either Float Integer of
Right i -> Right i
Left _ -> Left ("Number is not an integer: " <> show s)
-- | This is an unsafe (unchecked) version of 'naturalCodec'.
unsafeUnboundedNaturalCodec :: JSONCodec Natural
unsafeUnboundedNaturalCodec =
bimapCodec go fromIntegral scientificCodec
where
go s = case Scientific.floatingOrInteger s :: Either Float Natural of
Right i -> Right i
Left _ -> Left ("Number is not an integer: " <> show s)
-- | A codec for a literal piece of 'Text'.
--
-- During parsing, only the given 'Text' is accepted.
--
-- During rendering, the given 'Text' is always output.
--
--
-- === Example usage
--
-- >>> let c = literalTextCodec "hello"
-- >>> toJSONVia c "hello"
-- String "hello"
-- >>> toJSONVia c "world"
-- String "hello"
-- >>> JSON.parseMaybe (parseJSONVia c) (String "hello")
-- Just "hello"
-- >>> JSON.parseMaybe (parseJSONVia c) (String "world")
-- Nothing
literalTextCodec :: Text -> JSONCodec Text
literalTextCodec text = EqCodec text textCodec
-- | A codec for a literal value corresponding to a literal piece of 'Text'.
--
-- During parsing, only the given 'Text' is accepted.
--
-- During rendering, the given @value@ is always output.
--
--
-- === Example usage
--
-- >>> let c = literalTextValueCodec True "yes"
-- >>> toJSONVia c True
-- String "yes"
-- >>> toJSONVia c False
-- String "yes"
-- >>> JSON.parseMaybe (parseJSONVia c) (String "yes") :: Maybe Bool
-- Just True
-- >>> JSON.parseMaybe (parseJSONVia c) (String "no") :: Maybe Bool
-- Nothing
literalTextValueCodec :: value -> Text -> JSONCodec value
literalTextValueCodec value text = dimapCodec (const value) (const text) (literalTextCodec text)
-- | A choice codec, but unlike 'eitherCodec', it's for the same output type instead of different ones.
--
-- While parsing, this codec will first try the left codec, then the right if that fails.
--
-- While rendering, the provided function is used to decide which codec to use for rendering.
--
-- Note: The reason this is less primitive than the 'eitherCodec' is that 'Either' makes it clear which codec you want to use for rendering.
-- In this case, we need to provide our own function for choosing which codec we want to use for rendering.
--
--
-- === Example usage
--
-- >>> :{
-- let c =
-- matchChoiceCodec
-- (literalTextCodec "even")
-- (literalTextCodec "odd")
-- (\s -> if s == "even" then Left s else Right s)
-- :}
--
-- >>> toJSONVia c "even"
-- String "even"
-- >>> toJSONVia c "odd"
-- String "odd"
-- >>> JSON.parseMaybe (parseJSONVia c) (String "even") :: Maybe Text
-- Just "even"
-- >>> JSON.parseMaybe (parseJSONVia c) (String "odd") :: Maybe Text
-- Just "odd"
--
--
-- ==== API Note
--
-- This is a forward-compatible version of 'matchChoiceCodecAs PossiblyJointUnion':
--
-- > disjointMatchChoiceCodec = matchChoiceCodecAs PossiblyJointUnion
matchChoiceCodec ::
-- | First codec
Codec context input output ->
-- | Second codec
Codec context input' output ->
-- | Rendering chooser
(newInput -> Either input input') ->
Codec context newInput output
matchChoiceCodec = matchChoiceCodecAs PossiblyJointUnion
-- | Disjoint version of 'matchChoiceCodec'
--
--
-- ==== API Note
--
-- This is a forward-compatible version of 'matchChoiceCodecAs DisjointUnion':
--
-- > disjointMatchChoiceCodec = matchChoiceCodecAs DisjointUnion
disjointMatchChoiceCodec ::
-- | First codec
Codec context input output ->
-- | Second codec
Codec context input' output ->
-- | Rendering chooser
(newInput -> Either input input') ->
Codec context newInput output
disjointMatchChoiceCodec = matchChoiceCodecAs DisjointUnion
-- | An even more general version of 'matchChoiceCodec' and 'disjointMatchChoiceCodec'.
matchChoiceCodecAs ::
-- | Is the union DisjointUnion or PossiblyJointUnion
Union ->
-- | First codec
Codec context input output ->
-- | Second codec
Codec context input' output ->
-- | Rendering chooser
(newInput -> Either input input') ->
Codec context newInput output
matchChoiceCodecAs union c1 c2 renderingChooser =
dimapCodec (either id id) renderingChooser $
EitherCodec union c1 c2
-- | A choice codec for a list of options, each with their own rendering matcher.
--
-- During parsing, each of the codecs are tried from first to last until one succeeds.
--
-- During rendering, each matching function is tried until either one succeeds and the corresponding codec is used, or none succeed and the fallback codec is used.
--
--
-- === Example usage
--
-- >>> :{
-- let c =
-- matchChoicesCodec
-- [ (\s -> if s == "even" then Just s else Nothing, literalTextCodec "even")
-- , (\s -> if s == "odd" then Just s else Nothing, literalTextCodec "odd")
-- ] (literalTextCodec "fallback")
-- :}
--
-- >>> toJSONVia c "even"
-- String "even"
-- >>> toJSONVia c "odd"
-- String "odd"
-- >>> toJSONVia c "foobar"
-- String "fallback"
-- >>> JSON.parseMaybe (parseJSONVia c) (String "even") :: Maybe Text
-- Just "even"
-- >>> JSON.parseMaybe (parseJSONVia c) (String "odd") :: Maybe Text
-- Just "odd"
-- >>> JSON.parseMaybe (parseJSONVia c) (String "foobar") :: Maybe Text
-- Nothing
-- >>> JSON.parseMaybe (parseJSONVia c) (String "fallback") :: Maybe Text
-- Just "fallback"
--
--
-- ==== API Note
--
-- This is a forward-compatible version of 'matchChoicesCodecAs DisjointUnion'.
--
-- > disjointMatchChoiceCodec = matchChoicesCodecAs DisjointUnion
matchChoicesCodec ::
-- | Codecs, each with their own rendering matcher
[(input -> Maybe input, Codec context input output)] ->
-- | Fallback codec, in case none of the matchers in the list match
Codec context input output ->
Codec context input output
matchChoicesCodec = matchChoicesCodecAs PossiblyJointUnion
-- | Disjoint version of 'matchChoicesCodec'
--
--
-- ==== API Note
--
-- This is a forward-compatible version of 'matchChoicesCodecAs DisjointUnion'.
--
-- > disjointMatchChoiceCodec = matchChoicesCodecAs DisjointUnion
disjointMatchChoicesCodec ::
-- | Codecs, each with their own rendering matcher
[(input -> Maybe input, Codec context input output)] ->
-- | Fallback codec, in case none of the matchers in the list match
Codec context input output ->
Codec context input output
disjointMatchChoicesCodec = matchChoicesCodecAs DisjointUnion
-- | An even more general version of 'matchChoicesCodec' and 'disjointMatchChoicesCodec'
matchChoicesCodecAs ::
Union ->
-- | Codecs, each with their own rendering matcher
[(input -> Maybe input, Codec context input output)] ->
-- | Fallback codec, in case none of the matchers in the list match
Codec context input output ->
Codec context input output
matchChoicesCodecAs union l fallback = go l
where
go = \case
[] -> fallback
((m, c) : rest) -> matchChoiceCodecAs union c (go rest) $ \i -> case m i of
Just j -> Left j
Nothing -> Right i
-- | Use one codec for the default way of parsing and rendering, but then also
-- use a list of other codecs for potentially different parsing.
--
-- You can use this for keeping old ways of parsing intact while already rendering in the new way.
--
--
-- === Example usage
--
-- >>> data Fruit = Apple | Orange deriving (Show, Eq, Bounded, Enum)
-- >>> let c = parseAlternatives shownBoundedEnumCodec [stringConstCodec [(Apple, "foo"), (Orange, "bar")]]
-- >>> toJSONVia c Apple
-- String "Apple"
-- >>> JSON.parseMaybe (parseJSONVia c) (String "foo") :: Maybe Fruit
-- Just Apple
-- >>> JSON.parseMaybe (parseJSONVia c) (String "Apple") :: Maybe Fruit
-- Just Apple
-- >>> JSON.parseMaybe (parseJSONVia c) (String "Tomato") :: Maybe Fruit
-- Nothing
parseAlternatives ::
-- | Main codec, for parsing and rendering
Codec context input output ->
-- | Alternative codecs just for parsing
[Codec context input output] ->
Codec context input output
parseAlternatives c rest = go (c :| rest)
where
go :: NonEmpty (Codec context input output) -> Codec context input output
go = \case
(c' :| cRest) -> case NE.nonEmpty cRest of
Nothing -> c'
Just ne' -> matchChoiceCodec c' (go ne') Left
-- | Like 'parseAlternatives', but with only one alternative codec
--
--
-- === Example usage
-- ==== Values
--
-- >>> data Fruit = Apple | Orange deriving (Show, Eq, Bounded, Enum)
-- >>> let c = parseAlternative shownBoundedEnumCodec (stringConstCodec [(Apple, "foo"), (Orange, "bar")])
-- >>> toJSONVia c Apple
-- String "Apple"
-- >>> JSON.parseMaybe (parseJSONVia c) (String "foo") :: Maybe Fruit
-- Just Apple
-- >>> JSON.parseMaybe (parseJSONVia c) (String "Apple") :: Maybe Fruit
-- Just Apple
--
-- ==== Required object fields
--
-- >>> data Fruit = Apple | Orange deriving (Show, Eq, Bounded, Enum)
-- >>> let c = shownBoundedEnumCodec
-- >>> let o = parseAlternative (requiredFieldWith "current" c "current key for this field") (requiredFieldWith "legacy" c "legacy key for this field")
-- >>> toJSONObjectVia o Apple
-- fromList [("current",String "Apple")]
-- >>> JSON.parseMaybe (parseJSONObjectVia o) (KM.fromList [("current",String "Apple")]) :: Maybe Fruit
-- Just Apple
-- >>> JSON.parseMaybe (parseJSONObjectVia o) (KM.fromList [("legacy",String "Apple")]) :: Maybe Fruit
-- Just Apple
-- >>> JSON.parseMaybe (parseJSONObjectVia o) (KM.fromList [("current",String "Tomato")]) :: Maybe Fruit
-- Nothing
--
-- ==== Required object fields
--
-- While 'parseAlternative' works exactly like you would expect it would with 'requiredField', using 'parseAlterternative' with optional fields has some pitfalls.
--
-- >>> data Fruit = Apple | Orange deriving (Show, Eq, Bounded, Enum)
-- >>> let c = shownBoundedEnumCodec
-- >>> let o = parseAlternative (optionalFieldWith "current" c "current key for this field") (optionalFieldWith "legacy" c "legacy key for this field")
-- >>> toJSONObjectVia o (Just Apple)
-- fromList [("current",String "Apple")]
-- >>> toJSONObjectVia o Nothing
-- fromList []
-- >>> JSON.parseMaybe (parseJSONObjectVia o) (KM.fromList [("current",String "Apple")]) :: Maybe (Maybe Fruit)
-- Just (Just Apple)
--
--
-- ! This is the important result !
-- The second 'optionalFieldWith' is not tried because the first one _succeeds_ in parsing 'Nothing'
--
-- >>> JSON.parseMaybe (parseJSONObjectVia o) (KM.fromList [("legacy",String "Apple")]) :: Maybe (Maybe Fruit)
-- Just Nothing
--
-- Here the parser succeeds as well, because it fails to parse the @current@ field, so it tries to parse the @legacy@ field, which is missing.
--
-- >>> JSON.parseMaybe (parseJSONObjectVia o) (KM.fromList [("current",String "Tomato")]) :: Maybe (Maybe Fruit)
-- Just Nothing
parseAlternative ::
-- | Main codec, for parsing and rendering
Codec context input output ->
-- | Alternative codecs just for parsing
Codec context input' output ->
Codec context input output
parseAlternative c cAlt = matchChoiceCodec c cAlt Left
-- | A codec for an enum that can be written each with their own codec.
--
--
-- === WARNING
--
-- If you don't provide a string for one of the type's constructors, the last codec in the list will be used instead.
enumCodec ::
forall enum context.
(Eq enum) =>
NonEmpty (enum, Codec context enum enum) ->
Codec context enum enum
enumCodec = go
where
go :: NonEmpty (enum, Codec context enum enum) -> Codec context enum enum
go ((e, c) :| rest) = case NE.nonEmpty rest of
Nothing -> c
Just ne -> disjointMatchChoiceCodec c (go ne) $ \i ->
if e == i
then Left e
else Right i
-- | A codec for an enum that can be written as constant string values
--
--
-- === Example usage
--
-- >>> data Fruit = Apple | Orange deriving (Show, Eq)
-- >>> let c = stringConstCodec [(Apple, "foo"), (Orange, "bar")]
-- >>> toJSONVia c Orange
-- String "bar"
-- >>> JSON.parseMaybe (parseJSONVia c) (String "foo") :: Maybe Fruit
-- Just Apple
--
--
-- === WARNING
--
-- If you don't provide a string for one of the type's constructors, the last string in the list will be used instead:
--
-- >>> let c = stringConstCodec [(Apple, "foo")]
-- >>> toJSONVia c Orange
-- String "foo"
stringConstCodec ::
forall constant.
(Eq constant) =>
NonEmpty (constant, Text) ->
JSONCodec constant
stringConstCodec =
enumCodec
. NE.map
( \(constant, text) ->
( constant,
literalTextValueCodec constant text
)
)
-- | A codec for a 'Bounded' 'Enum' that uses the provided function to have the values correspond to literal 'Text' values.
--
--
-- === Example usage
--
-- >>> data Fruit = Apple | Orange deriving (Show, Eq, Enum, Bounded)
-- >>> :{
-- let c = boundedEnumCodec $ \case
-- Apple -> "foo"
-- Orange -> "bar"
-- :}
--
-- >>> toJSONVia c Apple
-- String "foo"
-- >>> JSON.parseMaybe (parseJSONVia c) (String "bar") :: Maybe Fruit
-- Just Orange
boundedEnumCodec ::
forall enum.
(Eq enum, Enum enum, Bounded enum) =>
(enum -> T.Text) ->
JSONCodec enum
boundedEnumCodec showFunc =
let ls = [minBound .. maxBound]
in case NE.nonEmpty ls of
Nothing -> error "0 enum values ?!"
Just ne -> stringConstCodec (NE.map (\v -> (v, showFunc v)) ne)
-- | A codec for a 'Bounded' 'Enum' that uses its 'Show' instance to have the values correspond to literal 'Text' values.
--
--
-- === Example usage
--
-- >>> data Fruit = Apple | Orange deriving (Show, Eq, Enum, Bounded)
-- >>> let c = shownBoundedEnumCodec
-- >>> toJSONVia c Apple
-- String "Apple"
-- >>> JSON.parseMaybe (parseJSONVia c) (String "Orange") :: Maybe Fruit
-- Just Orange
shownBoundedEnumCodec ::
forall enum.
(Show enum, Eq enum, Enum enum, Bounded enum) =>
JSONCodec enum
shownBoundedEnumCodec = boundedEnumCodec (T.pack . show)
-- | Helper function for 'optionalFieldOrNullWith' and 'optionalFieldOrNull'.
--
-- You probably don't need this.
orNullHelper ::
ObjectCodec (Maybe (Maybe input)) (Maybe (Maybe output)) ->
ObjectCodec (Maybe input) (Maybe output)
orNullHelper = dimapCodec f g
where
f :: Maybe (Maybe input) -> Maybe input
f = \case
Nothing -> Nothing
Just Nothing -> Nothing
Just (Just a) -> Just a
g :: Maybe output -> Maybe (Maybe output)
g = \case
Nothing -> Nothing
Just a -> Just (Just a)
-- | Name a codec.
--
-- This is used to allow for references to the codec, and that's necessary
-- to produce finite documentation for recursive codecs.
--
--
-- ==== API Note
--
-- This is a forward-compatible version of 'ReferenceCodec'.
--
-- > named = ReferenceCodec
named :: Text -> ValueCodec input output -> ValueCodec input output
named = ReferenceCodec
-- | Produce a codec using a type's 'FromJSON' and 'ToJSON' instances.
--
-- You will only want to use this if you cannot figure out how to produce a
-- 'JSONCodec' for your type.
--
-- Note that this will not have good documentation because, at a codec level,
-- it's just parsing and rendering a 'JSON.Value'.
--
--
-- === Example usage
--
-- >>> toJSONVia (codecViaAeson "Int") (5 :: Int)
-- Number 5.0
-- >>> JSON.parseMaybe (parseJSONVia (codecViaAeson "Int")) (Number 5) :: Maybe Int
-- Just 5
codecViaAeson ::
(FromJSON a, ToJSON a) =>
-- | Name
Text ->
JSONCodec a
codecViaAeson doc = bimapCodec (JSON.parseEither JSON.parseJSON) JSON.toJSON valueCodec <?> doc
-- Could get this from https://hackage.haskell.org/package/either-result-0.3.1.0/docs/Control-Monad-Result.html#t:Result
-- but just reimplementing here to avoid a dependency, as it's not exported anyway
-- (well it is actually, until we give this module an explicit export list).
-- We need to do this because `Either String a` doesn't have a `MonadFail` instance,
-- but `Time.iso8601ParseM` expects it's return value to have a `MonadFail` instance.
newtype Result a = Result {runResult :: Either String a}
deriving newtype (Functor, Applicative, Monad)
instance MonadFail Result where
fail = Result . Left
-- TODO 'aeson' has it's own custom datetime serialising code in the module @Data.Aeson.Encoding.Builder@:
-- The core function here is `Data.Aeson.Encoding.Builder.timeOfDay64`.
-- However, this module is private.
-- There is @Data.Aeson.Encoding.Internal@, which interestingly isn't private, but it's only exposed functions
-- wrap the return bytestring in a quotes. Only for the quotes to be removed in `Data.Aeson.Types.ToJSON.stringEncoding`
-- This all seems a bit silly.
-- I think `aeson` should just expose @Data.Aeson.Encoding.Builder@ and it's datetime instances should just take those builders,
-- convert them to Text and be done with it.
-- I plan to submit a PR to 'aeson' to do this.
-- In the meantime, I think the best way to ensure we are exactly behaving as 'aeson' is just to _assume_ aeson is returning a string
-- This is a correct assumption for any of the datetime types, but using this function generally is unsafe.
unsafeCodecViaAesonString ::
(FromJSON a, ToJSON a) =>
-- | Name
Text ->
JSONCodec a
unsafeCodecViaAesonString doc = bimapCodec (JSON.parseEither JSON.parseJSON . JSON.String) (unsafeAesonValueToString . JSON.toJSON) textCodec <?> doc
where
unsafeAesonValueToString v = case v of
JSON.String s -> s
_ -> error $ "unsafeAesonValueToString failed.\n " ++ show v ++ "\n is not a JSON string."