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

module Autodocodec.Yaml.Encode where

import qualified Autodocodec.Aeson.Compat as Compat
import Autodocodec.Aeson.Encode
import Autodocodec.Class
import Autodocodec.Codec
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

newtype AutodocodecYaml a = AutodocodecYaml {forall a. AutodocodecYaml a -> a
unAutodocodecYaml :: a}

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