tomland 1.1.0.1 → 1.3.3.3
raw patch · 112 files changed
Files
- CHANGELOG.md +202/−1
- README.lhs +111/−56
- README.md +111/−56
- benchmark/Benchmark/Htoml.hs +0/−45
- benchmark/Benchmark/HtomlMegaparsec.hs +0/−43
- benchmark/Benchmark/TomlParser.hs +0/−91
- benchmark/Benchmark/Tomland.hs +0/−39
- benchmark/Benchmark/Type.hs +0/−57
- benchmark/Main.hs +0/−41
- examples/Main.hs +259/−0
- examples/Playground.hs +0/−116
- src/Toml.hs +46/−14
- src/Toml/Bi.hs +0/−22
- src/Toml/Bi/Code.hs +0/−137
- src/Toml/Bi/Combinators.hs +0/−300
- src/Toml/Bi/Map.hs +0/−504
- src/Toml/Bi/Monad.hs +0/−231
- src/Toml/Codec.hs +125/−0
- src/Toml/Codec/BiMap.hs +240/−0
- src/Toml/Codec/BiMap/Conversion.hs +653/−0
- src/Toml/Codec/Code.hs +159/−0
- src/Toml/Codec/Combinator.hs +155/−0
- src/Toml/Codec/Combinator/Common.hs +79/−0
- src/Toml/Codec/Combinator/Custom.hs +268/−0
- src/Toml/Codec/Combinator/List.hs +225/−0
- src/Toml/Codec/Combinator/Map.hs +413/−0
- src/Toml/Codec/Combinator/Monoid.hs +117/−0
- src/Toml/Codec/Combinator/Primitive.hs +208/−0
- src/Toml/Codec/Combinator/Set.hs +242/−0
- src/Toml/Codec/Combinator/Table.hs +95/−0
- src/Toml/Codec/Combinator/Time.hs +74/−0
- src/Toml/Codec/Combinator/Tuple.hs +103/−0
- src/Toml/Codec/Di.hs +213/−0
- src/Toml/Codec/Error.hs +97/−0
- src/Toml/Codec/Generic.hs +824/−0
- src/Toml/Codec/Types.hs +224/−0
- src/Toml/Edsl.hs +0/−76
- src/Toml/Generic.hs +0/−393
- src/Toml/Parser.hs +47/−15
- src/Toml/Parser/Core.hs +12/−1
- src/Toml/Parser/Item.hs +115/−0
- src/Toml/Parser/Key.hs +58/−0
- src/Toml/Parser/String.hs +9/−2
- src/Toml/Parser/TOML.hs +0/−134
- src/Toml/Parser/Validate.hs +190/−0
- src/Toml/Parser/Value.hs +50/−9
- src/Toml/PrefixTree.hs +0/−222
- src/Toml/Printer.hs +0/−201
- src/Toml/Type.hs +69/−6
- src/Toml/Type/AnyValue.hs +29/−5
- src/Toml/Type/Edsl.hs +110/−0
- src/Toml/Type/Key.hs +141/−0
- src/Toml/Type/PrefixTree.hs +245/−0
- src/Toml/Type/Printer.hs +285/−0
- src/Toml/Type/TOML.hs +77/−11
- src/Toml/Type/UValue.hs +24/−5
- src/Toml/Type/Value.hs +60/−14
- test/Spec.hs +20/−1
- test/Test/Toml/BiCode/Property.hs +0/−178
- test/Test/Toml/BiMap/Property.hs +0/−64
- test/Test/Toml/Codec.hs +22/−0
- test/Test/Toml/Codec/BiMap.hs +67/−0
- test/Test/Toml/Codec/BiMap/Conversion.hs +74/−0
- test/Test/Toml/Codec/Code.hs +137/−0
- test/Test/Toml/Codec/Combinator.hs +28/−0
- test/Test/Toml/Codec/Combinator/Common.hs +83/−0
- test/Test/Toml/Codec/Combinator/Custom.hs +28/−0
- test/Test/Toml/Codec/Combinator/List.hs +28/−0
- test/Test/Toml/Codec/Combinator/Map.hs +29/−0
- test/Test/Toml/Codec/Combinator/Monoid.hs +24/−0
- test/Test/Toml/Codec/Combinator/Primitive.hs +30/−0
- test/Test/Toml/Codec/Combinator/Set.hs +30/−0
- test/Test/Toml/Codec/Combinator/Table.hs +16/−0
- test/Test/Toml/Codec/Combinator/Time.hs +18/−0
- test/Test/Toml/Codec/Combinator/Tuple.hs +24/−0
- test/Test/Toml/Codec/Di.hs +57/−0
- test/Test/Toml/Codec/Generic.hs +33/−0
- test/Test/Toml/Codec/SmallType.hs +59/−0
- test/Test/Toml/Gen.hs +160/−90
- test/Test/Toml/Parser.hs +34/−0
- test/Test/Toml/Parser/Array.hs +74/−0
- test/Test/Toml/Parser/Bool.hs +22/−0
- test/Test/Toml/Parser/Common.hs +153/−0
- test/Test/Toml/Parser/Date.hs +63/−0
- test/Test/Toml/Parser/Double.hs +45/−0
- test/Test/Toml/Parser/Examples.hs +25/−0
- test/Test/Toml/Parser/Integer.hs +123/−0
- test/Test/Toml/Parser/Key.hs +48/−0
- test/Test/Toml/Parser/Property.hs +21/−0
- test/Test/Toml/Parser/Text.hs +96/−0
- test/Test/Toml/Parser/Toml.hs +163/−0
- test/Test/Toml/Parser/Validate.hs +79/−0
- test/Test/Toml/Parsing/Examples.hs +0/−21
- test/Test/Toml/Parsing/Property.hs +0/−13
- test/Test/Toml/Parsing/Unit.hs +0/−573
- test/Test/Toml/PrefixTree/Property.hs +0/−73
- test/Test/Toml/PrefixTree/Unit.hs +0/−43
- test/Test/Toml/Printer/Golden.hs +0/−64
- test/Test/Toml/Property.hs +30/−14
- test/Test/Toml/TOML/Property.hs +0/−15
- test/Test/Toml/Type.hs +18/−0
- test/Test/Toml/Type/Key.hs +47/−0
- test/Test/Toml/Type/PrefixTree.hs +95/−0
- test/Test/Toml/Type/Printer.hs +69/−0
- test/Test/Toml/Type/TOML.hs +18/−0
- test/golden/pretty_custom_sorted.golden +1/−0
- test/golden/pretty_default.golden +1/−0
- test/golden/pretty_indented_only.golden +4/−3
- test/golden/pretty_lines.golden +30/−0
- test/golden/pretty_sorted_only.golden +1/−0
- test/golden/pretty_unformatted.golden +4/−3
- tomland.cabal +135/−80
CHANGELOG.md view
@@ -1,7 +1,208 @@ # Changelog -tomland uses [PVP Versioning][1].+`tomland` uses [PVP Versioning][1]. The changelog is available [on GitHub][2].++## 1.3.3.3 – Jun 7, 2024++* Support up to GHC-9.10.+* Remove `transformers` dependency.+* Allow test case to work with `OverloadedStrings`++## 1.3.3.2 – Oct 5, 2022++* [#395](https://github.com/kowainik/tomland/issues/395):+ Support GHC-9.2.4.+* Upgrade `text` to version `2`.+* Upgrade `hedgehog` and `hspec`.++## 🍁 1.3.3.1 — Nov 8, 2021++* Disable building executables by default+* Bump up dependencies:+ * Allow `bytestring-0.11.*`+ * Allow `hashable-1.4.0.0`+ * Allow `megaparsec-9.2.0`+ * Allow `time-1.13`+ * Allow `transformers-0.6.*`++## 🥞 1.3.3.0 — Mar 14, 2021++* [#370](https://github.com/kowainik/tomland/issues/370):+ Support GHC-9.0.1.+* [#368](https://github.com/kowainik/tomland/issues/368):+ Upgrade `hashable` lower bound to 1.3.1.0.+* Sort keys in pretty printing by default.++## 🐂 1.3.2.0 — Feb 12, 2021++* [#186](https://github.com/kowainik/tomland/issues/186):+ Implement TOML difference. Add `decodeExact` and `decodeFileExact`.+* [#325](https://github.com/kowainik/tomland/issues/325):+ Add ability to one or multiline printing to `PrintOptions` for arrays.+* [#329](https://github.com/kowainik/tomland/issues/329):+ Add `_Harcoded` codec and `hardcoded` combinator.+* [#333](https://github.com/kowainik/tomland/issues/333):+ Fix bug with parsing leading zeroes in numeric values.+* [#334](https://github.com/kowainik/tomland/issues/334):+ Escape unicode characters correctly in `encode`.+* [#364](https://github.com/kowainik/tomland/issues/364):+ Update GHC from `8.10.2` to `8.10.4`.+* [#358](https://github.com/kowainik/tomland/issues/358):+ Upgrade `parser-combinators` upper bound to allow `1.3`.++## 1.3.1.0 — Sep 21, 2020++* [#331](https://github.com/kowainik/tomland/issues/331):+ Support hexidecimal, octal and binary values with underscores.+* [#335](https://github.com/kowainik/tomland/issues/335):+ Consider table array keys in `tableMap`s as well.+* [#338](https://github.com/kowainik/tomland/issues/338):+ Allow `megaparsec-9.0` and `hspec-megaparsec-2.2`.+* Update GHC from `8.8.3` to `8.8.4`, from `8.10.1` to `8.10.2`.++## 1.3.0.0 — May 19, 2020++* [#253](https://github.com/kowainik/tomland/issues/253):+ Support GHC-8.10.1. Move to GHC-8.8.3 from 8.8.1.+* Drop support of GHC-8.2.2.+* [#271](https://github.com/kowainik/tomland/issues/271):+ Use `Validation` from `validation-selective` in `TomlEnv`.+ This allows to accumulate and display all errors that occurs during the+ decoding phase.+ All previous decode functions return list of all `TomlDecodeError`s.++ __Note:__ Due to the specific of `Validation` data type, there is no `Monad`+ instanse of `Codec` anymore. However, this doesn't limit any previously+ released features.+* Add `decodeValidation`, `decodeFileValidation` functions to return+ `Validation` instead of `Either`.+* [#263](https://github.com/kowainik/tomland/issues/263):+ Simplify `Codec` abstraction. Instead of having `Codec r w c a`+ now it is `Codec TomlEnv TomlState c a`.++ Remove `BiCodec` as it is simple `TomlCodec` with this change.+* [#256](https://github.com/kowainik/tomland/issues/256),+ [#278](https://github.com/kowainik/tomland/issues/278):+ Rename modules to simplify module structure.++ __Migration guide:__ If you use `Toml` module (as advised by the library) then+ no changes required in your code.+ If you import some particular modules from `tomland` here is the renaming+ scheme you can use to apply to your imports:++ | __Old__ | __New__ |+ |-----|-----|+ | `Toml.Bi` | `Toml.Codec` |+ | `Toml.Bi.Combinators` | `Toml.Codec.Combinator` |+ | `Toml.Bi.Monad` | `Toml.Codec.Types` |+ | `Toml.Bi.Code` | `Toml.Codec.Code` or `Toml.Codec.Types` or `Toml.Codec.Error` |+ | `Toml.Bi.Map` | `Toml.Codec.BiMap` or `Toml.Codec.BiMap.Conversion` |+ | `Toml.Generic` | `Toml.Codec.Generic` |+ | `Toml.Edsl` | `Toml.Type.Edsl` |+ | `Toml.Printer` | `Toml.Type.Printer` |+ | `Toml.PrefixTree` | `Toml.Type.PrefixTree` or `Toml.Type.Key` |+++* [#283](https://github.com/kowainik/tomland/issues/283):+ Documentation improvements:+ - Add Codec Tables to each kind of codecs with examples+ - Add high-level description to each reexported module+ - Add @since annotations+ - Improve README+ - Add more examples into functions+* [#237](https://github.com/kowainik/tomland/issues/237):+ Add `BiMap` `_Validate` and codecs `validate` and `validateIf` for custom+ validation.+* [#289](https://github.com/kowainik/tomland/issues/289):+ Add `_Coerce` `TomlBiMap`.+* [#270](https://github.com/kowainik/tomland/issues/270):+ Add `pair` and `triple` codecs for tuples.+* [#261](https://github.com/kowainik/tomland/issues/261):+ Implement `tableMap` codec to use TOML keys as `Map` keys.+* [#243](https://github.com/kowainik/tomland/issues/243):+ Implement `hashMap`, `tableHashMap`, `intMap`, `tableIntMap` codec+ combinators.+* Add `intSet` codec.+* Add `_KeyInt` `BiMap`for key-as-int approach.+* [#242](https://github.com/kowainik/tomland/issues/242):+ Add `HasCodec` instances for `Map`, `HashMap` and `IntMap` for+ `Generic` deriving.+* [#272](https://github.com/kowainik/tomland/issues/272):+ Add `TomlTable` newtype to be used in generic `DerivingVia`.+* [#251](https://github.com/kowainik/tomland/issues/251):+ Implement `ByteStringAsText`, `ByteStringAsBytes`, `LByteStringAsText`,+ `LByteStringAsBytes` newtypes. Add corresponding `HasCodec` instances for+ these data types.+* [#311](https://github.com/kowainik/tomland/issues/311):+ Reimplement custom `TomlState` instead of using `MaybeT` and `State`.+* Rename `ParseException` to `TomlParseError`.+* Rename `DecodeException` to `TomlDecodeError`.+* Add `TableArrayNotFound` constructor to `TomlDecodeError`.+* Remove `TrivialError` and `TypeMismatch` constructors of the `TomlDecodeError`+ type.+* [#313](https://github.com/kowainik/tomland/issues/313):+ Store `Key` in the `BiMapError` constructor of `TomlDecodeError`.+* Add `decodeFileEither` and `encodeToFile` functions.+* Fix `sum` and `product` behaviour on missing fields. Now it returns the+ wrapper of `mempty` instead of failure.+* [#302](https://github.com/kowainik/tomland/issues/302):+ `nonEmpty` codec throws `TableArrayNotFound` instead of `TableNotFound`.+* [#318](https://github.com/kowainik/tomland/issues/318):+ Export a function for parsing TOML keys `parseKey`.+* [#310](https://github.com/kowainik/tomland/issues/310):+ Add tests on all kinds of `TomlDecodeError` with `decode` function.+* [#218](https://github.com/kowainik/tomland/issues/218):+ Add tests for TOML validation.+* [#252](https://github.com/kowainik/tomland/issues/252):+ Move to `hspec-*` family of libraries from `tasty-*`.+* [#297](https://github.com/kowainik/tomland/issues/297):+ Tests parallelism and speed-up.+* [#246](https://github.com/kowainik/tomland/issues/246):+ Bump up `megaparsec` version to `8.0.0`.++## 1.2.1.0 — Nov 6, 2019++* [#203](https://github.com/kowainik/tomland/issues/203):+ Implement codecs for `Map`-like data structures.+ (by [@chshersh](https://github.com/chshersh))+* [#241](https://github.com/kowainik/tomland/issues/241):+ Implement codecs for `Monoid` wrappers:+ `all`, `any`, `sum`, `product`, `first`, `last`.+ (by [@vrom911](https://github.com/vrom911))++## 1.2.0.0 — Oct 12, 2019++* [#216](https://github.com/kowainik/tomland/issues/216):+ Refactor TOML parser significantly. Check for some validation errors.+ (by [@chshersh](https://github.com/chshersh))+* [#213](https://github.com/kowainik/tomland/issues/213):+ Support GHC-8.8.1.+ (by [@vrom911](https://github.com/vrom911))+* [#226](https://github.com/kowainik/tomland/issues/226):+ Add `dimatch` combinator for better support of sum types.+ (by [@Nimor111](https://github.com/Nimor111))+* [#219](https://github.com/kowainik/tomland/issues/219):+ Add INLINE pragmas to code.+ (by [@willbasky](https://github.com/willbasky))+* [#204](https://github.com/kowainik/tomland/issues/204):+ Implement bidirectional codecs to work with `ByteString` as array of bytes.+ (by [@crtschin](https://github.com/crtschin))+* [#201](https://github.com/kowainik/tomland/issues/201):+ Implement `set` and `hashSet` combinators for array of tables.+ (by [@SanchayanMaity](https://github.com/SanchayanMaity))+* [#215](https://github.com/kowainik/tomland/issues/215):+ Move benchmarks to separate repository+ [toml-benchmarks](https://github.com/kowainik/toml-benchmarks).+ (by [@kutyel](https://github.com/kutyel))+* [#209](https://github.com/kowainik/tomland/issues/209):+ Bump up `parser-combinators` to `1.2.0`.+ (by [@vrom911](https://github.com/vrom911))+* [#198](https://github.com/kowainik/tomland/issues/198):+ Improve test generators.+ (by [@gabrielelana](https://github.com/gabrielelana)+ , [@chshersh](https://github.com/chshersh)+ ) ## 1.1.0.1 — Jul 10, 2019
README.lhs view
@@ -1,28 +1,36 @@ # tomland -[](https://travis-ci.org/kowainik/tomland)++[](https://github.com/kowainik/tomland/actions) [](https://hackage.haskell.org/package/tomland)-[](http://stackage.org/lts/package/tomland)-[](http://stackage.org/nightly/package/tomland)-[](https://github.com/kowainik/tomland/blob/master/LICENSE)+[](https://github.com/kowainik/tomland/blob/main/LICENSE) > “A library is like an island in the middle of a vast sea of ignorance, > particularly if the library is very tall and the surrounding area has been > flooded.”->+ > ― Lemony Snicket, Horseradish -Bidirectional TOML serialization. The following blog post has more details about-library design:+`tomland` is a Haskell library for _Bidirectional TOML+Serialization_. It provides the composable interface for implementing+[TOML](https://github.com/toml-lang/toml) codecs. If you want to use+TOML as a configuration for your tool or application, you can use+`tomland` to easily convert in both ways between textual TOML+representation and Haskell types. -* [`tomland`: Bidirectional TOML serialization](https://kowainik.github.io/posts/2019-01-14-tomland)+✍️ `tomland` supports [TOML spec version 0.5.0](https://github.com/toml-lang/toml/wiki#v050-compliant). +The following blog post has more details about the library design and+internal implementation details:++* [`tomland`: Bidirectional TOML Serialization](https://kowainik.github.io/posts/2019-01-14-tomland)+ This README contains a basic usage example of the `tomland` library. All code below can be compiled and run with the following command: ```-cabal new-run readme+cabal run readme ``` ## Preamble: imports and language extensions@@ -37,15 +45,15 @@ {-# LANGUAGE OverloadedStrings #-} import Control.Applicative ((<|>))-import Control.Category ((>>>)) import Data.Text (Text)-import Toml (TomlBiMap, TomlCodec, (.=))+import Data.Time (Day)+import Toml (TomlCodec, (.=)) import qualified Data.Text.IO as TIO import qualified Toml ``` -`tomland` is mostly designed for qualified imports and intended to be imported+`tomland` is designed for qualified imports and intended to be imported as follows: ```haskell ignore@@ -55,10 +63,40 @@ ## Data type: parsing and printing -We're going to parse TOML configuration from [`examples/readme.toml`](examples/readme.toml) file.+We're going to parse TOML configuration from+[`examples/readme.toml`](examples/readme.toml) file. The configuration+contains the following description of our data: -This static configuration is captured by the following Haskell data type:+```toml+server.port = 8080+server.codes = [ 5, 10, 42 ]+server.description = """+This is production server.+Don't touch it!+""" +[mail]+ host = "smtp.gmail.com"+ send-if-inactive = false++[[user]]+ guestId = 42++[[user]]+ guestId = 114++[[user]]+ login = "Foo Bar"+ createdAt = 2020-05-19+```++The above static configuration describes `Settings` for some+server. It has several top-level fields, a table with the name `mail`+and an array of tables with the name `user` that stores list of+different types of users.++We can model such TOML using the following Haskell data types:+ ```haskell data Settings = Settings { settingsPort :: !Port@@ -74,28 +112,36 @@ } data User- = Admin Integer -- id of admin- | Client Text -- name of the client- deriving (Show)+ = Guest !Integer -- id of guest+ | Registered !RegisteredUser -- login and createdAt of registered user +data RegisteredUser = RegisteredUser+ { registeredUserLogin :: !Text+ , registeredUserCreatedAt :: !Day+ }+ newtype Port = Port Int newtype Host = Host Text ``` -Using `tomland` library, you can write bidirectional converters for these types-using the following guidelines and helper functions:+Using the `tomland` library, you can write bidirectional converters for these types+with the following guidelines and helper functions: -1. If your fields are some simple basic types like `Int` or `Text` you can just+1. If your fields are some simple primitive types like `Int` or `Text` you can just use standard codecs like `Toml.int` and `Toml.text`. 2. If you want to parse `newtype`s, use `Toml.diwrap` to wrap parsers for underlying `newtype` representation.-3. For parsing nested data types, use `Toml.table`. But this requires to specify- this data type as TOML table in `.toml` file.+3. For parsing nested data types, use `Toml.table`. But it requires to specify+ this data type as TOML table in the `.toml` file. 4. If you have lists of custom data types, use `Toml.list`. Such lists are- represented as array of tables in TOML. If you have lists of primitive types+ represented as _array of tables_ in TOML. If you have lists of the primitive types like `Int`, `Bool`, `Double`, `Text` or time types, that you can use `Toml.arrayOf` and parse arrays of values.-5. `tomland` separates conversion between Haskell types and TOML values from+5. If you have sets of custom data types, use `Toml.set` or `Toml.HashSet`. Such+ sets are represented as array of tables in TOML.+6. For parsing sum types, use `Toml.dimatch`. This requires writing matching functions+ for the constructors of the sum type.+7. `tomland` separates conversion between Haskell types and TOML values from matching values by keys. Converters between types and values have type `TomlBiMap` and are named with capital letter started with underscore. Main type for TOML codecs is called `TomlCodec`. To lift `TomlBiMap` to@@ -115,41 +161,49 @@ <$> Toml.diwrap (Toml.text "host") .= mailHost <*> Toml.bool "send-if-inactive" .= mailSendIfInactive -_Admin :: TomlBiMap User Integer-_Admin = Toml.prism Admin $ \case- Admin i -> Right i- other -> Toml.wrongConstructor "Admin" other+matchGuest :: User -> Maybe Integer+matchGuest = \case+ Guest i -> Just i+ _ -> Nothing -_Client :: TomlBiMap User Text-_Client = Toml.prism Client $ \case- Client n -> Right n- other -> Toml.wrongConstructor "Client" other+matchRegistered :: User -> Maybe RegisteredUser+matchRegistered = \case+ Registered u -> Just u+ _ -> Nothing userCodec :: TomlCodec User userCodec =- Toml.match (_Admin >>> Toml._Integer) "id"- <|> Toml.match (_Client >>> Toml._Text) "name"+ Toml.dimatch matchGuest Guest (Toml.integer "guestId")+ <|> Toml.dimatch matchRegistered Registered registeredUserCodec++registeredUserCodec :: TomlCodec RegisteredUser+registeredUserCodec = RegisteredUser+ <$> Toml.text "login" .= registeredUserLogin+ <*> Toml.day "createdAt" .= registeredUserCreatedAt ``` -And now we're ready to parse our TOML and print the result back to see whether+And now we are ready to parse our TOML and print the result back to see whether everything is okay. ```haskell main :: IO () main = do- tomlExample <- TIO.readFile "examples/readme.toml"- let res = Toml.decode settingsCodec tomlExample- case res of- Left err -> print err+ tomlRes <- Toml.decodeFileEither settingsCodec "examples/readme.toml"+ case tomlRes of+ Left errs -> TIO.putStrLn $ Toml.prettyTomlDecodeErrors errs Right settings -> TIO.putStrLn $ Toml.encode settingsCodec settings ``` ## Benchmarks and comparison with other libraries -`tomland` is compared with other libraries. Since it uses 2-step approach with-converting text to intermediate AST and only then decoding Haskell type from-this AST, benchmarks are also implemented in a way to reflect this difference.+You can find benchmarks of the `tomland` library in the following repository: +* [kowainik/toml-benchmarks](https://github.com/kowainik/toml-benchmarks)++Since `tomland` uses 2-step approach with converting text to+intermediate AST and only then decoding Haskell type from this AST,+benchmarks are also implemented in a way to reflect this difference.+ | Library | parse :: Text -> AST | transform :: AST -> Haskell | |--------------------|----------------------|-----------------------------| | `tomland` | `305.5 μs` | `1.280 μs` |@@ -157,21 +211,22 @@ | `htoml-megaparsec` | `295.0 μs` | `33.62 μs` | | `toml-parser` | `164.6 μs` | `1.101 μs` | -You may see that `tomland` is not the fastest one (though still very fast). But-performance hasn’t been optimized so far and:+In addition to the above numbers, `tomland` has several features that+make it unique: -1. `toml-parser` doesn’t support the array of tables and because of that it’s- hardly possible to specify the list of custom data types in TOML with this- library.-2. `tomland` supports latest TOML spec while `htoml` and `htoml-megaparsec`- don’t have support for all types, values and formats.-3. `tomland` is the only library that has pretty-printing.-4. `toml-parser` doesn’t have ways to convert TOML AST to custom Haskell types- and `htoml*` libraries use typeclasses-based approach via `aeson` library.-5. `tomland` is bidirectional :slightly_smiling_face:+1. `tomland` is the only Haskell library that has pretty-printing.+2. `tomland` is compatible with the latest TOML spec while other libraries are not.+3. `tomland` is bidirectional, which means that your encoding and+ decoding are consistent with each other by construction.+4. `tomland` provides abilities for `Generic` and `DerivingVia`+ deriving out-of-the-box.+5. Despite being the fastest, `toml-parser` doesn’t support the array+ of tables and because of that it’s hardly possible to specify the list+ of custom data types in TOML with this library. In addition,+ `toml-parser` doesn’t have ways to convert TOML AST to custom+ Haskell types and `htoml*` libraries use typeclasses-based approach+ via `aeson` library. ## Acknowledgement -Icons made by [Freepik](http://www.freepik.com) from-[www.flaticon.com](https://www.flaticon.com/) is licensed by-[CC 3.0 BY](http://creativecommons.org/licenses/by/3.0/).+Icons made by [Freepik](http://www.freepik.com) from [www.flaticon.com](https://www.flaticon.com/) is licensed by [CC 3.0 BY](http://creativecommons.org/licenses/by/3.0/).
README.md view
@@ -1,28 +1,36 @@ # tomland -[](https://travis-ci.org/kowainik/tomland)++[](https://github.com/kowainik/tomland/actions) [](https://hackage.haskell.org/package/tomland)-[](http://stackage.org/lts/package/tomland)-[](http://stackage.org/nightly/package/tomland)-[](https://github.com/kowainik/tomland/blob/master/LICENSE)+[](https://github.com/kowainik/tomland/blob/main/LICENSE) > “A library is like an island in the middle of a vast sea of ignorance, > particularly if the library is very tall and the surrounding area has been > flooded.”->+ > ― Lemony Snicket, Horseradish -Bidirectional TOML serialization. The following blog post has more details about-library design:+`tomland` is a Haskell library for _Bidirectional TOML+Serialization_. It provides the composable interface for implementing+[TOML](https://github.com/toml-lang/toml) codecs. If you want to use+TOML as a configuration for your tool or application, you can use+`tomland` to easily convert in both ways between textual TOML+representation and Haskell types. -* [`tomland`: Bidirectional TOML serialization](https://kowainik.github.io/posts/2019-01-14-tomland)+✍️ `tomland` supports [TOML spec version 0.5.0](https://github.com/toml-lang/toml/wiki#v050-compliant). +The following blog post has more details about the library design and+internal implementation details:++* [`tomland`: Bidirectional TOML Serialization](https://kowainik.github.io/posts/2019-01-14-tomland)+ This README contains a basic usage example of the `tomland` library. All code below can be compiled and run with the following command: ```-cabal new-run readme+cabal run readme ``` ## Preamble: imports and language extensions@@ -37,15 +45,15 @@ {-# LANGUAGE OverloadedStrings #-} import Control.Applicative ((<|>))-import Control.Category ((>>>)) import Data.Text (Text)-import Toml (TomlBiMap, TomlCodec, (.=))+import Data.Time (Day)+import Toml (TomlCodec, (.=)) import qualified Data.Text.IO as TIO import qualified Toml ``` -`tomland` is mostly designed for qualified imports and intended to be imported+`tomland` is designed for qualified imports and intended to be imported as follows: ```haskell ignore@@ -55,10 +63,40 @@ ## Data type: parsing and printing -We're going to parse TOML configuration from [`examples/readme.toml`](examples/readme.toml) file.+We're going to parse TOML configuration from+[`examples/readme.toml`](examples/readme.toml) file. The configuration+contains the following description of our data: -This static configuration is captured by the following Haskell data type:+```toml+server.port = 8080+server.codes = [ 5, 10, 42 ]+server.description = """+This is production server.+Don't touch it!+""" +[mail]+ host = "smtp.gmail.com"+ send-if-inactive = false++[[user]]+ guestId = 42++[[user]]+ guestId = 114++[[user]]+ login = "Foo Bar"+ createdAt = 2020-05-19+```++The above static configuration describes `Settings` for some+server. It has several top-level fields, a table with the name `mail`+and an array of tables with the name `user` that stores list of+different types of users.++We can model such TOML using the following Haskell data types:+ ```haskell data Settings = Settings { settingsPort :: !Port@@ -74,28 +112,36 @@ } data User- = Admin Integer -- id of admin- | Client Text -- name of the client- deriving (Show)+ = Guest !Integer -- id of guest+ | Registered !RegisteredUser -- login and createdAt of registered user +data RegisteredUser = RegisteredUser+ { registeredUserLogin :: !Text+ , registeredUserCreatedAt :: !Day+ }+ newtype Port = Port Int newtype Host = Host Text ``` -Using `tomland` library, you can write bidirectional converters for these types-using the following guidelines and helper functions:+Using the `tomland` library, you can write bidirectional converters for these types+with the following guidelines and helper functions: -1. If your fields are some simple basic types like `Int` or `Text` you can just+1. If your fields are some simple primitive types like `Int` or `Text` you can just use standard codecs like `Toml.int` and `Toml.text`. 2. If you want to parse `newtype`s, use `Toml.diwrap` to wrap parsers for underlying `newtype` representation.-3. For parsing nested data types, use `Toml.table`. But this requires to specify- this data type as TOML table in `.toml` file.+3. For parsing nested data types, use `Toml.table`. But it requires to specify+ this data type as TOML table in the `.toml` file. 4. If you have lists of custom data types, use `Toml.list`. Such lists are- represented as array of tables in TOML. If you have lists of primitive types+ represented as _array of tables_ in TOML. If you have lists of the primitive types like `Int`, `Bool`, `Double`, `Text` or time types, that you can use `Toml.arrayOf` and parse arrays of values.-5. `tomland` separates conversion between Haskell types and TOML values from+5. If you have sets of custom data types, use `Toml.set` or `Toml.HashSet`. Such+ sets are represented as array of tables in TOML.+6. For parsing sum types, use `Toml.dimatch`. This requires writing matching functions+ for the constructors of the sum type.+7. `tomland` separates conversion between Haskell types and TOML values from matching values by keys. Converters between types and values have type `TomlBiMap` and are named with capital letter started with underscore. Main type for TOML codecs is called `TomlCodec`. To lift `TomlBiMap` to@@ -115,41 +161,49 @@ <$> Toml.diwrap (Toml.text "host") .= mailHost <*> Toml.bool "send-if-inactive" .= mailSendIfInactive -_Admin :: TomlBiMap User Integer-_Admin = Toml.prism Admin $ \case- Admin i -> Right i- other -> Toml.wrongConstructor "Admin" other+matchGuest :: User -> Maybe Integer+matchGuest = \case+ Guest i -> Just i+ _ -> Nothing -_Client :: TomlBiMap User Text-_Client = Toml.prism Client $ \case- Client n -> Right n- other -> Toml.wrongConstructor "Client" other+matchRegistered :: User -> Maybe RegisteredUser+matchRegistered = \case+ Registered u -> Just u+ _ -> Nothing userCodec :: TomlCodec User userCodec =- Toml.match (_Admin >>> Toml._Integer) "id"- <|> Toml.match (_Client >>> Toml._Text) "name"+ Toml.dimatch matchGuest Guest (Toml.integer "guestId")+ <|> Toml.dimatch matchRegistered Registered registeredUserCodec++registeredUserCodec :: TomlCodec RegisteredUser+registeredUserCodec = RegisteredUser+ <$> Toml.text "login" .= registeredUserLogin+ <*> Toml.day "createdAt" .= registeredUserCreatedAt ``` -And now we're ready to parse our TOML and print the result back to see whether+And now we are ready to parse our TOML and print the result back to see whether everything is okay. ```haskell main :: IO () main = do- tomlExample <- TIO.readFile "examples/readme.toml"- let res = Toml.decode settingsCodec tomlExample- case res of- Left err -> print err+ tomlRes <- Toml.decodeFileEither settingsCodec "examples/readme.toml"+ case tomlRes of+ Left errs -> TIO.putStrLn $ Toml.prettyTomlDecodeErrors errs Right settings -> TIO.putStrLn $ Toml.encode settingsCodec settings ``` ## Benchmarks and comparison with other libraries -`tomland` is compared with other libraries. Since it uses 2-step approach with-converting text to intermediate AST and only then decoding Haskell type from-this AST, benchmarks are also implemented in a way to reflect this difference.+You can find benchmarks of the `tomland` library in the following repository: +* [kowainik/toml-benchmarks](https://github.com/kowainik/toml-benchmarks)++Since `tomland` uses 2-step approach with converting text to+intermediate AST and only then decoding Haskell type from this AST,+benchmarks are also implemented in a way to reflect this difference.+ | Library | parse :: Text -> AST | transform :: AST -> Haskell | |--------------------|----------------------|-----------------------------| | `tomland` | `305.5 μs` | `1.280 μs` |@@ -157,21 +211,22 @@ | `htoml-megaparsec` | `295.0 μs` | `33.62 μs` | | `toml-parser` | `164.6 μs` | `1.101 μs` | -You may see that `tomland` is not the fastest one (though still very fast). But-performance hasn’t been optimized so far and:+In addition to the above numbers, `tomland` has several features that+make it unique: -1. `toml-parser` doesn’t support the array of tables and because of that it’s- hardly possible to specify the list of custom data types in TOML with this- library.-2. `tomland` supports latest TOML spec while `htoml` and `htoml-megaparsec`- don’t have support for all types, values and formats.-3. `tomland` is the only library that has pretty-printing.-4. `toml-parser` doesn’t have ways to convert TOML AST to custom Haskell types- and `htoml*` libraries use typeclasses-based approach via `aeson` library.-5. `tomland` is bidirectional :slightly_smiling_face:+1. `tomland` is the only Haskell library that has pretty-printing.+2. `tomland` is compatible with the latest TOML spec while other libraries are not.+3. `tomland` is bidirectional, which means that your encoding and+ decoding are consistent with each other by construction.+4. `tomland` provides abilities for `Generic` and `DerivingVia`+ deriving out-of-the-box.+5. Despite being the fastest, `toml-parser` doesn’t support the array+ of tables and because of that it’s hardly possible to specify the list+ of custom data types in TOML with this library. In addition,+ `toml-parser` doesn’t have ways to convert TOML AST to custom+ Haskell types and `htoml*` libraries use typeclasses-based approach+ via `aeson` library. ## Acknowledgement -Icons made by [Freepik](http://www.freepik.com) from-[www.flaticon.com](https://www.flaticon.com/) is licensed by-[CC 3.0 BY](http://creativecommons.org/licenses/by/3.0/).+Icons made by [Freepik](http://www.freepik.com) from [www.flaticon.com](https://www.flaticon.com/) is licensed by [CC 3.0 BY](http://creativecommons.org/licenses/by/3.0/).
− benchmark/Benchmark/Htoml.hs
@@ -1,45 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}--{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE StandaloneDeriving #-}--module Benchmark.Htoml- ( decode- , parse- , convert- ) where--import Control.DeepSeq (NFData, rnf, rwhnf)-import Data.Aeson.Types (parseEither, parseJSON)-import Data.Semigroup ((<>))-import Data.Text (Text)-import GHC.Generics (Generic)-import Text.Parsec.Error (ParseError)--import "htoml" Text.Toml (parseTomlDoc)-import "htoml" Text.Toml.Types (Node (..), Table, toJSON)--import Benchmark.Type (HaskellType)----- | Decode toml file to Haskell type.-decode :: Text -> Either String HaskellType-decode txt = case parseTomlDoc "" txt of- Left err -> error $ "'htoml' parsing failed: " <> show err- Right toml -> convert toml---- | Wrapper on htoml's 'parseTomlDoc'-parse :: Text -> Either ParseError Table-parse = parseTomlDoc ""---- | Convert from already parsed toml to Haskell type.-convert :: Table -> Either String HaskellType-convert = parseEither parseJSON . toJSON--deriving instance NFData Node-deriving instance Generic Node--instance NFData ParseError where- rnf = rwhnf
− benchmark/Benchmark/HtomlMegaparsec.hs
@@ -1,43 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}--{-# LANGUAGE PackageImports #-}--module Benchmark.HtomlMegaparsec- ( decode- , parse- , convert- ) where--import Data.Aeson.Types (ToJSON, parseEither, parseJSON, toJSON)-import Data.Semigroup ((<>))-import Data.Text (Text)--import "htoml-megaparsec" Text.Toml (Node (..), Table, TomlError, parseTomlDoc)--import Benchmark.Type (HaskellType)---- | Decode toml file to Haskell type.-decode :: Text -> Either String HaskellType-decode txt = case parseTomlDoc "log" txt of- Left err -> error $ "'htoml-megaparsec' parsing failed: " <> show err- Right toml -> convert toml---- | Wrapper on htoml-megaparsec's parseTomlDoc-parse :: Text -> Either TomlError Table-parse = parseTomlDoc "log"---- | Convert from already parsed toml to Haskell type.-convert :: Table -> Either String HaskellType-convert = parseEither parseJSON . toJSON---- | 'ToJSON' instances for the 'Node' type that produce Aeson (JSON)--- in line with the TOML specification.-instance ToJSON Node where- toJSON (VTable v) = toJSON v- toJSON (VTArray v) = toJSON v- toJSON (VString v) = toJSON v- toJSON (VInteger v) = toJSON v- toJSON (VFloat v) = toJSON v- toJSON (VBoolean v) = toJSON v- toJSON (VDatetime v) = toJSON v- toJSON (VArray v) = toJSON v
− benchmark/Benchmark/TomlParser.hs
@@ -1,91 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}--{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}--module Benchmark.TomlParser- ( decode- , parse- , convert- ) where--import Control.DeepSeq (NFData, rnf, rwhnf)-import Data.Semigroup ((<>))-import Data.Text (Text)-import GHC.Generics (Generic)--import Benchmark.Type (FruitInside (..), HaskellType (..), SizeInside (..))--import qualified TOML----- | Decode toml file to Haskell type.-decode :: Text -> Either String HaskellType-decode txt = case parse txt of- Left err -> error $ "'toml-parser' parsing failed: " <> show err- Right toml -> maybe (Left "Some error during conversion") Right $ convert toml---- | Wrapper over 'TOML.parseTOML'-parse :: Text -> Either TOML.TOMLError [(Text, TOML.Value)]-parse = TOML.parseTOML---- | Convert from already parsed toml to Haskell type.-convert :: [(Text, TOML.Value)] -> Maybe HaskellType-convert toml = do- TOML.String htTitle <- lookup "title" toml- TOML.Double htAtom <- lookup "atom" toml- TOML.Bool htCash <- lookup "cash" toml-- TOML.List tomlWords <- lookup "words" toml- htWords <- mapM matchText tomlWords-- TOML.List tomlBools <- lookup "bool" toml- htBool <- mapM matchBool tomlBools-- TOML.ZonedTimeV htToday <- lookup "today" toml-- TOML.List tomlInts <- lookup "ints" toml- htInteger <- mapM matchInteger tomlInts-- TOML.Table fruit <- lookup "fruit" toml- htFruit <- do- TOML.String fiName <- lookup "name" fruit- TOML.String fiDescription <- lookup "description" fruit- pure FruitInside{..}-- TOML.Table size <- lookup "size" toml- htSize <- do- TOML.List dimensions <- lookup "dimensions" size- arrays :: [[TOML.Value]] <- mapM matchArray dimensions- unSize <- mapM (mapM matchDouble) arrays- pure SizeInside{..}-- pure HaskellType{..}--matchText :: TOML.Value -> Maybe Text-matchText (TOML.String t) = Just t-matchText _ = Nothing--matchBool :: TOML.Value -> Maybe Bool-matchBool (TOML.Bool b) = Just b-matchBool _ = Nothing--matchInteger :: TOML.Value -> Maybe Integer-matchInteger (TOML.Integer i) = Just i-matchInteger _ = Nothing--matchArray :: TOML.Value -> Maybe [TOML.Value]-matchArray (TOML.List a) = Just a-matchArray _ = Nothing--matchDouble :: TOML.Value -> Maybe Double-matchDouble (TOML.Double d) = Just d-matchDouble _ = Nothing--deriving instance Generic TOML.Value-deriving instance NFData TOML.Value--instance NFData TOML.TOMLError where- rnf = rwhnf
− benchmark/Benchmark/Tomland.hs
@@ -1,39 +0,0 @@-module Benchmark.Tomland- ( decode- , parse- , convert- ) where--import Data.Text (Text)--import Benchmark.Type (FruitInside (..), HaskellType (..), SizeInside (..))-import Toml (DecodeException, TOML, TomlCodec, parse, (.=))--import qualified Toml--decode :: Text -> Either DecodeException HaskellType-decode = Toml.decode codec--convert :: TOML -> Either DecodeException HaskellType-convert = Toml.runTomlCodec codec---- | Codec to use in tomland decode and convert functions.-codec :: TomlCodec HaskellType-codec = HaskellType- <$> Toml.text "title" .= htTitle- <*> Toml.double "atom" .= htAtom- <*> Toml.bool "cash" .= htCash- <*> Toml.arrayOf Toml._Text "words" .= htWords- <*> Toml.arrayOf Toml._Bool "bool" .= htBool- <*> Toml.zonedTime "today" .= htToday- <*> Toml.arrayOf Toml._Integer "ints" .= htInteger- <*> Toml.table insideF "fruit" .= htFruit- <*> Toml.table insideS "size" .= htSize--insideF :: TomlCodec FruitInside-insideF = FruitInside- <$> Toml.text "name" .= fiName- <*> Toml.text "description" .= fiDescription--insideS :: TomlCodec SizeInside-insideS = Toml.diwrap $ Toml.arrayOf (Toml._Array Toml._Double) "dimensions"
− benchmark/Benchmark/Type.hs
@@ -1,57 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}--module Benchmark.Type- ( HaskellType (..)- , FruitInside (..)- , SizeInside (..)- ) where--import Control.DeepSeq (NFData)-import Data.Aeson.Types (FromJSON, parseJSON, withObject, (.:))-import Data.Text (Text)-import Data.Time (ZonedTime)-import GHC.Generics (Generic)----- | Haskell type to convert to.-data HaskellType = HaskellType- { htTitle :: Text- , htAtom :: Double- , htCash :: Bool- , htWords :: [Text]- , htBool :: [Bool]- , htToday :: ZonedTime- , htInteger :: [Integer]- , htFruit :: FruitInside- , htSize :: SizeInside- } deriving (Show, NFData, Generic)--instance FromJSON HaskellType where- parseJSON = withObject "HaskellType" $ \o -> HaskellType- <$> o .: "title"- <*> o .: "atom"- <*> o .: "cash"- <*> o .: "words"- <*> o .: "bool"- <*> o .: "today"- <*> o .: "ints"- <*> o .: "fruit"- <*> o .: "size"--data FruitInside = FruitInside- { fiName :: Text- , fiDescription :: Text- } deriving (Show, NFData, Generic)--instance FromJSON FruitInside where- parseJSON = withObject "FruitInside" $ \o -> FruitInside- <$> o .: "name"- <*> o .: "description"--newtype SizeInside = SizeInside- { unSize :: [[Double]]- } deriving (Show, NFData, Generic)--instance FromJSON SizeInside where- parseJSON = withObject "SizeInside" $ \o -> SizeInside <$> o .: "dimensions"
− benchmark/Main.hs
@@ -1,41 +0,0 @@-module Main- ( main- ) where--import Gauge.Main (bench, bgroup, defaultMain, nf)--import qualified Benchmark.Htoml as Htoml-import qualified Benchmark.HtomlMegaparsec as HtomlM-import qualified Benchmark.Tomland as Tomland-import qualified Benchmark.TomlParser as TomlParser-import qualified Data.Text.IO as TIO----- | Benchmark.-main :: IO ()-main = do- txt <- TIO.readFile "./benchmark/benchmark.toml"- Right tomlandVal <- pure $ Tomland.parse txt- Right htomlVal <- pure $ Htoml.parse txt- Right htomlMegaVal <- pure $ HtomlM.parse txt- Right tomlParserVal <- pure $ TomlParser.parse txt- defaultMain- [ bgroup "Parse"- [ bench "tomland" $ nf Tomland.parse txt- , bench "htoml" $ nf Htoml.parse txt- , bench "htoml-megaparsec" $ nf HtomlM.parse txt- , bench "toml-parser" $ nf TomlParser.parse txt- ]- , bgroup "Convert"- [ bench "tomland" $ nf Tomland.convert tomlandVal- , bench "htoml" $ nf Htoml.convert htomlVal- , bench "htoml-megaparsec" $ nf HtomlM.convert htomlMegaVal- , bench "toml-parser" $ nf TomlParser.convert tomlParserVal- ]- , bgroup "Decode"- [ bench "tomland" $ nf Tomland.decode txt- , bench "htoml" $ nf Htoml.decode txt- , bench "htoml-megaparsec" $ nf HtomlM.decode txt- , bench "toml-parser" $ nf TomlParser.decode txt- ]- ]
+ examples/Main.hs view
@@ -0,0 +1,259 @@+{-# OPTIONS -Wno-unused-top-binds #-}++{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingVia #-}++module Main (main) where++import Control.Applicative ((<|>))+import Control.Arrow ((>>>))+import Data.ByteString (ByteString)+import Data.HashSet (HashSet)+import Data.Hashable (Hashable)+import Data.IntSet (IntSet)+import Data.List.NonEmpty (NonEmpty)+import Data.Map.Strict (Map)+import Data.Set (Set)+import Data.Text (Text)+import Data.Time (fromGregorian)+import GHC.Generics (Generic)++import Toml (TomlCodec, TomlParseError (..), pretty, (.=), (<!>))+import Toml.Codec.Generic (ByteStringAsBytes (..), HasCodec (..), TomlTableStrip (..),+ stripTypeNameCodec)+import Toml.Type (TOML (..), Value (..))+import Toml.Type.Edsl (mkToml, table, (=:))++import qualified Data.Text.IO as TIO++import qualified Toml+++newtype TestInside = TestInside { unInside :: Text }++insideCodec :: TomlCodec TestInside+insideCodec = Toml.dimap unInside TestInside $ Toml.text "inside"++data User = User+ { userName :: !Text+ , userAge :: !Int+ } deriving stock (Eq, Ord, Generic)+ deriving anyclass (Hashable)++userCodec :: TomlCodec User+userCodec = User+ <$> Toml.text "name" .= userName+ <*> Toml.int "age" .= userAge++newtype N = N+ { unN :: Text+ }++data ColorScheme+ = Light+ | Dark+ | HighContrast+ deriving stock (Show, Read, Enum, Bounded)++data UserStatus+ = Registered Text Text+ | Anonymous Text++matchRegistered :: UserStatus -> Maybe (Text, Text)+matchRegistered (Registered username password) = Just (username, password)+matchRegistered _ = Nothing++matchAnonymous :: UserStatus -> Maybe Text+matchAnonymous (Anonymous username) = Just username+matchAnonymous _ = Nothing++userPassCodec :: TomlCodec (Text, Text)+userPassCodec = Toml.pair+ (Toml.text "username")+ (Toml.text "password")++userStatusCodec :: TomlCodec UserStatus+userStatusCodec =+ Toml.dimatch matchRegistered (uncurry Registered) (Toml.table userPassCodec "testStatus")+ <|> Toml.dimatch matchAnonymous Anonymous (Toml.text "testStatus")++data Colour+ = Hex Text+ | RGB Rgb++matchHex :: Colour -> Maybe Text+matchHex = \case+ Hex t -> Just t+ _ -> Nothing++matchRgb :: Colour -> Maybe Rgb+matchRgb = \case+ RGB rgb -> Just rgb+ _ -> Nothing++colourCodec :: Toml.Key -> TomlCodec Colour+colourCodec key =+ Toml.dimatch matchHex Hex (Toml.text key)+ <|> Toml.dimatch matchRgb RGB (Toml.table rgbCodec key)++data Rgb = Rgb+ { rgbRed :: Int+ , rgbGreen :: Int+ , rgbBlue :: Int+ }++rgbCodec :: TomlCodec Rgb+rgbCodec = Rgb+ <$> Toml.int "red" .= rgbRed+ <*> Toml.int "green" .= rgbGreen+ <*> Toml.int "blue" .= rgbBlue++newtype Inner = Inner+ { val :: Text+ } deriving stock (Show)++innerCodec :: TomlCodec Inner+innerCodec = Inner <$> Toml.text "val" .= val++newtype MapWithList = MapWithList+ { mapList :: Map Text [Inner]+ } deriving stock (Show)++mapWithListCodec :: TomlCodec MapWithList+mapWithListCodec = MapWithList+ <$> Toml.tableMap Toml._KeyText (Toml.list innerCodec) "mapList" .= mapList++data Test = Test+ { testB :: !Bool+ , testI :: !Int+ , testF :: !Double+ , testS :: !Text+ , testA :: ![Text]+ , testNE :: !(NonEmpty Text)+ , testNET :: !(NonEmpty Int)+ , testM :: !(Maybe Bool)+ , testX :: !TestInside+ , testY :: !(Maybe TestInside)+ , testEven :: !Int+ , testN :: !N+ , testC :: !ColorScheme+ , testPair :: !(Int, Text)+ , testTriple :: !(Int, Text, Bool)+ , testE1 :: !(Either Integer String)+ , testE2 :: !(Either String Double)+ , testStatus :: !UserStatus+ , users :: ![User]+ , susers :: !(Set User)+ , husers :: !(HashSet User)+ , intset :: !IntSet+ , payloads :: !(Map Text Int)+ , colours :: !(Map Text Colour)+ , tableList :: !MapWithList+ , testHardcoded :: !Text+ }+++testT :: TomlCodec Test+testT = Test+ <$> Toml.bool "testB" .= testB+ <*> Toml.int "testI" .= testI+ <*> Toml.double "testF" .= testF+ <*> Toml.text "testS" .= testS+ <*> Toml.arrayOf Toml._Text "testA" .= testA+ <*> Toml.arrayNonEmptyOf Toml._Text "testNE" .= testNE+ <*> Toml.nonEmpty (Toml.int "a") "testNET" .= testNET+ <*> Toml.dioptional (Toml.bool "testM") .= testM+ <*> Toml.table insideCodec "testX" .= testX+ <*> Toml.dioptional (Toml.table insideCodec "testY") .= testY+ <*> Toml.validateIf even Toml._Int "testEven" .= testEven+ <*> Toml.diwrap (Toml.text "testN") .= testN+ <*> Toml.enumBounded "testC" .= testC+ <*> Toml.table pairC "testPair" .= testPair+ <*> Toml.table tripleC "testTriple" .= testTriple+ <*> eitherT1 .= testE1+ <*> eitherT2 .= testE2+ <*> userStatusCodec .= testStatus+ <*> Toml.list userCodec "user" .= users+ <*> Toml.set userCodec "suser" .= susers+ <*> Toml.hashSet userCodec "huser" .= husers+ <*> Toml.arrayIntSet "intset" .= intset+ <*> Toml.map (Toml.text "name") (Toml.int "payload") "payloads" .= payloads+ <*> Toml.tableMap Toml._KeyText colourCodec "colours" .= colours+ <*> mapWithListCodec .= tableList+ <*> Toml.hardcoded "abc" Toml._Text "testHardcoded" .= testHardcoded+ where+ pairC :: TomlCodec (Int, Text)+ pairC = Toml.pair (Toml.int "pNum") (Toml.text "pName")++ tripleC :: TomlCodec (Int, Text, Bool)+ tripleC = Toml.triple (Toml.int "tNum") (Toml.text "tName") (Toml.bool "isFav")++ -- different keys for sum type+ eitherT1 :: TomlCodec (Either Integer String)+ eitherT1 = Toml.match (Toml._Left >>> Toml._Integer) "either.Left"+ <|> Toml.match (Toml._Right >>> Toml._String) "either.Right"++ -- same key for sum type;+ -- doesn't work if you have something like `Either String String`,+ -- you should distinguish these cases by different keys like in `eitherT1` example+ eitherT2 :: TomlCodec (Either String Double)+ eitherT2 = ( Toml.match (Toml._Left >>> Toml._String)+ <!> Toml.match (Toml._Right >>> Toml._Double)+ ) "either"++data GenericPerson = GenericPerson+ { genericPersonName :: !Text+ , genericPersonAddress :: !Address+ } deriving stock (Generic)++data Address = Address+ { addressStreet :: !Text+ , addressHouse :: !Int+ } deriving stock (Generic)+ deriving HasCodec via (TomlTableStrip Address)++testGeneric :: TomlCodec GenericPerson+testGeneric = stripTypeNameCodec++newtype MyByteString = MyByteString+ { unMyByteString :: ByteString+ } deriving HasCodec via ByteStringAsBytes++main :: IO ()+main = do+ TIO.putStrLn "=== Printing manually specified TOML ==="+ TIO.putStrLn $ pretty myToml++ TIO.putStrLn "=== Trying to print invalid TOML ==="+ content <- TIO.readFile "examples/invalid.toml"+ TIO.putStrLn $ case Toml.parse content of+ Left (TomlParseError e) -> e+ Right toml -> pretty toml++ TIO.putStrLn "=== Testing bidirectional conversion ==="+ biFile <- TIO.readFile "examples/biTest.toml"+ TIO.putStrLn $ case Toml.decode testT biFile of+ Left msgs -> Toml.prettyTomlDecodeErrors msgs+ Right test -> Toml.encode testT test++ TIO.putStrLn "=== Testing Deriving Via ==="+ genericFile <- TIO.readFile "examples/generic.toml"+ TIO.putStrLn $ case Toml.decode testGeneric genericFile of+ Left msg -> Toml.prettyTomlDecodeErrors msg+ Right test -> Toml.encode testGeneric test++myToml :: TOML+myToml = mkToml $ do+ "a" =: Bool True+ "list" =: Array ["one", "two"]+ "time" =: Array [Day (fromGregorian 2018 3 29)]+ table "table.name.1" $ do+ "aInner" =: 1+ "listInner" =: Array [Bool True, Bool False]+ table "1" $ do+ "aInner11" =: 11+ "listInner11" =: Array [0, 1]+ table "2" $+ "Inner12" =: "12"+ table "table.name.2" $+ "Inner2" =: 42
− examples/Playground.hs
@@ -1,116 +0,0 @@-{-# OPTIONS -Wno-unused-top-binds #-}--module Main (main) where--import Control.Applicative ((<|>))-import Control.Arrow ((>>>))-import Data.Text (Text)-import Data.Time (fromGregorian)--import Toml (ParseException (..), TomlCodec, pretty, (.=), (<!>))-import Toml.Edsl (mkToml, table, (=:))-import Toml.Type (TOML (..), Value (..))--import qualified Data.Text.IO as TIO-import qualified Toml--newtype TestInside = TestInside { unInside :: Text }--insideCodec :: TomlCodec TestInside-insideCodec = Toml.dimap unInside TestInside $ Toml.text "inside"--data User = User- { userName :: Text- , userAge :: Int- }--userCodec :: TomlCodec User-userCodec = User- <$> Toml.text "name" .= userName- <*> Toml.int "age" .= userAge--newtype N = N Text--data ColorScheme = Light- | Dark- | HighContrast- deriving (Show, Enum, Bounded)--data Test = Test- { testB :: Bool- , testI :: Int- , testF :: Double- , testS :: Text- , testA :: [Text]- , testM :: Maybe Bool- , testX :: TestInside- , testY :: Maybe TestInside- , testN :: N- , testC :: ColorScheme- , testE1 :: Either Integer String- , testE2 :: Either String Double- , users :: [User]- }---testT :: TomlCodec Test-testT = Test- <$> Toml.bool "testB" .= testB- <*> Toml.int "testI" .= testI- <*> Toml.double "testF" .= testF- <*> Toml.text "testS" .= testS- <*> Toml.arrayOf Toml._Text "testA" .= testA- <*> Toml.dioptional (Toml.bool "testM") .= testM- <*> Toml.table insideCodec "testX" .= testX- <*> Toml.dioptional ((Toml.table insideCodec) "testY") .= testY- <*> Toml.diwrap (Toml.text "testN") .= testN- <*> Toml.enumBounded "testC" .= testC- <*> eitherT1 .= testE1- <*> eitherT2 .= testE2- <*> Toml.list userCodec "user" .= users- where- -- different keys for sum type- eitherT1 :: TomlCodec (Either Integer String)- eitherT1 = Toml.match (Toml._Left >>> Toml._Integer) "either.Left"- <|> Toml.match (Toml._Right >>> Toml._String) "either.Right"-- -- same key for sum type;- -- doesn't work if you have something like `Either String String`,- -- you should distinguish these cases by different keys like in `eitherT1` example- eitherT2 :: TomlCodec (Either String Double)- eitherT2 = ( Toml.match (Toml._Left >>> Toml._String)- <!> Toml.match (Toml._Right >>> Toml._Double)- ) "either"--main :: IO ()-main = do- TIO.putStrLn "=== Printing manually specified TOML ==="- TIO.putStrLn $ pretty myToml-- TIO.putStrLn "=== Trying to print invalid TOML ==="- content <- TIO.readFile "examples/invalid.toml"- TIO.putStrLn $ case Toml.parse content of- Left (ParseException e) -> e- Right toml -> pretty toml-- TIO.putStrLn "=== Testing bidirectional conversion ==="- biFile <- TIO.readFile "examples/biTest.toml"- TIO.putStrLn $ case Toml.decode testT biFile of- Left msg -> Toml.prettyException msg- Right test -> Toml.encode testT test--myToml :: TOML-myToml = mkToml $ do- "a" =: Bool True- "list" =: Array ["one", "two"]- "time" =: Array [Day (fromGregorian 2018 3 29)]- table "table.name.1" $ do- "aInner" =: 1- "listInner" =: Array [Bool True, Bool False]- table "1" $ do- "aInner11" =: 11- "listInner11" =: Array [0, 1]- table "2" $- "Inner12" =: "12"- table "table.name.2" $- "Inner2" =: 42
src/Toml.hs view
@@ -1,12 +1,21 @@-{- | This module reexports all functionality of @tomland@ package. It's+{- |+Module : Toml+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++This module reexports all functionality of the @tomland@ package. It's recommended to import this module qualified, like this: @-__import__ Toml (TomlCodec, (.=))-__import__ __qualified__ Toml+__import__ "Toml" ('TomlCodec', '(.=)')+__import__ __qualified__ "Toml" @ -Simple @'TomlCodec'@ could be written in the following way:+Simple @'TomlCodec'@ for a Haskell value, that can be decoded from+TOML or encoded as TOML, could be written in the following way: @ __data__ User = User@@ -20,28 +29,51 @@ \<*\> Toml.'int' "age" '.=' userAge @ +A value of such type will look in TOML like this:++@+name = "Alice"+age = 27+@+ For more detailed examples see README.md in the repository: * [tomland/README.md](https://github.com/kowainik/tomland#tomland) For the details of the library implementation see blog post: - * [tomland: Bidirectional TOML serialization](https://kowainik.github.io/posts/2019-01-14-tomland) -} module Toml- ( module Toml.Bi- , module Toml.Generic- , module Toml.Parser- , module Toml.PrefixTree- , module Toml.Printer+ ( -- $codec+ module Toml.Codec+ -- $type , module Toml.Type+ -- $parser+ , module Toml.Parser ) where -import Toml.Bi-import Toml.Generic+import Toml.Codec import Toml.Parser-import Toml.PrefixTree-import Toml.Printer import Toml.Type++{- $codec+Main types and functions to implement TOML codecs. This module+provides high-level API of @tomland@ library.+-}++{- $type+Low-level implementation details of types that power @tomland@. The+"Toml.Type" module contains types to represent TOML AST and basic+functions to work with it. This module also contains pretty-printing+API for 'TOML' AST and eDSL for type-safe definition of the TOML+values.+-}++{- $parser+Parser for types, defined in "Toml.Type". This modules contains+low-level functions to parse 'TOML' from text. If you want to convert+between Haskell types and TOML representation, use functions from+"Toml.Codec".+-}
− src/Toml/Bi.hs
@@ -1,22 +0,0 @@-{- | Reexports functions under @Toml.Bi.*@.--* __"Toml.Bi.Map"__: contains implementation of tagged bidirectional- isomorphisms.-* __"Toml.Bi.Monad"__: core abstraction for bidirectional conversion based on- profunctor monads.-* __"Toml.Bi.Combinators"__: TOML specific combinators based on 'Codec' type- from "Toml.Bi.Monad".-* __"Toml.Bi.Code"__: conversion functions like 'decode' and 'encode'.--}--module Toml.Bi- ( module Toml.Bi.Code- , module Toml.Bi.Combinators- , module Toml.Bi.Map- , module Toml.Bi.Monad- ) where--import Toml.Bi.Code-import Toml.Bi.Combinators-import Toml.Bi.Map-import Toml.Bi.Monad
− src/Toml/Bi/Code.hs
@@ -1,137 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}--{- | Coding functions like 'decode' and 'encode'. Also contains specialization of 'Codec' for TOML.--}--module Toml.Bi.Code- ( -- * Types- TomlCodec- , Env- , St-- -- * Exceptions- , DecodeException (..)- , LoadTomlException (..)- , prettyException-- -- * Encode/Decode- , decode- , decodeFile- , runTomlCodec- , encode- , execTomlCodec- ) where--import Control.DeepSeq (NFData)-import Control.Exception (Exception, throwIO)-import Control.Monad.Except (ExceptT, runExceptT)-import Control.Monad.IO.Class (MonadIO (..))-import Control.Monad.Reader (Reader, runReader)-import Control.Monad.State (State, execState)-import Control.Monad.Trans.Maybe (MaybeT (..))-import Data.Bifunctor (first)-import Data.Foldable (toList)-import Data.Semigroup (Semigroup (..))-import Data.Text (Text)-import GHC.Generics (Generic)--import Toml.Bi.Map (TomlBiMapError, prettyBiMapError)-import Toml.Bi.Monad (BiCodec, Codec (..))-import Toml.Parser (ParseException (..), parse)-import Toml.PrefixTree (Key (..), unPiece)-import Toml.Printer (pretty)-import Toml.Type (TOML (..), TValue, showType)--import qualified Data.Text as Text-import qualified Data.Text.IO as TIO---- | Type of exception for converting from TOML to user custom data type.-data DecodeException- = TrivialError- | BiMapError TomlBiMapError- | KeyNotFound Key -- ^ No such key- | TableNotFound Key -- ^ No such table- | TypeMismatch Key Text TValue -- ^ Expected type vs actual type- | ParseError ParseException -- ^ Exception during parsing- deriving (Eq, Generic, NFData)--instance Show DecodeException where- show = Text.unpack . prettyException--instance Semigroup DecodeException where- TrivialError <> e = e- e <> _ = e--instance Monoid DecodeException where- mempty = TrivialError- mappend = (<>)---- | Converts 'DecodeException' into pretty human-readable text.-prettyException :: DecodeException -> Text-prettyException de = "tomland decode error: " <> case de of- TrivialError -> "'empty' parser from 'Alternative' is used"- BiMapError biError -> prettyBiMapError biError- KeyNotFound name -> "Key " <> joinKey name <> " is not found"- TableNotFound name -> "Table [" <> joinKey name <> "] is not found"- TypeMismatch name expected actual -> "Type for key " <> joinKey name <> " doesn't match."- <> "\n Expected: " <> expected- <> "\n Actual: " <> Text.pack (showType actual)- ParseError (ParseException msg) -> "Parse error during conversion from TOML to custom user type: \n " <> msg- where- joinKey :: Key -> Text- joinKey = Text.intercalate "." . map unPiece . toList . unKey---- | Immutable environment for TOML conversion.--- This is @r@ type variable in 'Codec' data type.-type Env = ExceptT DecodeException (Reader TOML)--{- | Mutable context for TOML conversion.-This is @w@ type variable in 'Codec' data type.--@-MaybeT (State TOML) a- = State TOML (Maybe a)- = TOML -> (Maybe a, TOML)-@--}-type St = MaybeT (State TOML)--{- | Specialied 'BiCodec' type alias for bidirectional TOML serialization. Keeps-'TOML' object as both environment and state.--}-type TomlCodec a = BiCodec Env St a---- | Convert textual representation of toml into user data type.-decode :: TomlCodec a -> Text -> Either DecodeException a-decode codec text = do- toml <- first ParseError (parse text)- runTomlCodec codec toml---- | Convert toml into user data type.-runTomlCodec :: TomlCodec a -> TOML -> Either DecodeException a-runTomlCodec codec = runReader (runExceptT $ codecRead codec)---- | Convert object to textual representation.-encode :: TomlCodec a -> a -> Text-encode codec obj = pretty $ execTomlCodec codec obj---- | Runs 'codecWrite' of 'TomlCodec' and returns intermediate TOML AST.-execTomlCodec :: TomlCodec a -> a -> TOML-execTomlCodec codec obj = execState (runMaybeT $ codecWrite codec obj) mempty---- | File loading error data type.-data LoadTomlException = LoadTomlException FilePath Text--instance Show LoadTomlException where- show (LoadTomlException filePath msg) = "Couldnt parse file " ++ filePath ++ ": " ++ show msg--instance Exception LoadTomlException---- | Decode a value from a file. In case of parse errors, throws 'LoadTomlException'.-decodeFile :: (MonadIO m) => TomlCodec a -> FilePath -> m a-decodeFile codec filePath = liftIO $- (decode codec <$> TIO.readFile filePath) >>= errorWhenLeft- where- errorWhenLeft :: Either DecodeException a -> IO a- errorWhenLeft (Left e) = throwIO $ LoadTomlException filePath $ prettyException e- errorWhenLeft (Right pc) = pure pc
− src/Toml/Bi/Combinators.hs
@@ -1,300 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}---- | Contains TOML-specific combinators for converting between TOML and user data types.--module Toml.Bi.Combinators- ( -- * Basic codecs for primitive values- -- ** Boolean- bool- -- ** Integral numbers- , integer- , natural- , int- , word- -- ** Floating point numbers- , double- , float- -- ** Text types- , text- , lazyText- , byteString- , lazyByteString- , string- -- ** Time types- , zonedTime- , localTime- , day- , timeOfDay-- -- * Codecs for containers of primitives- , arrayOf- , arraySetOf- , arrayIntSet- , arrayHashSetOf- , arrayNonEmptyOf-- -- * Additional codecs for custom types- , textBy- , read- , enumBounded-- -- * Combinators for tables- , table- , nonEmpty- , list-- -- * General construction of codecs- , match- ) where--import Prelude hiding (read)--import Control.Monad (forM)-import Control.Monad.Except (catchError, throwError)-import Control.Monad.Reader (asks, local)-import Control.Monad.State (execState, gets, modify)-import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)-import Data.ByteString (ByteString)-import Data.Hashable (Hashable)-import Data.HashSet (HashSet)-import Data.IntSet (IntSet)-import Data.List.NonEmpty (NonEmpty (..), toList)-import Data.Maybe (fromMaybe)-import Data.Semigroup ((<>))-import Data.Set (Set)-import Data.Text (Text)-import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime)-import Data.Word (Word)-import Numeric.Natural (Natural)--import Toml.Bi.Code (DecodeException (..), Env, St, TomlCodec, execTomlCodec)-import Toml.Bi.Map (BiMap (..), TomlBiMap, _Array, _Bool, _ByteString, _Day, _Double, _EnumBounded,- _Float, _HashSet, _Int, _IntSet, _Integer, _LByteString, _LText, _LocalTime,- _Natural, _NonEmpty, _Read, _Set, _String, _Text, _TextBy, _TimeOfDay, _Word,- _ZonedTime)-import Toml.Bi.Monad (Codec (..))-import Toml.PrefixTree (Key)-import Toml.Type (AnyValue (..), TOML (..), insertKeyAnyVal, insertTable, insertTableArrays)--import qualified Data.ByteString.Lazy as BL-import qualified Data.HashMap.Strict as HashMap-import qualified Data.Text.Lazy as L-import qualified Toml.PrefixTree as Prefix---{- | General function to create bidirectional converters for key-value pairs. In-order to use this function you need to create 'TomlBiMap' for your type and-'AnyValue':--@-_MyType :: 'TomlBiMap' MyType 'AnyValue'-@--And then you can create codec for your type using 'match' function:--@-myType :: 'Key' -> 'TomlCodec' MyType-myType = 'match' _MyType-@--}-match :: forall a . TomlBiMap a AnyValue -> Key -> TomlCodec a-match BiMap{..} key = Codec input output- where- input :: Env a- input = do- mVal <- asks $ HashMap.lookup key . tomlPairs- case mVal of- Nothing -> throwError $ KeyNotFound key- Just anyVal -> case backward anyVal of- Right v -> pure v- Left err -> throwError $ BiMapError err-- output :: a -> St a- output a = do- anyVal <- MaybeT $ pure $ either (const Nothing) Just $ forward a- a <$ modify (insertKeyAnyVal key anyVal)---- | Codec for boolean values.-bool :: Key -> TomlCodec Bool-bool = match _Bool---- | Codec for integer values.-integer :: Key -> TomlCodec Integer-integer = match _Integer---- | Codec for integer values.-int :: Key -> TomlCodec Int-int = match _Int---- | Codec for natural values.-natural :: Key -> TomlCodec Natural-natural = match _Natural---- | Codec for word values.-word :: Key -> TomlCodec Word-word = match _Word---- | Codec for floating point values with double precision.-double :: Key -> TomlCodec Double-double = match _Double---- | Codec for floating point values.-float :: Key -> TomlCodec Float-float = match _Float---- | Codec for text values.-text :: Key -> TomlCodec Text-text = match _Text---- | Codec for lazy text values.-lazyText :: Key -> TomlCodec L.Text-lazyText = match _LText---- | Codec for text values with custom error messages for parsing.-textBy :: (a -> Text) -> (Text -> Either Text a) -> Key -> TomlCodec a-textBy to from = match (_TextBy to from)---- | Codec for string values.-string :: Key -> TomlCodec String-string = match _String---- | Codec for values with a 'Read' and 'Show' instance.-read :: (Show a, Read a) => Key -> TomlCodec a-read = match _Read--{- | Codec for general nullary sum data types with a 'Bounded', 'Enum', and-'Show' instance. This codec provides much better error messages than 'read' for-nullary sum types.--@since 1.1.1.0--}-enumBounded :: (Bounded a, Enum a, Show a) => Key -> TomlCodec a-enumBounded = match _EnumBounded---- | Codec for text values as 'ByteString'.-byteString :: Key -> TomlCodec ByteString-byteString = match _ByteString---- | Codec for text values as 'BL.ByteString'.-lazyByteString :: Key -> TomlCodec BL.ByteString-lazyByteString = match _LByteString---- | Codec for zoned time values.-zonedTime :: Key -> TomlCodec ZonedTime-zonedTime = match _ZonedTime---- | Codec for local time values.-localTime :: Key -> TomlCodec LocalTime-localTime = match _LocalTime---- | Codec for day values.-day :: Key -> TomlCodec Day-day = match _Day---- | Codec for time of day values.-timeOfDay :: Key -> TomlCodec TimeOfDay-timeOfDay = match _TimeOfDay---- | Codec for list of values. Takes converter for single value and--- returns a list of values.-arrayOf :: TomlBiMap a AnyValue -> Key -> TomlCodec [a]-arrayOf = match . _Array---- | Codec for sets. Takes converter for single value and--- returns a set of values.-arraySetOf :: Ord a => TomlBiMap a AnyValue -> Key -> TomlCodec (Set a)-arraySetOf = match . _Set---- | Codec for sets of ints. Takes converter for single value and--- returns a set of ints.-arrayIntSet :: Key -> TomlCodec IntSet-arrayIntSet = match _IntSet---- | Codec for hash sets. Takes converter for single hashable value and--- returns a set of hashable values.-arrayHashSetOf- :: (Hashable a, Eq a)- => TomlBiMap a AnyValue- -> Key- -> TomlCodec (HashSet a)-arrayHashSetOf = match . _HashSet---- | Codec for non- empty lists of values. Takes converter for single value and--- returns a non-empty list of values.-arrayNonEmptyOf :: TomlBiMap a AnyValue -> Key -> TomlCodec (NonEmpty a)-arrayNonEmptyOf = match . _NonEmpty--{- | Prepends given key to all errors that contain key. This function is used to-give better error messages. So when error happens we know all pieces of table-key, not only the last one.--}-handleErrorInTable :: Key -> DecodeException -> Env a-handleErrorInTable key = \case- KeyNotFound name -> throwError $ KeyNotFound (key <> name)- TableNotFound name -> throwError $ TableNotFound (key <> name)- TypeMismatch name t1 t2 -> throwError $ TypeMismatch (key <> name) t1 t2- e -> throwError e---- | Run 'codecRead' function with given 'TOML' inside 'Control.Monad.Reader.ReaderT' context.-codecReadTOML :: TOML -> TomlCodec a -> Env a-codecReadTOML toml codec = local (const toml) (codecRead codec)---- | Codec for tables. Use it when when you have nested objects.-table :: forall a . TomlCodec a -> Key -> TomlCodec a-table codec key = Codec input output- where- input :: Env a- input = do- mTable <- asks $ Prefix.lookup key . tomlTables- case mTable of- Nothing -> throwError $ TableNotFound key- Just toml -> codecReadTOML toml codec `catchError` handleErrorInTable key-- output :: a -> St a- output a = do- mTable <- gets $ Prefix.lookup key . tomlTables- let toml = fromMaybe mempty mTable- let newToml = execState (runMaybeT $ codecWrite codec a) toml- a <$ modify (insertTable key newToml)--{- | 'Codec' for 'NonEmpty' list of values. Represented in TOML as array of-tables.--}-nonEmpty :: forall a . TomlCodec a -> Key -> TomlCodec (NonEmpty a)-nonEmpty codec key = Codec input output- where- input :: Env (NonEmpty a)- input = do- mTables <- asks $ HashMap.lookup key . tomlTableArrays- case mTables of- Nothing -> throwError $ TableNotFound key- Just tomls -> forM tomls $ \toml ->- codecReadTOML toml codec `catchError` handleErrorInTable key-- -- adds all TOML objects to the existing list if there are some- output :: NonEmpty a -> St (NonEmpty a)- output as = do- let tomls = fmap (execTomlCodec codec) as- mTables <- gets $ HashMap.lookup key . tomlTableArrays-- let newTomls = case mTables of- Nothing -> tomls- Just oldTomls -> oldTomls <> tomls-- as <$ modify (insertTableArrays key newTomls)---- | 'Codec' for list of values. Represented in TOML as array of tables.-list :: forall a . TomlCodec a -> Key -> TomlCodec [a]-list codec key = Codec- { codecRead = (toList <$> codecRead nonEmptyCodec) `catchError` \case- TableNotFound errKey | errKey == key -> pure []- err -> throwError err- , codecWrite = \case- [] -> pure []- l@(x:xs) -> l <$ codecWrite nonEmptyCodec (x :| xs)- }- where- nonEmptyCodec :: TomlCodec (NonEmpty a)- nonEmptyCodec = nonEmpty codec key
− src/Toml/Bi/Map.hs
@@ -1,504 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeFamilies #-}--{- | Implementation of tagged partial bidirectional isomorphism.--}--module Toml.Bi.Map- ( -- * BiMap idea- BiMap (..)- , TomlBiMap- , invert- , iso- , prism-- -- * 'BiMap' errors for TOML- , TomlBiMapError (..)- , wrongConstructor- , prettyBiMapError-- -- * Helpers for BiMap and AnyValue- , mkAnyValueBiMap- , _TextBy- , _LTextText- , _NaturalInteger- , _StringText- , _ReadString- , _BoundedInteger- , _EnumBoundedText- , _ByteStringText- , _LByteStringText-- -- * Some predefined bi mappings- , _Array- , _Bool- , _Double- , _Integer- , _Text- , _LText- , _ZonedTime- , _LocalTime- , _Day- , _TimeOfDay- , _String- , _Read- , _Natural- , _Word- , _Int- , _Float- , _ByteString- , _LByteString- , _Set- , _IntSet- , _HashSet- , _NonEmpty-- , _Left- , _Right- , _EnumBounded- , _Just-- -- * Useful utility functions- , toMArray- ) where--import Control.Arrow ((>>>))-import Control.DeepSeq (NFData)-import Control.Monad ((>=>))-import Data.Bifunctor (bimap, first)-import Data.ByteString (ByteString)-import Data.Hashable (Hashable)-import Data.Map (Map)-import Data.Semigroup (Semigroup (..))-import Data.Text (Text)-import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime)-import Data.Word (Word)-import GHC.Generics (Generic)-import Numeric.Natural (Natural)-import Text.Read (readEither)--import Toml.Type (AnyValue (..), MatchError (..), TValue (..), Value (..), applyAsToAny, matchBool,- matchDay, matchDouble, matchHours, matchInteger, matchLocal, matchText,- matchZoned, mkMatchError, toMArray)--import qualified Control.Category as Cat-import qualified Data.ByteString.Lazy as BL-import qualified Data.HashSet as HS-import qualified Data.IntSet as IS-import qualified Data.List.NonEmpty as NE-import qualified Data.Map as M-import qualified Data.Set as S-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TL---------------------------------------------------------------------------------- BiMap concepts and ideas-------------------------------------------------------------------------------{- | Partial bidirectional isomorphism. @BiMap a b@ contains two function:--1. @a -> Either e b@-2. @b -> Either e a@--If you think of types as sets then this data type can be illustrated by the-following picture:----'BiMap' also implements 'Cat.Category' typeclass. And this instance can be described-clearly by this illustration:----}-data BiMap e a b = BiMap- { forward :: a -> Either e b- , backward :: b -> Either e a- }--instance Cat.Category (BiMap e) where- id :: BiMap e a a- id = BiMap Right Right-- (.) :: BiMap e b c -> BiMap e a b -> BiMap e a c- bc . ab = BiMap- { forward = forward ab >=> forward bc- , backward = backward bc >=> backward ab- }---- | Inverts bidirectional mapping.-invert :: BiMap e a b -> BiMap e b a-invert (BiMap f g) = BiMap g f--{- | Creates 'BiMap' from isomorphism. Can be used in the following way:--@-__newtype__ Even = Even Integer-__newtype__ Odd = Odd Integer--succEven :: Even -> Odd-succEven (Even n) = Odd (n + 1)--predOdd :: Odd -> Even-predOdd (Odd n) = Even (n - 1)--_EvenOdd :: 'BiMap' e Even Odd-_EvenOdd = 'iso' succEven predOdd-@--}-iso :: (a -> b) -> (b -> a) -> BiMap e a b-iso f g = BiMap (Right . f) (Right . g)--{- | Creates 'BiMap' from prism-like pair of functions. This combinator can be-used to create 'BiMap' for custom data types like this:--@-__data__ User- = Admin Integer -- id of admin- | Client Text -- name of the client- __deriving__ (Show)--_Admin :: 'TomlBiMap' User Integer-_Admin = Toml.'prism' Admin $ \\__case__- Admin i -> Right i- other -> Toml.'wrongConstructor' \"Admin\" other--_Client :: 'TomlBiMap' User Text-_Client = Toml.'prism' Client $ \\__case__- Client n -> Right n- other -> Toml.'wrongConstructor' \"Client\" other-@--}-prism :: (field -> object) -> (object -> Either error field) -> BiMap error object field-prism review preview = BiMap preview (Right . review)--------------------------------------------------------------------------------- BiMap error types--------------------------------------------------------------------------------- | 'BiMap' specialized to TOML error.-type TomlBiMap = BiMap TomlBiMapError---- | Type of errors for TOML 'BiMap'.-data TomlBiMapError- = WrongConstructor -- ^ Error for cases with wrong constructors. For- -- example, you're trying to convert 'Left' but- -- bidirectional converter expects 'Right'.- Text -- ^ Expected constructor name- Text -- ^ Actual value- | WrongValue -- ^ Error for cases with wrong values- MatchError -- ^ Information about failed matching- | ArbitraryError -- ^ Arbitrary textual error- Text -- ^ Error message- deriving (Eq, Show, Generic, NFData)---- | Converts 'TomlBiMapError' into pretty human-readable text.-prettyBiMapError :: TomlBiMapError -> Text-prettyBiMapError = \case- WrongConstructor expected actual -> T.unlines- [ "Invalid constructor"- , " * Expected: " <> expected- , " * Actual: " <> actual- ]- WrongValue (MatchError expected actual) -> T.unlines- [ "Invalid constructor"- , " * Expected: " <> tShow expected- , " * Actual: " <> tShow actual- ]- ArbitraryError text -> text---- | Helper to construct WrongConstuctor error.-wrongConstructor- :: Show a- => Text -- ^ Name of the expected constructor- -> a -- ^ Actual value- -> Either TomlBiMapError b-wrongConstructor constructor x = Left $ WrongConstructor constructor (tShow x)--------------------------------------------------------------------------------- General purpose bimaps--------------------------------------------------------------------------------- | Bimap for 'Either' and its left type-_Left :: (Show l, Show r) => TomlBiMap (Either l r) l-_Left = prism Left $ \case- Left l -> Right l- x -> wrongConstructor "Left" x---- | Bimap for 'Either' and its right type-_Right :: (Show l, Show r) => TomlBiMap (Either l r) r-_Right = prism Right $ \case- Right r -> Right r- x -> wrongConstructor "Right" x---- | Bimap for 'Maybe'-_Just :: Show r => TomlBiMap (Maybe r) r-_Just = prism Just $ \case- Just r -> Right r- x -> wrongConstructor "Just" x--------------------------------------------------------------------------------- BiMaps for value--------------------------------------------------------------------------------- | Creates prism for 'AnyValue'.-mkAnyValueBiMap- :: forall a (tag :: TValue) . (forall (t :: TValue) . Value t -> Either MatchError a)- -> (a -> Value tag)- -> TomlBiMap a AnyValue-mkAnyValueBiMap matchValue toValue = BiMap- { forward = Right . toAnyValue- , backward = fromAnyValue- }- where- toAnyValue :: a -> AnyValue- toAnyValue = AnyValue . toValue-- fromAnyValue :: AnyValue -> Either TomlBiMapError a- fromAnyValue (AnyValue value) = first WrongValue $ matchValue value---- | Creates bimap for 'Data.Text.Text' to 'AnyValue' with custom functions-_TextBy- :: forall a .- (a -> Text) -- ^ @show@ function for @a@- -> (Text -> Either Text a) -- ^ Parser of @a@ from 'Data.Text.Text'- -> TomlBiMap a AnyValue-_TextBy toText parseText = BiMap toAnyValue fromAnyValue- where- toAnyValue :: a -> Either TomlBiMapError AnyValue- toAnyValue = Right . AnyValue . Text . toText-- fromAnyValue :: AnyValue -> Either TomlBiMapError a- fromAnyValue (AnyValue v) =- first WrongValue (matchText v) >>= first ArbitraryError . parseText--{- | 'Prelude.Bool' bimap for 'AnyValue'. Usually used as-'Toml.Bi.Combinators.bool' combinator.--}-_Bool :: TomlBiMap Bool AnyValue-_Bool = mkAnyValueBiMap matchBool Bool--{- | 'Prelude.Integer' bimap for 'AnyValue'. Usually used as-'Toml.Bi.Combinators.integer' combinator.--}-_Integer :: TomlBiMap Integer AnyValue-_Integer = mkAnyValueBiMap matchInteger Integer--{- | 'Prelude.Double' bimap for 'AnyValue'. Usually used as-'Toml.Bi.Combinators.double' combinator.--}-_Double :: TomlBiMap Double AnyValue-_Double = mkAnyValueBiMap matchDouble Double--{- | 'Data.Text.Text' bimap for 'AnyValue'. Usually used as-'Toml.Bi.Combinators.text' combinator.--}-_Text :: TomlBiMap Text AnyValue-_Text = mkAnyValueBiMap matchText Text---- | Helper bimap for 'Data.Text.Lazy.Text' and 'Data.Text.Text'.-_LTextText :: BiMap e TL.Text Text-_LTextText = iso TL.toStrict TL.fromStrict--{- | 'Data.Text.Lazy.Text' bimap for 'AnyValue'. Usually used as-'Toml.Bi.Combinators.lazyText' combinator.--}-_LText :: TomlBiMap TL.Text AnyValue-_LText = _LTextText >>> _Text--{- | 'Data.Time.ZonedTime' bimap for 'AnyValue'. Usually used as-'Toml.Bi.Combinators.zonedTime' combinator.--}-_ZonedTime :: TomlBiMap ZonedTime AnyValue-_ZonedTime = mkAnyValueBiMap matchZoned Zoned--{- | 'Data.Time.LocalTime' bimap for 'AnyValue'. Usually used as-'Toml.Bi.Combinators.localTime' combinator.--}-_LocalTime :: TomlBiMap LocalTime AnyValue-_LocalTime = mkAnyValueBiMap matchLocal Local--{- | 'Data.Time.Day' bimap for 'AnyValue'. Usually used as-'Toml.Bi.Combinators.day' combinator.--}-_Day :: TomlBiMap Day AnyValue-_Day = mkAnyValueBiMap matchDay Day--{- | 'Data.Time.TimeOfDay' bimap for 'AnyValue'. Usually used as-'Toml.Bi.Combinators.timeOfDay' combinator.--}-_TimeOfDay :: TomlBiMap TimeOfDay AnyValue-_TimeOfDay = mkAnyValueBiMap matchHours Hours---- | Helper bimap for 'String' and 'Data.Text.Text'.-_StringText :: BiMap e String Text-_StringText = iso T.pack T.unpack--{- | 'String' bimap for 'AnyValue'. Usually used as-'Toml.Bi.Combinators.string' combinator.--}-_String :: TomlBiMap String AnyValue-_String = _StringText >>> _Text---- | Helper bimap for 'String' and types with 'Read' and 'Show' instances.-_ReadString :: (Show a, Read a) => TomlBiMap a String-_ReadString = BiMap (Right . show) (first (ArbitraryError . T.pack) . readEither)---- | Bimap for 'AnyValue' and values with a 'Read' and 'Show' instance.--- Usually used as 'Toml.Bi.Combinators.read' combinator.-_Read :: (Show a, Read a) => TomlBiMap a AnyValue-_Read = _ReadString >>> _String---- | Helper bimap for 'Natural' and 'Prelude.Integer'.-_NaturalInteger :: TomlBiMap Natural Integer-_NaturalInteger = BiMap (Right . toInteger) eitherInteger- where- eitherInteger :: Integer -> Either TomlBiMapError Natural- eitherInteger n- | n < 0 = Left $ ArbitraryError $ "Value is below zero, but expected Natural: " <> tShow n- | otherwise = Right (fromIntegral n)--{- | 'String' bimap for 'AnyValue'. Usually used as-'Toml.Bi.Combinators.natural' combinator.--}-_Natural :: TomlBiMap Natural AnyValue-_Natural = _NaturalInteger >>> _Integer---- | Helper bimap for 'Prelude.Integer' and integral, bounded values.-_BoundedInteger :: (Integral a, Bounded a, Show a) => TomlBiMap a Integer-_BoundedInteger = BiMap (Right . toInteger) eitherBounded- where- eitherBounded :: forall a. (Integral a, Bounded a, Show a) => Integer -> Either TomlBiMapError a- eitherBounded n- | n < toInteger (minBound @a) =- let msg = "Value " <> tShow n <> " is less than minBound: " <> tShow (minBound @a)- in Left $ ArbitraryError msg- | n > toInteger (maxBound @a) =- let msg = "Value " <> tShow n <> " is greater than maxBound: " <> tShow (maxBound @a)- in Left $ ArbitraryError msg- | otherwise = Right (fromIntegral n)--{- | Helper bimap for 'EnumBounded' and 'Data.Text.Text'.--@since 1.1.1.0--}-_EnumBoundedText :: forall a. (Show a, Enum a, Bounded a) => TomlBiMap a Text-_EnumBoundedText = BiMap- { forward = Right . tShow- , backward = toEnumBounded- }- where- toEnumBounded :: Text -> Either TomlBiMapError a- toEnumBounded value = case M.lookup value enumOptions of- Just a -> Right a- Nothing ->- let msg = "Value is '" <> value <> "' but expected one of: " <> T.intercalate ", " options- in Left (ArbitraryError msg)- where- enumOptions :: Map Text a- enumOptions = M.fromList $ zip options enums- options = fmap tShow enums- enums = [minBound @a .. maxBound @a]--{- | Bimap for nullary sum data types with 'Show', 'Enum' and 'Bounded'-instances. Usually used as 'Toml.Bi.Combinators.enumBounded' combinator.--@since 1.1.1.0--}-_EnumBounded :: (Show a, Enum a, Bounded a) => TomlBiMap a AnyValue-_EnumBounded = _EnumBoundedText >>> _Text--{- | 'Word' bimap for 'AnyValue'. Usually used as-'Toml.Bi.Combinators.word' combinator.--}-_Word :: TomlBiMap Word AnyValue-_Word = _BoundedInteger >>> _Integer--{- | 'Int' bimap for 'AnyValue'. Usually used as-'Toml.Bi.Combinators.int' combinator.--}-_Int :: TomlBiMap Int AnyValue-_Int = _BoundedInteger >>> _Integer--{- | 'Float' bimap for 'AnyValue'. Usually used as-'Toml.Bi.Combinators.float' combinator.--}-_Float :: TomlBiMap Float AnyValue-_Float = iso realToFrac realToFrac >>> _Double---- | Helper bimap for 'Data.Text.Text' and strict 'ByteString'-_ByteStringText :: TomlBiMap ByteString Text-_ByteStringText = prism T.encodeUtf8 eitherText- where- eitherText :: ByteString -> Either TomlBiMapError Text- eitherText = either (\err -> Left $ ArbitraryError $ tShow err) Right . T.decodeUtf8'---- | UTF8 encoded 'ByteString' bimap for 'AnyValue'.--- Usually used as 'Toml.Bi.Combinators.byteString' combinator.-_ByteString :: TomlBiMap ByteString AnyValue-_ByteString = _ByteStringText >>> _Text---- | Helper bimap for 'Data.Text.Text' and lazy 'BL.ByteString'.-_LByteStringText :: TomlBiMap BL.ByteString Text-_LByteStringText = prism (TL.encodeUtf8 . TL.fromStrict) eitherText- where- eitherText :: BL.ByteString -> Either TomlBiMapError Text- eitherText = bimap (ArbitraryError . tShow) TL.toStrict . TL.decodeUtf8'---- | UTF8 encoded lazy 'BL.ByteString' bimap for 'AnyValue'.--- Usually used as 'Toml.Bi.Combinators.lazyByteString' combinator.-_LByteString :: TomlBiMap BL.ByteString AnyValue-_LByteString = _LByteStringText >>> _Text---- | Takes a bimap of a value and returns a bimap between a list of values and 'AnyValue'--- as an array. Usually used as 'Toml.Bi.Combinators.arrayOf' combinator.-_Array :: forall a . TomlBiMap a AnyValue -> TomlBiMap [a] AnyValue-_Array elementBimap = BiMap toAnyValue fromAnyValue- where- toAnyValue :: [a] -> Either TomlBiMapError AnyValue- toAnyValue = mapM (forward elementBimap) >=> bimap WrongValue AnyValue . toMArray-- fromAnyValue :: AnyValue -> Either TomlBiMapError [a]- fromAnyValue (AnyValue v) = matchElements (backward elementBimap) v-- -- can't reuse matchArray here :(- matchElements :: (AnyValue -> Either TomlBiMapError a) -> Value t -> Either TomlBiMapError [a]- matchElements match (Array a) = mapM (applyAsToAny match) a- matchElements _ val = first WrongValue $ mkMatchError TArray val----- | Takes a bimap of a value and returns a bimap between a non-empty list of values and 'AnyValue'--- as an array. Usually used as 'Toml.Bi.Combinators.nonEmpty' combinator.-_NonEmpty :: TomlBiMap a AnyValue -> TomlBiMap (NE.NonEmpty a) AnyValue-_NonEmpty bi = _NonEmptyArray >>> _Array bi--_NonEmptyArray :: TomlBiMap (NE.NonEmpty a) [a]-_NonEmptyArray = BiMap- { forward = Right . NE.toList- , backward = maybe (Left $ ArbitraryError "Empty array list, but expected NonEmpty") Right . NE.nonEmpty- }---- | Takes a bimap of a value and returns a bimap between a set of values and 'AnyValue'--- as an array. Usually used as 'Toml.Bi.Combinators.arraySetOf' combinator.-_Set :: (Ord a) => TomlBiMap a AnyValue -> TomlBiMap (S.Set a) AnyValue-_Set bi = iso S.toList S.fromList >>> _Array bi---- | Takes a bimap of a value and returns a bimap between a hash set of values and 'AnyValue'--- as an array. Usually used as 'Toml.Bi.Combinators.arrayHashSetOf' combinator.-_HashSet :: (Eq a, Hashable a) => TomlBiMap a AnyValue -> TomlBiMap (HS.HashSet a) AnyValue-_HashSet bi = iso HS.toList HS.fromList >>> _Array bi--{- | 'IS.IntSet' bimap for 'AnyValue'. Usually used as-'Toml.Bi.Combinators.arrayIntSet' combinator.--}-_IntSet :: TomlBiMap IS.IntSet AnyValue-_IntSet = iso IS.toList IS.fromList >>> _Array _Int--tShow :: Show a => a -> Text-tShow = T.pack . show
− src/Toml/Bi/Monad.hs
@@ -1,231 +0,0 @@--- | Contains general underlying monad for bidirectional conversion.--module Toml.Bi.Monad- ( Codec (..)- , BiCodec- , dimap- , dioptional- , diwrap- , (<!>)- , (.=)- ) where--import Control.Applicative (Alternative (..), optional)-import Control.Monad (MonadPlus (..))-import Data.Coerce (Coercible, coerce)---{- | Monad for bidirectional conversion. Contains pair of functions:--1. How to read value of type @a@ from immutable environment context @r@?-2. How to store value of type @a@ in stateful context @w@?--In practice instead of @r@ we will use some @Reader Toml@ and instead of @w@ we will-use @State Toml@. This approach with the bunch of utility functions allows to-have single description for from/to @TOML@ conversion.--In practice this type will always be used in the following way:--@-type 'BiCodec' r w a = 'Codec' r w a a-@--Type parameter @c@ if fictional. Here some trick is used. This trick is-implemented in the [codec](http://hackage.haskell.org/package/codec) package and-described in more details in related blog post:-<https://blog.poisson.chat/posts/2016-10-12-bidirectional-serialization.html>.--}-data Codec r w c a = Codec- { -- | Extract value of type @a@ from monadic context @r@.- codecRead :: r a-- -- | Store value of type @c@ inside monadic context @w@ and returning- -- value of type @a@. Type of this function actually should be @a -> w ()@ but with- -- such type it's impossible to have 'Monad' and other instances.- , codecWrite :: c -> w a- }---- | Specialized version of 'Codec' data type. This type alias is used in practice.-type BiCodec r w a = Codec r w a a--instance (Functor r, Functor w) => Functor (Codec r w c) where- fmap :: (a -> b) -> Codec r w c a -> Codec r w c b- fmap f codec = Codec- { codecRead = f <$> codecRead codec- , codecWrite = fmap f . codecWrite codec- }--instance (Applicative r, Applicative w) => Applicative (Codec r w c) where- pure :: a -> Codec r w c a- pure a = Codec- { codecRead = pure a- , codecWrite = \_ -> pure a- }-- (<*>) :: Codec r w c (a -> b) -> Codec r w c a -> Codec r w c b- codecf <*> codeca = Codec- { codecRead = codecRead codecf <*> codecRead codeca- , codecWrite = \c -> codecWrite codecf c <*> codecWrite codeca c- }--instance (Monad r, Monad w) => Monad (Codec r w c) where- (>>=) :: Codec r w c a -> (a -> Codec r w c b) -> Codec r w c b- codec >>= f = Codec- { codecRead = codecRead codec >>= \a -> codecRead (f a)- , codecWrite = \c -> codecWrite codec c >>= \a -> codecWrite (f a) c- }--instance (Alternative r, Alternative w) => Alternative (Codec r w c) where- empty :: Codec r w c a- empty = Codec- { codecRead = empty- , codecWrite = \_ -> empty- }-- (<|>) :: Codec r w c a -> Codec r w c a -> Codec r w c a- codec1 <|> codec2 = Codec- { codecRead = codecRead codec1 <|> codecRead codec2- , codecWrite = \c -> codecWrite codec1 c <|> codecWrite codec2 c- }--instance (MonadPlus r, MonadPlus w) => MonadPlus (Codec r w c) where- mzero = empty- mplus = (<|>)---- | Alternative instance for function arrow but without 'empty'.-infixl 3 <!>-(<!>) :: Alternative f => (a -> f x) -> (a -> f x) -> (a -> f x)-f <!> g = \a -> f a <|> g a--{- | This is an instance of @Profunctor@ for 'Codec'. But since there's no-@Profunctor@ type class in @base@ or package with no dependencies (and we don't-want to bring extra dependencies) this instance is implemented as a single-top-level function.--Useful when you want to parse @newtype@s. For example, if you had data type like-this:--@-__data__ Example = Example- { foo :: Bool- , bar :: Text- }-@--Bidirectional TOML converter for this type will look like this:--@-exampleCodec :: TomlCodec Example-exampleCodec = Example- \<$\> Toml.bool "foo" '.=' foo- \<*\> Toml.text "bar" '.=' bar-@--Now if you change your type in the following way:--@-__newtype__ Email = Email { unEmail :: Text }--__data__ Example = Example- { foo :: Bool- , bar :: Email- }-@--you need to patch your TOML codec like this:--@-exampleCodec :: TomlCodec Example-exampleCodec = Example- \<$\> Toml.bool "foo" '.=' foo- \<*\> 'dimap' unEmail Email (Toml.text "bar") '.=' bar-@--}-dimap- :: (Functor r, Functor w)- => (c -> d) -- ^ Mapper for consumer- -> (a -> b) -- ^ Mapper for producer- -> Codec r w d a -- ^ Source 'Codec' object- -> Codec r w c b -- ^ Target 'Codec' object-dimap f g codec = Codec- { codecRead = g <$> codecRead codec- , codecWrite = fmap g . codecWrite codec . f- }--{- | Bidirectional converter for @Maybe a@ values. For example, given the data-type:--@-__data__ Example = Example- { foo :: Bool- , bar :: Maybe Int- }-@--the TOML codec will look like--@-exampleCodec :: TomlCodec Example-exampleCodec = Example- \<$\> Toml.bool "foo" '.=' foo- \<*\> 'dioptional' (Toml.int "bar") '.=' bar-@--}-dioptional- :: (Alternative r, Applicative w)- => Codec r w c a- -> Codec r w (Maybe c) (Maybe a)-dioptional Codec{..} = Codec- { codecRead = optional codecRead- , codecWrite = traverse codecWrite- }--{- | Combinator used for @newtype@ wrappers. For example, given the data types:--@-__newtype__ N = N Int--__data__ Example = Example- { foo :: Bool- , bar :: N- }-@--the TOML codec can look like--@-exampleCodec :: TomlCodec Example-exampleCodec = Example- \<$\> Toml.bool "foo" '.=' foo- \<*\> 'diwrap' (Toml.int "bar") '.=' bar-@--}-diwrap- :: forall b a r w .- (Coercible a b, Functor r, Functor w)- => BiCodec r w a- -> BiCodec r w b-diwrap = dimap coerce coerce--{- | Operator to connect two operations:--1. How to get field from object?-2. How to write this field to toml?--In code this should be used like this:--@-__data__ Foo = Foo- { fooBar :: Int- , fooBaz :: String- }--fooCodec :: TomlCodec Foo-fooCodec = Foo- \<$\> Toml.int "bar" '.=' fooBar- \<*\> Toml.str "baz" '.=' fooBaz-@--}-infixl 5 .=-(.=) :: Codec r w field a -> (object -> field) -> Codec r w object a-codec .= getter = codec { codecWrite = codecWrite codec . getter }
+ src/Toml/Codec.hs view
@@ -0,0 +1,125 @@+{- |+Module : Toml.Codec+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++This module provides utilities for implementing and using+bidirectional TOML codecs. The concept of bidirectional conversion in+@tomland@ has two parts: __'TomlBiMap'__ and __'TomlCodec'__.++== General TOML description++In the following TOML++@+name = "foo"+@++we call @name@ as __key__ and @"foo"@ as __value__.++== 'TomlBiMap'++'TomlBiMap' provides a bidirectional conversion between+__TOML values__ and Haskell primitive values. TOML specification+defines some primitive values you can use in key-value pairs+(e.g. /integer/, /string/, /local time/). 'TomlBiMap' provides a way+to convert between TOML primitives and Haskell values. 'TomlBiMap'+doesn't know anything about TOML keys.++== 'TomlCodec'++'TomlCodec' describes how to convert in both ways between a single or+multiple key-value pairs and Haskell types. @tomland@ provides basic+primitives for decoding and encoding single key-value pairs, but also+a way to compose multiple 'TomlCodec's into a single one. So, if you+have a custom data type, that has several fields or several+constructors, you need to define 'TomlCodec' for your data type.++== Encoding and decoding++If you have a type like @User@ then @userCodec :: 'TomlCodec' User@ is+an object that describes how to 'encode' a value of type @User@ to+TOML and 'decode' TOML to a value of type @User@.++* To TOML: @'encode' userCodec someUser@+* From TOML: @'decode' userCodec someToml@++== Naming conventions++@tomland@ uses the following naming conventions (and encourages+library users to follow them as well):++* __\_SomeName__: for 'TomlBiMap' (e.g. '_Int', '_Text', '_Array')+* __someName__: for basic 'TomlCodec's (e.g. 'int', 'text', 'arrayOf')+* __someNameCodec__: for user defined codecs for custom types (e.g. @userCodec@, @configCodec@, @serverCodec@)++@since 1.3.0.0+-}++module Toml.Codec+ ( -- $types+ module Toml.Codec.Types+ -- $error+ , module Toml.Codec.Error+ -- $code+ , module Toml.Codec.Code+ -- $di+ , module Toml.Codec.Di+ -- $combinator+ , module Toml.Codec.Combinator+ -- $generic+ , module Toml.Codec.Generic+ -- $bimap+ , module Toml.Codec.BiMap+ -- $bimapConversion+ , module Toml.Codec.BiMap.Conversion+ ) where++import Toml.Codec.BiMap+import Toml.Codec.BiMap.Conversion+import Toml.Codec.Code+import Toml.Codec.Combinator+import Toml.Codec.Di+import Toml.Codec.Error+import Toml.Codec.Generic+import Toml.Codec.Types++{- $types+Core codec types, including @Toml@ specialised ones: 'TomlCodec', 'TomlState'+and 'TomlEnv'.+-}++{- $error+Core error types, including 'TomlDecodeError' and 'LoadTomlException'.+-}++{- $code+Contains TOML-specific combinators for converting between TOML and user data+types.+-}++{- $di+Forward and backward mapping functions and combinators (similar to profunctors).+-}++{- $combinator+Contains TOML-specific combinators and codecs for converting between TOML and+user data types.+-}++{- $generic+Automatic TOML codecs using 'GHC.Generics.Generic'.+-}++{- $bimap+'BiMap' type that represents /Tagged Partial Bidirectional Conversion/+between TOML primitives and Haskell types.+-}++{- $bimapConversion+Specific implementations of 'BiMap' between Haskell types and TOML+values.+-}
+ src/Toml/Codec/BiMap.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE Rank2Types #-}++{- |+Module : Toml.Codec.BiMap+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++Implementation of /Tagged Partial Bidirectional Isomorphism/.+This module contains the 'BiMap' type that represents conversion between+two types with the possibility of failure.++See "Toml.Codec.BiMap.Conversion" for examples of 'BiMap' with+specific types. The 'BiMap' concept is general and is not specific to+TOML, but in this package most usages of 'BiMap' are between TOML+values and Haskell values.+-}++module Toml.Codec.BiMap+ ( -- * 'BiMap' concept+ BiMap (..)+ , invert+ , iso+ , prism++ -- * TOML 'BiMap'+ -- ** Type+ , TomlBiMap+ -- ** Error+ , TomlBiMapError (..)+ , wrongConstructor+ , prettyBiMapError+ -- ** Smart constructors+ , mkAnyValueBiMap+ -- ** Internals+ , tShow+ ) where++import Control.DeepSeq (NFData)+import Control.Monad ((>=>))+import Data.Bifunctor (first)+import Data.Text (Text)+import GHC.Generics (Generic)++import Toml.Type.AnyValue (AnyValue (..), MatchError (..))+import Toml.Type.Value (TValue (..), Value (..))++import qualified Control.Category as Cat+import qualified Data.Text as T+++{- | Partial bidirectional isomorphism. @BiMap a b@ contains two function:++1. @a -> Either e b@+2. @b -> Either e a@++If you think of types as sets then this data type can be illustrated by the+following picture:++++'BiMap' also implements 'Cat.Category' typeclass. And this instance can be described+clearly by this illustration:++++@since 0.4.0+-}+data BiMap e a b = BiMap+ { forward :: a -> Either e b+ , backward :: b -> Either e a+ }++-- | @since 0.4.0+instance Cat.Category (BiMap e) where+ id :: BiMap e a a+ id = BiMap Right Right+ {-# INLINE id #-}++ (.) :: BiMap e b c -> BiMap e a b -> BiMap e a c+ bc . ab = BiMap+ { forward = forward ab >=> forward bc+ , backward = backward bc >=> backward ab+ }+ {-# INLINE (.) #-}++{- | Inverts bidirectional mapping.++@since 0.4.0+-}+invert :: BiMap e a b -> BiMap e b a+invert (BiMap f g) = BiMap g f+{-# INLINE invert #-}++{- | Creates 'BiMap' from isomorphism. Can be used in the following way:++@+__newtype__ Even = Even Integer+__newtype__ Odd = Odd Integer++succEven :: Even -> Odd+succEven (Even n) = Odd (n + 1)++predOdd :: Odd -> Even+predOdd (Odd n) = Even (n - 1)++_EvenOdd :: 'BiMap' e Even Odd+_EvenOdd = 'iso' succEven predOdd+@++@since 0.4.0+-}+iso :: (a -> b) -> (b -> a) -> BiMap e a b+iso f g = BiMap (Right . f) (Right . g)+{-# INLINE iso #-}++{- | Creates 'BiMap' from prism-like pair of functions. This combinator can be+used to create 'BiMap' for custom sum types like this:++@+__data__ User+ = Admin Integer -- id of admin+ | Client Text -- name of the client+ __deriving__ (Show)++_Admin :: 'TomlBiMap' User Integer+_Admin = Toml.'prism' Admin $ \\__case__+ Admin i -> Right i+ other -> Toml.'wrongConstructor' \"Admin\" other++_Client :: 'TomlBiMap' User Text+_Client = Toml.'prism' Client $ \\__case__+ Client n -> Right n+ other -> Toml.'wrongConstructor' \"Client\" other+@++@since 0.4.0+-}+prism+ :: (field -> object)+ -- ^ Constructor+ -> (object -> Either error field)+ -- ^ Match object to either error or field+ -> BiMap error object field+prism review preview = BiMap preview (Right . review)+{-# INLINE prism #-}++----------------------------------------------------------------------------+-- TOML BiMap+----------------------------------------------------------------------------++{- | 'BiMap' specialized to TOML error.++@since 1.0.0+-}+type TomlBiMap = BiMap TomlBiMapError++{- | Type of errors for TOML 'BiMap'.++@since 1.0.0+-}+data TomlBiMapError+ = WrongConstructor -- ^ Error for cases with wrong constructors. For+ -- example, you're trying to convert 'Left' but+ -- bidirectional converter expects 'Right'.+ !Text -- ^ Expected constructor name+ !Text -- ^ Actual value+ | WrongValue -- ^ Error for cases with wrong values+ !MatchError -- ^ Information about failed matching+ | ArbitraryError -- ^ Arbitrary textual error+ !Text -- ^ Error message+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++{- | Converts 'TomlBiMapError' into pretty human-readable text.++@since 1.0.0+-}+prettyBiMapError :: TomlBiMapError -> Text+prettyBiMapError = \case+ WrongConstructor expected actual -> T.unlines+ [ "Invalid constructor"+ , " * Expected: " <> expected+ , " * Actual: " <> actual+ ]+ WrongValue (MatchError expected actual) -> T.unlines+ [ "Invalid constructor"+ , " * Expected: " <> tShow expected+ , " * Actual: " <> tShow actual+ ]+ ArbitraryError text -> text++{- | Helper to construct WrongConstuctor error.++@since 1.0.0+-}+wrongConstructor+ :: Show a+ => Text -- ^ Name of the expected constructor+ -> a -- ^ Actual value+ -> Either TomlBiMapError b+wrongConstructor constructor x = Left $ WrongConstructor constructor (tShow x)++tShow :: Show a => a -> Text+tShow = T.pack . show+{-# INLINE tShow #-}++----------------------------------------------------------------------------+-- BiMaps for value+----------------------------------------------------------------------------++{- | Smart constructor for 'BiMap' from a Haskell value (some+primitive like 'Int' or 'Text') to 'AnyValue'.++@since 0.4.0+-}+mkAnyValueBiMap+ :: forall a (tag :: TValue)+ . (forall (t :: TValue) . Value t -> Either MatchError a)+ -- ^ Haskell type exctractor from 'Value'+ -> (a -> Value tag)+ -- ^ Convert Haskell type back to 'Value'+ -> TomlBiMap a AnyValue+mkAnyValueBiMap matchValue toValue = BiMap+ { forward = Right . toAnyValue+ , backward = fromAnyValue+ }+ where+ toAnyValue :: a -> AnyValue+ toAnyValue = AnyValue . toValue++ fromAnyValue :: AnyValue -> Either TomlBiMapError a+ fromAnyValue (AnyValue value) = first WrongValue $ matchValue value
+ src/Toml/Codec/BiMap/Conversion.hs view
@@ -0,0 +1,653 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}++{- |+Module : Toml.Codec.BiMap.Conversion+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++Implementations of 'BiMap' for specific Haskell types and TOML+values. Usually, you use codecs from the "Toml.Codec.Combinator" module.+You may need to use these 'BiMap's instead of codecs in the+following situations:++1. When using 'Toml.Codec.Combinator.List.arrayOf' combinator (or similar).+2. When using 'Toml.Codec.Combinator.Map.tableMap' combinator (for keys).+3. When implementing custom 'BiMap' for your types.++@since 1.3.0.0+-}++module Toml.Codec.BiMap.Conversion+ ( -- * Primitive+ -- ** Boolean+ _Bool+ -- ** Integral+ , _Int+ , _Word+ , _Word8+ , _Integer+ , _Natural+ -- ** Floating+ , _Double+ , _Float+ -- ** Text+ , _Text+ , _LText+ , _ByteString+ , _LByteString+ , _String++ -- * Time+ , _ZonedTime+ , _LocalTime+ , _Day+ , _TimeOfDay++ -- * Arrays+ , _Array+ , _NonEmpty+ , _Set+ , _HashSet+ , _IntSet+ , _ByteStringArray+ , _LByteStringArray++ -- * Coerce+ , _Coerce++ -- * Custom+ , _EnumBounded+ , _Read+ , _TextBy+ , _Validate+ , _Hardcoded++ -- * 'Key's+ , _KeyText+ , _KeyString+ , _KeyInt++ -- * General purpose+ , _Just+ , _Left+ , _Right++ -- * Internal helpers+ , _LTextText+ , _NaturalInteger+ , _NonEmptyList+ , _StringText+ , _ReadString+ , _BoundedInteger+ , _EnumBoundedText+ , _ByteStringText+ , _LByteStringText+ ) where++import Control.Category ((>>>))+import Control.Monad ((>=>))+import Data.Bifunctor (bimap, first)+import Data.ByteString (ByteString)+import Data.Coerce (Coercible, coerce)+import Data.Hashable (Hashable)+import Data.Map (Map)+import Data.Text (Text)+import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime)+import Data.Word (Word8)+import Numeric.Natural (Natural)+import Text.Read (readEither)++import Toml.Codec.BiMap (BiMap (..), TomlBiMap, TomlBiMapError (..), iso, mkAnyValueBiMap, prism,+ tShow, wrongConstructor)+import Toml.Parser (TomlParseError (..), parseKey)+import Toml.Type.AnyValue (AnyValue (..), applyAsToAny, matchBool, matchDay, matchDouble,+ matchHours, matchInteger, matchLocal, matchText, matchZoned,+ mkMatchError, toMArray)+import Toml.Type.Key (Key (..))+import Toml.Type.Printer (prettyKey)+import Toml.Type.Value (TValue (..), Value (..))++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.HashSet as HS+import qualified Data.IntSet as IS+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL++----------------------------------------------------------------------------+-- Primitive+----------------------------------------------------------------------------++{- | 'Prelude.Bool' 'BiMap' for 'AnyValue'. Usually used as the+'Toml.Codec.Combinator.Primitive.bool' combinator.++@since 0.4.0+-}+_Bool :: TomlBiMap Bool AnyValue+_Bool = mkAnyValueBiMap matchBool Bool+{-# INLINE _Bool #-}++{- | 'Prelude.Integer' 'BiMap' for 'AnyValue'. Usually used as the+'Toml.Codec.Combinator.Primitive.integer' combinator.++@since 0.4.0+-}+_Integer :: TomlBiMap Integer AnyValue+_Integer = mkAnyValueBiMap matchInteger Integer+{-# INLINE _Integer #-}++{- | 'Prelude.Double' 'BiMap' for 'AnyValue'. Usually used as the+'Toml.Codec.Combinator.Primitive.double' combinator.++@since 0.4.0+-}+_Double :: TomlBiMap Double AnyValue+_Double = mkAnyValueBiMap matchDouble Double+{-# INLINE _Double #-}++{- | 'Data.Text.Text' 'BiMap' for 'AnyValue'. Usually used as the+'Toml.Codec.Combinator.Primitive.text' combinator.++@since 0.4.0+-}+_Text :: TomlBiMap Text AnyValue+_Text = mkAnyValueBiMap matchText Text+{-# INLINE _Text #-}++{- | Helper bimap for 'Data.Text.Lazy.Text' and 'Data.Text.Text'.++@since 1.0.0+-}+_LTextText :: BiMap e TL.Text Text+_LTextText = iso TL.toStrict TL.fromStrict+{-# INLINE _LTextText #-}++{- | 'Data.Text.Lazy.Text' 'BiMap' for 'AnyValue'. Usually used as the+'Toml.Codec.Combinator.Primitive.lazyText' combinator.++@since 1.0.0+-}+_LText :: TomlBiMap TL.Text AnyValue+_LText = _LTextText >>> _Text+{-# INLINE _LText #-}++{- | 'Data.Time.ZonedTime' bimap for 'AnyValue'. Usually used as the+'Toml.Codec.Combinator.Time.zonedTime' combinator.++@since 0.5.0+-}+_ZonedTime :: TomlBiMap ZonedTime AnyValue+_ZonedTime = mkAnyValueBiMap matchZoned Zoned+{-# INLINE _ZonedTime #-}++{- | 'Data.Time.LocalTime' bimap for 'AnyValue'. Usually used as the+'Toml.Codec.Combinator.Time.localTime' combinator.++@since 0.5.0+-}+_LocalTime :: TomlBiMap LocalTime AnyValue+_LocalTime = mkAnyValueBiMap matchLocal Local+{-# INLINE _LocalTime #-}++{- | 'Data.Time.Day' 'BiMap' for 'AnyValue'. Usually used as the+'Toml.Codec.Combinator.Time.day' combinator.++@since 0.5.0+-}+_Day :: TomlBiMap Day AnyValue+_Day = mkAnyValueBiMap matchDay Day+{-# INLINE _Day #-}++{- | 'Data.Time.TimeOfDay' 'BiMap' for 'AnyValue'. Usually used as the+'Toml.Codec.Combinator.Time.timeOfDay' combinator.++@since 0.5.0+-}+_TimeOfDay :: TomlBiMap TimeOfDay AnyValue+_TimeOfDay = mkAnyValueBiMap matchHours Hours+{-# INLINE _TimeOfDay #-}++{- | Helper 'BiMap' for 'String' and 'Data.Text.Text'.++@since 0.4.0+-}+_StringText :: BiMap e String Text+_StringText = iso T.pack T.unpack+{-# INLINE _StringText #-}++{- | 'String' 'BiMap' for 'AnyValue'. Usually used as the+'Toml.Codec.Combinator.Primitive.string' combinator.++@since 0.4.0+-}+_String :: TomlBiMap String AnyValue+_String = _StringText >>> _Text+{-# INLINE _String #-}++{- | Helper 'BiMap' for 'Natural' and 'Prelude.Integer'.++@since 0.5.0+-}+_NaturalInteger :: TomlBiMap Natural Integer+_NaturalInteger = BiMap (Right . toInteger) eitherInteger+ where+ eitherInteger :: Integer -> Either TomlBiMapError Natural+ eitherInteger n+ | n < 0 = Left $ ArbitraryError $ "Value is below zero, but expected Natural: " <> tShow n+ | otherwise = Right (fromIntegral n)++{- | 'Natural' 'BiMap' for 'AnyValue'. Usually used as the+'Toml.Codec.Combinator.Primitive.natural' combinator.++@since 0.5.0+-}+_Natural :: TomlBiMap Natural AnyValue+_Natural = _NaturalInteger >>> _Integer+{-# INLINE _Natural #-}++{- | Helper 'BiMap' for 'Prelude.Integer' and integral, bounded values.++@since 0.5.0+-}+_BoundedInteger :: (Integral a, Bounded a, Show a) => TomlBiMap a Integer+_BoundedInteger = BiMap (Right . toInteger) eitherBounded+ where+ eitherBounded :: forall a. (Integral a, Bounded a, Show a) => Integer -> Either TomlBiMapError a+ eitherBounded n+ | n < toInteger (minBound @a) =+ let msg = "Value " <> tShow n <> " is less than minBound: " <> tShow (minBound @a)+ in Left $ ArbitraryError msg+ | n > toInteger (maxBound @a) =+ let msg = "Value " <> tShow n <> " is greater than maxBound: " <> tShow (maxBound @a)+ in Left $ ArbitraryError msg+ | otherwise = Right (fromIntegral n)+++{- | 'Word' 'BiMap' for 'AnyValue'. Usually used as the+'Toml.Codec.Combinator.Primitive.word' combinator.++@since 0.5.0+-}+_Word :: TomlBiMap Word AnyValue+_Word = _BoundedInteger >>> _Integer+{-# INLINE _Word #-}++{- | 'Word8' 'BiMap' for 'AnyValue'. Usually used as the+'Toml.Codec.Combinator.Primitive.word8' combinator.++@since 1.2.0.0+-}+_Word8 :: TomlBiMap Word8 AnyValue+_Word8 = _BoundedInteger >>> _Integer+{-# INLINE _Word8 #-}++{- | 'Int' 'BiMap' for 'AnyValue'. Usually used as the+'Toml.Codec.Combinator.Primitive.int' combinator.++@since 0.5.0+-}+_Int :: TomlBiMap Int AnyValue+_Int = _BoundedInteger >>> _Integer+{-# INLINE _Int #-}++{- | 'Float' 'BiMap' for 'AnyValue'. Usually used as the+'Toml.Codec.Combinator.Primitive.float' combinator.++@since 0.5.0+-}+_Float :: TomlBiMap Float AnyValue+_Float = iso realToFrac realToFrac >>> _Double+{-# INLINE _Float #-}++{- | Helper 'BiMap' for 'Data.Text.Text' and strict 'ByteString'++@since 0.5.0+-}+_ByteStringText :: TomlBiMap ByteString Text+_ByteStringText = prism T.encodeUtf8 eitherText+ where+ eitherText :: ByteString -> Either TomlBiMapError Text+ eitherText = either (\err -> Left $ ArbitraryError $ tShow err) Right . T.decodeUtf8'+{-# INLINE _ByteStringText #-}++{- | UTF-8 encoded 'ByteString' 'BiMap' for 'AnyValue'.+Usually used as the 'Toml.Codec.Combinator.Primitive.byteString' combinator.++@since 0.5.0+-}+_ByteString :: TomlBiMap ByteString AnyValue+_ByteString = _ByteStringText >>> _Text+{-# INLINE _ByteString #-}++{- | Helper 'BiMap' for 'Data.Text.Text' and lazy 'BL.ByteString'.++@since 0.5.0+-}+_LByteStringText :: TomlBiMap BL.ByteString Text+_LByteStringText = prism (TL.encodeUtf8 . TL.fromStrict) eitherText+ where+ eitherText :: BL.ByteString -> Either TomlBiMapError Text+ eitherText = bimap (ArbitraryError . tShow) TL.toStrict . TL.decodeUtf8'+{-# INLINE _LByteStringText #-}++{- | UTF-8 encoded lazy 'BL.ByteString' 'BiMap' for 'AnyValue'.+Usually used as the 'Toml.Codec.Combinator.Primitive.lazyByteString' combinator.++@since 0.5.0+-}+_LByteString :: TomlBiMap BL.ByteString AnyValue+_LByteString = _LByteStringText >>> _Text+{-# INLINE _LByteString #-}++----------------------------------------------------------------------------+-- Array+----------------------------------------------------------------------------++{- | 'ByteString' 'BiMap' for 'AnyValue' encoded as a list of bytes+(non-negative integers between 0 and 255). Usually used as the+'Toml.Codec.Combinator.Primitive.byteStringArray' combinator.++@since 1.2.0.0+-}+_ByteStringArray :: TomlBiMap ByteString AnyValue+_ByteStringArray = iso BS.unpack BS.pack >>> _Array _Word8+{-# INLINE _ByteStringArray #-}++{- | Lazy 'ByteString' 'BiMap' for 'AnyValue' encoded as a list of+bytes (non-negative integers between 0 and 255). Usually used as+'Toml.Codec.Combinator.Primitive.lazyByteStringArray' combinator.++@since 1.2.0.0+-}+_LByteStringArray :: TomlBiMap BL.ByteString AnyValue+_LByteStringArray = iso BL.unpack BL.pack >>> _Array _Word8+{-# INLINE _LByteStringArray #-}++{- | Takes a 'BiMap' of a value and returns a 'BiMap' for a list of values and 'AnyValue'+as an array. Usually used as the 'Toml.Codec.Combinator.List.arrayOf' combinator.++@since 0.4.0+-}+_Array :: forall a . TomlBiMap a AnyValue -> TomlBiMap [a] AnyValue+_Array elementBimap = BiMap toAnyValue fromAnyValue+ where+ toAnyValue :: [a] -> Either TomlBiMapError AnyValue+ toAnyValue = mapM (forward elementBimap) >=> bimap WrongValue AnyValue . toMArray++ fromAnyValue :: AnyValue -> Either TomlBiMapError [a]+ fromAnyValue (AnyValue v) = matchElements (backward elementBimap) v++ -- can't reuse matchArray here :(+ matchElements :: (AnyValue -> Either TomlBiMapError a) -> Value t -> Either TomlBiMapError [a]+ matchElements match (Array a) = mapM (applyAsToAny match) a+ matchElements _ val = first WrongValue $ mkMatchError TArray val++{- | Takes a 'BiMap' of a value and returns a 'BiMap' for a 'NonEmpty'+list of values and 'AnyValue' as an array. Usually used as the+'Toml.Codec.Combinator.List.arrayNonEmptyOf' combinator.++@since 0.5.0+-}+_NonEmpty :: TomlBiMap a AnyValue -> TomlBiMap (NE.NonEmpty a) AnyValue+_NonEmpty bi = _NonEmptyList >>> _Array bi+{-# INLINE _NonEmpty #-}++{- | Helper 'BiMap' for lists and 'NE.NonEmpty'.++@since 1.3.0.0+-}+_NonEmptyList :: TomlBiMap (NE.NonEmpty a) [a]+_NonEmptyList = BiMap+ { forward = Right . NE.toList+ , backward = maybe (Left $ ArbitraryError "Empty array list, but expected NonEmpty") Right . NE.nonEmpty+ }+{-# INLINE _NonEmptyList #-}++{- | Takes a 'BiMap' of a value and returns a 'BiMap' for a 'Set' of+values and 'AnyValue' as an array. Usually used as the+'Toml.Codec.Combinator.Set.arraySetOf' combinator.++@since 0.5.0+-}+_Set :: (Ord a) => TomlBiMap a AnyValue -> TomlBiMap (S.Set a) AnyValue+_Set bi = iso S.toList S.fromList >>> _Array bi+{-# INLINE _Set #-}++{- | Takes a 'BiMap' of a value and returns a 'BiMap' for a 'HashSet' of+values and 'AnyValue' as an array. Usually used as the+'Toml.Codec.Combinator.Set.arrayHashSetOf' combinator.++@since 0.5.0+-}+_HashSet+#if MIN_VERSION_hashable(1,4,0)+ :: (Hashable a)+#else+ :: (Eq a, Hashable a)+#endif+ => TomlBiMap a AnyValue+ -> TomlBiMap (HS.HashSet a) AnyValue+_HashSet bi = iso HS.toList HS.fromList >>> _Array bi+{-# INLINE _HashSet #-}++{- | 'IS.IntSet' bimap for 'AnyValue'. Usually used as the+'Toml.Codec.Combinator.Set.arrayIntSet' combinator.++@since 0.5.0+-}+_IntSet :: TomlBiMap IS.IntSet AnyValue+_IntSet = iso IS.toList IS.fromList >>> _Array _Int+{-# INLINE _IntSet #-}++----------------------------------------------------------------------------+-- Coerce+----------------------------------------------------------------------------++{- | 'BiMap' for 'Coercible' values. It takes a 'TomlBiMap'+for @a@ type and returns a 'TomlBiMap' @b@ if these types are coercible.++It is supposed to be used to ease the work with @newtypes@.++E.g.++@+__newtype__ Foo = Foo+ { unFoo :: 'Int'+ }++fooBiMap :: 'TomlBiMap' Foo 'AnyValue'+fooBiMap = '_Coerce' '_Int'+@++@since 1.3.0.0+-}+_Coerce :: (Coercible a b) => TomlBiMap a AnyValue -> TomlBiMap b AnyValue+_Coerce = coerce+{-# INLINE _Coerce #-}++----------------------------------------------------------------------------+-- Custom+----------------------------------------------------------------------------++{- | Helper 'BiMap' for 'String' and types with 'Read' and 'Show' instances.++@since 0.5.0+-}+_ReadString :: (Show a, Read a) => TomlBiMap a String+_ReadString = BiMap (Right . show) (first (ArbitraryError . T.pack) . readEither)+{-# INLINE _ReadString #-}++{- | 'BiMap' for 'AnyValue' and values with a 'Read' and 'Show' instances.+Usually used as the 'Toml.Codec.Combinator.Custom.read' combinator.++@since 0.5.0+-}+_Read :: (Show a, Read a) => TomlBiMap a AnyValue+_Read = _ReadString >>> _String+{-# INLINE _Read #-}++{- | Creates 'BiMap' for 'Data.Text.Text' to 'AnyValue' with custom functions.+Usually used as the 'Toml.Codec.Combinator.Custom.textBy' combinator.++@since 0.5.0+-}+_TextBy+ :: forall a .+ (a -> Text) -- ^ @show@ function for @a@+ -> (Text -> Either Text a) -- ^ Parser of @a@ from 'Data.Text.Text'+ -> TomlBiMap a AnyValue+_TextBy toText parseText = BiMap toAnyValue fromAnyValue+ where+ toAnyValue :: a -> Either TomlBiMapError AnyValue+ toAnyValue = Right . AnyValue . Text . toText++ fromAnyValue :: AnyValue -> Either TomlBiMapError a+ fromAnyValue (AnyValue v) =+ first WrongValue (matchText v) >>= first ArbitraryError . parseText++{- | By the given 'BiMap' validates it with the given predicate that returns+'Either' the value, if the validation is successful, or the 'Text' of the error+that should be returned in case of validation failure.++Usually used as the 'Toml.Codec.Combinator.Custom.validate' or+'Toml.Codec.Combinator.Custom.validateIf' combinator.++@since 1.3.0.0+-}+_Validate :: forall a . (a -> Either Text a) -> TomlBiMap a AnyValue -> TomlBiMap a AnyValue+_Validate p BiMap{..} = BiMap forward backwardWithValidation+ where+ backwardWithValidation :: AnyValue -> Either TomlBiMapError a+ backwardWithValidation anyVal = backward anyVal >>= first ArbitraryError . p++{- | Helper 'BiMap' for '_EnumBounded' and 'Data.Text.Text'.++@since 1.1.0.0+-}+_EnumBoundedText :: forall a. (Show a, Enum a, Bounded a) => TomlBiMap a Text+_EnumBoundedText = BiMap+ { forward = Right . tShow+ , backward = toEnumBounded+ }+ where+ toEnumBounded :: Text -> Either TomlBiMapError a+ toEnumBounded value = case M.lookup value enumOptions of+ Just a -> Right a+ Nothing ->+ let msg = "Value is '" <> value <> "' but expected one of: " <> T.intercalate ", " options+ in Left (ArbitraryError msg)+ where+ enumOptions :: Map Text a+ enumOptions = M.fromList $ zip options enums+ options = fmap tShow enums+ enums = [minBound @a .. maxBound @a]++{- | 'BiMap' for nullary sum data types (enumerations) with 'Show',+'Enum' and 'Bounded' instances. Usually used as the+'Toml.Codec.Combinator.Custom.enumBounded' combinator.++@since 1.1.0.0+-}+_EnumBounded :: (Show a, Enum a, Bounded a) => TomlBiMap a AnyValue+_EnumBounded = _EnumBoundedText >>> _Text+{-# INLINE _EnumBounded #-}+++{- | 'BiMap' for hardcoded values.+It returns the same value in case of success and 'ArbitraryError' in other case.++@since 1.3.2.0+-}+_Hardcoded :: forall a . (Show a, Eq a) => a -> TomlBiMap a a+_Hardcoded a = BiMap+ { forward = const (Right a)+ , backward = checkValue+ }+ where+ checkValue :: a -> Either TomlBiMapError a+ checkValue v = if v == a+ then Right v+ else Left (ArbitraryError msg)+ where+ msg :: Text+ msg = "Value '" <> T.pack (show v)+ <> "' doesn't align with the hardcoded value '"+ <> T.pack (show a) <> "'"++----------------------------------------------------------------------------+-- Keys+----------------------------------------------------------------------------++{- | Bidirectional converter between 'Key' and+'Data.Text.Text'. Usually used as an argument for+'Toml.Codec.Combinator.Map.tableMap'.++@since 1.3.0.0+-}+_KeyText :: TomlBiMap Key Text+_KeyText = BiMap+ { forward = Right . prettyKey+ , backward = first (ArbitraryError . unTomlParseError) . parseKey+ }++{- | Bidirectional converter between 'Key' and 'String'. Usually used+as an argument for 'Toml.Codec.Combinator.Map.tableMap'.++@since 1.3.0.0+-}+_KeyString :: TomlBiMap Key String+_KeyString = BiMap+ { forward = Right . T.unpack . prettyKey+ , backward = first (ArbitraryError . unTomlParseError) . parseKey . T.pack+ }++{- | Bidirectional converter between 'Key' and 'Int'. Usually used+as an argument for 'Toml.Codec.Combinator.Map.tableIntMap'.++@since 1.3.0.0+-}+_KeyInt :: TomlBiMap Key Int+_KeyInt = BiMap+ { forward = first (ArbitraryError . T.pack) . readEither . T.unpack . prettyKey+ , backward = first (ArbitraryError . unTomlParseError) . parseKey . tShow+ }++----------------------------------------------------------------------------+-- General purpose bimaps+----------------------------------------------------------------------------++{- | 'BiMap' for 'Either' and its 'Left' part.++@since 0.4.0+-}+_Left :: (Show l, Show r) => TomlBiMap (Either l r) l+_Left = prism Left $ \case+ Left l -> Right l+ x -> wrongConstructor "Left" x++{- | 'BiMap' for 'Either' and its 'Right' part.++@since 0.4.0+-}+_Right :: (Show l, Show r) => TomlBiMap (Either l r) r+_Right = prism Right $ \case+ Right r -> Right r+ x -> wrongConstructor "Right" x++{- | 'BiMap' for 'Maybe' and its 'Just' part.++@since 0.5.0+-}+_Just :: Show r => TomlBiMap (Maybe r) r+_Just = prism Just $ \case+ Just r -> Right r+ x -> wrongConstructor "Just" x
+ src/Toml/Codec/Code.hs view
@@ -0,0 +1,159 @@+{- |+Module : Toml.Codec.Code+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++Conversion from textual representation of @TOML@ values to the Haskell data+types by the given 'TomlCodec'.++This module includes coding functions like 'decode' and 'encode'.+-}++module Toml.Codec.Code+ ( -- * Decode+ decode+ , decodeExact+ , decodeValidation+ , decodeFileEither+ , decodeFile+ , decodeFileExact+ -- * Encode+ , encode+ , encodeToFile+ -- * Run+ , runTomlCodec+ , execTomlCodec+ ) where++import Control.Exception (throwIO)+import Control.Monad.IO.Class (MonadIO (..))+import Data.Text (Text)+import Validation (Validation (..), validationToEither)++import Toml.Codec.Error (LoadTomlException (..), TomlDecodeError (..), prettyTomlDecodeErrors)+import Toml.Codec.Types (Codec (..), TomlCodec, TomlState (..))+import Toml.Parser (parse)+import Toml.Type (TOML (..), tomlDiff)+import Toml.Type.Printer (pretty)++import qualified Data.Text.IO as TIO+++{- | Convert textual representation of @TOML@ into user data type by the+provided codec.++@since 1.3.0.0+-}+decodeValidation :: TomlCodec a -> Text -> Validation [TomlDecodeError] a+decodeValidation codec text = case parse text of+ Left err -> Failure [ParseError err]+ Right toml -> runTomlCodec codec toml++{- | Convert textual representation of @TOML@ into user data type by the+provided codec.++@since 0.0.0+-}+decode :: TomlCodec a -> Text -> Either [TomlDecodeError] a+decode codec = validationToEither . decodeValidation codec++{- | Convert textual representation of @TOML@ into user data type by the+provided codec.++Unlike 'decode', this function returns 'NotExactDecode' error in case if given+@TOML@ has redundant fields and other elements.++@since 1.3.2.0+-}+decodeExact :: TomlCodec a -> Text -> Either [TomlDecodeError] a+decodeExact codec text = case parse text of+ Left err -> Left [ParseError err]+ Right toml -> case runTomlCodec codec toml of+ Failure errs -> Left errs+ Success a ->+ let tomlExpected = execTomlCodec codec a+ aDiff = tomlDiff toml tomlExpected in+ if aDiff == mempty+ then Right a+ else Left [NotExactDecode aDiff]++{- | Similar to 'decodeValidation', but takes a path to a file with textual @TOML@+values from which it decodes them with the provided codec.++@since 1.3.0.0+-}+decodeFileValidation+ :: forall a m . (MonadIO m)+ => TomlCodec a+ -> FilePath+ -> m (Validation [TomlDecodeError] a)+decodeFileValidation codec = fmap (decodeValidation codec) . liftIO . TIO.readFile++{- | Similar to 'decode', but takes a path to a file with textual @TOML@+values from which it decodes them with the provided codec.++@since 1.3.0.0+-}+decodeFileEither+ :: forall a m . (MonadIO m)+ => TomlCodec a+ -> FilePath+ -> m (Either [TomlDecodeError] a)+decodeFileEither codec = fmap validationToEither . decodeFileValidation codec++{- | Similar to 'decodeExact', but takes a path to a file with textual @TOML@+values from which it decodes them with the provided codec.++@since 1.3.2.0+-}+decodeFileExact+ :: forall a m . (MonadIO m)+ => TomlCodec a+ -> FilePath+ -> m (Either [TomlDecodeError] a)+decodeFileExact codec = fmap (decodeExact codec) . liftIO . TIO.readFile++{- | Similar to 'decodeFileEither', throws 'LoadTomlException' in case of parse+errors ('TomlDecodeError').++@since 0.3.1+-}+decodeFile :: forall a m . (MonadIO m) => TomlCodec a -> FilePath -> m a+decodeFile codec filePath = decodeFileEither codec filePath >>= errorWhenLeft+ where+ errorWhenLeft :: Either [TomlDecodeError] a -> m a+ errorWhenLeft (Left errs) =+ liftIO+ $ throwIO+ $ LoadTomlException filePath+ $ prettyTomlDecodeErrors errs+ errorWhenLeft (Right pc) = pure pc++{- | Convert data type to the textual representation of @TOML@ values.++@since 0.0.0+-}+encode :: TomlCodec a -> a -> Text+encode codec obj = pretty $ execTomlCodec codec obj++{- | Convert data type to the textual representation of @TOML@ values.+and write it info the given file.++@since 1.3.0.0+-}+encodeToFile :: forall a m . (MonadIO m) => TomlCodec a -> FilePath -> a -> m Text+encodeToFile codec filePath obj = content <$ liftIO (TIO.writeFile filePath content)+ where+ content :: Text+ content = encode codec obj++-- | Convert toml into user data type.+runTomlCodec :: TomlCodec a -> TOML -> Validation [TomlDecodeError] a+runTomlCodec = codecRead++-- | Runs 'codecWrite' of 'TomlCodec' and returns intermediate TOML AST.+execTomlCodec :: TomlCodec a -> a -> TOML+execTomlCodec codec obj = snd $ unTomlState (codecWrite codec obj) mempty
+ src/Toml/Codec/Combinator.hs view
@@ -0,0 +1,155 @@+{- |+Module : Toml.Codec.Combinator+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++Contains TOML-specific combinators for converting between TOML and user data+types.+-}++module Toml.Codec.Combinator+ ( -- * Basic codecs for primitive values+ -- $primitive+ module Toml.Codec.Combinator.Primitive+ -- ** Time types+ -- $time+ , module Toml.Codec.Combinator.Time++ -- * Combinators for tables+ -- $table+ , module Toml.Codec.Combinator.Table++ -- * Codecs for containers of primitives+ -- ** Lists+ -- $list+ , module Toml.Codec.Combinator.List+ -- ** Sets+ -- $set+ , module Toml.Codec.Combinator.Set+ -- ** Maps+ -- $map+ , module Toml.Codec.Combinator.Map+ -- ** Tuples+ -- $tuple+ , module Toml.Codec.Combinator.Tuple++ -- * Codecs for 'Monoid's+ -- $monoid+ , module Toml.Codec.Combinator.Monoid++ -- * Additional codecs for custom types+ -- $custom+ , module Toml.Codec.Combinator.Custom++ -- * General construction of codecs+ -- $common+ , module Toml.Codec.Combinator.Common+ ) where++import Prelude hiding (all, any, last, map, product, read, sum)++import Toml.Codec.Combinator.Common+import Toml.Codec.Combinator.Custom+import Toml.Codec.Combinator.List+import Toml.Codec.Combinator.Map+import Toml.Codec.Combinator.Monoid+import Toml.Codec.Combinator.Primitive+import Toml.Codec.Combinator.Set+import Toml.Codec.Combinator.Table+import Toml.Codec.Combinator.Time+import Toml.Codec.Combinator.Tuple++{- $primitive+TOML-specific combinators for converting between TOML and Haskell primitive+types, e.g. 'int' \<-\> 'Int', 'byteString' \<-\> 'ByteString'.++See the "Toml.Codec.Combinator.Primitive" module documentation for the overview+table and more examples.+-}++{- $time+TOML-specific combinators for converting between TOML and Haskell date and time+data types. TOML specification describes date and time primitives you+can use in your configuration. @tomland@ provides mapping of those+primitives to types from the @time@ library.++See the "Toml.Codec.Combinator.Time" module documentation for the overview+table and more examples.+-}++{- $table+Combinators for the @TOML@ tables.++See the "Toml.Codec.Combinator.Table" module documentation for more examples.+-}++{- $list+TOML-specific combinators for converting between TOML and Haskell list-like data+types.++See the "Toml.Codec.Combinator.List" module documentation for the overview+table and more examples.+-}++{- $set+TOML-specific combinators for converting between TOML and Haskell set-like data+types.++See the "Toml.Codec.Combinator.Set" module documentation for the overview+table and more examples.+-}++{- $map+TOML-specific combinators for converting between TOML and Haskell map-like data+types.++See the "Toml.Codec.Combinator.Map" module documentation for the overview+table and more examples.+-}++{- $tuple+TOML-specific combinators for converting between TOML and Haskell tuples.+It's recommended to create your custom data types and implement codecs+for them, but if you need to have tuples (e.g. for decoding different+constructors of sum types), you can find codecs from this module+helpful.++See the "Toml.Codec.Combinator.Tuple" module documentation for the overview+table and more examples.+-}++{- $monoid+TOML-specific combinators for converting between TOML and Haskell 'Monoid'+wrapper data types. These codecs are especially handy when you are implementing+the [Partial Options Monoid](https://medium.com/@jonathangfischoff/the-partial-options-monoid-pattern-31914a71fc67)+pattern.++See the "Toml.Codec.Combinator.Monoid" module documentation for the overview+table and more examples.+-}++{- $custom+This module provides additional combinators that could help in the situation+when some additional manipulations for the standard combinators is required.++/For example,/ 'validate' allows to perform some custom validation on the codec+before encoding. And 'enumBounded' is an automatical codec that uses 'Enum' and+'Bounded' instances of the data type only and provides descriptive error+messages at the same time.++See the "Toml.Codec.Combinator.Custom" module documentation for the overview+table and more examples.+-}++{- $common+This module implements common utilities for writing custom codecs+without diving into internal implementation details. Most of the time+you don't need to implement your own codecs and can reuse existing+ones. But if you need something that library doesn't provide, you can+find functions in this module useful.++See the "Toml.Codec.Combinator.Common" module documentation for more examples.+-}
+ src/Toml/Codec/Combinator/Common.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE FlexibleContexts #-}++{- |+Module : Toml.Codec.Combinator.Common+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++This module implements common utilities for writing custom codecs+without diving into internal implementation details. Most of the time+you don't need to implement your own codecs and can reuse existing+ones. But if you need something that library doesn't provide, you can+find functions in this module useful.++@since 1.3.0.0+-}++module Toml.Codec.Combinator.Common+ ( match+ , whenLeftBiMapError+ ) where++import Control.Monad.State (modify)+import Validation (Validation (..))++import Toml.Codec.BiMap (BiMap (..), TomlBiMap, TomlBiMapError)+import Toml.Codec.Error (TomlDecodeError (..))+import Toml.Codec.Types (Codec (..), TomlCodec, TomlEnv, TomlState, eitherToTomlState)+import Toml.Type.AnyValue (AnyValue (..))+import Toml.Type.Key (Key)+import Toml.Type.TOML (TOML (..), insertKeyAnyVal)++import qualified Data.HashMap.Strict as HashMap+++{- | General function to create bidirectional converters for key-value pairs. In+order to use this function you need to create 'TomlBiMap' for your type and+'AnyValue':++@+_MyType :: 'TomlBiMap' MyType 'AnyValue'+@++And then you can create codec for your type using 'match' function:++@+myType :: 'Key' -> 'TomlCodec' MyType+myType = 'match' _MyType+@++@since 0.4.0+-}+match :: forall a . TomlBiMap a AnyValue -> Key -> TomlCodec a+match BiMap{..} key = Codec input output+ where+ input :: TomlEnv a+ input = \toml -> case HashMap.lookup key (tomlPairs toml) of+ Nothing -> Failure [KeyNotFound key]+ Just anyVal -> whenLeftBiMapError key (backward anyVal) pure++ output :: a -> TomlState a+ output a = do+ anyVal <- eitherToTomlState $ forward a+ a <$ modify (insertKeyAnyVal key anyVal)++{- | Throw error on 'Left', or perform a given action with 'Right'.++@since 1.3.0.0+-}+whenLeftBiMapError+ :: Key+ -> Either TomlBiMapError a+ -> (a -> Validation [TomlDecodeError] b)+ -> Validation [TomlDecodeError] b+whenLeftBiMapError key val action = case val of+ Right a -> action a+ Left err -> Failure [BiMapError key err]
+ src/Toml/Codec/Combinator/Custom.hs view
@@ -0,0 +1,268 @@+{- |+Module : Toml.Codec.Combinator.Custom+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++Contains TOML-specific custom combinators for converting between TOML and+special user data types.++See examples below of the situations you may need the following combinators.++@since 1.3.0.0+-}++module Toml.Codec.Combinator.Custom+ ( -- * 'Text' combinators+ textBy+ , read+ , enumBounded+ , hardcoded++ -- * Validation+ , validate+ , validateIf+ ) where++import Prelude hiding (read)++import Control.Category ((>>>))+import Data.Text (Text)++import Toml.Codec.BiMap (TomlBiMap)+import Toml.Codec.BiMap.Conversion (_EnumBounded, _Read, _TextBy, _Validate, _Hardcoded)+import Toml.Codec.Combinator.Common (match)+import Toml.Codec.Types (TomlCodec)+import Toml.Type.AnyValue (AnyValue)+import Toml.Type.Key (Key)+import Toml.Type.Printer (prettyKey)+++{- | Codec for text values with custom error messages for parsing.++__Example:__++We have the following type that represents the image format:++@+__data__ Format+ = Jpeg+ | Png+ | Gif+ __deriving__ ('Show', 'Read', 'Enum')+@++But we want to be able to decode and encode this data type through the custom+text representation, that can be formilised in the following functions:++@+showFormat :: Format -> 'Text'+showFormat = \case+ Jpeg -> ".jpeg"+ Png -> ".png"+ Gif -> ".gif"++parseFormat :: 'Text' -> 'Either' 'Text' Format+parseFormat = __\case__+ ".jpeg" -> 'Right' Jpeg+ ".png" -> 'Right' Png+ ".gif" -> 'Right' Gif+ other -> 'Left' $ "Unsupported format: " <> other+@++To write the codec for @Format@ data type using the above rules we can use+'textBy' combinator:++@+formatCodec :: 'Key' -> 'TomlCodec' Format+formatCodec = 'textBy' showFormat parseFormat+@++And now with the @formatCodec "foo"@ we can have the following line in our+@TOML@ perfectly encoded:++@+foo = ".gif"+@++But the @foo = "jif"@ will lead to the following error:++@+tomland decode error: Unsupported format: jif+@++@since 1.0.0+-}+textBy :: (a -> Text) -> (Text -> Either Text a) -> Key -> TomlCodec a+textBy to from = match (_TextBy to from)+{-# INLINE textBy #-}+++{- | Codec for values with a 'Read' and 'Show' instance.++__Example:__++We have the following type that represents the image format:++@+__data__ Format+ = Jpeg+ | Png+ | Gif+ deriving (Show, Read, Enum)+@++And we want to be able to decode and encode this data type through the 'Show'+and 'Read' instances.++To write the codec for @Format@ data type using the existing instances we can+use 'read' combinator. And now with the @Toml.'read' "foo"@ we can have the+following line in our @TOML@ perfectly encoded:++@+foo = "Gif"+@++But the @foo = ".gif"@ will lead to the following error:++@+tomland decode error: Prelude.read: no parse+@++@since 0.5.0+-}+read :: (Show a, Read a) => Key -> TomlCodec a+read = match _Read+{-# INLINE read #-}++{- | Codec for general nullary sum data types with a 'Bounded', 'Enum', and+'Show' instance. This codec is similar to 'read' but provides much better error+messages than 'read' for nullary sum types.++E.g. for the same @Format@ example from 'read' function, but with the+@Toml.'enumBounded' "foo"@ codec the error for @foo = \"Jif\"@ in the @TOML@ file+will look like this:++@+tomland decode error: Value is 'Jif' but expected one of: Jpeg, Png, Gif+@++@since 1.1.0.0+-}+enumBounded :: (Bounded a, Enum a, Show a) => Key -> TomlCodec a+enumBounded = match _EnumBounded+{-# INLINE enumBounded #-}++{- | Codec for hardcoded provided values and its 'BiMap'.++If you want to decode a single key-value pair where only one value is allowed.+Like in the example below:++@+scope = "all"+@++To decode that you could use the following function:++@+Toml.hardcoded "all" Toml._Text "scope"+@++in case if the value in @TOML@ is not the same as hardcoded, you will get the following error:++@+tomland decode error: BiMap error in key 'scope' : Value '"foo"' doesn't align with the hardcoded value '"all"'+@++@since 1.3.2.0+-}+hardcoded :: (Show a, Eq a) => a -> TomlBiMap a AnyValue -> Key -> TomlCodec a+hardcoded a aBm = match (_Hardcoded a >>> aBm)++{- | Codec that checks the 'BiMap' on the given predicate.+The predicate function returns the value, if the validation is successful, or+the 'Text' of the error that should be returned in case of validation failure.++__Example:__++Let's imagine that we want to have the list in @TOML@ that could only+have even 'Int's inside. In this case, you can write the following codec:++@+allEven :: ['Int'] -> 'Either' 'Text' ['Int']+allEven xs =+ if all even xs+ then 'Right' xs+ else 'Left' "This is wrong, I asked you for even only :("++allEvenCodec :: 'TomlCodec' ['Int']+allEvenCodec = Toml.'validate' allEven (Toml._Array Toml._Int) \"myEvenList\"+@++Then in your @TOML@ file you can have:++@+myEvenList = [2, 4, 6]+@++But the following one will lead to the error:++@+myEvenList = [1, 2, 3]+@++@+tomland decode error: This is wrong, I asked you for even only :(+@++@since 1.3.0.0+-}+validate :: (a -> Either Text a) -> TomlBiMap a AnyValue -> Key -> TomlCodec a+validate p biMap = match (_Validate p biMap)+{-# INLINE validate #-}++{- | Similar to 'validate' but takes the predicate that returnes 'Bool'.+The error in case of the validation failure looks like this:++@+Value does not pass the validation for key: KEY_NAME+@++__Example:__++Let's imagine that we want to have the 'Text' field in @TOML@ that could only+have 3 chars in it. In this case, you can write the following codec:++@+my3charTextCodec :: TomlCodec Text+my3CharTextCodec = Toml.'validateIf' ((==) 3 . Text.length) Toml._Text "myKeyName"+@++The in your @TOML@ file you can have:++@+myKeyName = "abc"+@++But the following one will lead to the error:++@+myKeyName = "I have more than enough"+@++@+tomland decode error: Value does not pass the validation for key: myKeyName+@++@since 1.3.0.0+-}+validateIf :: forall a . (a -> Bool) -> TomlBiMap a AnyValue -> Key -> TomlCodec a+validateIf p biMap k = validate validateEither biMap k+ where+ validateEither :: a -> Either Text a+ validateEither a =+ if p a+ then Right a+ else Left $ "Value does not pass the validation for key: " <> prettyKey k
+ src/Toml/Codec/Combinator/List.hs view
@@ -0,0 +1,225 @@+{- |+Module : Toml.Codec.Combinator.List+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++TOML-specific combinators for converting between TOML and Haskell list-like data+types.++There are two way to represent list-like structures with the @tomland@ library.++* Ordinary array lists of primitives:++ @+ foo = [100, 200, 300]+ @++* Lists via tables:++ @+ foo =+ [ {x = 100}+ , {x = 200}+ , {x = 300}+ ]++ __OR__++ [[foo]]+ x = 100+ [[foo]]+ x = 200+ [[foo]]+ x = 300+ @++You can find both types of the codecs in this module for different list-like+structures. See the following table for the better understanding:+++-------------------------+----------------------------------+-------------------------------------++| Haskell Type | @TOML@ | 'TomlCodec' |++=========================+==================================+=====================================++| __@['Int']@__ | @a = [1, 2, 3]@ | @'arrayOf' 'Toml._Int' "a"@ |++-------------------------+----------------------------------+-------------------------------------++| __@'NonEmpty' 'Int'@__ | @a = [11, 42]@ | @'arrayNonEmptyOf' 'Toml._Int' "a"@ |++-------------------------+----------------------------------+-------------------------------------++| __@['Text']@__ | @x = [{a = "foo"}, {a = "bar"}]@ | @'list' ('Toml.text' "a") "x"@ |++-------------------------+----------------------------------+-------------------------------------++| __@'NonEmpty' 'Text'@__ | @x = [{a = "foo"}, {a = "bar"}]@ | @'nonEmpty' ('Toml.text' "a") "x"@ |++-------------------------+----------------------------------+-------------------------------------+++@since 1.3.0.0+-}++module Toml.Codec.Combinator.List+ ( -- * Array lists+ arrayOf+ , arrayNonEmptyOf++ -- * Table lists+ , list+ , nonEmpty+ ) where++import Control.Monad.State (gets, modify)+import Data.List.NonEmpty (NonEmpty (..), toList)+import Validation (Validation (..))++import Toml.Codec.BiMap (TomlBiMap)+import Toml.Codec.BiMap.Conversion (_Array, _NonEmpty)+import Toml.Codec.Code (execTomlCodec)+import Toml.Codec.Combinator.Common (match)+import Toml.Codec.Combinator.Table (handleTableErrors)+import Toml.Codec.Error (TomlDecodeError (..))+import Toml.Codec.Types (Codec (..), TomlCodec, TomlEnv, TomlState)+import Toml.Type.AnyValue (AnyValue (..))+import Toml.Type.Key (Key)+import Toml.Type.TOML (TOML (..), insertTableArrays)++import qualified Data.HashMap.Strict as HashMap+++{- | Codec for list of values. Takes converter for single value and+returns a list of values.++__Example:__++Haskell @['Int']@ can look like this in your @TOML@ file:++@+foo = [1, 2, 3]+@++If the key is not present in @TOML@ the following decode error will be spotted:++@+tomland decode error: Key foo is not found+@++@since 0.1.0+-}+arrayOf :: TomlBiMap a AnyValue -> Key -> TomlCodec [a]+arrayOf = match . _Array+{-# INLINE arrayOf #-}++{- | Codec for non- empty lists of values. Takes converter for single value and+returns a non-empty list of values.++__Example:__++Haskell @'NonEmpty' 'Int'@ can look like this in your @TOML@ file:++@+foo = [1, 2, 3]+@++If you try to decode an empty @TOML@ list you will see the error:++@+tomland decode error: Empty array list, but expected NonEmpty+@++If the key is not present in @TOML@ the following decode error will be spotted:++@+tomland decode error: Key foo is not found+@++@since 0.5.0+-}+arrayNonEmptyOf :: TomlBiMap a AnyValue -> Key -> TomlCodec (NonEmpty a)+arrayNonEmptyOf = match . _NonEmpty+{-# INLINE arrayNonEmptyOf #-}++{- | 'Codec' for list of values. Represented in TOML as array of tables.++__Example:__++Haskell @['Int']@ can look like this in your @TOML@ file:++@+foo =+ [ {a = 1}+ , {a = 2}+ , {a = 3}+ ]+@++Decodes to an empty list @[]@ when the key is not present.++@since 1.0.0+-}+list :: forall a . TomlCodec a -> Key -> TomlCodec [a]+list codec key = Codec+ { codecRead = \toml -> case codecRead nonEmptyCodec toml of+ Success ne -> Success $ toList ne+ Failure [TableArrayNotFound errKey]+ | errKey == key -> pure []+ Failure errs -> Failure errs+ , codecWrite = \case+ [] -> pure []+ l@(x:xs) -> l <$ codecWrite nonEmptyCodec (x :| xs)+ }+ where+ nonEmptyCodec :: TomlCodec (NonEmpty a)+ nonEmptyCodec = nonEmpty codec key+++{- | 'Codec' for 'NonEmpty' list of values. Represented in TOML as array of+tables.++__Example:__++Haskell @'NonEmpty' 'Int'@ can look like this in your @TOML@ file:++@+foo =+ [ {a = 1}+ , {a = 2}+ , {a = 3}+ ]+@++If you try to decode an empty @TOML@ list you will see the error:++@+tomland decode error: Table array [[foo]] is not found+@++or++@+tomland decode error: Key foo.a is not found+@++If the key is not present in @TOML@ the following decode error will be spotted:++@+tomland decode error: Table array [[foo]] is not found+@++@since 1.0.0+-}+nonEmpty :: forall a . TomlCodec a -> Key -> TomlCodec (NonEmpty a)+nonEmpty codec key = Codec input output+ where+ input :: TomlEnv (NonEmpty a)+ input = \t -> case HashMap.lookup key $ tomlTableArrays t of+ Nothing -> Failure [TableArrayNotFound key]+ Just tomls -> traverse (handleTableErrors codec key) tomls+++ -- adds all TOML objects to the existing list if there are some+ output :: NonEmpty a -> TomlState (NonEmpty a)+ output as = do+ let tomls = fmap (execTomlCodec codec) as+ mTables <- gets $ HashMap.lookup key . tomlTableArrays++ let newTomls = case mTables of+ Nothing -> tomls+ Just oldTomls -> oldTomls <> tomls++ as <$ modify (insertTableArrays key newTomls)
+ src/Toml/Codec/Combinator/Map.hs view
@@ -0,0 +1,413 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TupleSections #-}++{- |+Module : Toml.Codec.Combinator.Map+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++TOML-specific combinators for converting between TOML and Haskell Map-like data+types.++There are two way to represent map-like structures with the @tomland@ library.++* Map structure with the key and value represented as key-value pairs:++ @+ foo =+ [ {myKey = "name", myVal = 42}+ , {myKey = "otherName", myVal = 100}+ ]+ @++* Map structure as a table with the @TOML@ key as the map key:++ @+ [foo]+ name = 42+ otherName = 100+ @++You can find both types of the codecs in this module for different map-like+structures. See the following table for the heads up:+++------------------------------+--------------------------------+----------------------------------------------------++| Haskell Type | @TOML@ | 'TomlCodec' |++==============================+================================+====================================================++| __@'Map' 'Int' 'Text'@__ | @x = [{k = 42, v = "foo"}]@ | @'map' ('Toml.int' "k") ('Toml.text' "v") "x"@ |++------------------------------+--------------------------------+----------------------------------------------------++| __@'Map' 'Text' 'Int'@__ | @x = {a = 42, b = 11}@ | @'tableMap' 'Toml._KeyText' 'Toml.int' "x"@ |++------------------------------+--------------------------------+----------------------------------------------------++| __@'HashMap' 'Int' 'Text'@__ | @x = [{k = 42, v = "foo"}]@ | @'hashMap' ('Toml.int' "k") ('Toml.text' "v") "x"@ |++------------------------------+--------------------------------+----------------------------------------------------++| __@'HashMap' 'Text' 'Int'@__ | @x = {a = 42, b = 11}@ | @'tableHashMap' 'Toml._KeyText' 'Toml.int' "x"@ |++------------------------------+--------------------------------+----------------------------------------------------++| __@'IntMap' 'Text'@__ | @x = [{k = 42, v = "foo"}]@ | @'intMap' ('Toml.int' "k") ('Toml.text' "v") "x"@ |++------------------------------+--------------------------------+----------------------------------------------------++| __@'IntMap' 'Text'@__ | @x = {1 = "one", 2 = "two"}@ | @'tableIntMap' 'Toml._KeyInt' 'Toml.text' "x"@ |++------------------------------+--------------------------------+----------------------------------------------------+++__Note:__ in case of the missing key on the @TOML@ side an empty map structure+is returned.++@since 1.3.0.0+-}++module Toml.Codec.Combinator.Map+ ( -- * 'Map' codecs+ map+ , tableMap+ -- * 'HashMap' codecs+ , hashMap+ , tableHashMap+ -- * 'IntMap' codecs+ , intMap+ , tableIntMap+ ) where++import Prelude hiding (map)++import Control.Applicative (empty)+import Control.Monad (forM_)+import Control.Monad.State (gets, modify)+import Data.HashMap.Strict (HashMap)+import Data.Hashable (Hashable)+import Data.IntMap.Strict (IntMap)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map.Strict (Map)+import Data.Maybe (fromMaybe)+import Data.Traversable (for)+import Validation (Validation (..))++import Toml.Codec.BiMap (BiMap (..), TomlBiMap)+import Toml.Codec.Code (execTomlCodec)+import Toml.Codec.Combinator.Common (whenLeftBiMapError)+import Toml.Codec.Types (Codec (..), TomlCodec, TomlEnv, TomlState (..))+import Toml.Type.Key (Key, pattern (:||))+import Toml.Type.TOML (TOML (..), insertTable, insertTableArrays)++import qualified Data.HashMap.Strict as HashMap+import qualified Data.IntMap.Strict as IntMap+import qualified Data.List.NonEmpty as NE+import qualified Data.Map.Strict as Map++import qualified Toml.Type.PrefixTree as Prefix+++{- | Bidirectional codec for 'Map'. It takes birectional converter for keys and+values and produces bidirectional codec for 'Map'. Currently it works only with array+of tables, so you need to specify 'Map's in TOML files like this:++@+myMap =+ [ { name = "foo", payload = 42 }+ , { name = "bar", payload = 69 }+ ]+@++'TomlCodec' for such TOML field can look like this:++@+Toml.'map' (Toml.'text' "name") (Toml.'int' "payload") "myMap"+@++If there's no key with the name @"myMap"@ then empty 'Map' is returned.++@since 1.2.1.0+-}+map :: forall k v .+ Ord k+ => TomlCodec k -- ^ Codec for 'Map' keys+ -> TomlCodec v -- ^ Codec for 'Map' values+ -> Key -- ^ TOML key where 'Map' is stored+ -> TomlCodec (Map k v) -- ^ Codec for the 'Map'+map = internalMap Map.empty Map.toList Map.fromList++{- | This 'TomlCodec' helps you to convert TOML key-value pairs+directly to 'Map' using TOML keys as 'Map' keys. It can be convenient+if your 'Map' keys are types like 'Text' or 'Int' and you want to work with raw+TOML keys directly.++For example, if you have TOML like this:++@+[colours]+yellow = "#FFFF00"+red = { red = 255, green = 0, blue = 0 }+pink = "#FFC0CB"+@++You want to convert such TOML configuration into the following Haskell+types:+++@+__data__ Rgb = Rgb+ { rgbRed :: Int+ , rgbGreen :: Int+ , rgbBlue :: Int+ }++__data__ Colour+ = Hex Text+ | RGB Rgb++colourCodec :: 'TomlCodec' Colour+colourCodec = ...++__data__ ColourConfig = ColourConfig+ { configColours :: 'Map' 'Text' Colour+ }+@++And you want in the result to have a 'Map' like this:++@+'Map.fromList'+ [ "yellow" -> Hex "#FFFF00"+ , "pink" -> Hex "#FFC0CB"+ , "red" -> Rgb 255 0 0+ ]+@++You can use 'tableMap' to define 'TomlCodec' in the following way:++@+colourConfigCodec :: 'TomlCodec' ColourConfig+colourConfigCodec = ColourConfig+ \<$\> Toml.'tableMap' Toml._KeyText colourCodec "colours" .= configColours+@++__Hint:__ You can use 'Toml.Codec.BiMap._KeyText' or+'Toml.Codec.BiMap._KeyString' to convert betwen TOML keys and 'Map'+keys (or you can write your custom 'TomlBiMap').++__NOTE__: Unlike the 'map' codec, this codec is less flexible (i.e. it doesn't+allow to have arbitrary structures as 'Key's, it works only for+text-like keys), but can be helpful if you want to save a few+keystrokes during TOML configuration. A similar TOML configuration,+but suitable for the 'map' codec will look like this:++@+colours =+ [ { key = "yellow", hex = "#FFFF00" }+ , { key = "pink", hex = "#FFC0CB" }+ , { key = "red", rgb = { red = 255, green = 0, blue = 0 } }+ ]+@++@since 1.3.0.0+-}+tableMap+ :: forall k v+ . Ord k+ => TomlBiMap Key k+ -- ^ Bidirectional converter between TOML 'Key's and 'Map' keys+ -> (Key -> TomlCodec v)+ -- ^ Codec for 'Map' values for the corresponding 'Key'+ -> Key+ -- ^ Table name for 'Map'+ -> TomlCodec (Map k v)+tableMap = internalTableMap Map.empty Map.toList Map.fromList++{- | Bidirectional codec for 'HashMap'. It takes birectional converter for keys and+values and produces bidirectional codec for 'HashMap'. It works with array of+tables, so you need to specify 'HashMap's in TOML files like this:++@+myHashMap =+ [ { name = "foo", payload = 42 }+ , { name = "bar", payload = 69 }+ ]+@++'TomlCodec' for such TOML field can look like this:++@+Toml.'hashMap' (Toml.'text' "name") (Toml.'int' "payload") "myHashMap"+@++If there's no key with the name @"myHashMap"@ then empty 'HashMap' is returned.++@since 1.3.0.0+-}+hashMap+ :: forall k v+#if MIN_VERSION_hashable(1,4,0)+ . (Hashable k)+#else+ . (Eq k, Hashable k)+#endif+ => TomlCodec k -- ^ Codec for 'HashMap' keys+ -> TomlCodec v -- ^ Codec for 'HashMap' values+ -> Key -- ^ TOML key where 'HashMap' is stored+ -> TomlCodec (HashMap k v) -- ^ Codec for the 'HashMap'+hashMap = internalMap HashMap.empty HashMap.toList HashMap.fromList++{- | This 'TomlCodec' helps to convert TOML key-value pairs+directly to 'HashMap' using TOML keys as 'HashMap' keys.+It can be convenient if your 'HashMap' keys are types like 'Text' or 'Int' and+you want to work with raw TOML keys directly.++For example, if you can write your 'HashMap' in @TOML@ like this:++@+[myHashMap]+key1 = "value1"+key2 = "value2"+@++@since 1.3.0.0+-}+tableHashMap+ :: forall k v+#if MIN_VERSION_hashable(1,4,0)+ . (Hashable k)+#else+ . (Eq k, Hashable k)+#endif+ => TomlBiMap Key k+ -- ^ Bidirectional converter between TOML 'Key's and 'HashMap' keys+ -> (Key -> TomlCodec v)+ -- ^ Codec for 'HashMap' values for the corresponding 'Key'+ -> Key+ -- ^ Table name for 'HashMap'+ -> TomlCodec (HashMap k v)+tableHashMap = internalTableMap HashMap.empty HashMap.toList HashMap.fromList++{- | Bidirectional codec for 'IntMap'. It takes birectional converter for keys and+values and produces bidirectional codec for 'IntMap'. It works with array of+tables, so you need to specify 'IntMap's in TOML files like this:++@+myIntMap =+ [ { name = "foo", payload = 42 }+ , { name = "bar", payload = 69 }+ ]+@++'TomlCodec' for such TOML field can look like this:++@+Toml.'intMap' (Toml.'text' "name") (Toml.'int' "payload") "myIntMap"+@++If there's no key with the name @"myIntMap"@ then empty 'IntMap' is returned.++@since 1.3.0.0+-}+intMap+ :: forall v+ . TomlCodec Int -- ^ Codec for 'IntMap' keys+ -> TomlCodec v -- ^ Codec for 'IntMap' values+ -> Key -- ^ TOML key where 'IntMap' is stored+ -> TomlCodec (IntMap v) -- ^ Codec for the 'IntMap'+intMap = internalMap IntMap.empty IntMap.toList IntMap.fromList++{- | This 'TomlCodec' helps to convert TOML key-value pairs+directly to 'IntMap' using TOML 'Int' keys as 'IntMap' keys.++For example, if you can write your 'IntMap' in @TOML@ like this:++@+[myIntMap]+1 = "value1"+2 = "value2"+@++@since 1.3.0.0+-}+tableIntMap+ :: forall v+ . TomlBiMap Key Int+ -- ^ Bidirectional converter between TOML 'Key's and 'IntMap' keys+ -> (Key -> TomlCodec v)+ -- ^ Codec for 'IntMap' values for the corresponding 'Key'+ -> Key+ -- ^ Table name for 'IntMap'+ -> TomlCodec (IntMap v)+tableIntMap = internalTableMap IntMap.empty IntMap.toList IntMap.fromList+++----------------------------------------------------------------------------+-- Internal+----------------------------------------------------------------------------++internalMap :: forall map k v+ . map -- ^ empty map+ -> (map -> [(k, v)]) -- ^ toList function+ -> ([(k, v)] -> map) -- ^ fromList function+ -> TomlCodec k -- ^ Codec for Map keys+ -> TomlCodec v -- ^ Codec for Map values+ -> Key -- ^ TOML key where Map is stored+ -> TomlCodec map -- ^ Codec for the Map+internalMap emptyMap toListMap fromListMap keyCodec valCodec key = Codec input output+ where+ input :: TomlEnv map+ input = \t -> case HashMap.lookup key $ tomlTableArrays t of+ Nothing -> Success emptyMap+ Just tomls -> fmap fromListMap $ for (NE.toList tomls) $ \toml -> do+ k <- codecRead keyCodec toml+ v <- codecRead valCodec toml+ pure (k, v)++ output :: map -> TomlState map+ output dict = do+ let tomls = fmap+ (\(k, v) -> execTomlCodec keyCodec k <> execTomlCodec valCodec v)+ (toListMap dict)++ mTables <- gets $ HashMap.lookup key . tomlTableArrays++ let updateAction :: TOML -> TOML+ updateAction = case mTables of+ Nothing -> case tomls of+ [] -> id+ t:ts -> insertTableArrays key (t :| ts)+ Just (t :| ts) ->+ insertTableArrays key $ t :| (ts ++ tomls)++ dict <$ modify updateAction++internalTableMap+ :: forall map k v+ . map -- ^ empty map+ -> (map -> [(k, v)]) -- ^ toList function+ -> ([(k, v)] -> map) -- ^ fromList function+ -> TomlBiMap Key k+ -- ^ Bidirectional converter between TOML 'Key's and Map keys+ -> (Key -> TomlCodec v)+ -- ^ Codec for Map values for the corresponding 'Key'+ -> Key+ -- ^ Table name for Map+ -> TomlCodec map+internalTableMap emptyMap toListMap fromListMap keyBiMap valCodec tableName =+ Codec input output+ where+ input :: TomlEnv map+ input = \t -> case Prefix.lookup tableName $ tomlTables t of+ Nothing -> Success emptyMap+ Just toml ->+ let valKeys = HashMap.keys $ tomlPairs toml+ tableKeys = fmap (:|| []) $ HashMap.keys $ tomlTables toml+ tableArrayKey = HashMap.keys $ tomlTableArrays toml+ in fmap fromListMap $ for (valKeys <> tableKeys <> tableArrayKey) $ \key ->+ whenLeftBiMapError key (forward keyBiMap key) $ \k ->+ (k,) <$> codecRead (valCodec key) toml++ output :: map -> TomlState map+ output m = do+ mTable <- gets $ Prefix.lookup tableName . tomlTables+ let toml = fromMaybe mempty mTable+ let (_, newToml) = unTomlState updateMapTable toml+ m <$ modify (insertTable tableName newToml)+ where+ updateMapTable :: TomlState ()+ updateMapTable = forM_ (toListMap m) $ \(k, v) -> case backward keyBiMap k of+ Left _ -> empty+ Right key -> codecWrite (valCodec key) v
+ src/Toml/Codec/Combinator/Monoid.hs view
@@ -0,0 +1,117 @@+{- |+Module : Toml.Codec.Combinator.Monoid+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++TOML-specific combinators for converting between TOML and Haskell 'Monoid'+wrapper data types. These codecs are especially handy when you are implementing+the [Partial Options Monoid](https://medium.com/@jonathangfischoff/the-partial-options-monoid-pattern-31914a71fc67)+pattern.+++-----------------------+------------+----------------------------+---------------------++| Haskell Type | @TOML@ | 'TomlCodec' | Default on |+| | | | missing field |++=======================+============+============================+=====================++| __'All'__ | @a = true@ | @'all' "a"@ | @'All' 'True'@ |++-----------------------+------------+----------------------------+---------------------++| __'Any'__ | @a = true@ | @'any' "a"@ | @'Any' 'False'@ |++-----------------------+------------+----------------------------+---------------------++| __@'Sum' 'Int'@__ | @a = 11@ | @'sum' 'Toml.int' "a"@ | @'Sum' 0@ |++-----------------------+------------+----------------------------+---------------------++| __@'Product' 'Int'@__ | @a = 11@ | @'product' 'Toml.int' "a"@ | @'Product' 1@ |++-----------------------+------------+----------------------------+---------------------++| __@'First' 'Int'@__ | @a = 42@ | @'first' 'Toml.int' "a"@ | @'First' 'Nothing'@ |++-----------------------+------------+----------------------------+---------------------++| __@'Last' 'Bool'@__ | @a = true@ | @'last' 'Toml.bool' "a"@ | @'Last' 'Nothing'@ |++-----------------------+------------+----------------------------+---------------------+++@since 1.3.0.0+-}++module Toml.Codec.Combinator.Monoid+ ( -- * Codecs for 'Monoid's+ -- ** Bool wrappers+ all+ , any+ -- ** 'Num' wrappers+ , sum+ , product+ -- ** 'Maybe' wrappers+ , first+ , last+ ) where++import Prelude hiding (all, any, last, product, sum)++import Data.Monoid (All (..), Any (..), First (..), Last (..), Product (..), Sum (..))++import Toml.Codec.Combinator.Primitive (bool)+import Toml.Codec.Di (dimap, dioptional, diwrap)+import Toml.Codec.Types (TomlCodec)+import Toml.Type.Key (Key)+++{- | Codec for 'All' wrapper for boolean values.+Returns @'All' 'True'@ on missing fields.++Decodes to @'All' 'True'@ when the key is not present.++@since 1.2.1.0+-}+all :: Key -> TomlCodec All+all = dimap (Just . getAll) (maybe mempty All) . dioptional . bool+{-# INLINE all #-}++{- | Codec for 'Any' wrapper for boolean values.+Returns @'Any' 'False'@ on missing fields.++Decodes to @'Any' 'False'@ when the key is not present.++@since 1.2.1.0+-}+any :: Key -> TomlCodec Any+any = dimap (Just . getAny) (maybe mempty Any) . dioptional . bool+{-# INLINE any #-}++{- | Codec for 'Sum' wrapper for given converter's values.++Decodes to @'Sum' 0@ when the key is not present.++@since 1.2.1.0+-}+sum :: (Num a) => (Key -> TomlCodec a) -> Key -> TomlCodec (Sum a)+sum codec = dimap (Just . getSum) (maybe mempty Sum) . dioptional . codec+{-# INLINE sum #-}++{- | Codec for 'Product' wrapper for given converter's values.++Decodes to @'Product' 1@ when the key is not present.++@since 1.2.1.0+-}+product :: (Num a) => (Key -> TomlCodec a) -> Key -> TomlCodec (Product a)+product codec = dimap (Just . getProduct) (maybe mempty Product) . dioptional . codec+{-# INLINE product #-}++{- | Codec for 'First' wrapper for given converter's values.++Decodes to @'First' 'Nothing'@ when the key is not present.++@since 1.2.1.0+-}+first :: (Key -> TomlCodec a) -> Key -> TomlCodec (First a)+first codec = diwrap . dioptional . codec+{-# INLINE first #-}++{- | Codec for 'Last' wrapper for given converter's values.++Decodes to @'Last' 'Nothing'@ when the key is not present.++@since 1.2.1.0+-}+last :: (Key -> TomlCodec a) -> Key -> TomlCodec (Last a)+last codec = diwrap . dioptional . codec+{-# INLINE last #-}
+ src/Toml/Codec/Combinator/Primitive.hs view
@@ -0,0 +1,208 @@+{- |+Module : Toml.Codec.Combinator.Primitive+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++TOML-specific combinators for converting between TOML and Haskell primitive+types, e.g. 'Int', 'ByteString'.++For the overall picture you can see how different types are represented by+codecs in the following table:+++---------------------------+-----------------+---------------------------++| Haskell Type | @TOML@ | 'TomlCodec' |++===========================+=================+===========================++| 'Bool' | @a = true@ | 'bool' "a" |++---------------------------+-----------------+---------------------------++| 'Integer' | @a = 100@ | 'integer' "a" |++---------------------------+-----------------+---------------------------++| 'Int' | @a = -42@ | 'int' "a" |++---------------------------+-----------------+---------------------------++| 'Natural' | @a = 11@ | 'natural' "a" |++---------------------------+-----------------+---------------------------++| 'Word' | @a = 1@ | 'word' "a" |++---------------------------+-----------------+---------------------------++| 'Word8' | @a = 1@ | 'word8' "a" |++---------------------------+-----------------+---------------------------++| 'Double' | @a = 36.6@ | 'double' "a" |++---------------------------+-----------------+---------------------------++| 'Float' | @a = -100.09@ | 'float' "a" |++---------------------------+-----------------+---------------------------++| 'String' | @a = \"Hello\"@ | 'string' "a" |++---------------------------+-----------------+---------------------------++| 'Text' | @a = \"Hello\"@ | 'text' "a" |++---------------------------+-----------------+---------------------------++| Lazy'L.Text' | @a = \"Hey\"@ | 'lazyText' "a" |++---------------------------+-----------------+---------------------------++| 'ByteString' | @a = \"Hello\"@ | 'byteString' "a" |++---------------------------+-----------------+---------------------------++| Lazy'BL.ByteString' | @a = \"Hey\"@ | 'lazyByteString' "a" |++---------------------------+-----------------+---------------------------++| 'ByteString' as Array | @a = [10, 15]@ | 'byteStringArray' "a" |++---------------------------+-----------------+---------------------------++| Lazy'ByteString' as Array | @a = [15, 10]@ | 'lazyByteStringArray' "a" |++---------------------------+-----------------+---------------------------+++@since 1.3.0.0+-}++module Toml.Codec.Combinator.Primitive+ ( -- * Boolean+ bool+ -- * Integral numbers+ , integer+ , int+ , natural+ , word+ , word8+ -- * Floating point numbers+ , double+ , float+ -- * Text types+ , string+ , text+ , lazyText+ , byteString+ , lazyByteString+ , byteStringArray+ , lazyByteStringArray+ ) where++import Data.ByteString (ByteString)+import Data.Text (Text)+import Data.Word (Word8)+import Numeric.Natural (Natural)++import Toml.Codec.BiMap.Conversion (_Bool, _ByteString, _ByteStringArray, _Double, _Float, _Int,+ _Integer, _LByteString, _LByteStringArray, _LText, _Natural,+ _String, _Text, _Word, _Word8)+import Toml.Codec.Combinator.Common (match)+import Toml.Codec.Types (TomlCodec)+import Toml.Type.Key (Key)++import qualified Data.ByteString.Lazy as BL+import qualified Data.Text.Lazy as L+++{- | Codec for boolean values.++@since 0.0.0+-}+bool :: Key -> TomlCodec Bool+bool = match _Bool+{-# INLINE bool #-}++{- | Codec for integer values.++@since 0.1.0+-}+integer :: Key -> TomlCodec Integer+integer = match _Integer+{-# INLINE integer #-}++{- | Codec for integer values.++@since 0.0.0+-}+int :: Key -> TomlCodec Int+int = match _Int+{-# INLINE int #-}++{- | Codec for natural values.++@since 0.5.0+-}+natural :: Key -> TomlCodec Natural+natural = match _Natural+{-# INLINE natural #-}++{- | Codec for word values.++@since 0.5.0+-}+word :: Key -> TomlCodec Word+word = match _Word+{-# INLINE word #-}++{- | Codec for word8 values.++@since 1.2.0.0+-}+word8 :: Key -> TomlCodec Word8+word8 = match _Word8+{-# INLINE word8 #-}++{- | Codec for floating point values with double precision.++@since 0.0.0+-}+double :: Key -> TomlCodec Double+double = match _Double+{-# INLINE double #-}++{- | Codec for floating point values.++@since 0.5.0+-}+float :: Key -> TomlCodec Float+float = match _Float+{-# INLINE float #-}++{- | Codec for string values.++@since 0.4.0+-}+string :: Key -> TomlCodec String+string = match _String+{-# INLINE string #-}++{- | Codec for text values.++@since 0.3.0+-}+text :: Key -> TomlCodec Text+text = match _Text+{-# INLINE text #-}++{- | Codec for lazy text values.++@since 1.0.0+-}+lazyText :: Key -> TomlCodec L.Text+lazyText = match _LText+{-# INLINE lazyText #-}++{- | Codec for text values as 'ByteString'.++@since 0.5.0+-}+byteString :: Key -> TomlCodec ByteString+byteString = match _ByteString+{-# INLINE byteString #-}++{- | Codec for text values as 'BL.ByteString'.++@since 0.5.0+-}+lazyByteString :: Key -> TomlCodec BL.ByteString+lazyByteString = match _LByteString+{-# INLINE lazyByteString #-}++{- | Codec for positive integer array values as 'ByteString'.++@since 1.2.0.0+-}+byteStringArray :: Key -> TomlCodec ByteString+byteStringArray = match _ByteStringArray+{-# INLINE byteStringArray #-}++{- | Codec for positive integer array values as lazy 'ByteString'.++@since 1.2.0.0+-}+lazyByteStringArray :: Key -> TomlCodec BL.ByteString+lazyByteStringArray = match _LByteStringArray+{-# INLINE lazyByteStringArray #-}
+ src/Toml/Codec/Combinator/Set.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE CPP #-}++{- |+Module : Toml.Codec.Combinator.Set+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++TOML-specific combinators for converting between TOML and Haskell Set-like data+types.++There are two way to represent list-like structures with the @tomland@ library.++* Ordinary array sets of primitives:++ @+ foo = [100, 200, 300]+ @++* Sets via tables:++ @+ foo =+ [ {x = 100}+ , {x = 200}+ , {x = 300}+ ]++ __OR__++ [[foo]]+ x = 100+ [[foo]]+ x = 200+ [[foo]]+ x = 300+ @++You can find both types of the codecs in this module for different set-like+structures. See the following table for the better understanding:+++------------------------+----------------------------------+-------------------------------------++| Haskell Type | @TOML@ | 'TomlCodec' |++========================+==================================+=====================================++| __@'Set' 'Text'@__ | @a = ["foo", "bar", "baz"]@ | @'arraySetOf' 'Toml._Text' "a"@ |++------------------------+----------------------------------+-------------------------------------++| __'IntSet'__ | @a = [11, 42]@ | @'arrayIntSet' "a"@ |++------------------------+----------------------------------+-------------------------------------++| __@'HashSet' 'Text'@__ | @a = ["foo", "bar"]@ | @'arrayHashSetOf' 'Toml._Text' "a"@ |++------------------------+----------------------------------+-------------------------------------++| __@'Set' 'Text'@__ | @x = [{a = "foo"}, {a = "bar"}]@ | @'set' ('Toml.text' "a") "x"@ |++------------------------+----------------------------------+-------------------------------------++| __@'HashSet' 'Text'@__ | @x = [{a = "foo"}, {a = "bar"}]@ | @'hashSet' ('Toml.text' "a") "x"@ |++------------------------+----------------------------------+-------------------------------------+++@since 1.3.0.0+-}++module Toml.Codec.Combinator.Set+ ( -- * Array sets+ arraySetOf+ , arrayIntSet+ , arrayHashSetOf+ -- * Table Sets+ , set+ , intSet+ , hashSet+ ) where++import Data.Hashable (Hashable)+import Data.HashSet (HashSet)+import Data.IntSet (IntSet)+import Data.Set (Set)++import Toml.Codec.BiMap (TomlBiMap)+import Toml.Codec.BiMap.Conversion (_HashSet, _IntSet, _Set)+import Toml.Codec.Combinator.Common (match)+import Toml.Codec.Combinator.List (list)+import Toml.Codec.Di (dimap)+import Toml.Codec.Types (TomlCodec)+import Toml.Type.AnyValue (AnyValue (..))+import Toml.Type.Key (Key)++import qualified Data.HashSet as HS+import qualified Data.IntSet as IS+import qualified Data.Set as S+++{- | Codec for sets. Takes converter for single value and+returns a set of values.++__Example:__++Haskell @'Set' 'Int'@ can look like this in your @TOML@ file:++@+foo = [1, 2, 3]+@++In case of the missing field, the following error will be seen:++@+tomland decode error: Key foo is not found+@++@since 0.5.0+-}+arraySetOf :: Ord a => TomlBiMap a AnyValue -> Key -> TomlCodec (Set a)+arraySetOf = match . _Set+{-# INLINE arraySetOf #-}++{- | Codec for sets of ints. Takes converter for single value and+returns a set of ints.++__Example:__++Haskell @'IntSet'@ can look like this in your @TOML@ file:++@+foo = [1, 2, 3]+@++In case of the missing field, the following error will be seen:++@+tomland decode error: Key foo is not found+@++@since 0.5.0+-}+arrayIntSet :: Key -> TomlCodec IntSet+arrayIntSet = match _IntSet+{-# INLINE arrayIntSet #-}++{- | Codec for hash sets. Takes converter for single hashable value and+returns a set of hashable values.++__Example:__++Haskell @'HashSet' 'Int'@ can look like this in your @TOML@ file:++@+foo = [1, 2, 3]+@++In case of the missing field, the following error will be seen:++@+tomland decode error: Key foo is not found+@++@since 0.5.0+-}+arrayHashSetOf+#if MIN_VERSION_hashable(1,4,0)+ :: (Hashable a)+#else+ :: (Eq a, Hashable a)+#endif+ => TomlBiMap a AnyValue+ -> Key+ -> TomlCodec (HashSet a)+arrayHashSetOf = match . _HashSet+{-# INLINE arrayHashSetOf #-}++----------------------------------------------------------------------------+-- Tables and arrays of tables+----------------------------------------------------------------------------++{- | 'Codec' for set of values. Represented in TOML as array of tables.++__Example:__++Haskell @'Set' 'Int'@ can look like this in your @TOML@ file:++@+foo =+ [ {a = 1}+ , {a = 2}+ ]+@++Decodes to an empty 'Set' in case of the missing field in @TOML@.++@since 1.2.0.0+-}+set :: forall a . Ord a => TomlCodec a -> Key -> TomlCodec (Set a)+set codec key = dimap S.toList S.fromList (list codec key)+{-# INLINE set #-}++{- | 'Codec' for 'IntSet'. Represented in TOML as an array of tables.++__Example:__++Haskell 'IntSet' can look like this in your @TOML@ file:++@+foo =+ [ {a = 1}+ , {a = 2}+ ]+@++Decodes to an empty 'IntSet' in case of the missing field in @TOML@.++@since 1.3.0.0+-}+intSet :: TomlCodec Int -> Key -> TomlCodec IntSet+intSet codec key = dimap IS.toList IS.fromList (list codec key)+{-# INLINE intSet #-}++{- | 'Codec' for 'HashSet' of values. Represented in TOML as an array of tables.++__Example:__++Haskell @'HashSet' 'Int'@ can look like this in your @TOML@ file:++@+foo =+ [ {a = 1}+ , {a = 2}+ ]+@++Decodes to an empty 'HashSet' in case of the missing field in @TOML@.++@since 1.2.0.0+-}+hashSet + :: forall a +#if MIN_VERSION_hashable(1,4,0)+ . (Hashable a)+#else+ . (Eq a, Hashable a)+#endif+ => TomlCodec a + -> Key + -> TomlCodec (HashSet a)+hashSet codec key = dimap HS.toList HS.fromList (list codec key)+{-# INLINE hashSet #-}
+ src/Toml/Codec/Combinator/Table.hs view
@@ -0,0 +1,95 @@+{- |+Module : Toml.Codec.Combinator.Table+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++Contains TOML-specific combinators for converting between TOML and user data+types.++Tables can be represented in @TOML@ in one of the following ways:++@+foo =+ { x = ...+ , y = ...+ , ...+ }+@++__Or__++@+[foo]+ x = ...+ y = ...+ ...+@++@since 1.3.0.0+-}++module Toml.Codec.Combinator.Table+ ( -- * Tables+ table+ -- * Error Helpers+ , handleTableErrors+ , mapTableErrors+ ) where++import Control.Monad.State (gets, modify)+import Data.Maybe (fromMaybe)+import Validation (Validation (..))++import Toml.Codec.Error (TomlDecodeError (..))+import Toml.Codec.Types (Codec (..), TomlCodec, TomlEnv, TomlState (..))+import Toml.Type.Key (Key)+import Toml.Type.TOML (TOML (..), insertTable)++import qualified Toml.Type.PrefixTree as Prefix++++{- | Maps errors in tables with 'mapTableErrors'++@since 1.3.0.0+-}+handleTableErrors :: TomlCodec a -> Key -> TOML -> Validation [TomlDecodeError] a+handleTableErrors codec key toml = case codecRead codec toml of+ Success res -> Success res+ Failure errs -> Failure $ mapTableErrors key errs++{- | Prepends given key to all errors that contain key. This function is used to+give better error messages. So when error happens we know all pieces of table+key, not only the last one.++@since 0.2.0+-}+mapTableErrors :: Key -> [TomlDecodeError] -> [TomlDecodeError]+mapTableErrors key = map (\case+ KeyNotFound name -> KeyNotFound (key <> name)+ TableNotFound name -> TableNotFound (key <> name)+ TableArrayNotFound name -> TableArrayNotFound (key <> name)+ e -> e+ )++{- | Codec for tables. Use it when when you have nested objects.++@since 0.2.0+-}+table :: forall a . TomlCodec a -> Key -> TomlCodec a+table codec key = Codec input output+ where+ input :: TomlEnv a+ input = \t -> case Prefix.lookup key $ tomlTables t of+ Nothing -> Failure [TableNotFound key]+ Just toml -> handleTableErrors codec key toml++ output :: a -> TomlState a+ output a = do+ mTable <- gets $ Prefix.lookup key . tomlTables+ let toml = fromMaybe mempty mTable+ let (_, newToml) = unTomlState (codecWrite codec a) toml+ a <$ modify (insertTable key newToml)
+ src/Toml/Codec/Combinator/Time.hs view
@@ -0,0 +1,74 @@+{- |+Module : Toml.Codec.Combinator.Time+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++TOML-specific combinators for converting between TOML and Haskell date and time+data types. TOML specification describes date and time primitives you+can use in your configuration. @tomland@ provides mapping of those+primitives to types from the @time@ library.+++-----------------+----------------------------+-------------------++| Haskell Type | @TOML@ | 'TomlCodec' |++=================+============================+===================++| __'ZonedTime'__ | @a = 2020-05-16T04:32:00Z@ | @'zonedTime' "a"@ |++-----------------+----------------------------+-------------------++| __'LocalTime'__ | @a = 2020-05-16T04:32:00@ | @'localTime' "a"@ |++-----------------+----------------------------+-------------------++| __'Day'__ | @a = 2020-05-16@ | @'day' "a"@ |++-----------------+----------------------------+-------------------++| __'TimeOfDay'__ | @a = 04:32:00@ | @'timeOfDay' "a"@ |++-----------------+----------------------------+-------------------+++@since 1.3.0.0+-}++module Toml.Codec.Combinator.Time+ ( zonedTime+ , localTime+ , day+ , timeOfDay+ ) where++import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime)++import Toml.Codec.BiMap.Conversion (_Day, _LocalTime, _TimeOfDay, _ZonedTime)+import Toml.Codec.Combinator.Common (match)+import Toml.Codec.Types (TomlCodec)+import Toml.Type.Key (Key)+++{- | Codec for zoned time values.++@since 0.5.0+-}+zonedTime :: Key -> TomlCodec ZonedTime+zonedTime = match _ZonedTime+{-# INLINE zonedTime #-}++{- | Codec for local time values.++@since 0.5.0+-}+localTime :: Key -> TomlCodec LocalTime+localTime = match _LocalTime+{-# INLINE localTime #-}++{- | Codec for day values.++@since 0.5.0+-}+day :: Key -> TomlCodec Day+day = match _Day+{-# INLINE day #-}++{- | Codec for time of day values.++@since 0.5.0+-}+timeOfDay :: Key -> TomlCodec TimeOfDay+timeOfDay = match _TimeOfDay+{-# INLINE timeOfDay #-}
+ src/Toml/Codec/Combinator/Tuple.hs view
@@ -0,0 +1,103 @@+{- |+Module : Toml.Codec.Combinator.Tuple+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++TOML-specific combinators for converting between TOML and Haskell tuples.+It's recommended to create your custom data types and implement codecs+for them, but if you need to have tuples (e.g. for decoding different+constructors of sum types), you can find codecs from this module+helpful.+++-------------------------------+---------------+------------------------++| Haskell Type | @TOML@ | 'TomlCodec' |++===============================+===============+========================++| __@('Int', 'Text')@__ | @[foo]@ | @'pair'@ |++-------------------------------+---------------+------------------------++| | @ a = 42@ | @ ('Toml.int' "a")@ |++-------------------------------+---------------+------------------------++| |@ b = "bar"@| @ ('Toml.text' "b")@|++-------------------------------+---------------+------------------------++| __@('Int', 'Text', 'Bool')@__ | @[foo]@ | @'triple'@ |++-------------------------------+---------------+------------------------++| | @ a = 42@ | @ ('Toml.int' "a")@ |++-------------------------------+---------------+------------------------++| |@ b = "bar"@| @ ('Toml.text' "b")@|++-------------------------------+---------------+------------------------++| |@ c = false@| @ ('Toml.bool' "c")@|++-------------------------------+---------------+------------------------+++@since 1.3.0.0+-}++module Toml.Codec.Combinator.Tuple+ ( pair+ , triple+ ) where++import Toml.Codec.Di ((.=))+import Toml.Codec.Types (TomlCodec)+++{- | Codec for pair of values. Takes codecs for the first and for the second+values of the pair.++If I have the following @TOML@ entry++@+myPair = { first = 11, second = "eleven"}+@++and want to convert it into the Haskell tuple of two elements, I can use the+following codec:++@+myPairCodec :: 'TomlCodec' ('Int', 'Text')+myPairCodec = flip Toml.'table' \"myPair\" $ Toml.'pair'+ (Toml.'int' \"first\")+ (Toml.'text' \"second\")+@++@since 1.3.0.0+-}+pair :: TomlCodec a -> TomlCodec b -> TomlCodec (a, b)+pair aCodec bCodec = (,)+ <$> aCodec .= fst+ <*> bCodec .= snd+{-# INLINE pair #-}++{- | Codec for triple of values. Takes codecs for the first, second and third+values of the triple.++If I have the following @TOML@ entry++@+myTriple =+ { first = 11+ , second = "eleven"+ , isMyFavourite = true+ }+@++and want to convert it into the Haskell tuple of three elements, I can use the+following codec:++@+myTripleCodec :: 'TomlCodec' ('Int', 'Text', 'Bool')+myTripleCodec = flip Toml.'table' \"myTriple\" $ Toml.'triple'+ (Toml.'int' \"first\")+ (Toml.'text' \"second\")+ (Toml.'bool' \"isMyFavourite\")+@++@since 1.3.0.0+-}+triple :: TomlCodec a -> TomlCodec b -> TomlCodec c -> TomlCodec (a, b, c)+triple aCodec bCodec cCodec = (,,)+ <$> aCodec .= (\(a, _, _) -> a)+ <*> bCodec .= (\(_, b, _) -> b)+ <*> cCodec .= (\(_, _, c) -> c)+{-# INLINE triple #-}
+ src/Toml/Codec/Di.hs view
@@ -0,0 +1,213 @@+{- |+Module : Toml.Codec.Di+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++Forward and backward mapping functions and combinators (similar to profunctors).++@since 1.3.0.0+-}++module Toml.Codec.Di+ ( dimap+ , dioptional+ , diwrap+ , dimatch+ , (.=)+ ) where++import Control.Applicative (Alternative (..))+import Data.Coerce (Coercible, coerce)++import Toml.Codec.Types (Codec (..), TomlCodec, (<!>))+++{- | This is an instance of @Profunctor@ for 'Codec'. But since there's no+@Profunctor@ type class in @base@ or package with no dependencies (and we don't+want to bring extra dependencies) this instance is implemented as a single+top-level function.++Useful when you want to parse @newtype@s. For example, if you had data type like+this:++@+__data__ Example = Example+ { foo :: Bool+ , bar :: Text+ }+@++Bidirectional TOML converter for this type will look like this:++@+exampleCodec :: TomlCodec Example+exampleCodec = Example+ \<$\> Toml.bool "foo" '.=' foo+ \<*\> Toml.text "bar" '.=' bar+@++Now if you change your type in the following way:++@+__newtype__ Email = Email { unEmail :: Text }++__data__ Example = Example+ { foo :: Bool+ , bar :: Email+ }+@++you need to patch your TOML codec like this:++@+exampleCodec :: TomlCodec Example+exampleCodec = Example+ \<$\> Toml.bool "foo" '.=' foo+ \<*\> 'dimap' unEmail Email (Toml.text "bar") '.=' bar+@++@since 0.2.0+-}+dimap+ :: (b -> a) -- ^ Mapper for consumer+ -> (a -> b) -- ^ Mapper for producer+ -> TomlCodec a -- ^ Source 'Codec' object+ -> TomlCodec b -- ^ Target 'Codec' object+dimap f g codec = Codec+ { codecRead = fmap g . codecRead codec+ , codecWrite = fmap g . codecWrite codec . f+ }+{-# INLINE dimap #-}++{- | Bidirectional converter for @Maybe a@ values. For example, given the data+type:++@+__data__ Example = Example+ { foo :: Bool+ , bar :: Maybe Int+ }+@++the TOML codec will look like++@+exampleCodec :: TomlCodec Example+exampleCodec = Example+ \<$\> Toml.bool "foo" '.=' foo+ \<*\> 'dioptional' (Toml.int "bar") '.=' bar+@++@since 0.5.0+-}+dioptional+ :: TomlCodec a+ -> TomlCodec (Maybe a)+dioptional Codec{..} = Codec+ { codecRead = fmap Just . codecRead <!> \_ -> pure Nothing+ , codecWrite = traverse codecWrite+ }+{-# INLINE dioptional #-}++{- | Combinator used for @newtype@ wrappers. For example, given the data types:++@+__newtype__ N = N Int++__data__ Example = Example+ { foo :: Bool+ , bar :: N+ }+@++the TOML codec can look like++@+exampleCodec :: TomlCodec Example+exampleCodec = Example+ \<$\> Toml.bool "foo" '.=' foo+ \<*\> 'diwrap' (Toml.int "bar") '.=' bar+@++@since 1.0.0+-}+diwrap+ :: forall b a .+ (Coercible a b)+ => TomlCodec a+ -> TomlCodec b+diwrap = coerce+{-# INLINE diwrap #-}++{- | Bidirectional converter for @sum types@. For example, given the data+type:++@+__data__ Example+ = Foo Int+ | Bar Bool Int+@++the TOML codec will look like++@+matchFoo :: Example -> Maybe Int+matchFoo (Foo num) = Just num+matchFoo _ = Nothing++matchBar :: Example -> Maybe (Bool, Int)+matchBar (Bar b num) = Just (b, num)+matchBar _ = Nothing++barCodec :: TomlCodec (Bool, Int)+barCodec = Toml.pair+ (Toml.bool "a")+ (Toml.int "b")++exampleCodec :: TomlCodec Example+exampleCodec =+ dimatch matchFoo Foo (Toml.int "foo")+ \<|\> dimatch matchBar (uncurry Bar) (Toml.table barCodec "bar")+@++@since 1.2.0.0+-}+dimatch+ :: (b -> Maybe a) -- ^ Mapper for consumer+ -> (a -> b) -- ^ Mapper for producer+ -> TomlCodec a -- ^ Source 'Codec' object+ -> TomlCodec b -- ^ Target 'Codec' object+dimatch match ctor codec = Codec+ { codecRead = fmap ctor . codecRead codec+ , codecWrite = \c -> case match c of+ Nothing -> empty+ Just d -> ctor <$> codecWrite codec d+ }+{-# INLINE dimatch #-}++{- | Operator to connect two operations:++1. How to get field from object?+2. How to write this field to toml?++In code this should be used like this:++@+__data__ Foo = Foo+ { fooBar :: Int+ , fooBaz :: String+ }++fooCodec :: TomlCodec Foo+fooCodec = Foo+ \<$\> Toml.int "bar" '.=' fooBar+ \<*\> Toml.str "baz" '.=' fooBaz+@+-}+infixl 5 .=+(.=) :: Codec field a -> (object -> field) -> Codec object a+codec .= getter = codec { codecWrite = codecWrite codec . getter }+{-# INLINE (.=) #-}
+ src/Toml/Codec/Error.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE DeriveAnyClass #-}++{- |+Module : Toml.Codec.Error+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++Core error types, including 'TomlDecodeError' and 'LoadTomlException'.++@since 1.3.0.0+-}++module Toml.Codec.Error+ ( TomlDecodeError (..)+ , prettyTomlDecodeErrors+ , prettyTomlDecodeError++ , LoadTomlException (..)+ ) where++import Control.DeepSeq (NFData)+import Control.Exception (Exception)+import Data.Text (Text)+import GHC.Generics (Generic)++import Toml.Codec.BiMap (TomlBiMapError, prettyBiMapError)+import Toml.Parser (TomlParseError (..))+import Toml.Type.Key (Key (..))+import Toml.Type.TOML (TOML)+import Toml.Type.Printer (prettyKey, pretty)++import qualified Data.Text as Text+++{- | Type of exception for converting from TOML to user custom data type.++@since 1.3.0.0+-}+data TomlDecodeError+ = BiMapError !Key !TomlBiMapError+ | KeyNotFound !Key -- ^ No such key+ | TableNotFound !Key -- ^ No such table+ | TableArrayNotFound !Key+ {- ^ No such table array++ @since 1.3.0.0+ -}+ | ParseError !TomlParseError -- ^ Exception during parsing+ | NotExactDecode !TOML+ {- ^ Unused field left in the decoded TOML.++ @since 1.3.2.0+ -}+ deriving stock (Show, Eq, Generic)+ deriving anyclass (NFData)++{- | Converts 'TomlDecodeError's into pretty human-readable text.++@since 1.3.0.0+-}+prettyTomlDecodeErrors :: [TomlDecodeError] -> Text+prettyTomlDecodeErrors errs = Text.unlines $+ ("tomland errors number: " <> Text.pack (show $ length errs))+ : map prettyTomlDecodeError errs++{- | Converts 'TomlDecodeError' into pretty human-readable text.++@since 1.3.0.0+-}+prettyTomlDecodeError :: TomlDecodeError -> Text+prettyTomlDecodeError de = "tomland decode error: " <> case de of+ BiMapError name biError -> "BiMap error in key '" <> prettyKey name <> "' : "+ <> prettyBiMapError biError+ KeyNotFound name -> "Key " <> prettyKey name <> " is not found"+ TableNotFound name -> "Table [" <> prettyKey name <> "] is not found"+ TableArrayNotFound name -> "Table array [[" <> prettyKey name <> "]] is not found"+ ParseError (TomlParseError msg) ->+ "Parse error during conversion from TOML to custom user type:\n " <> msg+ NotExactDecode toml ->+ "The following fields are present in TOML but not used:\n"+ <> pretty toml++{- | File loading error data type.++@since 0.3.1+-}+data LoadTomlException = LoadTomlException !FilePath !Text++-- | @since 0.3.1+instance Show LoadTomlException where+ show (LoadTomlException filePath msg) = "Couldnt parse file " ++ filePath ++ ": " ++ show msg++-- | @since 0.3.1+instance Exception LoadTomlException
+ src/Toml/Codec/Generic.hs view
@@ -0,0 +1,824 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}++{- |+Module : Toml.Codec.Generic+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++This module contains implementation of the 'Generic' TOML codec. If your+data types are big and nested, and you want to have codecs for them without writing a lot of+boilerplate code, you can find this module helpful. Below you can find the detailed+explanation on how the 'Generic' codecs work.++Consider the following Haskell data types:++@+__data__ User = User+ { age :: Int+ , address :: Address+ , socials :: [Social]+ } __deriving__ ('Generic')++__data__ Address = Address+ { street :: Text+ , house :: Int+ } __deriving__ ('Generic')++__data__ Social = Social+ { name :: Text+ , link :: Text+ } __deriving__ ('Generic')+@++Value of the @User@ type represents the following TOML:++@+age = 27++[address]+ street = "Miami Beach"+ house = 42++[[socials]]+ name = \"Twitter\"+ link = "https://twitter.com/foo"++[[socials]]+ name = \"GitHub\"+ link = "https://github.com/bar"+@++Normally you would write 'TomlCodec' for this data type like this:++@+userCodec :: 'TomlCodec' User+userCodec = User+ \<$\> Toml.int "age" .= age+ \<*\> Toml.table addressCodec "address" .= address+ \<*\> Toml.list socialCodec "socials" .= socials++addressCodec :: 'TomlCodec' Address+addressCodec = Address+ \<$\> Toml.text "street" .= street+ \<*\> Toml.int "house" .= house++socialCodec :: 'TomlCodec' Social+socialCodec = Social+ \<$\> Toml.text "name" .= name+ \<*\> Toml.text "link" .= link+@++However, if you derive 'Generic' instance for your data types (as we do in the+example), you can write your codecs in a simpler way.++@+userCodec :: 'TomlCodec' User+userCodec = 'genericCodec'++__instance__ 'HasCodec' Address __where__+ hasCodec = Toml.table 'genericCodec'++__instance__ 'HasItemCodec' Social __where__+ hasItemCodec = Right 'genericCodec'+@++Several notes about the interface:++1. Your top-level data types are always implemented as 'genericCodec' (or other+generic codecs).+2. If you have a custom data type as a field of another type, you need to implement+the instance of the 'HasCodec' typeclass.+3. If the data type appears as an element of a list, you need to implement the instance+of the 'HasItemCodec' typeclass.++@since 1.1.0.0+-}++module Toml.Codec.Generic+ ( genericCodec+ , genericCodecWithOptions+ , stripTypeNameCodec++ -- * Options+ , TomlOptions (..)+ , GenericOptions (..)+ , stripTypeNameOptions+ , stripTypeNamePrefix++ -- * Core generic typeclass+ , HasCodec (..)+ , HasItemCodec (..)+ , GenericCodec (..)++ -- * 'ByteString' newtypes+ -- $bytestring+ , ByteStringAsText (..)+ , ByteStringAsBytes (..)+ , LByteStringAsText (..)+ , LByteStringAsBytes (..)++ -- * Deriving Via+ , TomlTable (..)+ , TomlTableStrip (..)+ ) where++import Data.ByteString (ByteString)+import Data.Char (isLower, toLower)+import Data.Coerce (coerce)+import Data.HashMap.Strict (HashMap)+import Data.HashSet (HashSet)+import Data.Hashable (Hashable)+import Data.IntMap.Strict (IntMap)+import Data.IntSet (IntSet)+import Data.Kind (Type)+import Data.List (stripPrefix)+import Data.List.NonEmpty (NonEmpty)+import Data.Map.Strict (Map)+import Data.Monoid (All (..), Any (..), First (..), Last (..), Product (..), Sum (..))+import Data.Proxy (Proxy (..))+import Data.Set (Set)+import Data.String (IsString (..))+import Data.Text (Text)+import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime)+import Data.Typeable (Typeable, typeRep)+import Data.Word (Word8)+import GHC.Generics (C1, D1, Generic (..), K1 (..), M1 (..), Rec0, S1, Selector (..), (:*:) (..),+ (:+:))+import GHC.TypeLits (ErrorMessage (..), TypeError)+import Numeric.Natural (Natural)++import Toml.Codec.BiMap (TomlBiMap)+import Toml.Codec.Di (diwrap, (.=))+import Toml.Codec.Types (TomlCodec)+import Toml.Type.AnyValue (AnyValue)+import Toml.Type.Key (Key)++import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text.Lazy as L++import qualified Toml.Codec.BiMap.Conversion as Toml+import qualified Toml.Codec.Combinator as Toml+import qualified Toml.Codec.Di as Toml+++{- | Generic codec for arbitrary data types. Uses field names as keys.++@since 1.1.0.0+-}+genericCodec :: (Generic a, GenericCodec (Rep a)) => TomlCodec a+genericCodec = Toml.dimap from to $ genericTomlCodec (GenericOptions id)+{-# INLINE genericCodec #-}++{- | Generic codec with options for arbitrary data types.++@since 1.1.0.0+-}+genericCodecWithOptions+ :: forall a+ . (Generic a, GenericCodec (Rep a), Typeable a)+ => TomlOptions a+ -> TomlCodec a+genericCodecWithOptions = Toml.dimap from to . genericTomlCodec . toGenericOptions @a+{-# INLINE genericCodecWithOptions #-}++{- | Generic codec that uses 'stripTypeNameOptions'.++@since 1.1.0.0+-}+stripTypeNameCodec+ :: forall a+ . (Generic a, GenericCodec (Rep a), Typeable a)+ => TomlCodec a+stripTypeNameCodec = genericCodecWithOptions $ stripTypeNameOptions @a+{-# INLINE stripTypeNameCodec #-}++----------------------------------------------------------------------------+-- Generic typeclasses+----------------------------------------------------------------------------++{- | Options to configure various parameters of generic encoding. Specifically:++* __'tomlOptionsFieldModifier'__: how to translate field names to TOML keys?++@since 1.1.0.0+-}+data TomlOptions a = TomlOptions+ { tomlOptionsFieldModifier :: Typeable a => Proxy a -> String -> String+ }++{- | Same as 'TomlOptions' but with all data type information erased. This data+type is used internally. Define your options using 'TomlOptions' data type.++@since 1.1.0.0+-}+newtype GenericOptions = GenericOptions+ { genericOptionsFieldModifier :: String -> String+ }++toGenericOptions :: forall a . Typeable a => TomlOptions a -> GenericOptions+toGenericOptions TomlOptions{..} = GenericOptions+ { genericOptionsFieldModifier = tomlOptionsFieldModifier (Proxy @a)+ }++{- | Options that use 'stripTypeNamePrefix' as 'tomlOptionsFieldModifier'.++@since 1.1.0.0+-}+stripTypeNameOptions :: Typeable a => TomlOptions a+stripTypeNameOptions = TomlOptions+ { tomlOptionsFieldModifier = stripTypeNamePrefix+ }++{- | Strips name of the type name from field name prefix.++>>> data UserData = UserData { userDataId :: Int, userDataShortInfo :: Text }+>>> stripTypeNamePrefix (Proxy @UserData) "userDataId"+"id"+>>> stripTypeNamePrefix (Proxy @UserData) "userDataShortInfo"+"shortInfo"+>>> stripTypeNamePrefix (Proxy @UserData) "udStats"+"stats"+>>> stripTypeNamePrefix (Proxy @UserData) "fooBar"+"bar"+>>> stripTypeNamePrefix (Proxy @UserData) "name"+"name"++@since 1.1.0.0+-}+stripTypeNamePrefix :: forall a . Typeable a => Proxy a -> String -> String+stripTypeNamePrefix _ fieldName =+ case stripPrefix (headToLower $ typeName @a) fieldName of+ Just rest -> leaveIfEmpty rest+ Nothing -> leaveIfEmpty (dropWhile isLower fieldName)+ where+ headToLower :: String -> String+ headToLower = \case+ [] -> error "Cannot use 'headToLower' on empty Text"+ x:xs -> toLower x : xs++ -- if all lower case then leave field as it is+ leaveIfEmpty :: String -> String+ leaveIfEmpty rest = if null rest then fieldName else headToLower rest++typeName :: forall a . Typeable a => String+typeName = show $ typeRep (Proxy @a)++----------------------------------------------------------------------------+-- Generic typeclasses+----------------------------------------------------------------------------++{- | Helper class to derive TOML codecs generically.++@since 1.1.0.0+-}+class GenericCodec (f :: k -> Type) where+ genericTomlCodec :: GenericOptions -> TomlCodec (f p)++-- | @since 1.1.0.0+instance GenericCodec f => GenericCodec (D1 d f) where+ genericTomlCodec = Toml.dimap unM1 M1 . genericTomlCodec+ {-# INLINE genericTomlCodec #-}++type GenericSumTomlNotSupported =+ 'Text "Generic TOML deriving for arbitrary sum types is not supported currently."++-- | @since 1.1.0.0+instance (TypeError GenericSumTomlNotSupported) => GenericCodec (f :+: g) where+ genericTomlCodec = error "Not supported"++-- | @since 1.1.0.0+instance GenericCodec f => GenericCodec (C1 c f) where+ genericTomlCodec = Toml.dimap unM1 M1 . genericTomlCodec+ {-# INLINE genericTomlCodec #-}++-- | @since 1.1.0.0+instance (GenericCodec f, GenericCodec g) => GenericCodec (f :*: g) where+ genericTomlCodec options = (:*:)+ <$> genericTomlCodec options .= fstG+ <*> genericTomlCodec options .= sndG+ where+ fstG :: (f :*: g) p -> f p+ fstG (f :*: _) = f++ sndG :: (f :*: g) p -> g p+ sndG (_ :*: g) = g+ {-# INLINE genericTomlCodec #-}++-- | @since 1.1.0.0+instance (Selector s, HasCodec a) => GenericCodec (S1 s (Rec0 a)) where+ genericTomlCodec GenericOptions{..} = genericWrap $ hasCodec @a fieldName+ where+ genericWrap :: TomlCodec a -> TomlCodec (S1 s (Rec0 a) p)+ genericWrap = Toml.dimap (unK1 . unM1) (M1 . K1)++ fieldName :: Key+ fieldName =+ fromString+ $ genericOptionsFieldModifier+ $ selName (error "S1" :: S1 s Proxy ())+ {-# INLINE genericTomlCodec #-}++----------------------------------------------------------------------------+-- Helper typeclasses+----------------------------------------------------------------------------++{- | This typeclass tells how the data type should be coded as an item of a+list. Lists in TOML can have two types: __primitive__ and __table of arrays__.++* If 'hasItemCodec' returns 'Left': __primitive__ arrays codec is used.+* If 'hasItemCodec' returns 'Right:' __table of arrays__ codec is used.++@since 1.1.0.0+-}+class HasItemCodec a where+ hasItemCodec :: Either (TomlBiMap a AnyValue) (TomlCodec a)++-- | @since 1.1.0.0+instance HasItemCodec Bool where+ hasItemCodec = Left Toml._Bool+ {-# INLINE hasItemCodec #-}++-- | @since 1.1.0.0+instance HasItemCodec Int where+ hasItemCodec = Left Toml._Int+ {-# INLINE hasItemCodec #-}++-- | @since 1.1.0.0+instance HasItemCodec Word where+ hasItemCodec = Left Toml._Word+ {-# INLINE hasItemCodec #-}++-- | @since 1.2.0.0+instance HasItemCodec Word8 where+ hasItemCodec = Left Toml._Word8+ {-# INLINE hasItemCodec #-}++-- | @since 1.1.0.0+instance HasItemCodec Integer where+ hasItemCodec = Left Toml._Integer+ {-# INLINE hasItemCodec #-}++-- | @since 1.1.0.0+instance HasItemCodec Natural where+ hasItemCodec = Left Toml._Natural+ {-# INLINE hasItemCodec #-}++-- | @since 1.1.0.0+instance HasItemCodec Double where+ hasItemCodec = Left Toml._Double+ {-# INLINE hasItemCodec #-}++-- | @since 1.1.0.0+instance HasItemCodec Float where+ hasItemCodec = Left Toml._Float+ {-# INLINE hasItemCodec #-}++-- | @since 1.1.0.0+instance HasItemCodec Text where+ hasItemCodec = Left Toml._Text+ {-# INLINE hasItemCodec #-}++-- | @since 1.1.0.0+instance HasItemCodec L.Text where+ hasItemCodec = Left Toml._LText+ {-# INLINE hasItemCodec #-}++-- | @since 1.3.0.0+instance HasItemCodec ByteStringAsText where+ hasItemCodec = Left $ coerce Toml._ByteString+ {-# INLINE hasItemCodec #-}++-- | @since 1.3.0.0+instance HasItemCodec ByteStringAsBytes where+ hasItemCodec = Left $ coerce Toml._ByteStringArray+ {-# INLINE hasItemCodec #-}++-- | @since 1.3.0.0+instance HasItemCodec LByteStringAsText where+ hasItemCodec = Left $ coerce Toml._LByteString+ {-# INLINE hasItemCodec #-}++-- | @since 1.3.0.0+instance HasItemCodec LByteStringAsBytes where+ hasItemCodec = Left $ coerce Toml._LByteStringArray+ {-# INLINE hasItemCodec #-}++-- | @since 1.1.0.0+instance HasItemCodec ZonedTime where+ hasItemCodec = Left Toml._ZonedTime+ {-# INLINE hasItemCodec #-}++-- | @since 1.1.0.0+instance HasItemCodec LocalTime where+ hasItemCodec = Left Toml._LocalTime+ {-# INLINE hasItemCodec #-}++-- | @since 1.1.0.0+instance HasItemCodec Day where+ hasItemCodec = Left Toml._Day+ {-# INLINE hasItemCodec #-}++-- | @since 1.1.0.0+instance HasItemCodec TimeOfDay where+ hasItemCodec = Left Toml._TimeOfDay+ {-# INLINE hasItemCodec #-}++-- | @since 1.1.0.0+instance HasItemCodec IntSet where+ hasItemCodec = Left Toml._IntSet+ {-# INLINE hasItemCodec #-}++{- | If data type @a@ is not primitive then this instance returns codec for list+under key equal to @a@ type name.++@since 1.1.0.0+-}+instance (HasItemCodec a, Typeable a) => HasItemCodec [a] where+ hasItemCodec = case hasItemCodec @a of+ Left prim -> Left $ Toml._Array prim+ Right codec -> Right $ Toml.list codec (fromString $ typeName @a)+ {-# INLINE hasItemCodec #-}++{- | Helper typeclass for generic deriving. This instance tells how the data+type should be coded if it's a field of another data type.++__NOTE:__ If you implement TOML codecs for your data types manually, prefer more+explicit @Toml.int@ or @Toml.text@ instead of implicit @Toml.hasCodec@.+Implement instances of this typeclass only when using 'genericCodec' and when+your custom data types are not covered here.++@since 1.1.0.0+-}+class HasCodec a where+ hasCodec :: Key -> TomlCodec a++-- | @since 1.1.0.0+instance HasCodec Bool where+ hasCodec = Toml.bool+ {-# INLINE hasCodec #-}++-- | @since 1.1.0.0+instance HasCodec Int where+ hasCodec = Toml.int+ {-# INLINE hasCodec #-}++-- | @since 1.1.0.0+instance HasCodec Word where+ hasCodec = Toml.word+ {-# INLINE hasCodec #-}++-- | @since 1.2.0.0+instance HasCodec Word8 where+ hasCodec = Toml.word8+ {-# INLINE hasCodec #-}++-- | @since 1.1.0.0+instance HasCodec Integer where+ hasCodec = Toml.integer+ {-# INLINE hasCodec #-}++-- | @since 1.1.0.0+instance HasCodec Natural where+ hasCodec = Toml.natural+ {-# INLINE hasCodec #-}++-- | @since 1.1.0.0+instance HasCodec Double where+ hasCodec = Toml.double+ {-# INLINE hasCodec #-}++-- | @since 1.1.0.0+instance HasCodec Float where+ hasCodec = Toml.float+ {-# INLINE hasCodec #-}++-- | @since 1.1.0.0+instance HasCodec Text where+ hasCodec = Toml.text+ {-# INLINE hasCodec #-}++-- | @since 1.1.0.0+instance HasCodec L.Text where+ hasCodec = Toml.lazyText+ {-# INLINE hasCodec #-}++-- | @since 1.3.0.0+instance HasCodec ByteStringAsText where+ hasCodec = diwrap . Toml.byteString+ {-# INLINE hasCodec #-}++-- | @since 1.3.0.0+instance HasCodec ByteStringAsBytes where+ hasCodec = diwrap . Toml.byteStringArray+ {-# INLINE hasCodec #-}++-- | @since 1.3.0.0+instance HasCodec LByteStringAsText where+ hasCodec = diwrap . Toml.lazyByteString+ {-# INLINE hasCodec #-}++-- | @since 1.3.0.0+instance HasCodec LByteStringAsBytes where+ hasCodec = diwrap . Toml.lazyByteStringArray+ {-# INLINE hasCodec #-}++-- | @since 1.1.0.0+instance HasCodec ZonedTime where+ hasCodec = Toml.zonedTime+ {-# INLINE hasCodec #-}++-- | @since 1.1.0.0+instance HasCodec LocalTime where+ hasCodec = Toml.localTime+ {-# INLINE hasCodec #-}++-- | @since 1.1.0.0+instance HasCodec Day where+ hasCodec = Toml.day+ {-# INLINE hasCodec #-}++-- | @since 1.1.0.0+instance HasCodec TimeOfDay where+ hasCodec = Toml.timeOfDay+ {-# INLINE hasCodec #-}++-- | @since 1.1.0.0+instance HasCodec IntSet where+ hasCodec = Toml.arrayIntSet+ {-# INLINE hasCodec #-}++-- | @since 1.1.0.0+instance HasCodec a => HasCodec (Maybe a) where+ hasCodec = Toml.dioptional . hasCodec @a+ {-# INLINE hasCodec #-}++-- | @since 1.1.0.0+instance HasItemCodec a => HasCodec [a] where+ hasCodec = case hasItemCodec @a of+ Left prim -> Toml.arrayOf prim+ Right codec -> Toml.list codec+ {-# INLINE hasCodec #-}++-- | @since 1.1.0.0+instance HasItemCodec a => HasCodec (NonEmpty a) where+ hasCodec = case hasItemCodec @a of+ Left prim -> Toml.arrayNonEmptyOf prim+ Right codec -> Toml.nonEmpty codec+ {-# INLINE hasCodec #-}++-- | @since 1.2.0.0+instance (Ord a, HasItemCodec a) => HasCodec (Set a) where+ hasCodec = case hasItemCodec @a of+ Left prim -> Toml.arraySetOf prim+ Right codec -> Toml.set codec+ {-# INLINE hasCodec #-}++-- | @since 1.2.0.0+#if MIN_VERSION_hashable(1,4,0)+instance (Hashable a, HasItemCodec a)+#else+instance (Hashable a, Eq a, HasItemCodec a)+#endif+ => HasCodec (HashSet a) where+ hasCodec = case hasItemCodec @a of+ Left prim -> Toml.arrayHashSetOf prim+ Right codec -> Toml.hashSet codec+ {-# INLINE hasCodec #-}++{- | Encodes 'Map' as array of tables with the @key@ and @val@ TOML+key names for 'Map' keys and values. E.g. if you have a type+@'Map' 'Int' 'Text'@, the 'HasCodec' instance for 'Generic' deriving+will work with the following TOML representation:++@+fieldName =+ [ { key = 10, val = "book" }+ , { key = 42, val = "food" }+ ]+@++@since 1.3.0.0+-}+instance (Ord k, HasCodec k, HasCodec v) => HasCodec (Map k v) where+ hasCodec = Toml.map (hasCodec @k "key") (hasCodec @v "val")+ {-# INLINE hasCodec #-}++{- | Encodes 'HashMap' as array of tables with the @key@ and @val@ TOML+key names for 'HashMap' keys and values. E.g. if you have a type+@'HashMap' 'Text' 'Int'@, the 'HasCodec' instance for 'Generic'+deriving will work with the following TOML representation:++@+fieldName =+ [ { key = "foo", val = 15 }+ , { key = "bar", val = 7 }+ ]+@++@since 1.3.0.0+-}+#if MIN_VERSION_hashable(1,4,0)+instance (Hashable k, HasCodec k, HasCodec v)+#else+instance (Hashable k, Eq k, HasCodec k, HasCodec v)+#endif+ => HasCodec (HashMap k v) where+ hasCodec = Toml.hashMap (hasCodec @k "key") (hasCodec @v "val")+ {-# INLINE hasCodec #-}++{- | Encodes 'IntMap' as array of tables with the @key@ and @val@ TOML+key names for 'IntMap' keys and values. E.g. if you have a type+@'IntMap' 'Text'@, the 'HasCodec' instance for 'Generic' deriving will+work with the following TOML representation:++@+fieldName =+ [ { key = 10, val = "foo" }+ , { key = 42, val = "bar" }+ ]+@++@since 1.3.0.0+-}+instance (HasCodec v) => HasCodec (IntMap v) where+ hasCodec = Toml.intMap (hasCodec @Int "key") (hasCodec @v "val")+ {-# INLINE hasCodec #-}++-- | @since 1.3.0.0+instance HasCodec All where+ hasCodec = Toml.all+ {-# INLINE hasCodec #-}++-- | @since 1.3.0.0+instance HasCodec Any where+ hasCodec = Toml.any+ {-# INLINE hasCodec #-}++-- | @since 1.3.0.0+instance (Num a, HasCodec a) => HasCodec (Sum a) where+ hasCodec = Toml.sum (hasCodec @a)+ {-# INLINE hasCodec #-}++-- | @since 1.3.0.0+instance (Num a, HasCodec a) => HasCodec (Product a) where+ hasCodec = Toml.product (hasCodec @a)+ {-# INLINE hasCodec #-}++-- | @since 1.3.0.0+instance HasCodec a => HasCodec (First a) where+ hasCodec = Toml.first (hasCodec @a)+ {-# INLINE hasCodec #-}++-- | @since 1.3.0.0+instance HasCodec a => HasCodec (Last a) where+ hasCodec = Toml.last (hasCodec @a)+ {-# INLINE hasCodec #-}++{- | @newtype@ for generic deriving of 'HasCodec' typeclass for custom data+types that should we wrapped into separate table. Use it only for data types+that are fields of another data types.++@+__data__ Person = Person+ { personName :: !'Text'+ , personAddress :: !Address+ } __deriving__ ('Generic')++data Address = Address+ { addressStreet :: !'Text'+ , addressHouse :: !'Int'+ } __deriving__ ('Generic')+ __deriving__ 'HasCodec' __via__ 'TomlTable' Address++personCodec :: 'TomlCodec' Person+personCodec = 'stripTypeNameCodec'+@++@personCodec@ corresponds to the TOML of the following structure:++@+name = "foo"+[address]+ addressStreet = \"Bar\"+ addressHouse = 42+@++@since 1.3.0.0+-}+newtype TomlTable a = TomlTable+ { unTomlTable :: a+ }++-- | @since 1.3.0.0+instance (Generic a, GenericCodec (Rep a)) => HasCodec (TomlTable a) where+ hasCodec :: Key -> TomlCodec (TomlTable a)+ hasCodec = Toml.diwrap . Toml.table (genericCodec @a)+ {-# INLINE hasCodec #-}++-- | @since 1.3.0.0+instance (Generic a, GenericCodec (Rep a)) => HasItemCodec (TomlTable a) where+ hasItemCodec = Right $ Toml.diwrap $ genericCodec @a+ {-# INLINE hasItemCodec #-}++{- | @newtype@ for generic deriving of 'HasCodec' typeclass for custom data+types that should be wrapped into a separate table.++Similar to 'TomlTable' but also strips the data type name prefix from+TOML keys.++@personCodec@ from the 'TomlTable' comment corresponds to the TOML of+the following structure:++@+name = "foo"+[address]+ street = \"Bar\"+ house = 42+@++@since 1.3.2.0+-}+newtype TomlTableStrip a = TomlTableStrip+ { unTomlTableStrip :: a+ }++-- | @since 1.3.2.0+instance (Generic a, GenericCodec (Rep a), Typeable a) => HasCodec (TomlTableStrip a) where+ hasCodec :: Key -> TomlCodec (TomlTableStrip a)+ hasCodec = Toml.diwrap . Toml.table (stripTypeNameCodec @a)+ {-# INLINE hasCodec #-}++-- | @since 1.3.2.0+instance (Generic a, GenericCodec (Rep a), Typeable a) => HasItemCodec (TomlTableStrip a) where+ hasItemCodec = Right $ Toml.diwrap $ stripTypeNameCodec @a+ {-# INLINE hasItemCodec #-}++{- $bytestring+There are two ways to encode 'ByteString' in TOML:++1. Via text.+2. Via an array of integers (aka array of bytes).++To handle all these cases, @tomland@ provides helpful newtypes, specifically:++* 'ByteStringAsText'+* 'ByteStringAsBytes'+* 'LByteStringAsText'+* 'LByteStringAsBytes'++As a bonus, on GHC >= 8.6 you can use these newtypes with the @DerivingVia@+extensions for your own 'ByteString' types.++@+__newtype__ MyByteString = MyByteString+ { unMyByteString :: 'ByteString'+ } __deriving__ 'HasCodec' __via__ 'ByteStringAsBytes'+@+-}++{- | Newtype wrapper over 'ByteString' to be used for text values.++@since 1.3.0.0+-}+newtype ByteStringAsText = ByteStringAsText+ { unByteStringAsText :: ByteString+ } deriving newtype (Show, Eq)++{- | Newtype wrapper over 'ByteString' to be used for array of integers+representation.++@since 1.3.0.0+-}+newtype ByteStringAsBytes = ByteStringAsBytes+ { unByteStringAsBytes :: ByteString+ } deriving newtype (Show, Eq)++{- | Newtype wrapper over lazy 'LBS.ByteString' to be used for text values.++@since 1.3.0.0+-}+newtype LByteStringAsText = LByteStringAsText+ { unLByteStringAsText :: LBS.ByteString+ } deriving newtype (Show, Eq)++{- | Newtype wrapper over lazy 'LBS.ByteString' to be used for array of integers+representation.++@since 1.3.0.0+-}+newtype LByteStringAsBytes = LByteStringAsBytes+ { unLByteStringAsBytes :: LBS.ByteString+ } deriving newtype (Show, Eq)
+ src/Toml/Codec/Types.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{- |+Module : Toml.Codec.Types+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++Contains general underlying monad for bidirectional conversion.++@since 1.3.0.0+-}++module Toml.Codec.Types+ ( -- * Toml Codec+ TomlCodec+ -- * Toml Environment+ , TomlEnv+ -- * Toml State+ , TomlState (..)+ , eitherToTomlState++ -- * Codec+ , Codec (..)++ -- * Function alternative+ , (<!>)+ ) where++import Control.Applicative (Alternative (..), liftA2)+import Control.Monad.State (MonadState (..))+import Data.Bifunctor (first)+import Validation (Validation (..))++import Toml.Codec.Error (TomlDecodeError)+import Toml.Type (TOML (..))+++{- | Immutable environment for TOML conversion.++@since 1.3.0.0+-}+type TomlEnv a = TOML -> Validation [TomlDecodeError] a+++{- | Specialied 'Codec' type alias for bidirectional TOML serialization. Keeps+'TOML' object as both environment and state.++@since 0.5.0+-}+type TomlCodec a = Codec a a++{- | Monad for bidirectional conversion. Contains pair of functions:++1. How to read value of type @o@ (out) from immutable environment context+('TomlEnv')?+2. How to store a value of type @i@ (in) in stateful context ('TomlState') and+return a value of type @o@?++This approach with the bunch of utility functions allows to+have single description for from/to @TOML@ conversion.++In practice this type will always be used in the following way:++@+type 'TomlCodec' a = 'Codec' a a+@++Type parameter @i@ if fictional. Here some trick is used. This trick is+implemented in the [codec](http://hackage.haskell.org/package/codec) package and+described in more details in related blog post:+<https://blog.poisson.chat/posts/2016-10-12-bidirectional-serialization.html>.++@since 0.0.0+-}+data Codec i o = Codec+ { -- | Extract value of type @o@ from monadic context 'TomlEnv'.+ codecRead :: TomlEnv o++ {- | Store value of type @i@ inside monadic context 'TomlState' and+ returning value of type @o@. Type of this function actually should be+ @o -> TomlState ()@ but with such type it's impossible to have 'Monad'+ and other instances.+ -}+ , codecWrite :: i -> TomlState o+ }++-- | @since 0.0.0+instance Functor (Codec i) where+ fmap :: (oA -> oB) -> Codec i oA -> Codec i oB+ fmap f codec = Codec+ { codecRead = fmap f . codecRead codec+ , codecWrite = fmap f . codecWrite codec+ }+ {-# INLINE fmap #-}++-- | @since 0.0.0+instance Applicative (Codec i) where+ pure :: o -> Codec i o+ pure a = Codec+ { codecRead = \_ -> Success a+ , codecWrite = \_ -> pure a+ }+ {-# INLINE pure #-}++ (<*>) :: Codec i (oA -> oB) -> Codec i oA -> Codec i oB+ codecf <*> codeca = Codec+ { codecRead = liftA2 (<*>) (codecRead codecf) (codecRead codeca)+ , codecWrite = \c -> codecWrite codecf c <*> codecWrite codeca c+ }+ {-# INLINE (<*>) #-}++instance Alternative (Codec i) where+ empty :: Codec i o+ empty = Codec+ { codecRead = \_ -> empty+ , codecWrite = \_ -> empty+ }+ {-# INLINE empty #-}++ (<|>) :: Codec i o -> Codec i o -> Codec i o+ codec1 <|> codec2 = Codec+ { codecRead = codecRead codec1 <!> codecRead codec2+ , codecWrite = \c -> codecWrite codec1 c <|> codecWrite codec2 c+ }+ {-# INLINE (<|>) #-}++-- | Alternative instance for function arrow but without 'empty'.+infixl 3 <!>+(<!>) :: Alternative f => (a -> f x) -> (a -> f x) -> (a -> f x)+f <!> g = \a -> f a <|> g a+{-# INLINE (<!>) #-}++{- | Mutable context for TOML conversion.+We are introducing our own implemetation of state with 'MonadState' instance due+to some limitation in the design connected to the usage of State.++This newtype is equivalent to the following transformer:++@+MaybeT (State TOML)+@+++@since 1.3.0.0+-}+newtype TomlState a = TomlState+ { unTomlState :: TOML -> (Maybe a, TOML)+ }++-- | @since 1.3.0.0+instance Functor TomlState where+ fmap :: (a -> b) -> TomlState a -> TomlState b+ fmap f TomlState{..} = TomlState (first (fmap f) . unTomlState)+ {-# INLINE fmap #-}++ (<$) :: a -> TomlState b -> TomlState a+ a <$ TomlState{..} = TomlState (first (fmap (const a)) . unTomlState)+ {-# INLINE (<$) #-}++-- | @since 1.3.0.0+instance Applicative TomlState where+ pure :: a -> TomlState a+ pure a = TomlState (Just a,)+ {-# INLINE pure #-}++ (<*>) :: TomlState (a -> b) -> TomlState a -> TomlState b+ tsF <*> tsA = TomlState $ \t ->+ let (mF, tF) = unTomlState tsF t+ (mA, tA) = unTomlState tsA tF+ in (mF <*> mA , tA)+ {-# INLINE (<*>) #-}++-- | @since 1.3.0.0+instance Alternative TomlState where+ empty :: TomlState a+ empty = TomlState (Nothing,)+ {-# INLINE empty #-}++ (<|>) :: TomlState a -> TomlState a -> TomlState a+ ts1 <|> ts2 = TomlState $ \t -> let (m1, t1) = unTomlState ts1 t in case m1 of+ Nothing -> unTomlState ts2 t+ Just _ -> (m1, t1)+ {-# INLINE (<|>) #-}++-- | @since 1.3.0.0+instance Monad TomlState where+ return :: a -> TomlState a+ return = pure+ {-# INLINE return #-}++ (>>=) :: TomlState a -> (a -> TomlState b) -> TomlState b+ tsA >>= f = TomlState $ \t -> let (mA, newT) = unTomlState tsA t in case mA of+ Nothing -> (Nothing, newT)+ Just a -> unTomlState (f a) newT+ {-# INLINE (>>=) #-}++-- | @since 1.3.0.0+instance (s ~ TOML) => MonadState s TomlState where+ state :: (TOML -> (a, TOML)) -> TomlState a+ state f = TomlState (first Just . f)+ {-# INLINE state #-}++ get :: TomlState TOML+ get = TomlState (\t -> (Just t, t))+ {-# INLINE get #-}++ put :: TOML -> TomlState ()+ put t = TomlState (\_ -> (Just (), t))+ {-# INLINE put #-}++{- | Transform 'Either' into 'TomlState'.++@since 1.3.0.0+-}+eitherToTomlState :: Either e a -> TomlState a+eitherToTomlState e = TomlState (either (const Nothing) Just e,)
− src/Toml/Edsl.hs
@@ -1,76 +0,0 @@-{- | This module introduces EDSL for manually specifying 'TOML' data types.--Consider the following raw TOML:--@-key1 = 1-key2 = true--[meme-quotes]- quote1 = [ \"Oh\", \"Hi\", \"Mark\" ]--[[arrayName]]- elem1 = "yes"--[[arrayName]]- [arrayName.elem2]- deep = 7--[[arrayName]]-@--using functions from this module you can specify the above TOML in safer way:--@-exampleToml :: 'TOML'-exampleToml = 'mkToml' $ __do__- \"key1\" '=:' 1- \"key2\" '=:' Bool True- 'table' \"meme-quotes\" $- \"quote1\" '=:' Array [\"Oh\", \"Hi\", \"Mark\"]- 'tableArray' \"arrayName\" $- \"elem1\" '=:' \"yes\" :|- [ 'table' \"elem2\" $ \"deep\" '=:' Integer 7- , 'empty'- ]-@--}--module Toml.Edsl- ( TDSL- , mkToml- , empty- , (=:)- , table- , tableArray- ) where--import Control.Monad.State (State, execState, modify, put)-import Data.List.NonEmpty (NonEmpty)--import Toml.PrefixTree (Key)-import Toml.Type (TOML (..), Value, insertKeyVal, insertTable, insertTableArrays)----- | Monad for creating TOML.-type TDSL = State TOML ()---- | Creates 'TOML' from the 'TDSL'.-mkToml :: TDSL -> TOML-mkToml env = execState env mempty---- | Creates an empty 'TDSL'.-empty :: TDSL-empty = put mempty---- | Adds key-value pair to the 'TDSL'.-(=:) :: Key -> Value a -> TDSL-(=:) k v = modify $ insertKeyVal k v---- | Adds table to the 'TDSL'.-table :: Key -> TDSL -> TDSL-table k = modify . insertTable k . mkToml---- | Adds array of tables to the 'TDSL'.-tableArray :: Key -> NonEmpty TDSL -> TDSL-tableArray k = modify . insertTableArrays k . fmap mkToml
− src/Toml/Generic.hs
@@ -1,393 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE UndecidableInstances #-}--{- | This module contains implementation of the 'Generic' TOML codec. If your-data types are big and nested, and you want to have codecs for them without writing a lot of-boilerplate code, you can find this module helpful. Below you can find the detailed-explanation on how the 'Generic' codecs work.--Consider the following Haskell data types:--@-__data__ User = User- { age :: Int- , address :: Address- , socials :: [Social]- } __deriving__ ('Generic')--__data__ Address = Address- { street :: Text- , house :: Int- } __deriving__ ('Generic')--__data__ Social = Social- { name :: Text- , link :: Text- } __deriving__ ('Generic')-@--Value of the @User@ type represents the following TOML:--@-age = 27--[address]- street = "Miami Beach"- house = 42--[[socials]]- name = \"Twitter\"- link = "https://twitter.com/foo"--[[socials]]- name = \"GitHub\"- link = "https://github.com/bar"-@--Normally you would write 'TomlCodec' for this data type like this:--@-userCodec :: 'TomlCodec' User-userCodec = User- \<$\> Toml.int "age" .= age- \<*\> Toml.table addressCodec "address" .= address- \<*\> Toml.list socialCodec "socials" .= socials--addressCodec :: 'TomlCodec' Address-addressCodec = Address- \<$\> Toml.text "street" .= street- \<*\> Toml.int "house" .= house--socialCodec :: 'TomlCodec' Social-socialCodec = Social- \<$\> Toml.text "name" .= name- \<*\> Toml.text "link" .= link-@--However, if you derive 'Generic' instance for your data types (as we do in the-example), you can write your codecs in a simpler way.--@-userCodec :: 'TomlCodec' User-userCodec = 'genericCodec'--__instance__ 'HasCodec' Address __where__- hasCodec = Toml.table 'genericCodec'--__instance__ 'HasItemCodec' Social __where__- hasItemCodec = Right 'genericCodec'-@--Several notes about the interface:--1. Your top-level data types are always implemented as 'genericCodec' (or other-generic codecs).-2. If you have a custom data type as a field of another type, you need to implement-the instance of the 'HasCodec' typeclass.-3. If the data type appears as an element of a list, you need to implement the instance-of the 'HasItemCodec' typeclass.--@since 1.1.1.0--}--module Toml.Generic- ( genericCodec- , genericCodecWithOptions- , stripTypeNameCodec-- -- * Options- , TomlOptions (..)- , GenericOptions (..)- , stripTypeNameOptions- , stripTypeNamePrefix-- -- * Core generic typeclass- , HasCodec (..)- , HasItemCodec (..)- , GenericCodec (..)- ) where--import Data.Char (isLower, toLower)-import Data.IntSet (IntSet)-import Data.Kind (Type)-import Data.List (stripPrefix)-import Data.List.NonEmpty (NonEmpty)-import Data.Proxy (Proxy (..))-import Data.String (IsString (..))-import Data.Text (Text)-import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime)-import Data.Typeable (Typeable, typeRep)-import Data.Word (Word)-import GHC.Generics ((:*:) (..), (:+:), C1, D1, Generic (..), K1 (..), M1 (..), Rec0, S1,- Selector (..))-import GHC.TypeLits (ErrorMessage (..), TypeError)-import Numeric.Natural (Natural)--import Toml.Bi (TomlBiMap, TomlCodec, (.=))-import Toml.PrefixTree (Key)-import Toml.Type (AnyValue)--import qualified Data.Text.Lazy as L-import qualified Toml.Bi as Toml---{- | Generic codec for arbitrary data types. Uses field names as keys.--}-genericCodec :: (Generic a, GenericCodec (Rep a)) => TomlCodec a-genericCodec = Toml.dimap from to $ genericTomlCodec (GenericOptions id)-{-# INLINE genericCodec #-}--{- | Generic codec with options for arbitrary data types.--}-genericCodecWithOptions- :: forall a- . (Generic a, GenericCodec (Rep a), Typeable a)- => TomlOptions a- -> TomlCodec a-genericCodecWithOptions = Toml.dimap from to . genericTomlCodec . toGenericOptions @a-{-# INLINE genericCodecWithOptions #-}--{- | Generic codec that uses 'stripTypeNameOptions'.--}-stripTypeNameCodec- :: forall a- . (Generic a, GenericCodec (Rep a), Typeable a)- => TomlCodec a-stripTypeNameCodec = genericCodecWithOptions $ stripTypeNameOptions @a-{-# INLINE stripTypeNameCodec #-}--------------------------------------------------------------------------------- Generic typeclasses-------------------------------------------------------------------------------{- | Options to configure various parameters of generic encoding. Specifically:--* __'tomlOptionsFieldModifier'__: how to translate field names to TOML keys?--}-data TomlOptions a = TomlOptions- { tomlOptionsFieldModifier :: Typeable a => Proxy a -> String -> String- }--{- | Same as 'TomlOptions' but with all data type information erased. This data-type is used internally. Define your options using 'TomlOptions' data type.--}-newtype GenericOptions = GenericOptions- { genericOptionsFieldModifier :: String -> String- }--toGenericOptions :: forall a . Typeable a => TomlOptions a -> GenericOptions-toGenericOptions TomlOptions{..} = GenericOptions- { genericOptionsFieldModifier = tomlOptionsFieldModifier (Proxy @a)- }---- | Options that use 'stripTypeNamePrefix' as 'tomlOptionsFieldModifier'.-stripTypeNameOptions :: Typeable a => TomlOptions a-stripTypeNameOptions = TomlOptions- { tomlOptionsFieldModifier = stripTypeNamePrefix- }--{- | Strips name of the type name from field name prefix.-->>> data UserData = UserData { userDataId :: Int, userDataShortInfo :: Text }->>> stripTypeNamePrefix (Proxy @UserData) "userDataId"-"id"->>> stripTypeNamePrefix (Proxy @UserData) "userDataShortInfo"-"shortInfo"->>> stripTypeNamePrefix (Proxy @UserData) "udStats"-"stats"->>> stripTypeNamePrefix (Proxy @UserData) "fooBar"-"bar"->>> stripTypeNamePrefix (Proxy @UserData) "name"-"name"--}-stripTypeNamePrefix :: forall a . Typeable a => Proxy a -> String -> String-stripTypeNamePrefix _ fieldName =- case stripPrefix (headToLower $ typeName @a) fieldName of- Just rest -> leaveIfEmpty rest- Nothing -> leaveIfEmpty (dropWhile isLower fieldName)- where- headToLower :: String -> String- headToLower = \case- [] -> error "Cannot use 'headToLower' on empty Text"- x:xs -> toLower x : xs-- -- if all lower case then leave field as it is- leaveIfEmpty :: String -> String- leaveIfEmpty rest = if null rest then fieldName else headToLower rest--typeName :: forall a . Typeable a => String-typeName = show $ typeRep (Proxy @a)--------------------------------------------------------------------------------- Generic typeclasses-------------------------------------------------------------------------------class GenericCodec (f :: k -> Type) where- genericTomlCodec :: GenericOptions -> TomlCodec (f p)--instance GenericCodec f => GenericCodec (D1 d f) where- genericTomlCodec = Toml.dimap unM1 M1 . genericTomlCodec- {-# INLINE genericTomlCodec #-}--type GenericSumTomlNotSupported =- 'Text "Generic TOML deriving for arbitrary sum types is not supported currently."--instance (TypeError GenericSumTomlNotSupported) => GenericCodec (f :+: g) where- genericTomlCodec = error "Not supported"--instance GenericCodec f => GenericCodec (C1 c f) where- genericTomlCodec = Toml.dimap unM1 M1 . genericTomlCodec- {-# INLINE genericTomlCodec #-}--instance (GenericCodec f, GenericCodec g) => GenericCodec (f :*: g) where- genericTomlCodec options = (:*:)- <$> genericTomlCodec options .= fstG- <*> genericTomlCodec options .= sndG- where- fstG :: (f :*: g) p -> f p- fstG (f :*: _) = f-- sndG :: (f :*: g) p -> g p- sndG (_ :*: g) = g- {-# INLINE genericTomlCodec #-}--instance (Selector s, HasCodec a) => GenericCodec (S1 s (Rec0 a)) where- genericTomlCodec GenericOptions{..} = genericWrap $ hasCodec @a fieldName- where- genericWrap :: TomlCodec a -> TomlCodec (S1 s (Rec0 a) p)- genericWrap = Toml.dimap (unK1 . unM1) (M1 . K1)-- fieldName :: Key- fieldName =- fromString- $ genericOptionsFieldModifier- $ selName (error "S1" :: S1 s Proxy ())- {-# INLINE genericTomlCodec #-}--------------------------------------------------------------------------------- Helper typeclasses-------------------------------------------------------------------------------{- | This typeclass tells how the data type should be coded as an item of a-list. Lists in TOML can have two types: __primitive__ and __table of arrays__.--* If 'hasItemCodec' returns 'Left': __primitive__ arrays codec is used.-* If 'hasItemCodec' returns 'Right:' __table of arrays__ codec is used.--}-class HasItemCodec a where- hasItemCodec :: Either (TomlBiMap a AnyValue) (TomlCodec a)--instance HasItemCodec Bool where hasItemCodec = Left Toml._Bool-instance HasItemCodec Int where hasItemCodec = Left Toml._Int-instance HasItemCodec Word where hasItemCodec = Left Toml._Word-instance HasItemCodec Integer where hasItemCodec = Left Toml._Integer-instance HasItemCodec Natural where hasItemCodec = Left Toml._Natural-instance HasItemCodec Double where hasItemCodec = Left Toml._Double-instance HasItemCodec Float where hasItemCodec = Left Toml._Float-instance HasItemCodec Text where hasItemCodec = Left Toml._Text-instance HasItemCodec L.Text where hasItemCodec = Left Toml._LText-instance HasItemCodec ZonedTime where hasItemCodec = Left Toml._ZonedTime-instance HasItemCodec LocalTime where hasItemCodec = Left Toml._LocalTime-instance HasItemCodec Day where hasItemCodec = Left Toml._Day-instance HasItemCodec TimeOfDay where hasItemCodec = Left Toml._TimeOfDay-instance HasItemCodec IntSet where hasItemCodec = Left Toml._IntSet--{- | If data type @a@ is not primitive then this instance returns codec for list-under key equal to @a@ type name.--}-instance (HasItemCodec a, Typeable a) => HasItemCodec [a] where- hasItemCodec = case hasItemCodec @a of- Left prim -> Left $ Toml._Array prim- Right codec -> Right $ Toml.list codec (fromString $ typeName @a)--{- | Helper typeclass for generic deriving. This instance tells how the data-type should be coded if it's a field of another data type.--__NOTE:__ If you implement TOML codecs for your data types manually, prefer more-explicit @Toml.int@ or @Toml.text@ instead of implicit @Toml.hasCodec@.-Implement instances of this typeclass only when using 'genericCodec' and when-your custom data types are not covered here.--}-class HasCodec a where- hasCodec :: Key -> TomlCodec a--instance HasCodec Bool where hasCodec = Toml.bool-instance HasCodec Int where hasCodec = Toml.int-instance HasCodec Word where hasCodec = Toml.word-instance HasCodec Integer where hasCodec = Toml.integer-instance HasCodec Natural where hasCodec = Toml.natural-instance HasCodec Double where hasCodec = Toml.double-instance HasCodec Float where hasCodec = Toml.float-instance HasCodec Text where hasCodec = Toml.text-instance HasCodec L.Text where hasCodec = Toml.lazyText-instance HasCodec ZonedTime where hasCodec = Toml.zonedTime-instance HasCodec LocalTime where hasCodec = Toml.localTime-instance HasCodec Day where hasCodec = Toml.day-instance HasCodec TimeOfDay where hasCodec = Toml.timeOfDay-instance HasCodec IntSet where hasCodec = Toml.arrayIntSet--instance HasCodec a => HasCodec (Maybe a) where- hasCodec = Toml.dioptional . hasCodec @a--instance HasItemCodec a => HasCodec [a] where- hasCodec = case hasItemCodec @a of- Left prim -> Toml.arrayOf prim- Right codec -> Toml.list codec--instance HasItemCodec a => HasCodec (NonEmpty a) where- hasCodec = case hasItemCodec @a of- Left prim -> Toml.arrayNonEmptyOf prim- Right codec -> Toml.nonEmpty codec--{--TODO: uncomment when higher-kinded roles will be implemented-* https://github.com/ghc-proposals/ghc-proposals/pull/233--{- | @newtype@ for generic deriving of 'HasCodec' typeclass for custom data-types that should we wrapped into separate table. Use it only for data types-that are fields of another data types.--@-data Person = Person- { personName :: Text- , personAddress :: Address- } deriving (Generic)--data Address = Address- { addressStreet :: Text- , addressHouse :: Int- } deriving (Generic)- deriving HasCodec via TomlTable Address--personCodec :: TomlCodec Person-personCodec = genericCodec-@--@personCodec@ corresponds to the TOML of the following structure:--@-name = "foo"-[address]- street = \"Bar\"- house = 42-@--}-newtype TomlTable a = TomlTable- { unTomlTable :: a- }--instance (Generic a, GenericCodec (Rep a)) => HasCodec (TomlTable a) where- hasCodec :: Key -> TomlCodec (TomlTable a)- hasCodec = Toml.diwrap . Toml.table (genericCodec @a)--instance (Generic a, GenericCodec (Rep a)) => HasItemCodec (TomlTable a) where- hasItemCodec = Right $ Toml.diwrap $ genericCodec @a--}
src/Toml/Parser.hs view
@@ -1,31 +1,63 @@-{-# LANGUAGE DeriveAnyClass #-}+{- |+Module : Toml.Parser+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable --- | Parser for text to TOML AST.+Parser for text to TOML AST. +@since 0.0.0+-}+ module Toml.Parser- ( ParseException (..)+ ( TomlParseError (..) , parse+ , parseKey ) where import Control.DeepSeq (NFData)-import Data.Text (Text, pack)+import Data.Text (Text) import GHC.Generics (Generic) -import Toml.Parser.TOML (tomlP)-import Toml.Type (TOML)+import Toml.Parser.Item (tomlP)+import Toml.Parser.Key (keyP)+import Toml.Parser.Validate (validateItems)+import Toml.Type.Key (Key)+import Toml.Type.TOML (TOML) +import qualified Data.Text as T import qualified Toml.Parser.Core as P (errorBundlePretty, parse) --- | Pretty parse exception for parsing toml.-newtype ParseException = ParseException Text- deriving (Show, Eq, Generic, NFData)+{- | Pretty parse exception for parsing toml. -{- | Parses 'Text' as 'TOML' AST object. If you want to convert 'Text' to your-custom haskell data type, use 'Toml.Bi.Code.decode' or 'Toml.Bi.Code.decodeFile'-functions.+@since 1.3.0.0 -}-parse :: Text -> Either ParseException TOML+newtype TomlParseError = TomlParseError+ { unTomlParseError :: Text+ } deriving stock (Show, Generic)+ deriving newtype (Eq, NFData)++{- | Parses 'Data.Text.Text' as 'TOML' AST object. If you want to+convert 'Data.Text.Text' to your custom haskell data type, use+'Toml.Codec.Code.decode' or 'Toml.Codec.Code.decodeFile' functions.++@since 0.0.0+-}+parse :: Text -> Either TomlParseError TOML parse t = case P.parse tomlP "" t of- Left err -> Left $ ParseException $ pack $ P.errorBundlePretty err- Right toml -> Right toml+ Left err -> Left $ TomlParseError $ T.pack $ P.errorBundlePretty err+ Right items -> case validateItems items of+ Left err -> Left $ TomlParseError $ T.pack $ show err+ Right toml -> Right toml++{- | Parse TOML 'Key' from 'Text'.++@since 1.3.0.0+-}+parseKey :: Text -> Either TomlParseError Key+parseKey t = case P.parse keyP "" t of+ Left err -> Left $ TomlParseError $ T.pack $ P.errorBundlePretty err+ Right key -> Right key
src/Toml/Parser/Core.hs view
@@ -1,3 +1,14 @@+{- |+Module : Toml.Parser.Core+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++Core functions for TOML parser.+-}+ module Toml.Parser.Core ( -- * Reexports from @megaparsec@ module Text.Megaparsec@@ -18,7 +29,7 @@ import Text.Megaparsec (Parsec, anySingle, eof, errorBundlePretty, match, parse, satisfy, try, (<?>))-import Text.Megaparsec.Char (alphaNumChar, char, digitChar, eol, hexDigitChar, space, space1,+import Text.Megaparsec.Char (alphaNumChar, char, digitChar, eol, hexDigitChar, octDigitChar, binDigitChar, space, space1, string, tab) import Text.Megaparsec.Char.Lexer (binary, float, hexadecimal, octal, signed, skipLineComment, symbol)
+ src/Toml/Parser/Item.hs view
@@ -0,0 +1,115 @@+{- |+Module : Toml.Parser.Item+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++This module contains the definition of the 'TomlItem' data type which+represents either key-value pair or table name. This data type serves the+purpose to be the intermediate representation of parsing a TOML file which will+be assembled to TOML AST later.++@since 1.2.0.0+-}++module Toml.Parser.Item+ ( TomlItem (..)+ , Table (..)+ , setTableName++ , tomlP+ , keyValP+ ) where++import Control.Applicative (liftA2, many)+import Control.Applicative.Combinators.NonEmpty (sepEndBy1)+import Control.Monad.Combinators (between, sepEndBy)+import Data.Foldable (asum)+import Data.List.NonEmpty (NonEmpty)++import Toml.Parser.Core (Parser, eof, sc, text, try, (<?>))+import Toml.Parser.Key (keyP, tableArrayNameP, tableNameP)+import Toml.Parser.Value (anyValueP)+import Toml.Type.AnyValue (AnyValue)+import Toml.Type.Key (Key)+++{- | One item of a TOML file. It could be either:++* A name of a table+* A name of a table array+* Key-value pair+* Inline table+* Inline array of tables++Knowing a list of 'TomlItem's, it's possible to construct 'Toml.Type.TOML.TOML'+from this information.+-}+data TomlItem+ = TableName !Key+ | TableArrayName !Key+ | KeyVal !Key !AnyValue+ | InlineTable !Key !Table+ | InlineTableArray !Key !(NonEmpty Table)+ deriving stock (Show, Eq)++{- | Changes name of table to a new one. Works only for 'TableName' and+'TableArrayName' constructors.+-}+setTableName :: Key -> TomlItem -> TomlItem+setTableName new = \case+ TableName _ -> TableName new+ TableArrayName _ -> TableArrayName new+ item -> item++{- | Table that contains only @key = val@ pairs.+-}+newtype Table = Table+ { unTable :: [(Key, AnyValue)]+ } deriving stock (Show)+ deriving newtype (Eq)++----------------------------------------------------------------------------+-- Parser+----------------------------------------------------------------------------++-- | Parser for inline tables.+inlineTableP :: Parser Table+inlineTableP =+ fmap Table+ $ between (text "{") (text "}")+ $ liftA2 (,) (keyP <* text "=") anyValueP `sepEndBy` text ","++-- | Parser for inline arrays of tables.+inlineTableArrayP :: Parser (NonEmpty Table)+inlineTableArrayP = between (text "[") (text "]")+ $ inlineTableP `sepEndBy1` text ","++-- | Parser for a single item in the TOML file.+tomlItemP :: Parser TomlItem+tomlItemP = asum+ [ TableName <$> try tableNameP <?> "table name"+ , TableArrayName <$> tableArrayNameP <?> "array of tables name"+ , keyValP+ ]++{- | parser for @"key = val"@ pairs; can be one of three forms:++1. key = { ... }+2. key = [ {...}, {...}, ... ]+3. key = ...+-}+keyValP :: Parser TomlItem+keyValP = do+ key <- keyP <* text "="+ asum+ [ InlineTable key <$> inlineTableP <?> "inline table"+ , InlineTableArray key <$> try inlineTableArrayP <?> "inline array of tables"+ , KeyVal key <$> anyValueP <?> "key-value pair"+ ]++-- | Parser for the full content of the .toml file.+tomlP :: Parser [TomlItem]+tomlP = sc *> many tomlItemP <* eof
+ src/Toml/Parser/Key.hs view
@@ -0,0 +1,58 @@+{- |+Module : Toml.Parser.Key+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++Parsers for keys and table names.++@since 1.2.0.0+-}++module Toml.Parser.Key+ ( keyP+ , tableNameP+ , tableArrayNameP+ ) where++import Control.Applicative (Alternative (..))+import Control.Applicative.Combinators.NonEmpty (sepBy1)+import Control.Monad.Combinators (between)+import Data.Text (Text)++import Toml.Parser.Core (Parser, alphaNumChar, char, lexeme, text)+import Toml.Parser.String (basicStringP, literalStringP)+import Toml.Type.Key (Key (..), Piece (..))++import qualified Data.Text as Text+++-- | Parser for bare key piece, like @foo@.+bareKeyPieceP :: Parser Text+bareKeyPieceP = lexeme $ Text.pack <$> bareStrP+ where+ bareStrP :: Parser String+ bareStrP = some $ alphaNumChar <|> char '_' <|> char '-'++-- | Parser for 'Piece'.+keyComponentP :: Parser Piece+keyComponentP = Piece <$>+ (bareKeyPieceP <|> (quote "\"" <$> basicStringP) <|> (quote "'" <$> literalStringP))+ where+ -- adds " or ' to both sides+ quote :: Text -> Text -> Text+ quote q t = q <> t <> q++-- | Parser for 'Key': dot-separated list of 'Piece'.+keyP :: Parser Key+keyP = Key <$> keyComponentP `sepBy1` char '.'++-- | Parser for table name: 'Key' inside @[]@.+tableNameP :: Parser Key+tableNameP = between (text "[") (text "]") keyP++-- | Parser for array of tables name: 'Key' inside @[[]]@.+tableArrayNameP :: Parser Key+tableArrayNameP = between (text "[[") (text "]]") keyP
src/Toml/Parser/String.hs view
@@ -1,4 +1,12 @@-{- | Parsers for strings in TOML format, including basic and literal strings+{- |+Module : Toml.Parser.String+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++Parsers for strings in TOML format, including basic and literal strings both singleline and multiline. -} @@ -11,7 +19,6 @@ import Control.Applicative (Alternative (..)) import Control.Applicative.Combinators (count, manyTill, optional) import Data.Char (chr, isControl)-import Data.Semigroup ((<>)) import Data.Text (Text) import Toml.Parser.Core (Parser, anySingle, char, eol, hexDigitChar, lexeme, satisfy, space, string,
− src/Toml/Parser/TOML.hs
@@ -1,134 +0,0 @@-{- | Parser for 'TOML' data type: keys, tables, array of tables. Uses value-parsers from "Toml.Parser.Value".--}--module Toml.Parser.TOML- ( keyP- , tomlP- ) where--import Control.Applicative (Alternative (..))-import Control.Monad.Combinators (between, sepEndBy)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Semigroup ((<>))-import Data.Text (Text)--import Toml.Parser.Core (Parser, alphaNumChar, char, eof, lexeme, sc, text, try)-import Toml.Parser.String (basicStringP, literalStringP)-import Toml.Parser.Value (anyValueP)-import Toml.PrefixTree (Key (..), KeysDiff (..), Piece (..), keysDiff, single)-import Toml.Type (AnyValue, TOML (..))--import qualified Control.Applicative.Combinators.NonEmpty as NC-import qualified Data.HashMap.Lazy as HashMap-import qualified Data.Text as Text----- | Parser for bare key piece, like @foo@.-bareKeyPieceP :: Parser Text-bareKeyPieceP = lexeme $ Text.pack <$> bareStrP- where- bareStrP :: Parser String- bareStrP = some $ alphaNumChar <|> char '_' <|> char '-'---- | Parser for 'Piece'.-keyComponentP :: Parser Piece-keyComponentP = Piece <$>- (bareKeyPieceP <|> (quote "\"" <$> basicStringP) <|> (quote "'" <$> literalStringP))- where- -- adds " or ' to both sides- quote :: Text -> Text -> Text- quote q t = q <> t <> q---- | Parser for 'Key': dot-separated list of 'Piece'.-keyP :: Parser Key-keyP = Key <$> keyComponentP `NC.sepBy1` char '.'---- | Parser for table name: 'Key' inside @[]@.-tableNameP :: Parser Key-tableNameP = between (text "[") (text "]") keyP---- | Parser for array of tables name: 'Key' inside @[[]]@.-tableArrayNameP :: Parser Key-tableArrayNameP = between (text "[[") (text "]]") keyP---- Helper functions for building TOML-tomlKV :: Key -> AnyValue -> TOML-tomlKV k v = mempty { tomlPairs = HashMap.singleton k v }--tomlT :: Key -> TOML -> TOML-tomlT k t = mempty { tomlTables = single k t }--tomlA :: Key -> NonEmpty TOML -> TOML-tomlA k a = mempty { tomlTableArrays = HashMap.singleton k a }---- | Parser for lines starting with 'key =', either values, inline tables or--- inline arrays of tables.-hasKeyP :: Maybe Key -> Parser TOML-hasKeyP key = do- k <- keyP <* text "="- table k <|> try (tableArray k) <|> (tomlKV k <$> anyValueP)- where- table :: Key -> Parser TOML- table k = do- (kDiff, _) <- childKeyP key (pure k)- tomlT kDiff <$> inlineTableP-- tableArray :: Key -> Parser TOML- tableArray k = do- (kDiff, _) <- childKeyP key (pure k)- tomlA kDiff <$> inlineTableArrayP---- | Parser for inline tables.-inlineTableP :: Parser TOML-inlineTableP = between (text "{") (text "}") $- mconcat <$>- (tomlKV <$> (keyP <* text "=") <*> anyValueP ) `sepEndBy` text ","---- | Parser for inline arrays of tables.-inlineTableArrayP :: Parser (NonEmpty TOML)-inlineTableArrayP = between (text "[") (text "]") $- inlineTableP `NC.sepEndBy1` text ","---- | Parser for an array of tables under a certain key.-tableArrayP :: Key -> Parser (NonEmpty TOML)-tableArrayP key =- localTomlP (Just key) `NC.sepBy1` sameKeyP key tableArrayNameP---- | Parser for a '.toml' file-tomlP :: Parser TOML-tomlP = sc *> localTomlP Nothing <* eof---- | Parser for a toml under a certain key-localTomlP :: Maybe Key -> Parser TOML-localTomlP key = mconcat <$> many (subArray <|> subTable <|> (try $ hasKeyP key))- where- subTable :: Parser TOML- subTable = do- (kDiff, k) <- try $ childKeyP key tableNameP- tomlT kDiff <$> localTomlP (Just k)-- subArray :: Parser TOML- subArray = do- (kDiff, k) <- try $ childKeyP key tableArrayNameP- tomlA kDiff <$> tableArrayP k---- | @childKeyP (Just key) p@ checks if the result of @p@ if a child key of--- @key@ and returns the difference of the keys and the child key.--- @childKeyP Nothing p@ is only called from @tomlP@ (no parent key).-childKeyP :: Maybe Key -> Parser Key -> Parser (Key, Key)-childKeyP Nothing parser = (\k -> (k, k)) <$> parser-childKeyP (Just key) parser = do- k <- parser- case keysDiff key k of- FstIsPref d -> pure (d, k)- _ -> fail $ show k ++ " is not a child key of " ++ show key---- | @sameKeyP key p@ returns the result of @p@ if the key returned by @p@ is--- the same as @key@, and fails otherwise.-sameKeyP :: Key -> Parser Key -> Parser Key-sameKeyP key parser = try $ do- k <- parser- case keysDiff key k of- Equal -> pure k- _ -> fail $ show k ++ " is not the same as " ++ show key
+ src/Toml/Parser/Validate.hs view
@@ -0,0 +1,190 @@+{- |+Module : Toml.Parser.Validate+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++This module contains functions that aggregate the result of+'Toml.Parser.Item.tomlP' parser into 'TOML'. This approach allows to keep parser+fast and simple and delegate the process of creating tree structure to a+separate function.++@since 1.2.0.0+-}++module Toml.Parser.Validate+ ( -- * Decoding+ validateItems+ , ValidationError (..)++ -- * Internal helpers+ , groupItems+ , groupWithParent+ , validateItemForest+ ) where++import Data.Bifunctor (first)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Tree (Forest, Tree (..))++import Toml.Parser.Item (Table (..), TomlItem (..), setTableName)+import Toml.Type.Key (Key, KeysDiff (FstIsPref), keysDiff)+import Toml.Type.TOML (TOML (..), insertKeyAnyVal, insertTable, insertTableArrays)++import qualified Data.HashMap.Strict as HashMap+import qualified Toml.Type.PrefixTree as PrefixMap+++{- | Validate list of 'TomlItem's and convert to 'TOML' if not validation+errors are found.+-}+validateItems :: [TomlItem] -> Either ValidationError TOML+validateItems = validateItemForest . groupItems++----------------------------------------------------------------------------+-- Grouping+----------------------------------------------------------------------------++{- | This function takes flat list of 'TomlItem's and groups it into list of+'Tree's by putting all corresponding items inside tables and table arrays. It+doesn't perform any validation, just groups items according to prefixes of their+keys. So, for example, if you have the following keys as flat list:++@+aaa # ordinary key+aaa.bbb # ordinary key+[foo] # table nam+foo.bar+foo.baz+[xxx] # table name+[xxx.yyy] # table name+zzz+@++the following tree structure will be created:++@+aaa+aaa.bbb+[foo]+├──── foo.bar+└──── foo.baz+[xxx]+└──── [yyy]+ └──── zzz+@+-}+groupItems :: [TomlItem] -> Forest TomlItem+groupItems = fst . groupWithParent Nothing++{- | This function groups list of TOML items into 'Forest' and returns list of+items that are not children of specified parent.++__Invariant:__ When this function is called with 'Nothing', second element in+the result tuple should be empty list.+-}+groupWithParent+ :: Maybe Key -- ^ Parent name+ -> [TomlItem] -- ^ List of items+ -> (Forest TomlItem, [TomlItem]) -- ^ Forest of times and remaining items+groupWithParent _ [] = ([], [])+groupWithParent parent (item:items) = case item of+ KeyVal{} -> Node item [] <:> groupWithParent parent items+ InlineTable{} -> Node item [] <:> groupWithParent parent items+ InlineTableArray{} -> Node item [] <:> groupWithParent parent items+ TableName name -> groupTable item name+ TableArrayName name -> groupTable item name+ where+ -- prepend to the first list, just to remove some code noise+ (<:>) :: a -> ([a], b) -> ([a], b)+ a <:> tup = first (a :) tup++ -- takes table item and its name, collects all children into table subforest+ -- and returns all elements after the table+ groupTable :: TomlItem -> Key -> (Forest TomlItem, [TomlItem])+ groupTable tableItem tableName = case parent of+ Nothing -> tableWithChildren tableName+ Just parentKey -> case keysDiff parentKey tableName of+ FstIsPref diff -> tableWithChildren diff+ _ -> ([], item:items)+ where+ tableWithChildren :: Key -> (Forest TomlItem, [TomlItem])+ tableWithChildren newName =+ let (children, rest) = groupWithParent (Just tableName) items+ newItem = setTableName newName tableItem+ in Node newItem children <:> groupWithParent parent rest++----------------------------------------------------------------------------+-- Decoding+----------------------------------------------------------------------------++{- | Error that happens during validating TOML which is already syntactically+correct. For the list of all possible validation errors and their explanation,+see the following issue on GitHub:++* https://github.com/kowainik/tomland/issues/5+-}++data ValidationError+ = DuplicateKey !Key+ | DuplicateTable !Key+ | SameNameKeyTable !Key+ | SameNameTableArray !Key+ deriving stock (Show, Eq)++{- | Construct 'TOML' from the 'Forest' of 'TomlItem' and performing validation+of TOML at the same time.+-}+validateItemForest :: Forest TomlItem -> Either ValidationError TOML+validateItemForest = go mempty+ where+ go :: TOML -> Forest TomlItem -> Either ValidationError TOML+ go toml [] = Right toml+ go toml@TOML{..} (node:nodes) = case rootLabel node of+ -- ignore subforest here+ KeyVal key val -> do+ HashMap.lookup key tomlPairs `errorOnJust` DuplicateKey key+ PrefixMap.lookup key tomlTables `errorOnJust` SameNameKeyTable key+ go (insertKeyAnyVal key val toml) nodes++ -- ignore subforest here+ InlineTable key table -> do+ HashMap.lookup key tomlPairs `errorOnJust` SameNameKeyTable key+ HashMap.lookup key tomlTableArrays `errorOnJust` SameNameTableArray key+ PrefixMap.lookup key tomlTables `errorOnJust` DuplicateTable key+ tableToml <- createTomlFromTable table+ go (insertTable key tableToml toml) nodes++ -- ignore subforest here+ InlineTableArray key tables -> do+ PrefixMap.lookup key tomlTables `errorOnJust` SameNameTableArray key+ arrayToml <- mapM createTomlFromTable tables+ go (insertTableArrays key arrayToml toml) nodes++ TableName key -> do+ HashMap.lookup key tomlPairs `errorOnJust` SameNameKeyTable key+ HashMap.lookup key tomlTableArrays `errorOnJust` SameNameTableArray key+ PrefixMap.lookup key tomlTables `errorOnJust` DuplicateTable key+ subTable <- go mempty (subForest node)+ go (insertTable key subTable toml) nodes++ TableArrayName key -> do+ PrefixMap.lookup key tomlTables `errorOnJust` SameNameTableArray key+ subTable <- go mempty (subForest node)+ let newArray = case HashMap.lookup key tomlTableArrays of+ Nothing -> HashMap.insert key (subTable :| []) tomlTableArrays+ Just arr ->+ HashMap.insert key (arr <> (subTable :| [])) tomlTableArrays+ go (toml { tomlTableArrays = newArray }) nodes++ createTomlFromTable :: Table -> Either ValidationError TOML+ createTomlFromTable (Table table) =+ go mempty $ map (\(k, v) -> Node (KeyVal k v) []) table++++errorOnJust :: Maybe a -> e -> Either e ()+errorOnJust (Just _) e = Left e+errorOnJust Nothing _ = Right ()
src/Toml/Parser/Value.hs view
@@ -1,5 +1,14 @@--- | Parser for 'UValue'.+{- |+Module : Toml.Parser.Value+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable +Parser for 'UValue'.+-}+ module Toml.Parser.Value ( arrayP , boolP@@ -14,12 +23,14 @@ import Control.Applicative.Combinators (between, count, option, optional, sepBy1, sepEndBy, skipMany) import Data.Fixed (Pico)-import Data.Semigroup ((<>)) import Data.Time (Day, LocalTime (..), TimeOfDay, ZonedTime (..), fromGregorianValid, makeTimeOfDayValid, minutesToTimeZone)+import Data.String (fromString)+ import Text.Read (readMaybe)+import Text.Megaparsec (observing, parseMaybe) -import Toml.Parser.Core (Parser, binary, char, digitChar, hexadecimal, lexeme, octal, sc, signed,+import Toml.Parser.Core (Parser, char, digitChar, hexDigitChar, octDigitChar, binDigitChar, hexadecimal, octal, binary, lexeme, sc, signed, string, text, try, (<?>)) import Toml.Parser.String (textP) import Toml.Type (AnyValue, UValue (..), typeCheck)@@ -27,24 +38,54 @@ -- | Parser for decimap 'Integer': included parsing of underscore. decimalP :: Parser Integer-decimalP = zero <|> more+decimalP = do+ value <- observing $ try leadingZeroP+ case value of+ Left _ -> do+ try more+ Right _ -> + fail "Leading zero."+ where- zero, more :: Parser Integer- zero = 0 <$ char '0'+ leadingZeroP :: Parser String+ leadingZeroP = do+ count 1 (char '0') >>= (\_ -> some digitChar)++ more :: Parser Integer more = check =<< readMaybe . concat <$> sepBy1 (some digitChar) (char '_') check :: Maybe Integer -> Parser Integer check = maybe (fail "Not an integer") pure +++-- | Parser for hexadecimal, octal and binary numbers : included parsing+numberP :: Parser Integer -> Parser Char -> String -> Parser Integer+numberP parseInteger parseDigit errorMessage = more+ where+ more :: Parser Integer+ more = check =<< intValueMaybe . concat <$> sepBy1 (some parseDigit) (char '_')++ intValueMaybe :: String -> Maybe Integer+ intValueMaybe = parseMaybe parseInteger . fromString++ check :: Maybe Integer -> Parser Integer+ check = maybe (fail errorMessage) pure+++ -- | Parser for 'Integer' value. integerP :: Parser Integer integerP = lexeme (bin <|> oct <|> hex <|> dec) <?> "integer" where bin, oct, hex, dec :: Parser Integer- bin = try (char '0' *> char 'b') *> binary <?> "bin"- oct = try (char '0' *> char 'o') *> octal <?> "oct"- hex = try (char '0' *> char 'x') *> hexadecimal <?> "hex"+ bin = try (char '0' *> char 'b') *> binaryP <?> "bin"+ oct = try (char '0' *> char 'o') *> octalP <?> "oct"+ hex = try (char '0' *> char 'x') *> hexadecimalP <?> "hex" dec = signed sc decimalP <?> "dec"+ binaryP = numberP binary binDigitChar "Invalid binary number"+ octalP = numberP octal octDigitChar "Invalid ocatl number"+ hexadecimalP = numberP hexadecimal hexDigitChar "Invalid hexadecimal number" -- | Parser for 'Double' value. doubleP :: Parser Double
− src/Toml/PrefixTree.hs
@@ -1,222 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE PatternSynonyms #-}---- | Implementation of prefix tree for TOML AST.--module Toml.PrefixTree- ( -- * Core types- Piece (..)- , Key (..)- , Prefix- , pattern (:||)-- -- * Key difference- , KeysDiff (..)- , keysDiff-- -- * Non-empty prefix tree- , PrefixTree (..)- , (<|)- , singleT- , insertT- , lookupT- , toListT-- -- * Prefix map that stores roots of 'PrefixTree'- , PrefixMap- , single- , insert- , lookup- , fromList- , toList- ) where--import Prelude hiding (lookup)--import Control.DeepSeq (NFData)-import Data.Bifunctor (first)-import Data.Coerce (coerce)-import Data.Foldable (foldl')-import Data.Hashable (Hashable)-import Data.HashMap.Strict (HashMap)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Semigroup (Semigroup (..))-import Data.String (IsString (..))-import Data.Text (Text)-import GHC.Generics (Generic)--import qualified Data.HashMap.Strict as HashMap-import qualified Data.List.NonEmpty as NonEmpty-import qualified Data.Text as Text----- | Represents the key piece of some layer.-newtype Piece = Piece { unPiece :: Text }- deriving stock (Generic)- deriving newtype (Show, Eq, Ord, Hashable, IsString, NFData)--{- | Key of value in @key = val@ pair. Represents as non-empty list of key-components — 'Piece's. Key like--@-site."google.com"-@--is represented like--@-Key (Piece "site" :| [Piece "\\"google.com\\""])-@--}-newtype Key = Key { unKey :: NonEmpty Piece }- deriving stock (Generic)- deriving newtype (Show, Eq, Ord, Hashable, NFData, Semigroup)--{- | Split a dot-separated string into 'Key'. Empty string turns into a 'Key'-with single element — empty 'Piece'.--This instance is not safe for now. Use carefully. If you try to use as a key-string like this @site.\"google.com\"@ you will have list of three components-instead of desired two.--}-instance IsString Key where- fromString :: String -> Key- fromString = \case- "" -> Key ("" :| [])- s -> case Text.splitOn "." (fromString s) of- [] -> error "Text.splitOn returned empty string" -- can't happen- x:xs -> coerce @(NonEmpty Text) @Key (x :| xs)--{- | Bidirectional pattern synonym for constructing and deconstructing 'Key's.--}-pattern (:||) :: Piece -> [Piece] -> Key-pattern x :|| xs <- Key (x :| xs)- where- x :|| xs = Key (x :| xs)--{-# COMPLETE (:||) #-}---- | Type synonym for 'Key'.-type Prefix = Key---- | Map of layer names and corresponding 'PrefixTree's.-type PrefixMap a = HashMap Piece (PrefixTree a)---- | Data structure to represent table tree for @toml@.-data PrefixTree a- = Leaf -- ^ End of a key.- !Key -- ^ End piece of the key.- !a -- ^ Value at the end.- | Branch -- ^ Values along pieces of a key.- !Prefix -- ^ Greatest common key prefix.- !(Maybe a) -- ^ Possible value at that point.- !(PrefixMap a) -- ^ Values at suffixes of the prefix.- deriving (Show, Eq, NFData, Generic)--instance Semigroup (PrefixTree a) where- a <> b = foldl' (\tree (k, v) -> insertT k v tree) a (toListT b)---- | Data structure to compare keys.-data KeysDiff- = Equal -- ^ Keys are equal- | NoPrefix -- ^ Keys don't have any common part.- | FstIsPref -- ^ The first key is the prefix of the second one.- !Key -- ^ Rest of the second key.- | SndIsPref -- ^ The second key is the prefix of the first one.- !Key -- ^ Rest of the first key.- | Diff -- ^ Key have a common prefix.- !Key -- ^ Common prefix.- !Key -- ^ Rest of the first key.- !Key -- ^ Rest of the second key.- deriving (Show, Eq)---- | Compares two keys-keysDiff :: Key -> Key -> KeysDiff-keysDiff (x :|| xs) (y :|| ys)- | x == y = listSame xs ys []- | otherwise = NoPrefix- where- listSame :: [Piece] -> [Piece] -> [Piece] -> KeysDiff- listSame [] [] _ = Equal- listSame [] (s:ss) _ = FstIsPref $ s :|| ss- listSame (f:fs) [] _ = SndIsPref $ f :|| fs- listSame (f:fs) (s:ss) pr =- if f == s- then listSame fs ss (pr ++ [f])- else Diff (x :|| pr) (f :|| fs) (s :|| ss)---- | Prepends 'Piece' to the beginning of the 'Key'.-(<|) :: Piece -> Key -> Key-(<|) p k = Key (p NonEmpty.<| unKey k)---- | Creates a 'PrefixTree' of one key-value element.-singleT :: Key -> a -> PrefixTree a-singleT = Leaf---- | Creates a 'PrefixMap' of one key-value element.-single :: Key -> a -> PrefixMap a-single k@(p :|| _) = HashMap.singleton p . singleT k---- | Inserts key-value element into the given 'PrefixTree'.-insertT :: Key -> a -> PrefixTree a -> PrefixTree a-insertT newK newV (Leaf k v) =- case keysDiff k newK of- Equal -> Leaf k newV- NoPrefix -> error "Algorithm error: can't be equal prefixes in insertT:Leaf case"- FstIsPref rK -> Branch k (Just v) $ single rK newV- SndIsPref lK -> Branch newK (Just newV) $ single lK v- Diff p k1@(f :|| _) k2@(s :|| _) ->- Branch p Nothing $ HashMap.fromList [(f, Leaf k1 v), (s, Leaf k2 newV)]-insertT newK newV (Branch pref mv prefMap) =- case keysDiff pref newK of- Equal -> Branch pref (Just newV) prefMap- NoPrefix -> error "Algorithm error: can't be equal prefixes in insertT:Branch case"- FstIsPref rK -> Branch pref mv $ insert rK newV prefMap- SndIsPref lK@(piece :|| _) ->- Branch newK (Just newV) $ HashMap.singleton piece (Branch lK mv prefMap)- Diff p k1@(f :|| _) k2@(s :|| _) ->- Branch p Nothing $ HashMap.fromList [ (f, Branch k1 mv prefMap)- , (s, Leaf k2 newV)- ]---- | Inserts key-value element into the given 'PrefixMap'.-insert :: Key -> a -> PrefixMap a -> PrefixMap a-insert k@(p :|| _) v prefMap = case HashMap.lookup p prefMap of- Just tree -> HashMap.insert p (insertT k v tree) prefMap- Nothing -> HashMap.insert p (singleT k v) prefMap---- | Looks up the value at a key in the 'PrefixTree'.-lookupT :: Key -> PrefixTree a -> Maybe a-lookupT lk (Leaf k v) = if lk == k then Just v else Nothing-lookupT lk (Branch pref mv prefMap) =- case keysDiff pref lk of- Equal -> mv- NoPrefix -> Nothing- Diff _ _ _ -> Nothing- SndIsPref _ -> Nothing- FstIsPref k -> lookup k prefMap---- | Looks up the value at a key in the 'PrefixMap'.-lookup :: Key -> PrefixMap a -> Maybe a-lookup k@(p :|| _) prefMap = HashMap.lookup p prefMap >>= lookupT k---- | Constructs 'PrefixMap' structure from the given list of 'Key' and value pairs.-fromList :: [(Key, a)] -> PrefixMap a-fromList = foldl' insertPair mempty- where- insertPair :: PrefixMap a -> (Key, a) -> PrefixMap a- insertPair prefMap (k, v) = insert k v prefMap---- | Converts 'PrefixTree' to the list of pairs.-toListT :: PrefixTree a -> [(Key, a)]-toListT (Leaf k v) = [(k, v)]-toListT (Branch pref ma prefMap) = case ma of- Just a -> (:) (pref, a)- Nothing -> id- $ map (\(k, v) -> (pref <> k, v)) $ toList prefMap---- | Converts 'PrefixMap' to the list of pairs.-toList :: PrefixMap a -> [(Key, a)]-toList = concatMap (\(p, tr) -> first (p <|) <$> toListT tr) . HashMap.toList
− src/Toml/Printer.hs
@@ -1,201 +0,0 @@-{-# LANGUAGE TypeFamilies #-}--{- | Contains functions for pretty printing @toml@ types. -}--module Toml.Printer- ( PrintOptions(..)- , defaultOptions- , pretty- , prettyOptions- , prettyKey- ) where--import Data.Bifunctor (first)-import Data.Function (on)-import Data.HashMap.Strict (HashMap)-import Data.List (sortBy, splitAt)-import Data.List.NonEmpty (NonEmpty)-import Data.Monoid ((<>))-import Data.Text (Text)-import Data.Time (ZonedTime, defaultTimeLocale, formatTime)--import Toml.PrefixTree (Key (..), Piece (..), PrefixMap, PrefixTree (..))-import Toml.Type (AnyValue (..), TOML (..), Value (..))--import qualified Data.HashMap.Strict as HashMap-import qualified Data.List.NonEmpty as NonEmpty-import qualified Data.Text as Text--{- | Configures the pretty printer. -}-data PrintOptions = PrintOptions- { {- | How table keys should be sorted, if at all.-- @since 1.1.1.0- -}- printOptionsSorting :: !(Maybe (Key -> Key -> Ordering))-- {- | Number of spaces by which to indent.- -}- , printOptionsIndent :: !Int- }--{- | Default printing options.--1. Sorts all keys and tables by name.-2. Indents with 2 spaces.--}-defaultOptions :: PrintOptions-defaultOptions = PrintOptions (Just compare) 2--{- | Converts 'TOML' type into 'Data.Text.Text' (using 'defaultOptions').--For example, this--@-TOML- { tomlPairs = HashMap.fromList- [("title", AnyValue $ Text "TOML example")]- , tomlTables = PrefixTree.fromList- [( "example" <| "owner"- , mempty- { tomlPairs = HashMap.fromList- [("name", AnyValue $ Text "Kowainik")]- }- )]- , tomlTableArrays = mempty- }-@--will be translated to this--@-title = "TOML Example"--[example.owner]- name = \"Kowainik\"-@--}-pretty :: TOML -> Text-pretty = prettyOptions defaultOptions---- | Converts 'TOML' type into 'Data.Text.Text' using provided 'PrintOptions'-prettyOptions :: PrintOptions -> TOML -> Text-prettyOptions options = Text.unlines . prettyTomlInd options 0 ""---- | Converts 'TOML' into a list of 'Data.Text.Text' elements with the given indent.-prettyTomlInd :: PrintOptions -- ^ Printing options- -> Int -- ^ Current indentation- -> Text -- ^ Accumulator for table names- -> TOML -- ^ Given 'TOML'- -> [Text] -- ^ Pretty result-prettyTomlInd options i prefix TOML{..} = concat- [ prettyKeyValue options i tomlPairs- , prettyTables options i prefix tomlTables- , prettyTableArrays options i prefix tomlTableArrays- ]---- | Converts a key to text-prettyKey :: Key -> Text-prettyKey = Text.intercalate "." . map unPiece . NonEmpty.toList . unKey---- | Returns pretty formatted key-value pairs of the 'TOML'.-prettyKeyValue :: PrintOptions -> Int -> HashMap Key AnyValue -> [Text]-prettyKeyValue options i = mapOrdered (\kv -> [kvText kv]) options . HashMap.toList- where- kvText :: (Key, AnyValue) -> Text- kvText (k, AnyValue v) =- tabWith options i <> prettyKey k <> " = " <> valText v-- valText :: Value t -> Text- valText (Bool b) = Text.toLower $ showText b- valText (Integer n) = showText n- valText (Double d) = showDouble d- valText (Text s) = showText s- valText (Zoned z) = showZonedTime z- valText (Local l) = showText l- valText (Day d) = showText d- valText (Hours h) = showText h- valText (Array a) = "[" <> Text.intercalate ", " (map valText a) <> "]"-- showText :: Show a => a -> Text- showText = Text.pack . show-- showDouble :: Double -> Text- showDouble d | isInfinite d && d < 0 = "-inf"- | isInfinite d = "inf"- | isNaN d = "nan"- | otherwise = showText d-- showZonedTime :: ZonedTime -> Text- showZonedTime t = Text.pack $ showZonedDateTime t <> showZonedZone t- where- showZonedDateTime = formatTime defaultTimeLocale "%FT%T%Q"- showZonedZone- = (\(x,y) -> x ++ ":" ++ y)- . (\z -> splitAt (length z - 2) z)- . formatTime defaultTimeLocale "%z"---- | Returns pretty formatted tables section of the 'TOML'.-prettyTables :: PrintOptions -> Int -> Text -> PrefixMap TOML -> [Text]-prettyTables options i pref asPieces = mapOrdered (prettyTable . snd) options asKeys- where- asKeys :: [(Key, PrefixTree TOML)]- asKeys = map (first pieceToKey) $ HashMap.toList asPieces-- pieceToKey :: Piece -> Key- pieceToKey = Key . pure-- prettyTable :: PrefixTree TOML -> [Text]- prettyTable (Leaf k toml) =- let name = addPrefix k pref- -- Each "" results in an empty line, inserted above table names- in "": tabWith options i <> prettyTableName name :- -- We don't want empty lines between a table name and a subtable name- dropWhile (== "") (prettyTomlInd options (i + 1) name toml)-- prettyTable (Branch k mToml prefMap) =- let name = addPrefix k pref- nextI = i + 1- toml = case mToml of- Nothing -> []- Just t -> prettyTomlInd options nextI name t- -- Each "" results in an empty line, inserted above table names- in "": tabWith options i <> prettyTableName name :- -- We don't want empty lines between a table name and a subtable name- dropWhile (== "") (toml ++ prettyTables options nextI name prefMap)-- prettyTableName :: Text -> Text- prettyTableName n = "[" <> n <> "]"--prettyTableArrays :: PrintOptions -> Int -> Text -> HashMap Key (NonEmpty TOML) -> [Text]-prettyTableArrays options i pref = mapOrdered arrText options . HashMap.toList- where- arrText :: (Key, NonEmpty TOML) -> [Text]- arrText (k, ne) =- let name = addPrefix k pref- render toml =- -- Each "" results in an empty line, inserted above array names- "": tabWith options i <> "[[" <> name <> "]]" :- -- We don't want empty lines between an array name and a subtable name- dropWhile (== "") (prettyTomlInd options (i + 1) name toml)- in concatMap render $ NonEmpty.toList ne---------------------------------------------------------- Helper functions---------------------------------------------------------- Returns an indentation prefix-tabWith :: PrintOptions -> Int -> Text-tabWith PrintOptions{..} n = Text.replicate (n * printOptionsIndent) " "---- Returns a proper sorting function-mapOrdered :: ((Key, v) -> [t]) -> PrintOptions -> [(Key, v)] -> [t]-mapOrdered f options = case printOptionsSorting options of- Just sorter -> concatMap f . sortBy (sorter `on` fst)- Nothing -> concatMap f---- Adds next part of the table name to the accumulator.-addPrefix :: Key -> Text -> Text-addPrefix key = \case- "" -> prettyKey key- prefix -> prefix <> "." <> prettyKey key
src/Toml/Type.hs view
@@ -1,13 +1,76 @@--- | Core types for TOML AST.+{- |+Module : Toml.Type+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable +Core types for TOML AST.+-}+ module Toml.Type- ( module Toml.Type.AnyValue- , module Toml.Type.TOML- , module Toml.Type.UValue- , module Toml.Type.Value- ) where+ ( -- $toml+ module Toml.Type.TOML +-- -- $edsl+-- , module Toml.Type.Edsl+-- Edsl.table conflicts with Codec.table++ -- $printer+ , module Toml.Type.Printer+ -- $prefix+ , module Toml.Type.PrefixTree+ -- $key+ , module Toml.Type.Key+ -- $uvalue+ , module Toml.Type.UValue+ -- $value+ , module Toml.Type.Value+ -- $anyvalue+ , module Toml.Type.AnyValue+ ) where+ import Toml.Type.AnyValue+-- import Toml.Type.Edsl+import Toml.Type.Key+import Toml.Type.PrefixTree+import Toml.Type.Printer import Toml.Type.TOML import Toml.Type.UValue import Toml.Type.Value++{- $toml+Main TOML AST data type. Text is converted to 'TOML' first. All codecs+work with the 'TOML' type instead of raw text.+-}++-- {- $eDSL+-- eDSL for type-safe construction of the 'TOML' values.+-- -}++{- $printer+Pretty-printer for 'TOML'.+-}++{- $prefix+'PrefixMap' and 'PrefixTree' types that help representing 'TOML' AST.+-}++{- $key+Key in key-value pairs and table names. Also 'Key' in 'PrefixMap'.+-}++{- $uvalue+Untyped value obtained directly from parsing.+-}++{- $value+Typed 'Value'. Result of type-checking 'UValue'.+-}++{- $anyvalue+Existential wrapper around 'Value' to be able to store 'Value's of+different types inside lists or other containers like+'Data.Map.Strict.Map' or 'Data.HashMap.Strict.HashMap'.+-}
src/Toml/Type/AnyValue.hs view
@@ -5,8 +5,19 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} --- | Existential wrapper over 'Value' type and matching functions.+{- |+Module : Toml.Type.AnyValue+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable +Existential wrapper over 'Value' type and matching functions.++@since 0.0.0+-}+ module Toml.Type.AnyValue ( AnyValue (..) , reifyAnyValues@@ -36,7 +47,10 @@ import Toml.Type.Value (TValue (..), TypeMismatchError (..), Value (..), sameValue) --- | Existential wrapper for 'Value'.+{- | Existential wrapper for 'Value'.++@since 0.0.0+-} data AnyValue = forall (t :: TValue) . AnyValue (Value t) instance Show AnyValue where@@ -52,9 +66,10 @@ -- | Value type mismatch error. data MatchError = MatchError- { valueExpected :: TValue- , valueActual :: AnyValue- } deriving (Eq, Show, Generic, NFData)+ { valueExpected :: !TValue+ , valueActual :: !AnyValue+ } deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData) -- | Helper function to create 'MatchError'. mkMatchError :: TValue -> Value t -> Either MatchError a@@ -68,46 +83,55 @@ matchBool :: Value t -> Either MatchError Bool matchBool (Bool b) = Right b matchBool value = mkMatchError TBool value+{-# INLINE matchBool #-} -- | Extract 'Prelude.Integer' from 'Value'. matchInteger :: Value t -> Either MatchError Integer matchInteger (Integer n) = Right n matchInteger value = mkMatchError TInteger value+{-# INLINE matchInteger #-} -- | Extract 'Prelude.Double' from 'Value'. matchDouble :: Value t -> Either MatchError Double matchDouble (Double f) = Right f matchDouble value = mkMatchError TDouble value+{-# INLINE matchDouble #-} -- | Extract 'Data.Text.Text' from 'Value'. matchText :: Value t -> Either MatchError Text matchText (Text s) = Right s matchText value = mkMatchError TText value+{-# INLINE matchText #-} -- | Extract 'Data.Time.ZonedTime' from 'Value'. matchZoned :: Value t -> Either MatchError ZonedTime matchZoned (Zoned d) = Right d matchZoned value = mkMatchError TZoned value+{-# INLINE matchZoned #-} -- | Extract 'Data.Time.LocalTime' from 'Value'. matchLocal :: Value t -> Either MatchError LocalTime matchLocal (Local d) = Right d matchLocal value = mkMatchError TLocal value+{-# INLINE matchLocal #-} -- | Extract 'Data.Time.Day' from 'Value'. matchDay :: Value t -> Either MatchError Day matchDay (Day d) = Right d matchDay value = mkMatchError TDay value+{-# INLINE matchDay #-} -- | Extract 'Data.Time.TimeOfDay' from 'Value'. matchHours :: Value t -> Either MatchError TimeOfDay matchHours (Hours d) = Right d matchHours value = mkMatchError THours value+{-# INLINE matchHours #-} -- | Extract list of elements of type @a@ from array. matchArray :: (AnyValue -> Either MatchError a) -> Value t -> Either MatchError [a] matchArray matchValue (Array a) = mapM (applyAsToAny matchValue) a matchArray _ value = mkMatchError TArray value+{-# INLINE matchArray #-} -- | Make function that works with 'AnyValue' also work with specific 'Value'. applyAsToAny :: (AnyValue -> r) -> (Value t -> r)
+ src/Toml/Type/Edsl.hs view
@@ -0,0 +1,110 @@+{- |+Module : Toml.Type.Edsl+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++This module introduces EDSL for manually specifying 'TOML' data types.++Consider the following raw TOML:++@+key1 = 1+key2 = true++[meme-quotes]+ quote1 = [ \"Oh\", \"Hi\", \"Mark\" ]++[[arrayName]]+ elem1 = "yes"++[[arrayName]]+ [arrayName.elem2]+ deep = 7++[[arrayName]]+@++using functions from this module you can specify the above TOML in safer way:++@+exampleToml :: 'TOML'+exampleToml = 'mkToml' $ __do__+ \"key1\" '=:' 1+ \"key2\" '=:' Bool True+ 'table' \"meme-quotes\" $+ \"quote1\" '=:' Array [\"Oh\", \"Hi\", \"Mark\"]+ 'tableArray' \"arrayName\" $+ \"elem1\" '=:' \"yes\" :|+ [ 'table' \"elem2\" $ \"deep\" '=:' Integer 7+ , 'empty'+ ]+@++@since 0.3+-}++module Toml.Type.Edsl+ ( TDSL+ , mkToml+ , empty+ , (=:)+ , table+ , tableArray+ ) where++import Control.Monad.State (State, execState, modify, put)+import Data.List.NonEmpty (NonEmpty)++import Toml.Type.Key (Key)+import Toml.Type.TOML (TOML (..), insertKeyVal, insertTable, insertTableArrays)+import Toml.Type.Value (Value)+++{- | Monad for creating TOML.++@since 0.3+-}+type TDSL = State TOML ()++{- | Creates 'TOML' from the 'TDSL'.++@since 0.3+-}+mkToml :: TDSL -> TOML+mkToml env = execState env mempty+{-# INLINE mkToml #-}++{- | Creates an empty 'TDSL'.++@since 0.3+-}+empty :: TDSL+empty = put mempty+{-# INLINE empty #-}++{- | Adds key-value pair to the 'TDSL'.++@since 0.3+-}+(=:) :: Key -> Value a -> TDSL+(=:) k v = modify $ insertKeyVal k v+{-# INLINE (=:) #-}++{- | Adds table to the 'TDSL'.++@since 0.3+-}+table :: Key -> TDSL -> TDSL+table k = modify . insertTable k . mkToml+{-# INLINE table #-}++{- | Adds array of tables to the 'TDSL'.++@since 1.0.0+-}+tableArray :: Key -> NonEmpty TDSL -> TDSL+tableArray k = modify . insertTableArrays k . fmap mkToml+{-# INLINE tableArray #-}
+ src/Toml/Type/Key.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE PatternSynonyms #-}++{- |+Module : Toml.Type.Key+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++Implementation of key type. The type is used for key-value pairs and+table names.++@since 1.3.0.0+-}++module Toml.Type.Key+ ( -- * Core types+ Key (..)+ , Prefix+ , Piece (..)+ , pattern (:||)+ , (<|)++ -- * Key difference+ , KeysDiff (..)+ , keysDiff+ ) where++import Control.DeepSeq (NFData)+import Data.Coerce (coerce)+import Data.Hashable (Hashable)+import Data.List.NonEmpty (NonEmpty (..))+import Data.String (IsString (..))+import Data.Text (Text)+import GHC.Generics (Generic)++import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Text as Text+++{- | Represents the key piece of some layer.++@since 0.0.0+-}+newtype Piece = Piece+ { unPiece :: Text+ } deriving stock (Generic)+ deriving newtype (Show, Eq, Ord, Hashable, IsString, NFData)++{- | Key of value in @key = val@ pair. Represents as non-empty list of key+components — 'Piece's. Key like++@+site."google.com"+@++is represented like++@+Key (Piece "site" :| [Piece "\\"google.com\\""])+@++@since 0.0.0+-}+newtype Key = Key+ { unKey :: NonEmpty Piece+ } deriving stock (Generic)+ deriving newtype (Show, Eq, Ord, Hashable, NFData, Semigroup)++{- | Type synonym for 'Key'.++@since 0.0.0+-}+type Prefix = Key++{- | Split a dot-separated string into 'Key'. Empty string turns into a 'Key'+with single element — empty 'Piece'.++This instance is not safe for now. Use carefully. If you try to use as a key+string like this @site.\"google.com\"@ you will have list of three components+instead of desired two.++@since 0.1.0+-}+instance IsString Key where+ fromString :: String -> Key+ fromString = \case+ "" -> Key ("" :| [])+ s -> case Text.splitOn "." (fromString s) of+ [] -> error "Text.splitOn returned empty string" -- can't happen+ x:xs -> coerce @(NonEmpty Text) @Key (x :| xs)++{- | Bidirectional pattern synonym for constructing and deconstructing 'Key's.+-}+pattern (:||) :: Piece -> [Piece] -> Key+pattern x :|| xs <- Key (x :| xs)+ where+ x :|| xs = Key (x :| xs)++{-# COMPLETE (:||) #-}++-- | Prepends 'Piece' to the beginning of the 'Key'.+(<|) :: Piece -> Key -> Key+(<|) p k = Key (p NonEmpty.<| unKey k)+{-# INLINE (<|) #-}++{- | Data represent difference between two keys.++@since 0.0.0+-}+data KeysDiff+ = Equal -- ^ Keys are equal+ | NoPrefix -- ^ Keys don't have any common part.+ | FstIsPref -- ^ The first key is the prefix of the second one.+ !Key -- ^ Rest of the second key.+ | SndIsPref -- ^ The second key is the prefix of the first one.+ !Key -- ^ Rest of the first key.+ | Diff -- ^ Key have a common prefix.+ !Key -- ^ Common prefix.+ !Key -- ^ Rest of the first key.+ !Key -- ^ Rest of the second key.+ deriving stock (Show, Eq)++{- | Find key difference between two keys.++@since 0.0.0+-}+keysDiff :: Key -> Key -> KeysDiff+keysDiff (x :|| xs) (y :|| ys)+ | x == y = listSame xs ys []+ | otherwise = NoPrefix+ where+ listSame :: [Piece] -> [Piece] -> [Piece] -> KeysDiff+ listSame [] [] _ = Equal+ listSame [] (s:ss) _ = FstIsPref $ s :|| ss+ listSame (f:fs) [] _ = SndIsPref $ f :|| fs+ listSame (f:fs) (s:ss) pr =+ if f == s+ then listSame fs ss (pr ++ [f])+ else Diff (x :|| pr) (f :|| fs) (s :|| ss)
+ src/Toml/Type/PrefixTree.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE PatternSynonyms #-}++{- |+Module : Toml.Type.PrefixTree+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++Implementation of prefix tree for TOML AST.++@since 0.0.0+-}++module Toml.Type.PrefixTree+ (+ -- * Non-empty prefix tree+ PrefixTree (..)+ , singleT+ , insertT+ , lookupT+ , toListT+ , addPrefixT+ , differenceWithT++ -- * Prefix map that stores roots of 'PrefixTree'+ , PrefixMap+ , single+ , insert+ , lookup+ , fromList+ , toList+ , differenceWith+ ) where++import Prelude hiding (lookup)++import Control.DeepSeq (NFData)+import Data.Bifunctor (first)+import Data.Foldable (foldl')+import Data.HashMap.Strict (HashMap)+import GHC.Generics (Generic)++import Toml.Type.Key (pattern (:||), Key, KeysDiff (..), Piece, Prefix, keysDiff, (<|))++import qualified Data.HashMap.Strict as HashMap+++{- | Map of layer names and corresponding 'PrefixTree's.++@since 0.0.0+-}+type PrefixMap a = HashMap Piece (PrefixTree a)++{- | Data structure to represent table tree for @toml@.++@since 0.0.0+-}+data PrefixTree a+ = Leaf -- ^ End of a key.+ !Key -- ^ End piece of the key.+ !a -- ^ Value at the end.+ | Branch -- ^ Values along pieces of a key.+ !Prefix -- ^ Greatest common key prefix.+ !(Maybe a) -- ^ Possible value at that point.+ !(PrefixMap a) -- ^ Values at suffixes of the prefix.+ deriving stock (Show, Eq, Generic)+ deriving anyclass (NFData)++-- | @since 0.3+instance Semigroup (PrefixTree a) where+ a <> b = foldl' (\tree (k, v) -> insertT k v tree) a (toListT b)++{- | Push 'Prefix' inside the given 'PrefixTree'.++@since 1.3.2.0+-}+addPrefixT :: Prefix -> PrefixTree a -> PrefixTree a+addPrefixT pref = \case+ Leaf k a -> Leaf (pref <> k) a+ Branch k ma pma -> Branch (pref <> k) ma pma++{- | Convert branches to 'Leaf' or remove them at all.++@since 1.3.2.0+-}+compressTree :: PrefixTree a -> Maybe (PrefixTree a)+compressTree = \case+ l@(Leaf _ _) -> Just l+ b@(Branch p ma pma) -> case HashMap.toList pma of+ [] -> ma >>= \a -> Just (Leaf p a)+ [(_, child)] -> case ma of+ Just _ -> Just b+ Nothing -> compressTree $ addPrefixT p child+ _ : _ : _ -> Just b++{- | Creates a 'PrefixTree' of one key-value element.++@since 0.0.0+-}+singleT :: Key -> a -> PrefixTree a+singleT = Leaf+{-# INLINE singleT #-}++{- | Creates a 'PrefixMap' of one key-value element.++@since 0.0.0+-}+single :: Key -> a -> PrefixMap a+single k@(p :|| _) = HashMap.singleton p . singleT k++{- | Inserts key-value element into the given 'PrefixTree'.++@since 0.0.0+-}+insertT :: Key -> a -> PrefixTree a -> PrefixTree a+insertT newK newV (Leaf k v) =+ case keysDiff k newK of+ Equal -> Leaf k newV+ NoPrefix -> error "Algorithm error: can't be equal prefixes in insertT:Leaf case"+ FstIsPref rK -> Branch k (Just v) $ single rK newV+ SndIsPref lK -> Branch newK (Just newV) $ single lK v+ Diff p k1@(f :|| _) k2@(s :|| _) ->+ Branch p Nothing $ HashMap.fromList [(f, Leaf k1 v), (s, Leaf k2 newV)]+insertT newK newV (Branch pref mv prefMap) =+ case keysDiff pref newK of+ Equal -> Branch pref (Just newV) prefMap+ NoPrefix -> error "Algorithm error: can't be equal prefixes in insertT:Branch case"+ FstIsPref rK -> Branch pref mv $ insert rK newV prefMap+ SndIsPref lK@(piece :|| _) ->+ Branch newK (Just newV) $ HashMap.singleton piece (Branch lK mv prefMap)+ Diff p k1@(f :|| _) k2@(s :|| _) ->+ Branch p Nothing $ HashMap.fromList [ (f, Branch k1 mv prefMap)+ , (s, Leaf k2 newV)+ ]++{- | Inserts key-value element into the given 'PrefixMap'.++@since 0.0.0+-}+insert :: Key -> a -> PrefixMap a -> PrefixMap a+insert k@(p :|| _) v prefMap = case HashMap.lookup p prefMap of+ Just tree -> HashMap.insert p (insertT k v tree) prefMap+ Nothing -> HashMap.insert p (singleT k v) prefMap++{- | Looks up the value at a key in the 'PrefixTree'.++@since 0.0.0+-}+lookupT :: Key -> PrefixTree a -> Maybe a+lookupT lk (Leaf k v) = if lk == k then Just v else Nothing+lookupT lk (Branch pref mv prefMap) =+ case keysDiff pref lk of+ Equal -> mv+ NoPrefix -> Nothing+ Diff _ _ _ -> Nothing+ SndIsPref _ -> Nothing+ FstIsPref k -> lookup k prefMap++{- | Looks up the value at a key in the 'PrefixMap'.++@since 0.0.0+-}+lookup :: Key -> PrefixMap a -> Maybe a+lookup k@(p :|| _) prefMap = HashMap.lookup p prefMap >>= lookupT k++{- | Constructs 'PrefixMap' structure from the given list of 'Key' and value pairs.++@since 0.0.0+-}+fromList :: [(Key, a)] -> PrefixMap a+fromList = foldl' insertPair mempty+ where+ insertPair :: PrefixMap a -> (Key, a) -> PrefixMap a+ insertPair prefMap (k, v) = insert k v prefMap++{- | Converts 'PrefixTree' to the list of pairs.++@since 0.0.0+-}+toListT :: PrefixTree a -> [(Key, a)]+toListT (Leaf k v) = [(k, v)]+toListT (Branch pref ma prefMap) = case ma of+ Just a -> (:) (pref, a)+ Nothing -> id+ $ map (\(k, v) -> (pref <> k, v)) $ toList prefMap++{- | Converts 'PrefixMap' to the list of pairs.++@since 0.0.0+-}+toList :: PrefixMap a -> [(Key, a)]+toList = concatMap (\(p, tr) -> first (p <|) <$> toListT tr) . HashMap.toList++{- | Difference of two 'PrefixMap's. Returns elements of the first 'PrefixMap'+that are not existing in the second one.++@since 1.3.2.0+-}+differenceWith :: (a -> b -> Maybe a) -> PrefixMap a -> PrefixMap b -> PrefixMap a+differenceWith f = HashMap.differenceWith (differenceWithT f)++{- | Difference of two 'PrefixTree's. Returns elements of the first 'PrefixTree'+that are not existing in the second one.++@since 1.3.2.0+-}+differenceWithT :: (a -> b -> Maybe a) -> PrefixTree a -> PrefixTree b -> Maybe (PrefixTree a)+differenceWithT f pt1 pt2 = case (pt1, pt2) of+ (Leaf k1 a, Leaf k2 b)+ | k1 == k2 -> f a b >>= \aNew -> Just (Leaf k1 aNew)+ | otherwise -> Just (Leaf k1 a)++ (l@(Leaf k a), Branch p mb pmb) -> case keysDiff k p of+ Equal -> mb >>= f a >>= \aNew -> Just (Leaf k aNew)+ NoPrefix -> Just l+ FstIsPref _ -> Just l+ SndIsPref kSuf -> case HashMap.toList $ differenceWith f (single kSuf a) pmb of+ -- zero elements+ [] -> Nothing+ -- our single key+ [(_, aNew)] -> Just $ addPrefixT k aNew+ -- shouldn't happen, but for some reasons+ _ : _ : _ -> Nothing+ Diff _ _ _ -> Just l++ (br@(Branch p ma pma), Leaf k b) -> case keysDiff p k of+ Equal -> compressTree $ Branch p (ma >>= \a -> f a b) pma+ NoPrefix -> Just br+ FstIsPref kSuf -> compressTree $ Branch p ma (differenceWith f pma $ single kSuf b)+ SndIsPref _ -> Just br+ Diff _ _ _ -> Just br++ (b1@(Branch p1 ma pma), Branch p2 mb pmb) -> case keysDiff p1 p2 of+ Equal -> compressTree $+ Branch p1 (ma >>= \a -> mb >>= \b -> f a b) (differenceWith f pma pmb)+ NoPrefix -> Just b1+ FstIsPref p2Suf@(p2Head :|| _) -> compressTree $+ Branch p1 ma (differenceWith f pma $ HashMap.singleton p2Head $ Branch p2Suf mb pmb)+ SndIsPref p1Suf@(p1Head :|| _) -> case HashMap.lookup p1Head pmb of+ Nothing -> Just b1+ Just ch -> addPrefixT p2 <$> differenceWithT f (Branch p1Suf ma pma) ch+ Diff _ _ _ -> Just b1
+ src/Toml/Type/Printer.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE TypeFamilies #-}++{- |+Module : Toml.Type.Printer+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable++Contains functions for pretty printing @toml@ types.++@since 0.0.0+-}++module Toml.Type.Printer+ ( PrintOptions(..)+ , Lines(..)+ , defaultOptions+ , pretty+ , prettyOptions+ , prettyKey+ ) where++import GHC.Exts (sortWith)+import Data.Bifunctor (first)+import Data.Char (isAscii, ord)+import Data.Coerce (coerce)+import Data.Function (on)+import Data.HashMap.Strict (HashMap)+import Data.List (sortBy, foldl')+import Data.List.NonEmpty (NonEmpty)+import Data.Semigroup (stimes)+import Data.Text (Text)+import Data.Time (ZonedTime, defaultTimeLocale, formatTime)++import Text.Printf (printf)++import Toml.Type.AnyValue (AnyValue (..))+import Toml.Type.Key (Key (..), Piece (..))+import Toml.Type.PrefixTree (PrefixMap, PrefixTree (..))+import Toml.Type.TOML (TOML (..))+import Toml.Type.Value (Value (..))++import qualified Data.HashMap.Strict as HashMap+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Text as Text++++{- | Configures the pretty printer.++@since 0.5.0+-}+data PrintOptions = PrintOptions+ { {- | How table keys should be sorted, if at all.++ @since 1.1.0.0+ -}+ printOptionsSorting :: !(Maybe (Key -> Key -> Ordering))++ {- | Number of spaces by which to indent.++ @since 1.1.0.0+ -}+ , printOptionsIndent :: !Int+ {- | How to print Array.+ OneLine:++ @+ foo = [a, b]+ @++ MultiLine:++ @+ foo =+ [ a+ , b+ ]+ @++ Default is 'OneLine'.+ -}+ , printOptionsLines :: !Lines+ }++{- | Default printing options.++1. Sorts all keys and tables by name.+2. Indents with 2 spaces.++@since 0.5.0+-}+defaultOptions :: PrintOptions+defaultOptions = PrintOptions (Just compare) 2 OneLine++data Lines = OneLine | MultiLine++{- | Converts 'TOML' type into 'Data.Text.Text' (using 'defaultOptions').++For example, this++@+TOML+ { tomlPairs = HashMap.fromList+ [("title", AnyValue $ Text "TOML example")]+ , tomlTables = PrefixTree.fromList+ [( "example" <| "owner"+ , mempty+ { tomlPairs = HashMap.fromList+ [("name", AnyValue $ Text "Kowainik")]+ }+ )]+ , tomlTableArrays = mempty+ }+@++will be translated to this++@+title = "TOML Example"++[example.owner]+ name = \"Kowainik\"+@++@since 0.0.0+-}+pretty :: TOML -> Text+pretty = prettyOptions defaultOptions++{- | Converts 'TOML' type into 'Data.Text.Text' using provided 'PrintOptions'++@since 0.5.0+-}+prettyOptions :: PrintOptions -> TOML -> Text+prettyOptions options = Text.unlines . prettyTomlInd options 0 ""++-- | Converts 'TOML' into a list of 'Data.Text.Text' elements with the given indent.+prettyTomlInd :: PrintOptions -- ^ Printing options+ -> Int -- ^ Current indentation+ -> Text -- ^ Accumulator for table names+ -> TOML -- ^ Given 'TOML'+ -> [Text] -- ^ Pretty result+prettyTomlInd options i prefix TOML{..} = concat+ [ prettyKeyValue options i tomlPairs+ , prettyTables options i prefix tomlTables+ , prettyTableArrays options i prefix tomlTableArrays+ ]++{- | Converts a key to text++@since 0.0.0+-}+prettyKey :: Key -> Text+prettyKey = Text.intercalate "." . NonEmpty.toList . coerce+{-# INLINE prettyKey #-}++-- | Returns pretty formatted key-value pairs of the 'TOML'.+prettyKeyValue :: PrintOptions -> Int -> HashMap Key AnyValue -> [Text]+prettyKeyValue options i = mapOrdered (\kv -> [kvText kv]) options . HashMap.toList+ where+ kvText :: (Key, AnyValue) -> Text+ kvText (k, AnyValue v) =+ tabWith options i <> prettyKey k <> " = " <> valText v++ valText :: Value t -> Text+ valText (Bool b) = Text.toLower $ showText b+ valText (Integer n) = showText n+ valText (Double d) = showDouble d+ valText (Text s) = showTextUnicode s+ valText (Zoned z) = showZonedTime z+ valText (Local l) = showText l+ valText (Day d) = showText d+ valText (Hours h) = showText h+ valText (Array a) = withLines options valText a++ showText :: Show a => a -> Text+ showText = Text.pack . show+++ -- | Function encodes all non-ascii characters in TOML defined form using the isAscii function+ showTextUnicode :: Text -> Text+ showTextUnicode text = Text.pack $ show finalText+ where+ xss = Text.unpack text+ finalText = foldl' (\acc (ch, asciiCh) -> acc ++ getCh ch asciiCh) "" asciiArr++ asciiArr = zip xss $ asciiStatus xss++ getCh :: Char -> Bool -> String+ getCh ch True = [ch] -- it is true ascii character+ getCh ch False = printf "\\U%08x" (ord ch) :: String -- it is not true ascii character, it must be encoded++ asciiStatus :: String -> [Bool]+ asciiStatus = map isAscii++ showDouble :: Double -> Text+ showDouble d | isInfinite d && d < 0 = "-inf"+ | isInfinite d = "inf"+ | isNaN d = "nan"+ | otherwise = showText d++ showZonedTime :: ZonedTime -> Text+ showZonedTime t = Text.pack $ showZonedDateTime t <> showZonedZone t+ where+ showZonedDateTime = formatTime defaultTimeLocale "%FT%T%Q"+ showZonedZone+ = (\(x,y) -> x ++ ":" ++ y)+ . (\z -> splitAt (length z - 2) z)+ . formatTime defaultTimeLocale "%z"++-- | Returns pretty formatted tables section of the 'TOML'.+prettyTables :: PrintOptions -> Int -> Text -> PrefixMap TOML -> [Text]+prettyTables options i pref asPieces = mapOrdered (prettyTable . snd) options asKeys+ where+ asKeys :: [(Key, PrefixTree TOML)]+ asKeys = map (first pieceToKey) $ HashMap.toList asPieces++ pieceToKey :: Piece -> Key+ pieceToKey = Key . pure++ prettyTable :: PrefixTree TOML -> [Text]+ prettyTable (Leaf k toml) =+ let name = addPrefix k pref+ -- Each "" results in an empty line, inserted above table names+ in "": tabWith options i <> prettyTableName name :+ -- We don't want empty lines between a table name and a subtable name+ dropWhile (== "") (prettyTomlInd options (i + 1) name toml)++ prettyTable (Branch k mToml prefMap) =+ let name = addPrefix k pref+ nextI = i + 1+ toml = case mToml of+ Nothing -> []+ Just t -> prettyTomlInd options nextI name t+ -- Each "" results in an empty line, inserted above table names+ in "": tabWith options i <> prettyTableName name :+ -- We don't want empty lines between a table name and a subtable name+ dropWhile (== "") (toml ++ prettyTables options nextI name prefMap)++ prettyTableName :: Text -> Text+ prettyTableName n = "[" <> n <> "]"++prettyTableArrays :: PrintOptions -> Int -> Text -> HashMap Key (NonEmpty TOML) -> [Text]+prettyTableArrays options i pref = mapOrdered arrText options . HashMap.toList+ where+ arrText :: (Key, NonEmpty TOML) -> [Text]+ arrText (k, ne) =+ let name = addPrefix k pref+ render toml =+ -- Each "" results in an empty line, inserted above array names+ "": tabWith options i <> "[[" <> name <> "]]" :+ -- We don't want empty lines between an array name and a subtable name+ dropWhile (== "") (prettyTomlInd options (i + 1) name toml)+ in concatMap render $ NonEmpty.toList ne++-----------------------------------------------------+-- Helper functions+-----------------------------------------------------++-- Returns an indentation prefix+tabWith :: PrintOptions -> Int -> Text+tabWith PrintOptions{..} n = Text.replicate (n * printOptionsIndent) " "++-- Returns a proper sorting function+mapOrdered :: ((Key, v) -> [t]) -> PrintOptions -> [(Key, v)] -> [t]+mapOrdered f options = case printOptionsSorting options of+ Just sorter -> concatMap f . sortBy (sorter `on` fst)+ Nothing -> concatMap f . sortWith fst++-- Adds next part of the table name to the accumulator.+addPrefix :: Key -> Text -> Text+addPrefix key = \case+ "" -> prettyKey key+ prefix -> prefix <> "." <> prettyKey key++withLines :: PrintOptions -> (Value t -> Text) -> [Value t] -> Text+withLines PrintOptions{..} valTxt a = case printOptionsLines of+ OneLine -> "[" <> Text.intercalate ", " (map valTxt a) <> "]"+ MultiLine -> off <> "[ " <> Text.intercalate (off <> ", ") (map valTxt a) <> off <> "]"+ where+ off :: Text+ off = "\n" <> stimes printOptionsIndent " "
src/Toml/Type/TOML.hs view
@@ -1,27 +1,39 @@ {-# LANGUAGE DeriveAnyClass #-} --- | Type of TOML AST. This is intermediate representation of TOML parsed from text.+{- |+Module : Toml.Type.TOML+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable +Type of TOML AST. This is intermediate representation of TOML parsed from text.+-}+ module Toml.Type.TOML ( TOML (..) , insertKeyVal , insertKeyAnyVal , insertTable , insertTableArrays++ , tomlDiff ) where import Control.DeepSeq (NFData) import Data.HashMap.Strict (HashMap) import Data.List.NonEmpty (NonEmpty)-import Data.Semigroup (Semigroup (..)) import GHC.Generics (Generic) -import Toml.PrefixTree (Key (..), PrefixMap) import Toml.Type.AnyValue (AnyValue (..))+import Toml.Type.Key (Key (..))+import Toml.Type.PrefixTree (PrefixMap) import Toml.Type.Value (Value) import qualified Data.HashMap.Strict as HashMap-import qualified Toml.PrefixTree as Prefix+import qualified Data.List.NonEmpty as NE+import qualified Toml.Type.PrefixTree as Prefix {- | Represents TOML configuration value.@@ -84,39 +96,93 @@ ] } @++@since 0.0.0 -} data TOML = TOML- { tomlPairs :: HashMap Key AnyValue- , tomlTables :: PrefixMap TOML- , tomlTableArrays :: HashMap Key (NonEmpty TOML)- } deriving (Show, Eq, NFData, Generic)+ { tomlPairs :: !(HashMap Key AnyValue)+ , tomlTables :: !(PrefixMap TOML)+ , tomlTableArrays :: !(HashMap Key (NonEmpty TOML))+ } deriving stock (Show, Eq, Generic)+ deriving anyclass (NFData) +-- | @since 0.3 instance Semigroup TOML where- (TOML pairsA tablesA arraysA) <> (TOML pairsB tablesB arraysB) = TOML+ (<>) :: TOML -> TOML -> TOML+ TOML pairsA tablesA arraysA <> TOML pairsB tablesB arraysB = TOML (pairsA <> pairsB) (HashMap.unionWith (<>) tablesA tablesB) (arraysA <> arraysB)+ {-# INLINE (<>) #-} +-- | @since 0.3 instance Monoid TOML where- mappend = (<>)+ mempty :: TOML mempty = TOML mempty mempty mempty+ {-# INLINE mempty #-} + mappend :: TOML -> TOML -> TOML+ mappend = (<>)+ {-# INLINE mappend #-}+ -- | Inserts given key-value into the 'TOML'. insertKeyVal :: Key -> Value a -> TOML -> TOML insertKeyVal k v = insertKeyAnyVal k (AnyValue v)+{-# INLINE insertKeyVal #-} -- | Inserts given key-value into the 'TOML'. insertKeyAnyVal :: Key -> AnyValue -> TOML -> TOML-insertKeyAnyVal k av toml =toml { tomlPairs = HashMap.insert k av (tomlPairs toml) }+insertKeyAnyVal k av toml = toml { tomlPairs = HashMap.insert k av (tomlPairs toml) }+{-# INLINE insertKeyAnyVal #-} -- | Inserts given table into the 'TOML'. insertTable :: Key -> TOML -> TOML -> TOML insertTable k inToml toml = toml { tomlTables = Prefix.insert k inToml (tomlTables toml) }+{-# INLINE insertTable #-} -- | Inserts given array of tables into the 'TOML'. insertTableArrays :: Key -> NonEmpty TOML -> TOML -> TOML insertTableArrays k arr toml = toml { tomlTableArrays = HashMap.insert k arr (tomlTableArrays toml) }+{-# INLINE insertTableArrays #-}++{- | Difference of two 'TOML's. Returns elements of the first 'TOML' that are+not existing in the second one.++@since 1.3.2.0+-}+tomlDiff :: TOML -> TOML -> TOML+tomlDiff t1 t2 = TOML+ { tomlPairs = HashMap.difference (tomlPairs t1) (tomlPairs t2)+ , tomlTables = prefixMapDiff (tomlTables t1) (tomlTables t2)+ , tomlTableArrays = HashMap.differenceWith interTomlsDiff+ (tomlTableArrays t1)+ (tomlTableArrays t2)+ }+ where+ interTomlsDiff :: NonEmpty TOML -> NonEmpty TOML -> Maybe (NonEmpty TOML)+ interTomlsDiff tl1 tl2 = NE.nonEmpty $ tomlListDiff (NE.toList tl1) (NE.toList tl2)+{-# INLINE tomlDiff #-}++{- | Difference of two 'PrefixMap's. Returns elements of the first 'PrefixMap'+that are not existing in the second one.++@since 1.3.2.0+-}+prefixMapDiff :: PrefixMap TOML -> PrefixMap TOML -> PrefixMap TOML+prefixMapDiff = Prefix.differenceWith $ \toml1 toml2 -> let diff = tomlDiff toml1 toml2 in+ if diff == mempty+ then Nothing+ else Just diff+++tomlListDiff :: [TOML] -> [TOML] -> [TOML]+tomlListDiff [] _ = []+tomlListDiff ts [] = ts+tomlListDiff (t1:t1s) (t2:t2s) = let diff = tomlDiff t1 t2 in+ if diff == mempty+ then tomlListDiff t1s t2s+ else diff : tomlListDiff t1s t2s
src/Toml/Type/UValue.hs view
@@ -1,7 +1,18 @@ {-# LANGUAGE GADTs #-} --- | Intermediate untype value representation used for parsing.+{- |+Module : Toml.Type.UValue+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable +Intermediate untype value representation used for parsing.++@since 0.0.0+-}+ module Toml.Type.UValue ( UValue (..) , typeCheck@@ -14,8 +25,12 @@ import Toml.Type.AnyValue (AnyValue (..)) import Toml.Type.Value (TypeMismatchError, Value (..), sameValue) --- | Untyped value of @TOML@. You shouldn't use this type in your code. Use--- 'Value' instead.++{- | Untyped value of @TOML@. You shouldn't use this type in your+code. Use 'Value' instead.++@since 0.0.0+-} data UValue = UBool !Bool | UInteger !Integer@@ -26,8 +41,9 @@ | UDay !Day | UHours !TimeOfDay | UArray ![UValue]- deriving (Show)+ deriving stock (Show) +-- | @since 0.0.0 instance Eq UValue where (UBool b1) == (UBool b2) = b1 == b2 (UInteger i1) == (UInteger i2) = i1 == i2@@ -42,7 +58,10 @@ (UArray a1) == (UArray a2) = a1 == a2 _ == _ = False --- | Ensures that 'UValue's represents type-safe version of @toml@.+{- | Ensures that 'UValue's represents type-safe version of @toml@.++@since 0.0.0+-} typeCheck :: UValue -> Either TypeMismatchError AnyValue typeCheck (UBool b) = rightAny $ Bool b typeCheck (UInteger n) = rightAny $ Integer n
src/Toml/Type/Value.hs view
@@ -6,8 +6,19 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} --- | GADT value for TOML.+{- |+Module : Toml.Type.Value+Copyright : (c) 2018-2022 Kowainik+SPDX-License-Identifier : MPL-2.0+Maintainer : Kowainik <xrom.xkov@gmail.com>+Stability : Stable+Portability : Portable +GADT value for TOML.++@since 0.0.0+-}+ module Toml.Type.Value ( -- * Type of value TValue (..)@@ -30,15 +41,35 @@ import Data.Type.Equality ((:~:) (..)) import GHC.Generics (Generic) --- | Needed for GADT parameterization-data TValue = TBool | TInteger | TDouble | TText | TZoned | TLocal | TDay | THours | TArray- deriving (Eq, Show, Read, NFData, Generic) --- | Convert 'TValue' constructors to 'String' without @T@ prefix.+{- | Needed for GADT parameterization++@since 0.0.0+-}+data TValue+ = TBool+ | TInteger+ | TDouble+ | TText+ | TZoned+ | TLocal+ | TDay+ | THours+ | TArray+ deriving stock (Eq, Show, Read, Generic)+ deriving anyclass (NFData)++{- | Convert 'TValue' constructors to 'String' without @T@ prefix.++@since 0.0.0+-} showType :: TValue -> String showType = drop 1 . show --- | Value in @key = value@ pair.+{- | Value in @key = value@ pair.++@since 0.0.0+-} data Value (t :: TValue) where {- | Boolean value: @@ -167,7 +198,8 @@ -} Array :: [Value t] -> Value 'TArray -deriving instance Show (Value t)+-- | @since 0.0.0+deriving stock instance Show (Value t) instance NFData (Value t) where rnf (Bool n) = rnf n@@ -190,6 +222,7 @@ instance (t ~ 'TText) => IsString (Value t) where fromString = Text . fromString @Text+ {-# INLINE fromString #-} instance Eq (Value t) where (Bool b1) == (Bool b2) = b1 == b2@@ -204,7 +237,10 @@ (Hours a) == (Hours b) = a == b (Array a1) == (Array a2) = eqValueList a1 a2 --- | Compare list of 'Value' of possibly different types.+{- | Compare list of 'Value' of possibly different types.++@since 0.0.0+-} eqValueList :: [Value a] -> [Value b] -> Bool eqValueList [] [] = True eqValueList (x:xs) (y:ys) = case sameValue x y of@@ -212,8 +248,12 @@ Left _ -> False eqValueList _ _ = False --- | Reifies type of 'Value' into 'TValue'. Unfortunately, there's no way to--- guarantee that 'valueType' will return @t@ for object with type @Value \'t@.+{- | Reifies type of 'Value' into 'TValue'. Unfortunately, there's no+way to guarantee that 'valueType' will return @t@ for object with type+@Value \'t@.++@since 0.0.0+-} valueType :: Value t -> TValue valueType (Bool _) = TBool valueType (Integer _) = TInteger@@ -229,12 +269,16 @@ -- Typechecking values ---------------------------------------------------------------------------- --- | Data type that holds expected vs. actual type.+{- | Data type that holds expected vs. actual type.++@since 0.1.0+-} data TypeMismatchError = TypeMismatchError- { typeExpected :: TValue- , typeActual :: TValue- } deriving (Eq)+ { typeExpected :: !TValue+ , typeActual :: !TValue+ } deriving stock (Eq) +-- | @since 0.1.0 instance Show TypeMismatchError where show TypeMismatchError{..} = "Expected type '" ++ showType typeExpected ++ "' but actual type: '" ++ showType typeActual ++ "'"@@ -242,6 +286,8 @@ {- | Checks whether two values are the same. This function is used for type checking where first argument is expected type and second argument is actual type.++@since 0.0.0 -} sameValue :: Value a -> Value b -> Either TypeMismatchError (a :~: b) sameValue Bool{} Bool{} = Right Refl
test/Spec.hs view
@@ -1,1 +1,20 @@-{-# OPTIONS_GHC -F -pgmF tasty-discover #-}+module Main (main) where++import Test.Hspec (hspec, parallel)+import Test.Hspec.Hedgehog (modifyMaxDiscardRatio)++import Test.Toml.Codec (codecSpec)+import Test.Toml.Parser (parserSpec)+import Test.Toml.Type (typeSpec)+++{- Default QuickCheck discard Ratio is 10 while @hedgehog@s is 100.+So we need to modify it manually in here.++See issue: <https://github.com/parsonsmatt/hspec-hedgehog/issues/9>+-}+main :: IO ()+main = hspec $ modifyMaxDiscardRatio (+ 90) $ parallel $ do+ typeSpec+ parserSpec+ codecSpec
− test/Test/Toml/BiCode/Property.hs
@@ -1,178 +0,0 @@-module Test.Toml.BiCode.Property where--import Control.Applicative ((<|>))-import Control.Category ((>>>))-import Data.ByteString (ByteString)-import Data.HashSet (HashSet)-import Data.IntSet (IntSet)-import Data.List.NonEmpty (NonEmpty)-import Data.Set (Set)-import Data.Text (Text)-import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime, zonedTimeToUTC)-import GHC.Exts (fromList)-import Hedgehog (Gen, forAll, tripping)-import Numeric.Natural (Natural)--import Toml (TomlBiMap, TomlCodec, (.=))-import Toml.Bi.Code (decode, encode)--import Test.Toml.Gen (PropertyTest, genBool, genByteString, genDay, genDouble, genFloat, genHashSet,- genHours, genInt, genIntSet, genInteger, genLByteString, genLocal, genNatural,- genNonEmpty, genString, genText, genWord, genZoned, prop)--import qualified Data.ByteString.Lazy as L-import qualified Hedgehog.Gen as Gen-import qualified Hedgehog.Range as Range-import qualified Toml--test_encodeDecodeProp :: PropertyTest-test_encodeDecodeProp = prop "decode . encode == id" $ do- bigType <- forAll genBigType- tripping bigType (encode bigTypeCodec) (decode bigTypeCodec)--data BigType = BigType- { btBool :: !Bool- , btInteger :: !Integer- , btNatural :: !Natural- , btInt :: !Int- , btWord :: !Word- , btDouble :: !(Batman Double)- , btFloat :: !(Batman Float)- , btText :: !Text- , btString :: !String- , btBS :: !ByteString- , btLazyBS :: !L.ByteString- , btLocalTime :: !LocalTime- , btDay :: !Day- , btTimeOfDay :: !TimeOfDay- , btArray :: ![Int]- , btArraySet :: !(Set Word)- , btArrayIntSet :: !IntSet- , btArrayHashSet :: !(HashSet Natural)- , btArrayNonEmpty :: !(NonEmpty Text)- , btNonEmpty :: !(NonEmpty ByteString)- , btList :: ![Bool]- , btNewtype :: !BigTypeNewtype- , btSum :: !BigTypeSum- , btRecord :: !BigTypeRecord- } deriving (Show, Eq)---- | Wrapper over 'Double' and 'Float' to be equal on @NaN@ values.-newtype Batman a = Batman a- deriving (Show)--instance RealFloat a => Eq (Batman a) where- Batman a == Batman b =- if isNaN a- then isNaN b- else a == b--newtype BigTypeNewtype = BigTypeNewtype ZonedTime- deriving (Show)--instance Eq BigTypeNewtype where- (BigTypeNewtype a) == (BigTypeNewtype b) = zonedTimeToUTC a == zonedTimeToUTC b--data BigTypeSum = BigTypeSumA Integer | BigTypeSumB Text- deriving (Show, Eq)--data BigTypeRecord = BigTypeRecord- { btrBoolSet :: Set Bool- , btrNewtypeList :: [BigTypeSum]- } deriving (Show, Eq)--bigTypeCodec :: TomlCodec BigType-bigTypeCodec = BigType- <$> Toml.bool "bool" .= btBool- <*> Toml.integer "integer" .= btInteger- <*> Toml.natural "natural" .= btNatural- <*> Toml.int "int" .= btInt- <*> Toml.word "word" .= btWord- <*> Toml.diwrap (Toml.double "double") .= btDouble- <*> Toml.diwrap (Toml.float "float") .= btFloat- <*> Toml.text "text" .= btText- <*> Toml.string "string" .= btString- <*> Toml.byteString "bs" .= btBS- <*> Toml.lazyByteString "lbs" .= btLazyBS- <*> Toml.localTime "localTime" .= btLocalTime- <*> Toml.day "day" .= btDay- <*> Toml.timeOfDay "timeOfDay" .= btTimeOfDay- <*> Toml.arrayOf Toml._Int "arrayOfInt" .= btArray- <*> Toml.arraySetOf Toml._Word "arraySetOfWord" .= btArraySet- <*> Toml.arrayIntSet "arrayIntSet" .= btArrayIntSet- <*> Toml.arrayHashSetOf Toml._Natural "arrayHashSetDouble" .= btArrayHashSet- <*> Toml.arrayNonEmptyOf Toml._Text "arrayNonEmptyOfText" .= btArrayNonEmpty- <*> Toml.nonEmpty (Toml.byteString "bs") "nonEmptyBS" .= btNonEmpty- <*> Toml.list (Toml.bool "bool") "listBool" .= btList- <*> Toml.diwrap (Toml.zonedTime "nt.zonedTime") .= btNewtype- <*> bigTypeSumCodec .= btSum- <*> Toml.table bigTypeRecordCodec "table-record" .= btRecord--_BigTypeSumA :: TomlBiMap BigTypeSum Integer-_BigTypeSumA = Toml.prism BigTypeSumA $ \case- BigTypeSumA i -> Right i- other -> Toml.wrongConstructor "BigTypeSumA" other--_BigTypeSumB :: TomlBiMap BigTypeSum Text-_BigTypeSumB = Toml.prism BigTypeSumB $ \case- BigTypeSumB n -> Right n- other -> Toml.wrongConstructor "BigTypeSumB" other--bigTypeSumCodec :: TomlCodec BigTypeSum-bigTypeSumCodec =- Toml.match (_BigTypeSumA >>> Toml._Integer) "sum.integer"- <|> Toml.match (_BigTypeSumB >>> Toml._Text) "sum.text"--bigTypeRecordCodec :: TomlCodec BigTypeRecord-bigTypeRecordCodec = BigTypeRecord- <$> Toml.arraySetOf Toml._Bool "rboolSet" .= btrBoolSet- <*> Toml.list bigTypeSumCodec "rnewtype" .= btrNewtypeList--------------------------------------------------------------------------------- Generator-------------------------------------------------------------------------------genBigType :: Gen BigType-genBigType = do- btBool <- genBool- btInteger <- genInteger- btNatural <- genNatural- btInt <- genInt- btWord <- genWord- btDouble <- Batman <$> genDouble- btFloat <- Batman <$> genFloat- btText <- genText- btString <- genString- btBS <- genByteString- btLazyBS <- genLByteString- btLocalTime <- genLocal- btDay <- genDay- btTimeOfDay <- genHours- btArray <- Gen.list (Range.constant 0 5) genInt- btArraySet <- Gen.set (Range.constant 0 5) genWord- btArrayIntSet <- genIntSet- btArrayHashSet <- genHashSet genNatural- btArrayNonEmpty <- genNonEmpty genText- btNonEmpty <- genNonEmpty genByteString- btList <- Gen.list (Range.constant 0 5) genBool- btNewtype <- genNewType- btSum <- genSum- btRecord <- genRec- pure BigType {..}---- Custom generators--genNewType :: Gen BigTypeNewtype-genNewType = BigTypeNewtype <$> genZoned--genSum :: Gen BigTypeSum-genSum = Gen.choice- [ BigTypeSumA <$> genInteger- , BigTypeSumB <$> genText- ]--genRec :: Gen BigTypeRecord-genRec = do- btrBoolSet <- fromList <$> Gen.list (Range.constant 0 5) genBool- btrNewtypeList <- Gen.list (Range.constant 0 5) genSum- pure BigTypeRecord{..}
− test/Test/Toml/BiMap/Property.hs
@@ -1,64 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Test.Toml.BiMap.Property where--import Hedgehog (Gen, PropertyT, assert, forAll, tripping, (===))--import Data.Time (ZonedTime (..))-import Test.Tasty (testGroup)-import Test.Toml.Gen (PropertyTest, prop)-import Toml.Bi.Map (BiMap (..), TomlBiMap)--import qualified Hedgehog.Gen as Gen-import qualified Test.Toml.Gen as G-import qualified Toml.Bi.Map as B---testBiMap- :: (Monad m, Show a, Show b, Eq a)- => TomlBiMap a b- -> Gen a- -> PropertyT m ()-testBiMap bimap gen = do- x <- forAll gen- tripping x (forward bimap) (backward bimap =<<)---- Double needs a special test because NaN /= NaN-testDouble :: PropertyT IO ()-testDouble = do- x <- forAll G.genDouble- if isNaN x- then assert $- fmap isNaN (forward B._Double x >>= backward B._Double) == Right True- else (forward B._Double x >>= backward B._Double) === Right x--test_BiMaps :: PropertyTest-test_BiMaps = pure $ testGroup "BiMap roundtrip tests" $ concat- [ prop "Bool" (testBiMap B._Bool G.genBool)- , prop "Integer" (testBiMap B._Integer G.genInteger)- , prop "Natural" (testBiMap B._Natural G.genNatural)- , prop "Int" (testBiMap B._Int G.genInt)- , prop "Word" (testBiMap B._Word G.genWord)- , prop "Double" testDouble- , prop "Float" (testBiMap B._Float G.genFloat)- , prop "Text" (testBiMap B._Text G.genText)- , prop "LazyText" (testBiMap B._LText G.genLText)- , prop "String" (testBiMap B._String G.genString)- , prop "Read (Integer)" (testBiMap B._Read G.genInteger)- , prop "ByteString" (testBiMap B._ByteString G.genByteString)- , prop "Lazy ByteString" (testBiMap B._LByteString G.genLByteString)- , prop "ZonedTime" (testBiMap B._ZonedTime G.genZoned)- , prop "LocalTime" (testBiMap B._LocalTime G.genLocal)- , prop "TimeOfDay" (testBiMap B._TimeOfDay G.genHours)- , prop "Day" (testBiMap B._Day G.genDay)- , prop "IntSet" (testBiMap B._IntSet G.genIntSet)- , prop "Array (Day)" (testBiMap (B._Array B._Day) (G.genList G.genDay))- , prop "Set (Day)" (testBiMap (B._Set B._Day) (Gen.set G.range100 G.genDay))- , prop "NonEmpty (Day)" (testBiMap (B._NonEmpty B._Day) (G.genNonEmpty G.genDay))- , prop "HashSet (Integer)" (testBiMap (B._HashSet B._Integer) (G.genHashSet G.genInteger))- ]---- Orphan instances--instance Eq ZonedTime where- (ZonedTime a b) == (ZonedTime c d) = a == c && b == d
+ test/Test/Toml/Codec.hs view
@@ -0,0 +1,22 @@+module Test.Toml.Codec+ ( codecSpec+ ) where++import Test.Hspec (Spec, describe, parallel)++import Test.Toml.Codec.BiMap (biMapSpec)+import Test.Toml.Codec.Code (codeSpec)+import Test.Toml.Codec.Combinator (combinatorSpec)+import Test.Toml.Codec.Di (diSpec)+import Test.Toml.Codec.Generic (genericSpec)+import Test.Toml.Codec.SmallType (smallTypeSpec)+++codecSpec :: Spec+codecSpec = parallel $ describe "Codec: unit and property tests for bidirectional codecs" $ do+ biMapSpec+ codeSpec+ combinatorSpec+ diSpec+ genericSpec+ smallTypeSpec
+ test/Test/Toml/Codec/BiMap.hs view
@@ -0,0 +1,67 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Test.Toml.Codec.BiMap+ ( biMapSpec+ ) where++import Prelude hiding (id, (.))++import Control.Category (id, (.))+import Data.Word (Word8)+import Hedgehog (Gen, PropertyT, forAll, (===))+import Test.Hspec (Spec, describe, it, parallel)+import Test.Hspec.Hedgehog (hedgehog)++import Test.Toml.Codec.BiMap.Conversion (conversionSpec)+import Test.Toml.Gen (genInteger, genText, genWord8)+import Toml.Codec.BiMap (BiMap (..), TomlBiMap)+import Toml.Codec.BiMap.Conversion (_BoundedInteger, _ReadString, _StringText)+++biMapSpec :: Spec+biMapSpec = parallel $ describe "Tagged Partial Bidirectional Isomorphism: tests" $ do+ conversionSpec+ categoryLaws++categoryLaws :: Spec+categoryLaws = describe "BiMap Category instance laws" $ do+ it "Right identity: f . id ≡ f" $ biMapEquality+ (_Word8Integer . id)+ _Word8Integer+ genWord8+ genInteger++ it "Left identity: id . f ≡ f" $ biMapEquality+ _Word8Integer+ (_Word8Integer . id)+ genWord8+ genInteger++ it "Associativity: f . (g . h) ≡ (f . g) . h" $ biMapEquality+ (_StringText . (_ReadString . _Word8Integer))+ ((_StringText . _ReadString) . _Word8Integer)+ genWord8+ genText++{- | Property that takes two 'BiMap's and checks them on equality. We+consider two 'BiMap's @m1@ and @m2@ equal if:++* @forward m1 ≡ forward m2@+* @backward m1 ≡ backward m2@+-}+biMapEquality+ :: (Eq a, Eq b, Show a, Show b)+ => TomlBiMap a b+ -> TomlBiMap a b+ -> Gen a+ -> Gen b+ -> PropertyT IO ()+biMapEquality m1 m2 genA genB = hedgehog $ do+ a <- forAll genA+ b <- forAll genB++ forward m1 a === forward m2 a+ backward m1 b === backward m2 b++_Word8Integer :: TomlBiMap Word8 Integer+_Word8Integer = _BoundedInteger
+ test/Test/Toml/Codec/BiMap/Conversion.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE PatternSynonyms #-}++module Test.Toml.Codec.BiMap.Conversion+ ( conversionSpec+ ) where++import Hedgehog (Gen, PropertyT, forAll, tripping)+import Test.Hspec (Spec, describe, it, parallel)+import Test.Hspec.Hedgehog (hedgehog)++import Test.Toml.Codec.Combinator.Common (Batman (..), _BatmanDouble)+import Toml.Codec.BiMap (BiMap (..), TomlBiMap, tShow)+import Toml.Type.Key (pattern (:||), Piece (..))++import qualified Hedgehog.Gen as Gen++import qualified Test.Toml.Gen as G+import qualified Toml.Codec.BiMap.Conversion as B+++conversionSpec :: Spec+conversionSpec = parallel $ describe "BiMap Rountrip Property tests" $ do+ describe "Primitive" $ do+ it "Bool" $ testBiMap B._Bool G.genBool+ it "Int" $ testBiMap B._Int G.genInt+ it "Word" $ testBiMap B._Word G.genWord+ it "Word8" $ testBiMap B._Word8 G.genWord8+ it "Integer" $ testBiMap B._Integer G.genInteger+ it "Natural" $ testBiMap B._Natural G.genNatural+ it "Double" $ testBiMap _BatmanDouble (Batman <$> G.genDouble)+ it "Float" $ testBiMap B._Float G.genFloat+ it "Text" $ testBiMap B._Text G.genText+ it "LazyText" $ testBiMap B._LText G.genLText+ it "ByteString" $ testBiMap B._ByteString G.genByteString+ it "Lazy ByteString" $ testBiMap B._LByteString G.genLByteString+ it "String" $ testBiMap B._String G.genString++ describe "Time" $ do+ it "ZonedTime" $ testBiMap B._ZonedTime G.genZonedTime+ it "LocalTime" $ testBiMap B._LocalTime G.genLocalTime+ it "Day" $ testBiMap B._Day G.genDay+ it "TimeOfDay" $ testBiMap B._TimeOfDay G.genTimeOfDay++ describe "Arrays" $ do+ it "Array (Int)" $ testBiMap (B._Array B._Int) (G.genList G.genInt)+ it "Array (Day)" $ testBiMap (B._Array B._Day) (G.genList G.genDay)+ it "NonEmpty (Int)" $ testBiMap (B._NonEmpty B._Int) (G.genNonEmpty G.genInt)+ it "Set (Int)" $ testBiMap (B._Set B._Int) (G.genSet G.genInt)+ it "HashSet (Int)" $ testBiMap (B._HashSet B._Int) (G.genHashSet G.genInt)+ it "IntSet" $ testBiMap B._IntSet G.genIntSet+ it "ByteStringArray" $ testBiMap B._ByteStringArray G.genByteString+ it "LByteStringArray" $ testBiMap B._LByteStringArray G.genLByteString++ describe "Custom" $ do+ it "EnumBounded (Ordering)" $ testBiMap B._EnumBounded $ Gen.enumBounded @_ @Ordering+ it "Read (Integer)" $ testBiMap B._Read G.genInteger+ it "TextBy (Text)" $ testBiMap (B._TextBy id Right) G.genText+ it "Hardcoded (Text)" $ do+ txt <- forAll G.genText+ testBiMap (B._Hardcoded txt) (pure txt)++ describe "Key" $ do+ it "KeyText" $ testBiMap B._KeyText G.genKey+ it "KeyString" $ testBiMap B._KeyString G.genKey+ it "KeyInt" $ testBiMap B._KeyInt ((:|| []) . Piece . tShow <$> G.genInt)++testBiMap+ :: (Show a, Show b, Eq a)+ => TomlBiMap a b+ -> Gen a+ -> PropertyT IO ()+testBiMap bimap gen = hedgehog $ do+ x <- forAll gen+ tripping x (forward bimap) (backward bimap =<<)
+ test/Test/Toml/Codec/Code.hs view
@@ -0,0 +1,137 @@+module Test.Toml.Codec.Code+ ( codeSpec+ ) where++import Test.Hspec (Spec, describe, it, shouldBe)++import Toml.Codec.BiMap (TomlBiMapError (..))+import Toml.Codec.Code (decode, decodeExact)+import Toml.Codec.Error (TomlDecodeError (..))+import Toml.Parser (TomlParseError (..))+import Toml.Type.AnyValue (AnyValue (..), MatchError (..))+import Toml.Type.Key (Key)+import Toml.Type.Value (TValue (..), Value (..))+import Toml.Type.Edsl (mkToml, table, tableArray, (=:))++import qualified Data.List.NonEmpty as NE+import qualified Data.Map.Strict as Map+import qualified Data.Text as Text+import qualified Toml.Codec as Toml+++codeSpec :: Spec+codeSpec = describe "Codec.Code decode tests on different TomlDecodeErrors" $ do+ it "fails parse as unclosed bracket" $+ decode (Toml.int "a") "a = 'foo" `shouldBe`+ Left [ ParseError $ TomlParseError $ Text.unlines+ [ "1:9:"+ , " |"+ , "1 | a = 'foo"+ , " | ^"+ , "unexpected end of input"+ , "expecting '''"+ ]+ ]+ it "fails decode text as Toml.int" $+ decode (Toml.int "a") "a = 'foo'" `shouldBe`+ Left [ matchErr "a" TInteger $ AnyValue $ Text "foo"]+ it "exact decode" $+ decodeExact (Toml.int "a") "a = 4" `shouldBe`+ Right 4+ it "fails to decode exact when there is other field" $+ decodeExact (Toml.int "a") "a = 4\nb = 'foo'" `shouldBe`+ Left [ NotExactDecode $ mkToml $ "b" =: "foo"]++ -- table+ it "fails to decode table on missing field" $+ decode (Toml.table (Toml.int "x") "foo") "" `shouldBe`+ Left [ TableNotFound "foo"]+ it "fails to decode table on missing field" $+ decode (Toml.table (Toml.int "x") "foo") "[foo]" `shouldBe`+ Left [ KeyNotFound "foo.x"]+ it "exact decode table" $+ decodeExact (Toml.table (Toml.int "x") "foo") "[foo]\nx = 5" `shouldBe`+ Right 5+ it "fails to decode exact table on missing field" $+ decodeExact (Toml.table (Toml.int "x") "foo") "[foo]\ny = 'abc'\nx = 5" `shouldBe`+ Left [ NotExactDecode $ mkToml $ table "foo" $ "y" =: "abc"]++ -- lists++ it "fails to decode arrayOf when field is missing" $+ decode (Toml.arrayOf Toml._Int "foo") "" `shouldBe`+ Left [KeyNotFound "foo"]+ it "fails to decode arrayNonEmptyOf when field is missing" $+ decode (Toml.arrayNonEmptyOf Toml._Int "foo") "" `shouldBe`+ Left [KeyNotFound "foo"]+ it "fails to decode arrayNonEmptyOf when list is empty" $+ decode (Toml.arrayNonEmptyOf Toml._Int "foo") "foo = []" `shouldBe`+ Left [BiMapError "foo" $ ArbitraryError "Empty array list, but expected NonEmpty"]++ it "decodes to an empty list when field is missing" $+ decode (Toml.list (Toml.int "i") "foo") "" `shouldBe`+ Right []+ it "decodes to an empty list when empty list" $+ decode (Toml.list (Toml.int "i") "foo") "foo = []" `shouldBe`+ Right []+ it "fails to decode list when internal field is missing" $+ decode (Toml.nonEmpty (Toml.int "i") "foo") "foo = [{a = 42}]" `shouldBe`+ Left [KeyNotFound "foo.i"]+ it "fails to decode nonEmpty when field is missing" $+ decode (Toml.nonEmpty (Toml.int "i") "foo") "" `shouldBe`+ Left [TableArrayNotFound "foo"]+ it "fails to decode nonEmpty when empty list" $+ decode (Toml.nonEmpty (Toml.int "i") "foo") "foo = []" `shouldBe`+ Left [TableArrayNotFound "foo"]++ -- table arrays+ it "exact decode table array" $+ decodeExact (Toml.list (Toml.int "x") "foo") "[[foo]]\nx = 1" `shouldBe`+ Right [1]++ it "fails to exact decode table array with redundant field" $+ decodeExact (Toml.list (Toml.int "x") "foo") "[[foo]]\nx = 1\ny = 'abc'" `shouldBe`+ Left [NotExactDecode $ mkToml $ tableArray "foo" $ ("y" =: "abc") NE.:| []]++ -- map+ it "map: decodes to an empty map when field is missing" $+ decode (Toml.map (Toml.int "key") (Toml.text "val") "foo") "" `shouldBe`+ Right Map.empty+ it "map: fails to decode when key and value mismatch type" $+ decode+ (Toml.map (Toml.int "key") (Toml.text "val") "foo")+ "foo = [{key = 'a', val = 42}]"+ `shouldBe` Left+ [ matchErr "key" TInteger $ AnyValue $ Text "a"+ , matchErr "val" TText $ AnyValue $ Integer 42+ ]+ it "map: fails to decode when value is missing" $+ decode+ (Toml.map (Toml.int "key") (Toml.text "val") "foo")+ "foo = [{key = 42}]"+ `shouldBe` Left [ KeyNotFound "val"]++ it "tableMap: decodes to an empty map when field is missing" $+ decode (Toml.tableMap Toml._KeyText Toml.int "foo") "" `shouldBe`+ Right Map.empty+ it "tableMap: throws error on invalid key type" $+ decode (Toml.tableMap Toml._KeyInt Toml.text "foo")+ "foo = {a = 'a'}"+ `shouldBe` Left [BiMapError "a" $ ArbitraryError "Prelude.read: no parse"]++ -- custom+ it "fails to decode via read when non-existing value" $+ decode (Toml.read @Ordering "foo") "foo = 'EQUAL'" `shouldBe`+ Left [BiMapError "foo" $ ArbitraryError "Prelude.read: no parse"]+ it "fails to decode via enumBounded when non-existing value" $+ decode (Toml.enumBounded @Ordering "foo") "foo = 'EQUAL'" `shouldBe`+ Left [BiMapError "foo" $ ArbitraryError "Value is 'EQUAL' but expected one of: LT, EQ, GT"]+ it "fails to validateIf" $+ decode (Toml.validateIf even Toml._Int "foo") "foo = 5" `shouldBe`+ Left [BiMapError "foo" $ ArbitraryError "Value does not pass the validation for key: foo"]+ it "fails to hardcoded" $+ decode (Toml.hardcoded "bar" Toml._Text "foo") "foo = \"baz\"" `shouldBe`+ Left [BiMapError "foo" $ ArbitraryError "Value '\"baz\"' doesn't align with the hardcoded value '\"bar\"'"]+ where+ matchErr :: Key -> TValue -> AnyValue -> TomlDecodeError+ matchErr key valueExpected valueActual = BiMapError key $ WrongValue $ MatchError {..}
+ test/Test/Toml/Codec/Combinator.hs view
@@ -0,0 +1,28 @@+module Test.Toml.Codec.Combinator+ ( combinatorSpec+ ) where++import Test.Hspec (Spec, describe, parallel)++import Test.Toml.Codec.Combinator.Custom (customSpec)+import Test.Toml.Codec.Combinator.List (listSpec)+import Test.Toml.Codec.Combinator.Map (mapSpec)+import Test.Toml.Codec.Combinator.Monoid (monoidSpec)+import Test.Toml.Codec.Combinator.Primitive (primitiveSpec)+import Test.Toml.Codec.Combinator.Set (setSpec)+import Test.Toml.Codec.Combinator.Table (tableSpec)+import Test.Toml.Codec.Combinator.Time (timeSpec)+import Test.Toml.Codec.Combinator.Tuple (tupleSpec)+++combinatorSpec :: Spec+combinatorSpec = parallel $ describe "Combinator spec" $ do+ customSpec+ listSpec+ mapSpec+ monoidSpec+ primitiveSpec+ setSpec+ tableSpec+ timeSpec+ tupleSpec
+ test/Test/Toml/Codec/Combinator/Common.hs view
@@ -0,0 +1,83 @@+module Test.Toml.Codec.Combinator.Common+ ( codecRoundtrip+ , exactCodecRoundtrip++ -- * Double helpers+ , Batman (..)+ , _BatmanDouble+ , batmanDoubleCodec+ , batmanFloatCodec+ ) where++import Data.Text (Text)+import Hedgehog (Gen, forAll, tripping)+import Test.Hspec (Arg, Expectation, SpecWith, it)+import Test.Hspec.Hedgehog (hedgehog)++import Toml.Codec.BiMap (TomlBiMap)+import Toml.Codec.Code (decode, decodeExact, encode)+import Toml.Codec.Error (TomlDecodeError)+import Toml.Codec.Types (TomlCodec)+import Toml.Type.AnyValue (AnyValue)+import Toml.Type.Key (Key)+++import qualified Toml.Codec as Toml+++codecRoundtripWith+ :: forall a+ . (Eq a, Show a)+ => (TomlCodec a -> Text -> Either [TomlDecodeError] a)+ -> String+ -> (Key -> TomlCodec a)+ -> Gen a+ -> SpecWith (Arg Expectation)+codecRoundtripWith dcode typeName mkCodec genA = it label $ hedgehog $ do+ a <- forAll genA+ let codec = mkCodec "a"+ tripping a (encode codec) (dcode codec)+ where+ label :: String+ label = typeName ++ ": decode . encode ≡ id"++codecRoundtrip+ :: forall a+ . (Eq a, Show a)+ => String+ -> (Key -> TomlCodec a)+ -> Gen a+ -> SpecWith (Arg Expectation)+codecRoundtrip = codecRoundtripWith decode++exactCodecRoundtrip+ :: forall a+ . (Eq a, Show a)+ => String+ -> (Key -> TomlCodec a)+ -> Gen a+ -> SpecWith (Arg Expectation)+exactCodecRoundtrip str = codecRoundtripWith decodeExact ("Exact " <> str)++-- | Wrapper over 'Double' and 'Float' to be equal on @NaN@ values.+newtype Batman a = Batman+ { unBatman :: a+ } deriving stock (Show)++instance Toml.HasCodec a => Toml.HasCodec (Batman a) where+ hasCodec = Toml.diwrap . Toml.hasCodec @a++instance RealFloat a => Eq (Batman a) where+ Batman a == Batman b =+ if isNaN a+ then isNaN b+ else a == b++_BatmanDouble :: TomlBiMap (Batman Double) AnyValue+_BatmanDouble = Toml._Coerce Toml._Double++batmanDoubleCodec :: Key -> TomlCodec (Batman Double)+batmanDoubleCodec = Toml.match _BatmanDouble++batmanFloatCodec :: Key -> TomlCodec (Batman Float)+batmanFloatCodec = Toml.diwrap . Toml.float
+ test/Test/Toml/Codec/Combinator/Custom.hs view
@@ -0,0 +1,28 @@+module Test.Toml.Codec.Combinator.Custom+ ( customSpec+ ) where++import Data.Bifunctor (first)+import Test.Hspec (Spec, describe)+import Text.Read (readEither)++import Test.Toml.Codec.Combinator.Common (codecRoundtrip)++import qualified Data.Text as Text+import qualified Hedgehog.Gen as Gen+import qualified Test.Toml.Gen as Gen+import qualified Toml.Codec.BiMap.Conversion as Toml+import qualified Toml.Codec.Combinator.Custom as Toml+++customSpec :: Spec+customSpec = describe "Combinator.Custom: Roundtrip tests" $ do+ codecRoundtrip "Read (Int) " (Toml.read @Int) Gen.genInt+ codecRoundtrip "Enum (Ordering) " (Toml.enumBounded @Ordering) Gen.enumBounded+ codecRoundtrip "Validate (Even) "+ (Toml.validateIf even Toml._Int)+ ((* 2) <$> Gen.genInt)+ codecRoundtrip "TextBy "+ (Toml.textBy (Text.pack . show) (first Text.pack . readEither . Text.unpack))+ Gen.genInt+ codecRoundtrip "Hardcoded (Text)" (Toml.hardcoded "abc" Toml._Text) (pure "abc")
+ test/Test/Toml/Codec/Combinator/List.hs view
@@ -0,0 +1,28 @@+module Test.Toml.Codec.Combinator.List+ ( listSpec+ ) where++import Test.Hspec (Spec, describe, parallel)++import Test.Toml.Codec.Combinator.Common (codecRoundtrip)++import qualified Test.Toml.Gen as Gen+import qualified Toml.Codec.BiMap.Conversion as Toml+import qualified Toml.Codec.Combinator.List as Toml+import qualified Toml.Codec.Combinator.Primitive as Toml+++listSpec :: Spec+listSpec = parallel $ describe "Combinator.List: Roundtrip tests" $ do+ codecRoundtrip "[Int] (Array) "+ (Toml.arrayOf Toml._Int)+ (Gen.genList Gen.genInt)+ codecRoundtrip "NonEmpty Int (Array)"+ (Toml.arrayNonEmptyOf Toml._Int)+ (Gen.genNonEmpty Gen.genInt)+ codecRoundtrip "[Int] (Table) "+ (Toml.list $ Toml.int "a")+ (Gen.genList Gen.genInt)+ codecRoundtrip "NonEmpty Int (Table)"+ (Toml.nonEmpty $ Toml.int "a")+ (Gen.genNonEmpty Gen.genInt)
+ test/Test/Toml/Codec/Combinator/Map.hs view
@@ -0,0 +1,29 @@+module Test.Toml.Codec.Combinator.Map+ ( mapSpec+ ) where++import Data.Foldable (toList)+import Test.Hspec (Spec, describe, parallel)++import Test.Toml.Codec.Combinator.Common (codecRoundtrip)+import Toml.Type.Printer (prettyKey)++import qualified Test.Toml.Gen as Gen+import qualified Toml.Codec.BiMap.Conversion as Toml+import qualified Toml.Codec.Combinator.List as Toml+import qualified Toml.Codec.Combinator.Map as Toml+import qualified Toml.Codec.Combinator.Primitive as Toml+++mapSpec :: Spec+mapSpec = parallel $ describe "Combinator.Map: Roundtrip tests" $ do+ codecRoundtrip "Map Int Text (map) "+ (Toml.map (Toml.int "key") (Toml.text "val"))+ (Gen.genMap Gen.genInt Gen.genText)+ codecRoundtrip "Map Text Int (tableMap)"+ (Toml.tableMap Toml._KeyText Toml.int)+ (Gen.genMap (prettyKey <$> Gen.genKey) Gen.genInt)+ -- TODO: handle empty lists in values.+ codecRoundtrip "Map Text [Int] (tableMap)"+ (Toml.tableMap Toml._KeyText (Toml.list $ Toml.int "val"))+ (Gen.genMap (prettyKey <$> Gen.genKey) (toList <$> Gen.genNonEmpty Gen.genInt))
+ test/Test/Toml/Codec/Combinator/Monoid.hs view
@@ -0,0 +1,24 @@+module Test.Toml.Codec.Combinator.Monoid+ ( monoidSpec+ ) where++import Data.Monoid (All (..), Any (..), First (..), Last (..), Product (..), Sum (..))+import Test.Hspec (Spec, describe)++import Test.Toml.Codec.Combinator.Common (codecRoundtrip)++import qualified Hedgehog.Gen as Gen++import qualified Test.Toml.Gen as Gen+import qualified Toml.Codec.Combinator.Monoid as Toml+import qualified Toml.Codec.Combinator.Primitive as Toml+++monoidSpec :: Spec+monoidSpec = describe "Combinator.Monoid: Roundtrip tests" $ do+ codecRoundtrip "All " Toml.all (All <$> Gen.genBool)+ codecRoundtrip "Any " Toml.any (Any <$> Gen.genBool)+ codecRoundtrip "Sum Int" (Toml.sum Toml.int) (Sum <$> Gen.genInt)+ codecRoundtrip "Product Int" (Toml.product Toml.int) (Product <$> Gen.genInt)+ codecRoundtrip "First Int" (Toml.first Toml.int) (First <$> Gen.maybe Gen.genInt)+ codecRoundtrip "Last Int" (Toml.last Toml.int) (Last <$> Gen.maybe Gen.genInt)
+ test/Test/Toml/Codec/Combinator/Primitive.hs view
@@ -0,0 +1,30 @@+module Test.Toml.Codec.Combinator.Primitive+ ( primitiveSpec+ ) where++import Test.Hspec (Spec, describe, parallel)++import Test.Toml.Codec.Combinator.Common (Batman (..), batmanDoubleCodec, batmanFloatCodec,+ codecRoundtrip)++import qualified Test.Toml.Gen as Gen+import qualified Toml.Codec.Combinator.Primitive as Toml+++primitiveSpec :: Spec+primitiveSpec = parallel $ describe "Combinator.Primitive: Roundtrip tests" $ do+ codecRoundtrip "Bool " Toml.bool Gen.genBool+ codecRoundtrip "Integer " Toml.integer Gen.genInteger+ codecRoundtrip "Int " Toml.int Gen.genInt+ codecRoundtrip "Natural " Toml.natural Gen.genNatural+ codecRoundtrip "Word " Toml.word Gen.genWord+ codecRoundtrip "Word8 " Toml.word8 Gen.genWord8+ codecRoundtrip "Double " batmanDoubleCodec (Batman <$> Gen.genDouble)+ codecRoundtrip "Float " batmanFloatCodec (Batman <$> Gen.genFloat)+ codecRoundtrip "String " Toml.string Gen.genString+ codecRoundtrip "Text " Toml.text Gen.genText+ codecRoundtrip "LText " Toml.lazyText Gen.genLText+ codecRoundtrip "ByteString " Toml.byteString Gen.genByteString+ codecRoundtrip "LByteString " Toml.lazyByteString Gen.genLByteString+ codecRoundtrip "ByteString Array " Toml.byteStringArray Gen.genByteString+ codecRoundtrip "LByteString Array" Toml.lazyByteStringArray Gen.genLByteString
+ test/Test/Toml/Codec/Combinator/Set.hs view
@@ -0,0 +1,30 @@+module Test.Toml.Codec.Combinator.Set+ ( setSpec+ ) where++import Test.Hspec (Spec, describe, parallel)++import Test.Toml.Codec.Combinator.Common (codecRoundtrip)++import qualified Data.HashSet as HashSet+import qualified Data.Set as Set+import qualified Test.Toml.Gen as Gen+import qualified Toml.Codec.BiMap.Conversion as Toml+import qualified Toml.Codec.Combinator.Primitive as Toml+import qualified Toml.Codec.Combinator.Set as Toml+++setSpec :: Spec+setSpec = parallel $ describe "Combinator.Set: Roundtrip tests" $ do+ codecRoundtrip "IntSet (Array) " Toml.arrayIntSet Gen.genIntSet+ codecRoundtrip "IntSet (Table) " (Toml.intSet $ Toml.int "a") Gen.genIntSet+ codecRoundtrip "Set Int (Array) " (Toml.arraySetOf Toml._Int) (Gen.genSet Gen.genInt)+ codecRoundtrip "Set Int (Table) "+ (Toml.set $ Toml.int "a")+ (Set.fromList <$> Gen.genSmallList Gen.genInt)+ codecRoundtrip "HashSet Text (Array)"+ (Toml.arrayHashSetOf Toml._Text)+ (HashSet.fromList <$> Gen.genSmallList Gen.genText)+ codecRoundtrip "HashSet Text (Table)"+ (Toml.hashSet $ Toml.text "a")+ (HashSet.fromList <$> Gen.genSmallList Gen.genText)
+ test/Test/Toml/Codec/Combinator/Table.hs view
@@ -0,0 +1,16 @@+module Test.Toml.Codec.Combinator.Table+ ( tableSpec+ ) where++import Test.Hspec (Spec, describe)++import Test.Toml.Codec.Combinator.Common (codecRoundtrip)++import qualified Test.Toml.Gen as Gen+import qualified Toml.Codec.Combinator.Primitive as Toml+import qualified Toml.Codec.Combinator.Table as Toml+++tableSpec :: Spec+tableSpec = describe "Combinator.Table: Roundtrip tests" $+ codecRoundtrip "Table (Int)" (Toml.table $ Toml.int "a") Gen.genInt
+ test/Test/Toml/Codec/Combinator/Time.hs view
@@ -0,0 +1,18 @@+module Test.Toml.Codec.Combinator.Time+ ( timeSpec+ ) where++import Test.Hspec (Spec, describe)++import Test.Toml.Codec.Combinator.Common (codecRoundtrip)++import qualified Test.Toml.Gen as Gen+import qualified Toml.Codec.Combinator.Time as Toml+++timeSpec :: Spec+timeSpec = describe "Combinator.Time: Roundtrip tests" $ do+ codecRoundtrip "ZonedTime " Toml.zonedTime Gen.genZonedTime+ codecRoundtrip "LocalTime " Toml.localTime Gen.genLocalTime+ codecRoundtrip "Day " Toml.day Gen.genDay+ codecRoundtrip "TimeOfDay " Toml.timeOfDay Gen.genTimeOfDay
+ test/Test/Toml/Codec/Combinator/Tuple.hs view
@@ -0,0 +1,24 @@+module Test.Toml.Codec.Combinator.Tuple+ ( tupleSpec+ ) where++import Control.Applicative (liftA2, liftA3)+import Test.Hspec (Spec, describe, parallel)++import Test.Toml.Codec.Combinator.Common (codecRoundtrip)++import qualified Test.Toml.Gen as Gen+import qualified Toml.Codec.Combinator.Primitive as Toml+import qualified Toml.Codec.Combinator.Tuple as Toml+++tupleSpec :: Spec+tupleSpec = parallel $ describe "Combinator.Tuple: Roundtrip tests" $ do+ codecRoundtrip+ "(Int, Text) "+ (const $ Toml.pair (Toml.int "a") (Toml.text "b"))+ (liftA2 (,) Gen.genInt Gen.genText)+ codecRoundtrip+ "(Int, Text, Bool)"+ (const $ Toml.triple (Toml.int "a") (Toml.text "b") (Toml.bool "c"))+ (liftA3 (,,) Gen.genInt Gen.genText Gen.genBool)
+ test/Test/Toml/Codec/Di.hs view
@@ -0,0 +1,57 @@+module Test.Toml.Codec.Di+ ( diSpec+ ) where++import Control.Applicative ((<|>))+import Data.Text (Text)+import Hedgehog (Gen)+import Test.Hspec (Spec, describe)++import Test.Toml.Codec.Combinator.Common (codecRoundtrip)+import Toml.Codec.Di (dimatch)+import Toml.Codec.Types (TomlCodec)+import Toml.Type.Key (Key)++import qualified Hedgehog.Gen as Gen+import qualified Test.Toml.Gen as Gen+import qualified Toml.Codec as Toml+++diSpec :: Spec+diSpec = describe "Codec.Di functions tests" $+ describe "dimatch" $+ codecRoundtrip "SumType" sumTypeExampleCodec genSumTypeExample++data SumType+ = One Bool+ | Two Int Text+ | Three [Int]+ deriving stock (Eq, Show)++matchOne :: SumType -> Maybe Bool+matchOne = \case+ One b -> Just b+ _ -> Nothing++matchTwo :: SumType -> Maybe (Int, Text)+matchTwo = \case+ Two i t -> Just (i, t)+ _ -> Nothing++matchThree :: SumType -> Maybe [Int]+matchThree = \case+ Three l -> Just l+ _ -> Nothing++sumTypeExampleCodec :: Key -> TomlCodec SumType+sumTypeExampleCodec _ =+ dimatch matchOne One (Toml.bool "one")+ <|> dimatch matchTwo (uncurry Two) (Toml.pair (Toml.int "two.a") (Toml.text "two.b"))+ <|> dimatch matchThree Three (Toml.arrayOf Toml._Int "three")++genSumTypeExample :: Gen SumType+genSumTypeExample = Gen.choice+ [ One <$> Gen.genBool+ , Two <$> Gen.genInt <*> Gen.genText+ , Three <$> Gen.genSmallList Gen.genInt+ ]
+ test/Test/Toml/Codec/Generic.hs view
@@ -0,0 +1,33 @@+module Test.Toml.Codec.Generic+ ( genericSpec+ ) where++import Hedgehog (forAll, tripping, (===))+import Test.Hspec (Arg, Expectation, Spec, SpecWith, describe, it, parallel)+import Test.Hspec.Hedgehog (hedgehog)++import Test.Toml.Codec.SmallType (SmallType, genSmallType, smallTypeCodec)+import Toml.Codec.Code (decode, encode)+import Toml.Codec.Generic (genericCodec)+import Toml.Codec.Types (TomlCodec)+++genericSpec :: Spec+genericSpec = parallel $ describe "Generic codecs tests" $ do+ genericRoundtripSpec+ genericDecodeSpec++genericRoundtripSpec :: SpecWith (Arg Expectation)+genericRoundtripSpec = it "genericDecode . genericEncode ≡ id" $ hedgehog $ do+ smallType <- forAll genSmallType+ tripping smallType (encode smallTypeGenericCodec) (decode smallTypeGenericCodec)++genericDecodeSpec :: SpecWith (Arg Expectation)+genericDecodeSpec = it "genericDecode . genericEncode ≡ decode . encode" $ hedgehog $ do+ smallType <- forAll genSmallType+ let genericDecode = decode smallTypeGenericCodec . encode smallTypeGenericCodec+ let manualDecode = decode smallTypeCodec . encode smallTypeCodec+ genericDecode smallType === manualDecode smallType++smallTypeGenericCodec :: TomlCodec SmallType+smallTypeGenericCodec = genericCodec
+ test/Test/Toml/Codec/SmallType.hs view
@@ -0,0 +1,59 @@+module Test.Toml.Codec.SmallType+ ( smallTypeSpec++ -- * Internals+ , SmallType+ , smallTypeCodec+ , genSmallType+ ) where++import Data.Monoid (Any (..))+import Data.Text (Text)+import Data.Time (Day)+import GHC.Generics (Generic)+import Hedgehog (Gen)+import Test.Hspec (Spec, describe)++import Test.Toml.Codec.Combinator.Common (codecRoundtrip, exactCodecRoundtrip)+import Toml.Codec (ByteStringAsBytes (..), TomlCodec, (.=))++import qualified Hedgehog.Gen as Gen+import qualified Test.Toml.Gen as Gen+import qualified Toml.Codec as Toml+++smallTypeSpec :: Spec+smallTypeSpec = describe "SmallType: tests for custom data type" $ do+ codecRoundtrip "SmallType" (Toml.table smallTypeCodec) genSmallType+ exactCodecRoundtrip "SmallType" (Toml.table smallTypeCodec) genSmallType++data SmallType = SmallType+ { smallTypeInt :: !Int+ , smallTypeText :: !Text+ , smallTypeAny :: !Any+ , smallTypeDay :: !Day+ , smallTypeMaybeWord :: !(Maybe Word)+ , smallTypeListInt :: ![Int]+ , smallTypeBS :: !ByteStringAsBytes+ } deriving stock (Eq, Show, Generic)++smallTypeCodec :: TomlCodec SmallType+smallTypeCodec = SmallType+ <$> Toml.int "int" .= smallTypeInt+ <*> Toml.text "text" .= smallTypeText+ <*> Toml.any "any" .= smallTypeAny+ <*> Toml.day "day" .= smallTypeDay+ <*> Toml.dioptional (Toml.word "maybe.word") .= smallTypeMaybeWord+ <*> Toml.arrayOf Toml._Int "list.int" .= smallTypeListInt+ <*> Toml.diwrap (Toml.byteStringArray "bs") .= smallTypeBS++genSmallType :: Gen SmallType+genSmallType = do+ smallTypeInt <- Gen.genInt+ smallTypeText <- Gen.genText+ smallTypeAny <- Any <$> Gen.genBool+ smallTypeDay <- Gen.genDay+ smallTypeMaybeWord <- Gen.maybe Gen.genWord+ smallTypeListInt <- Gen.genSmallList Gen.genInt+ smallTypeBS <- ByteStringAsBytes <$> Gen.genByteString+ pure SmallType{..}
test/Test/Toml/Gen.hs view
@@ -1,4 +1,8 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}@@ -7,25 +11,25 @@ -- | This module contains all generators for @tomland@ testing. module Test.Toml.Gen- ( -- * Property- PropertyTest- , prop-- -- * Generators+ ( -- * Generators -- ** Primitive+ genBool , genInt , genInteger , genDouble , genWord+ , genWord8 , genNatural , genFloat , genList+ , genSmallList , genNonEmpty+ , genSet , genHashSet , genIntSet - , genBool+ , genMap , genText , genString@@ -35,9 +39,9 @@ -- ** Dates , genDay- , genHours- , genLocal- , genZoned+ , genTimeOfDay+ , genLocalTime+ , genZonedTime -- ** @TOML@ specific , genVal@@ -53,43 +57,39 @@ import Control.Monad (forM, replicateM) import Data.ByteString (ByteString) import Data.Fixed (Fixed (..))-import Data.Functor.Identity (Identity) import Data.Hashable (Hashable)+import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) import Data.IntSet (IntSet) import Data.List.NonEmpty (NonEmpty)+import Data.Map.Strict (Map)+import Data.Set (Set) import Data.Text (Text) import Data.Time (Day, LocalTime (..), TimeOfDay (..), ZonedTime (..), fromGregorian, minutesToTimeZone)+import Data.Word (Word8) import GHC.Exts (fromList)-import GHC.Stack (HasCallStack)-import Hedgehog (Gen, GenBase, MonadGen, PropertyT, Range, property)+import Hedgehog (Gen, Range) import Numeric.Natural (Natural)-import Test.Tasty (TestName, TestTree)-import Test.Tasty.Hedgehog (testProperty) -import Toml.Bi.Map (toMArray)-import Toml.PrefixTree (pattern (:||), Key (..), Piece (..), PrefixMap, PrefixTree (..))-import Toml.Type (AnyValue (..), TOML (..), TValue (..), Value (..))+import Toml.Type.AnyValue (AnyValue (..), toMArray)+import Toml.Type.Key (pattern (:||), Key (..), Piece (..))+import Toml.Type.PrefixTree (PrefixMap, PrefixTree (..))+import Toml.Type.TOML (TOML (..))+import Toml.Type.Value (TValue (..), Value (..)) import qualified Data.ByteString.Lazy as LB import qualified Data.Char as Char import qualified Data.List.NonEmpty as NE+import qualified Data.Map.Strict as Map import qualified Data.Text as Text import qualified Data.Text.Lazy as L import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range-import qualified Toml.PrefixTree as Toml (fromList) -------------------------------------------------------------------------------- Property test creator-----------------------------------------------------------------------------+import qualified Toml.Type.PrefixTree as Toml (fromList) -type PropertyTest = [TestTree] -prop :: HasCallStack => TestName -> PropertyT IO () -> [TestTree]-prop testName = pure . testProperty testName . property- ---------------------------------------------------------------------------- -- Common generators ----------------------------------------------------------------------------@@ -98,51 +98,57 @@ type V = Int -genVal :: MonadGen m => m V+genVal :: Gen V genVal = Gen.int (Range.constant 0 256) -- | Generates random value of 'AnyValue' type.-genAnyValue :: MonadGen m => m AnyValue+genAnyValue :: Gen AnyValue genAnyValue = Gen.choice $ (AnyValue <$> genArray) : noneArrayList -- | Generate either a bare piece, or a quoted piece-genPiece :: forall m . (MonadGen m, GenBase m ~ Identity) => m Piece+genPiece :: Gen Piece genPiece = Piece <$> Gen.choice [bare, quoted] where- alphadashes :: m Char- alphadashes = Gen.choice [Gen.alphaNum, Gen.element "_-"]+ bare :: Gen Text+ bare = liftA2 Text.cons Gen.alpha $ Gen.text (Range.constant 1 10) alphadashes - notControl :: m Char- notControl = Gen.filter (not . Char.isControl) Gen.unicode+ alphadashes :: Gen Char+ alphadashes = Gen.choice [Gen.alphaNum, Gen.element ("_-" :: [Char])] - bare :: m Text- bare = Gen.text (Range.constant 1 10) alphadashes+ quoted :: Gen Text+ quoted = genNotEscape $ Gen.choice+ [ quotedWith '"' (\x -> x /= '\\' && notControl x)+ , quotedWith '\'' notControl+ ] + quotedWith :: Char -> (Char -> Bool) -> Gen Text+ quotedWith c isAllowed = wrapChar c <$> Gen.text (Range.constant 1 10) allowedChar+ where+ allowedChar :: Gen Char+ allowedChar = Gen.filter (\x -> x /= c && isAllowed x) Gen.unicode+ wrapChar :: Char -> Text -> Text wrapChar c = Text.cons c . (`Text.append` Text.singleton c) - quotedWith :: Char -> m Text- quotedWith c = wrapChar c <$> Gen.text (Range.constant 1 10) (Gen.filter (/= c) notControl)-- quoted :: m Text- quoted = Gen.choice [quotedWith '"', quotedWith '\'']+ notControl :: Char -> Bool+ notControl = not . Char.isControl -genKey :: (MonadGen m, GenBase m ~ Identity) => m Key+genKey :: Gen Key genKey = Key <$> Gen.nonEmpty (Range.constant 1 10) genPiece -genKeyAnyValue :: (MonadGen m, GenBase m ~ Identity) => m (Key, AnyValue)+genKeyAnyValue :: Gen (Key, AnyValue) genKeyAnyValue = liftA2 (,) genKey genAnyValue -genKeyAnyValueList :: (MonadGen m, GenBase m ~ Identity) => m [(Key, AnyValue)]+genKeyAnyValueList :: Gen [(Key, AnyValue)] genKeyAnyValueList = Gen.list (Range.linear 0 10) genKeyAnyValue -- Generates key-value pair for PrefixMap-genEntry :: (MonadGen m, GenBase m ~ Identity) => m (Piece, Key)+genEntry :: Gen (Piece, Key) genEntry = genKey >>= \case key@(piece :|| _) -> pure (piece, key) -genPrefixMap :: (MonadGen m, GenBase m ~ Identity) => m (PrefixMap V)+genPrefixMap :: Gen (PrefixMap V) genPrefixMap = do entries <- Gen.list (Range.linear 0 10) genEntry kvps <- forM entries $ \(piece, key) -> do@@ -151,7 +157,7 @@ pure $ fromList kvps -genPrefixTree :: forall m . (MonadGen m, GenBase m ~ Identity) => Key -> m (PrefixTree V)+genPrefixTree :: Key -> Gen (PrefixTree V) genPrefixTree key = Gen.recursive -- list picker generator combinator Gen.choice@@ -160,7 +166,7 @@ -- recursive generators [ genPrefixMap >>= genBranch ] where- genBranch :: PrefixMap V -> m (PrefixTree V)+ genBranch :: PrefixMap V -> Gen (PrefixTree V) genBranch prefMap = do prefVal <- Gen.maybe genVal pure $ Branch key prefVal prefMap@@ -168,46 +174,50 @@ makeToml :: [(Key, AnyValue)] -> TOML makeToml kv = TOML (fromList kv) mempty mempty -genToml :: (MonadGen m, GenBase m ~ Identity) => m TOML+genToml :: Gen TOML genToml = Gen.recursive- Gen.choice- [ makeToml <$> genKeyAnyValueList ]- [ TOML <$> keyValues <*> tables <*> arrays ]+ Gen.choice+ [ makeToml <$> genKeyAnyValueList ]+ [ TOML <$> keyValues <*> tables <*> arrays ] where+ keyValues :: Gen (HashMap Key AnyValue) keyValues = fromList <$> genKeyAnyValueList++ tables :: Gen (PrefixMap TOML) tables = fmap Toml.fromList- $ Gen.list (Range.linear 0 5)- $ (,) <$> genKey <*> genToml- arrays = fmap fromList $- Gen.list (Range.linear 0 10) $ do- key <- genKey- arr <- Gen.list (Range.linear 1 10) genToml- return (key, NE.fromList arr)+ $ Gen.list (Range.linear 0 5)+ $ (,) <$> genKey <*> genToml + arrays :: Gen (HashMap Key (NonEmpty TOML))+ arrays = fmap fromList $ Gen.list (Range.linear 0 10) $ do+ key <- genKey+ arr <- Gen.list (Range.linear 1 10) genToml+ pure (key, NE.fromList arr)+ -- Date generators -genDay :: MonadGen m => m Day+genDay :: Gen Day genDay = do y <- toInteger <$> Gen.int (Range.constant 1968 2019) m <- Gen.int (Range.constant 1 12) d <- Gen.int (Range.constant 1 28) pure $ fromGregorian y m d -genHours :: MonadGen m => m TimeOfDay-genHours = do+genTimeOfDay :: Gen TimeOfDay+genTimeOfDay = do secs <- MkFixed <$> Gen.integral (Range.constant 0 61) mins <- Gen.int (Range.constant 0 59) hours <- Gen.int (Range.constant 0 23) pure $ TimeOfDay hours mins secs -genLocal :: MonadGen m => m LocalTime-genLocal = do+genLocalTime :: Gen LocalTime+genLocalTime = do day <- genDay- LocalTime day <$> genHours+ LocalTime day <$> genTimeOfDay -genZoned :: MonadGen m => m ZonedTime-genZoned = do- local <- genLocal+genZonedTime :: Gen ZonedTime+genZonedTime = do+ local <- genLocalTime zMin <- Gen.int (Range.constant (-720) 720) let zTime = minutesToTimeZone zMin pure $ ZonedTime local zTime@@ -217,13 +227,16 @@ range100 :: Range Int range100 = Range.constant 0 100 -genInt :: MonadGen m => m Int+genBool :: Gen Bool+genBool = Gen.bool++genInt :: Gen Int genInt = Gen.int Range.constantBounded -genInteger :: MonadGen m => m Integer+genInteger :: Gen Integer genInteger = toInteger <$> genInt -genDouble :: MonadGen m => m Double+genDouble :: Gen Double genDouble = Gen.frequency [ (10, Gen.double $ Range.constant @Double (-1000000.0) 1000000.0) , (1, Gen.constant $ 1/0)@@ -231,16 +244,29 @@ , (1, Gen.constant $ 0/0) ] -genWord :: MonadGen m => m Word+genWord :: Gen Word genWord = Gen.word Range.constantBounded -genNatural :: MonadGen m => m Natural+genWord8 :: Gen Word8+genWord8 = Gen.word8 Range.constantBounded++genNatural :: Gen Natural genNatural = fromIntegral <$> genWord -genFloat :: MonadGen m => m Float+genFloat :: Gen Float genFloat = Gen.float (Range.constant (-10000.0) 10000.0) -genHashSet :: (Eq a, Hashable a) => Gen a -> Gen (HashSet a)+genSet :: Ord a => Gen a -> Gen (Set a)+genSet genA = fromList <$> genList genA++genHashSet +#if MIN_VERSION_hashable(1,4,0)+ :: (Hashable a)+#else+ :: (Eq a, Hashable a) +#endif+ => Gen a + -> Gen (HashSet a) genHashSet genA = fromList <$> genList genA genNonEmpty :: Gen a -> Gen (NonEmpty a)@@ -249,19 +275,22 @@ genList :: Gen a -> Gen [a] genList = Gen.list range100 +genSmallList :: Gen a -> Gen [a]+genSmallList = Gen.list $ Range.constant 0 10+ genIntSet :: Gen IntSet genIntSet = fromList <$> genList genInt -genBool :: MonadGen m => m Bool-genBool = Gen.bool+genMap :: Ord k => Gen k -> Gen v -> Gen (Map k v)+genMap genK genV = Map.fromList <$> genSmallList (liftA2 (,) genK genV) -- | Generatates control sympol.-genEscapeSequence :: MonadGen m => m Text+genEscapeSequence :: Gen Text genEscapeSequence = Gen.element [ "\n", "\b", "\f", "\r", "\t", "\\", "\"" ] -- | Generatates punctuation.-genPunctuation :: MonadGen m => m Text+genPunctuation :: Gen Text genPunctuation = Gen.element [ ",", ".", ":", ";", "'", "?", "!", "`" , "-", "_", "*", "$", "#", "@", "(", ")"@@ -269,31 +298,40 @@ ] -- | Generatates n length list of hex chars.-genDiffHex :: MonadGen m => Int -> m String+genDiffHex :: Int -> Gen String genDiffHex n = replicateM n Gen.hexit -- | Generates unicode color string (u1234)-genUniHex4Color :: MonadGen m => m Text+genUniHex4Color :: Gen Text genUniHex4Color = do hex <- genDiffHex 4 pure . Text.pack $ "\\u" ++ hex -- | Generates unicode color string (u12345678)-genUniHex8Color :: MonadGen m => m Text+genUniHex8Color :: Gen Text genUniHex8Color = do hex <- genDiffHex 8 pure . Text.pack $ "\\U" ++ hex +-- | Generates some unescaped unicode string+genUnicodeChar :: Gen Text+genUnicodeChar = Gen.element+ [ "č", "ć", "š", "đ", "ž", "Ö", "ё"+ , "в", "ь", "ж", "ю", "ч", "ü", "я"+ ]+ -- | Generates text from different symbols.-genText :: MonadGen m => m Text-genText = fmap Text.concat $ Gen.list (Range.constant 0 256) $ Gen.choice+genText :: Gen Text+genText = genNotEscape $ fmap Text.concat $ Gen.list (Range.constant 0 256) $ Gen.choice [ Text.singleton <$> Gen.alphaNum , genEscapeSequence , genPunctuation , genUniHex4Color , genUniHex8Color+ --, genUnicodeChar ] + genString :: Gen String genString = Text.unpack <$> genText @@ -307,19 +345,19 @@ genLText = L.fromStrict <$> genText -- | List of AnyValue generators.-noneArrayList :: MonadGen m => [m AnyValue]+noneArrayList :: [Gen AnyValue] noneArrayList = [ AnyValue . Bool <$> genBool , AnyValue . Integer <$> genInteger , AnyValue . Double <$> genDouble , AnyValue . Text <$> genText- , AnyValue . Zoned <$> genZoned- , AnyValue . Local <$> genLocal+ , AnyValue . Zoned <$> genZonedTime+ , AnyValue . Local <$> genLocalTime , AnyValue . Day <$> genDay- , AnyValue . Hours <$> genHours+ , AnyValue . Hours <$> genTimeOfDay ] -genArrayFrom :: MonadGen m => m AnyValue -> m (Value 'TArray)+genArrayFrom :: Gen AnyValue -> Gen (Value 'TArray) genArrayFrom noneArray = do eVal <- toMArray <$> Gen.list (Range.constant 0 5) noneArray case eVal of@@ -327,12 +365,44 @@ Right val -> pure val {- | Generate arrays and nested arrays. For example:+ Common array:-Array [Double (-563397.0197456297),Double (-308866.62837749254),Double (-29555.32072604308),Double 772371.8575471763,Double (-880016.1210667372),Double 182763.78796234122,Double (-462893.41157520143),Double 814856.6483699235,Double (-454629.17640282493)]++@+Array+ [ Double (-5.7)+ , Double (-6.4)+ , Double 1.3+ ]+@+ Nested array of AnyValue:-Array [Array [Text "ACyz38VcLz0hxwdFkHTU6PYK8h8CeaiEpI2xAaiZTKBQ3zC1W717cZY35lk8EAK6pPw3WvwIdNktxIV2LrvFSpU8ee6zkXvpvePitW9aspAeeOCF9Q9ry20y7skFZ2qShi7CSx8888zWIqyc8iBkoLNvq4fONLtuUqSw2SlNee4hDIwrnx5O4RuHW1dQfJcnC34h9S0DlIGYP08qq6QHxO4E0HE74cNmiViGm3xpDC8Ro5D8Y6p0FLSN1ELq9Lwm",Text "HhNv0LKICdlKxN"],Array [Integer 986479839551009895,Integer 8636972066308796678,Integer (-3464941350081979804),Integer (-6560688879547055621),Integer (-4749037439349044738)],Array []]++@+Array+ [ Array+ [ Text "AH",Text "HA"]+ , Array [Integer 9,Integer (-3)]+ , Array []+ ]+ ]+@ -}-genArray :: MonadGen m => m (Value 'TArray)+genArray :: Gen (Value 'TArray) genArray = Gen.recursive Gen.choice [Gen.choice $ map genArrayFrom noneArrayList] [Array <$> Gen.list (Range.constant 0 5) genArray]++-- filters++-- | Discards strings that end with @\@+genNotEscape :: Gen Text -> Gen Text+genNotEscape gen = gen >>= \t ->+ if | Text.null t -> pure t+ | Text.last t == '\\' -> Gen.discard+ | otherwise -> pure t++-- Orphan instances++instance Eq ZonedTime where+ (ZonedTime a b) == (ZonedTime c d) = a == c && b == d
+ test/Test/Toml/Parser.hs view
@@ -0,0 +1,34 @@+module Test.Toml.Parser+ ( parserSpec+ ) where++import Test.Hspec (Spec, describe)++import Test.Toml.Parser.Array (arraySpecs)+import Test.Toml.Parser.Bool (boolSpecs)+import Test.Toml.Parser.Date (dateSpecs)+import Test.Toml.Parser.Double (doubleSpecs)+import Test.Toml.Parser.Examples (examplesSpec)+import Test.Toml.Parser.Integer (integerSpecs)+import Test.Toml.Parser.Key (keySpecs)+import Test.Toml.Parser.Property (propertySpec)+import Test.Toml.Parser.Text (textSpecs)+import Test.Toml.Parser.Toml (tomlSpecs)+import Test.Toml.Parser.Validate (validateSpec)+++parserSpec :: Spec+parserSpec = describe "Parser for TOML" $ do+ examplesSpec+ propertySpec+ validateSpec++ -- unit tests for different parser parts+ arraySpecs+ boolSpecs+ dateSpecs+ doubleSpecs+ integerSpecs+ keySpecs+ textSpecs+ tomlSpecs
+ test/Test/Toml/Parser/Array.hs view
@@ -0,0 +1,74 @@+module Test.Toml.Parser.Array+ ( arraySpecs+ ) where++import Data.Time (TimeOfDay (..))+import Test.Hspec (Spec, describe, it)++import Test.Toml.Parser.Common (arrayFailOn, day1, day2, int1, int2, int3, int4, parseArray)+import Toml.Type (UValue (..))+++arraySpecs :: Spec+arraySpecs = describe "arrayP" $ do+ it "can parse arrays" $ do+ parseArray+ "[]"+ []+ parseArray+ "[1]"+ [int1]+ parseArray+ "[1, 2, 3]"+ [int1, int2, int3]+ parseArray+ "[1.2, 2.3, 3.4]"+ [UDouble 1.2, UDouble 2.3, UDouble 3.4]+ parseArray+ "['x', 'y']"+ [UText "x", UText "y"]+ parseArray+ "[[1], [2]]"+ [UArray [UInteger 1], UArray [UInteger 2]]+ parseArray+ "[1920-12-10, 1979-05-27]"+ [UDay day2, UDay day1]+ parseArray+ "[16:33:05, 10:15:30]"+ [UHours (TimeOfDay 16 33 5), UHours (TimeOfDay 10 15 30)]+ it "can parse multiline arrays" $+ parseArray+ "[\n1,\n2\n]"+ [int1, int2]+ it "can parse an array of arrays" $+ parseArray+ "[[1], [2.3, 5.1]]"+ [UArray [int1], UArray [UDouble 2.3, UDouble 5.1]]+ it "can parse an array with terminating commas (trailing commas)" $ do+ parseArray+ "[1, 2,]"+ [int1, int2]+ parseArray+ "[1, 2, 3, , ,]"+ [int1, int2, int3]+ it "allows an arbitrary number of comments and newlines before or after a value" $+ parseArray+ "[\n\n#c\n1, #c 2 \n 2, \n\n\n 3, #c \n #c \n 4]"+ [int1, int2, int3, int4]+ it "ignores white spaces" $+ parseArray+ "[ 1 , 2,3, 4 ]"+ [int1, int2, int3, int4]++ it "fails if the elements are not surrounded by square brackets" $ do+ arrayFailOn "1, 2, 3"+ arrayFailOn "[1, 2, 3"+ arrayFailOn "1, 2, 3]"+ arrayFailOn "{'x', 'y', 'z'}"+ arrayFailOn "(\"ab\", \"cd\")"+ arrayFailOn "<true, false>"+ it "fails if the elements are not separated by commas" $ do+ arrayFailOn "[1 2 3]"+ arrayFailOn "[1 . 2 . 3]"+ arrayFailOn "['x' - 'y' - 'z']"+ arrayFailOn "[1920-12-10, 10:15:30]"
+ test/Test/Toml/Parser/Bool.hs view
@@ -0,0 +1,22 @@+module Test.Toml.Parser.Bool+ ( boolSpecs+ ) where++import Test.Hspec (Spec, describe, it)++import Test.Toml.Parser.Common (boolFailOn, parseBool)+++boolSpecs :: Spec+boolSpecs = describe "boolP" $ do+ it "can parse `true` and `false`" $ do+ parseBool "true" True+ parseBool "false" False+ parseBool "true " True+ it "fails if `true` or `false` are not all lowercase" $ do+ boolFailOn "True"+ boolFailOn "False"+ boolFailOn "TRUE"+ boolFailOn "FALSE"+ boolFailOn "tRuE"+ boolFailOn "fAlSE"
+ test/Test/Toml/Parser/Common.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE CPP #-}++module Test.Toml.Parser.Common+ ( parseX+ , failOn+ , parseArray+ , parseBool+ , parseDouble+ , parseInteger+ , parseKey+ , parseText+ , parseToml+ , parseDateTime+ , arrayFailOn+ , boolFailOn+ , integerFailOn+ , dateTimeFailOn+ , doubleFailOn+ , textFailOn+ , tomlFailOn+ , quoteWith+ , squote+ , dquote+ , squote3+ , dquote3+ , makeOffset+ , makeZoned+ , int1+ , int2+ , int3+ , int4+ , offset710+ , offset0+ , day1+ , day2+ , hours1+ ) where++import Data.Text (Text)+import Data.Time (Day, LocalTime (..), TimeOfDay (..), TimeZone, ZonedTime (..), fromGregorian,+ minutesToTimeZone)+import Test.Hspec (Expectation)+import Test.Hspec.Megaparsec (shouldFailOn, shouldParse)+import Text.Megaparsec (Parsec, ShowErrorComponent, parse)+#if __GLASGOW_HASKELL__ <= 804+import Text.Megaparsec (Stream)+#endif+#if MIN_VERSION_megaparsec(9,0,0)+import Text.Megaparsec.Stream (TraversableStream, VisualStream)+#endif++import Toml.Parser.Item (tomlP)+import Toml.Parser.Key (keyP)+import Toml.Parser.String (textP)+import Toml.Parser.Validate (validateItems)+import Toml.Parser.Value (arrayP, boolP, dateTimeP, doubleP, integerP)+import Toml.Type.Key (Key (..))+import Toml.Type.TOML (TOML (..))+import Toml.Type.UValue (UValue (..))+++parseX+ :: ( ShowErrorComponent e+#if __GLASGOW_HASKELL__ <= 804+ , Stream s+#endif+#if MIN_VERSION_megaparsec(9,0,0)+ , VisualStream s+ , TraversableStream s+#endif+ , Show a+ , Eq a+ )+ => Parsec e s a -> s -> a -> Expectation+parseX p given expected = parse p "" given `shouldParse` expected++failOn :: Show a => Parsec e s a -> s -> Expectation+failOn p given = parse p "" `shouldFailOn` given++parseArray :: Text -> [UValue] -> Expectation+parseArray = parseX arrayP++parseBool :: Text -> Bool -> Expectation+parseBool = parseX boolP++parseDateTime :: Text -> UValue -> Expectation+parseDateTime = parseX dateTimeP++parseDouble :: Text -> Double -> Expectation+parseDouble = parseX doubleP++parseInteger :: Text -> Integer -> Expectation+parseInteger = parseX integerP++parseKey :: Text -> Key -> Expectation+parseKey = parseX keyP++parseText :: Text -> Text -> Expectation+parseText = parseX textP++parseToml :: Text -> TOML -> Expectation+parseToml test toml = parseX (validateItems <$> tomlP) test (Right toml)++arrayFailOn+ , boolFailOn+ , dateTimeFailOn+ , doubleFailOn+ , integerFailOn+ , textFailOn+ , tomlFailOn :: Text -> Expectation+arrayFailOn = failOn arrayP+boolFailOn = failOn boolP+dateTimeFailOn = failOn dateTimeP+doubleFailOn = failOn doubleP+integerFailOn = failOn integerP+textFailOn = failOn textP+tomlFailOn = failOn tomlP++-- Surround given text with quotes.+quoteWith :: Text -> Text -> Text+quoteWith q t = q <> t <> q+squote, dquote, squote3, dquote3 :: Text -> Text+squote = quoteWith "'"+dquote = quoteWith "\""+squote3 = quoteWith "'''"+dquote3 = quoteWith "\"\"\""++-- UValue Util++makeZoned :: Day -> TimeOfDay -> TimeZone -> UValue+makeZoned d h offset = UZoned $ ZonedTime (LocalTime d h) offset++makeOffset :: Int -> Int -> TimeZone+makeOffset hours mins = minutesToTimeZone (hours * 60 + mins * signum hours)++-- Test Data++int1, int2, int3, int4 :: UValue+int1 = UInteger 1+int2 = UInteger 2+int3 = UInteger 3+int4 = UInteger 4++offset0, offset710 :: TimeZone+offset0 = makeOffset 0 0+offset710 = makeOffset 7 10++day1, day2 :: Day+day1 = fromGregorian 1979 5 27 -- 1979-05-27+day2 = fromGregorian 1920 12 10 -- 1920-12-10++hours1 :: TimeOfDay+hours1 = TimeOfDay 7 32 0 -- 07:32:00
+ test/Test/Toml/Parser/Date.hs view
@@ -0,0 +1,63 @@+module Test.Toml.Parser.Date+ ( dateSpecs+ ) where++import Data.Time (LocalTime (..), TimeOfDay (..))+import Test.Hspec (Spec, describe, it)++import Test.Toml.Parser.Common (dateTimeFailOn, day1, hours1, makeOffset, makeZoned, offset0,+ offset710, parseDateTime)+import Toml.Type (UValue (..))+++dateSpecs :: Spec+dateSpecs = describe "dateTimeP" $ do+ it "can parse a date-time with an offset" $ do+ parseDateTime "1979-05-27T07:32:00Z" $+ makeZoned day1 hours1 offset0+ parseDateTime "1979-05-27T00:32:00+07:10" $+ makeZoned day1 (TimeOfDay 0 32 0) offset710+ parseDateTime "1979-05-27T00:32:00.999999-07:25" $+ makeZoned day1 (TimeOfDay 0 32 0.999999) (makeOffset (-7) 25)+ it "can parse a date-time with an offset when the T delimiter is replaced with a space" $+ parseDateTime "1979-05-27 07:32:00Z" $+ makeZoned day1 hours1 offset0+ it "can parse a date-time without an offset" $ do+ parseDateTime "1979-05-27T17:32:00"+ (ULocal $ LocalTime day1 (TimeOfDay 17 32 0))+ parseDateTime "1979-05-27T00:32:00.999999"+ (ULocal $ LocalTime day1 (TimeOfDay 0 32 0.999999))+ it "can parse a local date" $+ parseDateTime "1979-05-27" (UDay day1)+ it "can parse a local time" $ do+ parseDateTime "07:32:00" (UHours hours1)+ parseDateTime "00:32:00.999999" (UHours $ TimeOfDay 0 32 0.999999)+ it "truncates the additional precision after picoseconds in the fractional seconds" $+ parseDateTime "00:32:00.99999999999199"+ (UHours $ TimeOfDay 0 32 0.999999999991)+ it "fails if the date is not valid" $ do+ dateTimeFailOn "1920-15-12"+ dateTimeFailOn "1920-12-40"+ it "fails if the date does not have the form: 'yyyy-mm-dd'" $ do+ dateTimeFailOn "1920-01-1"+ dateTimeFailOn "1920-1-01"+ dateTimeFailOn "920-01-01"+ dateTimeFailOn "1920/10/01"+ it "fails if the time is not valid" $ do+ dateTimeFailOn "25:10:10"+ dateTimeFailOn "10:70:10"+ dateTimeFailOn "10:10:70"+ it "fails if the time does not have the form: 'hh:mm:ss'" $ do+ dateTimeFailOn "1:12:12"+ dateTimeFailOn "12:1:12"+ dateTimeFailOn "12:12:1"+ dateTimeFailOn "12-12-12"+ it "fails if the offset does not have any of the forms: 'Z', '+hh:mm', '-hh:mm'" $ do+ parseDateTime "1979-05-27T00:32:00X"+ (ULocal $ LocalTime day1 (TimeOfDay 0 32 0))+ parseDateTime "1979-05-27T00:32:00+07:1"+ (ULocal $ LocalTime day1 (TimeOfDay 0 32 0))+ parseDateTime "1979-05-27T00:32:00+7:01"+ (ULocal $ LocalTime day1 (TimeOfDay 0 32 0))+ parseDateTime "1979-05-27T00:32:0007:00"+ (ULocal $ LocalTime day1 (TimeOfDay 0 32 0))
+ test/Test/Toml/Parser/Double.hs view
@@ -0,0 +1,45 @@+module Test.Toml.Parser.Double+ (doubleSpecs+ ) where++import Test.Hspec (Spec, describe, it)+import Test.Hspec.Megaparsec (parseSatisfies)+import Text.Megaparsec (parse)++import Test.Toml.Parser.Common (doubleFailOn, parseDouble)+import Toml.Parser.Value (doubleP)+++doubleSpecs :: Spec+doubleSpecs = describe "doubleP" $ do+ it "can parse a number which consists of an integral part, and a fractional part" $ do+ parseDouble "+1.0" 1.0+ parseDouble "3.1415" 3.1415+ parseDouble "0.0" 0.0+ parseDouble "-0.01" (-0.01)+ parseDouble "5e+22" 5e+22+ parseDouble "1e6" 1e6+ parseDouble "-2E-2" (-2E-2)+ parseDouble "6.626e-34" 6.626e-34+ it "can parse a number with underscores" $ do+ parseDouble "5e+2_2" 5e+22+ parseDouble "1.1_1e6" 1.11e6+ parseDouble "-2_2.21_9E-0_2" (-22.219E-2)+ it "can parse sign-prefixed zero" $ do+ parseDouble "+0.0" 0.0+ parseDouble "-0.0" (-0.0)+ it "can parse positive and negative special float values (inf and nan)" $ do+ parseDouble "inf" (1 / 0)+ parseDouble "+inf" (1 / 0)+ parseDouble "-inf" (-1 / 0)+ doubleSatisfies "nan" isNaN+ doubleSatisfies "+nan" isNaN+ doubleSatisfies "-nan" isNaN+ it "fails if `inf` or `nan` are not all lowercase" $ do+ doubleFailOn "Inf"+ doubleFailOn "INF"+ doubleFailOn "Nan"+ doubleFailOn "NAN"+ doubleFailOn "NaN"+ where+ doubleSatisfies given f = parse doubleP "" given `parseSatisfies` f
+ test/Test/Toml/Parser/Examples.hs view
@@ -0,0 +1,25 @@+module Test.Toml.Parser.Examples+ ( examplesSpec+ ) where++import Data.Either (isRight)+import System.Directory (listDirectory)+import Test.Hspec (Spec, describe, it, runIO, shouldBe)++import Toml.Parser (parse)++import qualified Data.Text.IO as TIO+++examplesSpec :: Spec+examplesSpec = describe "Can parse official TOML examples" $ do+ files <- runIO $ listDirectory exampleDir+ mapM_ example files++example :: FilePath -> Spec+example file = it ("can parse file " ++ file) $ do+ toml <- TIO.readFile (exampleDir ++ file)+ isRight (parse toml) `shouldBe` True++exampleDir :: FilePath+exampleDir = "test/examples/"
+ test/Test/Toml/Parser/Integer.hs view
@@ -0,0 +1,123 @@+module Test.Toml.Parser.Integer+ ( integerSpecs+ ) where++import Test.Hspec (Spec, context, describe, it)++import Test.Toml.Parser.Common (integerFailOn, parseInteger)+++integerSpecs :: Spec+integerSpecs = describe "integerP" $ do+ context "when the integer is in decimal representation" $ do+ it "can parse positive integer numbers" $ do+ parseInteger "10" 10+ parseInteger "+3" 3+ parseInteger "0" 0+ it "can parse negative integer numbers" $+ parseInteger "-123" (-123)+ it "can parse sign-prefixed zero as an unprefixed zero" $ do+ parseInteger "+0" 0+ parseInteger "-0" 0+ it "can parse both the minimum and maximum numbers in the 64 bit range" $ do+ parseInteger "-9223372036854775808" (-9223372036854775808)+ parseInteger "9223372036854775807" 9223372036854775807+ it "can parse numbers with underscores between digits" $ do+ parseInteger "1_000" 1000+ parseInteger "5_349_221" 5349221+ parseInteger "1_2_3_4_5" 12345+ it "does not parse incorrect underscores" $ do+ integerFailOn "1_2_3_"+ integerFailOn "13_"+ integerFailOn "_123_"+ integerFailOn "_13"+ integerFailOn "_"+ it "does not parse numbers with leading zeros" $ do+ integerFailOn "0123"+ integerFailOn "00123"+ integerFailOn "-023"+ integerFailOn "-0023"+ context "when the integer is in binary representation" $ do+ it "can parse numbers prefixed with `0b`" $ do+ parseInteger "0b1101" 13+ parseInteger "0b0" 0+ it "does not parse numbers prefixed with `0B`" $+ parseInteger "0B1101" 0+ it "can parse numbers with leading zeros after the prefix" $ do+ parseInteger "0b000" 0+ parseInteger "0b00011" 3+ it "does not parse negative numbers" $+ parseInteger "-0b101" 0+ it "does not parse numbers with non-valid binary digits" $+ parseInteger "0b123" 1+ context "when the integer is in octal representation" $ do+ it "can parse numbers prefixed with `0o`" $ do+ parseInteger "0o567" 0o567+ parseInteger "0o0" 0+ it "does not parse numbers prefixed with `0O`" $+ parseInteger "0O567" 0+ it "can parse numbers with leading zeros after the prefix" $ do+ parseInteger "0o000000" 0+ parseInteger "0o000567" 0o567+ it "does not parse negative numbers" $+ parseInteger "-0o123" 0+ it "does not parse numbers with non-valid octal digits" $+ parseInteger "0o789" 0o7+ context "when the integer is in hexadecimal representation" $ do+ it "can parse numbers prefixed with `0x`" $ do+ parseInteger "0x12af" 0x12af+ parseInteger "0x0" 0+ it "does not parse numbers prefixed with `0X`" $+ parseInteger "0Xfff" 0+ it "can parse numbers with leading zeros after the prefix" $ do+ parseInteger "0x00000" 0+ parseInteger "0x012af" 0x12af+ it "does not parse negative numbers" $+ parseInteger "-0xfff" 0+ it "does not parse numbers with non-valid hexadecimal digits" $+ parseInteger "0xfgh" 0xf+ it "can parse numbers when hex digits are lowercase" $+ parseInteger "0xabcdef" 0xabcdef+ it "can parse numbers when hex digits are uppercase" $+ parseInteger "0xABCDEF" 0xABCDEF+ it "can parse numbers when hex digits are in both lowercase and uppercase" $ do+ parseInteger "0xAbCdEf" 0xAbCdEf+ parseInteger "0xaBcDeF" 0xaBcDeF+ context "when there is underscore in hexadecimal, octal and binary representation" $ do+ it "can parse numbers with underscore in hexadecimal representation" $ do+ parseInteger "0xAb_Cd_Ef" 0xabcdef+ parseInteger "0xA_bcd_ef" 0xabcdef+ parseInteger "0x123_abc" 0x123abc+ parseInteger "0xa_b_c_1_2_3" 0xabc123+ it "can't parse when underscore is between hexadecimal prefix and suffix" $ do+ integerFailOn "0x_Abab_ca"+ integerFailOn "0x_ababbac"+ it "can parse numbers with underscore in octal representation" $ do+ parseInteger "0o12_34_56" 0o123456+ parseInteger "0o1_2345_6" 0o123456+ parseInteger "0o76_54_21" 0o765421+ parseInteger "0o4_5_3_2_6" 0o45326+ it "can't parse when underscore is between octal prefix and suffix" $ do+ integerFailOn "0o_123_4567"+ integerFailOn "0o_1234567"+ it "can parse numbers with underscore in binary representation" $ do+ parseInteger "0b10_101_0" 42+ parseInteger "0b10_10_10" 42+ parseInteger "0b1_0_1" 5+ parseInteger "0b1_0" 2+ it "can't parse numbers when underscore is between binary prefix and suffix" $ do+ integerFailOn "0b_10101_0"+ integerFailOn "0b_101010"+ it "doesn't parse underscore not followed by any numbers" $ do + integerFailOn "0b_"+ integerFailOn "0o_"+ integerFailOn "0x_"+ it "doesn't parse when number is ending with underscore" $ do + integerFailOn "0b101_110_"+ integerFailOn "0b10101_"+ integerFailOn "0x1_23_daf_"+ integerFailOn "0x1214adf_"+ integerFailOn "0o1_15_41_"+ integerFailOn "0o1215147_"+ +
+ test/Test/Toml/Parser/Key.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE PatternSynonyms #-}++module Test.Toml.Parser.Key+ ( keySpecs+ ) where++import Test.Hspec (Spec, context, describe, it, xit)++import Test.Toml.Parser.Common (dquote, parseKey, squote)+import Toml.Type.Key (pattern (:||))+++keySpecs :: Spec+keySpecs = describe "keyP" $ do+ context "when the key is a bare key" $ do+ it "can parse keys which contain ASCII letters, digits, underscores, and dashes" $ do+ parseKey "key" "key"+ parseKey "bare_key1" "bare_key1"+ parseKey "bare-key2" "bare-key2"+ it "can parse keys which contain only digits" $+ parseKey "1234" "1234"+ context "when the key is a quoted key" $ do+ it "can parse keys that follow the exact same rules as basic strings" $ do+ parseKey (dquote "127.0.0.1") ("\"127.0.0.1\"" :|| [])+ parseKey (dquote "character encoding") "\"character encoding\""+ parseKey (dquote "ʎǝʞ") "\"ʎǝʞ\""+ it "can parse keys that follow the exact same rules as literal strings" $ do+ parseKey (squote "key2") "'key2'"+ parseKey (squote "quoted \"value\"") "'quoted \"value\"'"+ context "when the key is a dotted key" $ do+ it "can parse a sequence of bare or quoted keys joined with a dot" $ do+ parseKey "name" "name"+ parseKey "physical.color" "physical.color"+ parseKey "physical.shape" "physical.shape"+ parseKey "site.\"google.com\"" ("site" :|| ["\"google.com\""])+ xit "ignores whitespaces around dot-separated parts" $+ parseKey "a . b . c. d" ("a" :|| ["b", "c", "d"])+ context "when the key is symbols only" $ do+ it "parses Haskell comments" $+ parseKey "--" "--"+ it "parses Haskell comments with dots" $+ parseKey "--.--" $ "--" :|| [ "--" ]+ it "parses underscores" $ do+ parseKey "_" "_"+ parseKey "__" "__"+ parseKey "___" "___"+ it "parses quotes" $+ parseKey "\".\"" $ "\".\"" :|| []
+ test/Test/Toml/Parser/Property.hs view
@@ -0,0 +1,21 @@+module Test.Toml.Parser.Property+ ( propertySpec+ ) where++import Hedgehog (forAll, tripping)+import Test.Hspec (Arg, Expectation, Spec, SpecWith, describe, it)+import Test.Hspec.Hedgehog (hedgehog)++import Test.Toml.Gen (genToml)+import Toml.Parser (parse)+import Toml.Type.Printer (pretty)+++propertySpec :: Spec+propertySpec = describe "Parsing property tests"+ parsePrintRoundTrip++parsePrintRoundTrip :: SpecWith (Arg Expectation)+parsePrintRoundTrip = it "parse . prettyPrint == id" $ hedgehog $ do+ toml <- forAll genToml+ tripping toml pretty parse
+ test/Test/Toml/Parser/Text.hs view
@@ -0,0 +1,96 @@+module Test.Toml.Parser.Text+ ( textSpecs+ ) where++import Test.Hspec (Spec, context, describe, it)++import Test.Toml.Parser.Common (dquote, dquote3, parseText, squote, squote3, textFailOn)+++textSpecs :: Spec+textSpecs = describe "textP" $ do+ context "when the string is a basic string" $ do+ it "can parse strings surrounded by double quotes" $ do+ parseText (dquote "xyz") "xyz"+ parseText (dquote "") ""+ textFailOn "\"xyz"+ textFailOn "xyz\""+ textFailOn "xyz"+ it "can parse escaped quotation marks, backslashes, and control characters" $ do+ parseText (dquote "backspace: \\b") "backspace: \b"+ parseText (dquote "tab: \\t") "tab: \t"+ parseText (dquote "linefeed: \\n") "linefeed: \n"+ parseText (dquote "form feed: \\f") "form feed: \f"+ parseText (dquote "carriage return: \\r") "carriage return: \r"+ parseText (dquote "quote: \\\"") "quote: \""+ parseText (dquote "backslash: \\\\") "backslash: \\"+ parseText (dquote "a\\uD7FFxy\\U0010FFFF\\uE000") "a\55295xy\1114111\57344"+ it "fails if the string has an unescaped backslash, or control character" $ do+ textFailOn (dquote "new \n line")+ textFailOn (dquote "back \\ slash")+ it "fails if the string has an escape sequence that is not listed in the TOML specification" $+ textFailOn (dquote "xy\\z \\abc")+ it "fails if the string is not on a single line" $ do+ textFailOn (dquote "\nabc")+ textFailOn (dquote "ab\r\nc")+ textFailOn (dquote "abc\n")+ it "fails if escape codes are not valid Unicode scalar values" $ do+ textFailOn (dquote "\\u1")+ textFailOn (dquote "\\uxyzw")+ textFailOn (dquote "\\U0000")+ textFailOn (dquote "\\uD8FF")+ textFailOn (dquote "\\U001FFFFF")+ context "when the string is a multi-line basic string" $ do++ it "can parse multi-line strings surrounded by three double quotes" $+ parseText (dquote3 "Roses are red\nViolets are blue")+ "Roses are red\nViolets are blue"+ it "can parse single-line strings surrounded by three double quotes" $+ parseText (dquote3 "Roses are red Violets are blue")+ "Roses are red Violets are blue"+ it "can parse all of the escape sequences that are valid for basic strings" $ do+ parseText (dquote3 "backspace: \\b") "backspace: \b"+ parseText (dquote3 "tab: \\t") "tab: \t"+ parseText (dquote3 "linefeed: \\n") "linefeed: \n"+ parseText (dquote3 "form feed: \\f") "form feed: \f"+ parseText (dquote3 "carriage return: \\r") "carriage return: \r"+ parseText (dquote3 "quote: \\\"") "quote: \""+ parseText (dquote3 "backslash: \\\\") "backslash: \\"+ parseText (dquote3 "a\\uD7FFxy\\U0010FFFF\\uE000") "a\55295xy\1114111\57344"+ it "does not ignore whitespaces or newlines" $+ parseText (dquote3 "\nabc \n xyz") "abc \n xyz"+ it "ignores a newline only if it immediately follows the opening delimiter" $+ parseText (dquote3 "\nThe quick brown") "The quick brown"+ it "ignores whitespaces and newlines after line ending backslash" $+ parseText (dquote3 "The quick brown \\\n\n fox jumps over") "The quick brown fox jumps over"+ it "fails if the string has an unescaped backslash, or control character" $ do+ textFailOn (dquote3 "backslash \\ .")+ textFailOn (dquote3 "backspace \b ..")+ textFailOn (dquote3 "tab \t ..")+ context "when the string is a literal string" $ do+ it "can parse strings surrounded by single quotes" $ do+ parseText (squote "C:\\Users\\nodejs\\templates")+ "C:\\Users\\nodejs\\templates"+ parseText (squote "\\\\ServerX\\admin$\\system32\\")+ "\\\\ServerX\\admin$\\system32\\"+ parseText (squote "Tom \"Dubs\" Preston-Werner")+ "Tom \"Dubs\" Preston-Werner"+ parseText (squote "<\\i\\c*\\s*>") "<\\i\\c*\\s*>"+ parseText (squote "a \t tab") "a \t tab"+ it "fails if the string is not on a single line" $ do+ textFailOn (squote "\nabc")+ textFailOn (squote "ab\r\nc")+ textFailOn (squote "abc\n")+ context "when the string is a multi-line literal string" $ do+ it "can parse multi-line strings surrounded by three single quotes" $+ parseText (squote3 "first line \nsecond.\n 3\n")+ "first line \nsecond.\n 3\n"+ it "can parse single-line strings surrounded by three single quotes" $+ parseText (squote3 "I [dw]on't need \\d{2} apples")+ "I [dw]on't need \\d{2} apples"+ it "ignores a newline immediately following the opening delimiter" $+ parseText (squote3 "\na newline \nsecond.\n 3\n")+ "a newline \nsecond.\n 3\n"+ it "fails if the string has an unescaped control character other than tab" $ do+ parseText (squote3 "\t") "\t"+ textFailOn (squote3 "\b")
+ test/Test/Toml/Parser/Toml.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE PatternSynonyms #-}++module Test.Toml.Parser.Toml+ ( tomlSpecs+ ) where++import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.Text (Text)+import Test.Hspec (Spec, describe, it, xit)++import Test.Toml.Parser.Common (day2, failOn, parseToml, tomlFailOn)+import Toml.Parser.Item (keyValP)+import Toml.Type.Edsl (empty, mkToml, table, tableArray, (=:))+import Toml.Type.Key (pattern (:||))+import Toml.Type.TOML (TOML (..))+import Toml.Type.Value (Value (..))++import qualified Data.List.NonEmpty as NE+import qualified Data.Text as T+++tomlSpecs :: Spec+tomlSpecs = do+ describe "Key/values" $ do+ it "can parse key/value pairs" $ do+ parseToml "x='abcdef'" $ mkToml ("x" =: "abcdef")+ parseToml "x= 1" $ mkToml ("x" =: 1)+ parseToml "x =5.2" $ mkToml ("x" =: Double 5.2)+ parseToml "x = true" $ mkToml ("x" =: Bool True)+ parseToml "x= [1, 2, 3]" $ mkToml ("x" =: Array [1, 2, 3])+ parseToml "x =1920-12-10" $ mkToml ("x" =: Day day2)+ it "ignores white spaces around key names and values" $ do+ let toml = mkToml ("x" =: 1)+ parseToml "x=1 " toml+ parseToml "x= 1" toml+ parseToml "x =1" toml+ parseToml "x\t= 1 " toml+ parseToml "\"x\" = 1" $ mkToml ("\"x\"" =: 1)+ xit "fails if the key, equals sign, and value are not on the same line" $ do+ failOn keyValP "x\n=\n1"+ failOn keyValP "x=\n1"+ failOn keyValP "\"x\"\n=\n1"+ it "works if the value is broken over multiple lines" $+ parseToml "x=[1, \n2\n]" $ mkToml ("x" =: Array [1, 2])+ it "fails if the value is not specified" $+ tomlFailOn "x="++ describe "tables" $ do+ it "can parse a TOML table" $ do+ let t = mkToml $+ table "table" $ do+ "key1" =: "some string"+ "key2" =: 123++ parseToml "[table] \n key1 = \"some string\"\nkey2 = 123" t+ it "can parse an empty TOML table" $+ parseToml "[table]" $ mkToml (table "table" empty)+ it "can parse a table with subarrays" $ do+ let t = mkToml $+ table "table" $+ tableArray "array" ("key1" =: "some string" :| ["key2" =: 123])++ parseToml "[table] \n [[table.array]] \nkey1 = \"some string\"\n \+ \[[table.array]] \nkey2 = 123" t+ it "can parse a TOML inline table" $+ parseToml "table={key1 = \"some string\", key2 = 123}" $+ mkToml $+ table "table" $ do+ "key1" =: "some string"+ "key2" =: 123+ it "can parse an empty inline TOML table" $+ parseToml "table = {}" $ mkToml (table "table" empty)+ it "can parse a table followed by an inline table" $+ parseToml "[table1] \n key1 = \"some string\" \n table2 = {key2 = 123}" $+ mkToml $+ table "table1" $ do+ "key1" =: "some string"+ table "table2" $ "key2" =: 123+ it "can parse an empty table followed by an inline table" $+ parseToml "[table1] \n table2 = {key2 = 123}" $+ mkToml $+ table "table1" $+ table "table2" $+ "key2" =: 123+ it "allows the name of the table to be any valid TOML key" $ do+ parseToml "dog.\"tater.man\"={}" $ mkToml $ table ("dog" :|| ["\"tater.man\""]) empty+ parseToml "j.\"ʞ\".'l'={}" $ mkToml $ table "j.\"ʞ\".'l'" empty++ describe "array of tables" $ do+ it "can parse an empty array" $+ parseToml "[[array]]" $ mkToml $ tableArray "array" (empty :| [])+ it "can parse an array of key/values" $ do+ let array = mkToml $+ tableArray "array" $+ "key1" =: "some string" :|+ ["key2" =: 123]++ parseToml "[[array]]\n key1 = \"some string\"\n \+ \[[array]]\n key2 = 123" array+ it "can parse an array of tables" $ do+ let table1 = table "table1" ("key1" =: "some string")+ table2 = table "table2" ("key2" =: 123)+ array = mkToml $ tableArray "array" $ table1 :| [table2]++ parseToml "[[array]]\n[array.table1] \n key1 = \"some string\"\n \+ \[[array]]\n[array.table2] \n key2 = 123" array+ it "can parse an array of array" $ do+ let arr = tableArray "subarray" ("key1" =: "some string" :| ["key2" =: 123])+ array = mkToml $ tableArray "array" (arr :| [])++ parseToml "[[array]] \n [[array.subarray]] \nkey1 = \"some string\"\n \+ \[[array.subarray]] \nkey2 = 123" array+ it "can parse an array of arrays" $ do+ let+ arr1 = tableArray "table-1" ("key1" =: Text "some string" :| [])+ arr2 = tableArray "table-2" ("key2" =: Integer 123 :| [])+ array = mkToml $ tableArray "array" $ (arr1 >> arr2) :| []++ parseToml "[[array]]\n [[array.table-1]] \nkey1 = \"some string\"\n \+ \[[array.table-2]] \nkey2 = 123" array+ it "can parse very large arrays" $ do+ let array = mkToml $ tableArray "array" $ NE.fromList $ replicate 1000 empty+ parseToml (mconcat $ replicate 1000 "[[array]]\n") array+ it "can parse an inline array of tables" $ do+ let array = mkToml $ tableArray "table" $ NE.fromList ["key1" =: "some string", "key2" =: 123]+ parseToml "table = [{key1 = \"some string\"}, {key2 = 123}]" array++ describe "TOML" $ do+ it "can parse TOML files" $+ parseToml tomlStr1 toml1+ it "can parse mix of tables and arrays" $+ parseToml tomlStr2 toml2+ where+ tomlStr1, tomlStr2 :: Text+ tomlStr1 = T.unlines+ [ " # This is a TOML document.\n\n"+ , "title = \"TOML Example\" # Comment \n\n"+ , "[owner]\n"+ , " name = \"Tom Preston-Werner\" "+ , " enabled = true # First class dates"+ ]+ tomlStr2 = T.unlines+ [ "[[array1]]\n key1 = \"some string\" \n"+ , ""+ , "[table1] \n key2 = 123 \n"+ , "[[array2]]\n key3 = 3.14 \n"+ , " [table2] \n key4 = true"+ ]++ toml1, toml2 :: TOML+ toml1 = mkToml $ do+ "title" =: "TOML Example"+ table "owner" $ do+ "name" =: "Tom Preston-Werner"+ "enabled" =: Bool True++ toml2 = mkToml $ do+ tableArray "array1" $+ "key1" =: "some string" :| []+ table "table1" $ "key2" =: 123+ tableArray "array2" $+ "key3" =: Double 3.14 :| []+ table "table2" $ "key4" =: Bool True
+ test/Test/Toml/Parser/Validate.hs view
@@ -0,0 +1,79 @@+module Test.Toml.Parser.Validate+ ( validateSpec+ ) where++import Data.List.NonEmpty (NonEmpty (..))+import Hedgehog (evalEither, forAll)+import Test.Hspec (Arg, Expectation, Spec, SpecWith, describe, it, shouldBe)+import Test.Hspec.Hedgehog (hedgehog)+import Text.Megaparsec (parse)++import Test.Toml.Gen (genToml)+import Toml.Parser.Item (Table (..), TomlItem (..), tomlP)+import Toml.Parser.Validate (ValidationError (..), validateItems)+import Toml.Type.AnyValue (AnyValue (..))+import Toml.Type.Key (Key)+import Toml.Type.Printer (pretty)+import Toml.Type.Value (Value (..))+++validateSpec :: Spec+validateSpec = describe "Parser Validation tests" $ do+ -- property success+ validationProperty+ -- failure+ validationFail+ [keyVal "key", keyVal "key"]+ (DuplicateKey "key")+ validationFail+ [TableName "table", TableName "table"]+ (DuplicateTable "table")+ validationFail+ [keyVal "keyAndTable", TableName "keyAndTable"]+ (SameNameKeyTable "keyAndTable")+ validationFail+ [TableName "tableArray", TableArrayName "tableArray"]+ (SameNameTableArray "tableArray")+ validationFail+ [TableArrayName "tableArray", TableName "tableArray"]+ (SameNameTableArray "tableArray")+ validationFail+ [inlineTable "inline", TableName "inline"]+ (DuplicateTable "inline")+ validationFail+ [keyVal "inline", inlineTable "inline"]+ (SameNameKeyTable "inline")+ validationFail+ [inlineTableArray, TableName "inlinearray"]+ (SameNameTableArray "inlinearray")+ validationFail+ [inlineTableArray, inlineTable "inlinearray"]+ (SameNameTableArray "inlinearray")+ validationFail+ [inlineTable "inlinearray", inlineTableArray]+ (SameNameTableArray "inlinearray")++ where+ keyVal :: Key -> TomlItem+ keyVal k = KeyVal k (AnyValue $ Bool True)++ inlineTable :: Key -> TomlItem+ inlineTable k = InlineTable k table++ inlineTableArray :: TomlItem+ inlineTableArray = InlineTableArray "inlinearray" (table :| [])++ table :: Table+ table = Table []++validationProperty :: SpecWith (Arg Expectation)+validationProperty = it "Property: validates any generated TOML" $ hedgehog $ do+ toml <- forAll genToml+ let tomlText = pretty toml+ tomlItems <- evalEither $ parse tomlP "" tomlText+ _ <- evalEither (validateItems tomlItems)+ pure ()++validationFail :: [TomlItem] -> ValidationError -> SpecWith (Arg Expectation)+validationFail tomlItems validationError = it ("fail on " ++ show validationError) $+ validateItems tomlItems `shouldBe` Left validationError
− test/Test/Toml/Parsing/Examples.hs
@@ -1,21 +0,0 @@-module Test.Toml.Parsing.Examples where--import Data.Either (isRight)-import System.Directory (listDirectory)-import Test.Tasty.Hspec (Spec, describe, it, runIO, shouldBe)-import Toml.Parser (parse)--import qualified Data.Text.IO as TIO--spec_Examples :: Spec-spec_Examples = describe "Can parse official TOML examples" $ do- files <- runIO $ listDirectory exampleDir- mapM_ example files--example :: FilePath -> Spec-example file = it ("can parse file " ++ file) $ do- toml <- TIO.readFile (exampleDir ++ file)- isRight (parse toml) `shouldBe` True--exampleDir :: FilePath-exampleDir = "test/examples/"
− test/Test/Toml/Parsing/Property.hs
@@ -1,13 +0,0 @@-module Test.Toml.Parsing.Property where--import Hedgehog (forAll, tripping)--import Toml.Parser (parse)-import Toml.Printer (pretty)--import Test.Toml.Gen (PropertyTest, genToml, prop)--test_tomlRoundtrip :: PropertyTest-test_tomlRoundtrip = prop "parse . prettyPrint == id" $ do- toml <- forAll genToml- tripping toml pretty parse
− test/Test/Toml/Parsing/Unit.hs
@@ -1,573 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--module Test.Toml.Parsing.Unit where--import Data.List.NonEmpty (NonEmpty ((:|)))-import Data.Semigroup ((<>))-import Data.Text (Text)-import Data.Time (Day, LocalTime (..), TimeOfDay (..), TimeZone, ZonedTime (..), fromGregorian,- minutesToTimeZone)-import Test.Hspec.Megaparsec (parseSatisfies, shouldFailOn, shouldParse)-import Test.Tasty.Hspec (Expectation, Spec, context, describe, it)-import Text.Megaparsec (Parsec, ShowErrorComponent, Stream, parse)--import Toml.Edsl (mkToml, table, tableArray, (=:))-import Toml.Parser.String (textP)-import Toml.Parser.TOML (keyP, tomlP)-import Toml.Parser.Value (arrayP, boolP, dateTimeP, doubleP, integerP)-import Toml.PrefixTree (Key (..), Piece (..), fromList)-import Toml.Type (AnyValue (..), TOML (..), UValue (..), Value (..))--import qualified Data.HashMap.Lazy as HashMap-import qualified Data.List.NonEmpty as NE-import qualified Data.Text as T--spec_Parser :: Spec-spec_Parser = do- arraySpecs- boolSpecs- doubleSpecs- integerSpecs- keySpecs- textSpecs- dateSpecs- tomlSpecs--arraySpecs :: Spec-arraySpecs = describe "arrayP" $ do- it "can parse arrays" $ do- parseArray "[]" []- parseArray "[1]" [int1]- parseArray "[1, 2, 3]" [int1, int2, int3]- parseArray "[1.2, 2.3, 3.4]" [UDouble 1.2, UDouble 2.3, UDouble 3.4]- parseArray "['x', 'y']" [UText "x", UText "y"]- parseArray "[[1], [2]]" [UArray [UInteger 1], UArray [UInteger 2]]- parseArray "[1920-12-10, 1979-05-27]" [UDay day2, UDay day1]- parseArray "[16:33:05, 10:15:30]" [UHours (TimeOfDay 16 33 5), UHours (TimeOfDay 10 15 30)]- it "can parse multiline arrays" $- parseArray "[\n1,\n2\n]" [int1, int2]- it "can parse an array of arrays" $- parseArray "[[1], [2.3, 5.1]]" [UArray [int1], UArray [UDouble 2.3, UDouble 5.1]]- it "can parse an array with terminating commas (trailing commas)" $ do- parseArray "[1, 2,]" [int1, int2]- parseArray "[1, 2, 3, , ,]" [int1, int2, int3]- it "allows an arbitrary number of comments and newlines before or after a value" $- parseArray "[\n\n#c\n1, #c 2 \n 2, \n\n\n 3, #c \n #c \n 4]" [int1, int2, int3, int4]- it "ignores white spaces" $- parseArray "[ 1 , 2,3, 4 ]" [int1, int2, int3, int4]- it "fails if the elements are not surrounded by square brackets" $ do- arrayFailOn "1, 2, 3"- arrayFailOn "[1, 2, 3"- arrayFailOn "1, 2, 3]"- arrayFailOn "{'x', 'y', 'z'}"- arrayFailOn "(\"ab\", \"cd\")"- arrayFailOn "<true, false>"- it "fails if the elements are not separated by commas" $ do- arrayFailOn "[1 2 3]"- arrayFailOn "[1 . 2 . 3]"- arrayFailOn "['x' - 'y' - 'z']"- arrayFailOn "[1920-12-10, 10:15:30]"--boolSpecs :: Spec-boolSpecs = describe "boolP" $ do- it "can parse `true` and `false`" $ do- parseBool "true" True- parseBool "false" False- parseBool "true " True- it "fails if `true` or `false` are not all lowercase" $ do- boolFailOn "True"- boolFailOn "False"- boolFailOn "TRUE"- boolFailOn "FALSE"- boolFailOn "tRuE"- boolFailOn "fAlSE"--doubleSpecs :: Spec-doubleSpecs = describe "doubleP" $ do- it "can parse a number which consists of an integral part, and a fractional part" $ do- parseDouble "+1.0" 1.0- parseDouble "3.1415" 3.1415- parseDouble "0.0" 0.0- parseDouble "-0.01" (-0.01)- parseDouble "5e+22" 5e+22- parseDouble "1e6" 1e6- parseDouble "-2E-2" (-2E-2)- parseDouble "6.626e-34" 6.626e-34- it "can parse a number with underscores" $ do- parseDouble "5e+2_2" 5e+22- parseDouble "1.1_1e6" 1.11e6- parseDouble "-2_2.21_9E-0_2" (-22.219E-2)- it "can parse sign-prefixed zero" $ do- parseDouble "+0.0" 0.0- parseDouble "-0.0" (-0.0)- it "can parse positive and negative special float values (inf and nan)" $ do- parseDouble "inf" (1 / 0)- parseDouble "+inf" (1 / 0)- parseDouble "-inf" (-1 / 0)- doubleSatisfies "nan" isNaN- doubleSatisfies "+nan" isNaN- doubleSatisfies "-nan" isNaN- it "fails if `inf` or `nan` are not all lowercase" $ do- doubleFailOn "Inf"- doubleFailOn "INF"- doubleFailOn "Nan"- doubleFailOn "NAN"- doubleFailOn "NaN"- where- doubleSatisfies given f = parse doubleP "" given `parseSatisfies` f--integerSpecs :: Spec-integerSpecs = describe "integerP" $ do- context "when the integer is in decimal representation" $ do- it "can parse positive integer numbers" $ do- parseInteger "10" 10- parseInteger "+3" 3- parseInteger "0" 0- it "can parse negative integer numbers" $- parseInteger "-123" (-123)- it "can parse sign-prefixed zero as an unprefixed zero" $ do- parseInteger "+0" 0- parseInteger "-0" 0- it "can parse both the minimum and maximum numbers in the 64 bit range" $ do- parseInteger "-9223372036854775808" (-9223372036854775808)- parseInteger "9223372036854775807" 9223372036854775807- it "can parse numbers with underscores between digits" $ do- parseInteger "1_000" 1000- parseInteger "5_349_221" 5349221- parseInteger "1_2_3_4_5" 12345- it "does not parse incorrect underscores" $ do- integerFailOn "1_2_3_"- integerFailOn "13_"- integerFailOn "_123_"- integerFailOn "_13"- integerFailOn "_"- it "does not parse numbers with leading zeros" $ do- parseInteger "0123" 0- parseInteger "-023" 0- context "when the integer is in binary representation" $ do- it "can parse numbers prefixed with `0b`" $ do- parseInteger "0b1101" 13- parseInteger "0b0" 0- it "does not parse numbers prefixed with `0B`" $- parseInteger "0B1101" 0- it "can parse numbers with leading zeros after the prefix" $ do- parseInteger "0b000" 0- parseInteger "0b00011" 3- it "does not parse negative numbers" $- parseInteger "-0b101" 0- it "does not parse numbers with non-valid binary digits" $- parseInteger "0b123" 1- context "when the integer is in octal representation" $ do- it "can parse numbers prefixed with `0o`" $ do- parseInteger "0o567" 0o567- parseInteger "0o0" 0- it "does not parse numbers prefixed with `0O`" $- parseInteger "0O567" 0- it "can parse numbers with leading zeros after the prefix" $ do- parseInteger "0o000000" 0- parseInteger "0o000567" 0o567- it "does not parse negative numbers" $- parseInteger "-0o123" 0- it "does not parse numbers with non-valid octal digits" $- parseInteger "0o789" 0o7- context "when the integer is in hexadecimal representation" $ do- it "can parse numbers prefixed with `0x`" $ do- parseInteger "0x12af" 0x12af- parseInteger "0x0" 0- it "does not parse numbers prefixed with `0X`" $- parseInteger "0Xfff" 0- it "can parse numbers with leading zeros after the prefix" $ do- parseInteger "0x00000" 0- parseInteger "0x012af" 0x12af- it "does not parse negative numbers" $- parseInteger "-0xfff" 0- it "does not parse numbers with non-valid hexadecimal digits" $- parseInteger "0xfgh" 0xf- it "can parse numbers when hex digits are lowercase" $- parseInteger "0xabcdef" 0xabcdef- it "can parse numbers when hex digits are uppercase" $- parseInteger "0xABCDEF" 0xABCDEF- it "can parse numbers when hex digits are in both lowercase and uppercase" $ do- parseInteger "0xAbCdEf" 0xAbCdEf- parseInteger "0xaBcDeF" 0xaBcDeF--keySpecs :: Spec-keySpecs = describe "keyP" $ do- context "when the key is a bare key" $ do- it "can parse keys which contain ASCII letters, digits, underscores, and dashes" $ do- parseKey "key" (makeKey ["key"])- parseKey "bare_key1" (makeKey ["bare_key1"])- parseKey "bare-key2" (makeKey ["bare-key2"])- it "can parse keys which contain only digits" $- parseKey "1234" (makeKey ["1234"])- context "when the key is a quoted key" $ do- it "can parse keys that follow the exact same rules as basic strings" $ do- parseKey (dquote "127.0.0.1") (makeKey [dquote "127.0.0.1"])- parseKey (dquote "character encoding") (makeKey [dquote "character encoding"])- parseKey (dquote "ʎǝʞ") (makeKey [dquote "ʎǝʞ"])- it "can parse keys that follow the exact same rules as literal strings" $ do- parseKey (squote "key2") (makeKey [squote "key2"])- parseKey (squote "quoted \"value\"") (makeKey [squote "quoted \"value\""])- context "when the key is a dotted key" $ do- it "can parse a sequence of bare or quoted keys joined with a dot" $ do- parseKey "name" (makeKey ["name"])- parseKey "physical.color" (makeKey ["physical", "color"])- parseKey "physical.shape" (makeKey ["physical", "shape"])- parseKey "site.\"google.com\"" (makeKey ["site", dquote "google.com"])- -- it "ignores whitespaces around dot-separated parts" $ do- -- parseKey "a . b . c. d" (makeKey ["a", "b", "c", "d"])--textSpecs :: Spec-textSpecs = describe "textP" $ do- context "when the string is a basic string" $ do- it "can parse strings surrounded by double quotes" $ do- parseText (dquote "xyz") "xyz"- parseText (dquote "") ""- textFailOn "\"xyz"- textFailOn "xyz\""- textFailOn "xyz"- it "can parse escaped quotation marks, backslashes, and control characters" $ do- parseText (dquote "backspace: \\b") "backspace: \b"- parseText (dquote "tab: \\t") "tab: \t"- parseText (dquote "linefeed: \\n") "linefeed: \n"- parseText (dquote "form feed: \\f") "form feed: \f"- parseText (dquote "carriage return: \\r") "carriage return: \r"- parseText (dquote "quote: \\\"") "quote: \""- parseText (dquote "backslash: \\\\") "backslash: \\"- parseText (dquote "a\\uD7FFxy\\U0010FFFF\\uE000") "a\55295xy\1114111\57344"- it "fails if the string has an unescaped backslash, or control character" $ do- textFailOn (dquote "new \n line")- textFailOn (dquote "back \\ slash")- it "fails if the string has an escape sequence that is not listed in the TOML specification" $- textFailOn (dquote "xy\\z \\abc")- it "fails if the string is not on a single line" $ do- textFailOn (dquote "\nabc")- textFailOn (dquote "ab\r\nc")- textFailOn (dquote "abc\n")- it "fails if escape codes are not valid Unicode scalar values" $ do- textFailOn (dquote "\\u1")- textFailOn (dquote "\\uxyzw")- textFailOn (dquote "\\U0000")- textFailOn (dquote "\\uD8FF")- textFailOn (dquote "\\U001FFFFF")- context "when the string is a multi-line basic string" $ do-- it "can parse multi-line strings surrounded by three double quotes" $- parseText (dquote3 "Roses are red\nViolets are blue")- "Roses are red\nViolets are blue"- it "can parse single-line strings surrounded by three double quotes" $- parseText (dquote3 "Roses are red Violets are blue")- "Roses are red Violets are blue"- it "can parse all of the escape sequences that are valid for basic strings" $ do- parseText (dquote3 "backspace: \\b") "backspace: \b"- parseText (dquote3 "tab: \\t") "tab: \t"- parseText (dquote3 "linefeed: \\n") "linefeed: \n"- parseText (dquote3 "form feed: \\f") "form feed: \f"- parseText (dquote3 "carriage return: \\r") "carriage return: \r"- parseText (dquote3 "quote: \\\"") "quote: \""- parseText (dquote3 "backslash: \\\\") "backslash: \\"- parseText (dquote3 "a\\uD7FFxy\\U0010FFFF\\uE000") "a\55295xy\1114111\57344"- it "does not ignore whitespaces or newlines" $- parseText (dquote3 "\nabc \n xyz") "abc \n xyz"- it "ignores a newline only if it immediately follows the opening delimiter" $- parseText (dquote3 "\nThe quick brown") "The quick brown"- it "ignores whitespaces and newlines after line ending backslash" $- parseText (dquote3 "The quick brown \\\n\n fox jumps over") "The quick brown fox jumps over"- it "fails if the string has an unescaped backslash, or control character" $ do- textFailOn (dquote3 "backslash \\ .")- textFailOn (dquote3 "backspace \b ..")- textFailOn (dquote3 "tab \t ..")- context "when the string is a literal string" $ do- it "can parse strings surrounded by single quotes" $ do- parseText (squote "C:\\Users\\nodejs\\templates")- "C:\\Users\\nodejs\\templates"- parseText (squote "\\\\ServerX\\admin$\\system32\\")- "\\\\ServerX\\admin$\\system32\\"- parseText (squote "Tom \"Dubs\" Preston-Werner")- "Tom \"Dubs\" Preston-Werner"- parseText (squote "<\\i\\c*\\s*>") "<\\i\\c*\\s*>"- parseText (squote "a \t tab") "a \t tab"- it "fails if the string is not on a single line" $ do- textFailOn (squote "\nabc")- textFailOn (squote "ab\r\nc")- textFailOn (squote "abc\n")- context "when the string is a multi-line literal string" $ do- it "can parse multi-line strings surrounded by three single quotes" $- parseText (squote3 "first line \nsecond.\n 3\n")- "first line \nsecond.\n 3\n"- it "can parse single-line strings surrounded by three single quotes" $- parseText (squote3 "I [dw]on't need \\d{2} apples")- "I [dw]on't need \\d{2} apples"- it "ignores a newline immediately following the opening delimiter" $- parseText (squote3 "\na newline \nsecond.\n 3\n")- "a newline \nsecond.\n 3\n"- it "fails if the string has an unescaped control character other than tab" $ do- parseText (squote3 "\t") "\t"- textFailOn (squote3 "\b")--dateSpecs :: Spec-dateSpecs = describe "dateTimeP" $ do- it "can parse a date-time with an offset" $ do- parseDateTime "1979-05-27T07:32:00Z" $ makeZoned day1 hours1 offset0- parseDateTime "1979-05-27T00:32:00+07:10" $- makeZoned day1 (TimeOfDay 0 32 0) offset710- parseDateTime "1979-05-27T00:32:00.999999-07:25" $- makeZoned day1 (TimeOfDay 0 32 0.999999) (makeOffset (-7) 25)- it "can parse a date-time with an offset when the T delimiter is replaced with a space" $- parseDateTime "1979-05-27 07:32:00Z" $ makeZoned day1 hours1 offset0- it "can parse a date-time without an offset" $ do- parseDateTime "1979-05-27T17:32:00"- (ULocal $ LocalTime day1 (TimeOfDay 17 32 0))- parseDateTime "1979-05-27T00:32:00.999999"- (ULocal $ LocalTime day1 (TimeOfDay 0 32 0.999999))- it "can parse a local date"- $ parseDateTime "1979-05-27" (UDay day1)- it "can parse a local time" $ do- parseDateTime "07:32:00" (UHours hours1)- parseDateTime "00:32:00.999999" (UHours $ TimeOfDay 0 32 0.999999)- it "truncates the additional precision after picoseconds in the fractional seconds" $- parseDateTime "00:32:00.99999999999199" (UHours $ TimeOfDay 0 32 0.999999999991)- it "fails if the date is not valid" $ do- dateTimeFailOn "1920-15-12"- dateTimeFailOn "1920-12-40"- it "fails if the date does not have the form: 'yyyy-mm-dd'" $ do- dateTimeFailOn "1920-01-1"- dateTimeFailOn "1920-1-01"- dateTimeFailOn "920-01-01"- dateTimeFailOn "1920/10/01"- it "fails if the time is not valid" $ do- dateTimeFailOn "25:10:10"- dateTimeFailOn "10:70:10"- dateTimeFailOn "10:10:70"- it "fails if the time does not have the form: 'hh:mm:ss'" $ do- dateTimeFailOn "1:12:12"- dateTimeFailOn "12:1:12"- dateTimeFailOn "12:12:1"- dateTimeFailOn "12-12-12"- it "fails if the offset does not have any of the forms: 'Z', '+hh:mm', '-hh:mm'" $ do- parseDateTime "1979-05-27T00:32:00X"- (ULocal $ LocalTime day1 (TimeOfDay 0 32 0))- parseDateTime "1979-05-27T00:32:00+07:1"- (ULocal $ LocalTime day1 (TimeOfDay 0 32 0))- parseDateTime "1979-05-27T00:32:00+7:01"- (ULocal $ LocalTime day1 (TimeOfDay 0 32 0))- parseDateTime "1979-05-27T00:32:0007:00"- (ULocal $ LocalTime day1 (TimeOfDay 0 32 0))--tomlSpecs :: Spec-tomlSpecs = do- describe "Key/values" $ do- it "can parse key/value pairs" $ do- parseToml "x='abcdef'" (tomlFromKeyVal [(makeKey ["x"], AnyValue (Text "abcdef"))])- parseToml "x=1" (tomlFromKeyVal [(makeKey ["x"], AnyValue (Integer 1))])- parseToml "x=5.2" (tomlFromKeyVal [(makeKey ["x"], AnyValue (Double 5.2))])- parseToml "x=true" (tomlFromKeyVal [(makeKey ["x"], AnyValue (Bool True))])- parseToml "x=[1, 2, 3]" (tomlFromKeyVal [(makeKey ["x"] , AnyValue (Array [Integer 1, Integer 2, Integer 3]))])- parseToml "x = 1920-12-10" (tomlFromKeyVal [(makeKey ["x"], AnyValue (Day day2))])- it "ignores white spaces around key names and values" $ do- let toml = tomlFromKeyVal [(makeKey ["x"], AnyValue (Integer 1))]- parseToml "x=1 " toml- parseToml "x= 1" toml- parseToml "x =1" toml- parseToml "x\t= 1 " toml- parseToml "\"x\" = 1" (tomlFromKeyVal [(makeKey [dquote "x"], AnyValue (Integer 1))])- --xit "fails if the key, equals sign, and value are not on the same line" $ do- -- keyValFailOn "x\n=\n1"- -- keyValFailOn "x=\n1"- -- keyValFailOn "\"x\"\n=\n1"- it "works if the value is broken over multiple lines" $- parseToml "x=[1, \n2\n]" (tomlFromKeyVal [(makeKey ["x"], AnyValue (Array [Integer 1, Integer 2]))])- it "fails if the value is not specified" $- tomlFailOn "x="-- describe "tables" $ do- it "can parse a TOML table" $- parseToml "[table] \n key1 = \"some string\"\nkey2 = 123"- $ tomlFromTable [(makeKey ["table"], tomlFromKeyVal [str, int])]- it "can parse an empty TOML table" $- parseToml "[table]" (tomlFromTable [(makeKey ["table"], mempty)])- it "can parse a table with subarrays" $ do- let t = tomlFromTable [(makeKey ["table"], tomlFromArray [(makeKey ["array"], strT :| [intT])])]- parseToml "[table] \n [[table.array]] \nkey1 = \"some string\"\n \- \[[table.array]] \nkey2 = 123" t- it "can parse a TOML inline table" $- parseToml "table={key1 = \"some string\", key2 = 123}"- (tomlFromTable [(makeKey ["table"], tomlFromKeyVal [str, int])])- it "can parse an empty inline TOML table" $- parseToml "table = {}" (tomlFromTable [(makeKey ["table"], mempty)])- it "can parse a table followed by an inline table" $- parseToml "[table1] \n key1 = \"some string\" \n table2 = {key2 = 123}"- (tomlFromTable [(makeKey ["table1"], tomlFromKeyVal [str])- ,(makeKey ["table2"], tomlFromKeyVal [int])])- it "can parse an empty table followed by an inline table" $- parseToml "[table1] \n table2 = {key2 = 123}"- (tomlFromTable [(makeKey ["table1"], mempty)- ,(makeKey ["table2"], tomlFromKeyVal [int])])- it "allows the name of the table to be any valid TOML key" $ do- parseToml "dog.\"tater.man\"={}"- (tomlFromTable [(makeKey ["dog", dquote "tater.man"], mempty)])- parseToml "j.\"ʞ\".'l'={}"- (tomlFromTable [(makeKey ["j", dquote "ʞ", squote "l"], mempty)])-- describe "array of tables" $ do- it "can parse an empty array" $- parseToml "[[array]]" (tomlFromArray [(makeKey ["array"], mempty :| [])])- it "can parse an array of key/values" $ do- let array = tomlFromArray [(makeKey ["array"], NE.fromList [strT, intT])]- parseToml "[[array]]\n key1 = \"some string\"\n \- \[[array]]\n key2 = 123" array- it "can parse an array of tables" $ do- let table1 = tomlFromTable [(makeKey ["table1"], strT)]- table2 = tomlFromTable [(makeKey ["table2"], intT)]- array = tomlFromArray [(makeKey ["array"], NE.fromList [table1, table2])]- parseToml "[[array]]\n[array.table1] \n key1 = \"some string\"\n \- \[[array]]\n[array.table2] \n key2 = 123" array- it "can parse an array of array" $ do- let arr = tomlFromArray [(makeKey ["subarray"], NE.fromList [strT, intT])]- array = tomlFromArray [(makeKey ["array"], arr :| [])]- parseToml "[[array]] \n [[array.subarray]] \nkey1 = \"some string\"\n \- \[[array.subarray]] \nkey2 = 123" array- it "can parse an array of arrays" $ do- let arr1 = (makeKey ["table-1"], strT :| [])- arr2 = (makeKey ["table-2"], intT :| [])- array = tomlFromArray [(makeKey ["array"], tomlFromArray [arr1, arr2] :| [])]- parseToml "[[array]]\n [[array.table-1]] \nkey1 = \"some string\"\n \- \[[array.table-2]] \nkey2 = 123" array- it "can parse very large arrays" $ do- let array = tomlFromArray [(makeKey ["array"], NE.fromList $ replicate 1000 mempty)]- parseToml (mconcat $ replicate 1000 "[[array]]\n") array- it "can parse an inline array of tables" $ do- let array = tomlFromArray [(makeKey ["table"], NE.fromList [strT, intT])]- parseToml "table = [{key1 = \"some string\"}, {key2 = 123}]" array-- describe "TOML" $ do- it "can parse TOML files" $- parseToml tomlStr1 toml1- it "can parse mix of tables and arrays" $- parseToml tomlStr2 toml2- where- tomlStr1, tomlStr2 :: Text- tomlStr1 = T.unlines- [ " # This is a TOML document.\n\n"- , "title = \"TOML Example\" # Comment \n\n"- , "[owner]\n"- , " name = \"Tom Preston-Werner\" "- , " enabled = true # First class dates"- ]- tomlStr2 = T.unlines- [ "[[array1]]\n key1 = \"some string\" \n"- , ""- , "[table1] \n key2 = 123 \n"- , "[[array2]]\n key3 = 3.14 \n"- , " [table2] \n key4 = true"- ]-- toml1, toml2 :: TOML- toml1 = mkToml $ do- "title" =: "TOML Example"- table "owner" $ do- "name" =: "Tom Preston-Werner"- "enabled" =: Bool True-- toml2 = mkToml $ do- tableArray "array1" $- "key1" =: "some string" :| []- table "table1" $ "key2" =: 123- tableArray "array2" $- "key3" =: Double 3.14 :| []- table "table2" $ "key4" =: Bool True--------------------------------------------------------------------------------- Utilities-------------------------------------------------------------------------------parseX :: (ShowErrorComponent e, Stream s, Show a, Eq a)- => Parsec e s a -> s -> a -> Expectation-parseX p given expected = parse p "" given `shouldParse` expected--failOn :: Show a => Parsec e s a -> s -> Expectation-failOn p given = parse p "" `shouldFailOn` given--parseArray :: Text -> [UValue] -> Expectation-parseArray = parseX arrayP-parseBool :: Text -> Bool -> Expectation-parseBool = parseX boolP-parseDateTime :: Text -> UValue -> Expectation-parseDateTime = parseX dateTimeP-parseDouble :: Text -> Double -> Expectation-parseDouble = parseX doubleP-parseInteger :: Text -> Integer -> Expectation-parseInteger = parseX integerP-parseKey :: Text -> Key -> Expectation-parseKey = parseX keyP-parseText :: Text -> Text -> Expectation-parseText = parseX textP--parseToml :: Text -> TOML -> Expectation-parseToml = parseX tomlP--arrayFailOn, boolFailOn, dateTimeFailOn, doubleFailOn, integerFailOn, textFailOn, tomlFailOn :: Text -> Expectation-arrayFailOn = failOn arrayP-boolFailOn = failOn boolP-dateTimeFailOn = failOn dateTimeP-doubleFailOn = failOn doubleP-integerFailOn = failOn integerP-textFailOn = failOn textP-tomlFailOn = failOn tomlP---- UValue Util--makeZoned :: Day -> TimeOfDay -> TimeZone -> UValue-makeZoned d h offset = UZoned $ ZonedTime (LocalTime d h) offset--makeOffset :: Int -> Int -> TimeZone-makeOffset hours mins = minutesToTimeZone (hours * 60 + mins * signum hours)--makeKey :: [Text] -> Key-makeKey = Key . NE.fromList . map Piece--tomlFromKeyVal :: [(Key, AnyValue)] -> TOML-tomlFromKeyVal kv = TOML (HashMap.fromList kv) mempty mempty--tomlFromTable :: [(Key, TOML)] -> TOML-tomlFromTable t = TOML mempty (fromList t) mempty--tomlFromArray :: [(Key, NonEmpty TOML)] -> TOML-tomlFromArray = TOML mempty mempty . HashMap.fromList---- Surround given text with quotes.-quoteWith :: Text -> Text -> Text-quoteWith q t = q <> t <> q-squote, dquote, squote3, dquote3 :: Text -> Text-squote = quoteWith "'"-dquote = quoteWith "\""-squote3 = quoteWith "'''"-dquote3 = quoteWith "\"\"\""---- Test Data---- Key-Value pairs-str, int :: (Key, AnyValue)-str = (makeKey ["key1"], AnyValue (Text "some string"))-int = (makeKey ["key2"], AnyValue (Integer 123))--strT, intT :: TOML-strT = tomlFromKeyVal [str]-intT = tomlFromKeyVal [int]--int1, int2, int3, int4 :: UValue-int1 = UInteger 1-int2 = UInteger 2-int3 = UInteger 3-int4 = UInteger 4--offset0, offset710 :: TimeZone-offset0 = makeOffset 0 0-offset710 = makeOffset 7 10--day1, day2 :: Day-day1 = fromGregorian 1979 5 27 -- 1979-05-27-day2 = fromGregorian 1920 12 10 -- 1920-12-10--hours1 :: TimeOfDay-hours1 = TimeOfDay 7 32 0 -- 07:32:00
− test/Test/Toml/PrefixTree/Property.hs
@@ -1,73 +0,0 @@-module Test.Toml.PrefixTree.Property where--import Hedgehog (forAll, tripping, (===))--import Test.Toml.Gen (PropertyTest, genKey, genPrefixMap, genVal, prop)-import Test.Toml.Property (assocLaw, identityLaw)--import Data.String (IsString (..))--import qualified Data.Text as Text-import qualified Toml.PrefixTree as Prefix-import qualified Toml.Printer as Printer--------------------------------------------------------------------------------- Key printing and parsing-------------------------------------------------------------------------------test_KeyPrinting :: PropertyTest-test_KeyPrinting = prop "Key printing: fromString . prettyKey == id" $ do- key <- forAll genKey- tripping key Printer.prettyKey (Just . fromString . Text.unpack)--------------------------------------------------------------------------------- InsertLookup-------------------------------------------------------------------------------test_PrefixTreeInsertLookup :: PropertyTest-test_PrefixTreeInsertLookup = prop "lookup k (insert k v m) == Just v" $ do- t <- forAll genPrefixMap- key <- forAll genKey- val <- forAll genVal-- Prefix.lookup key (Prefix.insert key val t) === Just val-- -- DEBUG: ensures that trees of depth at least 5 are generated- -- assert $ depth prefMap < 5--------------------------------------------------------------------------------- InsertInsert-------------------------------------------------------------------------------test_PrefixTreeInsertInsert :: PropertyTest-test_PrefixTreeInsertInsert = prop "insert x a . insert x b == insert x a" $ do- t <- forAll genPrefixMap- x <- forAll genKey- a <- forAll genVal- b <- forAll genVal-- Prefix.lookup x (Prefix.insert x a $ Prefix.insert x b t) === Just a--------------------------------------------------------------------------------- DEBUG--------------------------------------------------------------------------------- useful functions to test generators--- uncomment when you need them---- depth :: PrefixMap a -> Int--- depth = HashMap.foldl' (\acc t -> max acc (depthT t)) 0------ depthT :: PrefixTree a -> Int--- depthT (Leaf _ _) = 1--- depthT (Branch _ _ prefMap) = 1 + depth prefMap--------------------------------------------------------------------------------- Laws-------------------------------------------------------------------------------test_PrefixTreeAssocLaw :: PropertyTest-test_PrefixTreeAssocLaw = assocLaw genPrefixMap--test_PrefixTreeIdentityLaw :: PropertyTest-test_PrefixTreeIdentityLaw = identityLaw genPrefixMap
− test/Test/Toml/PrefixTree/Unit.hs
@@ -1,43 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE TypeApplications #-}--module Test.Toml.PrefixTree.Unit where--import Test.Tasty.Hspec (Spec, describe, it, shouldBe)--import Toml.PrefixTree (pattern (:||))--import qualified Toml.PrefixTree as Prefix--spec_PrefixTree :: Spec-spec_PrefixTree = do- -- some test keys- let a = "a" :|| []- let b = "b" :|| []- let c = "c" :|| []- let ab = "a" :|| ["b"]-- describe "Insert and lookup unit tests" $ do- it "Lookup on empty map returns Nothing" $- Prefix.lookup @Bool a mempty `shouldBe` Nothing- it "Lookup in single map returns this element" $ do- let t = Prefix.single a True- Prefix.lookup a t `shouldBe` Just True- Prefix.lookup b t `shouldBe` Nothing- it "Lookup after insert returns this element" $ do- let t = Prefix.insert a True mempty- Prefix.lookup a t `shouldBe` Just True- Prefix.lookup b t `shouldBe` Nothing- it "Lookup after multiple non-overlapping inserts" $ do- let t = Prefix.insert a True $ Prefix.insert b False mempty- Prefix.lookup a t `shouldBe` Just True- Prefix.lookup b t `shouldBe` Just False- Prefix.lookup c t `shouldBe` Nothing- it "Prefix lookup" $ do- let t = Prefix.insert ab True mempty- Prefix.lookup a t `shouldBe` Nothing- Prefix.lookup ab t `shouldBe` Just True- it "Composite key lookup" $ do- let t = Prefix.insert a True $ Prefix.insert ab False mempty- Prefix.lookup a t `shouldBe` Just True- Prefix.lookup ab t `shouldBe` Just False
− test/Test/Toml/Printer/Golden.hs
@@ -1,64 +0,0 @@--- | This module contains golden tests for @Toml.Printer@.--module Test.Toml.Printer.Golden- ( test_prettyGolden- ) where--import Data.List.NonEmpty (NonEmpty ((:|)))-import Data.Ord (comparing)-import Test.Tasty (TestTree, testGroup)-import Test.Tasty.Silver (goldenVsAction)--import Toml (TOML, Value (..))-import Toml.Edsl (empty, mkToml, table, tableArray, (=:))-import Toml.PrefixTree (Key (..), (<|))-import Toml.Printer (PrintOptions (..), defaultOptions, prettyOptions)--example :: TOML-example = mkToml $ do- "b" =: "bb"- "a" =: "a"- "d" =: "ddd"- "c" =: "cccc"- table ("qux" <| "doo") $ do- "spam" =: "!"- "egg" =: "?"- table "foo" empty- table "doo" empty- table "baz" empty- tableArray "deepest" $- "ping" =: "pong"- :| [empty]- tableArray "deeper" $- "green" =: Bool True- :| [table "blue" ("red" =: Integer 255)]--noFormatting :: PrintOptions-noFormatting = PrintOptions- { printOptionsSorting = Nothing- , printOptionsIndent = 0- }---- | Decorate keys as tuples so spam comes before egg-spamEggDecorate :: Key -> (Int, Key)-spamEggDecorate k- | k == "spam" = (0, "spam")- | k == "egg" = (1, "egg")- | otherwise = (2, k)--spamEgg :: Key -> Key -> Ordering-spamEgg = comparing spamEggDecorate--test_prettyGolden :: TestTree-test_prettyGolden =- testGroup "Toml.Printer"- [ test "pretty_default" defaultOptions- , test "pretty_sorted_only" noFormatting { printOptionsSorting = Just compare }- , test "pretty_indented_only" noFormatting { printOptionsIndent = 4 }- , test "pretty_unformatted" noFormatting- , test "pretty_custom_sorted" noFormatting { printOptionsSorting = Just spamEgg }- ]- where- test name options =- goldenVsAction name ("test/golden/" ++ name ++ ".golden")- (pure $ prettyOptions options example) id
test/Test/Toml/Property.hs view
@@ -1,39 +1,55 @@ module Test.Toml.Property- ( assocLaw- , identityLaw+ ( assocSemigroup+ , rightIdentityMonoid+ , leftIdentityMonoid ) where -import Data.Semigroup (Semigroup ((<>))) import Hedgehog (Gen, forAll, (===))+import Test.Hspec (Arg, Expectation, SpecWith, it)+import Test.Hspec.Hedgehog (hedgehog) -import Test.Toml.Gen (PropertyTest, prop) {- | The semigroup associativity axiom: @ x <> (y <> z) ≡ (x <> y) <> z @- -}-assocLaw :: (Eq a, Show a, Semigroup a) => Gen a -> PropertyTest-assocLaw gen = prop "Semigroup associativity law" $ do+assocSemigroup+ :: (Eq a, Show a, Semigroup a)+ => Gen a+ -> SpecWith (Arg Expectation)+assocSemigroup gen = it "Semigroup associativity: x <> (y <> z) ≡ (x <> y) <> z" $ hedgehog $ do x <- forAll gen y <- forAll gen z <- forAll gen (x <> (y <> z)) === ((x <> y) <> z) -{- | Identity law for Monoid+{- | Right Identity law for Monoid @-mempty <> x = x-x <> mempty = x+x <> mempty ≡ x @- -}-identityLaw :: (Eq a, Show a, Semigroup a, Monoid a) => Gen a -> PropertyTest-identityLaw gen = prop "Monoid identity laws" $ do+rightIdentityMonoid+ :: (Eq a, Show a, Monoid a)+ => Gen a+ -> SpecWith (Arg Expectation)+rightIdentityMonoid gen = it "Monoid Right Identity: x <> mempty ≡ x" $ hedgehog $ do x <- forAll gen- x <> mempty === x++{- | Left Identity law for Monoid++@+mempty <> x ≡ x+@+-}+leftIdentityMonoid+ :: (Eq a, Show a, Monoid a)+ => Gen a+ -> SpecWith (Arg Expectation)+leftIdentityMonoid gen = it "Monoid Right Identity: mempty <> x ≡ x" $ hedgehog $ do+ x <- forAll gen mempty <> x === x
− test/Test/Toml/TOML/Property.hs
@@ -1,15 +0,0 @@-module Test.Toml.TOML.Property where--import Test.Toml.Gen (PropertyTest, genToml)-import Test.Toml.Property (assocLaw, identityLaw)---------------------------------------------------------------------------------- Laws-------------------------------------------------------------------------------test_TomlAssocLaw :: PropertyTest-test_TomlAssocLaw = assocLaw genToml--test_TomlIdentityLaw :: PropertyTest-test_TomlIdentityLaw = identityLaw genToml
+ test/Test/Toml/Type.hs view
@@ -0,0 +1,18 @@+module Test.Toml.Type+ ( typeSpec+ ) where++import Test.Hspec (Spec, describe, parallel)++import Test.Toml.Type.Key (keySpec)+import Test.Toml.Type.PrefixTree (prefixTreeSpec)+import Test.Toml.Type.Printer (printerSpec)+import Test.Toml.Type.TOML (tomlSpec)+++typeSpec :: Spec+typeSpec = parallel $ describe "Toml.Type tests" $ do+ keySpec+ prefixTreeSpec+ printerSpec+ tomlSpec
+ test/Test/Toml/Type/Key.hs view
@@ -0,0 +1,47 @@+module Test.Toml.Type.Key+ ( keySpec+ ) where++import Hedgehog (forAll, tripping)+import Test.Hspec (Arg, Expectation, Spec, SpecWith, describe, it, shouldBe)+import Test.Hspec.Hedgehog (hedgehog)++import Test.Toml.Gen (genKey)+import Toml.Type.Key (KeysDiff (..), keysDiff)++import qualified Toml.Parser as Parser+import qualified Toml.Type.Printer as Printer+++keySpec :: Spec+keySpec = describe "TOML Key" $ do+ keyRoundtripSpec+ keysDiffSpec++keyRoundtripSpec :: SpecWith (Arg Expectation)+keyRoundtripSpec = it "Key printing: fromString . prettyKey ≡ id" $ hedgehog $ do+ key <- forAll genKey+ tripping key Printer.prettyKey Parser.parseKey++keysDiffSpec :: Spec+keysDiffSpec = describe "Key difference" $ do+ it "Equal: Simple" $+ keysDiff "key" "key" `shouldBe` Equal+ it "Equal: Complex" $+ keysDiff "foo.bar.baz" "foo.bar.baz" `shouldBe` Equal+ it "NoPrefix: Simple" $+ keysDiff "foo" "bar" `shouldBe` NoPrefix+ it "NoPrefix: Only common suffix" $+ keysDiff "foo.key" "bar.key" `shouldBe` NoPrefix+ it "FstIsPref" $+ keysDiff "key" "key.nest" `shouldBe` FstIsPref "nest"+ it "SndIsPref" $+ keysDiff "key.nest" "key" `shouldBe` SndIsPref "nest"+ it "Diff: Simple" $+ keysDiff "key.foo" "key.bar" `shouldBe` Diff "key" "foo" "bar"+ it "Diff: Two components" $+ keysDiff "key.nest.foo" "key.nest.bar" `shouldBe` Diff "key.nest" "foo" "bar"+ it "Diff: Two diff components" $+ keysDiff "key.foo.nest" "key.bar.nest" `shouldBe` Diff "key" "foo.nest" "bar.nest"+ it "Diff: Different diff length" $+ keysDiff "key.foo" "key.bar.nest" `shouldBe` Diff "key" "foo" "bar.nest"
+ test/Test/Toml/Type/PrefixTree.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE PatternSynonyms #-}++module Test.Toml.Type.PrefixTree+ ( prefixTreeSpec+ ) where++import Hedgehog (forAll, (===))+import Test.Hspec (Arg, Expectation, Spec, SpecWith, describe, it, parallel, shouldBe)+import Test.Hspec.Hedgehog (hedgehog)++import Test.Toml.Gen (genKey, genPrefixMap, genVal)+import Test.Toml.Property (assocSemigroup, leftIdentityMonoid, rightIdentityMonoid)+import Toml.Type.Key (pattern (:||))++import qualified Toml.Type.PrefixTree as Prefix+++prefixTreeSpec :: Spec+prefixTreeSpec = describe "PrefixTree unit and property tests" $ do+ prefixTreeUnitSpec+ prefixTreePropertySpec++prefixTreeUnitSpec :: Spec+prefixTreeUnitSpec = describe "Unit tests for basic cases" $ do+ -- some test keys+ let a = "a" :|| []+ let b = "b" :|| []+ let c = "c" :|| []+ let ab = "a" :|| ["b"]++ it "Lookup on empty map returns Nothing" $+ Prefix.lookup @Bool a mempty `shouldBe` Nothing+ it "Lookup in single map returns this element" $ do+ let t = Prefix.single a True+ Prefix.lookup a t `shouldBe` Just True+ Prefix.lookup b t `shouldBe` Nothing+ it "Lookup after insert returns this element" $ do+ let t = Prefix.insert a True mempty+ Prefix.lookup a t `shouldBe` Just True+ Prefix.lookup b t `shouldBe` Nothing+ it "Lookup after multiple non-overlapping inserts" $ do+ let t = Prefix.insert a True $ Prefix.insert b False mempty+ Prefix.lookup a t `shouldBe` Just True+ Prefix.lookup b t `shouldBe` Just False+ Prefix.lookup c t `shouldBe` Nothing+ it "Prefix lookup" $ do+ let t = Prefix.insert ab True mempty+ Prefix.lookup a t `shouldBe` Nothing+ Prefix.lookup ab t `shouldBe` Just True+ it "Composite key lookup" $ do+ let t = Prefix.insert a True $ Prefix.insert ab False mempty+ Prefix.lookup a t `shouldBe` Just True+ Prefix.lookup ab t `shouldBe` Just False++prefixTreePropertySpec :: Spec+prefixTreePropertySpec = parallel $ describe "Laws and behaviour property tests" $ do+ insertLookupSpec+ insertInsertSpec+ assocSemigroup genPrefixMap+ leftIdentityMonoid genPrefixMap+ rightIdentityMonoid genPrefixMap++insertLookupSpec :: SpecWith (Arg Expectation)+insertLookupSpec = it "lookup k (insert k v m) ≡ Just v" $ hedgehog $ do+ t <- forAll genPrefixMap+ key <- forAll genKey+ val <- forAll genVal++ Prefix.lookup key (Prefix.insert key val t) === Just val++ -- DEBUG: ensures that trees of depth at least 5 are generated+ -- assert $ depth prefMap < 5++insertInsertSpec :: SpecWith (Arg Expectation)+insertInsertSpec = it "insert x a . insert x b ≡ insert x a" $ hedgehog $ do+ t <- forAll genPrefixMap+ x <- forAll genKey+ a <- forAll genVal+ b <- forAll genVal++ Prefix.lookup x (Prefix.insert x a $ Prefix.insert x b t) === Just a++----------------------------------------------------------------------------+-- DEBUG+----------------------------------------------------------------------------++-- useful functions to test generators+-- uncomment when you need them++-- depth :: PrefixMap a -> Int+-- depth = HashMap.foldl' (\acc t -> max acc (depthT t)) 0+--+-- depthT :: PrefixTree a -> Int+-- depthT (Leaf _ _) = 1+-- depthT (Branch _ _ prefMap) = 1 + depth prefMap
+ test/Test/Toml/Type/Printer.hs view
@@ -0,0 +1,69 @@+-- | This module contains golden tests for @Toml.Printer@.++module Test.Toml.Type.Printer+ ( printerSpec+ ) where++import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.Ord (comparing)+import Test.Hspec (Arg, Expectation, Spec, SpecWith, describe, it, shouldReturn)++import Toml.Type.Edsl (empty, mkToml, table, tableArray, (=:))+import Toml.Type.Key (Key (..), (<|))+import Toml.Type.Printer (PrintOptions (..), Lines(..), defaultOptions, prettyOptions)+import Toml.Type.TOML (TOML)+import Toml.Type.Value (Value (..))++import qualified Data.Text.IO as T+++printerSpec :: Spec+printerSpec = describe "Toml.Type.Printer: Golden tests for pretty-printing" $ do+ test "pretty_default" defaultOptions+ test "pretty_sorted_only" noFormatting { printOptionsSorting = Just compare }+ test "pretty_indented_only" noFormatting { printOptionsIndent = 4 }+ test "pretty_unformatted" noFormatting+ test "pretty_custom_sorted" noFormatting { printOptionsSorting = Just spamEgg }+ test "pretty_lines" defaultOptions { printOptionsLines = MultiLine }+ where+ test :: String -> PrintOptions -> SpecWith (Arg Expectation)+ test name options = it ("Golden " ++ name) $+ T.readFile ("test/golden/" ++ name ++ ".golden")+ `shouldReturn` prettyOptions options example++example :: TOML+example = mkToml $ do+ "b" =: "bb"+ "a" =: "a"+ "d" =: "ddd"+ "c" =: "cccc"+ table ("qux" <| "doo") $ do+ "spam" =: "!"+ "egg" =: "?"+ table "foo" empty+ table "doo" empty+ table "baz" empty+ "list" =: Array ["one", "two"]+ tableArray "deepest" $+ "ping" =: "pong"+ :| [empty]+ tableArray "deeper" $+ "green" =: Bool True+ :| [table "blue" ("red" =: Integer 255)]++noFormatting :: PrintOptions+noFormatting = PrintOptions+ { printOptionsSorting = Nothing+ , printOptionsIndent = 0+ , printOptionsLines = OneLine+ }++-- | Decorate keys as tuples so spam comes before egg+spamEggDecorate :: Key -> (Int, Key)+spamEggDecorate k+ | k == "spam" = (0, "spam")+ | k == "egg" = (1, "egg")+ | otherwise = (2, k)++spamEgg :: Key -> Key -> Ordering+spamEgg = comparing spamEggDecorate
+ test/Test/Toml/Type/TOML.hs view
@@ -0,0 +1,18 @@+{- | Property tests for @TOML@ data type.+-}++module Test.Toml.Type.TOML+ ( tomlSpec+ ) where++import Test.Hspec (Spec, describe, parallel)++import Test.Toml.Gen (genToml)+import Test.Toml.Property (assocSemigroup, leftIdentityMonoid, rightIdentityMonoid)+++tomlSpec :: Spec+tomlSpec = parallel $ describe "TOML laws" $ do+ assocSemigroup genToml+ rightIdentityMonoid genToml+ leftIdentityMonoid genToml
test/golden/pretty_custom_sorted.golden view
@@ -2,6 +2,7 @@ b = "bb" c = "cccc" d = "ddd"+list = ["one", "two"] [baz]
test/golden/pretty_default.golden view
@@ -2,6 +2,7 @@ b = "bb" c = "cccc" d = "ddd"+list = ["one", "two"] [baz]
test/golden/pretty_indented_only.golden view
@@ -1,13 +1,14 @@ a = "a"+b = "bb" c = "cccc" d = "ddd"-b = "bb"+list = ["one", "two"] +[baz]+ [doo] [foo]--[baz] [qux.doo] egg = "?"
+ test/golden/pretty_lines.golden view
@@ -0,0 +1,30 @@+a = "a"+b = "bb"+c = "cccc"+d = "ddd"+list = + [ "one"+ , "two"+ ]++[baz]++[doo]++[foo]++[qux.doo]+ egg = "?"+ spam = "!"++[[deeper]]+ green = true++[[deeper]]+ [deeper.blue]+ red = 255++[[deepest]]+ ping = "pong"++[[deepest]]
test/golden/pretty_sorted_only.golden view
@@ -2,6 +2,7 @@ b = "bb" c = "cccc" d = "ddd"+list = ["one", "two"] [baz]
test/golden/pretty_unformatted.golden view
@@ -1,13 +1,14 @@ a = "a"+b = "bb" c = "cccc" d = "ddd"-b = "bb"+list = ["one", "two"] +[baz]+ [doo] [foo]--[baz] [qux.doo] egg = "?"
tomland.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: tomland-version: 1.1.0.1+version: 1.3.3.3 synopsis: Bidirectional TOML serialization description: Implementation of bidirectional TOML serialization. Simple codecs look like this:@@ -27,36 +27,64 @@ license-file: LICENSE author: Dmitrii Kovanikov, Veronika Romashkina maintainer: Kowainik <xrom.xkov@gmail.com>-copyright: 2018-2019 Kowainik+copyright: 2018-2023 Kowainik category: TOML, Text, Configuration build-type: Simple extra-doc-files: README.md- , CHANGELOG.md+ CHANGELOG.md extra-source-files: test/golden/*.golden- , test/examples/*.toml-tested-with: GHC == 8.2.2- , GHC == 8.4.4- , GHC == 8.6.5+ test/examples/*.toml+tested-with: GHC == 8.4.4+ GHC == 8.6.5+ GHC == 8.8.4+ GHC == 8.10.7+ GHC == 9.0.2+ GHC == 9.2.7+ GHC == 9.4.4+ GHC == 9.6.3+ GHC == 9.8.1 source-repository head type: git location: https://github.com/kowainik/tomland.git +flag build-readme+ description: Build README generator.+ default: False+ manual: True++flag build-play-tomland+ description: Build play-tomland executable.+ default: False+ manual: True+ common common-options- build-depends: base >= 4.10 && < 4.13+ build-depends: base >= 4.11 && < 4.21 ghc-options: -Wall- -Wincomplete-uni-patterns- -Wincomplete-record-updates -Wcompat -Widentities+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates -Wredundant-constraints- -Wpartial-fields -fhide-source-paths -freverse-errors+ if impl(ghc >= 8.4)+ ghc-options: -Wmissing-export-lists+ -Wpartial-fields+ if impl(ghc >= 8.8.1)+ ghc-options: -Wmissing-deriving-strategies+ -Werror=missing-deriving-strategies+ if impl(ghc >= 8.10)+ ghc-options: -Wunused-packages+ if impl(ghc >= 9.2)+ ghc-options:+ -Wredundant-bang-patterns default-language: Haskell2010 default-extensions: DeriveGeneric+ DerivingStrategies+ GeneralizedNewtypeDeriving InstanceSigs LambdaCase OverloadedStrings@@ -69,51 +97,77 @@ hs-source-dirs: src exposed-modules: Toml- Toml.Bi- Toml.Bi.Code- Toml.Bi.Combinators- Toml.Bi.Monad- Toml.Bi.Map- Toml.Edsl- Toml.Generic+ Toml.Codec+ Toml.Codec.BiMap+ Toml.Codec.BiMap.Conversion+ Toml.Codec.Code+ Toml.Codec.Combinator+ Toml.Codec.Combinator.Common+ Toml.Codec.Combinator.Custom+ Toml.Codec.Combinator.List+ Toml.Codec.Combinator.Map+ Toml.Codec.Combinator.Monoid+ Toml.Codec.Combinator.Primitive+ Toml.Codec.Combinator.Set+ Toml.Codec.Combinator.Table+ Toml.Codec.Combinator.Time+ Toml.Codec.Combinator.Tuple+ Toml.Codec.Di+ Toml.Codec.Error+ Toml.Codec.Generic+ Toml.Codec.Types Toml.Parser Toml.Parser.Core+ Toml.Parser.Item+ Toml.Parser.Key Toml.Parser.String+ Toml.Parser.Validate Toml.Parser.Value- Toml.Parser.TOML- Toml.PrefixTree- Toml.Printer Toml.Type Toml.Type.AnyValue+ Toml.Type.Edsl+ Toml.Type.Key+ Toml.Type.PrefixTree+ Toml.Type.Printer Toml.Type.TOML Toml.Type.UValue Toml.Type.Value - build-depends: bytestring ^>= 0.10- , containers >= 0.5.7 && < 0.7- , deepseq ^>= 1.4- , hashable ^>= 1.2- , megaparsec ^>= 7.0.5- , mtl ^>= 2.2- , parser-combinators ^>= 1.1.0- , text ^>= 1.2- , time >= 1.8 && < 1.10- , transformers ^>= 0.5+ build-depends: bytestring >= 0.10 && < 0.13+ , containers >= 0.5.7 && < 0.8+ , deepseq >= 1.4 && < 1.6+ , hashable >= 1.3.1.0 && < 1.5+ , megaparsec >= 7.0.5 && < 9.7+ , mtl >= 2.2 && < 2.4+ , parser-combinators >= 1.1.0 && < 1.4+ , text >= 1.2 && < 2.2+ , time >= 1.8 && < 1.15 , unordered-containers ^>= 0.2.7+ , validation-selective >= 0.1.0 && < 0.3 executable readme import: common-options+ -- doesn't work on windows for unknown reasons+ if !flag(build-readme) || os(windows)+ buildable: False main-is: README.lhs- build-depends: text- , tomland+ build-depends: tomland+ , text+ , time build-tool-depends: markdown-unlit:markdown-unlit ghc-options: -pgmL markdown-unlit executable play-tomland import: common-options- main-is: Playground.hs+ -- We are using DerivingVia that works only with > 8.6+ if !flag(build-play-tomland) || impl(ghc < 8.6)+ buildable: False+ main-is: Main.hs build-depends: tomland+ , bytestring+ , containers+ , hashable , text , time , unordered-containers@@ -127,29 +181,58 @@ hs-source-dirs: test main-is: Spec.hs - other-modules: Test.Toml.BiMap.Property- Test.Toml.BiCode.Property+ other-modules: Test.Toml.Codec+ Test.Toml.Codec.BiMap+ Test.Toml.Codec.BiMap.Conversion+ Test.Toml.Codec.Code+ Test.Toml.Codec.Combinator+ Test.Toml.Codec.Combinator.Common+ Test.Toml.Codec.Combinator.Custom+ Test.Toml.Codec.Combinator.List+ Test.Toml.Codec.Combinator.Map+ Test.Toml.Codec.Combinator.Monoid+ Test.Toml.Codec.Combinator.Primitive+ Test.Toml.Codec.Combinator.Set+ Test.Toml.Codec.Combinator.Table+ Test.Toml.Codec.Combinator.Time+ Test.Toml.Codec.Combinator.Tuple+ Test.Toml.Codec.Di+ Test.Toml.Codec.Generic+ Test.Toml.Codec.SmallType++ Test.Toml.Parser+ Test.Toml.Parser.Examples+ Test.Toml.Parser.Property+ Test.Toml.Parser.Validate+ -- unit tests for parsing different parts of TOML ast+ Test.Toml.Parser.Array+ Test.Toml.Parser.Bool+ Test.Toml.Parser.Common+ Test.Toml.Parser.Date+ Test.Toml.Parser.Double+ Test.Toml.Parser.Integer+ Test.Toml.Parser.Key+ Test.Toml.Parser.Text+ Test.Toml.Parser.Toml++ Test.Toml.Type+ Test.Toml.Type.Key+ Test.Toml.Type.PrefixTree+ Test.Toml.Type.Printer+ Test.Toml.Type.TOML++ -- helpers Test.Toml.Gen Test.Toml.Property- Test.Toml.Parsing.Property- Test.Toml.Parsing.Unit- Test.Toml.Parsing.Examples- Test.Toml.PrefixTree.Property- Test.Toml.PrefixTree.Unit- Test.Toml.Printer.Golden- Test.Toml.TOML.Property - build-tool-depends: tasty-discover:tasty-discover ^>= 4.2.1- build-depends: bytestring ^>= 0.10- , containers >= 0.5.7 && < 0.7+ build-depends: bytestring+ , containers >= 0.5.7 && < 0.8 , hashable- , hedgehog ^>= 1.0- , hspec-megaparsec ^>= 2.0.0+ , hedgehog >= 1.0.1 && < 1.5+ , hspec >= 2.7.1 && < 2.12+ , hspec-hedgehog >= 0.0.1.1 && < 0.2+ , hspec-megaparsec >= 2.0.0 && < 2.3.0 , megaparsec- , tasty ^>= 1.2- , tasty-hedgehog ^>= 1.0.0.0- , tasty-hspec ^>= 1.1.5.1- , tasty-silver ^>= 3.1.11 , directory ^>= 1.3 , text , time@@ -157,31 +240,3 @@ , unordered-containers ghc-options: -threaded -rtsopts -with-rtsopts=-N--benchmark tomland-benchmark- import: common-options- type: exitcode-stdio-1.0- main-is: Main.hs- hs-source-dirs: benchmark-- other-modules: Benchmark.Type- Benchmark.Htoml- Benchmark.HtomlMegaparsec- Benchmark.Tomland- Benchmark.TomlParser-- ghc-options: -threaded- -rtsopts- -with-rtsopts=-N- -O2-- build-depends: aeson- , deepseq ^>= 1.4- , gauge ^>= 0.2.4- , htoml ^>= 1.0.0.3- , htoml-megaparsec ^>= 2.1.0.3- , parsec- , text- , time- , toml-parser ^>= 0.1.0.0- , tomland