Tagliatelle.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}

module Data.Tagliatelle where

import Control.Monad (zipWithM)
import Data.Aeson
  ( Encoding,
    FromJSON,
    Key,
    Object,
    Series,
    ToJSON,
    Value,
  )
import Data.Aeson qualified as Aeson
import Data.Aeson.Encoding qualified as Enc
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Aeson.Types (Parser, typeMismatch)
import Data.Aeson.Types qualified as Aeson
import Data.Data (Proxy (..))
import Data.HashMap.Strict.InsOrd qualified as InsOrd
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.OpenApi qualified as OA
import Data.Tagliatelle.OpenApi
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.Builder qualified as TB
import Data.Text.Lazy.Builder.Int qualified as TB
import Data.Text.Read qualified as TR
import Data.Typeable (Typeable)
import Data.Vector qualified as V
import Data.Vector.Mutable qualified as VM
import Data.Word (Word32, Word64, Word8)
import GHC.Int (Int32, Int64)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Lens.Micro ((&), (.~))

-- * Codecs

-- | A tagliatelle @Codec@ provides a 'Value' encoder, decoder and corresponding OpenApi
-- specification for values of type @a@.
--
-- Codecs are made to fuse well, yielding core that is very close to hand-written
-- instances, if not better in some cases.
data Codec a = Codec
  { codecToEncoding :: a -> Encoding,
    codecToValue :: a -> Value,
    codecFromJSON :: Value -> Parser a,
    codecSchema :: Decl OA.NamedSchema
  }

-- | Codec's are not really functors, but we can transport them over isomorphisms.
codecMap :: (b -> a) -> (a -> b) -> Codec a -> Codec b
{-# INLINE codecMap #-}
codecMap from to c =
  Codec
    { codecToEncoding = codecToEncoding c . from,
      codecToValue = codecToValue c . from,
      codecFromJSON = fmap to . codecFromJSON c,
      codecSchema = codecSchema c
    }

-- ** DerivingVia helpers #derivingvia#

-- $derivingviaexample
-- The easiest way to use tagliatelle is to derive 'ToJSON', 'FromJSON'
-- and 'OA.ToSchema' @via ViaCodec@:
--
-- > data Sauce = Red { redSauce :: RedSauce } | Bechamel { whiteSauce :: WhiteSauce }
-- >   deriving (ToJSON, FromJSON, ToSchema) via ViaCodec Sauce
-- >
-- > instance HasCodec Sauce where
-- >   codec = ...

class HasCodec a where
  codec :: Codec a

-- | Newtype for @deriving via@. Requires a 'HasCodec' instance. Check <#g:derivingvia DerivingVia>
-- for an example.
newtype ViaCodec a = ViaCodec {unViaCodec :: a}

instance (HasCodec a) => ToJSON (ViaCodec a) where
  {-# INLINE toEncoding #-}
  toEncoding (ViaCodec a) = codecToEncoding (codec @a) a

  {-# INLINE toJSON #-}
  toJSON (ViaCodec a) = codecToValue (codec @a) a

instance (HasCodec a) => FromJSON (ViaCodec a) where
  {-# INLINE parseJSON #-}
  parseJSON v = ViaCodec <$> codecFromJSON (codec @a) v

instance (HasCodec a, Typeable a) => OA.ToSchema (ViaCodec a) where
  declareNamedSchema _ = codecSchema (codec @a)

-- ** Products

-- | Wraps a 'ProductCodec' into a JSON Object, giving us a 'Codec'
prod :: Text -> ProductCodec a -> Codec a
{-# INLINE prod #-}
prod name oc =
  Codec
    { codecToEncoding = Aeson.pairs . prodSeries oc,
      codecToValue = \v -> Aeson.Object $ prodObject oc v mempty,
      codecFromJSON = Aeson.withObject (Text.unpack name) (prodDecode oc),
      codecSchema = do
        props <- traverse (\(k, d, req) -> (req,) . (k,) <$> d) (prodSchema oc)
        pure $
          OA.NamedSchema (Just name) $
            mempty
              & OA.type_ .~ Just OA.OpenApiObject
              & OA.properties .~ InsOrd.fromList (map snd props)
              & OA.required .~ map (fst . snd) (filter fst props)
    }

-- | A @PartialProdCodec s a@ encodes/decodes an @a@ that is a component within
-- a product-like type @s@. This type is pretty much the same as @ObjectCodec@
-- from @autodocodec@, where we drew inspiration from.
data PartialProdCodec s a = PartialProdCodec
  { prodSeries :: s -> Series,
    prodObject :: s -> Object -> Object,
    prodDecode :: Object -> Parser a,
    prodSchema ::
      [ ( Text,
          Decl (OA.Referenced OA.Schema),
          Bool -- is this field required?
        )
      ]
  }

-- | In a @PartialProdCodec s a@, when @s ~ a@, the codec is no longer /partial/,
-- it encodes/decodes the shole @s@. 'ProductCodec' is just a synonym for that.
type ProductCodec a = PartialProdCodec a a

instance Functor (PartialProdCodec s) where
  fmap f oc = oc {prodDecode = fmap (fmap f) (prodDecode oc)}

instance Applicative (PartialProdCodec s) where
  {-# INLINE pure #-}
  pure a = PartialProdCodec (const mempty) (const id) (const (pure a)) []
  {-# INLINE (<*>) #-}
  f <*> x =
    PartialProdCodec
      { prodSeries = \s -> prodSeries f s <> prodSeries x s,
        prodObject = \v -> prodObject f v . prodObject x v,
        prodDecode = \o -> prodDecode f o <*> prodDecode x o,
        prodSchema = prodSchema f <> prodSchema x
      }

-- | Fields are used in the context of a 'PartialProdCodec':
--
-- > data Version = Version { major :: Int, minor :: Maybe Int }
-- >
-- > instance HasCodec Version where
-- >   codec = prod "Version" $ Version
-- >     <$> T.field    "major" major codec
-- >     <*> T.optField "minor" minor codec
field :: Key -> (s -> a) -> Codec a -> PartialProdCodec s a
{-# INLINE field #-}
field key acc c =
  PartialProdCodec
    { prodSeries = \s -> Enc.pair key (codecToEncoding c (acc s)),
      prodObject = \v ->
        let !r = codecToValue c (acc v)
         in KeyMap.insert key r,
      prodDecode = \o ->
        case KeyMap.lookup key o of
          Nothing -> fail ("missing key: " <> Key.toString key)
          Just v -> codecFromJSON c v Aeson.<?> Aeson.Key key,
      prodSchema = [(Key.toText key, declareSchemaRef (codecSchema c), True)] -- required = True
    }

-- | Just like 'field', but optional. Check 'field' for an example.
-- Absent or 'Aeson.Null' decodes to 'Nothing'; 'Nothing' is omitted on encode.
optField :: Key -> (s -> Maybe a) -> Codec a -> PartialProdCodec s (Maybe a)
{-# INLINE optField #-}
optField key acc c =
  PartialProdCodec
    { prodSeries = \s -> case acc s of
        Nothing -> mempty -- omit
        Just a -> Enc.pair key (codecToEncoding c a),
      prodObject = \v -> case acc v of
        Nothing -> id
        Just a -> KeyMap.insert key (codecToValue c a),
      prodDecode = \o ->
        case KeyMap.lookup key o of
          Nothing -> pure Nothing -- absent = Nothing
          Just Aeson.Null -> pure Nothing -- accept null too (lenient)
          Just v -> Just <$> (codecFromJSON c v Aeson.<?> Aeson.Key key),
      prodSchema = [(Key.toText key, declareSchemaRef (codecSchema c), False)] -- required = False
    }

-- ** Coproducts #coproducts#

-- $coproductsexample
-- Tagliatelle produces tagged encodings, as the name hints. Every coproduct case, then,
-- must be specified by a @TaggedCodec t@; the type variable @t@ is a type-level 'Symbol'
-- used to specify the label for the tag:
--
-- > data Sauce = Red { redSauce :: RedSauce } | Bechamel { bechSauce :: WhiteSauce }
-- >
-- > instance HasCodec Sauce where
-- >   codec = coprod @"sauce_type" "Sauce"
-- >       ( \case
-- >           Red {} -> redFields
-- >           Bechamel {} -> bechamelFields
-- >       )
-- >       [redFields, bechamelFields]
-- >     where
-- >       redFields :: TaggedCodec t Sauce
-- >       redFields = Tagged "red" (Red <$> field "sauce" redSauce codec)
-- >
-- >       bechamelFields = Tagged "bechamel" (Bechamel <$> field "sauce" bechSauce codec)
--
-- This codec will produce JSON 'Value's discriminated by @"sauce_type"@, which can take the
-- values either @"red"@ or @"bechamel"@. Note that to specify this codec, the programmer
-- only wrote each tag once, this removes the chance of misspelling a tag and having
-- a decoder that wont work.

-- | Same as adding another 'field' to the 'ProductCodec', but this field
-- name is passed at the type level, through @t@.
data TaggedCodec (t :: Symbol) a where
  Tagged :: forall t a. Text -> ProductCodec a -> TaggedCodec t a

-- | Creates a codec for a coproduct-like type. The type-level @Symbol@ is the label
-- that tagliatelle will use for tagging the values. Check <#g:coproducts Coproducts Section>
-- for an example.
--
-- This is slightly more expensive than a hand-written @case@ statement, but we have no
-- choice but to keep a map of tags to dispatchers in memory, so we know which codec
-- to use by each constructor. A design goal of @coprod@ is that you never write a
-- magic string twice: removing the chance of spelling errors.
coprod ::
  forall t a.
  (KnownSymbol t) =>
  Text ->
  (a -> TaggedCodec t a) ->
  [TaggedCodec t a] ->
  Codec a
{-# INLINE coprod #-}
coprod name dispatch decoders =
  Codec
    { codecToEncoding = \a -> case dispatch a of
        Tagged tag pc -> Aeson.pairs $ Enc.pair tagField (Enc.text tag) <> prodSeries pc a,
      codecToValue = \v -> case dispatch v of
        Tagged tag pc -> Aeson.Object (prodObject pc v (KeyMap.singleton tagField (Aeson.String tag))),
      codecFromJSON = Aeson.withObject (Text.unpack name) $ \o -> do
        tag <- o Aeson..: tagField
        case Map.lookup tag decoderMap of
          Nothing -> fail ("unknown tag: " <> Text.unpack tag)
          Just dec -> Aeson.modifyFailure (("On case " <> Text.unpack tag) <>) (prodDecode dec o),
      codecSchema = do
        refs <-
          traverse
            ( \(tag, pc) -> declareSchemaRef $ do
                props <- traverse (\(k, d, _) -> (k,) <$> d) (prodSchema pc)
                let reqs = [k | (k, _, True) <- prodSchema pc]
                    tagValSchema =
                      mempty
                        & OA.type_
                          .~ Just OA.OpenApiString
                        & OA.enum_
                          .~ Just [Aeson.String tag]
                    schema =
                      mempty
                        & OA.type_
                          .~ Just OA.OpenApiObject
                        & OA.properties
                          .~ InsOrd.fromList
                            ((tagFieldName, OA.Inline tagValSchema) : props)
                        & OA.required
                          .~ (tagFieldName : reqs)
                pure $ OA.NamedSchema (Just (name <> "." <> tag)) $ schema
            )
            decoderList
        pure $
          OA.NamedSchema (Just name) $
            mempty
              & OA.oneOf
                .~ Just refs
              & OA.discriminator
                .~ Just (OA.Discriminator tagFieldName mempty)
    }
  where
    pt = Proxy @t
    !tagFieldName = Text.pack $ symbolVal pt
    !tagField = Key.fromText tagFieldName

    decoderList :: [(Text, ProductCodec a)]
    decoderList = [(tagVal, pc) | Tagged tagVal pc <- decoders]

    !decoderMap =
      Map.fromListWith
        (\_ _ -> error $ "coprod: duplicate tag for field " <> Text.unpack tagFieldName)
        decoderList

-- ** Enums

-- | Explicit enumeration codec. Keeps two 'Map.Map' for encoding and
-- decoding, hence the @Ord a@ constraint.
enum :: (Ord a) => Text -> [(a, Text)] -> Codec a
enum name pairs =
  Codec
    { codecToEncoding = Aeson.toEncoding . encode',
      codecToValue = Aeson.String . encode',
      codecFromJSON = \case
        Aeson.String t ->
          maybe
            (fail $ "unknown " <> Text.unpack name <> ": " <> Text.unpack t)
            pure
            (Map.lookup t decodeMap)
        v -> typeMismatch "String" v,
      codecSchema =
        pure $
          OA.NamedSchema (Just name) $
            mempty
              & OA.type_ .~ Just OA.OpenApiString
              & OA.enum_ .~ Just (map (Aeson.String . snd) pairs)
    }
  where
    !encodeMap = Map.fromList pairs
    !decodeMap = Map.fromList (map (\(a, t) -> (t, a)) pairs)
    encode' a =
      maybe
        (error $ "Servanter.Codec.enum: non-exhaustive table for " <> Text.unpack name)
        id
        (Map.lookup a encodeMap)

-- ** Tuples and Triples

instance (HasCodec a, HasCodec b) => HasCodec (a, b) where
  codec = tuple codec codec

-- | Encodes a tuple as an array, just like @Aeson.toJSON ("a", 4)@ would.
tuple :: Codec a -> Codec b -> Codec (a, b)
{-# INLINE tuple #-}
tuple codecA codecB =
  Codec
    { codecToEncoding = \(a, b) -> Enc.list id [codecToEncoding codecA a, codecToEncoding codecB b],
      codecToValue = \(a, b) -> Aeson.Array $ V.create $ do
        mv <- VM.unsafeNew 2
        VM.unsafeWrite mv 0 (codecToValue codecA a)
        VM.unsafeWrite mv 1 (codecToValue codecB b)
        pure mv,
      codecFromJSON =
        Aeson.withArray "tuple" $ \arr ->
          if V.length arr /= 2
            then fail "Expecting exactly two elements"
            else
              (,)
                <$> codecFromJSON codecA (arr V.! 0) Aeson.<?> Aeson.Index 0
                <*> codecFromJSON codecB (arr V.! 1) Aeson.<?> Aeson.Index 1,
      codecSchema = do
        refA <- declareSchemaRef $ codecSchema codecA
        refB <- declareSchemaRef $ codecSchema codecB
        pure $
          OA.NamedSchema Nothing $
            mempty
              & OA.type_ .~ Just OA.OpenApiArray
              & OA.items .~ Just (OA.OpenApiItemsArray [refA, refB])
              & OA.maxItems .~ Just 2
              & OA.minItems .~ Just 2
    }

instance (HasCodec a, HasCodec b, HasCodec c) => HasCodec (a, b, c) where
  codec = triple codec codec codec

-- | Encodes a triple as an array, just like @Aeson.toJSON ("a", 4, "b")@ would.
triple :: Codec a -> Codec b -> Codec c -> Codec (a, b, c)
{-# INLINE triple #-}
triple codecA codecB codecC =
  Codec
    { codecToEncoding = \(a, b, c) -> Enc.list id [codecToEncoding codecA a, codecToEncoding codecB b, codecToEncoding codecC c],
      codecToValue = \(a, b, c) -> Aeson.Array $ V.create $ do
        mv <- VM.unsafeNew 3
        VM.unsafeWrite mv 0 (codecToValue codecA a)
        VM.unsafeWrite mv 1 (codecToValue codecB b)
        VM.unsafeWrite mv 2 (codecToValue codecC c)
        pure mv,
      codecFromJSON =
        Aeson.withArray "triple" $ \arr ->
          if V.length arr /= 3
            then fail "Expecting exactly three elements"
            else
              (,,)
                <$> codecFromJSON codecA (arr V.! 0) Aeson.<?> Aeson.Index 0
                <*> codecFromJSON codecB (arr V.! 1) Aeson.<?> Aeson.Index 1
                <*> codecFromJSON codecC (arr V.! 2) Aeson.<?> Aeson.Index 2,
      codecSchema = do
        refA <- declareSchemaRef $ codecSchema codecA
        refB <- declareSchemaRef $ codecSchema codecB
        refC <- declareSchemaRef $ codecSchema codecC
        pure $
          OA.NamedSchema Nothing $
            mempty
              & OA.type_ .~ Just OA.OpenApiArray
              & OA.items .~ Just (OA.OpenApiItemsArray [refA, refB, refC])
              & OA.maxItems .~ Just 3
              & OA.minItems .~ Just 3
    }

-- ** List

instance (HasCodec a) => HasCodec [a] where
  codec = list codec

-- | Encodes lists as JSON arrays. This is significantly more efficient than
-- a recursive encoding and is just like @aeson@ does it.
list :: Codec a -> Codec [a]
{-# INLINE list #-}
list Codec {..} =
  Codec
    { codecToEncoding = Enc.list codecToEncoding,
      codecToValue = Aeson.Array . V.fromList . map codecToValue,
      codecFromJSON =
        Aeson.withArray "list" $ \a ->
          zipWithM (\ix v -> codecFromJSON v Aeson.<?> Aeson.Index ix) [0 ..] $ V.toList a,
      codecSchema = do
        ref <- declareSchemaRef codecSchema
        pure $
          OA.NamedSchema Nothing $
            mempty
              & OA.type_ .~ Just OA.OpenApiArray
              & OA.items .~ Just (OA.OpenApiItemsObject ref)
    }

-- ** Maybe

instance (HasCodec a) => HasCodec (Maybe a) where
  codec = nullable codec

-- | Encodes a @Maybe a@, mapping @Nothing@ to 'Aeson.Null'. This is not meant to be
-- used for marking fields of a produc codec optional, use 'optField' for that.
nullable :: Codec a -> Codec (Maybe a)
{-# INLINE nullable #-}
nullable c =
  Codec
    { codecToEncoding = \case
        Nothing -> Aeson.toEncoding Aeson.Null
        Just a -> codecToEncoding c a,
      codecToValue = \case
        Nothing -> Aeson.Null
        Just v -> codecToValue c v,
      codecFromJSON = \case
        Aeson.Null -> pure Nothing
        v -> Just <$> codecFromJSON c v,
      codecSchema = mkNullable <$> declareSchemaRef (codecSchema c)
    }

-- ** Map

parseBoundedSigned :: forall a. (Integral a, Bounded a) => Text -> Parser a
{-# INLINE parseBoundedSigned #-}
parseBoundedSigned t =
  case TR.signed TR.decimal t of
    Right (n :: Integer, rest)
      | not (Text.null rest) ->
          fail $ "trailing characters after integer: " <> Text.unpack rest
      | n < toInteger (minBound :: a) || n > toInteger (maxBound :: a) ->
          fail $ "integer out of range: " <> show n
      | otherwise -> pure (fromInteger n)
    Left e -> fail e

parseBoundedUnsigned :: forall a. (Integral a, Bounded a) => Text -> Parser a
{-# INLINE parseBoundedUnsigned #-}
parseBoundedUnsigned t =
  case TR.decimal t of
    Right (n :: Integer, rest)
      | not (Text.null rest) ->
          fail $ "trailing characters after integer: " <> Text.unpack rest
      | n < 0 || n > toInteger (maxBound :: a) ->
          fail $ "unsigned integer out of range: " <> show n
      | otherwise -> pure (fromInteger n)
    Left e -> fail e

-- | Converts an integral type into a 'Aeson.Key'; for small numbers,
-- it is faster to just call:
--
-- > Key.fromText (Text.pack (show n))
--
-- But I don't want to be maintaining a million specialised helpers.
intDecToKey :: (Integral a) => a -> Key
{-# INLINE intDecToKey #-}
intDecToKey = Key.fromText . TL.toStrict . TB.toLazyText . TB.decimal

-- | 'IsKey' tells tagliatelle how to convert values of a type @k@ for them to appear as
-- JSON keys. We're deliberately not relying on 'Aeson.ToJSONKey' infrastructure: it does
-- some magic when deciding the representation. We don't do magic in this library.
-- For example, for @Int@ keys, @"1000"@ and @"1e3"@ parse to the same key according to
-- 'Aeson.FromJSONKey' instance for @Int@. Tagliatelle will give you an error:
--
-- > ghci> let v = Aeson.object [("1000",Aeson.String "a"),("1e3",Aeson.String "b")]
-- > ghci> Aeson.parseEither Aeson.parseJSON v :: Either String (Map.Map Int32 String)
-- > Right (fromList [(1000,"a")])
-- > ghci> Aeson.parseEither (codecFromJSON codec) v :: Either String (Map.Map Int32 String)
-- > Left "Error in $['1e3']: trailing characters after integer: e3"
class (Ord k) => IsKey k where
  toKey :: k -> Key
  encodeKey :: k -> Enc.Encoding' Key
  parseKey :: Key -> Parser k

instance IsKey Int32 where
  {-# INLINE encodeKey #-}
  encodeKey = Enc.int32Text
  {-# INLINE parseKey #-}
  parseKey = parseBoundedSigned . Key.toText
  {-# INLINE toKey #-}
  toKey = intDecToKey

instance IsKey Int64 where
  {-# INLINE encodeKey #-}
  encodeKey = Enc.int64Text
  {-# INLINE parseKey #-}
  parseKey = parseBoundedSigned . Key.toText
  {-# INLINE toKey #-}
  toKey = intDecToKey

instance IsKey Word8 where
  {-# INLINE encodeKey #-}
  encodeKey = Enc.word8Text
  {-# INLINE parseKey #-}
  parseKey = parseBoundedUnsigned . Key.toText
  {-# INLINE toKey #-}
  toKey = intDecToKey

instance IsKey Word32 where
  {-# INLINE encodeKey #-}
  encodeKey = Enc.word32Text
  {-# INLINE parseKey #-}
  parseKey = parseBoundedUnsigned . Key.toText
  {-# INLINE toKey #-}
  toKey = intDecToKey

instance IsKey Word64 where
  {-# INLINE encodeKey #-}
  encodeKey = Enc.word64Text
  {-# INLINE parseKey #-}
  parseKey = parseBoundedUnsigned . Key.toText
  {-# INLINE toKey #-}
  toKey = intDecToKey

instance {-# OVERLAPPING #-} (HasCodec v) => HasCodec (Map Text v) where
  codec = kvmapText codec

instance {-# OVERLAPPABLE #-} (IsKey k, HasCodec v) => HasCodec (Map k v) where
  codec = kvmap codec

-- | Encodes a map as a JSON object, this means we need to be able to translate
-- @k@ into JSON keys. The @IsKey@ instance will do that for you. If you rather
-- encode your map as an array of pairs, check 'kvmapAsList' instead.
--
-- If @k ~ Text@, you're better of using 'kvmapText'
kvmap :: (IsKey k) => Codec v -> Codec (Map k v)
{-# INLINE kvmap #-}
kvmap Codec {..} =
  Codec
    { codecToEncoding = \m -> Enc.dict encodeKey codecToEncoding Map.foldrWithKey m,
      codecToValue = \m ->
        Aeson.Object $
          -- KeyMap.fromMap is just coerce when Aeson is built with ordered-keymap,
          -- which it is, by default.
          KeyMap.fromMap $
            Map.foldlWithKey'
              (\acc k v -> Map.insert (toKey k) (codecToValue v) acc)
              Map.empty
              m,
      codecFromJSON =
        Aeson.withObject "kvmap" $
          -- When @k~Text@, this is horrible: we're building a whole map when that is not
          -- needed at all! Check 'kvmapText'
          KeyMap.foldrWithKey
            ( \k v m ->
                Map.insert
                  <$> (parseKey k Aeson.<?> Aeson.Key k)
                  <*> (codecFromJSON v Aeson.<?> Aeson.Key k)
                  <*> m
            )
            (pure Map.empty),
      codecSchema = do
        ref <- declareSchemaRef $ codecSchema
        pure $
          OA.NamedSchema Nothing $
            mempty
              & OA.type_
                .~ Just OA.OpenApiObject
              & OA.additionalProperties
                .~ Just (OA.AdditionalPropertiesSchema ref)
    }

-- | Sometimes your key type is more involved and you don't want to write @IsKey k@
-- instance. In those cases, just represent the map as a list of tuples. This is what
-- Aeson does when you define the 'Aeson.ToJSONKeyFunction'to be a @ToJSONKeyValue@.
kvmapAsList :: (Ord k) => Codec k -> Codec v -> Codec (Map k v)
{-# INLINE kvmapAsList #-}
kvmapAsList codecK codecV = codecMap Map.toList Map.fromList (list (tuple codecK codecV))

-- | If your map is already keyed by 'Text', then we can do a lot better than 'kvmap' :)
--
-- This codec assumes that 'Key.toText' and 'Key.fromText' is monotonic, which should be because
-- as of @aeson-2.x.x.x@, 'Key.Key' is just a newtype wrapper over 'Text' and 'Ord'
-- is either derived or newtype-derived, in both cases, perfectly safe to run it
-- on a 'Map.mapKeysMonotonic'
--
-- Aeson manages this with a complex definition of @FromJSONKeyFunction@, which does some
-- magic when the right constructor is chosen. Tagliatelle does no magic, therefore,
-- we expose this specialised codec.
kvmapText :: Codec v -> Codec (Map Text v)
{-# INLINE kvmapText #-}
kvmapText Codec {..} =
  Codec
    { codecToEncoding = \m -> Enc.dict Enc.text codecToEncoding Map.foldrWithKey m,
      codecToValue = \m ->
        Aeson.Object $
          -- KeyMap.fromMap is just coerce when Aeson is built with ordered-keymap, which it is, by default.
          KeyMap.fromMap $
            fmap codecToValue $
              Map.mapKeysMonotonic Key.fromText m,
      codecFromJSON =
        Aeson.withObject "kvmapText" $
          fmap (Map.mapKeysMonotonic Key.toText)
            . Map.traverseWithKey (\k v -> codecFromJSON v Aeson.<?> Aeson.Key k)
            . KeyMap.toMap,
      codecSchema = do
        ref <- declareSchemaRef $ codecSchema
        pure $
          OA.NamedSchema Nothing $
            mempty
              & OA.type_
                .~ Just OA.OpenApiObject
              & OA.additionalProperties
                .~ Just (OA.AdditionalPropertiesSchema ref)
    }

-- * Primitives

-- | Lifts a type for which we have a 'ToJSON', 'FromJSON' and a 'OA.NamedSchema' into
-- a codec. This should be used for primitive types, otherwise you'd be forfeiting
-- the fusing benefits from tagliatelle.
primitive :: (ToJSON a, FromJSON a) => OA.NamedSchema -> Codec a
{-# INLINE primitive #-}
primitive ns =
  Codec
    { codecToEncoding = Aeson.toEncoding,
      codecToValue = Aeson.toJSON,
      codecFromJSON = Aeson.parseJSON,
      codecSchema = pure ns
    }

instance HasCodec Bool where codec = bool

-- | Codec for booleans
bool :: Codec Bool
bool = primitive $ OA.NamedSchema Nothing (mempty & OA.type_ .~ Just OA.OpenApiBoolean)

instance HasCodec Int where codec = int

-- | Codec for ints
int :: Codec Int
int =
  primitive $
    OA.NamedSchema
      Nothing
      ( mempty
          & OA.type_ .~ Just OA.OpenApiInteger
          & OA.format .~ Just "int"
          & OA.default_ .~ Just (Aeson.toJSON (7 :: Int))
      )

instance HasCodec Int32 where codec = int32

-- | Codec for 'Int32'
int32 :: Codec Int32
int32 =
  primitive $
    OA.NamedSchema
      Nothing
      ( mempty
          & OA.type_ .~ Just OA.OpenApiInteger
          & OA.format .~ Just "int32"
          & OA.default_ .~ Just (Aeson.toJSON (7 :: Int32))
      )

instance HasCodec Int64 where codec = int64

-- | Codec for 'Int64'
int64 :: Codec Int64
int64 =
  primitive $
    OA.NamedSchema
      Nothing
      ( mempty
          & OA.type_ .~ Just OA.OpenApiInteger
          & OA.format .~ Just "int64"
          & OA.default_ .~ Just (Aeson.toJSON (7 :: Int64))
      )

instance HasCodec Integer where codec = integer

-- | Codec for 'Integer'
integer :: Codec Integer
integer =
  primitive $
    OA.NamedSchema
      Nothing
      ( mempty
          & OA.type_ .~ Just OA.OpenApiInteger
          & OA.default_ .~ Just (Aeson.toJSON (7 :: Integer))
      )

instance HasCodec Double where codec = double

-- | Codec for 'Double'
double :: Codec Double
double =
  primitive $
    OA.NamedSchema
      Nothing
      ( mempty
          & OA.type_ .~ Just OA.OpenApiNumber
          & OA.format .~ Just "double"
          & OA.default_ .~ Just (Aeson.toJSON (4.25 :: Double))
      )

instance HasCodec Float where codec = float

-- | Codec for 'Float
float :: Codec Float
float =
  primitive $
    OA.NamedSchema
      Nothing
      ( mempty
          & OA.type_ .~ Just OA.OpenApiNumber
          & OA.format .~ Just "float"
          & OA.default_ .~ Just (Aeson.toJSON (4.25 :: Float))
      )

instance HasCodec Text where codec = text

-- | Codec for 'Text', adds an example value making it clear this accepts utf8 text.
text :: Codec Text
text =
  primitive $
    OA.NamedSchema
      Nothing
      ( mempty
          & OA.type_ .~ Just OA.OpenApiString
          & OA.default_ .~ Just (Aeson.String "utf8 text 🌍")
      )

instance {-# OVERLAPPING #-} HasCodec String where codec = string

-- | Codec for 'String, adds an example value making it clear this accepts only ASCII chars.
string :: Codec String
string =
  primitive $
    OA.NamedSchema
      Nothing
      ( mempty
          & OA.type_ .~ Just OA.OpenApiString
          & OA.default_ .~ Just (Aeson.String "ascii string")
      )