{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Autodocodec.Class where

import Autodocodec.Codec
import Data.Aeson (FromJSONKey, ToJSONKey)
import qualified Data.Aeson as JSON
#if MIN_VERSION_aeson(2,0,0)
import Data.Aeson.KeyMap (KeyMap)
#endif
import Data.HashMap.Strict (HashMap)
import Data.Hashable (Hashable)
import Data.Int
import Data.List.NonEmpty (NonEmpty (..))
import Data.Map (Map)
import Data.Scientific
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text.Lazy as LT
import Data.Time
import Data.Word

-- | A class for values which have a canonical codec.
--
-- There are no formal laws for this class.
-- If you really want a law, it should be "Whomever uses the 'codec' from your instance should not be surprised."
class HasCodec value where
  -- | A codec for a single value
  --
  -- See the sections on helper functions for implementing this for plenty of examples.
  codec :: JSONCodec value

  -- | A codec for a list of values
  --
  -- This is really only useful for cases like 'Char' and 'String'.
  -- We didn't call it 'listCodec' so we could use that name for making a codec for a list of values from a single codec instead.
  listCodecForStringCompatibility :: JSONCodec [value]
  listCodecForStringCompatibility = ValueCodec value value -> JSONCodec [value]
forall input output.
ValueCodec input output -> ValueCodec [input] [output]
listCodec ValueCodec value value
forall value. HasCodec value => ValueCodec value value
codec

  {-# MINIMAL codec #-}

instance HasCodec Bool where
  codec :: JSONCodec Bool
codec = JSONCodec Bool
boolCodec

instance HasCodec Ordering where
  codec :: JSONCodec Ordering
codec = JSONCodec Ordering
forall enum.
(Show enum, Eq enum, Enum enum, Bounded enum) =>
JSONCodec enum
shownBoundedEnumCodec

instance HasCodec Char where
  codec :: JSONCodec Char
codec =
    let parseChar :: [Char] -> Either [Char] (Item [Char])
parseChar = \case
          [] -> [Char] -> Either [Char] (Item [Char])
forall a b. a -> Either a b
Left [Char]
"Expected exactly 1 character, but got none."
          [Item [Char]
c] -> Item [Char] -> Either [Char] (Item [Char])
forall a b. b -> Either a b
Right Item [Char]
c
          [Char]
s -> [Char] -> Either [Char] (Item [Char])
forall a b. a -> Either a b
Left ([Char] -> Either [Char] (Item [Char]))
-> [Char] -> Either [Char] (Item [Char])
forall a b. (a -> b) -> a -> b
$ [Char]
"Expected exactly 1 character, but got more:" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
s
     in ([Char] -> Either [Char] Char)
-> (Char -> [Char]) -> JSONCodec [Char] -> JSONCodec Char
forall oldOutput newOutput newInput oldInput context.
(oldOutput -> Either [Char] newOutput)
-> (newInput -> oldInput)
-> Codec context oldInput oldOutput
-> Codec context newInput newOutput
bimapCodec [Char] -> Either [Char] Char
[Char] -> Either [Char] (Item [Char])
parseChar (Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: []) JSONCodec [Char]
stringCodec
  listCodecForStringCompatibility :: JSONCodec [Char]
listCodecForStringCompatibility = JSONCodec [Char]
stringCodec

instance HasCodec Text where
  codec :: JSONCodec Text
codec = JSONCodec Text
textCodec

instance HasCodec LT.Text where
  codec :: JSONCodec Text
codec = (Text -> Text)
-> (Text -> Text) -> JSONCodec Text -> JSONCodec Text
forall oldOutput newOutput newInput oldInput context.
(oldOutput -> newOutput)
-> (newInput -> oldInput)
-> Codec context oldInput oldOutput
-> Codec context newInput newOutput
dimapCodec Text -> Text
LT.fromStrict Text -> Text
LT.toStrict JSONCodec Text
textCodec

instance HasCodec Scientific where
  codec :: JSONCodec Scientific
codec = JSONCodec Scientific
scientificCodec

instance HasCodec Int where
  codec :: JSONCodec Int
codec = JSONCodec Int
forall i. (Integral i, Bounded i) => JSONCodec i
boundedIntegralCodec

instance HasCodec Int8 where
  codec :: JSONCodec Int8
codec = JSONCodec Int8
forall i. (Integral i, Bounded i) => JSONCodec i
boundedIntegralCodec

instance HasCodec Int16 where
  codec :: JSONCodec Int16
codec = JSONCodec Int16
forall i. (Integral i, Bounded i) => JSONCodec i
boundedIntegralCodec

instance HasCodec Int32 where
  codec :: JSONCodec Int32
codec = JSONCodec Int32
forall i. (Integral i, Bounded i) => JSONCodec i
boundedIntegralCodec

instance HasCodec Int64 where
  codec :: JSONCodec Int64
codec = JSONCodec Int64
forall i. (Integral i, Bounded i) => JSONCodec i
boundedIntegralCodec

instance HasCodec Word where
  codec :: JSONCodec Word
codec = JSONCodec Word
forall i. (Integral i, Bounded i) => JSONCodec i
boundedIntegralCodec

instance HasCodec Word8 where
  codec :: JSONCodec Word8
codec = JSONCodec Word8
forall i. (Integral i, Bounded i) => JSONCodec i
boundedIntegralCodec

instance HasCodec Word16 where
  codec :: JSONCodec Word16
codec = JSONCodec Word16
forall i. (Integral i, Bounded i) => JSONCodec i
boundedIntegralCodec

instance HasCodec Word32 where
  codec :: JSONCodec Word32
codec = JSONCodec Word32
forall i. (Integral i, Bounded i) => JSONCodec i
boundedIntegralCodec

instance HasCodec Word64 where
  codec :: JSONCodec Word64
codec = JSONCodec Word64
forall i. (Integral i, Bounded i) => JSONCodec i
boundedIntegralCodec

instance HasCodec JSON.Value where
  codec :: JSONCodec Value
codec = JSONCodec Value
ValueCodec

instance HasCodec a => HasCodec (Maybe a) where
  codec :: JSONCodec (Maybe a)
codec = ValueCodec a a -> JSONCodec (Maybe a)
forall input output.
ValueCodec input output -> ValueCodec (Maybe input) (Maybe output)
maybeCodec ValueCodec a a
forall value. HasCodec value => ValueCodec value value
codec

instance (HasCodec l, HasCodec r) => HasCodec (Either l r) where
  codec :: JSONCodec (Either l r)
codec =
    Codec Value l l -> Codec Value r r -> JSONCodec (Either l r)
forall context input1 output1 input2 output2.
Codec context input1 output1
-> Codec context input2 output2
-> Codec context (Either input1 input2) (Either output1 output2)
disjointEitherCodec
      (Maybe Text -> ObjectCodec l l -> Codec Value l l
forall input output.
Maybe Text -> ObjectCodec input output -> ValueCodec input output
ObjectOfCodec Maybe Text
forall a. Maybe a
Nothing (Text -> ObjectCodec l l
forall output. HasCodec output => Text -> ObjectCodec output output
requiredField' Text
"Left"))
      (Maybe Text -> ObjectCodec r r -> Codec Value r r
forall input output.
Maybe Text -> ObjectCodec input output -> ValueCodec input output
ObjectOfCodec Maybe Text
forall a. Maybe a
Nothing (Text -> ObjectCodec r r
forall output. HasCodec output => Text -> ObjectCodec output output
requiredField' Text
"Right"))

instance HasCodec a => HasCodec [a] where
  codec :: JSONCodec [a]
codec = JSONCodec [a]
forall a. HasCodec a => JSONCodec [a]
listCodecForStringCompatibility

instance HasCodec a => HasCodec (NonEmpty a) where
  codec :: JSONCodec (NonEmpty a)
codec = ValueCodec a a -> JSONCodec (NonEmpty a)
forall input output.
ValueCodec input output
-> ValueCodec (NonEmpty input) (NonEmpty output)
nonEmptyCodec ValueCodec a a
forall value. HasCodec value => ValueCodec value value
codec

instance (Ord a, HasCodec a) => HasCodec (Set a) where
  codec :: JSONCodec (Set a)
codec = ([a] -> Set a)
-> (Set a -> [a]) -> Codec Value [a] [a] -> JSONCodec (Set a)
forall oldOutput newOutput newInput oldInput context.
(oldOutput -> newOutput)
-> (newInput -> oldInput)
-> Codec context oldInput oldOutput
-> Codec context newInput newOutput
dimapCodec [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList Set a -> [a]
forall a. Set a -> [a]
S.toList Codec Value [a] [a]
forall value. HasCodec value => ValueCodec value value
codec

instance (Ord k, FromJSONKey k, ToJSONKey k, HasCodec v) => HasCodec (Map k v) where
  codec :: JSONCodec (Map k v)
codec = JSONCodec v -> JSONCodec (Map k v)
forall k v.
(Ord k, FromJSONKey k, ToJSONKey k) =>
JSONCodec v -> JSONCodec (Map k v)
MapCodec JSONCodec v
forall value. HasCodec value => ValueCodec value value
codec

instance (Eq k, Hashable k, FromJSONKey k, ToJSONKey k, HasCodec v) => HasCodec (HashMap k v) where
  codec :: JSONCodec (HashMap k v)
codec = JSONCodec v -> JSONCodec (HashMap k v)
forall k v.
(Eq k, Hashable k, FromJSONKey k, ToJSONKey k) =>
JSONCodec v -> JSONCodec (HashMap k v)
HashMapCodec JSONCodec v
forall value. HasCodec value => ValueCodec value value
codec

#if MIN_VERSION_aeson(2,0,0)
instance HasCodec v => HasCodec (KeyMap v) where
  codec :: JSONCodec (KeyMap v)
codec = JSONCodec v -> JSONCodec (KeyMap v)
forall v. JSONCodec v -> JSONCodec (KeyMap v)
keyMapCodec JSONCodec v
forall value. HasCodec value => ValueCodec value value
codec
#endif

-- TODO make these instances better once aeson exposes its @Data.Aeson.Parser.Time@ or @Data.Attoparsec.Time@ modules.
instance HasCodec Day where
  codec :: JSONCodec Day
codec = Text -> JSONCodec Day
forall a. (FromJSON a, ToJSON a) => Text -> JSONCodec a
codecViaAeson Text
"Day"

instance HasCodec LocalTime where
  codec :: JSONCodec LocalTime
codec = Text -> JSONCodec LocalTime
forall a. (FromJSON a, ToJSON a) => Text -> JSONCodec a
codecViaAeson Text
"LocalTime"

instance HasCodec UTCTime where
  codec :: JSONCodec UTCTime
codec = Text -> JSONCodec UTCTime
forall a. (FromJSON a, ToJSON a) => Text -> JSONCodec a
codecViaAeson Text
"LocalTime"

instance HasCodec TimeOfDay where
  codec :: JSONCodec TimeOfDay
codec = Text -> JSONCodec TimeOfDay
forall a. (FromJSON a, ToJSON a) => Text -> JSONCodec a
codecViaAeson Text
"TimeOfDay"

instance HasCodec ZonedTime where
  codec :: JSONCodec ZonedTime
codec = Text -> JSONCodec ZonedTime
forall a. (FromJSON a, ToJSON a) => Text -> JSONCodec a
codecViaAeson Text
"ZonedTime"

instance HasCodec NominalDiffTime where
  codec :: JSONCodec NominalDiffTime
codec = (Scientific -> NominalDiffTime)
-> (NominalDiffTime -> Scientific)
-> JSONCodec Scientific
-> JSONCodec NominalDiffTime
forall oldOutput newOutput newInput oldInput context.
(oldOutput -> newOutput)
-> (newInput -> oldInput)
-> Codec context oldInput oldOutput
-> Codec context newInput newOutput
dimapCodec Scientific -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime -> Scientific
forall a b. (Real a, Fractional b) => a -> b
realToFrac (JSONCodec Scientific
forall value. HasCodec value => ValueCodec value value
codec :: JSONCodec Scientific)

instance HasCodec DiffTime where
  codec :: JSONCodec DiffTime
codec = (Scientific -> DiffTime)
-> (DiffTime -> Scientific)
-> JSONCodec Scientific
-> JSONCodec DiffTime
forall oldOutput newOutput newInput oldInput context.
(oldOutput -> newOutput)
-> (newInput -> oldInput)
-> Codec context oldInput oldOutput
-> Codec context newInput newOutput
dimapCodec Scientific -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac DiffTime -> Scientific
forall a b. (Real a, Fractional b) => a -> b
realToFrac (JSONCodec Scientific
forall value. HasCodec value => ValueCodec value value
codec :: JSONCodec Scientific)

-- | A required field
--
-- During decoding, the field must be in the object.
--
-- During encoding, the field will always be in the object.
--
-- See 'requiredFieldWith'
requiredField ::
  HasCodec output =>
  -- | Key
  Text ->
  -- | Documentation
  Text ->
  ObjectCodec output output
requiredField :: Text -> Text -> ObjectCodec output output
requiredField Text
key = Text
-> ValueCodec output output -> Text -> ObjectCodec output output
forall input output.
Text -> ValueCodec input output -> Text -> ObjectCodec input output
requiredFieldWith Text
key ValueCodec output output
forall value. HasCodec value => ValueCodec value value
codec

-- | Like 'requiredField', but without documentation
requiredField' ::
  HasCodec output =>
  -- | Key
  Text ->
  ObjectCodec output output
requiredField' :: Text -> ObjectCodec output output
requiredField' Text
key = Text -> ValueCodec output output -> ObjectCodec output output
forall input output.
Text -> ValueCodec input output -> ObjectCodec input output
requiredFieldWith' Text
key ValueCodec output output
forall value. HasCodec value => ValueCodec value value
codec

-- | An optional field
--
-- During decoding, the field may be in the object. 'Nothing' will be parsed otherwise.
--
-- During encoding, the field will be in the object if it is not 'Nothing', and omitted otherwise.
--
-- See 'optionalFieldWith'
optionalField ::
  HasCodec output =>
  -- | Key
  Text ->
  -- | Documentation
  Text ->
  ObjectCodec (Maybe output) (Maybe output)
optionalField :: Text -> Text -> ObjectCodec (Maybe output) (Maybe output)
optionalField Text
key = Text
-> ValueCodec output output
-> Text
-> ObjectCodec (Maybe output) (Maybe output)
forall input output.
Text
-> ValueCodec input output
-> Text
-> ObjectCodec (Maybe input) (Maybe output)
optionalFieldWith Text
key ValueCodec output output
forall value. HasCodec value => ValueCodec value value
codec

-- | Like 'optionalField', but without documentation
optionalField' ::
  HasCodec output =>
  -- | Key
  Text ->
  ObjectCodec (Maybe output) (Maybe output)
optionalField' :: Text -> ObjectCodec (Maybe output) (Maybe output)
optionalField' Text
key = Text
-> ValueCodec output output
-> ObjectCodec (Maybe output) (Maybe output)
forall input output.
Text
-> ValueCodec input output
-> ObjectCodec (Maybe input) (Maybe output)
optionalFieldWith' Text
key ValueCodec output output
forall value. HasCodec value => ValueCodec value value
codec

-- | An optional field with a default value
--
-- During decoding, the field may be in the object. The default value will be parsed otherwise.
--
-- During encoding, the field will be in the object. The default value is ignored.
--
-- The shown version of the default value will appear in the documentation.
optionalFieldWithDefault ::
  (HasCodec output) =>
  -- | Key
  Text ->
  -- | Default value
  output ->
  -- | Documentation
  Text ->
  ObjectCodec output output
optionalFieldWithDefault :: Text -> output -> Text -> ObjectCodec output output
optionalFieldWithDefault Text
key output
defaultValue Text
doc = Text
-> JSONCodec output -> output -> Text -> ObjectCodec output output
forall output.
Text
-> JSONCodec output -> output -> Text -> ObjectCodec output output
optionalFieldWithDefaultWith Text
key JSONCodec output
forall value. HasCodec value => ValueCodec value value
codec output
defaultValue Text
doc

-- | Like 'optionalFieldWithDefault', but without documentation
optionalFieldWithDefault' ::
  (HasCodec output) =>
  -- | Key
  Text ->
  -- | Default value
  output ->
  ObjectCodec output output
optionalFieldWithDefault' :: Text -> output -> ObjectCodec output output
optionalFieldWithDefault' Text
key output
defaultValue = Text -> JSONCodec output -> output -> ObjectCodec output output
forall output.
Text -> JSONCodec output -> output -> ObjectCodec output output
optionalFieldWithDefaultWith' Text
key JSONCodec output
forall value. HasCodec value => ValueCodec value value
codec output
defaultValue

-- | 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 in the object if it is not 'Nothing', and omitted otherwise.
optionalFieldOrNull ::
  forall output.
  HasCodec output =>
  -- | Key
  Text ->
  -- | Documentation
  Text ->
  ObjectCodec (Maybe output) (Maybe output)
optionalFieldOrNull :: Text -> Text -> ObjectCodec (Maybe output) (Maybe output)
optionalFieldOrNull Text
key Text
doc = ObjectCodec (Maybe (Maybe output)) (Maybe (Maybe output))
-> ObjectCodec (Maybe output) (Maybe output)
forall input output.
ObjectCodec (Maybe (Maybe input)) (Maybe (Maybe output))
-> ObjectCodec (Maybe input) (Maybe output)
orNullHelper (ObjectCodec (Maybe (Maybe output)) (Maybe (Maybe output))
 -> ObjectCodec (Maybe output) (Maybe output))
-> ObjectCodec (Maybe (Maybe output)) (Maybe (Maybe output))
-> ObjectCodec (Maybe output) (Maybe output)
forall a b. (a -> b) -> a -> b
$ Text
-> ValueCodec (Maybe output) (Maybe output)
-> Maybe Text
-> ObjectCodec (Maybe (Maybe output)) (Maybe (Maybe output))
forall input output.
Text
-> ValueCodec input output
-> Maybe Text
-> ObjectCodec (Maybe input) (Maybe output)
OptionalKeyCodec Text
key (ValueCodec output output
-> ValueCodec (Maybe output) (Maybe output)
forall input output.
ValueCodec input output -> ValueCodec (Maybe input) (Maybe output)
maybeCodec ValueCodec output output
forall value. HasCodec value => ValueCodec value value
codec) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
doc)

-- | Like 'optionalFieldOrNull', but without documentation
optionalFieldOrNull' ::
  forall output.
  HasCodec output =>
  -- | Key
  Text ->
  ObjectCodec (Maybe output) (Maybe output)
optionalFieldOrNull' :: Text -> ObjectCodec (Maybe output) (Maybe output)
optionalFieldOrNull' Text
key = ObjectCodec (Maybe (Maybe output)) (Maybe (Maybe output))
-> ObjectCodec (Maybe output) (Maybe output)
forall input output.
ObjectCodec (Maybe (Maybe input)) (Maybe (Maybe output))
-> ObjectCodec (Maybe input) (Maybe output)
orNullHelper (ObjectCodec (Maybe (Maybe output)) (Maybe (Maybe output))
 -> ObjectCodec (Maybe output) (Maybe output))
-> ObjectCodec (Maybe (Maybe output)) (Maybe (Maybe output))
-> ObjectCodec (Maybe output) (Maybe output)
forall a b. (a -> b) -> a -> b
$ Text
-> ValueCodec (Maybe output) (Maybe output)
-> Maybe Text
-> ObjectCodec (Maybe (Maybe output)) (Maybe (Maybe output))
forall input output.
Text
-> ValueCodec input output
-> Maybe Text
-> ObjectCodec (Maybe input) (Maybe output)
OptionalKeyCodec Text
key (ValueCodec output output
-> ValueCodec (Maybe output) (Maybe output)
forall input output.
ValueCodec input output -> ValueCodec (Maybe input) (Maybe output)
maybeCodec ValueCodec output output
forall value. HasCodec value => ValueCodec value value
codec) Maybe Text
forall a. Maybe a
Nothing

optionalFieldWithOmittedDefault ::
  (Eq output, HasCodec output) =>
  -- | Key
  Text ->
  -- | Default value
  output ->
  -- | Documentation
  Text ->
  ObjectCodec output output
optionalFieldWithOmittedDefault :: Text -> output -> Text -> ObjectCodec output output
optionalFieldWithOmittedDefault Text
key output
defaultValue Text
doc = Text
-> JSONCodec output -> output -> Text -> ObjectCodec output output
forall output.
Eq output =>
Text
-> JSONCodec output -> output -> Text -> ObjectCodec output output
optionalFieldWithOmittedDefaultWith Text
key JSONCodec output
forall value. HasCodec value => ValueCodec value value
codec output
defaultValue Text
doc

optionalFieldWithOmittedDefault' ::
  (Eq output, HasCodec output) =>
  -- | Key
  Text ->
  -- | Default value
  output ->
  ObjectCodec output output
optionalFieldWithOmittedDefault' :: Text -> output -> ObjectCodec output output
optionalFieldWithOmittedDefault' Text
key output
defaultValue = Text -> JSONCodec output -> output -> ObjectCodec output output
forall output.
Eq output =>
Text -> JSONCodec output -> output -> ObjectCodec output output
optionalFieldWithOmittedDefaultWith' Text
key JSONCodec output
forall value. HasCodec value => ValueCodec value value
codec output
defaultValue

optionalFieldOrNullWithOmittedDefault ::
  (Eq output, HasCodec output) =>
  -- | Key
  Text ->
  -- | Default value
  output ->
  -- | Documentation
  Text ->
  ObjectCodec output output
optionalFieldOrNullWithOmittedDefault :: Text -> output -> Text -> ObjectCodec output output
optionalFieldOrNullWithOmittedDefault Text
key output
defaultValue Text
doc = Text
-> JSONCodec output -> output -> Text -> ObjectCodec output output
forall output.
Eq output =>
Text
-> JSONCodec output -> output -> Text -> ObjectCodec output output
optionalFieldOrNullWithOmittedDefaultWith Text
key JSONCodec output
forall value. HasCodec value => ValueCodec value value
codec output
defaultValue Text
doc

optionalFieldOrNullWithOmittedDefault' ::
  (Eq output, HasCodec output) =>
  -- | Key
  Text ->
  -- | Default value
  output ->
  ObjectCodec output output
optionalFieldOrNullWithOmittedDefault' :: Text -> output -> ObjectCodec output output
optionalFieldOrNullWithOmittedDefault' Text
key output
defaultValue = Text -> JSONCodec output -> output -> ObjectCodec output output
forall output.
Eq output =>
Text -> JSONCodec output -> output -> ObjectCodec output output
optionalFieldOrNullWithOmittedDefaultWith' Text
key JSONCodec output
forall value. HasCodec value => ValueCodec value value
codec output
defaultValue