yamlet-aeson (empty) → 1.0.0.0
raw patch · 16 files changed
+1615/−0 lines, 16 filesdep +aesondep +basedep +bytestring
Dependencies added: aeson, base, bytestring, containers, deepseq, ghc-heap, scientific, tasty, tasty-bench, tasty-hunit, tasty-quickcheck, text, vector, yaml, yamlet, yamlet-aeson
Files
- CHANGELOG.md +2/−0
- LICENSE +30/−0
- README.md +147/−0
- bench/Main.hs +17/−0
- bench/Yamlet/Aeson/Bench/Inputs.hs +48/−0
- bench/Yamlet/Aeson/Bench/Libraries.hs +69/−0
- bench/Yamlet/Aeson/Bench/Types.hs +189/−0
- src/Yamlet/Aeson.hs +364/−0
- tests/Main.hs +17/−0
- tests/Retention.hs +130/−0
- tests/Yamlet/Aeson/Test/Decode.hs +202/−0
- tests/Yamlet/Aeson/Test/Encode.hs +151/−0
- tests/Yamlet/Aeson/Test/Helpers.hs +64/−0
- tests/Yamlet/Aeson/Test/Helpers/Thunks.hs +28/−0
- tests/Yamlet/Aeson/Test/RoundTrip.hs +16/−0
- yamlet-aeson.cabal +141/−0
+ CHANGELOG.md view
@@ -0,0 +1,2 @@+# yamlet-aeson-1.0.0.0 (2026-10-11)+* Initial release.
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,147 @@+# yamlet-aeson++[](https://github.com/arybczak/yamlet/actions/workflows/haskell-gha.yaml?query=branch%3Amaster)+[](https://hackage.haskell.org/package/yamlet-aeson)+[](https://www.stackage.org/lts/package/yamlet-aeson)+[](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.
+ bench/Main.hs view
@@ -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"
+ bench/Yamlet/Aeson/Bench/Inputs.hs view
@@ -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
+ bench/Yamlet/Aeson/Bench/Libraries.hs view
@@ -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
+ bench/Yamlet/Aeson/Bench/Types.hs view
@@ -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
+ src/Yamlet/Aeson.hs view
@@ -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")
+ tests/Main.hs view
@@ -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+ ]
+ tests/Retention.hs view
@@ -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)
+ tests/Yamlet/Aeson/Test/Decode.hs view
@@ -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
+ tests/Yamlet/Aeson/Test/Encode.hs view
@@ -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)
+ tests/Yamlet/Aeson/Test/Helpers.hs view
@@ -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
+ tests/Yamlet/Aeson/Test/Helpers/Thunks.hs view
@@ -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))]
+ tests/Yamlet/Aeson/Test/RoundTrip.hs view
@@ -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
+ yamlet-aeson.cabal view
@@ -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+ <https://hackage.haskell.org/package/yamlet yamlet> for the types that have+ @FromJSON@ and @ToJSON@ instances of+ <https://hackage.haskell.org/package/aeson aeson>, 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