diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,2 @@ +# yamlet-aeson-1.0.0.0 (2026-10-11) +* Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2026, Andrzej Rybczak + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Andrzej Rybczak nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,147 @@ +# yamlet-aeson + +[![CI](https://github.com/arybczak/yamlet/actions/workflows/haskell-gha.yaml/badge.svg?branch=master)](https://github.com/arybczak/yamlet/actions/workflows/haskell-gha.yaml?query=branch%3Amaster) +[![Hackage](https://img.shields.io/hackage/v/yamlet-aeson.svg)](https://hackage.haskell.org/package/yamlet-aeson) +[![Stackage LTS](https://www.stackage.org/package/yamlet-aeson/badge/lts)](https://www.stackage.org/lts/package/yamlet-aeson) +[![Stackage Nightly](https://www.stackage.org/package/yamlet-aeson/badge/nightly)](https://www.stackage.org/nightly/package/yamlet-aeson) + +Use the `FromJSON` and `ToJSON` instances of +[aeson](https://hackage.haskell.org/package/aeson) with +[yamlet](https://hackage.haskell.org/package/yamlet), for the types that have +no `FromYaml` and `ToYaml` instances yet, e.g. in a program that moves from +the yaml package to yamlet. + +- A value in `ViaAeson` decodes and encodes with its `FromJSON` and `ToJSON` + instances, so the functions of yamlet work with it, e.g. + `decodeFile @(ViaAeson Config)`. A program can try yamlet by changing only + the places that decode and encode. +- A type with `FromJSON` and `ToJSON` instances can derive its `FromYaml` and + `ToYaml` instances via `ViaAeson`, e.g. in a program that reads and writes + both JSON and YAML and keeps one set of instances. +- An error of a decoder of aeson points to the node that caused it, with the + line, the column and the path. An error of a key of a map points to the + value of the key, and its path names the key. +- The encoder keeps the order of the fields of a type whose instance defines + `toEncoding`, e.g. with `genericToEncoding`. +- The package also has the `FromYaml` and `ToYaml` instances for the `Value` + of aeson. + +A program that uses the yaml package can switch to yamlet in steps with this +package. The document +[Coming from the yaml package](https://github.com/arybczak/yamlet/blob/master/docs/coming-from-yaml.md) +shows how, and lists the differences between the two. + +## Example + +A list of servers decodes with the `FromJSON` instance of the server type. +Each server decodes on its own, so an error in one server does not hide the +errors in the others: + +```haskell +{-# LANGUAGE GHC2021 #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} + +import Data.Aeson qualified as A +import Data.Text (Text) +import Yamlet +import Yamlet.Aeson + +data Server = Server {port :: Int, host :: Text} + deriving stock (Generic, Show) + deriving anyclass (A.FromJSON) + +main :: IO () +main = do + result <- decodeFile @[ViaAeson Server] path + case result of + Left errs -> mapM_ (putStrLn . prettyError path) errs + Right servers -> mapM_ (print . (.value)) servers + where + path :: FilePath + path = "servers.yaml" +``` + +For this file: + +```yaml +- port: 80 + host: a.example.com +- port: 81 + host: b.example.com +``` + +the program prints the servers: + +``` +Server {port = 80, host = "a.example.com"} +Server {port = 81, host = "b.example.com"} +``` + +For this file: + +```yaml +- port: http + host: a.example.com +- port: 81 +- port: 82 + host: c.example.com +``` + +the program prints every error: + +``` +servers.yaml:1:9: [0].port: parsing Int failed, expected Number, but encountered String + | +1 | - port: http + | ^ +servers.yaml:3:3: [1]: parsing Main.Server(Server) failed, key "host" not found + | +3 | - port: 81 + | ^ +``` + +## Order of keys + +The encoder writes the keys of a mapping in the order of `toEncoding`. The +default `toEncoding` goes through `toJSON`, so the keys come in the order of +an aeson object, which is sorted by default. + +The decoder of aeson gets the keys in no order, because an aeson object has +none. To keep the order of a mapping, a program decodes the mapping with a +decoder of yamlet, e.g. with `withMapping` and `objectEntries`. Its values +can still decode via `ViaAeson`. + +## Conversion + +A YAML document converts to an 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"`. 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, which the `FromJSON` and `ToJSON` instances for `Double` and `Float` + read and write. +- `-0.0` is the number 0, because a `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 `Number` + converts to YAML as aeson writes it in JSON: as an integer if its + `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 `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. + +A `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. diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,17 @@ +module Main (main) where + +import Data.ByteString qualified as BS +import Test.Tasty.Bench + +import Yamlet.Aeson.Bench.Inputs +import Yamlet.Aeson.Bench.Libraries + +main :: IO () +main = do + printSize "config" configInput + printSize "json" jsonInput + defaultMain libraryBenchmarks + where + printSize :: String -> BS.ByteString -> IO () + printSize name bs = + putStrLn $ name ++ ": " ++ show (BS.length bs `div` 1024) ++ " KiB" diff --git a/bench/Yamlet/Aeson/Bench/Inputs.hs b/bench/Yamlet/Aeson/Bench/Inputs.hs new file mode 100644 --- /dev/null +++ b/bench/Yamlet/Aeson/Bench/Inputs.hs @@ -0,0 +1,48 @@ +-- | The generated YAML inputs of the benchmarks, the same as in the +-- benchmarks of yamlet. +module Yamlet.Aeson.Bench.Inputs + ( configInput + , jsonInput + ) where + +import Data.ByteString qualified as BS +import Data.Text qualified as T +import Data.Text.Encoding qualified as T + +-- | A block sequence of block mappings, as in a configuration file. +configInput :: BS.ByteString +configInput = T.encodeUtf8 . T.concat $ map record [1 .. 5000] + where + record :: Int -> T.Text + record i = + T.unlines + [ "- name: item " <> num i + , " id: " <> num i + , " tags: [alpha, beta, gamma]" + , " description: \"an \\\"escaped\\\" string\\twith a tab\"" + , " path: /usr/local/share/item-" <> num i + , " enabled: true" + , " nested:" + , " x: 1.5" + , " y: -3" + , " list:" + , " - one" + , " - 'two'" + ] + +-- | JSON-like flow collections. +jsonInput :: BS.ByteString +jsonInput = T.encodeUtf8 $ "[" <> T.intercalate ",\n " (map record [1 .. 5000]) <> "]\n" + where + record :: Int -> T.Text + record i = + T.concat + [ "{\"id\": " + , num i + , ", \"name\": \"item " + , num i + , "\", \"values\": [1, 2.5, true, null], \"child\": {\"a\": \"b\"}}" + ] + +num :: Int -> T.Text +num = T.pack . show diff --git a/bench/Yamlet/Aeson/Bench/Libraries.hs b/bench/Yamlet/Aeson/Bench/Libraries.hs new file mode 100644 --- /dev/null +++ b/bench/Yamlet/Aeson/Bench/Libraries.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | The benchmarks that compare the t'Data.Aeson.FromJSON' and +-- t'Data.Aeson.ToJSON' instances through 'ViaAeson' with written 'FromYaml' +-- and 'ToYaml' instances and with the yaml package. +module Yamlet.Aeson.Bench.Libraries + ( libraryBenchmarks + ) where + +import Control.DeepSeq +import Data.Aeson qualified as J +import Data.ByteString qualified as BS +import Data.Yaml qualified as Y +import Test.Tasty.Bench +import Yamlet + +import Yamlet.Aeson +import Yamlet.Aeson.Bench.Inputs +import Yamlet.Aeson.Bench.Types + +-- | The benchmarks are grouped by the operation, so that the times of the +-- libraries for one operation and input are next to each other. +libraryBenchmarks :: [Benchmark] +libraryBenchmarks = + [ bgroup + "decode" + [ decoding @[Config] "config" configInput + , decoding @[Json] "json" jsonInput + ] + , bgroup + "encode" + [ encoding @[Config] "config" configInput + , encoding @[Json] "json" jsonInput + ] + ] + where + -- The benchmarks that decode an input into a value of the type. + decoding + :: forall a + . (NFData a, FromYaml a, J.FromJSON a) + => String + -> BS.ByteString + -> Benchmark + decoding name bs = + bgroup + name + [ bench "yamlet" $ nf (either (error . show) id . decode @a) bs + , bench "yamlet-aeson" $ + nf (either (error . show) (.value) . decode @(ViaAeson a)) bs + , bench "yaml" $ nf (either (error . show) id . Y.decodeEither' @a) bs + ] + + -- The benchmarks that encode the value of an input, decoded as the type. + encoding + :: forall a + . (NFData a, FromYaml a, ToYaml a, J.ToJSON a) + => String + -> BS.ByteString + -> Benchmark + encoding name bs = + bgroup + name + [ bench "yamlet" $ nf encode value + , bench "yamlet-aeson" $ nf (encode . ViaAeson) value + , bench "yaml" $ nf Y.encode value + ] + where + value :: a + value = either (error . show) id $ decode bs diff --git a/bench/Yamlet/Aeson/Bench/Types.hs b/bench/Yamlet/Aeson/Bench/Types.hs new file mode 100644 --- /dev/null +++ b/bench/Yamlet/Aeson/Bench/Types.hs @@ -0,0 +1,189 @@ +-- | The types that the inputs decode into, with written 'FromYaml', 'ToYaml', +-- t'Data.Aeson.FromJSON' and t'Data.Aeson.ToJSON' instances, the same as in +-- the benchmarks of yamlet. +module Yamlet.Aeson.Bench.Types + ( Config (..) + , Nested (..) + , Json (..) + , Item (..) + ) where + +import Control.DeepSeq +import Data.Aeson qualified as J +import Data.Map.Strict qualified as M +import Data.Scientific qualified as Sci +import Data.Text qualified as T +import Yamlet + +-- | An entry of 'Yamlet.Aeson.Bench.Inputs.config'. +data Config = Config + { name :: T.Text + , itemId :: Int + , tags :: [T.Text] + , description :: T.Text + , path :: T.Text + , enabled :: Bool + , nested :: Nested + } + deriving stock (Generic) + deriving anyclass (NFData) + +data Nested = Nested + { x :: Double + , y :: Int + , list :: [T.Text] + } + deriving stock (Generic) + deriving anyclass (NFData) + +-- | An entry of 'Yamlet.Aeson.Bench.Inputs.json'. +data Json = Json + { itemId :: Int + , name :: T.Text + , values :: [Item] + , child :: M.Map T.Text T.Text + } + deriving stock (Generic) + deriving anyclass (NFData) + +-- | An item of the values of a 'Json'. +data Item = ItemNumber Double | ItemBool Bool | ItemNull + deriving stock (Generic) + deriving anyclass (NFData) + +instance FromYaml Config where + parseYaml = withMapping $ \o -> + Config + <$> parseField o "name" + <*> parseField o "id" + <*> parseField o "tags" + <*> parseField o "description" + <*> parseField o "path" + <*> parseField o "enabled" + <*> parseField o "nested" + +instance J.FromJSON Config where + parseJSON = J.withObject "Config" $ \o -> + Config + <$> o J..: "name" + <*> o J..: "id" + <*> o J..: "tags" + <*> o J..: "description" + <*> o J..: "path" + <*> o J..: "enabled" + <*> o J..: "nested" + +instance FromYaml Nested where + parseYaml = withMapping $ \o -> + Nested + <$> parseField o "x" + <*> parseField o "y" + <*> parseField o "list" + +instance J.FromJSON Nested where + parseJSON = J.withObject "Nested" $ \o -> + Nested + <$> o J..: "x" + <*> o J..: "y" + <*> o J..: "list" + +instance FromYaml Json where + parseYaml = withMapping $ \o -> + Json + <$> parseField o "id" + <*> parseField o "name" + <*> parseField o "values" + <*> parseField o "child" + +instance J.FromJSON Json where + parseJSON = J.withObject "Json" $ \o -> + Json + <$> o J..: "id" + <*> o J..: "name" + <*> o J..: "values" + <*> o J..: "child" + +instance FromYaml Item where + parseYaml n = case view n of + IntView i -> pure $ ItemNumber (fromInteger i) + FloatView f -> pure $ ItemNumber (floatValueToRealFloat f) + BoolView b -> pure $ ItemBool b + NullView -> pure ItemNull + _ -> typeMismatch "a number, a boolean or null" n + +instance J.FromJSON Item where + parseJSON = \case + J.Number s -> pure $ ItemNumber (Sci.toRealFloat s) + J.Bool b -> pure $ ItemBool b + J.Null -> pure ItemNull + _ -> fail "expected a number, a boolean or null" + +instance ToYaml Config where + toYaml r = + mapping + [ "name" .= r.name + , "id" .= r.itemId + , "tags" .= r.tags + , "description" .= r.description + , "path" .= r.path + , "enabled" .= r.enabled + , "nested" .= r.nested + ] + +instance J.ToJSON Config where + toJSON r = + J.object + [ "name" J..= r.name + , "id" J..= r.itemId + , "tags" J..= r.tags + , "description" J..= r.description + , "path" J..= r.path + , "enabled" J..= r.enabled + , "nested" J..= r.nested + ] + +instance ToYaml Nested where + toYaml n = + mapping + [ "x" .= n.x + , "y" .= n.y + , "list" .= n.list + ] + +instance J.ToJSON Nested where + toJSON n = + J.object + [ "x" J..= n.x + , "y" J..= n.y + , "list" J..= n.list + ] + +instance ToYaml Json where + toYaml r = + mapping + [ "id" .= r.itemId + , "name" .= r.name + , "values" .= r.values + , "child" .= r.child + ] + +instance J.ToJSON Json where + toJSON r = + J.object + [ "id" J..= r.itemId + , "name" J..= r.name + , "values" J..= r.values + , "child" J..= r.child + ] + +instance ToYaml Item where + toYaml = \case + ItemNumber d -> toYaml d + ItemBool b -> toYaml b + ItemNull -> toYaml () + +instance J.ToJSON Item where + toJSON = \case + ItemNumber d -> J.toJSON d + ItemBool b -> J.toJSON b + ItemNull -> J.Null diff --git a/src/Yamlet/Aeson.hs b/src/Yamlet/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Yamlet/Aeson.hs @@ -0,0 +1,364 @@ +-- 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 {value :: a} + deriving stock (Eq, Ord, Show) + +-- | The value of a node, converted as the section +-- [Conversion]("Yamlet.Aeson#conversion") says. +instance FromYaml A.Value where + parseYaml = parseNode $ \n -> case view n of + NullView -> pure A.Null + BoolView b -> pure $! A.Bool b + IntView i -> pure $! A.Number (fromInteger i) + FloatView f -> + pure $! case f of + Finite s + | s == 0 -> zero + | otherwise -> A.Number s + NegativeZero -> zero + Infinity -> A.String "+inf" + NegativeInfinity -> A.String "-inf" + NaN -> A.Null + StringView t -> pure $! A.String (T.copy t) + SequenceView xs -> A.Array . V.fromList <$!> parseItems parseYaml xs + MappingView _ -> object <$!> parseYaml n + AliasView _ -> typeMismatch "a value" 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 = A.Number (Sci.scientific 0 (-1)) + + -- A key of aeson orders as its text, as KeyText does. + object :: M.Map KeyText A.Value -> A.Value + object = A.Object . KM.fromMap . M.mapKeysMonotonic (\(KeyText t) -> K.fromText t) + +-- | The value as aeson writes it in JSON. +instance ToYaml A.Value where + toYaml = toYaml . 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 n = do + v <- parseYaml n + case A.ifromJSON @a v of + A.ISuccess a -> pure (ViaAeson a) + A.IError path msg -> failAtPath path msg n + where + failAtPath :: A.JSONPath -> String -> S.Node -> Parser b + failAtPath path msg node = case (path, node.content) of + ([], _) -> failAt node msg + (A.Key key : rest, S.MappingContent _ kvs) + | Just (_, v) <- L.find (isKey (K.toText key) . fst) kvs -> + failAtPath rest msg v + (A.Index i : rest, S.SequenceContent _ xs) + | i >= 0 + , x : _ <- drop i xs -> + failAtPath rest msg x + _ -> + failAt node (msg ++ " at " ++ renderPath (pathFromElements (map element path))) + + isKey :: T.Text -> S.Node -> Bool + isKey key k = case k.content of + S.ScalarContent _ t -> t == key + _ -> False + + element :: A.JSONPathElement -> PathElement + element = \case + A.Key key -> Key (K.toText key) + A.Index i -> Index 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) = toYaml $ case value (lbsToTokens (A.encode a)) of + Left err -> invalid err + Right (v, rest) + | LBS8.all (`elem` jsonSpace) rest -> v + | otherwise -> invalid $ "unexpected " ++ show (LBS8.unpack rest) ++ " after the value" + where + -- The whitespace of RFC 8259. + jsonSpace :: String + jsonSpace = " \t\n\r" + + -- The call stack would only point to this module. + invalid :: String -> b + invalid err = + errorWithoutStackTrace $ + "Yamlet.Aeson.ViaAeson: the toEncoding is not valid JSON: " ++ err + + value :: Tokens t String -> Either String (Value, t) + value = \case + TkLit l rest -> Right (lit l, rest) + TkText t rest -> Right (String t, rest) + TkNumber n rest -> Right (number n, rest) + TkArrayOpen arr -> items [] arr + TkRecordOpen r -> pairs [] r + TkErr err -> Left err + + -- The items and the pairs are in reverse order until the end. + items :: [Value] -> TkArray t String -> Either String (Value, t) + items acc = \case + TkItem toks -> value toks >>= \(v, rest) -> items (v : acc) rest + TkArrayEnd rest -> Right (Sequence (reverse acc), rest) + TkArrayErr err -> Left err + + pairs :: [(A.Key, Value)] -> TkRecord t String -> Either String (Value, t) + pairs acc = \case + TkPair key toks -> value toks >>= \(v, rest) -> pairs ((key, v) : acc) rest + TkRecordEnd rest -> Right (Mapping (firstKeys Set.empty (reverse acc)), rest) + TkRecordErr err -> Left err + + firstKeys :: Set.Set A.Key -> [(A.Key, Value)] -> [(Value, Value)] + firstKeys seen = \case + [] -> [] + (key, v) : rest + | key `Set.member` seen -> firstKeys seen rest + | otherwise -> (String (K.toText key), v) : firstKeys (Set.insert key seen) rest + + lit :: Lit -> Value + lit = \case + LitNull -> Null + LitTrue -> Bool True + LitFalse -> Bool False + + number :: Number -> Value + number = \case + NumInteger i -> Int i + NumDecimal s -> Float (Finite s) + NumScientific s -> Float (Finite s) + +-- | The text of a scalar key, which is the key of an aeson object. +newtype KeyText = KeyText T.Text + deriving stock (Eq, Ord) + +instance FromYaml KeyText where + parseYaml = parseNode $ \k -> case k.content of + S.ScalarContent _ t -> pure $! KeyText (T.copy t) + _ -> typeMismatch "a scalar key" k + +-- | The value as aeson writes it in JSON. +aesonValue :: A.Value -> Value +aesonValue = \case + A.Null -> Null + A.Bool b -> Bool b + A.Number s -> number s + A.String t -> String t + A.Array xs -> Sequence (map aesonValue (V.toList xs)) + A.Object o -> Mapping [(String (K.toText k), aesonValue v) | (k, v) <- KM.toList 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 s + | e < 0 || e > 1024 = Float (Finite s) + | otherwise = Int (Sci.coefficient s * 10 ^ e) + where + e :: Int + e = Sci.base10Exponent s + +-- $setup +-- >>> import Yamlet +-- >>> printErrors = mapM_ (putStrLn . prettyError "input.yaml") diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,17 @@ +module Main (main) where + +import Test.Tasty + +import Yamlet.Aeson.Test.Decode +import Yamlet.Aeson.Test.Encode +import Yamlet.Aeson.Test.RoundTrip + +main :: IO () +main = + defaultMain $ + testGroup + "yamlet-aeson" + [ decodeTests + , encodeTests + , roundTripTests + ] diff --git a/tests/Retention.hs b/tests/Retention.hs new file mode 100644 --- /dev/null +++ b/tests/Retention.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +-- Full laziness would float the input out of the action of a check into the +-- list of checks, which keeps it alive. +{-# OPTIONS_GHC -fno-full-laziness #-} + +-- | The checks of yamlet's retention suite for the instances of this package. +-- They run without tasty for the same reason: in a test of tasty, a major +-- collection at times kept the input of a decode alive although no value +-- referred to it. +module Main (main) where + +import Control.Exception +import Control.Monad +import Data.Aeson qualified as A +import Data.IORef +import Data.List qualified as L +import Data.Maybe +import Data.Text qualified as T +import Data.Text.Array qualified as TA +import Data.Text.Internal qualified as T +import GHC.Exts (mkWeakNoFinalizer#) +import GHC.IO +import GHC.Weak +import System.Exit +import System.IO +import System.Mem +import Yamlet + +import Yamlet.Aeson +import Yamlet.Aeson.Test.Helpers.Thunks + +-- | Run the checks, and fail if one of them fails. +main :: IO () +main = do + failures <- fmap catMaybes . forM checks $ \(Check name act) -> do + result <- act + putStrLn $ name ++ ": " ++ maybe "OK" (const "FAIL") result + pure $ (\msg -> name ++ ": " ++ msg) <$> result + unless (null failures) $ do + mapM_ (hPutStrLn stderr) failures + exitFailure + +-- | A check with its name. The action returns the message of a failure. +data Check = Check String (IO (Maybe String)) + +-- | A decoded value does not keep the input alive, and neither do the errors +-- of a failed decode. +checks :: [Check] +checks = + [ Check "input without a value" $ do + input <- evaluate (T.copy "a") + weak <- weakArray input + performMajorGC + kept <- isJust <$> deRefWeak weak + pure $ if kept then Just "the check keeps the input alive" else Nothing + , retains @[A.Value] "Value" "- {a: b, 1: c}\n- [d, 1.5, .inf]\n- !x e" + , retains @(ViaAeson [T.Text]) "ViaAeson" "- a\n- b" + , retains @(ViaAeson [Endpoint]) "record" "- host: a\n tags: [b]" + , errorRetains @A.Value "error with a key in the message" "a: 1\n!x a: 2" + , errorRetains @(ViaAeson [Endpoint]) "error of aeson" "- host: a\n tags: b" + ] + +-- | The array of the input is garbage while the value is alive. A weak +-- pointer tells, unlike the size of the heap. +retains :: forall a. FromYaml a => String -> T.Text -> Check +retains name doc = Check name $ do + -- A copy, because the array of a literal is never garbage. + input <- evaluate (T.copy doc) + weak <- weakArray input + case decodeText @a input of + Left errs -> pure (Just (show errs)) + Right v -> do + ref <- newIORef v + performMajorGC + kept <- isJust <$> deRefWeak weak + failure <- + if kept + then Just <$> (keptAlive "the value" weak =<< readIORef ref) + else pure Nothing + _ <- evaluate =<< readIORef ref + pure failure + +-- | The array of the input is garbage while the errors of a failed decode +-- are alive. +errorRetains :: forall a. FromYaml a => String -> T.Text -> Check +errorRetains name doc = Check name $ do + input <- evaluate (T.copy doc) + weak <- weakArray input + case decodeText @a input of + Left errs -> do + -- An error in weak head normal form has no thunks that keep the input. + mapM_ evaluate errs + ref <- newIORef errs + performMajorGC + kept <- isJust <$> deRefWeak weak + failure <- + if kept + then Just <$> (keptAlive "the errors" weak =<< readIORef ref) + else pure Nothing + _ <- evaluate =<< readIORef ref + pure failure + Right _ -> pure (Just "the decode succeeded") + +-- | The message for a value that keeps the input alive, with what tells a +-- leak from the state of the runtime: whether a second collection frees the +-- input while the value is still alive, and the thunks in the value. +keptAlive :: String -> Weak () -> a -> IO String +keptAlive what weak x = do + ts <- thunks x + performMajorGC + still <- isJust <$> deRefWeak weak + _ <- evaluate x + pure $ + what + ++ " keeps the input alive; after a second collection, the input is " + ++ (if still then "still alive" else "gone") + ++ "; thunks in the value: " + ++ (if null ts then "none" else L.intercalate ", " ts) + +-- | A weak pointer to the array of the text. A slice of the text shares the +-- array, so the weak pointer is empty only if no text of the array is alive. +weakArray :: T.Text -> IO (Weak ()) +weakArray (T.Text (TA.ByteArray arr) _ _) = IO $ \s -> case mkWeakNoFinalizer# arr () s of + (# s', w #) -> (# s', Weak w #) + +data Endpoint = Endpoint {host :: T.Text, tags :: [T.Text]} + deriving stock (Generic) + deriving anyclass (A.FromJSON) diff --git a/tests/Yamlet/Aeson/Test/Decode.hs b/tests/Yamlet/Aeson/Test/Decode.hs new file mode 100644 --- /dev/null +++ b/tests/Yamlet/Aeson/Test/Decode.hs @@ -0,0 +1,202 @@ +module Yamlet.Aeson.Test.Decode + ( decodeTests + ) where + +import Control.Applicative +import Data.Aeson qualified as A +import Data.Aeson.Types qualified as A +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict qualified as M +import Data.Text qualified as T +import Test.Tasty +import Test.Tasty.HUnit +import Yamlet + +import Yamlet.Aeson +import Yamlet.Aeson.Test.Helpers + +decodeTests :: TestTree +decodeTests = + testGroup + "decode" + [ testCase "scalar keys" test_scalarKeys + , testCase "keys with the same text" test_sameText + , testCase "collection keys" test_collectionKeys + , testCase "special floats" test_specialFloats + , testCase "tags" test_tags + , testCase "aliases" test_aliases + , testCase "merge key" test_mergeKey + , testCase "error location" test_errorLocation + , testCase "error of a key of a map" test_keyOfMap + , testCase "error with a message that ignores the value" test_constantMessage + , testCase "error at a missing key" test_missingKey + , testCase "error path beyond the node" test_pathBeyondNode + , testCase "field of a derived record" test_derivedField + , testCase "types of aeson" test_aesonTypes + ] + +test_scalarKeys :: Assertion +test_scalarKeys = + assertEqual + "the text of each key" + ( Right $ + A.object + ["0x10" A..= 'a', "true" A..= 'b', "~" A..= 'c', "" A..= 'd', "1.0" A..= 'e'] + ) + (decodeText @A.Value "0x10: a\ntrue: b\n~: c\n'': d\n'1.0': e\n") + +test_sameText :: Assertion +test_sameText = do + assertEqual + "a number and a string" + [(2, 1, "duplicate key \"1\" after conversion"), (1, 1, "the first key 1")] + (errorsOf (decodeText @A.Value "1: a\n\"1\": b\n")) + assertEqual + "a string with a tag" + [(2, 4, "duplicate key \"a\" after conversion"), (1, 1, "the first key \"a\"")] + (errorsOf (decodeText @A.Value "a: 1\n!x a: 2\n")) + +test_collectionKeys :: Assertion +test_collectionKeys = + assertEqual + "an error at each key" + [ (1, 3, "expected a scalar key, but got a list") + , (3, 3, "expected a scalar key, but got a mapping") + ] + (errorsOf (decodeText @A.Value "? [1]\n: a\n? {b: c}\n: d\n")) + +test_specialFloats :: Assertion +test_specialFloats = do + assertEqual + "the values" + (Right (A.toJSON [A.String "+inf", A.String "-inf", A.Null, A.Number 0])) + (decodeText @A.Value "[.inf, -.inf, .nan, -0.0]") + assertEqual + "the doubles" + (Right ["Infinity", "-Infinity", "NaN", "0.0"]) + (map show . (.value) <$> decodeText @(ViaAeson [Double]) "[.inf, -.inf, .nan, -0.0]") + +test_tags :: Assertion +test_tags = + assertEqual + "the values without tags" + ( Right $ + A.object + ["x" A..= ("abc" :: T.Text), "y" A..= ("1" :: T.Text), "z" A..= (2 :: Int)] + ) + (decodeText @A.Value "!point {x: !secret abc, y: !!str 1, z: !!int 2}") + +test_aliases :: Assertion +test_aliases = + assertEqual + "the alias gives the value of its anchor" + (Right (A.object ["a" A..= [1 :: Int], "b" A..= [1 :: Int]])) + (decodeText @A.Value "a: &x [1]\nb: *x\n") + +test_mergeKey :: Assertion +test_mergeKey = + assertEqual + "an ordinary key" + (Right (A.object ["<<" A..= A.object ["a" A..= (1 :: Int)], "b" A..= (2 :: Int)])) + (decodeText @A.Value "<<: {a: 1}\nb: 2\n") + +test_errorLocation :: Assertion +test_errorLocation = do + let result = + decodeText @(ViaAeson [Server]) "- port: 80\n host: a\n- port: http\n host: b\n" + assertEqual + "the error at the value" + [(3, 9, "parsing Int failed, expected Number, but encountered String")] + (errorsOf result) + assertEqual + "the path of the value" + ["[1].port"] + (pathsOf result) + where + pathsOf :: Either (NE.NonEmpty Error) a -> [String] + pathsOf = \case + Left errs -> [renderPath err.path | err <- NE.toList errs] + Right _ -> [] + +test_keyOfMap :: Assertion +test_keyOfMap = do + assertEqual + "an error of the key at the value" + [(2, 6, "parsing Int failed, Unexpected 'a' while parsing number literal")] + (errorsOf (decodeText @(ViaAeson (M.Map Int T.Text)) "1: a\nabc: x\n")) + assertEqual + "an error of the value at the value" + [(2, 4, "parsing Int failed, expected Number, but encountered String")] + (errorsOf (decodeText @(ViaAeson (M.Map Int Int)) "1: 2\n3: x\n")) + +test_constantMessage :: Assertion +test_constantMessage = + assertEqual + "the error at the value" + [(1, 7, "invalid port")] + (errorsOf (decodeText @(ViaAeson Endpoint) "port: http\n")) + +test_missingKey :: Assertion +test_missingKey = + assertEqual + "the error at the mapping" + [ (3, 3, "parsing Yamlet.Aeson.Test.Helpers.Server(Server) failed, key \"host\" not found") + ] + (errorsOf (decodeText @(ViaAeson [Server]) "- port: 80\n host: a\n- port: 81\n")) + +test_pathBeyondNode :: Assertion +test_pathBeyondNode = + assertEqual + "the error at the deepest node with the rest of the path" + [(1, 3, "parsing Int failed, expected Number, but encountered String at outer[0].inner")] + (errorsOf (decodeText @(ViaAeson [Nested]) "- a\n")) + +test_derivedField :: Assertion +test_derivedField = do + assertEqual + "a missing key is null for aeson" + (Right (Service "a" (ViaAeson Nothing))) + (decodeText "name: a\n") + assertEqual + "the field" + (Right (Service "a" (ViaAeson (Just (Server 80 "b"))))) + (decodeText "name: a\nbackend: {port: 80, host: b}\n") + assertEqual + "the output" + "name: a\nbackend:\n port: 80\n host: b\n" + (encodeText (Service "a" (ViaAeson (Just (Server 80 "b"))))) + +test_aesonTypes :: Assertion +test_aesonTypes = do + assertEqual + "a float for an Int" + (Right (ViaAeson @Int 1)) + (decodeText "1.0") + assertEqual + "yes of YAML 1.2" + (Right (ViaAeson @T.Text "yes")) + (decodeText "yes") + +-- | A decoder with a path that goes beyond a scalar. +newtype Nested = Nested Int + deriving stock (Show) + +instance A.FromJSON Nested where + parseJSON v = + Nested <$> A.parseJSON v A. A.Key "inner" A. A.Index 0 A. A.Key "outer" + +newtype Port = Port Int + deriving stock (Show) + +-- | The same message for every invalid value. +instance A.FromJSON Port where + parseJSON v = Port <$> A.parseJSON v <|> fail "invalid port" + +newtype Endpoint = Endpoint {port :: Port} + deriving stock (Show, Generic) + deriving anyclass (A.FromJSON) + +data Service = Service {name :: T.Text, backend :: ViaAeson (Maybe Server)} + deriving stock (Eq, Show, Generic) + deriving anyclass (GenericYamlOptions) + deriving (FromYaml, ToYaml) via GenericYaml Service diff --git a/tests/Yamlet/Aeson/Test/Encode.hs b/tests/Yamlet/Aeson/Test/Encode.hs new file mode 100644 --- /dev/null +++ b/tests/Yamlet/Aeson/Test/Encode.hs @@ -0,0 +1,151 @@ +module Yamlet.Aeson.Test.Encode + ( encodeTests + ) where + +import Control.Exception +import Data.Aeson qualified as A +import Data.Aeson.Encoding qualified as E +import Data.List qualified as L +import Data.Map.Strict qualified as M +import Data.String +import Data.Text qualified as T +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +import Yamlet + +import Yamlet.Aeson +import Yamlet.Aeson.Test.Helpers + +encodeTests :: TestTree +encodeTests = + testGroup + "encode" + [ testCase "order of fields" test_fieldOrder + , testCase "polymorphic value" test_polymorphic + , testCase "keys that look like numbers" test_numberKeys + , testCase "special floats" test_encodeSpecialFloats + , testCase "zeros" test_zeros + , testCase "duplicate keys" test_duplicateKeys + , testCase "invalid encoding" test_invalidEncoding + , testProperty "value as its encoding" prop_valueAsEncoding + ] + +test_fieldOrder :: Assertion +test_fieldOrder = do + assertEqual + "the order of the declaration" + "- port: 80\n host: localhost\n" + (encodeText (ViaAeson [Server 80 "localhost"])) + assertEqual + "the order of an aeson object without toEncoding" + "- host: localhost\n port: 80\n" + (encodeText (ViaAeson [Unordered 80 "localhost"])) + +test_polymorphic :: Assertion +test_polymorphic = + assertEqual + "the output" + "- 1\n" + (encodeAny @[Int] [1]) + where + encodeAny :: A.ToJSON a => a -> T.Text + encodeAny = encodeText . ViaAeson + +test_numberKeys :: Assertion +test_numberKeys = do + let m = M.fromList @Int @Char [(1, 'a'), (2, 'b')] + assertEqual + "the keys in quotes" + "'1': a\n'2': b\n" + (encodeText (ViaAeson m)) + assertEqual + "the keys read back" + (Right (ViaAeson m)) + (decodeText (encodeText (ViaAeson m))) + +test_encodeSpecialFloats :: Assertion +test_encodeSpecialFloats = do + let ds = [1 / 0, -(1 / 0), 0 / 0, -0.0, 1.0 :: Double] + assertEqual + "the values of aeson" + "- +inf\n- -inf\n- null\n- 0.0\n- 1.0\n" + (encodeText (ViaAeson ds)) + assertEqual + "the values read back as from JSON" + (Right (map show <$> A.decode @[Double] (A.encode ds))) + $ Just . map show . (.value) + <$> decodeText @(ViaAeson [Double]) (encodeText (ViaAeson ds)) + +test_zeros :: Assertion +test_zeros = + assertEqual + "a float zero stays a float" + (Right "- 0.0\n- 0.0\n- 0\n- 1.0\n") + (encodeText <$> decodeText @A.Value "[0.0, -0.0, 0, 1.0]") + +test_duplicateKeys :: Assertion +test_duplicateKeys = + assertEqual + "the first key stays" + "a: 1\nb: 3\n" + (encodeText (ViaAeson Twice)) + +test_invalidEncoding :: Assertion +test_invalidEncoding = do + -- The messages of the lexer of aeson can change between its versions, so + -- only their start is fixed. + assertInvalid + "an incomplete value" + "Unexpected" + (Raw "{") + assertInvalid + "content after the value" + "unexpected \"} [2]\" after the value" + (Raw "{\"a\":1}} [2]") + assertInvalid + "an invalid value in a list" + "Unexpected" + [Raw "1", Raw "x"] + assertEqual + "spaces after the value" + "a: 1\n" + (encodeText (ViaAeson (Raw "{\"a\":1} \n"))) + where + -- The message starts with the prefix of all such errors and the given + -- text. + assertInvalid :: A.ToJSON a => String -> String -> a -> Assertion + assertInvalid preface expected x = + try (evaluate (encodeText (ViaAeson x))) >>= \case + Left (ErrorCall msg) -> + assertBool + (preface ++ ": the error of the encoding: " ++ msg) + ((prefix ++ expected) `L.isPrefixOf` msg) + Right out -> assertFailure (preface ++ ": no error, the output is " ++ show out) + where + prefix :: String + prefix = "Yamlet.Aeson.ViaAeson: the toEncoding is not valid JSON: " + +prop_valueAsEncoding :: Property +prop_valueAsEncoding = forAll genValue $ \v -> toYaml (ViaAeson v) === toYaml v + +-- | An instance with the default 'A.toEncoding', which goes through +-- 'A.toJSON'. +data Unordered = Unordered {port :: Int, host :: T.Text} + deriving stock (Generic) + deriving anyclass (A.ToJSON) + +-- | An encoding with the key @a@ twice. +data Twice = Twice + +instance A.ToJSON Twice where + toJSON _ = A.object ["a" A..= (1 :: Int), "b" A..= (3 :: Int)] + toEncoding _ = + A.pairs ("a" A..= (1 :: Int) <> "a" A..= (2 :: Int) <> "b" A..= (3 :: Int)) + +-- | An encoding of the given text. +newtype Raw = Raw String + +instance A.ToJSON Raw where + toJSON (Raw s) = A.toJSON s + toEncoding (Raw s) = E.unsafeToEncoding (fromString s) diff --git a/tests/Yamlet/Aeson/Test/Helpers.hs b/tests/Yamlet/Aeson/Test/Helpers.hs new file mode 100644 --- /dev/null +++ b/tests/Yamlet/Aeson/Test/Helpers.hs @@ -0,0 +1,64 @@ +-- | The helpers that several test modules use. +module Yamlet.Aeson.Test.Helpers + ( errorsOf + , genValue + , Server (..) + ) where + +import Data.Aeson qualified as A +import Data.Aeson.Key qualified as K +import Data.List.NonEmpty qualified as NE +import Data.Scientific qualified as Sci +import Data.Text qualified as T +import Data.Vector qualified as V +import Test.Tasty.QuickCheck +import Yamlet + +-- | A value with numbers that yamlet reads back, i.e. with an exponent from +-- -1000 to 1000. +genValue :: Gen A.Value +genValue = sized go + where + go :: Int -> Gen A.Value + go n + | n <= 1 = scalar + | otherwise = + oneof + [ scalar + , A.Array . V.fromList <$> children go + , A.object <$> children (\m -> (A..=) . K.fromText <$> text <*> go m) + ] + where + -- The children share the size, so that a value has about as many + -- nodes as the size. + children :: (Int -> Gen a) -> Gen [a] + children gen = do + k <- choose (0, 5) + vectorOf k (gen (n `div` (k + 1))) + + scalar :: Gen A.Value + scalar = + oneof + [ pure A.Null + , A.Bool <$> arbitrary + , A.Number . fromInteger <$> arbitrary + , A.Number <$> (Sci.scientific <$> arbitrary <*> choose (-1000, 1000)) + , A.String <$> text + ] + + text :: Gen T.Text + text = T.pack <$> arbitrary + +-- | The line, the column and the message of each error. +errorsOf :: Either (NE.NonEmpty Error) a -> [(Int, Int, String)] +errorsOf = \case + Left errs -> + [(err.location.line, err.location.column, err.message) | err <- NE.toList errs] + Right _ -> [] + +data Server = Server {port :: Int, host :: T.Text} + deriving stock (Eq, Show, Generic) + deriving anyclass (A.FromJSON) + +instance A.ToJSON Server where + toEncoding = A.genericToEncoding A.defaultOptions diff --git a/tests/Yamlet/Aeson/Test/Helpers/Thunks.hs b/tests/Yamlet/Aeson/Test/Helpers/Thunks.hs new file mode 100644 --- /dev/null +++ b/tests/Yamlet/Aeson/Test/Helpers/Thunks.hs @@ -0,0 +1,28 @@ +-- | A check that a value is fully evaluated. +module Yamlet.Aeson.Test.Helpers.Thunks + ( thunks + ) where + +import GHC.Exts.Heap + +-- | The thunks that a value refers to, each with the constructors on the way +-- to it. +thunks :: a -> IO [String] +thunks = go [] . asBox + where + go :: [String] -> Box -> IO [String] + go path b = + getBoxedClosureData b >>= \case + ConstrClosure {name, ptrArgs} -> concat <$> mapM (go (name : path)) ptrArgs + -- An evaluated thunk refers to its value until the next garbage + -- collection. + IndClosure {indirectee} -> go path indirectee + BlackholeClosure {indirectee} -> go path indirectee + ThunkClosure {} -> found "thunk" + SelectorClosure {} -> found "selector thunk" + APClosure {} -> found "application thunk" + APStackClosure {} -> found "stack thunk" + _ -> pure [] + where + found :: String -> IO [String] + found kind = pure [unwords (reverse (kind : path))] diff --git a/tests/Yamlet/Aeson/Test/RoundTrip.hs b/tests/Yamlet/Aeson/Test/RoundTrip.hs new file mode 100644 --- /dev/null +++ b/tests/Yamlet/Aeson/Test/RoundTrip.hs @@ -0,0 +1,16 @@ +module Yamlet.Aeson.Test.RoundTrip + ( roundTripTests + ) where + +import Test.Tasty +import Test.Tasty.QuickCheck +import Yamlet + +import Yamlet.Aeson () +import Yamlet.Aeson.Test.Helpers + +roundTripTests :: TestTree +roundTripTests = testProperty "round trip" prop_roundTrip + +prop_roundTrip :: Property +prop_roundTrip = forAll genValue $ \v -> decodeText (encodeText v) === Right v diff --git a/yamlet-aeson.cabal b/yamlet-aeson.cabal new file mode 100644 --- /dev/null +++ b/yamlet-aeson.cabal @@ -0,0 +1,141 @@ +cabal-version: 3.8 +build-type: Simple +name: yamlet-aeson +version: 1.0.0.0 +license: BSD-3-Clause +license-file: LICENSE +category: Text, Data, JSON +maintainer: andrzej@rybczak.net +author: Andrzej Rybczak +synopsis: Use the FromJSON and ToJSON instances of aeson with yamlet. + +description: + Instances of @FromYaml@ and @ToYaml@ of + for the types that have + @FromJSON@ and @ToJSON@ instances of + , e.g. in a program that + moves from the yaml package to yamlet. Errors point to the node of the input + that caused them, and the encoder keeps the order of the fields of a type + whose instance defines @toEncoding@. + +extra-doc-files: + CHANGELOG.md + README.md + +tested-with: GHC ^>= { 9.2, 9.4, 9.6, 9.8, 9.10, 9.12, 9.14, 10.0 } + +bug-reports: https://github.com/arybczak/yamlet/issues +source-repository head + type: git + location: https://github.com/arybczak/yamlet.git + subdir: yamlet-aeson + +common language + ghc-options: -Wall + -Werror=missing-deriving-strategies + -Werror=name-shadowing + -Werror=prepositive-qualified-module + -Wno-unticked-promoted-constructors + + default-language: GHC2021 + + default-extensions: DataKinds + DeriveAnyClass + DerivingStrategies + DerivingVia + DuplicateRecordFields + LambdaCase + MultiWayIf + NoFieldSelectors + OverloadedRecordDot + OverloadedStrings + TypeFamilies + UndecidableInstances + +library + import: language + + build-depends: base >= 4.16 && < 5 + , aeson >= 2.3 && < 2.4 + , bytestring >= 0.11 + , containers >= 0.6.3.1 + , scientific >= 0.3.9 + , text >= 2.0.2 + , vector >= 0.13.1 + , yamlet >= 1.0 && < 2 + + hs-source-dirs: src + + exposed-modules: Yamlet.Aeson + +test-suite test + import: language + + ghc-options: -threaded -rtsopts + + build-depends: base + , aeson + , containers + , scientific + , tasty + , tasty-hunit >= 0.10 + , tasty-quickcheck >= 0.8.1 + , text + , vector + , yamlet + , yamlet-aeson + + hs-source-dirs: tests + + type: exitcode-stdio-1.0 + main-is: Main.hs + + other-modules: Yamlet.Aeson.Test.Decode + Yamlet.Aeson.Test.Encode + Yamlet.Aeson.Test.Helpers + Yamlet.Aeson.Test.RoundTrip + +test-suite retention + import: language + + ghc-options: -threaded -rtsopts + + build-depends: base + , aeson + , ghc-heap + , text + , yamlet + , yamlet-aeson + + hs-source-dirs: tests + + type: exitcode-stdio-1.0 + main-is: Retention.hs + + other-modules: Yamlet.Aeson.Test.Helpers.Thunks + +benchmark bench + import: language + + ghc-options: -rtsopts + + build-depends: base + , aeson + , bytestring + , containers + , deepseq + , scientific + , tasty-bench + , text + , yaml + , yamlet + , yamlet-aeson + + hs-source-dirs: bench + + type: exitcode-stdio-1.0 + main-is: Main.hs + + other-modules: Yamlet.Aeson.Bench.Inputs + Yamlet.Aeson.Bench.Libraries + Yamlet.Aeson.Bench.Types