{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# OPTIONS_GHC -fno-warn-partial-type-signatures -fno-warn-orphans #-}

module Autodocodec.Yaml.Encode where

import qualified Autodocodec.Aeson.Compat as Compat
import Autodocodec.Aeson.Encode
import Autodocodec.Class
import Autodocodec.Codec
import Autodocodec.DerivingVia
import Control.Arrow (first)
import Data.Scientific
import Data.Text (Text)
import qualified Data.Text as T
import Data.Vector (Vector)
import qualified Data.Vector as V
import qualified Data.Yaml as JSON
import Data.Yaml.Builder as Yaml

-- | Implement 'Yaml.toYaml' using a type's codec
toYamlViaCodec :: HasCodec a => a -> YamlBuilder
toYamlViaCodec :: forall a. HasCodec a => a -> YamlBuilder
toYamlViaCodec = forall a void. ValueCodec a void -> a -> YamlBuilder
toYamlVia forall value. HasCodec value => JSONCodec value
codec

-- | Implement 'Yaml.toYaml' using a given codec
toYamlVia :: ValueCodec a void -> a -> YamlBuilder
toYamlVia :: forall a void. ValueCodec a void -> a -> YamlBuilder
toYamlVia = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a void. a -> ValueCodec a void -> YamlBuilder
go
  where
    -- We use type-annotations here for readability of type information that is
    -- gathered to case-matching on GADTs, they aren't strictly necessary.
    go :: a -> ValueCodec a void -> YamlBuilder
    go :: forall a void. a -> ValueCodec a void -> YamlBuilder
go a
a = \case
      ValueCodec a void
NullCodec -> YamlBuilder
Yaml.null
      BoolCodec Maybe Text
_ -> Bool -> YamlBuilder
Yaml.bool (a
a :: Bool)
      StringCodec Maybe Text
_ -> Text -> YamlBuilder
Yaml.string (a
a :: Text)
      NumberCodec Maybe Text
_ Maybe NumberBounds
_ -> Scientific -> YamlBuilder
yamlNumber (a
a :: Scientific)
      ArrayOfCodec Maybe Text
_ ValueCodec input1 output1
c -> [YamlBuilder] -> YamlBuilder
Yaml.array (forall a b. (a -> b) -> [a] -> [b]
map (forall a void. a -> ValueCodec a void -> YamlBuilder
`go` ValueCodec input1 output1
c) (forall a. Vector a -> [a]
V.toList (a
a :: Vector _)))
      ObjectOfCodec Maybe Text
_ ObjectCodec a void
oc -> [(Text, YamlBuilder)] -> YamlBuilder
Yaml.mapping (forall a void. a -> ObjectCodec a void -> [(Text, YamlBuilder)]
goObject a
a ObjectCodec a void
oc)
      HashMapCodec JSONCodec v
c -> forall a void. a -> ValueCodec a void -> YamlBuilder
go (forall a void. ValueCodec a void -> a -> Value
toJSONVia (forall k v.
(Eq k, Hashable k, FromJSONKey k, ToJSONKey k) =>
JSONCodec v -> Codec Value (HashMap k v) (HashMap k v)
HashMapCodec JSONCodec v
c) a
a) Codec Value Value Value
ValueCodec -- This may be optimisable?
      MapCodec JSONCodec v
c -> forall a void. a -> ValueCodec a void -> YamlBuilder
go (forall a void. ValueCodec a void -> a -> Value
toJSONVia (forall k v.
(Ord k, FromJSONKey k, ToJSONKey k) =>
JSONCodec v -> Codec Value (Map k v) (Map k v)
MapCodec JSONCodec v
c) a
a) Codec Value Value Value
ValueCodec -- This may be optimisable?
      ValueCodec a void
ValueCodec -> Value -> YamlBuilder
yamlValue (a
a :: JSON.Value)
      EqCodec a
value JSONCodec a
c -> forall a void. a -> ValueCodec a void -> YamlBuilder
go a
value JSONCodec a
c
      BimapCodec oldOutput -> Either String void
_ a -> oldInput
g Codec Value oldInput oldOutput
c -> forall a void. a -> ValueCodec a void -> YamlBuilder
go (a -> oldInput
g a
a) Codec Value oldInput oldOutput
c
      EitherCodec Union
_ Codec Value input1 output1
c1 Codec Value input2 output2
c2 -> case (a
a :: Either _ _) of
        Left input1
a1 -> forall a void. a -> ValueCodec a void -> YamlBuilder
go input1
a1 Codec Value input1 output1
c1
        Right input2
a2 -> forall a void. a -> ValueCodec a void -> YamlBuilder
go input2
a2 Codec Value input2 output2
c2
      CommentCodec Text
_ ValueCodec a void
c -> forall a void. a -> ValueCodec a void -> YamlBuilder
go a
a ValueCodec a void
c
      ReferenceCodec Text
_ ValueCodec a void
c -> forall a void. a -> ValueCodec a void -> YamlBuilder
go a
a ValueCodec a void
c

    goObject :: a -> ObjectCodec a void -> [(Text, YamlBuilder)]
    goObject :: forall a void. a -> ObjectCodec a void -> [(Text, YamlBuilder)]
goObject a
a = \case
      RequiredKeyCodec Text
k ValueCodec a void
c Maybe Text
_ -> [(Text
k, forall a void. a -> ValueCodec a void -> YamlBuilder
go a
a ValueCodec a void
c)]
      OptionalKeyCodec Text
k ValueCodec input1 output1
c Maybe Text
_ -> case (a
a :: Maybe _) of
        Maybe input1
Nothing -> []
        Just input1
b -> [Text
k forall a. ToYaml a => Text -> a -> (Text, YamlBuilder)
Yaml..= forall a void. a -> ValueCodec a void -> YamlBuilder
go input1
b ValueCodec input1 output1
c]
      OptionalKeyWithDefaultCodec Text
k ValueCodec a a
c a
_ Maybe Text
mDoc -> forall a void. a -> ObjectCodec a void -> [(Text, YamlBuilder)]
goObject (forall a. a -> Maybe a
Just a
a) (forall input1 output1.
Text
-> ValueCodec input1 output1
-> Maybe Text
-> Codec Object (Maybe input1) (Maybe output1)
OptionalKeyCodec Text
k ValueCodec a a
c Maybe Text
mDoc)
      OptionalKeyWithOmittedDefaultCodec Text
k ValueCodec a a
c a
defaultValue Maybe Text
mDoc ->
        if a
a forall a. Eq a => a -> a -> Bool
== a
defaultValue
          then []
          else forall a void. a -> ObjectCodec a void -> [(Text, YamlBuilder)]
goObject a
a (forall input.
Text
-> ValueCodec input input
-> input
-> Maybe Text
-> Codec Object input input
OptionalKeyWithDefaultCodec Text
k ValueCodec a a
c a
defaultValue Maybe Text
mDoc)
      BimapCodec oldOutput -> Either String void
_ a -> oldInput
g Codec Object oldInput oldOutput
c -> forall a void. a -> ObjectCodec a void -> [(Text, YamlBuilder)]
goObject (a -> oldInput
g a
a) Codec Object oldInput oldOutput
c
      EitherCodec Union
_ Codec Object input1 output1
c1 Codec Object input2 output2
c2 -> case (a
a :: Either _ _) of
        Left input1
a1 -> forall a void. a -> ObjectCodec a void -> [(Text, YamlBuilder)]
goObject input1
a1 Codec Object input1 output1
c1
        Right input2
a2 -> forall a void. a -> ObjectCodec a void -> [(Text, YamlBuilder)]
goObject input2
a2 Codec Object input2 output2
c2
      DiscriminatedUnionCodec Text
propertyName a -> (Text, ObjectCodec a ())
m HashMap Text (Text, ObjectCodec Void void)
_ ->
        case a -> (Text, ObjectCodec a ())
m a
a of
          (Text
discriminatorValue, ObjectCodec a ()
c) ->
            (Text
propertyName, Text -> YamlBuilder
Yaml.string Text
discriminatorValue) forall a. a -> [a] -> [a]
: forall a void. a -> ObjectCodec a void -> [(Text, YamlBuilder)]
goObject a
a ObjectCodec a ()
c
      PureCodec void
_ -> []
      ApCodec ObjectCodec a (output1 -> void)
oc1 ObjectCodec a output1
oc2 -> forall a void. a -> ObjectCodec a void -> [(Text, YamlBuilder)]
goObject a
a ObjectCodec a (output1 -> void)
oc1 forall a. Semigroup a => a -> a -> a
<> forall a void. a -> ObjectCodec a void -> [(Text, YamlBuilder)]
goObject a
a ObjectCodec a output1
oc2

    -- Encode a 'Scientific' value 'safely' by refusing to encode values that would be enormous.
    yamlNumber :: Scientific -> YamlBuilder
    yamlNumber :: Scientific -> YamlBuilder
yamlNumber Scientific
s =
      if Scientific
s forall a. Ord a => a -> a -> Bool
> Scientific
1E1024 Bool -> Bool -> Bool
|| Scientific
s forall a. Ord a => a -> a -> Bool
< -Scientific
1E1024
        then Text -> YamlBuilder
Yaml.string forall a b. (a -> b) -> a -> b
$ Text
"Cannot encode super duper large numbers with toYaml: " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show Scientific
s)
        else Scientific -> YamlBuilder
Yaml.scientific Scientific
s

    -- Encode a 'JSON.Object'
    yamlObject :: JSON.Object -> YamlBuilder
    yamlObject :: Object -> YamlBuilder
yamlObject Object
a = [(Text, YamlBuilder)] -> YamlBuilder
Yaml.mapping forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Key -> Text
Compat.fromKey) forall a b. (a -> b) -> a -> b
$ forall v. KeyMap v -> [(Key, v)]
Compat.toList (forall v1 v2. (v1 -> v2) -> KeyMap v1 -> KeyMap v2
Compat.map Value -> YamlBuilder
yamlValue (Object
a :: JSON.Object))

    -- Encode a 'JSON.Value'
    yamlValue :: JSON.Value -> YamlBuilder
    yamlValue :: Value -> YamlBuilder
yamlValue = \case
      Value
JSON.Null -> YamlBuilder
Yaml.null
      JSON.Bool Bool
b -> Bool -> YamlBuilder
Yaml.bool Bool
b
      JSON.String Text
s -> Text -> YamlBuilder
Yaml.string Text
s
      JSON.Number Scientific
s -> Scientific -> YamlBuilder
yamlNumber Scientific
s
      JSON.Object Object
o -> Object -> YamlBuilder
yamlObject Object
o
      JSON.Array Array
v -> [YamlBuilder] -> YamlBuilder
Yaml.array forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Value -> YamlBuilder
yamlValue forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> [a]
V.toList Array
v

instance HasCodec a => ToYaml (Autodocodec a) where
  toYaml :: Autodocodec a -> YamlBuilder
toYaml = forall a. HasCodec a => a -> YamlBuilder
toYamlViaCodec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Autodocodec a -> a
unAutodocodec