diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,26 @@ +## yaml + +[![GitHub build and test status](https://github.com/snoyberg/yaml/actions/workflows/tests.yml/badge.svg?branch=master)](https://github.com/snoyberg/yaml/actions/workflows/tests.yml) +[![Appveyor build status](https://ci.appveyor.com/api/projects/status/hqy2jketp8m502so/branch/master?svg=true)](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 +``` diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/examples/Config.hs b/examples/Config.hs new file mode 100644 --- /dev/null +++ b/examples/Config.hs @@ -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) diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Main.hs @@ -0,0 +1,10 @@ +module Main where + +import qualified Config +import qualified Simple + +main :: IO () +main = do + Simple.main + Config.main + diff --git a/examples/Simple.hs b/examples/Simple.hs new file mode 100644 --- /dev/null +++ b/examples/Simple.hs @@ -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. diff --git a/exe/Common.hs b/exe/Common.hs new file mode 100644 --- /dev/null +++ b/exe/Common.hs @@ -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 diff --git a/exe/json2yaml.hs b/exe/json2yaml.hs new file mode 100644 --- /dev/null +++ b/exe/json2yaml.hs @@ -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 diff --git a/exe/yaml2json.hs b/exe/yaml2json.hs new file mode 100644 --- /dev/null +++ b/exe/yaml2json.hs @@ -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 diff --git a/src/Data/Yaml.hs b/src/Data/Yaml.hs new file mode 100644 --- /dev/null +++ b/src/Data/Yaml.hs @@ -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." #-} diff --git a/src/Data/Yaml/Aeson.hs b/src/Data/Yaml/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Data/Yaml/Aeson.hs @@ -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 diff --git a/src/Data/Yaml/Builder.hs b/src/Data/Yaml/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Data/Yaml/Builder.hs @@ -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) diff --git a/src/Data/Yaml/Config.hs b/src/Data/Yaml/Config.hs new file mode 100644 --- /dev/null +++ b/src/Data/Yaml/Config.hs @@ -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 diff --git a/src/Data/Yaml/Include.hs b/src/Data/Yaml/Include.hs new file mode 100644 --- /dev/null +++ b/src/Data/Yaml/Include.hs @@ -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 diff --git a/src/Data/Yaml/Internal.hs b/src/Data/Yaml/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Yaml/Internal.hs @@ -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 + diff --git a/src/Data/Yaml/Parser.hs b/src/Data/Yaml/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Data/Yaml/Parser.hs @@ -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 diff --git a/src/Data/Yaml/Pretty.hs b/src/Data/Yaml/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Data/Yaml/Pretty.hs @@ -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 diff --git a/src/Data/Yaml/TH.hs b/src/Data/Yaml/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Yaml/TH.hs @@ -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") diff --git a/test/Data/Yaml/IncludeSpec.hs b/test/Data/Yaml/IncludeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Yaml/IncludeSpec.hs @@ -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 diff --git a/test/Data/Yaml/THSpec.hs b/test/Data/Yaml/THSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Yaml/THSpec.hs @@ -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] diff --git a/test/Data/YamlSpec.hs b/test/Data/YamlSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/YamlSpec.hs @@ -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 ! 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 ! 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 ! 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 . + "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 + ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/json.yaml b/test/json.yaml new file mode 100644 --- /dev/null +++ b/test/json.yaml @@ -0,0 +1,9 @@ +string: str +number: 2 +anArray: + - a + - b +hash: + key1: value1 + key2: value2 +extrastring: 1234-foo diff --git a/test/largest-string.yaml b/test/largest-string.yaml new file mode 100644 --- /dev/null +++ b/test/largest-string.yaml @@ -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 diff --git a/test/resources/accent/foo.yaml b/test/resources/accent/foo.yaml new file mode 100644 --- /dev/null +++ b/test/resources/accent/foo.yaml @@ -0,0 +1,1 @@ +foo: true diff --git a/test/resources/bar.yaml b/test/resources/bar.yaml new file mode 100644 --- /dev/null +++ b/test/resources/bar.yaml @@ -0,0 +1,2 @@ +one: 1 +two: 2 diff --git a/test/resources/baz.yaml b/test/resources/baz.yaml new file mode 100644 --- /dev/null +++ b/test/resources/baz.yaml @@ -0,0 +1,1 @@ +foo: !include foo.yaml diff --git a/test/resources/empty.yaml b/test/resources/empty.yaml new file mode 100644 --- /dev/null +++ b/test/resources/empty.yaml diff --git a/test/resources/empty2.yaml b/test/resources/empty2.yaml new file mode 100644 --- /dev/null +++ b/test/resources/empty2.yaml @@ -0,0 +1,1 @@ +# comment diff --git a/test/resources/foo.yaml b/test/resources/foo.yaml new file mode 100644 --- /dev/null +++ b/test/resources/foo.yaml @@ -0,0 +1,3 @@ +foo: 23 +bar: !include bar.yaml +baz: 42 diff --git a/test/resources/loop/bar.yaml b/test/resources/loop/bar.yaml new file mode 100644 --- /dev/null +++ b/test/resources/loop/bar.yaml @@ -0,0 +1,2 @@ +one: 1 +two: !include foo.yaml diff --git a/test/resources/loop/foo.yaml b/test/resources/loop/foo.yaml new file mode 100644 --- /dev/null +++ b/test/resources/loop/foo.yaml @@ -0,0 +1,3 @@ +foo: 23 +bar: !include bar.yaml +baz: 42 diff --git a/yaml-streamly.cabal b/yaml-streamly.cabal new file mode 100644 --- /dev/null +++ b/yaml-streamly.cabal @@ -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 , Anton Ageev ,Kirill Simonov, Julian Ospald + +maintainer: Julian Ospald +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