{-# 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 :: 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 :: 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 :: 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
a :: Bool)
      StringCodec Maybe Text
_ -> Text -> YamlBuilder
Yaml.string (a
Text
a :: Text)
      NumberCodec Maybe Text
_ Maybe NumberBounds
_ -> Scientific -> YamlBuilder
yamlNumber (a
Scientific
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
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)
      HashMapCodec JSONCodec v
c -> Value -> ValueCodec Value Value -> YamlBuilder
forall a void. a -> ValueCodec a void -> YamlBuilder
go (ValueCodec (HashMap k v) (HashMap k v) -> HashMap k v -> Value
forall a void. ValueCodec a void -> a -> Value
toJSONVia (JSONCodec v -> ValueCodec (HashMap k v) (HashMap k v)
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
HashMap k v
a) ValueCodec Value Value
ValueCodec -- This may be optimisable?
      MapCodec JSONCodec v
c -> Value -> ValueCodec Value Value -> YamlBuilder
forall a void. a -> ValueCodec a void -> YamlBuilder
go (ValueCodec (Map k v) (Map k v) -> Map k v -> Value
forall a void. ValueCodec a void -> a -> Value
toJSONVia (JSONCodec v -> ValueCodec (Map k v) (Map k v)
forall k v.
(Ord k, FromJSONKey k, ToJSONKey k) =>
JSONCodec v -> Codec Value (Map k v) (Map k v)
MapCodec JSONCodec v
c) a
Map k v
a) ValueCodec Value Value
ValueCodec -- This may be optimisable?
      ValueCodec a void
ValueCodec -> Value -> YamlBuilder
yamlValue (a
Value
a :: JSON.Value)
      EqCodec a
value JSONCodec a
c -> a -> JSONCodec a -> YamlBuilder
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 -> 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
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 :: 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
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 input1 output1.
Text
-> ValueCodec input1 output1
-> Maybe Text
-> Codec (KeyMap Value) (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 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
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 input.
Text
-> ValueCodec input input
-> input
-> Maybe Text
-> Codec (KeyMap Value) input input
OptionalKeyWithDefaultCodec Text
k ValueCodec a a
c a
defaultValue Maybe Text
mDoc)
      BimapCodec oldOutput -> Either String void
_ a -> oldInput
g Codec (KeyMap Value) oldInput oldOutput
c -> oldInput
-> Codec (KeyMap Value) oldInput oldOutput -> [(Text, YamlBuilder)]
forall a void. a -> ObjectCodec a void -> [(Text, YamlBuilder)]
goObject (a -> oldInput
g a
a) Codec (KeyMap Value) oldInput oldOutput
c
      EitherCodec Union
_ Codec (KeyMap Value) input1 output1
c1 Codec (KeyMap Value) input2 output2
c2 -> case (a
Either input1 input2
a :: Either _ _) of
        Left input1
a1 -> input1
-> Codec (KeyMap Value) input1 output1 -> [(Text, YamlBuilder)]
forall a void. a -> ObjectCodec a void -> [(Text, YamlBuilder)]
goObject input1
a1 Codec (KeyMap Value) input1 output1
c1
        Right input2
a2 -> input2
-> Codec (KeyMap Value) input2 output2 -> [(Text, YamlBuilder)]
forall a void. a -> ObjectCodec a void -> [(Text, YamlBuilder)]
goObject input2
a2 Codec (KeyMap Value) 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 :: KeyMap Value -> YamlBuilder
yamlObject KeyMap Value
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 (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) -> KeyMap Value -> KeyMap YamlBuilder
forall v1 v2. (v1 -> v2) -> KeyMap v1 -> KeyMap v2
Compat.map Value -> YamlBuilder
yamlValue (KeyMap Value
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 KeyMap Value
o -> KeyMap Value -> YamlBuilder
yamlObject KeyMap Value
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