yaml-streamly (empty) → 0.12.0
raw patch · 34 files changed
+3693/−0 lines, 34 filesdep +HUnitdep +aesondep +attoparsecsetup-changed
Dependencies added: HUnit, aeson, attoparsec, base, base-compat, bytestring, containers, directory, filepath, hspec, libyaml-streamly, mockery, mtl, optparse-applicative, raw-strings-qq, safe-exceptions, scientific, streamly, template-haskell, temporary, text, transformers, unordered-containers, vector, yaml-streamly
Files
- ChangeLog.md +283/−0
- LICENSE +25/−0
- README.md +26/−0
- Setup.lhs +7/−0
- examples/Config.hs +55/−0
- examples/Main.hs +10/−0
- examples/Simple.hs +14/−0
- exe/Common.hs +68/−0
- exe/json2yaml.hs +106/−0
- exe/yaml2json.hs +87/−0
- src/Data/Yaml.hs +266/−0
- src/Data/Yaml/Aeson.hs +7/−0
- src/Data/Yaml/Builder.hs +248/−0
- src/Data/Yaml/Config.hs +229/−0
- src/Data/Yaml/Include.hs +95/−0
- src/Data/Yaml/Internal.hs +519/−0
- src/Data/Yaml/Parser.hs +208/−0
- src/Data/Yaml/Pretty.hs +102/−0
- src/Data/Yaml/TH.hs +80/−0
- test/Data/Yaml/IncludeSpec.hs +133/−0
- test/Data/Yaml/THSpec.hs +17/−0
- test/Data/YamlSpec.hs +892/−0
- test/Spec.hs +1/−0
- test/json.yaml +9/−0
- test/largest-string.yaml +6/−0
- test/resources/accent/foo.yaml +1/−0
- test/resources/bar.yaml +2/−0
- test/resources/baz.yaml +1/−0
- test/resources/empty.yaml +0/−0
- test/resources/empty2.yaml +1/−0
- test/resources/foo.yaml +3/−0
- test/resources/loop/bar.yaml +2/−0
- test/resources/loop/foo.yaml +3/−0
- yaml-streamly.cabal +187/−0
+ ChangeLog.md view
@@ -0,0 +1,283 @@+# ChangeLog for yaml-streamly++## 0.12.0++* Rewrite in streamly++## 0.11.7.0++* Support `aeson` 2 [#202](https://github.com/snoyberg/yaml/pull/202)++## 0.11.6.0++* `yaml2json`: add `--help` and `--version` options [#197](https://github.com/snoyberg/yaml/pull/197)+* `json2yaml`: add `--help` and `--version` options [#198](https://github.com/snoyberg/yaml/pull/198)+* Add the `-o` options to both `yaml2json` and `json2yaml` [#200](https://github.com/snoyberg/yaml/pull/200)++## 0.11.5.0++* New functions capable of parsing YAML streams containing multiple documents into a list of results:+ * `decodeAllEither'`+ * `decodeAllFileEither`+ * `decodeAllFileWithWarnings`+ * `decodeAllThrow`+ * `decodeAllFileThrow`++## 0.11.4.0++* add `ToYaml` instance for `String` [#186](https://github.com/snoyberg/yaml/pull/186)++## 0.11.3.0++* Don't wrap up async exceptions [#185](https://github.com/snoyberg/yaml/issues/185)++## 0.11.2.0++* Reduces some of the code duplication between the `encode` and `encodePretty` functions+* The output of `encodePretty` has been improved:+ - Multiline strings now use `Literal` style instead of `SingleQuoted`+ - Special keys are now quoted in mappings [#179](https://github.com/snoyberg/yaml/issues/179)+* Support for complex keys in mappings: [#182](https://github.com/snoyberg/yaml/issues/182)+ - Adds `complexMapping` function to `Data.Yaml.Builder`+ - Decode functions now return a `NonStringKey` error when attempting to decode a mapping with a complex key as it is not possible to decode these to an Aeson `Value`+* Adds missing `ToYaml` instances++## 0.11.1.2++* Compiles with GHC 8.8.1 (`MonadFail` split)++## 0.11.1.1++* Use the appropriate `Scientific` rendering function to avoid a memory overflow when rendering. The previously used function from `aeson` would not use scientific notation, and could use large amounts of memory for values such as `1e9999999999999`.++## 0.11.1.0++* Better error messages in the `Data.Yaml.Config` module [#168](https://github.com/snoyberg/yaml/issues/168)+* Add `LoadSettingsException` exception and remove error printing from `loadYamlSettings` [#172](https://github.com/snoyberg/yaml/pull/172)++## 0.11.0.0++* Split out the `libyaml` and `Text.Libyaml` code into its own package. [#145](https://github.com/snoyberg/yaml/issues/145)++## 0.10.4.0++* Add `decodeMarked` and `decodeFileMarked` functions to `Text.Libyaml`, and+ extend native bindings to extract mark information. [#157](https://github.com/snoyberg/yaml/issues/157)++## 0.10.3.0++* Add support for anchors and aliases to Data.Yaml.Builder [#155](https://github.com/snoyberg/yaml/pull/155)+* Fix test suite for 32 bit machines [#158](https://github.com/snoyberg/yaml/issues/158)++## 0.10.2.0++* Add `EncodeOptions` and `FormatOptions` to control the style of the encoded YAML. [#153](https://github.com/snoyberg/yaml/pull/153)+* Default to using literal style for multiline strings [#152](https://github.com/snoyberg/yaml/issues/152)++## 0.10.1.1++* Correctly declare libyaml dependency on system-libyaml flag [#151](https://github.com/snoyberg/yaml/pull/151)++## 0.10.1++* Avoid incurring a `semigroups` dependency on recent GHCs.+* Fix a space leak that was introduced with `0.10.0` [#147](https://github.com/snoyberg/yaml/issues/147)++## 0.10.0++* Add `decodeFileWithWarnings` which returns warnings for duplicate fields++## 0.9.0++* Expose style and tags on mappings and sequences in Text.Libyaml [#141](https://github.com/snoyberg/yaml/pull/141)++## 0.8.32++* Escape keys as necessary [#137](https://github.com/snoyberg/yaml/issues/137)+* Support hexadecimal and octal number values [#135](https://github.com/snoyberg/yaml/issues/135)+* More resilient `isNumeric` (should reduce cases of unneeded quoting)+* hpackify+* src subdir++## 0.8.31.1++* Add a workaround for a cabal bug [haskell-infra/hackage-trustees#165](https://github.com/haskell-infra/hackage-trustees/issues/165)++## 0.8.31++* Add `decodeThrow` and `decodeFileThrow` convenience functions.+* Upgrade libyaml versions+* Deprecate `decode` and `decodeEither`++## 0.8.30++* Removed `AppSettings` mentioned in `loadYamlSettings` error message.++## 0.8.29++* Deprecated `decodeFile` [#129](https://github.com/snoyberg/yaml/issues/129)+* Turn off executables by default [#103](https://github.com/snoyberg/yaml/issues/103)++## 0.8.28++* Add `Data.Yaml.TH.yamlQQ`++## 0.8.27++* Support conduit 1.3++## 0.8.26++* Add `Semigroup` instance [#123](https://github.com/snoyberg/yaml/pull/123)++## 0.8.25.2++* Use `throwM` instead of `monadThrow`++## 0.8.25.1++* Drop aeson-qq dep (incompatible with Stackage Nightly)++## 0.8.25++* Tweaks to the executable `yaml2json` [#119](https://github.com/snoyberg/yaml/pull/119): + - Add command-line option `-h` and `--help` to show help message+ - Error messages are now written to `stderr` instead of `stdout`++## 0.8.24++* New encodePretty option `setConfDropNull` to drop null values from objects [#116](https://github.com/snoyberg/yaml/issues/116)++## 0.8.23.3++* Avoid over-escaping `*` [#113](https://github.com/snoyberg/yaml/issues/113)++## 0.8.23.2++* Update libyaml [#110](https://github.com/snoyberg/yaml/issues/110)++## 0.8.23.1++* Update CPP `MIN_VERSION_*` checks [#109](https://github.com/snoyberg/yaml/pull/109)++## 0.8.23++* Re-export the with helpers from aeson++## 0.8.22.1++* Make numeric string detection slightly smarter so, e.g., `.` does+ not get quoted++## 0.8.22++* Update to libyaml hosted on Github [#105](https://github.com/snoyberg/yaml/issues/105)++## 0.8.21.2++* Fix wrong file not found exception in `Data.Yaml.Include` with pre-1.2.3.0 `directory` [#104](https://github.com/snoyberg/yaml/pull/104)++## 0.8.21.1++* Add missing test files [#102](https://github.com/snoyberg/yaml/pull/102)++## 0.8.21++* Decode empty inputs as Null [#101](https://github.com/snoyberg/yaml/pull/101)++## 0.8.20++* Upgrade to libyaml 0.1.7++## 0.8.19.0++* Add `Data.Yaml.TH` module++## 0.8.18.7++* Add `O_TRUNC` when opening files++## 0.8.18.6++* s/fdopen/_fdopen on Windows [#96](https://github.com/snoyberg/yaml/issues/96)++## 0.8.18.5++* Properly fix previous bug (fixes #94)++## 0.8.18.4++* Remove file with non-ASCII name due to Stack/cabal-install/Hackage+ restrictions (see [#92](https://github.com/snoyberg/yaml/issues/92))++## 0.8.18.2++* Handle non-ASCII filenames correctly on Windows [#91](https://github.com/snoyberg/yaml/pull/91)++## 0.8.18.1++* Improve prettyPrintParseException when context is empty [#89](https://github.com/snoyberg/yaml/pull/89)++## 0.8.18++* Switched yaml decode function for config file readers in `Data.Yaml.Config` to+ the one from `Data.Yaml.Include` that supports `!include` syntax.++## 0.8.17.2++* Fix pretty-printing order of UnexpectedEvent's fields (fixes [#84](https://github.com/snoyberg/yaml/issues/84)) [#85](https://github.com/snoyberg/yaml/pull/85)++## 0.8.17.1++* Avoid bug in Cabal [#83](https://github.com/snoyberg/yaml/pull/83)++## 0.8.17++* `loadYamlSettingsArgs`++## 0.8.16.1++* Slight doc improvement++## 0.8.16++Add env variable parsing. `loadYamlSettings` can read config values from the environment with Yaml that specifies an env var.+The syntax is++`var: _env:ENV_VAR:default`++## 0.8.15.3++* Give a warning when compiling with GHCJS++## 0.8.15.2++* Canonicalise Monad instances [#76](https://github.com/snoyberg/yaml/pull/76)++## 0.8.15.1++* Compile with aeson below 0.7 [#70](https://github.com/snoyberg/yaml/pull/70)++## 0.8.15++* Parse `Scientific` directly, avoiding loss in precision. [#68](https://github.com/snoyberg/yaml/pull/68)++## 0.8.14++* Pretty print improvements for exceptions [#67](https://github.com/snoyberg/yaml/pull/67)++## 0.8.13++* Pretty module [#66](https://github.com/snoyberg/yaml/pull/66)++## 0.8.12++* Proper handling of `String "+123"` [#64](https://github.com/snoyberg/yaml/issues/64)++## 0.8.11++* Function to print prettier parse exceptions [#59](https://github.com/snoyberg/yaml/pull/59)++## 0.8.10++Add the Data.Yaml.Include module
+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2008, Michael Snoyman. 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.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 HOLDERS 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,26 @@+## yaml++[](https://github.com/snoyberg/yaml/actions/workflows/tests.yml)+[](https://ci.appveyor.com/project/snoyberg/yaml/branch/master)++Provides support for parsing and emitting Yaml documents.++`Data.Yaml` provides a high-level interface based around the JSON datatypes provided by the `aeson` package. It uses `Text.Libyaml` from `libyaml` in its implementation of the low-level yaml encoder/decoder.++### Examples++Usage examples can be found in the `Data.Yaml` documentation or in the [examples](https://github.com/snoyberg/yaml/tree/master/yaml/examples) directory.++### Additional `yaml` modules++* `Data.Yaml.Include` supports adding `!include` directives to your YAML files.+* `Data.Yaml.Builder` and `Data.Yaml.Parser` allow more fine-grained control of parsing an rendering, as opposed to just using the aeson typeclass and datatype system for parsing and rendering.+* `Data.Yaml.Aeson` is currently a re-export of `Data.Yaml` to explicitly choose to use the aeson-compatible API.++### Executables++Converters `json2yaml` and `yaml2json` can be built by disabling flag `no-exe`, e.g., one of:+```+cabal install yaml -f-no-exe+stack install yaml --flag yaml:-no-exe+```
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ examples/Config.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Config where++import Data.Text (Text)+import qualified Data.Yaml as Y+import Data.Yaml (FromJSON(..), (.:))+import Text.RawString.QQ+import Data.ByteString (ByteString)+import Control.Applicative+import Prelude -- Ensure Applicative is in scope and we have no warnings, before/after AMP.++configYaml :: ByteString+configYaml = [r|+resolver: lts-3.7+packages:+ - ./yesod-core+ - ./yesod-static+ - ./yesod-persistent+ - ./yesod-newsfeed+ - ./yesod-form+ - ./yesod-auth+ - ./yesod-auth-oauth+ - ./yesod-sitemap+ - ./yesod-test+ - ./yesod-bin+ - ./yesod+ - ./yesod-eventsource+ - ./yesod-websockets++# Needed for LTS 2+extra-deps:+- wai-app-static-3.1.4.1+|]++data Config =+ Config {+ resolver :: Text+ , packages :: [FilePath]+ , extraDeps :: [Text]+ } deriving (Eq, Show)++instance FromJSON Config where+ parseJSON (Y.Object v) =+ Config <$>+ v .: "resolver" <*>+ v .: "packages" <*>+ v .: "extra-deps"+ parseJSON _ = fail "Expected Object for Config value"++main :: IO ()+main = do+ config <- Y.decodeThrow configYaml+ print (config :: Config)
+ examples/Main.hs view
@@ -0,0 +1,10 @@+module Main where++import qualified Config+import qualified Simple++main :: IO ()+main = do+ Simple.main+ Config.main+
+ examples/Simple.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE OverloadedStrings #-}++module Simple where++import qualified Data.Yaml as Y++main :: IO ()+main = do+ res <- Y.decodeThrow "[1,2,3]"+ print (res :: [Integer])++-- You can go one step further and decode into a custom type by implementing+-- 'FromJSON' for that type. This is also appropriate where extra+-- normalization, formatting or manipulation of the YAML is required on decode.
+ exe/Common.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}++-- | Code shared between @yaml2json@ and @json2yaml@.++module Common where++import Data.List ( intercalate )+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup ( Semigroup(..) )+#endif+import Data.Version ( Version(versionBranch) )++import Options.Applicative ( Parser, help, hidden, infoOption, long, short )++import qualified Paths_yaml_streamly as Paths++-- * Version info and option+---------------------------------------------------------------------------++-- | Homepage for @yaml2json@ and @json2yaml@.++homepage :: String+homepage = "https://github.com/snoyberg/yaml/"++-- | Version in @x.y.z@ format.++version :: String+version = intercalate "." $ map show $ versionBranch Paths.version++-- | The version header including given program name and 'homepage'.++versionText :: String -> String+versionText self = unwords+ [ self+ , "version"+ , version+ , homepage -- concat [ "<", homepage, ">" ]+ ]++-- | Option @--numeric-version@.++numericVersionOption :: Parser (a -> a)+numericVersionOption =+ infoOption version+ $ long "numeric-version"+ <> hidden+ <> help "Show just version number."++-- | Option @--version@.++versionOption :: String -> Parser (a -> a)+versionOption self =+ infoOption (versionText self)+ $ long "version"+ <> short 'V'+ <> hidden+ <> help "Show version info."++-- * Misc+---------------------------------------------------------------------------++-- | @Just@ unless argument is @"-"@ (denoting @stdin@ or @stdout@).++dashToNothing :: FilePath -> Maybe FilePath+dashToNothing = \case+ "-" -> Nothing+ file -> Just file
+ exe/json2yaml.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NamedFieldPuns #-}++import qualified Data.Aeson as J+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import qualified Data.Yaml as Y+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup ( Semigroup(..) )+#endif++import Options.Applicative+ ( Parser, (<|>)+ , action, execParser, footerDoc, headerDoc, help, helper, hidden, info+ , long, metavar, short, strArgument, strOption, value+ )+import Options.Applicative.Help.Pretty+ ( vcat, text )++import System.Exit ( die )++import Common ( dashToNothing, versionText, versionOption, numericVersionOption )++data Options = Options+ { optInput :: Maybe FilePath+ -- ^ 'Nothing' means @stdin@.+ , optOutput :: Maybe FilePath+ -- ^ 'Nothing' means @stdout@.+ }++-- | Name of the executable.++self :: String+self = "json2yaml"++-- | Parse options; handle parse errors, @--help@, @--version@.++options :: IO Options+options =+ execParser $+ info (helper <*> versionOption self <*> numericVersionOption <*> programOptions)+ $ headerDoc hdoc+ <> footerDoc fdoc++ where+ hdoc = Just $ vcat $ map text+ [ versionText self+ , "Convert JSON to YAML."+ ]+ fdoc = Just $ text $ concat+ [ "The old call pattern '"+ , self+ , " IN OUT' is also accepted, but deprecated."+ ]++ programOptions :: Parser Options+ programOptions = Options <$> oInput <*> oOutput++ oInput :: Parser (Maybe FilePath)+ oInput = dashToNothing <$> do+ strArgument+ $ metavar "IN"+ <> value "-"+ <> action "file"+ <> help "The input file containing the JSON document; use '-' for stdin (default)."++ oOutput :: Parser (Maybe FilePath)+ oOutput = dashToNothing <$> do+ oOutputExplicit <|> oOutputImplicit++ oOutputExplicit :: Parser FilePath+ oOutputExplicit =+ strOption+ $ long "output"+ <> short 'o'+ <> metavar "OUT"+ <> action "file"+ -- <> help "The file to hold the produced YAML document; use '-' for stdout (default)."++ oOutputImplicit :: Parser FilePath+ oOutputImplicit =+ strArgument+ $ metavar "OUT"+ <> value "-"+ <> action "file"+ <> hidden+ <> help "The file to hold the produced YAML document; use '-' for stdout (default)."++-- | Exit with 'self'-stamped error message.++abort :: String -> IO a+abort msg = die $ concat [ self, ": ", msg ]++main :: IO ()+main = do+ Options{ optInput, optOutput } <- options++ -- Read JSON.+ mval <- J.decode <$> maybe L.getContents L.readFile optInput++ -- Write YAML.+ case mval of+ Nothing -> abort "Invalid input JSON"+ Just val -> case optOutput of+ Nothing -> S.putStr $ Y.encode (val :: Y.Value)+ Just f -> Y.encodeFile f val
+ exe/yaml2json.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}++import Data.Aeson (encode, Value)+import qualified Data.ByteString as S (getContents)+import qualified Data.ByteString.Lazy as L (putStr, writeFile)+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup(..))+#endif+import Data.Yaml (decodeFileEither, decodeEither')+import System.Exit (die)++import Options.Applicative+ ( Parser+ , action, execParser, headerDoc, help, helper, info+ , long, metavar, short, strArgument, strOption, value+ )+import Options.Applicative.Help.Pretty+ ( vcat, text )++import Common+ ( versionText, versionOption, numericVersionOption, dashToNothing )++data Options = Options+ { optInput :: Maybe FilePath+ -- ^ 'Nothing' means @stdin@.+ , optOutput :: Maybe FilePath+ -- ^ 'Nothing' means @stdout@.+ }++-- | Name of the executable.++self :: String+self = "yaml2json"++-- | Parse options; handle parse errors, @--help@, @--version@.++options :: IO Options+options =+ execParser $+ info (helper <*> versionOption self <*> numericVersionOption <*> programOptions)+ (headerDoc hdoc)++ where+ hdoc = Just $ vcat $ map text+ [ versionText self+ , "Convert YAML to JSON."+ ]++ programOptions = Options <$> oInput <*> oOutput++ oInput :: Parser (Maybe FilePath)+ oInput = dashToNothing <$> do+ strArgument+ $ metavar "IN"+ <> value "-"+ <> action "file"+ <> help "The input file containing the YAML document; use '-' for stdin (default)."++ oOutput :: Parser (Maybe FilePath)+ oOutput = dashToNothing <$> do+ strOption+ $ long "output"+ <> short 'o'+ <> value "-"+ <> metavar "OUT"+ <> action "file"+ <> help "The file to hold the produced JSON document; use '-' for stdout (default)."+++main :: IO ()+main = do+ Options{ optInput, optOutput } <- options++ -- Input YAML.+ result <- case optInput of+ -- strict getContents will read in all of stdin at once+ Nothing -> decodeEither' <$> S.getContents+ Just f -> decodeFileEither f++ -- Output JSON.+ case result of+ Left err -> die $ show err+ Right val -> do+ let json = encode (val :: Value)+ maybe L.putStr L.writeFile optOutput json
+ src/Data/Yaml.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Provides a high-level interface for processing YAML files.+--+-- This module reuses most of the infrastructure from the @aeson@ package.+-- This means that you can use all of the existing tools for JSON+-- processing for processing YAML files. As a result, much of the+-- documentation below mentions JSON; do not let that confuse you, it's+-- intentional.+--+-- For the most part, YAML content translates directly into JSON, and+-- therefore there is very little data loss. If you need to deal with YAML+-- more directly (e.g., directly deal with aliases), you should use the+-- "Text.Libyaml" module instead.+--+-- For documentation on the @aeson@ types, functions, classes, and+-- operators, please see the @Data.Aeson@ module of the @aeson@ package.+--+-- Look in the examples directory of the source repository for some initial+-- pointers on how to use this library.++#if (defined (ghcjs_HOST_OS))+module Data.Yaml {-# WARNING "GHCJS is not supported yet (will break at runtime once called)." #-}+#else+module Data.Yaml+#endif+ ( -- * Encoding+ encode+ , encodeWith+ , encodeFile+ , encodeFileWith+ -- * Decoding+ , decodeEither'+ , decodeFileEither+ , decodeFileWithWarnings+ , decodeThrow+ , decodeFileThrow+ -- ** Decoding multiple documents+ --+ -- | For situations where we need to be able to parse multiple documents+ -- separated by `---` in a YAML stream, these functions decode a list of+ -- values rather than a single value.+ , decodeAllEither'+ , decodeAllFileEither+ , decodeAllFileWithWarnings+ , decodeAllThrow+ , decodeAllFileThrow+ -- ** More control over decoding+ , decodeHelper+ -- * Types+ , Value (..)+ , Parser+ , Object+ , Array+ , ParseException(..)+ , prettyPrintParseException+ , YamlException (..)+ , YamlMark (..)+ -- * Constructors and accessors+ , object+ , array+ , (.=)+ , (.:)+ , (.:?)+ , (.!=)+ -- ** With helpers (since 0.8.23)+ , withObject+ , withText+ , withArray+ , withScientific+ , withBool+ -- * Parsing+ , parseMonad+ , parseEither+ , parseMaybe+ -- * Classes+ , ToJSON (..)+ , FromJSON (..)+ -- * Custom encoding+ , isSpecialString+ , EncodeOptions+ , defaultEncodeOptions+ , defaultStringStyle+ , setStringStyle+ , setFormat+ , FormatOptions+ , defaultFormatOptions+ , setWidth+ ) where+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative((<$>))+#endif+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Aeson+ ( Value (..), ToJSON (..), FromJSON (..), object+ , (.=) , (.:) , (.:?) , (.!=)+ , Object, Array+ , withObject, withText, withArray, withScientific, withBool+ )+import Data.Aeson.Types (parseMaybe, parseEither, Parser)+import Data.ByteString (ByteString)+import qualified Data.Vector as V+import System.IO.Unsafe (unsafePerformIO)+import Data.Text (Text)++import Data.Yaml.Internal+import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile, encodeWith, encodeFileWith)+import qualified Text.Libyaml as Y++import Control.Exception.Safe++import qualified Streamly.Prelude as S+++-- | Set the string style in the encoded YAML. This is a function that decides+-- for each string the type of YAML string to output.+--+-- __WARNING__: You must ensure that special strings (like @"yes"@\/@"no"@\/@"null"@\/@"1234"@) are not encoded with the 'Plain' style, because+-- then they will be decoded as boolean, null or numeric values. You can use 'isSpecialString' to detect them.+--+-- By default, strings are encoded as follows:+--+-- * Any string containing a newline character uses the 'Literal' style+--+-- * Otherwise, any special string (see 'isSpecialString') uses 'SingleQuoted'+--+-- * Otherwise, use 'Plain'+--+-- @since 0.10.2.0+setStringStyle :: (Text -> ( Tag, Style )) -> EncodeOptions -> EncodeOptions+setStringStyle s opts = opts { encodeOptionsStringStyle = s }++-- | Set the encoding formatting for the encoded YAML. By default, this is `defaultFormatOptions`.+--+-- @since 0.10.2.0+setFormat :: FormatOptions -> EncodeOptions -> EncodeOptions+setFormat f opts = opts { encodeOptionsFormat = f }++-- |+-- @since 0.10.2.0+data EncodeOptions = EncodeOptions+ { encodeOptionsStringStyle :: Text -> ( Tag, Style )+ , encodeOptionsFormat :: FormatOptions+ }++-- |+-- @since 0.10.2.0+defaultEncodeOptions :: EncodeOptions+defaultEncodeOptions = EncodeOptions+ { encodeOptionsStringStyle = defaultStringStyle+ , encodeOptionsFormat = defaultFormatOptions+ }++-- | Encode a value into its YAML representation.+encode :: ToJSON a => a -> ByteString+encode = encodeWith defaultEncodeOptions++-- | Encode a value into its YAML representation with custom styling.+--+-- @since 0.10.2.0+encodeWith :: ToJSON a => EncodeOptions -> a -> ByteString+encodeWith opts obj = unsafePerformIO $ Y.encodeWith (encodeOptionsFormat opts) (S.fromList $ objToStream (encodeOptionsStringStyle opts) $ toJSON obj)++-- | Encode a value into its YAML representation and save to the given file.+encodeFile :: ToJSON a => FilePath -> a -> IO ()+encodeFile = encodeFileWith defaultEncodeOptions++-- | Encode a value into its YAML representation with custom styling and save to the given file.+--+-- @since 0.10.2.0+encodeFileWith :: ToJSON a => EncodeOptions -> FilePath -> a -> IO ()+encodeFileWith opts fp obj = Y.encodeFileWith (encodeOptionsFormat opts) fp (S.fromList $ objToStream (encodeOptionsStringStyle opts) $ toJSON obj)++-- | A version of 'decodeFile' which should not throw runtime exceptions.+--+-- @since 0.8.4+decodeFileEither+ :: FromJSON a+ => FilePath+ -> IO (Either ParseException a)+decodeFileEither = fmap (fmap snd) . decodeFileWithWarnings++-- | Like `decodeFileEither`, but decode multiple documents.+--+-- @since 0.11.5.0+decodeAllFileEither+ :: FromJSON a+ => FilePath+ -> IO (Either ParseException [a])+decodeAllFileEither = fmap (fmap snd) . decodeAllFileWithWarnings++-- | A version of `decodeFileEither` that returns warnings along with the parse+-- result.+--+-- @since 0.10.0+decodeFileWithWarnings+ :: FromJSON a+ => FilePath+ -> IO (Either ParseException ([Warning], a))+decodeFileWithWarnings = decodeHelper_ . Y.decodeFile++-- | Like `decodeFileWithWarnings`, but decode multiple documents.+--+-- @since 0.11.5.0+decodeAllFileWithWarnings+ :: FromJSON a+ => FilePath+ -> IO (Either ParseException ([Warning], [a]))+decodeAllFileWithWarnings = decodeAllHelper_ . Y.decodeFile+++-- | More helpful version of 'decodeEither' which returns the 'YamlException'.+--+-- @since 0.8.3+decodeEither' :: FromJSON a => ByteString -> Either ParseException a+decodeEither' = either Left (either (Left . AesonException) Right)+ . unsafePerformIO+ . fmap (fmap snd) . decodeHelper+ . Y.decode++-- | Like 'decodeEither'', but decode multiple documents.+--+-- @since 0.11.5.0+decodeAllEither' :: FromJSON a => ByteString -> Either ParseException [a]+decodeAllEither' = either Left (either (Left . AesonException) Right)+ . unsafePerformIO+ . fmap (fmap snd) . decodeAllHelper+ . Y.decode++-- | A version of 'decodeEither'' lifted to MonadThrow+--+-- @since 0.8.31+decodeThrow :: (MonadThrow m, FromJSON a) => ByteString -> m a+decodeThrow = either throwM return . decodeEither'++-- | Like `decodeThrow`, but decode multiple documents.+--+-- @since 0.11.5.0+decodeAllThrow :: (MonadThrow m, FromJSON a) => ByteString -> m [a]+decodeAllThrow = either throwM return . decodeAllEither'++-- | A version of 'decodeFileEither' lifted to MonadIO+--+-- @since 0.8.31+decodeFileThrow :: (MonadIO m, FromJSON a) => FilePath -> m a+decodeFileThrow f = liftIO $ decodeFileEither f >>= either throwIO return++-- | Like `decodeFileThrow`, but decode multiple documents.+--+-- @since 0.11.5.0+decodeAllFileThrow :: (MonadIO m, FromJSON a) => FilePath -> m [a]+decodeAllFileThrow f = liftIO $ decodeAllFileEither f >>= either throwIO return++-- | Construct a new 'Value' from a list of 'Value's.+array :: [Value] -> Value+array = Array . V.fromList++#if MIN_VERSION_base(4, 13, 0)+parseMonad :: MonadFail m => (a -> Parser b) -> a -> m b+#else+parseMonad :: Monad m => (a -> Parser b) -> a -> m b+#endif+parseMonad p = either fail return . parseEither p+{-# DEPRECATED parseMonad "With the MonadFail split, this function is going to be removed in the future. Please migrate to parseEither." #-}
+ src/Data/Yaml/Aeson.hs view
@@ -0,0 +1,7 @@+-- | Just a re-export of @Data.Yaml@. In the future, this will be the canonical+-- name for that module\'s contents.+module Data.Yaml.Aeson+ ( module Data.Yaml+ ) where++import Data.Yaml
+ src/Data/Yaml/Builder.hs view
@@ -0,0 +1,248 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+-- | NOTE: This module is a highly experimental preview release. It may change+-- drastically, or be entirely removed, in a future release.+module Data.Yaml.Builder+ ( YamlBuilder (..)+ , ToYaml (..)+ , mapping+ , namedMapping+ , maybeNamedMapping+ , mappingComplex+ , namedMappingComplex+ , maybeNamedMappingComplex+ , array+ , namedArray+ , maybeNamedArray+ , string+ , namedString+ , maybeNamedString+ , bool+ , namedBool+ , maybeNamedBool+ , null+ , namedNull+ , maybeNamedNull+ , scientific+ , namedScientific+ , maybeNamedScientific+ , alias+ , number+ , toByteString+ , toByteStringWith+ , writeYamlFile+ , writeYamlFileWith+ , (.=)+ , FormatOptions+ , setWidth+ ) where++import Prelude hiding (null)++#if MIN_VERSION_aeson(1,0,0)+import Data.Aeson.Text (encodeToTextBuilder)+#else+import Data.Aeson.Encode (encodeToTextBuilder)+#endif+import Data.Aeson.Types (Value(..))+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S8+import Data.Scientific (Scientific)+import Data.Text (Text, unpack)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Lazy as TL+import Data.Text.Lazy.Builder (toLazyText)+import System.IO.Unsafe (unsafePerformIO)++import Data.Yaml.Internal+import Text.Libyaml++import Control.Exception.Safe++import qualified Streamly.Prelude as S+import Streamly.Prelude (SerialT, MonadAsync)++(.=) :: ToYaml a => Text -> a -> (Text, YamlBuilder)+k .= v = (k, toYaml v)++newtype YamlBuilder = YamlBuilder { unYamlBuilder :: [Event] -> [Event] }++class ToYaml a where+ toYaml :: a -> YamlBuilder+instance ToYaml YamlBuilder where+ toYaml = id+instance (ToYaml a, ToYaml b) => ToYaml [(a, b)] where+ toYaml = mappingComplex . map (\(k, v) -> (toYaml k, toYaml v))+instance ToYaml a => ToYaml [a] where+ toYaml = array . map toYaml+instance ToYaml Text where+ toYaml = string+instance {-# OVERLAPPING #-} ToYaml String where+ toYaml = string . T.pack+instance ToYaml Int where+ toYaml i = YamlBuilder (EventScalar (S8.pack $ show i) NoTag PlainNoTag Nothing:)+instance ToYaml Double where+ toYaml i = YamlBuilder (EventScalar (S8.pack $ show i) NoTag PlainNoTag Nothing:)+instance ToYaml Scientific where+ toYaml = scientific+instance ToYaml Bool where+ toYaml = bool+instance ToYaml a => ToYaml (Maybe a) where+ toYaml = maybe null toYaml++-- |+-- @since 0.10.3.0+maybeNamedMapping :: Maybe Text -> [(Text, YamlBuilder)] -> YamlBuilder+maybeNamedMapping anchor pairs = maybeNamedMappingComplex anchor complexPairs+ where+ complexPairs = map (\(k, v) -> (string k, v)) pairs++-- |+-- @since 0.8.7+mapping :: [(Text, YamlBuilder)] -> YamlBuilder+mapping = maybeNamedMapping Nothing++-- |+-- @since 0.10.3.0+namedMapping :: Text -> [(Text, YamlBuilder)] -> YamlBuilder+namedMapping name = maybeNamedMapping $ Just name++-- |+-- @since 0.11.2.0+maybeNamedMappingComplex :: Maybe Text -> [(YamlBuilder, YamlBuilder)] -> YamlBuilder+maybeNamedMappingComplex anchor pairs = YamlBuilder $ \rest ->+ EventMappingStart NoTag AnyMapping (unpack <$> anchor) : foldr addPair (EventMappingEnd : rest) pairs+ where+ addPair (YamlBuilder key, YamlBuilder value) after = key $ value after++-- |+-- @since 0.11.2.0+mappingComplex :: [(YamlBuilder, YamlBuilder)] -> YamlBuilder+mappingComplex = maybeNamedMappingComplex Nothing++-- |+-- @since 0.11.2.0+namedMappingComplex :: Text -> [(YamlBuilder, YamlBuilder)] -> YamlBuilder+namedMappingComplex name = maybeNamedMappingComplex $ Just name++-- |+-- @since 0.10.3.0+maybeNamedArray :: Maybe Text -> [YamlBuilder] -> YamlBuilder+maybeNamedArray anchor bs =+ YamlBuilder $ (EventSequenceStart NoTag AnySequence (unpack <$> anchor):) . flip (foldr go) bs . (EventSequenceEnd:)+ where+ go (YamlBuilder b) = b++-- |+-- @since 0.8.7+array :: [YamlBuilder] -> YamlBuilder+array = maybeNamedArray Nothing++-- |+-- @since 0.10.3.0+namedArray :: Text -> [YamlBuilder] -> YamlBuilder+namedArray name = maybeNamedArray $ Just name++-- |+-- @since 0.10.3.0+maybeNamedString :: Maybe Text -> Text -> YamlBuilder+maybeNamedString anchor s = YamlBuilder (stringScalar defaultStringStyle anchor s :)++-- |+-- @since 0.8.7+string :: Text -> YamlBuilder+string = maybeNamedString Nothing++-- |+-- @since 0.10.3.0+namedString :: Text -> Text -> YamlBuilder+namedString name = maybeNamedString $ Just name+ +-- Use aeson's implementation which gets rid of annoying decimal points+-- |+-- @since 0.10.3.0+maybeNamedScientific :: Maybe Text -> Scientific -> YamlBuilder+maybeNamedScientific anchor n = YamlBuilder (EventScalar (TE.encodeUtf8 $ TL.toStrict $ toLazyText $ encodeToTextBuilder (Number n)) NoTag PlainNoTag (unpack <$> anchor) :)++-- |+-- @since 0.8.13+scientific :: Scientific -> YamlBuilder+scientific = maybeNamedScientific Nothing++-- |+-- @since 0.10.3.0+namedScientific :: Text -> Scientific -> YamlBuilder+namedScientific name = maybeNamedScientific $ Just name++-- |+-- @since 0.8.13+{-# DEPRECATED number "Use scientific" #-}+number :: Scientific -> YamlBuilder+number = scientific++-- |+-- @since 0.10.3.0+maybeNamedBool :: Maybe Text -> Bool -> YamlBuilder+maybeNamedBool anchor True = YamlBuilder (EventScalar "true" NoTag PlainNoTag (unpack <$> anchor) :)+maybeNamedBool anchor False = YamlBuilder (EventScalar "false" NoTag PlainNoTag (unpack <$> anchor) :)++-- |+-- @since 0.8.13+bool :: Bool -> YamlBuilder+bool = maybeNamedBool Nothing++-- |+-- @since 0.10.3.0+namedBool :: Text -> Bool -> YamlBuilder+namedBool name = maybeNamedBool $ Just name++-- |+-- @since 0.10.3.0+maybeNamedNull :: Maybe Text -> YamlBuilder+maybeNamedNull anchor = YamlBuilder (EventScalar "null" NoTag PlainNoTag (unpack <$> anchor) :)++-- |+-- @since 0.8.13+null :: YamlBuilder+null = maybeNamedNull Nothing++-- |+-- @since 0.10.3.0+namedNull :: Text -> YamlBuilder+namedNull name = maybeNamedNull $ Just name++-- |+-- @since 0.10.3.0+alias :: Text -> YamlBuilder+alias anchor = YamlBuilder (EventAlias (unpack anchor) :)++toEvents :: YamlBuilder -> [Event]+toEvents (YamlBuilder front) =+ EventStreamStart : EventDocumentStart : front [EventDocumentEnd, EventStreamEnd]++toSource :: (Monad m, ToYaml a, MonadCatch m, MonadAsync m, MonadMask m)+ => a+ -> SerialT m Event+toSource = S.fromList . toEvents . toYaml++-- |+-- @since 0.8.7+toByteString :: ToYaml a => a -> ByteString+toByteString = toByteStringWith defaultFormatOptions+++-- |+-- @since 0.10.2.0+toByteStringWith :: ToYaml a => FormatOptions -> a -> ByteString+toByteStringWith opts yb = unsafePerformIO $ encodeWith opts (toSource yb)++writeYamlFile :: ToYaml a => FilePath -> a -> IO ()+writeYamlFile = writeYamlFileWith defaultFormatOptions++-- |+-- @since 0.10.2.0+writeYamlFileWith :: ToYaml a => FormatOptions -> FilePath -> a -> IO ()+writeYamlFileWith opts fp yb = encodeFileWith opts fp (toSource yb)
+ src/Data/Yaml/Config.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Functionality for using YAML as configuration files+--+-- In particular, merging environment variables with yaml values+--+-- 'loadYamlSettings' is a high-level API for loading YAML and merging environment variables.+-- A yaml value of @_env:ENV_VAR:default@ will lookup the environment variable @ENV_VAR@.+--+-- On a historical note, this code was taken directly from the yesod web framework's configuration module.+module Data.Yaml.Config+ ( -- * High-level+ loadYamlSettings+ , loadYamlSettingsArgs+ -- ** EnvUsage+ , EnvUsage+ , ignoreEnv+ , useEnv+ , requireEnv+ , useCustomEnv+ , requireCustomEnv+ -- * Lower level+ , applyCurrentEnv+ , getCurrentEnv+ , applyEnvValue+ ) where+++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>))+import Data.Monoid+#endif+import Data.Semigroup+import Data.List.NonEmpty (nonEmpty)+import Data.Aeson+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as K+import qualified Data.Aeson.KeyMap as H+import Data.Aeson.KeyMap (KeyMap)+#else+import qualified Data.HashMap.Strict as H+#endif+import Data.Text (Text, pack)+import System.Environment (getArgs, getEnvironment)+import Control.Arrow ((***))+import Control.Monad (forM)+import Control.Exception (throwIO)+import Data.Text.Encoding (encodeUtf8)+import qualified Data.Yaml as Y+import qualified Data.Yaml.Include as YI+import Data.Maybe (fromMaybe)+import qualified Data.Text as T++#if MIN_VERSION_aeson(2,0,0)+fromText :: T.Text -> Key+fromText = K.fromText+#else+fromText :: T.Text -> T.Text+fromText = id++type KeyMap a = H.HashMap T.Text a+#endif++newtype MergedValue = MergedValue { getMergedValue :: Value }++instance Semigroup MergedValue where+ MergedValue x <> MergedValue y = MergedValue $ mergeValues x y++-- | Left biased+mergeValues :: Value -> Value -> Value+mergeValues (Object x) (Object y) = Object $ H.unionWith mergeValues x y+mergeValues x _ = x++-- | Override environment variable placeholders in the given @Value@ with+-- values from the environment.+--+-- If the first argument is @True@, then all placeholders _must_ be provided by+-- the actual environment. Otherwise, default values from the @Value@ will be+-- used.+--+-- @since 0.8.16+applyEnvValue :: Bool -- ^ require an environment variable to be present?+ -> KeyMap Text -> Value -> Value+applyEnvValue requireEnv' env =+ goV+ where+ goV (Object o) = Object $ goV <$> o+ goV (Array a) = Array (goV <$> a)+ goV (String t1) = fromMaybe (String t1) $ do+ t2 <- T.stripPrefix "_env:" t1+ let (name, t3) = T.break (== ':') t2+ mdef = fmap parseValue $ T.stripPrefix ":" t3+ Just $ case H.lookup (fromText name) env of+ Just val ->+ -- If the default value parses as a String, we treat the+ -- environment variable as a raw value and do not parse it.+ -- This means that things like numeric passwords just work.+ -- However, for originally numerical or boolean values (e.g.,+ -- port numbers), we still perform a normal YAML parse.+ --+ -- For details, see:+ -- https://github.com/yesodweb/yesod/issues/1061+ case mdef of+ Just (String _) -> String val+ _ -> parseValue val+ Nothing ->+ case mdef of+ Just val | not requireEnv' -> val+ _ -> Null+ goV v = v++ parseValue val = either+ (const (String val))+ id+ (Y.decodeThrow $ encodeUtf8 val)++-- | Get the actual environment as a @HashMap@ from @Text@ to @Text@.+--+-- @since 0.8.16+getCurrentEnv :: IO (KeyMap Text)+getCurrentEnv = fmap (H.fromList . map (fromText . pack *** pack)) getEnvironment++-- | A convenience wrapper around 'applyEnvValue' and 'getCurrentEnv'+--+-- @since 0.8.16+applyCurrentEnv :: Bool -- ^ require an environment variable to be present?+ -> Value -> IO Value+applyCurrentEnv requireEnv' orig = flip (applyEnvValue requireEnv') orig <$> getCurrentEnv++-- | Defines how we want to use the environment variables when loading a config+-- file. Use the smart constructors provided by this module.+--+-- @since 0.8.16+data EnvUsage = IgnoreEnv+ | UseEnv+ | RequireEnv+ | UseCustomEnv (KeyMap Text)+ | RequireCustomEnv (KeyMap Text)++-- | Do not use any environment variables, instead relying on defaults values+-- in the config file.+--+-- @since 0.8.16+ignoreEnv :: EnvUsage+ignoreEnv = IgnoreEnv++-- | Use environment variables when available, otherwise use defaults.+--+-- @since 0.8.16+useEnv :: EnvUsage+useEnv = UseEnv++-- | Do not use default values from the config file, but instead take all+-- overrides from the environment. If a value is missing, loading the file will+-- throw an exception.+--+-- @since 0.8.16+requireEnv :: EnvUsage+requireEnv = RequireEnv++-- | Same as 'useEnv', but instead of the actual environment, use the provided+-- @HashMap@ as the environment.+--+-- @since 0.8.16+useCustomEnv :: KeyMap Text -> EnvUsage+useCustomEnv = UseCustomEnv++-- | Same as 'requireEnv', but instead of the actual environment, use the+-- provided @HashMap@ as the environment.+--+-- @since 0.8.16+requireCustomEnv :: KeyMap Text -> EnvUsage+requireCustomEnv = RequireCustomEnv++-- | Load the settings from the following three sources:+--+-- * Run time config files+--+-- * Run time environment variables+--+-- * The default compile time config file+--+-- For example, to load up settings from @config/foo.yaml@ and allow overriding+-- from the actual environment, you can use:+--+-- > loadYamlSettings ["config/foo.yaml"] [] useEnv+--+-- @since 0.8.16+loadYamlSettings+ :: FromJSON settings+ => [FilePath] -- ^ run time config files to use, earlier files have precedence+ -> [Value] -- ^ any other values to use, usually from compile time config. overridden by files+ -> EnvUsage+ -> IO settings+loadYamlSettings runTimeFiles compileValues envUsage = do+ runValues <- forM runTimeFiles $ \fp -> do+ eres <- YI.decodeFileEither fp+ case eres of+ Left e -> throwIO (Y.LoadSettingsException fp e)+ Right value -> return value++ value' <-+ case nonEmpty $ map MergedValue $ runValues ++ compileValues of+ Nothing -> error "loadYamlSettings: No configuration provided"+ Just ne -> return $ getMergedValue $ sconcat ne+ value <-+ case envUsage of+ IgnoreEnv -> return $ applyEnvValue False mempty value'+ UseEnv -> applyCurrentEnv False value'+ RequireEnv -> applyCurrentEnv True value'+ UseCustomEnv env -> return $ applyEnvValue False env value'+ RequireCustomEnv env -> return $ applyEnvValue True env value'++ case Y.parseEither parseJSON value of+ Left s -> error $ "Could not convert to expected type: " ++ s+ Right settings -> return settings++-- | Same as @loadYamlSettings@, but get the list of runtime config files from+-- the command line arguments.+--+-- @since 0.8.17+loadYamlSettingsArgs+ :: FromJSON settings+ => [Value] -- ^ any other values to use, usually from compile time config. overridden by files+ -> EnvUsage -- ^ use environment variables+ -> IO settings+loadYamlSettingsArgs values env = do+ args <- getArgs+ loadYamlSettings args values env
+ src/Data/Yaml/Include.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+module Data.Yaml.Include (+ decodeFile+, decodeFileEither+, decodeFileWithWarnings+) where++#if !MIN_VERSION_directory(1, 2, 3)+import Control.Exception (handleJust)+import Control.Monad (guard)+import System.IO.Error (ioeGetFileName, ioeGetLocation, isDoesNotExistError)+#endif++import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)+import Data.Aeson (FromJSON)+import Data.Text (unpack)+import Data.Text.Encoding (decodeUtf8)+import System.Directory+import System.FilePath++import Data.Yaml.Internal (ParseException(..), Warning(..), decodeHelper_, decodeHelper)+import Text.Libyaml hiding (decodeFile)+import qualified Text.Libyaml as Y++import Control.Exception.Safe+import qualified Streamly.Prelude as S+import Streamly.Prelude (SerialT, MonadAsync)++eventsFromFile+ :: (MonadCatch m, MonadAsync m, MonadMask m)+ => FilePath+ -> SerialT m Event+eventsFromFile = go []+ where+-- decodeFile :: (MonadCatch m, MonadAsync m, MonadMask m) => FilePath -> SerialT m Event+ go :: (MonadCatch m, MonadAsync m, MonadMask m) => [FilePath] -> FilePath -> SerialT m Event+ go seen fp = do+ cfp <- liftIO $ handleNotFound $ canonicalizePath fp+ when (cfp `elem` seen) $ do+ liftIO $ throwIO CyclicIncludes+ Y.decodeFile cfp >>= \event -> case event of+ EventScalar f (UriTag "!include") _ _ -> do+ let includeFile = takeDirectory cfp </> unpack (decodeUtf8 f)+ S.filter (`notElem` irrelevantEvents) $ go (cfp : seen) includeFile+ _ -> pure event++ irrelevantEvents = [EventStreamStart, EventDocumentStart, EventDocumentEnd, EventStreamEnd]++#if !MIN_VERSION_directory(1, 2, 3)+ handleNotFound = handleJust+ (\e -> do+ guard (isDoesNotExistError e)+ guard (ioeGetLocation e == "canonicalizePath")+ ioeGetFileName e)+ (throwIO . YamlException . ("Yaml file not found: " ++))+#else+ handleNotFound = id+#endif++-- | Like `Data.Yaml.decodeFile` but with support for relative and absolute+-- includes.+--+-- The syntax for includes follows the form:+--+-- > somekey: !include ./somefile.yaml+decodeFile+ :: FromJSON a+ => FilePath+ -> IO (Maybe a)+decodeFile fp = (fmap snd <$> decodeHelper (eventsFromFile fp)) >>= either throwIO (return . either (const Nothing) id)++-- | Like `Data.Yaml.decodeFileEither` but with support for relative and+-- absolute includes.+--+-- The syntax for includes follows the form:+--+-- > somekey: !include ./somefile.yaml+decodeFileEither+ :: FromJSON a+ => FilePath+ -> IO (Either ParseException a)+decodeFileEither = fmap (fmap snd) . decodeFileWithWarnings++-- | A version of `decodeFileEither` that returns warnings along with the parse+-- result.+--+-- @since 0.10.0+decodeFileWithWarnings+ :: FromJSON a+ => FilePath+ -> IO (Either ParseException ([Warning], a))+decodeFileWithWarnings = decodeHelper_ . eventsFromFile
+ src/Data/Yaml/Internal.hs view
@@ -0,0 +1,519 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE InstanceSigs #-}+module Data.Yaml.Internal+ (+ ParseException(..)+ , prettyPrintParseException+ , Warning(..)+ , parse+ , decodeHelper+ , decodeHelper_+ , decodeAllHelper+ , decodeAllHelper_+ , textToScientific+ , stringScalar+ , defaultStringStyle+ , isSpecialString+ , specialStrings+ , isNumeric+ , objToStream+ , objToEvents+ , anyEvent+ , missed+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), Applicative(..))+#endif+import Control.Applicative ((<|>))+import Control.Monad.State.Strict+import Control.Monad.Reader+import Data.Aeson+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as K+import qualified Data.Aeson.KeyMap as M+import Data.Aeson.KeyMap (KeyMap)+#else+import qualified Data.HashMap.Strict as M+#endif+import Data.Aeson.Internal (formatError)+import Data.Aeson.Types hiding (parse, Parser)+import qualified Data.Attoparsec.Text as Atto+import Data.Bits (shiftL, (.|.))+import Data.ByteString (ByteString)+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Lazy as BL+import Data.ByteString.Builder.Scientific (scientificBuilder)+import Data.Char (toUpper, ord)+import Data.List (foldl', (\\))+import qualified Data.HashSet as HashSet+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Scientific (Scientific, base10Exponent, coefficient)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8With, encodeUtf8)+import Data.Text.Encoding.Error (lenientDecode)+import Data.Typeable+import qualified Data.Vector as V++import qualified Text.Libyaml as Y+import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile)++import Control.Exception.Safe++import Streamly.Prelude (SerialT)+import Streamly.Internal.Data.Parser (Parser)+import qualified Streamly.Internal.Data.Parser as Parser+import qualified Streamly.Internal.Data.Stream.IsStream.Eliminate as Stream+import qualified Streamly.Internal.Data.Stream.StreamK as K+import Streamly.Internal.Data.Parser.ParserK.Type (fromParserK, toParserK, fromEffect)+import qualified Streamly.Internal.Data.Parser.ParserD.Type as ParserD+++++#if MIN_VERSION_aeson(2,0,0)+fromText :: T.Text -> K.Key+fromText = K.fromText++toText :: K.Key -> T.Text+toText = K.toText+#else+fromText :: T.Text -> T.Text+fromText = id++toText :: Key -> T.Text+toText = id++type KeyMap a = M.HashMap Text a+type Key = Text+#endif++data ParseException = NonScalarKey+ | UnknownAlias { _anchorName :: Y.AnchorName }+ | UnexpectedEvent { _received :: Maybe Event+ , _expected :: Maybe Event+ }+ | InvalidYaml (Maybe YamlException)+ | MultipleDocuments+ | AesonException String+ | OtherParseException SomeException+ | NonStringKey JSONPath+ | NonStringKeyAlias Y.AnchorName Value+ | CyclicIncludes+ | LoadSettingsException FilePath ParseException+ deriving (Show, Typeable)++instance Exception ParseException where+#if MIN_VERSION_base(4, 8, 0)+ displayException = prettyPrintParseException+#endif++-- | Alternative to 'show' to display a 'ParseException' on the screen.+-- Instead of displaying the data constructors applied to their arguments,+-- a more textual output is returned. For example, instead of printing:+--+-- > InvalidYaml (Just (YamlParseException {yamlProblem = "did not find expected ',' or '}'", yamlContext = "while parsing a flow mapping", yamlProblemMark = YamlMark {yamlIndex = 42, yamlLine = 2, yamlColumn = 12}})))+--+-- It looks more pleasant to print:+--+-- > YAML parse exception at line 2, column 12,+-- > while parsing a flow mapping:+-- > did not find expected ',' or '}'+--+-- Since 0.8.11+prettyPrintParseException :: ParseException -> String+prettyPrintParseException pe = case pe of+ NonScalarKey -> "Non scalar key"+ UnknownAlias anchor -> "Unknown alias `" ++ anchor ++ "`"+ UnexpectedEvent { _expected = mbExpected, _received = mbUnexpected } -> unlines+ [ "Unexpected event: expected"+ , " " ++ show mbExpected+ , "but received"+ , " " ++ show mbUnexpected+ ]+ InvalidYaml mbYamlError -> case mbYamlError of+ Nothing -> "Unspecified YAML error"+ Just yamlError -> case yamlError of+ YamlException s -> "YAML exception:\n" ++ s+ YamlParseException problem context mark -> concat+ [ "YAML parse exception at line " ++ show (yamlLine mark) +++ ", column " ++ show (yamlColumn mark)+ , case context of+ "" -> ":\n"+ -- The context seems to include a leading "while" or similar.+ _ -> ",\n" ++ context ++ ":\n"+ , problem+ ]+ MultipleDocuments -> "Multiple YAML documents encountered"+ AesonException s -> "Aeson exception:\n" ++ s+ OtherParseException exc -> "Generic parse exception:\n" ++ show exc+ NonStringKey path -> formatError path "Non-string keys are not supported"+ NonStringKeyAlias anchor value -> unlines+ [ "Non-string key alias:"+ , " Anchor name: " ++ anchor+ , " Value: " ++ show value+ ]+ CyclicIncludes -> "Cyclic includes"+ LoadSettingsException fp exc -> "Could not parse file as YAML: " ++ fp ++ "\n" ++ prettyPrintParseException exc+++defineAnchor :: Value -> String -> Parser (ReaderT JSONPath Parse) Event ()+defineAnchor value name = modify (modifyAnchors $ Map.insert name value)+ where+ modifyAnchors :: (Map String Value -> Map String Value) -> ParseState -> ParseState+ modifyAnchors f st = st {parseStateAnchors = f (parseStateAnchors st)}++lookupAnchor :: String -> Parser (ReaderT JSONPath Parse) Event (Maybe Value)+lookupAnchor name = gets (Map.lookup name . parseStateAnchors)++data Warning = DuplicateKey !JSONPath+ deriving (Eq, Show)++addWarning :: Warning -> Parser (ReaderT JSONPath Parse) Event ()+addWarning w = modify (modifyWarnings (w :))+ where+ modifyWarnings :: ([Warning] -> [Warning]) -> ParseState -> ParseState+ modifyWarnings f st = st {parseStateWarnings = f (parseStateWarnings st)}++data ParseState = ParseState {+ parseStateAnchors :: Map String Value+, parseStateWarnings :: [Warning]+}++type Parse = StateT ParseState IO++requireEvent :: Event -> Parser (ReaderT JSONPath Parse) Event ()+requireEvent e = do+ f <- anyEvent+ unless (f == Just e) $ missed (Just e)++{-# INLINE anyEvent #-}+anyEvent :: MonadCatch m => Parser m a (Maybe a)+anyEvent = toParserK $ ParserD.Parser step initial extract+ where+ initial = pure $ ParserD.IPartial ()+ step _ a = pure $ ParserD.Done 0 (Just a)+ extract _ = pure Nothing+++parse :: Parser (ReaderT JSONPath Parse) Event Value+parse = do+ docs <- parseAll+ case docs of+ [] -> return Null+ [doc] -> return doc+ _ -> liftIO $ throwIO MultipleDocuments+++parseAll :: Parser (ReaderT JSONPath Parse) Event [Value]+parseAll = do+ e <- anyEvent+ case e of+ Nothing -> return []+ Just EventStreamStart ->+ parseDocs+ _ -> missed e++parseDocs :: Parser (ReaderT JSONPath Parse) Event [Value]+parseDocs = do+ e <- anyEvent+ case e of+ Just EventStreamEnd -> return []+ Just EventDocumentStart -> do+ res <- parseO+ requireEvent EventDocumentEnd+ (res :) <$> parseDocs+ _ -> missed e++missed :: (MonadIO m, MonadThrow m) => Maybe Event -> Parser m a b+missed event = liftIO $ throwIO $ UnexpectedEvent event Nothing+++parseScalar :: ByteString -> Anchor -> Style -> Tag+ -> Parser (ReaderT JSONPath Parse) Event Text+parseScalar v a style tag = do+ let res = decodeUtf8With lenientDecode v+ mapM_ (defineAnchor (textToValue style tag res)) a+ return res+++textToValue :: Style -> Tag -> Text -> Value+textToValue SingleQuoted _ t = String t+textToValue DoubleQuoted _ t = String t+textToValue _ StrTag t = String t+textToValue Folded _ t = String t+textToValue _ _ t+ | t `elem` ["null", "Null", "NULL", "~", ""] = Null+ | any (t `isLike`) ["y", "yes", "on", "true"] = Bool True+ | any (t `isLike`) ["n", "no", "off", "false"] = Bool False+ | Right x <- textToScientific t = Number x+ | otherwise = String t+ where x `isLike` ref = x `elem` [ref, T.toUpper ref, titleCased]+ where titleCased = toUpper (T.head ref) `T.cons` T.tail ref++textToScientific :: Text -> Either String Scientific+textToScientific = Atto.parseOnly (num <* Atto.endOfInput)+ where+ num = (fromInteger <$> ("0x" *> Atto.hexadecimal))+ <|> (fromInteger <$> ("0o" *> octal))+ <|> Atto.scientific++ octal = T.foldl' step 0 <$> Atto.takeWhile1 isOctalDigit+ where+ isOctalDigit c = (c >= '0' && c <= '7')+ step a c = (a `shiftL` 3) .|. fromIntegral (ord c - 48)+++parseO :: Parser (ReaderT JSONPath Parse) Event Value+parseO = do+ me <- anyEvent+ case me of+ Just (EventScalar v tag style a) -> textToValue style tag <$> parseScalar v a style tag+ Just (EventSequenceStart _ _ a) -> parseS 0 a id+ Just (EventMappingStart _ _ a) -> parseM mempty a M.empty+ Just (EventAlias an) -> do+ m <- lookupAnchor an+ case m of+ Nothing -> liftIO $ throwIO $ UnknownAlias an+ Just v -> return v+ _ -> missed me++parseS :: Int+ -> Y.Anchor+ -> ([Value] -> [Value])+ -> Parser (ReaderT JSONPath Parse) Event Value+parseS !n a front = do+ me <- Parser.lookAhead anyEvent+ case me of+ Just EventSequenceEnd -> do+ void anyEvent+ let res = Array $ V.fromList $ front []+ mapM_ (defineAnchor res) a+ return res+ _ -> do+ o <- local (Index n :) parseO+ parseS (succ n) a $ front . (:) o++parseM :: Set Key+ -> Y.Anchor+ -> KeyMap Value+ -> Parser (ReaderT JSONPath Parse) Event Value+parseM mergedKeys a front = do+ me <- anyEvent+ case me of+ Just EventMappingEnd -> do+ let res = Object front+ mapM_ (defineAnchor res) a+ return res+ _ -> do+ s <- case me of+ Just (EventScalar v tag style a') -> fromText <$> parseScalar v a' style tag+ Just (EventAlias an) -> do+ m <- lookupAnchor an+ case m of+ Nothing -> liftIO $ throwIO $ UnknownAlias an+ Just (String t) -> return $ fromText t+ Just v -> liftIO $ throwIO $ NonStringKeyAlias an v+ _ -> do+ path <- ask+ liftIO $ throwIO $ NonStringKey path++ (mergedKeys', al') <- local (Key s :) $ do+ o <- parseO+ let al = do+ when (M.member s front && Set.notMember s mergedKeys) $ do+ path <- reverse <$> ask+ addWarning (DuplicateKey path)+ return (Set.delete s mergedKeys, M.insert s o front)+ if s == "<<"+ then case o of+ Object l -> return (merge l)+ Array l -> return $ merge $ foldl' mergeObjects M.empty $ V.toList l+ _ -> al+ else al+ parseM mergedKeys' a al'+ where mergeObjects al (Object om) = M.union al om+ mergeObjects al _ = al++ merge xs = (Set.fromList (M.keys xs \\ M.keys front), M.union front xs)+++parseSrc :: Parser (ReaderT JSONPath Parse) Event val+ -> SerialT IO Event+ -> IO (val, ParseState)+parseSrc eventParser src =+ flip runStateT (ParseState Map.empty []) $+ flip runReaderT [] $+ Stream.parse eventParser (K.hoist liftIO src)++mkHelper :: Parser (ReaderT JSONPath Parse) Event val -- ^ parse libyaml events as Value or [Value]+ -> (SomeException -> IO (Either ParseException a)) -- ^ what to do with unhandled exceptions+ -> ((val, ParseState) -> Either ParseException a) -- ^ further transform and parse results+ -> SerialT IO Event -- ^ the libyaml event (string/file) source+ -> IO (Either ParseException a)+mkHelper eventParser onOtherExc extractResults src = catches+ (extractResults <$> parseSrc eventParser src)+ [ Handler $ \pe -> return $ Left (pe :: ParseException)+ , Handler $ \ye -> return $ Left $ InvalidYaml $ Just (ye :: YamlException)+ , Handler $ \sae -> throwIO (sae :: SomeAsyncException)+ , Handler onOtherExc+ ]++decodeHelper :: FromJSON a+ => SerialT IO Y.Event+ -> IO (Either ParseException ([Warning], Either String a))+decodeHelper = mkHelper parse throwIO $ \(v, st) ->+ Right (parseStateWarnings st, parseEither parseJSON v)++decodeAllHelper :: FromJSON a+ => SerialT IO Event+ -> IO (Either ParseException ([Warning], Either String [a]))+decodeAllHelper = mkHelper parseAll throwIO $ \(vs, st) ->+ Right (parseStateWarnings st, mapM (parseEither parseJSON) vs)++catchLeft :: SomeException -> IO (Either ParseException a)+catchLeft = return . Left . OtherParseException++decodeHelper_ :: FromJSON a+ => SerialT IO Event+ -> IO (Either ParseException ([Warning], a))+decodeHelper_ = mkHelper parse catchLeft $ \(v, st) ->+ case parseEither parseJSON v of+ Left e -> Left $ AesonException e+ Right x -> Right (parseStateWarnings st, x)++decodeAllHelper_ :: FromJSON a+ => SerialT IO Event+ -> IO (Either ParseException ([Warning], [a]))+decodeAllHelper_ = mkHelper parseAll catchLeft $ \(vs, st) ->+ case mapM (parseEither parseJSON) vs of+ Left e -> Left $ AesonException e+ Right xs -> Right (parseStateWarnings st, xs)++type StringStyle = Text -> ( Tag, Style )++-- | Encodes a string with the supplied style. This function handles the empty+-- string case properly to avoid https://github.com/snoyberg/yaml/issues/24+--+-- @since 0.11.2.0+stringScalar :: StringStyle -> Maybe Text -> Text -> Event+stringScalar _ anchor "" = EventScalar "" NoTag SingleQuoted (T.unpack <$> anchor)+stringScalar stringStyle anchor s = EventScalar (encodeUtf8 s) tag style (T.unpack <$> anchor)+ where+ ( tag, style ) = stringStyle s++-- |+-- @since 0.11.2.0+defaultStringStyle :: StringStyle+defaultStringStyle = \s ->+ case () of+ ()+ | "\n" `T.isInfixOf` s -> ( NoTag, Literal )+ | isSpecialString s -> ( NoTag, SingleQuoted )+ | otherwise -> ( NoTag, PlainNoTag )++-- | Determine whether a string must be quoted in YAML and can't appear as plain text.+-- Useful if you want to use 'setStringStyle'.+--+-- @since 0.10.2.0+isSpecialString :: Text -> Bool+isSpecialString s = s `HashSet.member` specialStrings || isNumeric s++-- | Strings which must be escaped so as not to be treated as non-string scalars.+--+-- @since 0.8.32+specialStrings :: HashSet.HashSet Text+specialStrings = HashSet.fromList $ T.words+ "y Y yes Yes YES n N no No NO true True TRUE false False FALSE on On ON off Off OFF null Null NULL ~ *"++-- |+-- @since 0.8.32+isNumeric :: Text -> Bool+isNumeric = either (const False) (const True) . textToScientific++-- | Encode a value as a YAML document stream.+--+-- @since 0.11.2.0+objToStream :: ToJSON a => StringStyle -> a -> [Y.Event]+objToStream stringStyle o =+ (:) EventStreamStart+ . (:) EventDocumentStart+ $ objToEvents stringStyle o+ [ EventDocumentEnd+ , EventStreamEnd+ ]++-- | Encode a value as a list of 'Event's.+--+-- @since 0.11.2.0+objToEvents :: ToJSON a => StringStyle -> a -> [Y.Event] -> [Y.Event]+objToEvents stringStyle = objToEvents' . toJSON+ where+ objToEvents' (Array list) rest =+ EventSequenceStart NoTag AnySequence Nothing+ : foldr objToEvents' (EventSequenceEnd : rest) (V.toList list)++ objToEvents' (Object o) rest =+ EventMappingStart NoTag AnyMapping Nothing+ : foldr pairToEvents (EventMappingEnd : rest) (M.toList o)+ where+ pairToEvents :: Pair -> [Y.Event] -> [Y.Event]+ pairToEvents (k, v) = objToEvents' (String $ toText k) . objToEvents' v++ objToEvents' (String s) rest = stringScalar stringStyle Nothing s : rest++ objToEvents' Null rest = EventScalar "null" NullTag PlainNoTag Nothing : rest++ objToEvents' (Bool True) rest = EventScalar "true" BoolTag PlainNoTag Nothing : rest+ objToEvents' (Bool False) rest = EventScalar "false" BoolTag PlainNoTag Nothing : rest++ objToEvents' (Number s) rest =+ let builder+ -- Special case the 0 exponent to remove the trailing .0+ | base10Exponent s == 0 = BB.integerDec $ coefficient s+ | otherwise = scientificBuilder s+ lbs = BB.toLazyByteString builder+ bs = BL.toStrict lbs+ in EventScalar bs IntTag PlainNoTag Nothing : rest+++instance (MonadThrow m, MonadReader r m, MonadCatch m) => MonadReader r (Parser m a) where+ {-# INLINE ask #-}+ ask = fromEffect ask+ {-# INLINE local #-}+ local f (fromParserK -> ParserD.Parser step init' extract) =+ toParserK $ ParserD.Parser ((local f .) . step)+ (local f init')+ (local f . extract)+++instance (MonadThrow m, MonadState s m) => MonadState s (Parser m a) where+ {-# INLINE get #-}+ get = fromEffect get+ {-# INLINE put #-}+ put = fromEffect . put+++instance (MonadThrow m, MonadIO m) => MonadIO (Parser m a) where+ {-# INLINE liftIO #-}+ liftIO = fromEffect . liftIO+
+ src/Data/Yaml/Parser.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+-- | NOTE: This module is a highly experimental preview release. It may change+-- drastically, or be entirely removed, in a future release.+module Data.Yaml.Parser where++import Control.Applicative+import Control.Monad (MonadPlus (..), liftM, ap)+import Control.Exception.Safe+import Control.Monad.IO.Class+import Control.Monad.Trans.Writer.Strict (tell, WriterT, runWriterT)+import Data.ByteString (ByteString)+import qualified Data.Map as Map+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid (..))+#endif+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup(..))+#endif+import Data.Yaml.Internal+import Data.Text (Text, pack, unpack)+import Data.Text.Encoding (decodeUtf8)+import Data.Text.Read (signed, decimal)++import Streamly.Prelude (SerialT)+import Streamly.Internal.Data.Parser (Parser)+import qualified Streamly.Internal.Data.Stream.IsStream.Eliminate as Stream+import qualified Streamly.Internal.Data.Stream.StreamK as K+import Streamly.Internal.Data.Parser.ParserK.Type (fromEffect, die)++import Text.Libyaml++newtype YamlParser a = YamlParser+ { unYamlParser :: AnchorMap -> Either Text a+ }+instance Functor YamlParser where+ fmap = liftM+instance Applicative YamlParser where+ pure = YamlParser . const . Right+ (<*>) = ap+instance Alternative YamlParser where+ empty = fail "empty"+ (<|>) = mplus+instance Semigroup (YamlParser a) where+ (<>) = mplus+instance Monoid (YamlParser a) where+ mempty = fail "mempty"+#if !MIN_VERSION_base(4,11,0)+ mappend = (<>)+#endif+instance Monad YamlParser where+ return = pure+ YamlParser f >>= g = YamlParser $ \am ->+ case f am of+ Left t -> Left t+ Right x -> unYamlParser (g x) am+#if MIN_VERSION_base(4,13,0)+instance MonadFail YamlParser where+#endif+ fail = YamlParser . const . Left . pack+instance MonadPlus YamlParser where+ mzero = fail "mzero"+ mplus a b = YamlParser $ \am ->+ case unYamlParser a am of+ Left _ -> unYamlParser b am+ x -> x++lookupAnchor :: AnchorName -> YamlParser (Maybe YamlValue)+lookupAnchor name = YamlParser $ Right . Map.lookup name++withAnchor :: AnchorName -> Text -> (YamlValue -> YamlParser a) -> YamlParser a+withAnchor name expected f = do+ mv <- lookupAnchor name+ case mv of+ Nothing -> fail $ unpack expected ++ ": unknown alias " ++ name+ Just v -> f v++withMapping :: Text -> ([(Text, YamlValue)] -> YamlParser a) -> YamlValue -> YamlParser a+withMapping _ f (Mapping m _) = f m+withMapping expected f (Alias an) = withAnchor an expected $ withMapping expected f+withMapping expected _ v = typeMismatch expected v++withSequence :: Text -> ([YamlValue] -> YamlParser a) -> YamlValue -> YamlParser a+withSequence _ f (Sequence s _) = f s+withSequence expected f (Alias an) = withAnchor an expected $ withSequence expected f+withSequence expected _ v = typeMismatch expected v++withText :: Text -> (Text -> YamlParser a) -> YamlValue -> YamlParser a+withText _ f (Scalar s _ _ _) = f $ decodeUtf8 s+withText expected f (Alias an) = withAnchor an expected $ withText expected f+withText expected _ v = typeMismatch expected v++typeMismatch :: Text -> YamlValue -> YamlParser a+typeMismatch expected v =+ fail $ concat+ [ "Expected "+ , unpack expected+ , ", but got: "+ , t+ ]+ where+ t = case v of+ Mapping _ _ -> "mapping"+ Sequence _ _ -> "sequence"+ Scalar _ _ _ _ -> "scalar"+ Alias _ -> "alias"++class FromYaml a where+ fromYaml :: YamlValue -> YamlParser a+instance FromYaml YamlValue where+ fromYaml = return+instance FromYaml a => FromYaml [a] where+ fromYaml = withSequence "[a]" (mapM fromYaml)+instance FromYaml Text where+ fromYaml = withText "Text" return+instance FromYaml Int where+ fromYaml =+ withText "Int" go+ where+ go t =+ case signed decimal t of+ Right (i, "") -> return i+ _ -> fail $ "Invalid Int: " ++ unpack t++data YamlValue+ = Mapping [(Text, YamlValue)] Anchor+ | Sequence [YamlValue] Anchor+ | Scalar ByteString Tag Style Anchor+ | Alias AnchorName+ deriving Show++type AnchorMap = Map.Map AnchorName YamlValue+data RawDoc = RawDoc YamlValue AnchorMap+ deriving Show++parseRawDoc :: (FromYaml a, MonadThrow m) => RawDoc -> m a+parseRawDoc (RawDoc val am) =+ case unYamlParser (fromYaml val) am of+ Left t -> throwM $ FromYamlException t+ Right x -> return x++(.:) :: FromYaml a => [(Text, YamlValue)] -> Text -> YamlParser a+o .: k =+ case lookup k o of+ Nothing -> fail $ "Key not found: " ++ unpack k+ Just v -> fromYaml v++data YamlParseException+ = UnexpectedEndOfEvents+ | UnexpectedEvent Event+ | FromYamlException Text+ deriving (Show, Typeable)+instance Exception YamlParseException++{-# INLINE sinkValue #-}+sinkValue :: (MonadIO m, MonadCatch m, MonadThrow m) => Parser (WriterT AnchorMap m) Event YamlValue+sinkValue = start+ where+ start = anyEvent >>= maybe (die "Unexpected end of events") go++ tell' Nothing val = return val+ tell' (Just name) val = do+ fromEffect $ tell $ Map.singleton name val+ return val++ go EventStreamStart = start+ go EventDocumentStart = start+ go (EventAlias a) = return $ Alias a+ go (EventScalar a b c d) = tell' d $ Scalar a b c d+ go (EventSequenceStart _tag _style mname) = do+ vals <- goS id+ let val = Sequence vals mname+ tell' mname val+ go (EventMappingStart _tag _style mname) = do+ pairs <- goM id+ let val = Mapping pairs mname+ tell' mname val+ go e = missed (Just e)++ goS front = do+ me <- anyEvent+ case me of+ Nothing -> die "Unexpected end of events"+ Just EventSequenceEnd -> return $ front []+ Just e -> do+ val <- go e+ goS (front . (val:))++ goM front = do+ mk <- anyEvent+ case mk of+ Nothing -> die "Unexpected end of events"+ Just EventMappingEnd -> return $ front []+ Just (EventScalar a b c d) -> do+ _ <- tell' d $ Scalar a b c d+ let k = decodeUtf8 a+ v <- start+ goM (front . ((k, v):))+ Just e -> missed (Just e)++{-# INLINE sinkRawDoc #-}+sinkRawDoc :: SerialT IO Event -> IO RawDoc+sinkRawDoc src = do+ uncurry RawDoc <$> runWriterT (Stream.parse sinkValue (K.hoist liftIO src))++readYamlFile :: FromYaml a => FilePath -> IO a+readYamlFile fp = sinkRawDoc (decodeFile fp) >>= parseRawDoc
+ src/Data/Yaml/Pretty.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE CPP #-}+-- | Prettier YAML encoding.+--+-- @since 0.8.13+module Data.Yaml.Pretty+ ( encodePretty+ , Config+ , getConfCompare+ , setConfCompare+ , getConfDropNull+ , setConfDropNull+ , defConfig+ , pretty+ ) where++import Prelude hiding (null)++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+#endif+import Data.Bifunctor (first)+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as K+import qualified Data.Aeson.KeyMap as HM+#else+import qualified Data.HashMap.Strict as HM+#endif+import Data.Aeson.Types+import Data.ByteString (ByteString)+import Data.Function (on)+import Data.List (sortBy)+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid+#endif+import Data.Text (Text)+import qualified Data.Vector as V++import Data.Yaml.Builder++#if MIN_VERSION_aeson(2,0,0)+toText :: Key -> Text+toText = K.toText+#else+toText :: Key -> Text+toText = id++type Key = Text+#endif++-- |+-- @since 0.8.13+data Config = Config+ { confCompare :: Text -> Text -> Ordering -- ^ Function used to sort keys in objects+ , confDropNull :: Bool -- ^ Drop null values from objects+ }++-- | The default configuration: do not sort objects or drop keys+--+-- @since 0.8.13+defConfig :: Config+defConfig = Config mempty False++-- |+-- @since 0.8.13+getConfCompare :: Config -> Text -> Text -> Ordering+getConfCompare = confCompare++-- | Sets ordering for object keys+--+-- @since 0.8.13+setConfCompare :: (Text -> Text -> Ordering) -> Config -> Config+setConfCompare cmp c = c { confCompare = cmp }++-- |+-- @since 0.8.24+getConfDropNull :: Config -> Bool+getConfDropNull = confDropNull++-- | Drop entries with `Null` value from objects, if set to `True`+--+-- @since 0.8.24+setConfDropNull :: Bool -> Config -> Config+setConfDropNull m c = c { confDropNull = m }++pretty :: Config -> Value -> YamlBuilder+pretty cfg = go+ where go (Object o) = let sort = sortBy (confCompare cfg `on` fst)+ select+ | confDropNull cfg = HM.filter (/= Null)+ | otherwise = id+ in mapping (sort $ fmap (first toText) $ HM.toList $ HM.map go $ select o)+ go (Array a) = array (go <$> V.toList a)+ go Null = null+ go (String s) = string s+ go (Number n) = scientific n+ go (Bool b) = bool b++-- | Configurable 'encode'.+--+-- @since 0.8.13+encodePretty :: ToJSON a => Config -> a -> ByteString+encodePretty cfg = toByteString . pretty cfg . toJSON
+ src/Data/Yaml/TH.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Yaml.TH+ ( -- * Decoding+ yamlQQ+#if MIN_VERSION_template_haskell(2,9,0)+ , decodeFile+#endif+ -- * Re-exports from "Data.Yaml"+ , Value (..)+ , Parser+ , Object+ , Array+ , object+ , array+ , (.=)+ , (.:)+ , (.:?)+ , (.!=)+ , FromJSON (..)+ ) where++import Data.Text.Encoding+import qualified Data.Text as T+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Quote++import Data.Yaml++-- | Decode a YAML file at compile time. Only available on GHC version @7.8.1@+-- or higher.+--+-- @since 0.8.19.0+--+-- ==== __Examples__+--+-- @+-- {-\# LANGUAGE TemplateHaskell \#-}+--+-- config :: Config+-- config = $$('decodeFile' "config.yaml")+-- @+decodeFile :: forall a. (Lift a, FromJSON a) => FilePath -> Q (TExp a)+decodeFile path = do+ addDependentFile path+ x <- runIO $ decodeFileThrow path+ fmap TExp (lift (x :: a))++yamlExp :: String -> Q Exp+yamlExp input = do+ val <- runIO $ decodeThrow $ encodeUtf8 $ T.pack input+ lift (val :: Value)++-- | A @QuasiQuoter@ for YAML.+--+-- @since 0.8.28.0+--+-- ==== __Examples__+--+-- @+-- {-\# LANGUAGE QuasiQuotes \#-}+-- import Data.Yaml.TH+--+-- value :: Value+-- value = [yamlQQ|+-- name: John Doe+-- age: 23+-- |]+-- @+yamlQQ :: QuasiQuoter+yamlQQ = QuasiQuoter {+ quoteExp = yamlExp+, quotePat = notDefined "quotePat"+, quoteType = notDefined "quoteType"+, quoteDec = notDefined "quoteDec"+} where+ notDefined name _ = fail (name ++ " is not defined for yamlQQ")
+ test/Data/Yaml/IncludeSpec.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+module Data.Yaml.IncludeSpec (main, spec) where++import Test.Hspec+import Data.List (isPrefixOf)+import qualified Data.ByteString.Lazy as LB+import Data.Aeson+import Data.Aeson.Internal (JSONPathElement(..))+import Data.Yaml.Include+import Data.Yaml.Internal+import Text.Libyaml (YamlException(YamlException))+import Test.Mockery.Directory+import Text.RawString.QQ+import Data.Yaml.TH (yamlQQ)++main :: IO ()+main = hspec spec++asInt :: Int -> Int+asInt = id++spec :: Spec+spec = do+ describe "decodeFile" $ do+ it "supports includes" $ do+ decodeFile "test/resources/foo.yaml" `shouldReturn` Just (object+ [ "foo" .= asInt 23+ , "bar" .= object+ [ "one" .= asInt 1+ , "two" .= asInt 2+ ]+ , "baz" .= asInt 42+ ])++ it "supports recursive includes" $ do+ decodeFile "test/resources/baz.yaml" `shouldReturn` Just (object+ [ "foo" .= object+ [ "foo" .= asInt 23+ , "bar" .= object+ [ "one" .= asInt 1+ , "two" .= asInt 2+ ]+ , "baz" .= asInt 42+ ]+ ])++ it "aborts on cyclic includes" $ do+ (decodeFile "test/resources/loop/foo.yaml" :: IO (Maybe Value)) `shouldThrow` anyException++ context "when file does not exist" $ do+ it "throws Left (InvalidYaml (Just (YamlException \"Yaml file not found: ...\")))" $ do+ (decodeFile "./does_not_exist.yaml" :: IO (Maybe Value)) `shouldThrow` isYamlFileNotFoundException++ context "with a 1K stack size limit" $ around_ inTempDirectory $ do+ context "with a large list" $ do+ it "succeeds" $ do+ let+ xs :: [Value]+ xs = replicate 5000 (Number 23)+ LB.writeFile "foo.yaml" (encode xs)+ decodeFile "foo.yaml" `shouldReturn` Just xs++ describe "decodeFileEither" $ do+ context "when file does not exist" $ do+ it "returns Left (InvalidYaml (Just (YamlException \"Yaml file not found: ...\")))" $ do+ (decodeFileEither "./does_not_exist.yaml" :: IO (Either ParseException Value)) >>=+ (`shouldSatisfy` either isYamlFileNotFoundException (const False))++ describe "decodeFileWithWarnings" $ around_ inTempDirectory $ do+ it "warns on duplicate keys" $ do+ writeFile "foo.yaml" [r|+ foo: 23+ foo: bar+ |]+ Right result <- decodeFileWithWarnings "foo.yaml"+ result `shouldBe` ([DuplicateKey [Key "foo"]], [yamlQQ|+ foo: bar+ |])++ it "warns on nested duplicate keys" $ do+ writeFile "foo.yaml" [r|+ foo:+ - 42+ - bar: 23+ bar: baz+ |]+ Right result <- decodeFileWithWarnings "foo.yaml"+ result `shouldBe` ([DuplicateKey [Key "foo", Index 1, Key "bar"]], [yamlQQ|+ foo:+ - 42+ - bar: baz+ |])++ context "when overriding a merged key" $ do+ it "does not warn" $ do+ writeFile "foo.yaml" [r|+ foo-1: &my-ref+ bar: 23+ foo-2:+ <<: *my-ref+ bar: 42+ |]+ Right result <- decodeFileWithWarnings "foo.yaml"+ result `shouldBe` ([], [yamlQQ|+ foo-1:+ bar: 23+ foo-2:+ bar: 42+ |])++ context "when overriding twice" $ do+ it "warns" $ do+ writeFile "foo.yaml" [r|+ foo-1: &my-ref+ bar: 23+ foo-2:+ <<: *my-ref+ bar: 42+ bar: 65+ |]+ Right result <- decodeFileWithWarnings "foo.yaml"+ result `shouldBe` ([DuplicateKey [Key "foo-2", Key "bar"]], [yamlQQ|+ foo-1:+ bar: 23+ foo-2:+ bar: 65+ |])++isYamlFileNotFoundException :: ParseException -> Bool+isYamlFileNotFoundException (InvalidYaml (Just (YamlException msg)))+ | "Yaml file not found: " `isPrefixOf` msg = True+isYamlFileNotFoundException _ = False
+ test/Data/Yaml/THSpec.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+module Data.Yaml.THSpec (spec) where++import Test.Hspec+import Data.Aeson++import Data.Yaml.TH++spec :: Spec+spec = do+ describe "yamlQQ" $ do+ it "parses yaml" $ do+ [yamlQQ|+ name: John Doe+ age: 23+ |] `shouldBe` object ["name" .= String "John Doe", "age" .= Number 23]
+ test/Data/YamlSpec.hs view
@@ -0,0 +1,892 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++module Data.YamlSpec (main, spec) where++import qualified Text.Libyaml as Y+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as B8+import Data.Int (Int64)+import qualified Data.Scientific as S++import Test.HUnit hiding (Test, path)++import Control.Monad+import Control.Exception (try, SomeException)+import Test.Hspec+import Test.Hspec.QuickCheck+import Data.Either.Compat+import System.Directory (createDirectory, createDirectoryIfMissing)+import Test.Mockery.Directory++import qualified Data.Yaml as D+import qualified Data.Yaml.Builder as B+import qualified Data.Yaml.Internal as Internal+import qualified Data.Yaml.Pretty as Pretty+import Data.Yaml (object, array, (.=))+import Data.Maybe+import qualified Data.HashMap.Strict as HM+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as M+import qualified Data.Aeson.Key as K+import Data.Aeson.KeyMap (KeyMap)+#else+import qualified Data.HashMap.Strict as M+#endif+import qualified Data.Text as T+import Data.Aeson.TH+import Data.Scientific (Scientific)+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Data.Vector (Vector)+import qualified Data.Vector as V+import Data.HashMap.Strict (HashMap)+import System.IO (hClose)+import System.IO.Temp (withSystemTempFile)++import qualified Streamly.Prelude as P+import Streamly.Data.Fold (Fold)+import qualified Streamly.Data.Fold as Fold++#if MIN_VERSION_aeson(2,0,0)+fromText :: T.Text -> K.Key+fromText = K.fromText+#else+fromText :: T.Text -> T.Text+fromText = id++type KeyMap a = M.HashMap Text a+type Key = Text+#endif++data TestJSON = TestJSON+ { string :: Text+ , number :: Int+ , anArray :: Vector Text+ , hash :: HashMap Text Text+ , extrastring :: Text+ } deriving (Show, Eq)++deriveJSON defaultOptions ''TestJSON++testJSON :: TestJSON+testJSON = TestJSON+ { string = "str"+ , number = 2+ , anArray = V.fromList ["a", "b"]+ , hash = HM.fromList [("key1", "value1"), ("key2", "value2")]+ , extrastring = "1234-foo"+ }++shouldDecode :: (Show a, D.FromJSON a, Eq a) => B8.ByteString -> a -> IO ()+shouldDecode bs expected = do+ actual <- D.decodeThrow bs+ actual `shouldBe` expected++shouldDecodeAll :: (Show a, D.FromJSON a, Eq a) => B8.ByteString -> [a] -> IO ()+shouldDecodeAll bs expected = do+ actual <- D.decodeAllThrow bs+ actual `shouldBe` expected++shouldDecodeEvents :: B8.ByteString -> [Y.Event] -> IO ()+shouldDecodeEvents bs expected = do+ actual <- P.toList $ Y.decode bs+ map anyStyle actual `shouldBe` map anyStyle expected++anyStyle :: Y.Event -> Y.Event+anyStyle (Y.EventScalar bs tag _ anchor) = Y.EventScalar bs tag Y.Any anchor+anyStyle (Y.EventSequenceStart tag _ anchor) = Y.EventSequenceStart tag Y.AnySequence anchor+anyStyle (Y.EventMappingStart tag _ anchor) = Y.EventMappingStart tag Y.AnyMapping anchor+anyStyle event = event++testEncodeWith :: Y.FormatOptions -> [Y.Event] -> IO BS.ByteString+testEncodeWith opts es = Y.encodeWith opts (P.fromList $ eventStream es)++eventStream :: [Y.Event] -> [Y.Event]+eventStream events =+ [Y.EventStreamStart, Y.EventDocumentStart]+ ++ events+ ++ [Y.EventDocumentEnd, Y.EventStreamEnd]++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "streaming" $ do+ it "count scalars with anchor" caseCountScalarsWithAnchor+ it "count sequences with anchor" caseCountSequencesWithAnchor+ it "count mappings with anchor" caseCountMappingsWithAnchor+ it "count sequences with custom tag" caseCountSequenceTags+ it "count mappings with custom tag" caseCountMappingTags+ it "count count sequences with ! tag" caseCountEmptySequenceTags+ it "count count mappings with ! tag" caseCountEmptyMappingTags+ it "count block style sequences" caseCountBlockStyleSequences+ it "count flow style sequences" caseCountFlowStyleSequences+ it "count block style mappings" caseCountBlockStyleMappings+ it "count flow style mappings" caseCountFlowStyleMappings+ it "count aliases" caseCountAliases+ it "count scalars" caseCountScalars+ it "largest string" caseLargestString+ it "encode/decode" caseEncodeDecode+ it "encode/decode events" caseEncodeDecodeEvents+ it "encode/decode file" caseEncodeDecodeFile+ it "interleaved encode/decode" caseInterleave+ it "decode invalid document (without segfault)" caseDecodeInvalidDocument+ describe "Data.Yaml" $ do+ it "encode/decode" caseEncodeDecodeData+ it "encode/decode file" caseEncodeDecodeFileData+ it "encode/decode files with non-ASCII names" caseEncodeDecodeNonAsciiFileData+ it "encode/decode strings" caseEncodeDecodeStrings+ it "decode invalid file" caseDecodeInvalid+ it "processes datatypes" caseDataTypes+ it "encode invalid numbers" caseEncodeInvalidNumbers+ describe "Data.Yaml.Pretty" $ do+ it "encode/decode" caseEncodeDecodeDataPretty+ it "encode/decode strings" caseEncodeDecodeStringsPretty+ it "processes datatypes" caseDataTypesPretty+ describe "Data.Yaml.Builder" $ do+ it "encode/decode" caseEncodeDecodeDataBuilder+ it "encode/decode complex mapping" caseEncodeDecodeComplexMappingBuilder+ describe "Data.Yaml aliases" $ do+ it "simple scalar alias" caseSimpleScalarAlias+ it "simple sequence alias" caseSimpleSequenceAlias+ it "simple mapping alias" caseSimpleMappingAlias+ it "mapping alias before anchor" caseMappingAliasBeforeAnchor+ it "mapping alias inside anchor" caseMappingAliasInsideAnchor+ it "scalar alias overriding" caseScalarAliasOverriding+ describe "Data.Yaml merge keys" $ do+ it "test uniqueness of keys" caseAllKeysShouldBeUnique+ it "test mapping merge" caseSimpleMappingMerge+ it "test sequence of mappings merging" caseMergeSequence+ describe "numbers" $ do+ it "parses as string when quoted" caseQuotedNumber+ it "parses as number when unquoted" caseUnquotedNumber+ it "parses as number !!str is present" caseAttribNumber+ it "integers have no decimals" caseIntegerDecimals+ describe "booleans" $ do+ it "parses when all lowercase" caseLowercaseBool+ it "parses when all uppercase" caseUppercaseBool+ it "parses when titlecase" caseTitlecaseBool+ describe "empty input" $ do+ it "parses as Null" caseEmptyInput+ it "parses as Null from file" caseEmptyInputFile+ describe "comment only input" $ do+ it "parses as Null" caseCommentOnlyInput+ it "parses as Null from file" caseCommentOnlyInputFile+ describe "alias stripping" $ do+ it "works" caseStripAlias+ describe "nulls" $ do+ checkNull "null"+ checkNull "Null"+ checkNull "NULL"+ checkNull "~"+ checkNull ""++ describe "pretty output" $ do+ it "simple nulls" $ D.encode (object ["foo" .= D.Null]) `shouldBe` "foo: null\n"+ it "simple numbers" $ D.encode (object ["foo" .= (4 :: Int)]) `shouldBe` "foo: 4\n"+ it "True" $ D.encode (object ["foo" .= True]) `shouldBe` "foo: true\n"+ it "False" $ D.encode (object ["foo" .= False]) `shouldBe` "foo: false\n"+ it "simple string" $ D.encode (object ["foo" .= ("bar" :: T.Text)]) `shouldBe` "foo: bar\n"+ it "*" $ D.encode (object ["foo" .= ("*" :: T.Text)]) `shouldBe` "foo: '*'\n"++ describe "special keys" $ do+ let tester key = it (T.unpack key) $+ let value = object [fromText key .= True]+ in D.encode value `shouldDecode` value+ mapM_ tester specialStrings++ describe "special values" $ do+ let tester value = it (T.unpack value) $+ let value' = object ["foo" .= value]+ in D.encode value' `shouldDecode` value'+ mapM_ tester specialStrings++ describe "decodeFileEither" $ do+ it "loads YAML through JSON into Haskell data" $ do+ tj <- either (error . show) id `fmap` D.decodeFileEither "test/json.yaml"+ tj `shouldBe` testJSON++ context "when file does not exist" $ do+ it "returns Left" $ do+ (D.decodeFileEither "./does_not_exist.yaml" :: IO (Either D.ParseException D.Value)) >>= (`shouldSatisfy` isLeft)++ describe "multiple document support" $ do+ it "decodes zero-length input" $+ "" `shouldDecodeAll` ([] :: [D.Value])+ it "decodes comment-only input" $+ "# foo\n# bar" `shouldDecodeAll` ([] :: [D.Value])+ it "decodes a single document stream" $+ "foo: true" `shouldDecodeAll` [object ["foo" .= True]]+ it "decodes multiple documents" $+ "--- 1\n--- 2" `shouldDecodeAll` [D.Number 1, D.Number 2]++ describe "round-tripping of special scalars" $ do+ let special = words "y Y On ON false 12345 12345.0 12345a 12e3"+ forM_ special $ \w -> it w $+ let v = object ["word" .= w]+ in D.encode v `shouldDecode` v+ it "no tags" $ D.encode (object ["word" .= ("true" :: String)]) `shouldBe` "word: 'true'\n"++ it "aliases in keys #49" caseIssue49++ it "serialization of +123 #64" $ do+ D.encode ("+123" :: String) `shouldDecode` ("+123" :: String)++ it "preserves Scientific precision" casePreservesScientificPrecision++ it "truncates files" caseTruncatesFiles++ it "encode quotes special keys #137" $ caseSpecialKeys D.encode++ it "encodePretty quotes special keys #179" $ caseSpecialKeys (Pretty.encodePretty Pretty.defConfig)++ describe "non-decimal numbers #135" $ do+ let go str val = it str $ encodeUtf8 (T.pack str) `shouldDecode` val+ go "12345" (12345 :: Int)+ go "+12345" (12345 :: Int)+ go "0o14" (12 :: Int)+ go "0o123" (83 :: Int)+ go "0xC" (12 :: Int)+ go "0xc" (12 :: Int)+ go "0xdeadBEEF" (3735928559 :: Int64)+ go "0xDEADBEEF" (3735928559 :: Int64)+ go "1.23015e+3" (1230.15 :: Scientific)+ go "12.3015e+02" (1230.15 :: Scientific)+ go "1230.15" (1230.15 :: Scientific)++ describe "Text.Libyaml with default tag rendering" $ do+ let enc = testEncodeWith Y.defaultFormatOptions+ it "elides custom sequence tags" $+ enc taggedSequence `shouldReturn` "[]\n"+ it "elides custom mapping tags" $+ enc taggedMapping `shouldReturn` "{}\n"+ it "elides default sequence tags" $+ enc defaultTaggedSequence `shouldReturn` "[]\n"+ it "elides default mapping tags" $+ enc defaultTaggedMapping `shouldReturn` "{}\n"+ it "handles NoTag on sequences" $+ enc untaggedSequence `shouldReturn` "[]\n"+ it "handles NoTag on mappings" $+ enc untaggedMapping `shouldReturn` "{}\n"+ it "handles mixed tag usages but elides all mapping and sequence tags" $+ enc mixedTagSampleA `shouldReturn` "- {}\n"+ it "in combination of tags, anchors and styles, outputs only the scalar tags" $+ enc mixedTagSampleB `shouldReturn` "&a\n&b !<bar> foo: &c [&d !!null '']\n"+ it "outputs tags when double quoted" $+ enc [Y.EventScalar "foo" Y.StrTag Y.DoubleQuoted Nothing] `shouldReturn` "!!str \"foo\"\n"+ it "outputs tags when single quoted" $+ enc [Y.EventScalar "foo" Y.StrTag Y.SingleQuoted Nothing] `shouldReturn` "!!str 'foo'\n"+ it "outputs tags on literal text" $+ enc [Y.EventScalar "foo" Y.StrTag Y.Literal Nothing] `shouldReturn` "!!str |-\n foo\n"+ it "outputs tags on folded text" $+ enc [Y.EventScalar "foo" Y.StrTag Y.Folded Nothing] `shouldReturn` "!!str >-\n foo\n"+ describe "Text.Libyaml with all tags on" $ do+ let enc = testEncodeWith $ Y.setTagRendering Y.renderAllTags Y.defaultFormatOptions+ it "will output custom sequence tags" $+ enc taggedSequence `shouldReturn` "!foo []\n"+ it "will output custom mapping tags" $+ enc taggedMapping `shouldReturn` "!foo {}\n"+ it "will output default sequence tags" $+ enc defaultTaggedSequence `shouldReturn` "!!seq []\n"+ it "will output default mapping tags" $+ enc defaultTaggedMapping `shouldReturn` "!!map {}\n"+ it "handles NoTag on sequences" $+ enc untaggedSequence `shouldReturn` "[]\n"+ it "handles NoTag on mappings" $+ enc untaggedMapping `shouldReturn` "{}\n"+ it "handles mixed tag usages outputting all mapping and sequence tags" $+ enc mixedTagSampleA `shouldReturn` "- !foo {}\n"+ it "in combination of tags, anchors and styles, outputs all the tags" $+ enc mixedTagSampleB `shouldReturn` "&a\n&b !<bar> foo: &c !baz [&d !!null '']\n"+ it "outputs plain tags" $+ enc [Y.EventScalar "foo" Y.StrTag Y.Plain Nothing] `shouldReturn` "!!str foo\n"+ it "respects PlainNoTag tags" $+ enc [Y.EventScalar "foo" Y.StrTag Y.PlainNoTag Nothing] `shouldReturn` "foo\n"+ describe "Text.Libyaml with uri tags on" $ do+ let enc = testEncodeWith $ Y.setTagRendering Y.renderUriTags Y.defaultFormatOptions+ it "will output custom sequence tags" $+ enc taggedSequence `shouldReturn` "!foo []\n"+ it "will output custom mapping tags" $+ enc taggedMapping `shouldReturn` "!foo {}\n"+ it "will output default sequence tags" $+ enc defaultTaggedSequence `shouldReturn` "[]\n"+ it "will output default mapping tags" $+ enc defaultTaggedMapping `shouldReturn` "{}\n"+ it "handles NoTag on sequences" $+ enc untaggedSequence `shouldReturn` "[]\n"+ it "handles NoTag on mappings" $+ enc untaggedMapping `shouldReturn` "{}\n"+ it "handles mixed tag usages outputting all mapping and sequence tags" $+ enc mixedTagSampleA `shouldReturn` "- !foo {}\n"+ it "in combination of tags, anchors and styles, outputs all the tags" $+ enc mixedTagSampleB `shouldReturn` "&a\n&b !<bar> foo: &c !baz [&d '']\n"+ describe "Text.Libyaml with tags off" $ do+ let enc = testEncodeWith $ Y.setTagRendering Y.renderNoTags Y.defaultFormatOptions+ it "outputs plain tags" $+ enc [Y.EventScalar "foo" Y.StrTag Y.Plain Nothing] `shouldReturn` "foo\n"+ it "respects PlainNoTag tags" $+ enc [Y.EventScalar "foo" Y.StrTag Y.PlainNoTag Nothing] `shouldReturn` "foo\n"+ it "elides tags when double quoted" $+ enc [Y.EventScalar "foo" Y.StrTag Y.DoubleQuoted Nothing] `shouldReturn` "\"foo\"\n"+ it "elides tags when single quoted" $+ enc [Y.EventScalar "foo" Y.StrTag Y.SingleQuoted Nothing] `shouldReturn` "'foo'\n"+ it "elides tags on literal text" $+ enc [Y.EventScalar "foo" Y.StrTag Y.Literal Nothing] `shouldReturn` "|-\n foo\n"+ it "elides tags on folded text" $+ enc [Y.EventScalar "foo" Y.StrTag Y.Folded Nothing] `shouldReturn` ">-\n foo\n"+ describe "Text.Libyaml with only UriTags set to render " $ do+ let enc =+ testEncodeWith $+ Y.setTagRendering Y.renderUriTags $ Y.defaultFormatOptions+ it "outputs only UriTags" $+ enc+ [ Y.EventSequenceStart Y.NoTag Y.FlowSequence Nothing+ , Y.EventScalar "foo" Y.StrTag Y.DoubleQuoted Nothing+ , Y.EventScalar "99" Y.IntTag Y.Plain Nothing+ , Y.EventScalar "99.99" Y.FloatTag Y.Plain Nothing+ , Y.EventScalar "bar" Y.NoTag Y.Plain Nothing+ , Y.EventScalar "foo" (Y.UriTag "!foo") Y.DoubleQuoted Nothing+ , Y.EventScalar "foo" (Y.UriTag "!foo") Y.Plain Nothing+ , Y.EventSequenceEnd+ ] `shouldReturn`+ "[\"foo\", 99, 99.99, bar, !foo \"foo\", !foo foo]\n"++ prop "Scientific values round-trip" $ \coeff expon -> do+ let val = D.Number $ S.scientific coeff expon+ let rendered = D.encode val+ case D.decodeEither' rendered of+ Left e -> error $ show (coeff, expon, e)+ Right val' -> val' `shouldBe` val++specialStrings :: [T.Text]+specialStrings =+ [ "fo\"o"+ , "fo\'o"+ , "fo\\'o"+ , "fo: o"+ , "foo\nbar\nbaz\n"+ ]++counter :: Monad m => (Y.Event -> Bool) -> Fold m Y.Event Int+counter pred' =+ Fold.foldl' (\cnt e -> (if pred' e then 1 else 0) + cnt) 0++caseHelper :: String+ -> (Y.Event -> Bool)+ -> Int+ -> Assertion+caseHelper yamlString pred' expRes = do+ res <- P.fold (counter pred') (Y.decode (B8.pack yamlString))+ res @?= expRes++caseCountScalarsWithAnchor :: Assertion+caseCountScalarsWithAnchor =+ caseHelper yamlString isScalarA 1+ where+ yamlString = "foo:\n - &anchor bin1\n - bin2\n - bin3"+ isScalarA (Y.EventScalar _ _ _ (Just _)) = True+ isScalarA _ = False++caseCountSequencesWithAnchor :: Assertion+caseCountSequencesWithAnchor =+ caseHelper yamlString isSequenceStartA 1+ where+ yamlString = "foo: &anchor\n - bin1\n - bin2\n - bin3"+ isSequenceStartA (Y.EventSequenceStart Y.NoTag _ (Just _)) = True+ isSequenceStartA _ = False++caseCountMappingsWithAnchor :: Assertion+caseCountMappingsWithAnchor =+ caseHelper yamlString isMappingA 1+ where+ yamlString = "foo: &anchor\n key1: bin1\n key2: bin2\n key3: bin3"+ isMappingA (Y.EventMappingStart _ _ (Just _)) = True+ isMappingA _ = False++caseCountAliases :: Assertion+caseCountAliases =+ caseHelper yamlString isAlias 1+ where+ yamlString = "foo: &anchor\n key1: bin1\n key2: bin2\n key3: bin3\nboo: *anchor"+ isAlias Y.EventAlias{} = True+ isAlias _ = False++caseCountMappingTags :: Assertion+caseCountMappingTags =+ caseHelper yamlString isCustomTaggedMapping 1+ where+ yamlString = "foo: !bar\n k: v\n k2: v2"+ isCustomTaggedMapping (Y.EventMappingStart (Y.UriTag "!bar") _ _) = True+ isCustomTaggedMapping _ = False++caseCountEmptyMappingTags :: Assertion+caseCountEmptyMappingTags =+ caseHelper yamlString isCustomTaggedMapping 1+ where+ yamlString = "foo: !\n k: v\n k2: v2"+ isCustomTaggedMapping (Y.EventMappingStart (Y.UriTag "!") _ _) = True+ isCustomTaggedMapping _ = False++caseCountSequenceTags :: Assertion+caseCountSequenceTags =+ caseHelper yamlString isCustomTaggedSequence 1+ where+ yamlString = "foo: !bar [x, y, z]"+ isCustomTaggedSequence (Y.EventSequenceStart (Y.UriTag "!bar") _ _) = True+ isCustomTaggedSequence _ = False++caseCountEmptySequenceTags :: Assertion+caseCountEmptySequenceTags =+ caseHelper yamlString isCustomTaggedSequence 1+ where+ yamlString = "foo: ! [x, y, z]"+ isCustomTaggedSequence (Y.EventSequenceStart (Y.UriTag "!") _ _) = True+ isCustomTaggedSequence _ = False++caseCountFlowStyleSequences :: Assertion+caseCountFlowStyleSequences =+ caseHelper yamlString isFlowStyleSequence 1+ where+ yamlString = "foo: [x, y, z]"+ isFlowStyleSequence (Y.EventSequenceStart _ Y.FlowSequence _) = True+ isFlowStyleSequence _ = False++caseCountBlockStyleSequences :: Assertion+caseCountBlockStyleSequences =+ caseHelper yamlString isBlockStyleSequence 1+ where+ yamlString = "foo:\n- x\n- y\n- z\n"+ isBlockStyleSequence (Y.EventSequenceStart _ Y.BlockSequence _) = True+ isBlockStyleSequence _ = False++caseCountFlowStyleMappings :: Assertion+caseCountFlowStyleMappings =+ caseHelper yamlString isFlowStyleMapping 1+ where+ yamlString = "foo: { bar: 1, baz: 2 }"+ isFlowStyleMapping (Y.EventMappingStart _ Y.FlowMapping _) = True+ isFlowStyleMapping _ = False++caseCountBlockStyleMappings :: Assertion+caseCountBlockStyleMappings =+ caseHelper yamlString isBlockStyleMapping 1+ where+ yamlString = "foo: bar\nbaz: quux"+ isBlockStyleMapping (Y.EventMappingStart _ Y.BlockMapping _) = True+ isBlockStyleMapping _ = False++caseCountScalars :: Assertion+caseCountScalars = do+ res <- P.fold (Fold.foldl' adder accum) (Y.decode yamlBS)+ res @?= (7, 1, 2)+ where+ yamlString = "foo:\n baz: [bin1, bin2, bin3]\nbaz: bazval"+ yamlBS = B8.pack yamlString+ adder (s, l, m) (Y.EventScalar{}) = (s + 1, l, m)+ adder (s, l, m) (Y.EventSequenceStart{}) = (s, l + 1, m)+ adder (s, l, m) (Y.EventMappingStart{}) = (s, l, m + 1)+ adder a _ = a+ accum = (0, 0, 0) :: (Int, Int, Int)++caseLargestString :: Assertion+caseLargestString = do+ res <- P.fold (Fold.foldl' adder accum) (Y.decodeFile filePath)+ res @?= (length expected, expected)+ where+ expected = "this one is just a little bit bigger than the others"+ filePath = "test/largest-string.yaml"+ adder (i, s) (Y.EventScalar bs _ _ _) =+ let s' = B8.unpack bs+ i' = length s'+ in if i' > i then (i', s') else (i, s)+ adder acc _ = acc+ accum = (0, "no strings found")++newtype MyEvent = MyEvent Y.Event deriving Show+instance Eq MyEvent where+ (MyEvent (Y.EventScalar s t _ _)) == (MyEvent (Y.EventScalar s' t' _ _)) =+ s == s' && t == t'+ MyEvent e1 == MyEvent e2 = e1 == e2++caseEncodeDecode :: Assertion+caseEncodeDecode = do+ eList <- P.toList $ Y.decode yamlBS+ bs <- Y.encode (P.fromList eList)+ eList2 <- P.toList $ Y.decode bs+ map MyEvent eList @=? map MyEvent eList2+ where+ yamlString = "foo: bar\nbaz:\n - bin1\n - bin2\n"+ yamlBS = B8.pack yamlString++caseEncodeDecodeEvents :: Assertion+caseEncodeDecodeEvents = do+ let events = Internal.objToEvents D.defaultStringStyle testJSON []+ result <- Internal.decodeHelper_ . P.fromList $ eventStream events+ let (_, value) = either (error . show) id result+ value @?= testJSON++caseEncodeDecodeFile :: Assertion+caseEncodeDecodeFile = withFile "" $ \tmpPath -> do+ eList <- P.toList $ Y.decodeFile filePath+ Y.encodeFile tmpPath (P.fromList eList)+ eList2 <- P.toList $ Y.decodeFile filePath+ map MyEvent eList @=? map MyEvent eList2+ where+ filePath = "test/largest-string.yaml"++caseInterleave :: Assertion+caseInterleave = withFile "" $ \tmpPath -> withFile "" $ \tmpPath2 -> do+ () <- Y.encodeFile tmpPath (Y.decodeFile filePath)+ () <- Y.encodeFile tmpPath2 (Y.decodeFile tmpPath)+ f1 <- readFile tmpPath+ f2 <- readFile tmpPath2+ f1 @=? f2+ where+ filePath = "test/largest-string.yaml"++caseDecodeInvalidDocument :: Assertion+caseDecodeInvalidDocument = do+ x <- try $ P.toList $ Y.decode yamlBS+ case x of+ Left (_ :: SomeException) -> return ()+ Right y -> do+ putStrLn $ "bad return value: " ++ show y+ assertFailure "expected parsing exception, but got no errors"+ where+ yamlString = " - foo\n - baz\nbuz"+ yamlBS = B8.pack yamlString++mkScalar :: String -> D.Value+mkScalar = mkStrScalar++mkStrScalar :: String -> D.Value+mkStrScalar = D.String . T.pack++mappingKey :: D.Value-> String -> D.Value+mappingKey (D.Object m) k = (fromJust . M.lookup (fromText $ T.pack k) $ m)+mappingKey _ _ = error "expected Object"++sample :: D.Value+sample = array+ [ D.String "foo"+ , object+ [ ("bar1", D.String "bar2")+ , ("bar3", D.String "")+ ]+ , D.String ""+ , D.Number 1+ , D.Number 0.1+ , D.Bool True+ , D.Null+ ]++sampleBuilder :: B.YamlBuilder+sampleBuilder = B.array+ [ B.string "foo"+ , B.mapping+ [ ("bar1", B.string "bar2")+ , ("bar3", B.string "")+ ]+ , B.string ""+ , B.scientific 1+ , B.scientific 0.1+ , B.bool True+ , B.null+ ]++caseEncodeDecodeData :: Assertion+caseEncodeDecodeData = D.encode sample `shouldDecode` sample++caseEncodeDecodeDataPretty :: Assertion+caseEncodeDecodeDataPretty =+ Pretty.encodePretty Pretty.defConfig sample `shouldDecode` sample++caseEncodeDecodeDataBuilder :: Assertion+caseEncodeDecodeDataBuilder = do+ let events = B.unYamlBuilder sampleBuilder []+ bs <- testEncodeWith Y.defaultFormatOptions events+ bs `shouldDecodeEvents` eventStream events++caseEncodeDecodeComplexMappingBuilder :: Assertion+caseEncodeDecodeComplexMappingBuilder = do+ let events = B.unYamlBuilder builder []+ bs <- testEncodeWith Y.defaultFormatOptions events+ bs `shouldDecodeEvents` eventStream events+ where+ builder :: B.YamlBuilder+ builder = B.mappingComplex+ [ ( B.mapping+ [ ("foo", B.scientific 1)+ , ("bar", B.scientific 2)+ ]+ , B.bool True+ )+ ]++caseEncodeDecodeFileData :: Assertion+caseEncodeDecodeFileData = withFile "" $ \fp -> do+ D.encodeFile fp sample+ out <- D.decodeFileThrow fp+ out @?= sample++caseEncodeDecodeNonAsciiFileData :: Assertion+caseEncodeDecodeNonAsciiFileData = do+ let mySample = (object ["foo" .= True])+ inTempDirectory $ do+ createDirectory "accenté"+ D.encodeFile "accenté/bar.yaml" mySample+ out1 <- D.decodeFileThrow "accenté/bar.yaml"+ out1 @?= mySample++ c <- readFile "test/resources/accent/foo.yaml"+ inTempDirectory $ do+ createDirectoryIfMissing True "test/resources/unicode/accenté/"+ writeFile "test/resources/unicode/accenté/foo.yaml" c+ out2 <- D.decodeFileThrow "test/resources/unicode/accenté/foo.yaml"+ out2 @?= mySample++caseEncodeDecodeStrings :: Assertion+caseEncodeDecodeStrings = D.encode sample `shouldDecode` sample++caseEncodeDecodeStringsPretty :: Assertion+caseEncodeDecodeStringsPretty =+ Pretty.encodePretty Pretty.defConfig sample `shouldDecode` sample++caseDecodeInvalid :: Assertion+caseDecodeInvalid =+ D.decodeThrow "\tthis is 'not' valid :-)" `shouldBe`+ (Nothing :: Maybe D.Value)++caseSimpleScalarAlias :: Assertion+caseSimpleScalarAlias =+ "- &anch foo\n- baz\n- *anch" `shouldDecode`+ array [(mkScalar "foo"), (mkScalar "baz"), (mkScalar "foo")]++caseSimpleSequenceAlias :: Assertion+caseSimpleSequenceAlias =+ "seq: &anch\n - foo\n - baz\nseq2: *anch" `shouldDecode`+ object [("seq", array [(mkScalar "foo"), (mkScalar "baz")]), ("seq2", array [(mkScalar "foo"), (mkScalar "baz")])]++caseSimpleMappingAlias :: Assertion+caseSimpleMappingAlias =+ "map: &anch\n key1: foo\n key2: baz\nmap2: *anch" `shouldDecode`+ object [(packStr "map", object [("key1", mkScalar "foo"), ("key2", (mkScalar "baz"))]), (packStr "map2", object [("key1", (mkScalar "foo")), ("key2", mkScalar "baz")])]+ where+ packStr = fromText . T.pack++caseMappingAliasBeforeAnchor :: Assertion+caseMappingAliasBeforeAnchor =+ case D.decodeThrow "map: *anch\nmap2: &anch\n key1: foo\n key2: baz" of+ Nothing -> pure ()+ Just (_ :: D.Value) -> error "decode should return Nothing due to unknown alias"++caseMappingAliasInsideAnchor :: Assertion+caseMappingAliasInsideAnchor = do+ case D.decodeThrow "map: &anch\n key1: foo\n key2: *anch" of+ Nothing -> pure ()+ Just (_ :: D.Value) -> error "decode should return Nothing due to unknown alias"++caseScalarAliasOverriding :: Assertion+caseScalarAliasOverriding =+ "- &anch foo\n- baz\n- *anch\n- &anch boo\n- buz\n- *anch" `shouldDecode`+ array [(mkScalar "foo"), (mkScalar "baz"), (mkScalar "foo"), (mkScalar "boo"), (mkScalar "buz"), (mkScalar "boo")]++caseAllKeysShouldBeUnique :: Assertion+caseAllKeysShouldBeUnique = do+ res <- D.decodeThrow "foo1: foo\nfoo2: baz\nfoo1: buz"+ mappingKey res "foo1" `shouldBe` mkScalar "buz"++caseSimpleMappingMerge :: Assertion+caseSimpleMappingMerge = do+ res <- D.decodeThrow "foo1: foo\nfoo2: baz\n<<:\n foo1: buz\n foo3: fuz"+ mappingKey res "foo1" `shouldBe` mkScalar "foo"+ mappingKey res "foo3" `shouldBe` mkScalar "fuz"++caseMergeSequence :: Assertion+caseMergeSequence = do+ res <- D.decodeThrow "m1: &m1\n k1: !!str 1\n k2: !!str 2\nm2: &m2\n k1: !!str 3\n k3: !!str 4\nfoo1: foo\n<<: [ *m1, *m2 ]"+ mappingKey res "foo1" @?= (mkScalar "foo")+ mappingKey res "k1" @?= (D.String "1")+ mappingKey res "k2" @?= (D.String "2")+ mappingKey res "k3" @?= (D.String "4")++caseDataTypes :: Assertion+caseDataTypes =+ D.encode val `shouldDecode` val+ where+ val = object+ [ ("string", D.String "foo")+ , ("int", D.Number 5)+ , ("float", D.Number 4.3)+ , ("true", D.Bool True)+ , ("false", D.Bool False)+ , ("null", D.Null)+ ]++caseEncodeInvalidNumbers :: Assertion+caseEncodeInvalidNumbers =+ D.encode (D.String ".") `shouldBe` ".\n"++caseDataTypesPretty :: Assertion+caseDataTypesPretty =+ Pretty.encodePretty Pretty.defConfig val `shouldDecode` val+ where+ val = object+ [ ("string", D.String "foo")+ , ("int", D.Number 5)+ , ("float", D.Number 4.3)+ , ("true", D.Bool True)+ , ("false", D.Bool False)+ , ("null", D.Null)+ ]+caseQuotedNumber, caseUnquotedNumber, caseAttribNumber, caseIntegerDecimals :: Assertion+caseQuotedNumber = "foo: \"1234\"" `shouldDecode` object [("foo", D.String "1234")]+caseUnquotedNumber = "foo: 1234" `shouldDecode` object [("foo", D.Number 1234)]+caseAttribNumber = "foo: !!str 1234" `shouldDecode` object [("foo", D.String "1234")]+caseIntegerDecimals = "1\n" `shouldDecode` (1 :: Int)++obj :: D.Value+obj = object [("foo", D.Bool False), ("bar", D.Bool True), ("baz", D.Bool True)]++caseLowercaseBool, caseUppercaseBool, caseTitlecaseBool :: Assertion+caseLowercaseBool = "foo: off\nbar: y\nbaz: true" `shouldDecode` obj+caseUppercaseBool = "foo: FALSE\nbar: Y\nbaz: ON" `shouldDecode` obj+caseTitlecaseBool = "foo: No\nbar: Yes\nbaz: True" `shouldDecode` obj++caseEmptyInput :: Assertion+caseEmptyInput = B8.empty `shouldDecode` D.Null++caseEmptyInputFile :: Assertion+caseEmptyInputFile = do+ out <- D.decodeFileEither "test/resources/empty.yaml"+ either (Left . D.prettyPrintParseException) Right out @?= Right D.Null++caseCommentOnlyInput :: Assertion+caseCommentOnlyInput = "# comment\n" `shouldDecode` D.Null++caseCommentOnlyInputFile :: Assertion+caseCommentOnlyInputFile = do+ out <- D.decodeFileEither "test/resources/empty2.yaml"+ either (Left . D.prettyPrintParseException) Right out @?= Right D.Null++checkNull :: T.Text -> Spec+checkNull x =+ it ("null recognized: " ++ show x) $+ B8.pack ("foo: " ++ T.unpack x) `shouldDecode` object [("foo", D.Null)]++caseStripAlias :: Assertion+caseStripAlias =+ src `shouldDecode` object+ [ "Default" .= object+ [ "foo" .= (1 :: Int)+ , "bar" .= (2 :: Int)+ ]+ , "Obj" .= object+ [ "foo" .= (1 :: Int)+ , "bar" .= (2 :: Int)+ , "key" .= (3 :: Int)+ ]+ ]+ where+ src = "Default: &def\n foo: 1\n bar: 2\nObj:\n <<: *def\n key: 3\n"++caseIssue49 :: Assertion+caseIssue49 =+ src `shouldDecode` object+ [ "a" .= object [ "value" .= (1.0 :: Double) ]+ , "b" .= object [ "value" .= (1.2 :: Double) ]+ ]+ where+ src = "---\na:\n &id5 value: 1.0\nb:\n *id5: 1.2"++-- | We cannot guarantee this before aeson started using 'Scientific'.+casePreservesScientificPrecision :: Assertion+casePreservesScientificPrecision = do+ "x: 1e-100000" `shouldDecode` object+ [ "x" .= D.Number (read "1e-100000") ]+ -- Note that this ought to work also without 'Scientific', given+ -- that @read (show "9.78159610558926e-5") == 9.78159610558926e-5@.+ -- However, it didn't work (and still doesn't work with aeson < 0.7)+ -- for two reasons:+ --+ -- * We use 'Data.Text.Read.double', which is not as accurate as it+ -- can be;+ -- * Even if we used 'Data.Text.Read.rational' we would not get good+ -- results, because of <https://github.com/bos/text/issues/34>.+ "x: 9.78159610558926e-5" `shouldDecode` object+ [ "x" .= D.Number (read "9.78159610558926e-5") ]++caseTruncatesFiles :: Assertion+caseTruncatesFiles = withSystemTempFile "truncate.yaml" $ \fp h -> do+ replicateM_ 500 $ B8.hPut h "HELLO WORLD!!!!!\n"+ hClose h+ let val = object ["hello" .= ("world" :: String)]+ D.encodeFile fp val+ res <- D.decodeFileEither fp+ either (Left . show) Right res `shouldBe` Right val++caseSpecialKeys :: (KeyMap () -> B8.ByteString) -> Assertion+caseSpecialKeys encoder = do+ let keys = T.words "true false NO YES 1.2 1e5 null"+ bs = encoder $ M.fromList $ map (, ()) $ fmap fromText keys+ text = decodeUtf8 bs+ forM_ keys $ \key -> do+ let quoted = T.concat ["'", key, "'"]+ unless (quoted `T.isInfixOf` text) $ error $ concat+ [ "Could not find quoted key: "+ , T.unpack quoted+ , "\n\n"+ , T.unpack text+ ] :: IO ()++taggedSequence :: [Y.Event]+taggedSequence =+ [ Y.EventSequenceStart (Y.UriTag "!foo") Y.FlowSequence Nothing+ , Y.EventSequenceEnd+ ]++taggedMapping :: [Y.Event]+taggedMapping =+ [ Y.EventMappingStart (Y.UriTag "!foo") Y.FlowMapping Nothing+ , Y.EventMappingEnd+ ]++defaultTaggedSequence :: [Y.Event]+defaultTaggedSequence =+ [Y.EventSequenceStart Y.SeqTag Y.FlowSequence Nothing, Y.EventSequenceEnd]++defaultTaggedMapping :: [Y.Event]+defaultTaggedMapping =+ [Y.EventMappingStart Y.MapTag Y.FlowMapping Nothing, Y.EventMappingEnd]++untaggedSequence :: [Y.Event]+untaggedSequence =+ [Y.EventSequenceStart Y.NoTag Y.FlowSequence Nothing, Y.EventSequenceEnd]++untaggedMapping :: [Y.Event]+untaggedMapping =+ [Y.EventMappingStart Y.NoTag Y.FlowMapping Nothing, Y.EventMappingEnd]++mixedTagSampleA :: [Y.Event]+mixedTagSampleA =+ [ Y.EventSequenceStart Y.NoTag Y.BlockSequence Nothing+ , Y.EventMappingStart (Y.UriTag "!foo") Y.FlowMapping Nothing+ , Y.EventMappingEnd+ , Y.EventSequenceEnd+ ]++mixedTagSampleB :: [Y.Event]+mixedTagSampleB =+ [ Y.EventMappingStart Y.NoTag Y.BlockMapping (Just "a")+ , Y.EventScalar "foo" (Y.UriTag "bar") Y.Plain (Just "b")+ , Y.EventSequenceStart (Y.UriTag "!baz") Y.FlowSequence (Just "c")+ , Y.EventScalar "" Y.NullTag Y.Plain (Just "d")+ , Y.EventSequenceEnd+ , Y.EventMappingEnd+ ]
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/json.yaml view
@@ -0,0 +1,9 @@+string: str+number: 2+anArray:+ - a+ - b+hash:+ key1: value1+ key2: value2+extrastring: 1234-foo
+ test/largest-string.yaml view
@@ -0,0 +1,6 @@+this is a long string: but this one is even longer+this is shorter:+ - many+ - tiny+ - string+one the other hand: this one is just a little bit bigger than the others
+ test/resources/accent/foo.yaml view
@@ -0,0 +1,1 @@+foo: true
+ test/resources/bar.yaml view
@@ -0,0 +1,2 @@+one: 1+two: 2
+ test/resources/baz.yaml view
@@ -0,0 +1,1 @@+foo: !include foo.yaml
+ test/resources/empty.yaml view
+ test/resources/empty2.yaml view
@@ -0,0 +1,1 @@+# comment
+ test/resources/foo.yaml view
@@ -0,0 +1,3 @@+foo: 23+bar: !include bar.yaml+baz: 42
+ test/resources/loop/bar.yaml view
@@ -0,0 +1,2 @@+one: 1+two: !include foo.yaml
+ test/resources/loop/foo.yaml view
@@ -0,0 +1,3 @@+foo: 23+bar: !include bar.yaml+baz: 42
+ yaml-streamly.cabal view
@@ -0,0 +1,187 @@+cabal-version: 1.12+name: yaml-streamly+version: 0.12.0+synopsis: Support for parsing and rendering YAML documents.+description: Rewrite of yaml in streamly+category: Data+stability: stable+homepage: https://github.com/hasufell/streamly-yaml#readme+bug-reports: https://github.com/hasufell/streamly-yaml+author:+ Michael Snoyman <michael@snoyman.com>, Anton Ageev <antage@gmail.com>,Kirill Simonov, Julian Ospald <hasufell@posteo.de>++maintainer: Julian Ospald <hasufell@posteo.de>+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ ./ChangeLog.md+ ./README.md+ ./test/json.yaml+ ./test/largest-string.yaml+ ./test/resources/accent/foo.yaml+ ./test/resources/bar.yaml+ ./test/resources/baz.yaml+ ./test/resources/empty.yaml+ ./test/resources/empty2.yaml+ ./test/resources/foo.yaml+ ./test/resources/loop/bar.yaml+ ./test/resources/loop/foo.yaml++source-repository head+ type: git+ location: https://github.com/hasufell/streamly-yaml++flag no-examples+ description: don't build the examples+ manual: False+ default: True++flag no-exe+ description: don't install the yaml2json or json2yaml executables+ manual: False+ default: True++library+ exposed-modules:+ Data.Yaml+ Data.Yaml.Aeson+ Data.Yaml.Builder+ Data.Yaml.Config+ Data.Yaml.Include+ Data.Yaml.Internal+ Data.Yaml.Parser+ Data.Yaml.Pretty+ Data.Yaml.TH++ other-modules: Paths_yaml_streamly+ hs-source-dirs: src+ other-extensions: LambdaCase+ ghc-options:+ -Wall -Wcompat -fspecialise-aggressively -fexpose-all-unfoldings+ -fdicts-strict -O2 -fmax-worker-args=16 -fspec-constr-recursive=16++ build-depends:+ aeson >=0.11+ , attoparsec >=0.11.3.0+ , base >=4.9.1 && <5+ , bytestring >=0.9.1.4+ , containers+ , directory+ , filepath+ , libyaml-streamly >=0.2+ , mtl+ , safe-exceptions+ , scientific >=0.3+ , streamly >=0.8.0+ , template-haskell+ , text+ , transformers >=0.1+ , unordered-containers+ , vector++ default-language: Haskell2010++executable examples+ main-is: Main.hs+ other-modules:+ Config+ Paths_yaml_streamly+ Simple++ hs-source-dirs: examples+ ghc-options: -Wall -Wcompat+ build-depends:+ aeson >=0.11+ , base >=4.9.1 && <5+ , bytestring >=0.9.1.4+ , text++ if flag(no-examples)+ buildable: False++ else+ build-depends:+ raw-strings-qq+ , yaml-streamly++ default-language: Haskell2010++executable json2yaml+ main-is: json2yaml.hs+ other-modules:+ Common+ Paths_yaml_streamly++ hs-source-dirs: exe+ ghc-options: -Wall -Wcompat+ build-depends:+ aeson >=0.11+ , base >=4.9.1 && <5+ , bytestring >=0.9.1.4+ , optparse-applicative+ , yaml-streamly++ if flag(no-exe)+ buildable: False++ default-language: Haskell2010++executable yaml2json+ main-is: yaml2json.hs+ other-modules:+ Common+ Paths_yaml_streamly++ hs-source-dirs: exe+ other-extensions:+ CPP+ LambdaCase+ NamedFieldPuns++ ghc-options: -Wall -Wcompat+ build-depends:+ aeson >=0.11+ , base >=4.9.1 && <5+ , bytestring >=0.9.1.4+ , optparse-applicative+ , yaml-streamly++ if flag(no-exe)+ buildable: False++ default-language: Haskell2010++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Data.Yaml.IncludeSpec+ Data.Yaml.THSpec+ Data.YamlSpec+ Paths_yaml_streamly++ hs-source-dirs: test+ ghc-options: -Wall -Wcompat -with-rtsopts=-K1K+ cpp-options: -DTEST+ build-tool-depends: hspec-discover:hspec-discover -any+ build-depends:+ aeson >=0.11+ , base >=4.9.1 && <5+ , base-compat+ , bytestring >=0.9.1.4+ , directory+ , hspec >=1.3+ , HUnit+ , libyaml-streamly >=0.2+ , mockery+ , raw-strings-qq+ , scientific >=0.3+ , streamly >=0.8.0+ , temporary+ , text+ , unordered-containers+ , vector+ , yaml-streamly++ default-language: Haskell2010