-- The instances for the value of aeson are orphans. No other package should
-- define them, because yamlet and this package have the same author.
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Use the t'Data.Aeson.FromJSON' and t'Data.Aeson.ToJSON' instances of aeson
-- with yamlet, for a type that has no 'FromYaml' and 'ToYaml' instances yet,
-- e.g. in a program that moves from the yaml package to yamlet.
--
-- The examples use these external imports:
--
-- >>> import Data.Aeson qualified as A
-- >>> import Data.Map.Strict qualified as M
-- >>> import Data.Text qualified as T
-- >>> import Data.Text.IO qualified as T
--
-- A value in t'ViaAeson' decodes and encodes with the
-- t'Data.Aeson.FromJSON' and t'Data.Aeson.ToJSON' instances:
--
-- >>> :{
-- data Server = Server {port :: Int, host :: T.Text}
--   deriving stock (Generic, Show)
--   deriving anyclass (A.FromJSON)
-- instance A.ToJSON Server where
--   toEncoding = A.genericToEncoding A.defaultOptions
-- :}
--
-- >>> Right (ViaAeson server) = decodeText @(ViaAeson Server) "port: 80\nhost: localhost\n"
--
-- >>> server
-- Server {port = 80, host = "localhost"}
--
-- >>> T.putStr (encodeText (ViaAeson server))
-- port: 80
-- host: localhost
--
-- A type with t'Data.Aeson.FromJSON' and t'Data.Aeson.ToJSON' instances can
-- derive its 'FromYaml' and 'ToYaml' instances via t'ViaAeson', e.g. in a
-- program that reads and writes both JSON and YAML and keeps one set of
-- instances. Such a type can be a field of a type with instances of its own:
--
-- >>> :{
-- newtype Address = Address T.Text
--   deriving stock (Show)
--   deriving newtype (A.FromJSON, A.ToJSON)
--   deriving (FromYaml, ToYaml) via ViaAeson Address
-- data Mail = Mail {from :: Address, to :: [Address]}
--   deriving stock (Generic, Show)
--   deriving anyclass (GenericYamlOptions)
--   deriving (FromYaml, ToYaml) via GenericYaml Mail
-- :}
--
-- >>> decodeText @Mail "from: a@example.com\nto: [b@example.com]\n"
-- Right (Mail {from = Address "a@example.com", to = [Address "b@example.com"]})
--
-- An error of a decoder of aeson points to the node that caused it:
--
-- >>> input = "- port: 80\n  host: a\n- port: http\n  host: b\n"
--
-- >>> T.putStr input
-- - port: 80
--   host: a
-- - port: http
--   host: b
--
-- >>> either printErrors print (decodeText @(ViaAeson [Server]) input)
-- input.yaml:3:9: [1].port: parsing Int failed, expected Number, but encountered String
--   |
-- 3 | - port: http
--   |         ^
--
-- The module also has the 'FromYaml' and 'ToYaml' instances for an aeson
-- t'Data.Aeson.Value', e.g. for a field that holds any data. They convert as
-- the section [Conversion]("Yamlet.Aeson#conversion") says:
--
-- >>> decodeText @A.Value "name: a\nports: [80, 443]\n"
-- Right (Object (fromList [("name",String "a"),("ports",Array [Number 80.0,Number 443.0])]))
--
-- = Order of keys
--
-- The encoder writes the keys of a mapping in the order of
-- 'Data.Aeson.toEncoding'. That is the order of the fields if the instance
-- defines 'Data.Aeson.toEncoding', e.g. with 'Data.Aeson.genericToEncoding' as
-- @Server@ above, or with 'Data.Aeson.TH.deriveJSON'. The default
-- 'Data.Aeson.toEncoding' goes through 'Data.Aeson.toJSON', so the keys come
-- in the order of an aeson object, which is sorted by default.
--
-- 'Data.Aeson.parseJSON' gets the keys in no order, because an aeson object
-- has none. To keep the order of a mapping, decode the mapping with a decoder
-- of yamlet. Its values can still decode via t'ViaAeson':
--
-- >>> :{
-- newtype Servers = Servers [(T.Text, Server)]
--   deriving stock (Show)
-- instance FromYaml Servers where
--   parseYaml = withMapping $ \o ->
--     Servers
--       <$> traverse
--         ( \(k, v) ->
--             (,) <$> parseYaml k <*> fmap (.value) (parseYaml @(ViaAeson Server) v)
--         )
--         (objectEntries o)
-- :}
--
-- >>> decodeText @Servers "web: {port: 80, host: a}\napi: {port: 81, host: b}\n"
-- Right (Servers [("web",Server {port = 80, host = "a"}),("api",Server {port = 81, host = "b"})])
--
-- 'Yamlet.decodeWithDocument' keeps the whole document with the decoded
-- value, e.g. to write the document back with a change.
--
-- = Conversion
--
-- #conversion#
-- A YAML document converts to an aeson t'Data.Aeson.Value' as follows:
--
-- * A key is the text of its scalar, e.g. @"0x10"@ for @0x10@ and @"~"@ for
--   @~@, as in the yaml package. Two keys with the same text are an error,
--   e.g. @1@ and @\"1\"@, which are different keys in YAML. A key that is a
--   collection is an error.
--
-- * A key @<<@ is an ordinary key, because the merge keys of YAML 1.1 are
--   not supported.
--
-- * @.inf@ and @-.inf@ are the strings @"+inf"@ and @"-inf"@, and @.nan@ is
--   null. The t'Data.Aeson.FromJSON' and t'Data.Aeson.ToJSON' instances for
--   t'Double' and t'Float' read and write these values.
--
-- * @-0.0@ is the number 0, because a t'Data.Scientific.Scientific' has no
--   negative zero.
--
-- * A number whose exponent in scientific notation is beyond the range
--   from -1000 to 1000, e.g. @1e1001@, is an error, as in yamlet. A
--   'Data.Aeson.Number' converts to YAML as aeson writes it in JSON: as an
--   integer if its 'Data.Scientific.base10Exponent' is from 0 to 1024,
--   otherwise in scientific notation. Thus @1e1001@ reads back as an
--   integer, but @1e1025@ and @1e-1001@ do not read back.
--
-- * A tag that is not of the core schema makes a scalar a string, e.g.
--   @!secret 123@ is the string @"123"@. The yaml package reads it as the
--   number 123. A collection with such a tag converts as without it, e.g.
--   @!point {x: 1}@ is the object @{"x": 1}@.
--
-- A t'Data.Aeson.FromJSON' instance can convert two different keys to the
-- same key and then keep only one of the pairs, as it does for JSON, e.g. @1@
-- and @1.0@ for a @Map Int@. The 'FromYaml' instances for maps reject such
-- keys.
--
-- >>> decodeText @(ViaAeson (M.Map Int T.Text)) "1: a\n1.0: b\n"
-- Right (ViaAeson {value = fromList [(1,"a")]})
--
-- An aeson t'Data.Aeson.Value' converts to YAML as aeson writes it in JSON,
-- e.g. the keys of a @Map Int@ are strings, which the encoder quotes because
-- they look like numbers:
--
-- >>> T.putStr (encodeText (ViaAeson (M.fromList @Int @T.Text [(1, "a")])))
-- '1': a
module Yamlet.Aeson
  ( ViaAeson (..)
  ) where

import Control.Monad
import Data.Aeson qualified as A
import Data.Aeson.Decoding.ByteString.Lazy
import Data.Aeson.Decoding.Tokens
import Data.Aeson.Key qualified as K
import Data.Aeson.KeyMap qualified as KM
import Data.Aeson.Types qualified as A
import Data.ByteString.Lazy.Char8 qualified as LBS8
import Data.List qualified as L
import Data.Map.Strict qualified as M
import Data.Scientific qualified as Sci
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Vector qualified as V
import Yamlet
import Yamlet.Syntax qualified as S

-- | A value that decodes and encodes with its t'Data.Aeson.FromJSON' and
-- t'Data.Aeson.ToJSON' instances. The field has no selector function, so read
-- it with record dot syntax, e.g. @(.value)@, or with a pattern.
newtype ViaAeson a = ViaAeson {forall a. ViaAeson a -> a
value :: a}
  deriving stock (ViaAeson a -> ViaAeson a -> Bool
(ViaAeson a -> ViaAeson a -> Bool)
-> (ViaAeson a -> ViaAeson a -> Bool) -> Eq (ViaAeson a)
forall a. Eq a => ViaAeson a -> ViaAeson a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => ViaAeson a -> ViaAeson a -> Bool
== :: ViaAeson a -> ViaAeson a -> Bool
$c/= :: forall a. Eq a => ViaAeson a -> ViaAeson a -> Bool
/= :: ViaAeson a -> ViaAeson a -> Bool
Eq, Eq (ViaAeson a)
Eq (ViaAeson a) =>
(ViaAeson a -> ViaAeson a -> Ordering)
-> (ViaAeson a -> ViaAeson a -> Bool)
-> (ViaAeson a -> ViaAeson a -> Bool)
-> (ViaAeson a -> ViaAeson a -> Bool)
-> (ViaAeson a -> ViaAeson a -> Bool)
-> (ViaAeson a -> ViaAeson a -> ViaAeson a)
-> (ViaAeson a -> ViaAeson a -> ViaAeson a)
-> Ord (ViaAeson a)
ViaAeson a -> ViaAeson a -> Bool
ViaAeson a -> ViaAeson a -> Ordering
ViaAeson a -> ViaAeson a -> ViaAeson a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (ViaAeson a)
forall a. Ord a => ViaAeson a -> ViaAeson a -> Bool
forall a. Ord a => ViaAeson a -> ViaAeson a -> Ordering
forall a. Ord a => ViaAeson a -> ViaAeson a -> ViaAeson a
$ccompare :: forall a. Ord a => ViaAeson a -> ViaAeson a -> Ordering
compare :: ViaAeson a -> ViaAeson a -> Ordering
$c< :: forall a. Ord a => ViaAeson a -> ViaAeson a -> Bool
< :: ViaAeson a -> ViaAeson a -> Bool
$c<= :: forall a. Ord a => ViaAeson a -> ViaAeson a -> Bool
<= :: ViaAeson a -> ViaAeson a -> Bool
$c> :: forall a. Ord a => ViaAeson a -> ViaAeson a -> Bool
> :: ViaAeson a -> ViaAeson a -> Bool
$c>= :: forall a. Ord a => ViaAeson a -> ViaAeson a -> Bool
>= :: ViaAeson a -> ViaAeson a -> Bool
$cmax :: forall a. Ord a => ViaAeson a -> ViaAeson a -> ViaAeson a
max :: ViaAeson a -> ViaAeson a -> ViaAeson a
$cmin :: forall a. Ord a => ViaAeson a -> ViaAeson a -> ViaAeson a
min :: ViaAeson a -> ViaAeson a -> ViaAeson a
Ord, Int -> ViaAeson a -> ShowS
[ViaAeson a] -> ShowS
ViaAeson a -> String
(Int -> ViaAeson a -> ShowS)
-> (ViaAeson a -> String)
-> ([ViaAeson a] -> ShowS)
-> Show (ViaAeson a)
forall a. Show a => Int -> ViaAeson a -> ShowS
forall a. Show a => [ViaAeson a] -> ShowS
forall a. Show a => ViaAeson a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> ViaAeson a -> ShowS
showsPrec :: Int -> ViaAeson a -> ShowS
$cshow :: forall a. Show a => ViaAeson a -> String
show :: ViaAeson a -> String
$cshowList :: forall a. Show a => [ViaAeson a] -> ShowS
showList :: [ViaAeson a] -> ShowS
Show)

-- | The value of a node, converted as the section
-- [Conversion]("Yamlet.Aeson#conversion") says.
instance FromYaml A.Value where
  parseYaml :: Node -> Parser Value
parseYaml = (Node -> Parser Value) -> Node -> Parser Value
forall a. (Node -> Parser a) -> Node -> Parser a
parseNode ((Node -> Parser Value) -> Node -> Parser Value)
-> (Node -> Parser Value) -> Node -> Parser Value
forall a b. (a -> b) -> a -> b
$ \Node
n -> case Node -> View
view Node
n of
    View
NullView -> Value -> Parser Value
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
A.Null
    BoolView Bool
b -> Value -> Parser Value
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Parser Value) -> Value -> Parser Value
forall a b. (a -> b) -> a -> b
$! Bool -> Value
A.Bool Bool
b
    IntView Integer
i -> Value -> Parser Value
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Parser Value) -> Value -> Parser Value
forall a b. (a -> b) -> a -> b
$! Scientific -> Value
A.Number (Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger Integer
i)
    FloatView FloatValue
f ->
      Value -> Parser Value
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Parser Value) -> Value -> Parser Value
forall a b. (a -> b) -> a -> b
$! case FloatValue
f of
        Finite Scientific
s
          | Scientific
s Scientific -> Scientific -> Bool
forall a. Eq a => a -> a -> Bool
== Scientific
0 -> Value
zero
          | Bool
otherwise -> Scientific -> Value
A.Number Scientific
s
        FloatValue
NegativeZero -> Value
zero
        FloatValue
Infinity -> Text -> Value
A.String Text
"+inf"
        FloatValue
NegativeInfinity -> Text -> Value
A.String Text
"-inf"
        FloatValue
NaN -> Value
A.Null
    StringView Text
t -> Value -> Parser Value
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Parser Value) -> Value -> Parser Value
forall a b. (a -> b) -> a -> b
$! Text -> Value
A.String (Text -> Text
T.copy Text
t)
    SequenceView [Node]
xs -> Array -> Value
A.Array (Array -> Value) -> ([Value] -> Array) -> [Value] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Array
forall a. [a] -> Vector a
V.fromList ([Value] -> Value) -> Parser [Value] -> Parser Value
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> (Node -> Parser Value) -> [Node] -> Parser [Value]
forall a. (Node -> Parser a) -> [Node] -> Parser [a]
parseItems Node -> Parser Value
forall a. FromYaml a => Node -> Parser a
parseYaml [Node]
xs
    MappingView [(Node, Node)]
_ -> Map KeyText Value -> Value
object (Map KeyText Value -> Value)
-> Parser (Map KeyText Value) -> Parser Value
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Node -> Parser (Map KeyText Value)
forall a. FromYaml a => Node -> Parser a
parseYaml Node
n
    AliasView Text
_ -> String -> Node -> Parser Value
forall a. String -> Node -> Parser a
typeMismatch String
"a value" Node
n
    where
      -- yamlet gives every zero the exponent 0, and aeson writes a number
      -- with an exponent of at least 0 as an integer. The zero of aeson that
      -- reads 0.0 from JSON has the exponent -1.
      zero :: A.Value
      zero :: Value
zero = Scientific -> Value
A.Number (Integer -> Int -> Scientific
Sci.scientific Integer
0 (-Int
1))

      -- A key of aeson orders as its text, as KeyText does.
      object :: M.Map KeyText A.Value -> A.Value
      object :: Map KeyText Value -> Value
object = Object -> Value
A.Object (Object -> Value)
-> (Map KeyText Value -> Object) -> Map KeyText Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Key Value -> Object
forall v. Map Key v -> KeyMap v
KM.fromMap (Map Key Value -> Object)
-> (Map KeyText Value -> Map Key Value)
-> Map KeyText Value
-> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyText -> Key) -> Map KeyText Value -> Map Key Value
forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeysMonotonic (\(KeyText Text
t) -> Text -> Key
K.fromText Text
t)

-- | The value as aeson writes it in JSON.
instance ToYaml A.Value where
  toYaml :: Value -> Node
toYaml = Value -> Node
forall a. ToYaml a => a -> Node
toYaml (Value -> Node) -> (Value -> Value) -> Value -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Value
aesonValue

-- | The value with the t'Data.Aeson.FromJSON' instance. An error of
-- 'Data.Aeson.parseJSON' points to the node at its path. If the node has no
-- such path, the error points to the deepest node of the path and names the
-- rest of it.
--
-- An error of a key of a map points to the value of the key, because aeson
-- gives it the same path as an error of the value. The path at the start of
-- the message names the key:
--
-- >>> either printErrors print (decodeText @(ViaAeson (M.Map Int T.Text)) "1: a\nabc: b\n")
-- input.yaml:2:6: abc: parsing Int failed, Unexpected 'a' while parsing number literal
--   |
-- 2 | abc: b
--   |      ^
instance A.FromJSON a => FromYaml (ViaAeson a) where
  parseYaml :: Node -> Parser (ViaAeson a)
parseYaml Node
n = do
    v <- Node -> Parser Value
forall a. FromYaml a => Node -> Parser a
parseYaml Node
n
    case A.ifromJSON @a v of
      A.ISuccess a
a -> ViaAeson a -> Parser (ViaAeson a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> ViaAeson a
forall a. a -> ViaAeson a
ViaAeson a
a)
      A.IError JSONPath
path String
msg -> JSONPath -> String -> Node -> Parser (ViaAeson a)
forall b. JSONPath -> String -> Node -> Parser b
failAtPath JSONPath
path String
msg Node
n
    where
      failAtPath :: A.JSONPath -> String -> S.Node -> Parser b
      failAtPath :: forall b. JSONPath -> String -> Node -> Parser b
failAtPath JSONPath
path String
msg Node
node = case (JSONPath
path, Node
node.content) of
        ([], Content
_) -> Node -> String -> Parser b
forall a. Node -> String -> Parser a
failAt Node
node String
msg
        (A.Key Key
key : JSONPath
rest, S.MappingContent CollectionStyle
_ [(Node, Node)]
kvs)
          | Just (Node
_, Node
v) <- ((Node, Node) -> Bool) -> [(Node, Node)] -> Maybe (Node, Node)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (Text -> Node -> Bool
isKey (Key -> Text
K.toText Key
key) (Node -> Bool) -> ((Node, Node) -> Node) -> (Node, Node) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node, Node) -> Node
forall a b. (a, b) -> a
fst) [(Node, Node)]
kvs ->
              JSONPath -> String -> Node -> Parser b
forall b. JSONPath -> String -> Node -> Parser b
failAtPath JSONPath
rest String
msg Node
v
        (A.Index Int
i : JSONPath
rest, S.SequenceContent CollectionStyle
_ [Node]
xs)
          | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
          , Node
x : [Node]
_ <- Int -> [Node] -> [Node]
forall a. Int -> [a] -> [a]
drop Int
i [Node]
xs ->
              JSONPath -> String -> Node -> Parser b
forall b. JSONPath -> String -> Node -> Parser b
failAtPath JSONPath
rest String
msg Node
x
        (JSONPath, Content)
_ ->
          Node -> String -> Parser b
forall a. Node -> String -> Parser a
failAt Node
node (String
msg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Path -> String
renderPath ([PathElement] -> Path
pathFromElements ((JSONPathElement -> PathElement) -> JSONPath -> [PathElement]
forall a b. (a -> b) -> [a] -> [b]
map JSONPathElement -> PathElement
element JSONPath
path)))

      isKey :: T.Text -> S.Node -> Bool
      isKey :: Text -> Node -> Bool
isKey Text
key Node
k = case Node
k.content of
        S.ScalarContent ScalarStyle
_ Text
t -> Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
key
        Content
_ -> Bool
False

      element :: A.JSONPathElement -> PathElement
      element :: JSONPathElement -> PathElement
element = \case
        A.Key Key
key -> Text -> PathElement
Key (Key -> Text
K.toText Key
key)
        A.Index Int
i -> Int -> PathElement
Index Int
i

-- | The value with the t'Data.Aeson.ToJSON' instance, with the keys of each
-- mapping in the order of 'Data.Aeson.toEncoding'. Of two equal keys, the
-- first one stays, as when aeson decodes JSON.
--
-- If the encoding is not valid JSON, which only
-- 'Data.Aeson.Encoding.unsafeToEncoding' can cause, the conversion throws an
-- error.
instance A.ToJSON a => ToYaml (ViaAeson a) where
  -- The encode benchmarks of yamlet-aeson do not get faster with nodes built
  -- straight from the tokens, without the set of keys, or with a lazy
  -- conversion and the lexer of a strict ByteString. The last one makes
  -- toYaml faster, but the renderer keeps the whole tree alive, so the
  -- garbage collector copies it anyway.
  toYaml :: ViaAeson a -> Node
toYaml (ViaAeson a
a) = Value -> Node
forall a. ToYaml a => a -> Node
toYaml (Value -> Node) -> Value -> Node
forall a b. (a -> b) -> a -> b
$ case Tokens ByteString String -> Either String (Value, ByteString)
forall t. Tokens t String -> Either String (Value, t)
value (ByteString -> Tokens ByteString String
lbsToTokens (a -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode a
a)) of
    Left String
err -> String -> Value
forall b. String -> b
invalid String
err
    Right (Value
v, ByteString
rest)
      | (Char -> Bool) -> ByteString -> Bool
LBS8.all (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
jsonSpace) ByteString
rest -> Value
v
      | Bool
otherwise -> String -> Value
forall b. String -> b
invalid (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ String
"unexpected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show (ByteString -> String
LBS8.unpack ByteString
rest) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" after the value"
    where
      -- The whitespace of RFC 8259.
      jsonSpace :: String
      jsonSpace :: String
jsonSpace = String
" \t\n\r"

      -- The call stack would only point to this module.
      invalid :: String -> b
      invalid :: forall b. String -> b
invalid String
err =
        String -> b
forall a. String -> a
errorWithoutStackTrace (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$
          String
"Yamlet.Aeson.ViaAeson: the toEncoding is not valid JSON: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err

      value :: Tokens t String -> Either String (Value, t)
      value :: forall t. Tokens t String -> Either String (Value, t)
value = \case
        TkLit Lit
l t
rest -> (Value, t) -> Either String (Value, t)
forall a b. b -> Either a b
Right (Lit -> Value
lit Lit
l, t
rest)
        TkText Text
t t
rest -> (Value, t) -> Either String (Value, t)
forall a b. b -> Either a b
Right (Text -> Value
String Text
t, t
rest)
        TkNumber Number
n t
rest -> (Value, t) -> Either String (Value, t)
forall a b. b -> Either a b
Right (Number -> Value
number Number
n, t
rest)
        TkArrayOpen TkArray t String
arr -> [Value] -> TkArray t String -> Either String (Value, t)
forall t. [Value] -> TkArray t String -> Either String (Value, t)
items [] TkArray t String
arr
        TkRecordOpen TkRecord t String
r -> [(Key, Value)] -> TkRecord t String -> Either String (Value, t)
forall t.
[(Key, Value)] -> TkRecord t String -> Either String (Value, t)
pairs [] TkRecord t String
r
        TkErr String
err -> String -> Either String (Value, t)
forall a b. a -> Either a b
Left String
err

      -- The items and the pairs are in reverse order until the end.
      items :: [Value] -> TkArray t String -> Either String (Value, t)
      items :: forall t. [Value] -> TkArray t String -> Either String (Value, t)
items [Value]
acc = \case
        TkItem Tokens (TkArray t String) String
toks -> Tokens (TkArray t String) String
-> Either String (Value, TkArray t String)
forall t. Tokens t String -> Either String (Value, t)
value Tokens (TkArray t String) String
toks Either String (Value, TkArray t String)
-> ((Value, TkArray t String) -> Either String (Value, t))
-> Either String (Value, t)
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Value
v, TkArray t String
rest) -> [Value] -> TkArray t String -> Either String (Value, t)
forall t. [Value] -> TkArray t String -> Either String (Value, t)
items (Value
v Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
: [Value]
acc) TkArray t String
rest
        TkArrayEnd t
rest -> (Value, t) -> Either String (Value, t)
forall a b. b -> Either a b
Right ([Value] -> Value
Sequence ([Value] -> [Value]
forall a. [a] -> [a]
reverse [Value]
acc), t
rest)
        TkArrayErr String
err -> String -> Either String (Value, t)
forall a b. a -> Either a b
Left String
err

      pairs :: [(A.Key, Value)] -> TkRecord t String -> Either String (Value, t)
      pairs :: forall t.
[(Key, Value)] -> TkRecord t String -> Either String (Value, t)
pairs [(Key, Value)]
acc = \case
        TkPair Key
key Tokens (TkRecord t String) String
toks -> Tokens (TkRecord t String) String
-> Either String (Value, TkRecord t String)
forall t. Tokens t String -> Either String (Value, t)
value Tokens (TkRecord t String) String
toks Either String (Value, TkRecord t String)
-> ((Value, TkRecord t String) -> Either String (Value, t))
-> Either String (Value, t)
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Value
v, TkRecord t String
rest) -> [(Key, Value)] -> TkRecord t String -> Either String (Value, t)
forall t.
[(Key, Value)] -> TkRecord t String -> Either String (Value, t)
pairs ((Key
key, Value
v) (Key, Value) -> [(Key, Value)] -> [(Key, Value)]
forall a. a -> [a] -> [a]
: [(Key, Value)]
acc) TkRecord t String
rest
        TkRecordEnd t
rest -> (Value, t) -> Either String (Value, t)
forall a b. b -> Either a b
Right ([(Value, Value)] -> Value
Mapping (Set Key -> [(Key, Value)] -> [(Value, Value)]
firstKeys Set Key
forall a. Set a
Set.empty ([(Key, Value)] -> [(Key, Value)]
forall a. [a] -> [a]
reverse [(Key, Value)]
acc)), t
rest)
        TkRecordErr String
err -> String -> Either String (Value, t)
forall a b. a -> Either a b
Left String
err

      firstKeys :: Set.Set A.Key -> [(A.Key, Value)] -> [(Value, Value)]
      firstKeys :: Set Key -> [(Key, Value)] -> [(Value, Value)]
firstKeys Set Key
seen = \case
        [] -> []
        (Key
key, Value
v) : [(Key, Value)]
rest
          | Key
key Key -> Set Key -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Key
seen -> Set Key -> [(Key, Value)] -> [(Value, Value)]
firstKeys Set Key
seen [(Key, Value)]
rest
          | Bool
otherwise -> (Text -> Value
String (Key -> Text
K.toText Key
key), Value
v) (Value, Value) -> [(Value, Value)] -> [(Value, Value)]
forall a. a -> [a] -> [a]
: Set Key -> [(Key, Value)] -> [(Value, Value)]
firstKeys (Key -> Set Key -> Set Key
forall a. Ord a => a -> Set a -> Set a
Set.insert Key
key Set Key
seen) [(Key, Value)]
rest

      lit :: Lit -> Value
      lit :: Lit -> Value
lit = \case
        Lit
LitNull -> Value
Null
        Lit
LitTrue -> Bool -> Value
Bool Bool
True
        Lit
LitFalse -> Bool -> Value
Bool Bool
False

      number :: Number -> Value
      number :: Number -> Value
number = \case
        NumInteger Integer
i -> Integer -> Value
Int Integer
i
        NumDecimal Scientific
s -> FloatValue -> Value
Float (Scientific -> FloatValue
Finite Scientific
s)
        NumScientific Scientific
s -> FloatValue -> Value
Float (Scientific -> FloatValue
Finite Scientific
s)

-- | The text of a scalar key, which is the key of an aeson object.
newtype KeyText = KeyText T.Text
  deriving stock (KeyText -> KeyText -> Bool
(KeyText -> KeyText -> Bool)
-> (KeyText -> KeyText -> Bool) -> Eq KeyText
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: KeyText -> KeyText -> Bool
== :: KeyText -> KeyText -> Bool
$c/= :: KeyText -> KeyText -> Bool
/= :: KeyText -> KeyText -> Bool
Eq, Eq KeyText
Eq KeyText =>
(KeyText -> KeyText -> Ordering)
-> (KeyText -> KeyText -> Bool)
-> (KeyText -> KeyText -> Bool)
-> (KeyText -> KeyText -> Bool)
-> (KeyText -> KeyText -> Bool)
-> (KeyText -> KeyText -> KeyText)
-> (KeyText -> KeyText -> KeyText)
-> Ord KeyText
KeyText -> KeyText -> Bool
KeyText -> KeyText -> Ordering
KeyText -> KeyText -> KeyText
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: KeyText -> KeyText -> Ordering
compare :: KeyText -> KeyText -> Ordering
$c< :: KeyText -> KeyText -> Bool
< :: KeyText -> KeyText -> Bool
$c<= :: KeyText -> KeyText -> Bool
<= :: KeyText -> KeyText -> Bool
$c> :: KeyText -> KeyText -> Bool
> :: KeyText -> KeyText -> Bool
$c>= :: KeyText -> KeyText -> Bool
>= :: KeyText -> KeyText -> Bool
$cmax :: KeyText -> KeyText -> KeyText
max :: KeyText -> KeyText -> KeyText
$cmin :: KeyText -> KeyText -> KeyText
min :: KeyText -> KeyText -> KeyText
Ord)

instance FromYaml KeyText where
  parseYaml :: Node -> Parser KeyText
parseYaml = (Node -> Parser KeyText) -> Node -> Parser KeyText
forall a. (Node -> Parser a) -> Node -> Parser a
parseNode ((Node -> Parser KeyText) -> Node -> Parser KeyText)
-> (Node -> Parser KeyText) -> Node -> Parser KeyText
forall a b. (a -> b) -> a -> b
$ \Node
k -> case Node
k.content of
    S.ScalarContent ScalarStyle
_ Text
t -> KeyText -> Parser KeyText
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyText -> Parser KeyText) -> KeyText -> Parser KeyText
forall a b. (a -> b) -> a -> b
$! Text -> KeyText
KeyText (Text -> Text
T.copy Text
t)
    Content
_ -> String -> Node -> Parser KeyText
forall a. String -> Node -> Parser a
typeMismatch String
"a scalar key" Node
k

-- | The value as aeson writes it in JSON.
aesonValue :: A.Value -> Value
aesonValue :: Value -> Value
aesonValue = \case
  Value
A.Null -> Value
Null
  A.Bool Bool
b -> Bool -> Value
Bool Bool
b
  A.Number Scientific
s -> Scientific -> Value
number Scientific
s
  A.String Text
t -> Text -> Value
String Text
t
  A.Array Array
xs -> [Value] -> Value
Sequence ((Value -> Value) -> [Value] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Value
aesonValue (Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
xs))
  A.Object Object
o -> [(Value, Value)] -> Value
Mapping [(Text -> Value
String (Key -> Text
K.toText Key
k), Value -> Value
aesonValue Value
v) | (Key
k, Value
v) <- Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KM.toList Object
o]
  where
    -- The bounds of the exponent for an integer are those of the encoder of
    -- aeson, @Data.Aeson.Encoding.Builder.scientific@, so that a value converts
    -- as its JSON encoding does for 'ViaAeson'.
    number :: Sci.Scientific -> Value
    number :: Scientific -> Value
number Scientific
s
      | Int
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1024 = FloatValue -> Value
Float (Scientific -> FloatValue
Finite Scientific
s)
      | Bool
otherwise = Integer -> Value
Int (Scientific -> Integer
Sci.coefficient Scientific
s Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
10 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
e)
      where
        e :: Int
        e :: Int
e = Scientific -> Int
Sci.base10Exponent Scientific
s

-- $setup
-- >>> import Yamlet
-- >>> printErrors = mapM_ (putStrLn . prettyError "input.yaml")