{-# 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.Coerce (coerce)
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 = ValueCodec a a -> a -> YamlBuilder
forall a void. ValueCodec a void -> a -> YamlBuilder
toYamlVia ValueCodec a a
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 = (a -> ValueCodec a void -> YamlBuilder)
-> ValueCodec a void -> a -> YamlBuilder
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> ValueCodec a void -> YamlBuilder
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 -> Bool
forall a b. Coercible a b => a -> b
coerce a
a :: Bool)
      StringCodec Maybe Text
_ -> Text -> YamlBuilder
Yaml.string (a -> Text
forall a b. Coercible a b => a -> b
coerce a
a :: Text)
      IntegerCodec Maybe Text
_ Bounds Integer
_ -> Scientific -> YamlBuilder
Yaml.scientific (Scientific -> YamlBuilder) -> Scientific -> YamlBuilder
forall a b. (a -> b) -> a -> b
$ Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger (a -> Integer
forall a b. Coercible a b => a -> b
coerce a
a :: Integer)
      NumberCodec Maybe Text
_ Bounds Scientific
_ -> Scientific -> YamlBuilder
yamlNumber (a -> Scientific
forall a b. Coercible a b => a -> b
coerce a
a :: Scientific)
      ArrayOfCodec Maybe Text
_ ValueCodec input1 output1
c -> [YamlBuilder] -> YamlBuilder
Yaml.array ((input1 -> YamlBuilder) -> [input1] -> [YamlBuilder]
forall a b. (a -> b) -> [a] -> [b]
map (input1 -> ValueCodec input1 output1 -> YamlBuilder
forall a void. a -> ValueCodec a void -> YamlBuilder
`go` ValueCodec input1 output1
c) (Vector input1 -> [input1]
forall a. Vector a -> [a]
V.toList (a -> Vector input1
forall a b. Coercible a b => a -> b
coerce a
a :: Vector _)))
      ObjectOfCodec Maybe Text
_ ObjectCodec a void
oc -> [(Text, YamlBuilder)] -> YamlBuilder
Yaml.mapping (a -> ObjectCodec a void -> [(Text, YamlBuilder)]
forall a void. a -> ObjectCodec a void -> [(Text, YamlBuilder)]
goObject a
a ObjectCodec a void
oc)
      c :: ValueCodec a void
c@(HashMapCodec {}) -> Value -> ValueCodec Value Value -> YamlBuilder
forall a void. a -> ValueCodec a void -> YamlBuilder
go (ValueCodec a void -> a -> Value
forall a void. ValueCodec a void -> a -> Value
toJSONVia ValueCodec a void
c a
a) ValueCodec Value Value
valueCodec -- This may be optimisable?
      c :: ValueCodec a void
c@(MapCodec {}) -> Value -> ValueCodec Value Value -> YamlBuilder
forall a void. a -> ValueCodec a void -> YamlBuilder
go (ValueCodec a void -> a -> Value
forall a void. ValueCodec a void -> a -> Value
toJSONVia ValueCodec a void
c a
a) ValueCodec Value Value
valueCodec -- This may be optimisable?
      ValueCodec a void
ValueCodec -> Value -> YamlBuilder
yamlValue (a -> Value
forall a b. Coercible a b => a -> b
coerce a
a :: JSON.Value)
      EqCodec value
value JSONCodec value
c -> value -> JSONCodec value -> YamlBuilder
forall a void. a -> ValueCodec a void -> YamlBuilder
go value
value JSONCodec value
c
      BimapCodec oldOutput -> Either String void
_ a -> oldInput
g Codec Value oldInput oldOutput
c -> oldInput -> Codec Value oldInput oldOutput -> YamlBuilder
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 -> Either input1 input2
forall a b. Coercible a b => a -> b
coerce a
a :: Either _ _) of
        Left input1
a1 -> input1 -> Codec Value input1 output1 -> YamlBuilder
forall a void. a -> ValueCodec a void -> YamlBuilder
go input1
a1 Codec Value input1 output1
c1
        Right input2
a2 -> input2 -> Codec Value input2 output2 -> YamlBuilder
forall a void. a -> ValueCodec a void -> YamlBuilder
go input2
a2 Codec Value input2 output2
c2
      CommentCodec Text
_ ValueCodec a void
c -> a -> ValueCodec a void -> YamlBuilder
forall a void. a -> ValueCodec a void -> YamlBuilder
go a
a ValueCodec a void
c
      ReferenceCodec Text
_ ValueCodec a void
c -> a -> ValueCodec a void -> YamlBuilder
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, a -> ValueCodec a void -> YamlBuilder
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 -> Maybe input1
forall a b. Coercible a b => a -> b
coerce a
a :: Maybe _) of
        Maybe input1
Nothing -> []
        Just input1
b -> [Text
k Text -> YamlBuilder -> (Text, YamlBuilder)
forall a. ToYaml a => Text -> a -> (Text, YamlBuilder)
Yaml..= input1 -> ValueCodec input1 output1 -> YamlBuilder
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 -> Maybe a -> ObjectCodec (Maybe a) (Maybe a) -> [(Text, YamlBuilder)]
forall a void. a -> ObjectCodec a void -> [(Text, YamlBuilder)]
goObject (a -> Maybe a
forall a. a -> Maybe a
Just a
a) (Text
-> ValueCodec a a -> Maybe Text -> ObjectCodec (Maybe a) (Maybe a)
forall input output.
Text
-> ValueCodec input output
-> Maybe Text
-> ObjectCodec (Maybe input) (Maybe output)
optionalKeyCodec Text
k ValueCodec a a
c Maybe Text
mDoc)
      OptionalKeyWithOmittedDefaultCodec Text
k ValueCodec value value
c value
defaultValue Maybe Text
mDoc ->
        if a -> value
forall a b. Coercible a b => a -> b
coerce a
a value -> value -> Bool
forall a. Eq a => a -> a -> Bool
== value
defaultValue
          then []
          else a -> ObjectCodec a a -> [(Text, YamlBuilder)]
forall a void. a -> ObjectCodec a void -> [(Text, YamlBuilder)]
goObject a
a (Text -> ValueCodec a a -> a -> Maybe Text -> ObjectCodec a a
forall value.
Text
-> ValueCodec value value
-> value
-> Maybe Text
-> ObjectCodec value value
optionalKeyWithDefaultCodec Text
k (ValueCodec value value -> ValueCodec a a
forall a b. Coercible a b => a -> b
coerce ValueCodec value value
c) (value -> a
forall a b. Coercible a b => a -> b
coerce value
defaultValue) Maybe Text
mDoc)
      BimapCodec oldOutput -> Either String void
_ a -> oldInput
g Codec Object oldInput oldOutput
c -> oldInput
-> Codec Object oldInput oldOutput -> [(Text, YamlBuilder)]
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 -> Either input1 input2
forall a b. Coercible a b => a -> b
coerce a
a :: Either _ _) of
        Left input1
a1 -> input1 -> Codec Object input1 output1 -> [(Text, YamlBuilder)]
forall a void. a -> ObjectCodec a void -> [(Text, YamlBuilder)]
goObject input1
a1 Codec Object input1 output1
c1
        Right input2
a2 -> input2 -> Codec Object input2 output2 -> [(Text, YamlBuilder)]
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) (Text, YamlBuilder)
-> [(Text, YamlBuilder)] -> [(Text, YamlBuilder)]
forall a. a -> [a] -> [a]
: a -> ObjectCodec a () -> [(Text, YamlBuilder)]
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 -> a -> ObjectCodec a (output1 -> void) -> [(Text, YamlBuilder)]
forall a void. a -> ObjectCodec a void -> [(Text, YamlBuilder)]
goObject a
a ObjectCodec a (output1 -> void)
oc1 [(Text, YamlBuilder)]
-> [(Text, YamlBuilder)] -> [(Text, YamlBuilder)]
forall a. Semigroup a => a -> a -> a
<> a -> ObjectCodec a output1 -> [(Text, YamlBuilder)]
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 Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
> Scientific
1E1024 Bool -> Bool -> Bool
|| Scientific
s Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
< -Scientific
1E1024
        then Text -> YamlBuilder
Yaml.string (Text -> YamlBuilder) -> Text -> YamlBuilder
forall a b. (a -> b) -> a -> b
$ Text
"Cannot encode super duper large numbers with toYaml: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Scientific -> String
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 ([(Text, YamlBuilder)] -> YamlBuilder)
-> [(Text, YamlBuilder)] -> YamlBuilder
forall a b. (a -> b) -> a -> b
$ ((Key, YamlBuilder) -> (Text, YamlBuilder))
-> [(Key, YamlBuilder)] -> [(Text, YamlBuilder)]
forall a b. (a -> b) -> [a] -> [b]
map ((Key -> Text) -> (Key, YamlBuilder) -> (Text, YamlBuilder)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Key -> Text
Compat.fromKey) ([(Key, YamlBuilder)] -> [(Text, YamlBuilder)])
-> [(Key, YamlBuilder)] -> [(Text, YamlBuilder)]
forall a b. (a -> b) -> a -> b
$ KeyMap YamlBuilder -> [(Key, YamlBuilder)]
forall v. KeyMap v -> [(Key, v)]
Compat.toList ((Value -> YamlBuilder) -> Object -> KeyMap YamlBuilder
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 ([YamlBuilder] -> YamlBuilder) -> [YamlBuilder] -> YamlBuilder
forall a b. (a -> b) -> a -> b
$ (Value -> YamlBuilder) -> [Value] -> [YamlBuilder]
forall a b. (a -> b) -> [a] -> [b]
map Value -> YamlBuilder
yamlValue ([Value] -> [YamlBuilder]) -> [Value] -> [YamlBuilder]
forall a b. (a -> b) -> a -> b
$ Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
v

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