diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,106 @@ tomland uses [PVP Versioning][1]. The changelog is available [on GitHub][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): diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -1,8 +1,8 @@ # tomland ![palm](https://user-images.githubusercontent.com/4276606/51088259-7a777000-176e-11e9-9d76-6be4023c0ac3.png) + [![GitHub CI](https://github.com/kowainik/tomland/workflows/CI/badge.svg)](https://github.com/kowainik/tomland/actions) -[![Travis CI](https://img.shields.io/travis/kowainik/tomland.svg?logo=travis)](https://travis-ci.org/kowainik/tomland) [![AppVeyor CI](https://ci.appveyor.com/api/projects/status/github/kowainik/tomland?branch=master&svg=true)](https://ci.appveyor.com/project/kowainik/tomland) [![Hackage](https://img.shields.io/hackage/v/tomland.svg?logo=haskell)](https://hackage.haskell.org/package/tomland) [![Stackage LTS](http://stackage.org/package/tomland/badge/lts)](http://stackage.org/lts/package/tomland) @@ -12,19 +12,28 @@ > “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 @@ -39,15 +48,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 @@ -57,10 +66,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 @@ -76,25 +115,29 @@ } data User - = Admin !Integer -- id of admin - | Client !Text -- name of the client - deriving stock (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. If you have sets of custom data types, use `Toml.set` or `Toml.HashSet`. Such @@ -121,41 +164,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](https://github.com/kowainik/toml-benchmarks) 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` | @@ -163,21 +214,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/). diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,8 +1,8 @@ # tomland ![palm](https://user-images.githubusercontent.com/4276606/51088259-7a777000-176e-11e9-9d76-6be4023c0ac3.png) + [![GitHub CI](https://github.com/kowainik/tomland/workflows/CI/badge.svg)](https://github.com/kowainik/tomland/actions) -[![Travis CI](https://img.shields.io/travis/kowainik/tomland.svg?logo=travis)](https://travis-ci.org/kowainik/tomland) [![AppVeyor CI](https://ci.appveyor.com/api/projects/status/github/kowainik/tomland?branch=master&svg=true)](https://ci.appveyor.com/project/kowainik/tomland) [![Hackage](https://img.shields.io/hackage/v/tomland.svg?logo=haskell)](https://hackage.haskell.org/package/tomland) [![Stackage LTS](http://stackage.org/package/tomland/badge/lts)](http://stackage.org/lts/package/tomland) @@ -12,19 +12,28 @@ > “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 @@ -39,15 +48,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 @@ -57,10 +66,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 @@ -76,25 +115,29 @@ } data User - = Admin !Integer -- id of admin - | Client !Text -- name of the client - deriving stock (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. If you have sets of custom data types, use `Toml.set` or `Toml.HashSet`. Such @@ -121,41 +164,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](https://github.com/kowainik/toml-benchmarks) 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` | @@ -163,21 +214,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/). diff --git a/examples/Main.hs b/examples/Main.hs --- a/examples/Main.hs +++ b/examples/Main.hs @@ -1,25 +1,34 @@ {-# 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.Hashable (Hashable) 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 (fromGregorian) import GHC.Generics (Generic) -import Toml (ParseException (..), TomlCodec, pretty, (.=), ()) -import Toml.Edsl (mkToml, table, (=:)) +import Toml (TomlCodec, TomlParseError (..), pretty, (.=), ()) +import Toml.Codec.Generic (ByteStringAsBytes (..), HasCodec (..), TomlTable (..), + 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 @@ -44,7 +53,7 @@ = Light | Dark | HighContrast - deriving stock (Show, Enum, Bounded) + deriving stock (Show, Read, Enum, Bounded) data UserStatus = Registered Text Text @@ -59,33 +68,71 @@ matchAnonymous _ = Nothing userPassCodec :: TomlCodec (Text, Text) -userPassCodec = (,) - <$> Toml.text "username" .= fst - <*> Toml.text "password" .= snd +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 + 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) } @@ -96,19 +143,32 @@ <*> 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.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 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" @@ -122,6 +182,24 @@ 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 (TomlTable 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 ===" @@ -130,14 +208,20 @@ TIO.putStrLn "=== Trying to print invalid TOML ===" content <- TIO.readFile "examples/invalid.toml" TIO.putStrLn $ case Toml.parse content of - Left (ParseException e) -> e + 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 msg -> Toml.prettyException msg + 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 diff --git a/src/Toml.hs b/src/Toml.hs --- a/src/Toml.hs +++ b/src/Toml.hs @@ -1,17 +1,18 @@ {- | -Copyright: (c) 2018-2019 Kowainik +Copyright: (c) 2018-2020 Kowainik SPDX-License-Identifier: MPL-2.0 Maintainer: Kowainik -This module reexports all functionality of @tomland@ package. It's +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 @@ -25,28 +26,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". +-} diff --git a/src/Toml/Bi.hs b/src/Toml/Bi.hs deleted file mode 100644 --- a/src/Toml/Bi.hs +++ /dev/null @@ -1,27 +0,0 @@ -{- | -Copyright: (c) 2018-2019 Kowainik -SPDX-License-Identifier: MPL-2.0 -Maintainer: Kowainik - -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 diff --git a/src/Toml/Bi/Code.hs b/src/Toml/Bi/Code.hs deleted file mode 100644 --- a/src/Toml/Bi/Code.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} - -{- | -Copyright: (c) 2018-2019 Kowainik -SPDX-License-Identifier: MPL-2.0 -Maintainer: Kowainik - -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 stock (Eq, Generic) - deriving anyclass (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 diff --git a/src/Toml/Bi/Combinators.hs b/src/Toml/Bi/Combinators.hs deleted file mode 100644 --- a/src/Toml/Bi/Combinators.hs +++ /dev/null @@ -1,515 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} - -{- | -Copyright: (c) 2018-2019 Kowainik -SPDX-License-Identifier: MPL-2.0 -Maintainer: Kowainik - -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 - , word8 - -- ** Floating point numbers - , double - , float - -- ** Text types - , text - , lazyText - , byteString - , lazyByteString - , byteStringArray - , lazyByteStringArray - , string - -- ** Time types - , zonedTime - , localTime - , day - , timeOfDay - - -- * Codecs for containers of primitives - , arrayOf - , arraySetOf - , arrayIntSet - , arrayHashSetOf - , arrayNonEmptyOf - - -- * Codecs for 'Monoid's - -- ** Bool wrappers - , all - , any - -- ** 'Num' wrappers - , sum - , product - -- ** 'Maybe' wrappers - , first - , last - - -- * Additional codecs for custom types - , textBy - , read - , enumBounded - - -- * Combinators for tables - , table - , nonEmpty - , list - , set - , hashSet - - -- * Combinators for Maps - , map - - -- * General construction of codecs - , match - ) where - -import Prelude hiding (all, any, last, map, product, read, sum) - -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.Map.Strict (Map) -import Data.Maybe (fromMaybe) -import Data.Monoid (All (..), Any (..), First (..), Last (..), Product (..), Sum (..)) -import Data.Semigroup ((<>)) -import Data.Set (Set) -import Data.Text (Text) -import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime) -import Data.Word (Word8) -import Numeric.Natural (Natural) - -import Toml.Bi.Code (DecodeException (..), Env, St, TomlCodec, execTomlCodec) -import Toml.Bi.Map (BiMap (..), TomlBiMap, _Array, _Bool, _ByteString, _ByteStringArray, _Day, - _Double, _EnumBounded, _Float, _HashSet, _Int, _IntSet, _Integer, _LByteString, - _LByteStringArray, _LText, _LocalTime, _Natural, _NonEmpty, _Read, _Set, - _String, _Text, _TextBy, _TimeOfDay, _Word, _Word8, _ZonedTime) -import Toml.Bi.Monad (Codec (..), dimap, dioptional) -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.HashSet as HS -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as Map -import qualified Data.Set as S -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 -{-# INLINE bool #-} - --- | Codec for integer values. -integer :: Key -> TomlCodec Integer -integer = match _Integer -{-# INLINE integer #-} - --- | Codec for integer values. -int :: Key -> TomlCodec Int -int = match _Int -{-# INLINE int #-} - --- | Codec for natural values. -natural :: Key -> TomlCodec Natural -natural = match _Natural -{-# INLINE natural #-} - --- | Codec for word values. -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. -double :: Key -> TomlCodec Double -double = match _Double -{-# INLINE double #-} - --- | Codec for floating point values. -float :: Key -> TomlCodec Float -float = match _Float -{-# INLINE float #-} - --- | Codec for text values. -text :: Key -> TomlCodec Text -text = match _Text -{-# INLINE text #-} - --- | Codec for lazy text values. -lazyText :: Key -> TomlCodec L.Text -lazyText = match _LText -{-# INLINE lazyText #-} - --- | 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) -{-# INLINE textBy #-} - --- | Codec for string values. -string :: Key -> TomlCodec String -string = match _String -{-# INLINE string #-} - --- | Codec for values with a 'Read' and 'Show' instance. -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 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 -{-# INLINE enumBounded #-} - --- | Codec for text values as 'ByteString'. -byteString :: Key -> TomlCodec ByteString -byteString = match _ByteString -{-# INLINE byteString #-} - --- | Codec for text values as 'BL.ByteString'. -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 #-} - --- | Codec for zoned time values. -zonedTime :: Key -> TomlCodec ZonedTime -zonedTime = match _ZonedTime -{-# INLINE zonedTime #-} - --- | Codec for local time values. -localTime :: Key -> TomlCodec LocalTime -localTime = match _LocalTime -{-# INLINE localTime #-} - --- | Codec for day values. -day :: Key -> TomlCodec Day -day = match _Day -{-# INLINE day #-} - --- | Codec for time of day values. -timeOfDay :: Key -> TomlCodec TimeOfDay -timeOfDay = match _TimeOfDay -{-# INLINE 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 -{-# INLINE arrayOf #-} - --- | 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 -{-# INLINE arraySetOf #-} - --- | Codec for sets of ints. Takes converter for single value and --- returns a set of ints. -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. -arrayHashSetOf - :: (Hashable a, Eq a) - => TomlBiMap a AnyValue - -> Key - -> TomlCodec (HashSet a) -arrayHashSetOf = match . _HashSet -{-# INLINE arrayHashSetOf #-} - --- | 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 -{-# INLINE arrayNonEmptyOf #-} - ----------------------------------------------------------------------------- --- Monoid codecs ----------------------------------------------------------------------------- - -{- | Codec for 'All' wrapper for boolean values. -Returns @'All' 'True'@ on missing fields. - -@since 1.2.1.0 --} -all :: Key -> TomlCodec All -all = dimap (Just . getAll) (All . fromMaybe True) . dioptional . bool -{-# INLINE all #-} - -{- | Codec for 'Any' wrapper for boolean values. -Returns @'Any' 'False'@ on missing fields. - -@since 1.2.1.0 --} -any :: Key -> TomlCodec Any -any = dimap (Just . getAny) (Any . fromMaybe False) . dioptional . bool -{-# INLINE any #-} - -{- | Codec for 'Sum' wrapper for given converter's values. - -@since 1.2.1.0 --} -sum :: (Key -> TomlCodec a) -> Key -> TomlCodec (Sum a) -sum codec = dimap getSum Sum . codec -{-# INLINE sum #-} - -{- | Codec for 'Product' wrapper for given converter's values. - -@since 1.2.1.0 --} -product :: (Key -> TomlCodec a) -> Key -> TomlCodec (Product a) -product codec = dimap getProduct Product . codec -{-# INLINE product #-} - -{- | Codec for 'First' wrapper for given converter's values. - -@since 1.2.1.0 --} -first :: (Key -> TomlCodec a) -> Key -> TomlCodec (First a) -first codec = dimap getFirst First . dioptional . codec -{-# INLINE first #-} - -{- | Codec for 'Last' wrapper for given converter's values. - -@since 1.2.1.0 --} -last :: (Key -> TomlCodec a) -> Key -> TomlCodec (Last a) -last codec = dimap getLast Last . dioptional . codec -{-# INLINE last #-} - ----------------------------------------------------------------------------- --- Tables and arrays of tables ----------------------------------------------------------------------------- - -{- | 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 - -{- | 'Codec' for set of values. Represented in TOML as array of tables. - -@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 HashSet of values. Represented in TOML as array of tables. - -@since 1.2.0.0 --} - -hashSet :: forall a . (Hashable a, Eq a) => TomlCodec a -> Key -> TomlCodec (HashSet a) -hashSet codec key = dimap HS.toList HS.fromList (list codec key) -{-# INLINE hashSet #-} - ----------------------------------------------------------------------------- --- Map-like combinators ----------------------------------------------------------------------------- - -{- | 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 keyCodec valCodec key = Codec input output - where - input :: Env (Map k v) - input = do - mTables <- asks $ HashMap.lookup key . tomlTableArrays - case mTables of - Nothing -> pure Map.empty - Just tomls -> fmap Map.fromList $ forM (NE.toList tomls) $ \toml -> do - k <- codecReadTOML toml keyCodec - v <- codecReadTOML toml valCodec - pure (k, v) - - output :: Map k v -> St (Map k v) - output dict = do - let tomls = fmap - (\(k, v) -> execTomlCodec keyCodec k <> execTomlCodec valCodec v) - (Map.toList 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 diff --git a/src/Toml/Bi/Map.hs b/src/Toml/Bi/Map.hs deleted file mode 100644 --- a/src/Toml/Bi/Map.hs +++ /dev/null @@ -1,577 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TypeFamilies #-} - -{- | -Copyright: (c) 2018-2019 Kowainik -SPDX-License-Identifier: MPL-2.0 -Maintainer: Kowainik - -Implementation of tagged partial bidirectional isomorphism. --} - -module Toml.Bi.Map - ( -- * BiMap idea - BiMap (..) - , TomlBiMap - , invert - , iso - , prism - - -- * 'BiMap' errors for TOML - , TomlBiMapError (..) - , wrongConstructor - , prettyBiMapError - - -- * Some predefined bi mappings - , _Array - , _Bool - , _Double - , _Integer - , _Text - , _LText - , _ZonedTime - , _LocalTime - , _Day - , _TimeOfDay - , _String - , _Read - , _Natural - , _Word - , _Word8 - , _Int - , _Float - , _ByteString - , _LByteString - , _ByteStringArray - , _LByteStringArray - , _NonEmpty - , _Set - , _IntSet - , _HashSet - - -- * Helpers for BiMap and AnyValue - , mkAnyValueBiMap - , _TextBy - , _LTextText - , _NaturalInteger - , _StringText - , _ReadString - , _BoundedInteger - , _EnumBoundedText - , _ByteStringText - , _LByteStringText - , _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 (Word8) -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 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 - - ----------------------------------------------------------------------------- --- 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-type](https://user-images.githubusercontent.com/4276606/50770531-b6a36000-1298-11e9-9528-caae87951d2a.png) - -'BiMap' also implements 'Cat.Category' typeclass. And this instance can be described -clearly by this illustration: - -![bimap-cat](https://user-images.githubusercontent.com/4276606/50771234-13a01580-129b-11e9-93da-6c5dd0f7f160.png) --} -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 - {-# 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. -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 -@ --} -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 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) -{-# INLINE prism #-} - ----------------------------------------------------------------------------- --- 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 stock (Eq, Show, Generic) - deriving anyclass (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 -{-# INLINE _Bool #-} - -{- | 'Prelude.Integer' bimap for 'AnyValue'. Usually used as -'Toml.Bi.Combinators.integer' combinator. --} -_Integer :: TomlBiMap Integer AnyValue -_Integer = mkAnyValueBiMap matchInteger Integer -{-# INLINE _Integer #-} - -{- | 'Prelude.Double' bimap for 'AnyValue'. Usually used as -'Toml.Bi.Combinators.double' combinator. --} -_Double :: TomlBiMap Double AnyValue -_Double = mkAnyValueBiMap matchDouble Double -{-# INLINE _Double #-} - -{- | 'Data.Text.Text' bimap for 'AnyValue'. Usually used as -'Toml.Bi.Combinators.text' combinator. --} -_Text :: TomlBiMap Text AnyValue -_Text = mkAnyValueBiMap matchText Text -{-# INLINE _Text #-} - --- | Helper bimap for 'Data.Text.Lazy.Text' and 'Data.Text.Text'. -_LTextText :: BiMap e TL.Text Text -_LTextText = iso TL.toStrict TL.fromStrict -{-# INLINE _LTextText #-} - -{- | 'Data.Text.Lazy.Text' bimap for 'AnyValue'. Usually used as -'Toml.Bi.Combinators.lazyText' combinator. --} -_LText :: TomlBiMap TL.Text AnyValue -_LText = _LTextText >>> _Text -{-# INLINE _LText #-} - -{- | 'Data.Time.ZonedTime' bimap for 'AnyValue'. Usually used as -'Toml.Bi.Combinators.zonedTime' combinator. --} -_ZonedTime :: TomlBiMap ZonedTime AnyValue -_ZonedTime = mkAnyValueBiMap matchZoned Zoned -{-# INLINE _ZonedTime #-} - -{- | 'Data.Time.LocalTime' bimap for 'AnyValue'. Usually used as -'Toml.Bi.Combinators.localTime' combinator. --} -_LocalTime :: TomlBiMap LocalTime AnyValue -_LocalTime = mkAnyValueBiMap matchLocal Local -{-# INLINE _LocalTime #-} - -{- | 'Data.Time.Day' bimap for 'AnyValue'. Usually used as -'Toml.Bi.Combinators.day' combinator. --} -_Day :: TomlBiMap Day AnyValue -_Day = mkAnyValueBiMap matchDay Day -{-# INLINE _Day #-} - -{- | 'Data.Time.TimeOfDay' bimap for 'AnyValue'. Usually used as -'Toml.Bi.Combinators.timeOfDay' combinator. --} -_TimeOfDay :: TomlBiMap TimeOfDay AnyValue -_TimeOfDay = mkAnyValueBiMap matchHours Hours -{-# INLINE _TimeOfDay #-} - --- | Helper bimap for 'String' and 'Data.Text.Text'. -_StringText :: BiMap e String Text -_StringText = iso T.pack T.unpack -{-# INLINE _StringText #-} - -{- | 'String' bimap for 'AnyValue'. Usually used as -'Toml.Bi.Combinators.string' combinator. --} -_String :: TomlBiMap String AnyValue -_String = _StringText >>> _Text -{-# INLINE _String #-} - --- | 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) -{-# INLINE _ReadString #-} - --- | 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 -{-# INLINE _Read #-} - --- | 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 -{-# INLINE _Natural #-} - --- | 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 -{-# INLINE _EnumBounded #-} - -{- | 'Word' bimap for 'AnyValue'. Usually used as -'Toml.Bi.Combinators.word' combinator. --} -_Word :: TomlBiMap Word AnyValue -_Word = _BoundedInteger >>> _Integer -{-# INLINE _Word #-} - -{- | 'Word8' bimap for 'AnyValue'. Usually used as -'Toml.Bi.Combinators.word8' combinator. - -@since 1.2.0.0 --} -_Word8 :: TomlBiMap Word8 AnyValue -_Word8 = _BoundedInteger >>> _Integer -{-# INLINE _Word8 #-} - -{- | 'Int' bimap for 'AnyValue'. Usually used as -'Toml.Bi.Combinators.int' combinator. --} -_Int :: TomlBiMap Int AnyValue -_Int = _BoundedInteger >>> _Integer -{-# INLINE _Int #-} - -{- | 'Float' bimap for 'AnyValue'. Usually used as -'Toml.Bi.Combinators.float' combinator. --} -_Float :: TomlBiMap Float AnyValue -_Float = iso realToFrac realToFrac >>> _Double -{-# INLINE _Float #-} - --- | 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' -{-# INLINE _ByteStringText #-} - --- | UTF8 encoded 'ByteString' bimap for 'AnyValue'. --- Usually used as 'Toml.Bi.Combinators.byteString' combinator. -_ByteString :: TomlBiMap ByteString AnyValue -_ByteString = _ByteStringText >>> _Text -{-# INLINE _ByteString #-} - --- | 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' -{-# INLINE _LByteStringText #-} - --- | UTF8 encoded lazy 'BL.ByteString' bimap for 'AnyValue'. --- Usually used as 'Toml.Bi.Combinators.lazyByteString' combinator. -_LByteString :: TomlBiMap BL.ByteString AnyValue -_LByteString = _LByteStringText >>> _Text -{-# INLINE _LByteString #-} - -{- | 'ByteString' bimap for 'AnyValue' encoded as a list of non-negative integers. -Usually used as 'Toml.Bi.Combinators.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 non-negative integers. -Usually used as 'Toml.Bi.Combinators.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 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 -{-# INLINE _NonEmpty #-} - -_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 - } -{-# INLINE _NonEmptyArray #-} - --- | 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 -{-# INLINE _Set #-} - --- | 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 -{-# INLINE _HashSet #-} - -{- | '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 -{-# INLINE _IntSet #-} - -tShow :: Show a => a -> Text -tShow = T.pack . show -{-# INLINE tShow #-} diff --git a/src/Toml/Bi/Monad.hs b/src/Toml/Bi/Monad.hs deleted file mode 100644 --- a/src/Toml/Bi/Monad.hs +++ /dev/null @@ -1,298 +0,0 @@ -{- | -Copyright: (c) 2018-2019 Kowainik -SPDX-License-Identifier: MPL-2.0 -Maintainer: Kowainik - -Contains general underlying monad for bidirectional conversion. --} - -module Toml.Bi.Monad - ( Codec (..) - , BiCodec - , dimap - , dioptional - , diwrap - , dimatch - , () - , (.=) - ) 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: -. --} -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 - } - {-# INLINE fmap #-} - -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 - } - {-# INLINE pure #-} - - (<*>) :: 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 - } - {-# INLINE (<*>) #-} - -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 - } - {-# INLINE (>>=) #-} - -instance (Alternative r, Alternative w) => Alternative (Codec r w c) where - empty :: Codec r w c a - empty = Codec - { codecRead = empty - , codecWrite = \_ -> empty - } - {-# INLINE 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 - } - {-# INLINE (<|>) #-} - -instance (MonadPlus r, MonadPlus w) => MonadPlus (Codec r w c) where - mzero = empty - {-# INLINE mzero #-} - mplus = (<|>) - {-# INLINE 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 -{-# INLINE () #-} - -{- | 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 - } -{-# 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 -@ --} -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 - } -{-# 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 -@ --} -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 -{-# 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.bool "a" '.=' fst - \<*\> Toml.int "b" '.=' snd - -exampleCodec :: TomlCodec Example -exampleCodec = - dimatch matchFoo Foo (Toml.int "foo") - \<|\> dimatch matchBar (uncurry Bar) (Toml.table barCodec "bar") -@ - -@since 1.2.0.0 --} -dimatch - :: (Functor r, Alternative w) - => (c -> Maybe 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 -dimatch match ctor codec = Codec - { codecRead = 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 r w field a -> (object -> field) -> Codec r w object a -codec .= getter = codec { codecWrite = codecWrite codec . getter } -{-# INLINE (.=) #-} diff --git a/src/Toml/Codec.hs b/src/Toml/Codec.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Codec.hs @@ -0,0 +1,122 @@ +{- | +Copyright: (c) 2018-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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. +-} diff --git a/src/Toml/Codec/BiMap.hs b/src/Toml/Codec/BiMap.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Codec/BiMap.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE Rank2Types #-} + +{- | +Copyright: (c) 2018-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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-type](https://user-images.githubusercontent.com/4276606/50770531-b6a36000-1298-11e9-9528-caae87951d2a.png) + +'BiMap' also implements 'Cat.Category' typeclass. And this instance can be described +clearly by this illustration: + +![bimap-cat](https://user-images.githubusercontent.com/4276606/50771234-13a01580-129b-11e9-93da-6c5dd0f7f160.png) + +@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 diff --git a/src/Toml/Codec/BiMap/Conversion.hs b/src/Toml/Codec/BiMap/Conversion.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Codec/BiMap/Conversion.hs @@ -0,0 +1,619 @@ +{-# LANGUAGE GADTs #-} + +{- | +Copyright: (c) 2018-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 + + -- * '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 :: (Eq a, Hashable a) => 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 #-} + +---------------------------------------------------------------------------- +-- 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 diff --git a/src/Toml/Codec/Code.hs b/src/Toml/Codec/Code.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Codec/Code.hs @@ -0,0 +1,122 @@ +{- | +Copyright: (c) 2018-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 + , decodeValidation + , decodeFileEither + , decodeFile + -- * 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 (..)) +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 + +{- | 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 '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 diff --git a/src/Toml/Codec/Combinator.hs b/src/Toml/Codec/Combinator.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Codec/Combinator.hs @@ -0,0 +1,152 @@ +{- | +Copyright: (c) 2018-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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.Combinators.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.Combinators.Time" module documentation for the overview +table and more examples. +-} + +{- $table +Combinators for the @TOML@ tables. + +See the "Toml.Codec.Combinators.Table" module documentation for more examples. +-} + +{- $list +TOML-specific combinators for converting between TOML and Haskell list-like data +types. + +See the "Toml.Codec.Combinators.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.Combinators.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.Combinators.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.Combinators.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.Combinators.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.Combinators.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.Combinators.Common" module documentation for more examples. +-} diff --git a/src/Toml/Codec/Combinator/Common.hs b/src/Toml/Codec/Combinator/Common.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Codec/Combinator/Common.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE FlexibleContexts #-} + +{- | +Copyright: (c) 2018-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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] diff --git a/src/Toml/Codec/Combinator/Custom.hs b/src/Toml/Codec/Combinator/Custom.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Codec/Combinator/Custom.hs @@ -0,0 +1,237 @@ +{- | +Copyright: (c) 2018-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 + + -- * Validation + , validate + , validateIf + ) where + +import Prelude hiding (read) + +import Data.Text (Text) + +import Toml.Codec.BiMap (TomlBiMap) +import Toml.Codec.BiMap.Conversion (_EnumBounded, _Read, _TextBy, _Validate) +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 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 diff --git a/src/Toml/Codec/Combinator/List.hs b/src/Toml/Codec/Combinator/List.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Codec/Combinator/List.hs @@ -0,0 +1,222 @@ +{- | +Copyright: (c) 2018-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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) diff --git a/src/Toml/Codec/Combinator/Map.hs b/src/Toml/Codec/Combinator/Map.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Codec/Combinator/Map.hs @@ -0,0 +1,399 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TupleSections #-} + +{- | +Copyright: (c) 2018-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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.Hashable (Hashable) +import Data.HashMap.Strict (HashMap) +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 (pattern (:||), Key) +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 + . (Eq k, Hashable k) + => 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 + . (Eq k, Hashable k) + => 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 + in fmap fromListMap $ for (valKeys <> tableKeys) $ \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 diff --git a/src/Toml/Codec/Combinator/Monoid.hs b/src/Toml/Codec/Combinator/Monoid.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Codec/Combinator/Monoid.hs @@ -0,0 +1,114 @@ +{- | +Copyright: (c) 2018-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 #-} diff --git a/src/Toml/Codec/Combinator/Primitive.hs b/src/Toml/Codec/Combinator/Primitive.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Codec/Combinator/Primitive.hs @@ -0,0 +1,205 @@ +{- | +Copyright: (c) 2018-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 #-} diff --git a/src/Toml/Codec/Combinator/Set.hs b/src/Toml/Codec/Combinator/Set.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Codec/Combinator/Set.hs @@ -0,0 +1,224 @@ +{- | +Copyright: (c) 2018-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 + :: (Hashable a, Eq a) + => 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 . (Hashable a, Eq a) => TomlCodec a -> Key -> TomlCodec (HashSet a) +hashSet codec key = dimap HS.toList HS.fromList (list codec key) +{-# INLINE hashSet #-} diff --git a/src/Toml/Codec/Combinator/Table.hs b/src/Toml/Codec/Combinator/Table.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Codec/Combinator/Table.hs @@ -0,0 +1,92 @@ +{- | +Copyright: (c) 2018-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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) diff --git a/src/Toml/Codec/Combinator/Time.hs b/src/Toml/Codec/Combinator/Time.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Codec/Combinator/Time.hs @@ -0,0 +1,71 @@ +{- | +Copyright: (c) 2018-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 #-} diff --git a/src/Toml/Codec/Combinator/Tuple.hs b/src/Toml/Codec/Combinator/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Codec/Combinator/Tuple.hs @@ -0,0 +1,100 @@ +{- | +Copyright: (c) 2018-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 #-} diff --git a/src/Toml/Codec/Di.hs b/src/Toml/Codec/Di.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Codec/Di.hs @@ -0,0 +1,210 @@ +{- | +Copyright: (c) 2018-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 (.=) #-} diff --git a/src/Toml/Codec/Error.hs b/src/Toml/Codec/Error.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Codec/Error.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE DeriveAnyClass #-} + +{- | +Copyright: (c) 2018-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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.Printer (prettyKey) + +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 + 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 + +{- | 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 diff --git a/src/Toml/Codec/Generic.hs b/src/Toml/Codec/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Codec/Generic.hs @@ -0,0 +1,776 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | +Copyright: (c) 2018-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 (..) + ) where + +import Data.ByteString (ByteString) +import Data.Char (isLower, toLower) +import Data.Coerce (coerce) +import Data.Hashable (Hashable) +import Data.HashMap.Strict (HashMap) +import Data.HashSet (HashSet) +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 +instance (Hashable a, Eq a, HasItemCodec a) => 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 +-} +instance (Hashable k, Eq k, HasCodec k, HasCodec v) => 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 #-} + +{- $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) diff --git a/src/Toml/Codec/Types.hs b/src/Toml/Codec/Types.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Codec/Types.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | +Copyright: (c) 2018-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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: +. + +@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,) diff --git a/src/Toml/Edsl.hs b/src/Toml/Edsl.hs deleted file mode 100644 --- a/src/Toml/Edsl.hs +++ /dev/null @@ -1,86 +0,0 @@ -{- | -Copyright: (c) 2018-2019 Kowainik -SPDX-License-Identifier: MPL-2.0 -Maintainer: Kowainik - -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 -{-# INLINE mkToml #-} - --- | Creates an empty 'TDSL'. -empty :: TDSL -empty = put mempty -{-# INLINE empty #-} - --- | Adds key-value pair to the 'TDSL'. -(=:) :: Key -> Value a -> TDSL -(=:) k v = modify $ insertKeyVal k v -{-# INLINE (=:) #-} - --- | Adds table to the 'TDSL'. -table :: Key -> TDSL -> TDSL -table k = modify . insertTable k . mkToml -{-# INLINE table #-} - --- | Adds array of tables to the 'TDSL'. -tableArray :: Key -> NonEmpty TDSL -> TDSL -tableArray k = modify . insertTableArrays k . fmap mkToml -{-# INLINE tableArray #-} diff --git a/src/Toml/Generic.hs b/src/Toml/Generic.hs deleted file mode 100644 --- a/src/Toml/Generic.hs +++ /dev/null @@ -1,419 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} - -{- | -Copyright: (c) 2018-2019 Kowainik -SPDX-License-Identifier: MPL-2.0 -Maintainer: Kowainik - -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.Hashable (Hashable) -import Data.HashSet (HashSet) -import Data.IntSet (IntSet) -import Data.Kind (Type) -import Data.List (stripPrefix) -import Data.List.NonEmpty (NonEmpty) -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.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 ----------------------------------------------------------------------------- - -{- | Helper class to derive TOML codecs generically. --} -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 --- | @since 1.2.0.0 -instance HasItemCodec Word8 where hasItemCodec = Left Toml._Word8 -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 --- | @since 1.2.0.0 -instance HasCodec Word8 where hasCodec = Toml.word8 -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 - --- | @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 - --- | @since 1.2.0.0 -instance (Hashable a, Eq a, HasItemCodec a) => HasCodec (HashSet a) where - hasCodec = case hasItemCodec @a of - Left prim -> Toml.arrayHashSetOf prim - Right codec -> Toml.hashSet 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 --} diff --git a/src/Toml/Parser.hs b/src/Toml/Parser.hs --- a/src/Toml/Parser.hs +++ b/src/Toml/Parser.hs @@ -1,16 +1,17 @@ -{-# LANGUAGE DeriveAnyClass #-} - {- | -Copyright: (c) 2018-2019 Kowainik +Copyright: (c) 2018-2020 Kowainik SPDX-License-Identifier: MPL-2.0 Maintainer: Kowainik Parser for text to TOML AST. + +@since 0.0.0 -} module Toml.Parser - ( ParseException (..) + ( TomlParseError (..) , parse + , parseKey ) where import Control.DeepSeq (NFData) @@ -18,26 +19,42 @@ import GHC.Generics (Generic) import Toml.Parser.Item (tomlP) +import Toml.Parser.Key (keyP) import Toml.Parser.Validate (validateItems) -import Toml.Type (TOML) +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 - { unParseException :: Text +{- | Pretty parse exception for parsing toml. + +@since 1.3.0.0 +-} +newtype TomlParseError = TomlParseError + { unTomlParseError :: Text } deriving stock (Show, Generic) deriving newtype (Eq, NFData) -{- | 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. +{- | 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 ParseException TOML +parse :: Text -> Either TomlParseError TOML parse t = case P.parse tomlP "" t of - Left err -> Left $ ParseException $ T.pack $ P.errorBundlePretty err + Left err -> Left $ TomlParseError $ T.pack $ P.errorBundlePretty err Right items -> case validateItems items of - Left err -> Left $ ParseException $ T.pack $ show err + 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 diff --git a/src/Toml/Parser/Core.hs b/src/Toml/Parser/Core.hs --- a/src/Toml/Parser/Core.hs +++ b/src/Toml/Parser/Core.hs @@ -1,5 +1,5 @@ {- | -Copyright: (c) 2018-2019 Kowainik +Copyright: (c) 2018-2020 Kowainik SPDX-License-Identifier: MPL-2.0 Maintainer: Kowainik diff --git a/src/Toml/Parser/Item.hs b/src/Toml/Parser/Item.hs --- a/src/Toml/Parser/Item.hs +++ b/src/Toml/Parser/Item.hs @@ -1,5 +1,5 @@ {-| -Copyright: (c) 2018-2019 Kowainik +Copyright: (c) 2018-2020 Kowainik SPDX-License-Identifier: MPL-2.0 Maintainer: Kowainik @@ -17,6 +17,7 @@ , setTableName , tomlP + , keyValP ) where import Control.Applicative (liftA2, many) @@ -28,8 +29,8 @@ import Toml.Parser.Core (Parser, eof, sc, text, try, ()) import Toml.Parser.Key (keyP, tableArrayNameP, tableNameP) import Toml.Parser.Value (anyValueP) -import Toml.PrefixTree (Key) -import Toml.Type (AnyValue) +import Toml.Type.AnyValue (AnyValue) +import Toml.Type.Key (Key) {- | One item of a TOML file. It could be either: @@ -76,7 +77,7 @@ inlineTableP = fmap Table $ between (text "{") (text "}") - $ (liftA2 (,) (keyP <* text "=") anyValueP) `sepEndBy` text "," + $ liftA2 (,) (keyP <* text "=") anyValueP `sepEndBy` text "," -- | Parser for inline arrays of tables. inlineTableArrayP :: Parser (NonEmpty Table) @@ -90,19 +91,21 @@ , TableArrayName <$> tableArrayNameP "array of tables name" , keyValP ] - where - -- 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 @"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] diff --git a/src/Toml/Parser/Key.hs b/src/Toml/Parser/Key.hs --- a/src/Toml/Parser/Key.hs +++ b/src/Toml/Parser/Key.hs @@ -1,5 +1,5 @@ {- | -Copyright: (c) 2018-2019 Kowainik +Copyright: (c) 2018-2020 Kowainik SPDX-License-Identifier: MPL-2.0 Maintainer: Kowainik @@ -17,12 +17,11 @@ import Control.Applicative (Alternative (..)) import Control.Applicative.Combinators.NonEmpty (sepBy1) import Control.Monad.Combinators (between) -import Data.Semigroup ((<>)) import Data.Text (Text) import Toml.Parser.Core (Parser, alphaNumChar, char, lexeme, text) import Toml.Parser.String (basicStringP, literalStringP) -import Toml.PrefixTree (Key (..), Piece (..)) +import Toml.Type.Key (Key (..), Piece (..)) import qualified Data.Text as Text diff --git a/src/Toml/Parser/String.hs b/src/Toml/Parser/String.hs --- a/src/Toml/Parser/String.hs +++ b/src/Toml/Parser/String.hs @@ -1,5 +1,5 @@ {- | -Copyright: (c) 2018-2019 Kowainik +Copyright: (c) 2018-2020 Kowainik SPDX-License-Identifier: MPL-2.0 Maintainer: Kowainik @@ -16,7 +16,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, diff --git a/src/Toml/Parser/Validate.hs b/src/Toml/Parser/Validate.hs --- a/src/Toml/Parser/Validate.hs +++ b/src/Toml/Parser/Validate.hs @@ -1,5 +1,5 @@ {- | -Copyright: (c) 2018-2019 Kowainik +Copyright: (c) 2018-2020 Kowainik SPDX-License-Identifier: MPL-2.0 Maintainer: Kowainik @@ -24,15 +24,14 @@ import Data.Bifunctor (first) import Data.List.NonEmpty (NonEmpty (..)) -import Data.Semigroup ((<>)) import Data.Tree (Forest, Tree (..)) import Toml.Parser.Item (Table (..), TomlItem (..), setTableName) -import Toml.PrefixTree (Key, KeysDiff (FstIsPref), keysDiff) -import Toml.Type (TOML (..), insertKeyAnyVal, insertTable, insertTableArrays) +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.PrefixTree as PrefixMap +import qualified Toml.Type.PrefixTree as PrefixMap {- | Validate list of 'TomlItem's and convert to 'TOML' if not validation @@ -150,6 +149,7 @@ -- 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 @@ -162,6 +162,7 @@ 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 diff --git a/src/Toml/Parser/Value.hs b/src/Toml/Parser/Value.hs --- a/src/Toml/Parser/Value.hs +++ b/src/Toml/Parser/Value.hs @@ -1,5 +1,5 @@ {- | -Copyright: (c) 2018-2019 Kowainik +Copyright: (c) 2018-2020 Kowainik SPDX-License-Identifier: MPL-2.0 Maintainer: Kowainik @@ -20,7 +20,6 @@ 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 Text.Read (readMaybe) diff --git a/src/Toml/PrefixTree.hs b/src/Toml/PrefixTree.hs deleted file mode 100644 --- a/src/Toml/PrefixTree.hs +++ /dev/null @@ -1,231 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE PatternSynonyms #-} - -{- | -Copyright: (c) 2018-2019 Kowainik -SPDX-License-Identifier: MPL-2.0 -Maintainer: Kowainik - -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 stock (Show, Eq, Generic) - deriving anyclass (NFData) - -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 stock (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) -{-# INLINE (<|) #-} - --- | Creates a 'PrefixTree' of one key-value element. -singleT :: Key -> a -> PrefixTree a -singleT = Leaf -{-# INLINE singleT #-} - --- | 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 diff --git a/src/Toml/Printer.hs b/src/Toml/Printer.hs deleted file mode 100644 --- a/src/Toml/Printer.hs +++ /dev/null @@ -1,208 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -{- | -Copyright: (c) 2018-2019 Kowainik -SPDX-License-Identifier: MPL-2.0 -Maintainer: Kowainik - -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) -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 diff --git a/src/Toml/Type.hs b/src/Toml/Type.hs --- a/src/Toml/Type.hs +++ b/src/Toml/Type.hs @@ -1,5 +1,5 @@ {- | -Copyright: (c) 2018-2019 Kowainik +Copyright: (c) 2018-2020 Kowainik SPDX-License-Identifier: MPL-2.0 Maintainer: Kowainik @@ -7,13 +7,67 @@ -} 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'. +-} diff --git a/src/Toml/Type/AnyValue.hs b/src/Toml/Type/AnyValue.hs --- a/src/Toml/Type/AnyValue.hs +++ b/src/Toml/Type/AnyValue.hs @@ -6,11 +6,13 @@ {-# LANGUAGE KindSignatures #-} {- | -Copyright: (c) 2018-2019 Kowainik +Copyright: (c) 2018-2020 Kowainik SPDX-License-Identifier: MPL-2.0 Maintainer: Kowainik Existential wrapper over 'Value' type and matching functions. + +@since 0.0.0 -} module Toml.Type.AnyValue @@ -42,7 +44,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 diff --git a/src/Toml/Type/Edsl.hs b/src/Toml/Type/Edsl.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Type/Edsl.hs @@ -0,0 +1,107 @@ +{- | +Copyright: (c) 2018-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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 #-} diff --git a/src/Toml/Type/Key.hs b/src/Toml/Type/Key.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Type/Key.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE PatternSynonyms #-} + +{- | +Copyright: (c) 2018-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +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) diff --git a/src/Toml/Type/PrefixTree.hs b/src/Toml/Type/PrefixTree.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Type/PrefixTree.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE PatternSynonyms #-} + +{- | +Copyright: (c) 2018-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +Implementation of prefix tree for TOML AST. + +@since 0.0.0 +-} + +module Toml.Type.PrefixTree + ( + -- * 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.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) + + +{- | 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 diff --git a/src/Toml/Type/Printer.hs b/src/Toml/Type/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Type/Printer.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE TypeFamilies #-} + +{- | +Copyright: (c) 2018-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +Contains functions for pretty printing @toml@ types. + +@since 0.0.0 +-} + +module Toml.Type.Printer + ( PrintOptions(..) + , defaultOptions + , pretty + , prettyOptions + , prettyKey + ) where + +import Data.Bifunctor (first) +import Data.Coerce (coerce) +import Data.Function (on) +import Data.HashMap.Strict (HashMap) +import Data.List (sortBy) +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) +import Data.Time (ZonedTime, defaultTimeLocale, formatTime) + +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 + } + +{- | 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 + +{- | 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) = 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 diff --git a/src/Toml/Type/TOML.hs b/src/Toml/Type/TOML.hs --- a/src/Toml/Type/TOML.hs +++ b/src/Toml/Type/TOML.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {- | -Copyright: (c) 2018-2019 Kowainik +Copyright: (c) 2018-2020 Kowainik SPDX-License-Identifier: MPL-2.0 Maintainer: Kowainik @@ -19,15 +19,15 @@ 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 Toml.Type.PrefixTree as Prefix {- | Represents TOML configuration value. @@ -90,6 +90,8 @@ ] } @ + +@since 0.0.0 -} data TOML = TOML { tomlPairs :: !(HashMap Key AnyValue) @@ -98,6 +100,7 @@ } deriving stock (Show, Eq, Generic) deriving anyclass (NFData) +-- | @since 0.3 instance Semigroup TOML where (<>) :: TOML -> TOML -> TOML TOML pairsA tablesA arraysA <> TOML pairsB tablesB arraysB = TOML @@ -106,6 +109,7 @@ (arraysA <> arraysB) {-# INLINE (<>) #-} +-- | @since 0.3 instance Monoid TOML where mempty :: TOML mempty = TOML mempty mempty mempty diff --git a/src/Toml/Type/UValue.hs b/src/Toml/Type/UValue.hs --- a/src/Toml/Type/UValue.hs +++ b/src/Toml/Type/UValue.hs @@ -1,11 +1,13 @@ {-# LANGUAGE GADTs #-} {- | -Copyright: (c) 2018-2019 Kowainik +Copyright: (c) 2018-2020 Kowainik SPDX-License-Identifier: MPL-2.0 Maintainer: Kowainik Intermediate untype value representation used for parsing. + +@since 0.0.0 -} module Toml.Type.UValue @@ -21,8 +23,11 @@ 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 @@ -35,6 +40,7 @@ | UArray ![UValue] deriving stock (Show) +-- | @since 0.0.0 instance Eq UValue where (UBool b1) == (UBool b2) = b1 == b2 (UInteger i1) == (UInteger i2) = i1 == i2 @@ -49,7 +55,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 diff --git a/src/Toml/Type/Value.hs b/src/Toml/Type/Value.hs --- a/src/Toml/Type/Value.hs +++ b/src/Toml/Type/Value.hs @@ -7,11 +7,13 @@ {-# LANGUAGE TypeOperators #-} {- | -Copyright: (c) 2018-2019 Kowainik +Copyright: (c) 2018-2020 Kowainik SPDX-License-Identifier: MPL-2.0 Maintainer: Kowainik GADT value for TOML. + +@since 0.0.0 -} module Toml.Type.Value @@ -37,7 +39,10 @@ import GHC.Generics (Generic) --- | Needed for GADT parameterization +{- | Needed for GADT parameterization + +@since 0.0.0 +-} data TValue = TBool | TInteger @@ -51,11 +56,17 @@ deriving stock (Eq, Show, Read, Generic) deriving anyclass (NFData) --- | Convert 'TValue' constructors to 'String' without @T@ prefix. +{- | 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: @@ -184,6 +195,7 @@ -} Array :: [Value t] -> Value 'TArray +-- | @since 0.0.0 deriving stock instance Show (Value t) instance NFData (Value t) where @@ -222,7 +234,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 @@ -230,8 +245,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 @@ -247,12 +266,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 stock (Eq) +-- | @since 0.1.0 instance Show TypeMismatchError where show TypeMismatchError{..} = "Expected type '" ++ showType typeExpected ++ "' but actual type: '" ++ showType typeActual ++ "'" @@ -260,6 +283,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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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: +-} +main :: IO () +main = hspec $ modifyMaxDiscardRatio (+ 90) $ parallel $ do + typeSpec + parserSpec + codecSpec diff --git a/test/Test/Toml/BiCode/Property.hs b/test/Test/Toml/BiCode/Property.hs deleted file mode 100644 --- a/test/Test/Toml/BiCode/Property.hs +++ /dev/null @@ -1,206 +0,0 @@ -module Test.Toml.BiCode.Property where - -import Control.Applicative (liftA2, (<|>)) -import Control.Category ((>>>)) -import Data.ByteString (ByteString) -import Data.HashSet (HashSet) -import Data.IntSet (IntSet) -import Data.List.NonEmpty (NonEmpty) -import Data.Map.Strict (Map) -import Data.Monoid (All (..), Any (..), First (..), Last (..), Product (..), Sum (..)) -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 - , btSumType :: !BigTypeSum - , btRecord :: !BigTypeRecord - , btMap :: !(Map Int Bool) - , btAll :: !All - , btAny :: !Any - , btSum :: !(Sum Int) - , btProduct :: !(Product Int) - , btFirst :: !(First Int) - , btLast :: !(Last Int) - } deriving stock (Show, Eq) - --- | Wrapper over 'Double' and 'Float' to be equal on @NaN@ values. -newtype Batman a = Batman - { unBatman :: a - } deriving stock (Show) - -instance RealFloat a => Eq (Batman a) where - Batman a == Batman b = - if isNaN a - then isNaN b - else a == b - -newtype BigTypeNewtype = BigTypeNewtype - { unBigTypeNewtype :: ZonedTime - } deriving stock (Show) - -instance Eq BigTypeNewtype where - (BigTypeNewtype a) == (BigTypeNewtype b) = zonedTimeToUTC a == zonedTimeToUTC b - -data BigTypeSum - = BigTypeSumA !Integer - | BigTypeSumB !Text - deriving stock (Show, Eq) - -data BigTypeRecord = BigTypeRecord - { btrBoolSet :: !(Set Bool) - , btrNewtypeList :: ![BigTypeSum] - } deriving stock (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 .= btSumType - <*> Toml.table bigTypeRecordCodec "table-record" .= btRecord - <*> Toml.map (Toml.int "key") (Toml.bool "val") "map" .= btMap - <*> Toml.all "all" .= btAll - <*> Toml.any "any" .= btAny - <*> Toml.sum Toml.int "sum" .= btSum - <*> Toml.product Toml.int "product" .= btProduct - <*> Toml.first Toml.int "first" .= btFirst - <*> Toml.last Toml.int "last" .= btLast - -_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 - btSumType <- genSum - btRecord <- genRec - btMap <- Gen.map (Range.constant 0 10) (liftA2 (,) genInt genBool) - btAll <- All <$> genBool - btAny <- Any <$> genBool - btSum <- Sum <$> genInt - btProduct <- Product <$> genInt - btFirst <- First <$> Gen.maybe genInt - btLast <- Last <$> Gen.maybe genInt - 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{..} diff --git a/test/Test/Toml/BiMap/Property.hs b/test/Test/Toml/BiMap/Property.hs deleted file mode 100644 --- a/test/Test/Toml/BiMap/Property.hs +++ /dev/null @@ -1,67 +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 "Word8" (testBiMap B._Word8 G.genWord8) - , 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 "ByteStringArray" (testBiMap B._ByteStringArray G.genByteString) - , prop "Lazy ByteStringArray" (testBiMap B._LByteStringArray 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 diff --git a/test/Test/Toml/Codec.hs b/test/Test/Toml/Codec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Codec.hs @@ -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 diff --git a/test/Test/Toml/Codec/BiMap.hs b/test/Test/Toml/Codec/BiMap.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Codec/BiMap.hs @@ -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 diff --git a/test/Test/Toml/Codec/BiMap/Conversion.hs b/test/Test/Toml/Codec/BiMap/Conversion.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Codec/BiMap/Conversion.hs @@ -0,0 +1,71 @@ +{-# 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 + + 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 =<<) diff --git a/test/Test/Toml/Codec/Code.hs b/test/Test/Toml/Codec/Code.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Codec/Code.hs @@ -0,0 +1,110 @@ +module Test.Toml.Codec.Code + ( codeSpec + ) where + +import Test.Hspec (Spec, describe, it, shouldBe) + +import Toml.Codec.BiMap (TomlBiMapError (..)) +import Toml.Codec.Code (decode) +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 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"] + -- 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"] + + -- 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"] + + -- 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"] + where + matchErr :: Key -> TValue -> AnyValue -> TomlDecodeError + matchErr key valueExpected valueActual = BiMapError key $ WrongValue $ MatchError {..} diff --git a/test/Test/Toml/Codec/Combinator.hs b/test/Test/Toml/Codec/Combinator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Codec/Combinator.hs @@ -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 diff --git a/test/Test/Toml/Codec/Combinator/Common.hs b/test/Test/Toml/Codec/Combinator/Common.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Codec/Combinator/Common.hs @@ -0,0 +1,61 @@ +module Test.Toml.Codec.Combinator.Common + ( codecRoundtrip + + -- * Double helpers + , Batman (..) + , _BatmanDouble + , batmanDoubleCodec + , batmanFloatCodec + ) where + +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, encode) +import Toml.Codec.Types (TomlCodec) +import Toml.Type.AnyValue (AnyValue) +import Toml.Type.Key (Key) + + +import qualified Toml.Codec as Toml + + +codecRoundtrip + :: forall a + . (Eq a, Show a) + => String + -> (Key -> TomlCodec a) + -> Gen a + -> SpecWith (Arg Expectation) +codecRoundtrip typeName mkCodec genA = it label $ hedgehog $ do + a <- forAll genA + let codec = mkCodec "a" + tripping a (encode codec) (decode codec) + where + label :: String + label = typeName ++ ": decode . encode ≡ id" + +-- | 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 diff --git a/test/Test/Toml/Codec/Combinator/Custom.hs b/test/Test/Toml/Codec/Combinator/Custom.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Codec/Combinator/Custom.hs @@ -0,0 +1,27 @@ +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 diff --git a/test/Test/Toml/Codec/Combinator/List.hs b/test/Test/Toml/Codec/Combinator/List.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Codec/Combinator/List.hs @@ -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) diff --git a/test/Test/Toml/Codec/Combinator/Map.hs b/test/Test/Toml/Codec/Combinator/Map.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Codec/Combinator/Map.hs @@ -0,0 +1,23 @@ +module Test.Toml.Codec.Combinator.Map + ( mapSpec + ) where + +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.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) diff --git a/test/Test/Toml/Codec/Combinator/Monoid.hs b/test/Test/Toml/Codec/Combinator/Monoid.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Codec/Combinator/Monoid.hs @@ -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) diff --git a/test/Test/Toml/Codec/Combinator/Primitive.hs b/test/Test/Toml/Codec/Combinator/Primitive.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Codec/Combinator/Primitive.hs @@ -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 diff --git a/test/Test/Toml/Codec/Combinator/Set.hs b/test/Test/Toml/Codec/Combinator/Set.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Codec/Combinator/Set.hs @@ -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) diff --git a/test/Test/Toml/Codec/Combinator/Table.hs b/test/Test/Toml/Codec/Combinator/Table.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Codec/Combinator/Table.hs @@ -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 diff --git a/test/Test/Toml/Codec/Combinator/Time.hs b/test/Test/Toml/Codec/Combinator/Time.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Codec/Combinator/Time.hs @@ -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 diff --git a/test/Test/Toml/Codec/Combinator/Tuple.hs b/test/Test/Toml/Codec/Combinator/Tuple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Codec/Combinator/Tuple.hs @@ -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) diff --git a/test/Test/Toml/Codec/Di.hs b/test/Test/Toml/Codec/Di.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Codec/Di.hs @@ -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 + ] diff --git a/test/Test/Toml/Codec/Generic.hs b/test/Test/Toml/Codec/Generic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Codec/Generic.hs @@ -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 diff --git a/test/Test/Toml/Codec/SmallType.hs b/test/Test/Toml/Codec/SmallType.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Codec/SmallType.hs @@ -0,0 +1,58 @@ +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) +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" $ + codecRoundtrip "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{..} diff --git a/test/Test/Toml/Gen.hs b/test/Test/Toml/Gen.hs --- a/test/Test/Toml/Gen.hs +++ b/test/Test/Toml/Gen.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + {-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE PatternSynonyms #-} @@ -8,12 +10,9 @@ -- | This module contains all generators for @tomland@ testing. module Test.Toml.Gen - ( -- * Property - PropertyTest - , prop - - -- * Generators + ( -- * Generators -- ** Primitive + genBool , genInt , genInteger , genDouble @@ -23,11 +22,13 @@ , genFloat , genList + , genSmallList , genNonEmpty + , genSet , genHashSet , genIntSet - , genBool + , genMap , genText , genString @@ -37,9 +38,9 @@ -- ** Dates , genDay - , genHours - , genLocal - , genZoned + , genTimeOfDay + , genLocalTime + , genZonedTime -- ** @TOML@ specific , genVal @@ -55,44 +56,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 ---------------------------------------------------------------------------- @@ -101,51 +97,51 @@ 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, GenBase m ~ Identity) => 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 + bare :: Gen Text + bare = liftA2 Text.cons Gen.alpha $ Gen.text (Range.constant 1 10) alphadashes + + alphadashes :: Gen Char alphadashes = Gen.choice [Gen.alphaNum, Gen.element "_-"] - notControl :: m Char - notControl = Gen.filter (not . Char.isControl) Gen.unicode + quoted :: Gen Text + quoted = genNotEscape $ Gen.choice [quotedWith '"', quotedWith '\''] - bare :: m Text - bare = Gen.text (Range.constant 1 10) alphadashes + quotedWith :: Char -> Gen Text + quotedWith c = wrapChar c <$> Gen.text (Range.constant 1 10) notControl + where + notControl :: Gen Char + notControl = Gen.filter (\x -> x /= c && not (Char.isControl 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 = genNotEscape $ Gen.choice [quotedWith '"', quotedWith '\''] - -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 @@ -154,7 +150,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 @@ -163,7 +159,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 @@ -171,46 +167,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 @@ -220,13 +220,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) @@ -234,18 +237,21 @@ , (1, Gen.constant $ 0/0) ] -genWord :: MonadGen m => m Word +genWord :: Gen Word genWord = Gen.word Range.constantBounded -genWord8 :: MonadGen m => m Word8 +genWord8 :: Gen Word8 genWord8 = Gen.word8 Range.constantBounded -genNatural :: MonadGen m => m Natural +genNatural :: Gen Natural genNatural = fromIntegral <$> genWord -genFloat :: MonadGen m => m Float +genFloat :: Gen Float genFloat = Gen.float (Range.constant (-10000.0) 10000.0) +genSet :: Ord a => Gen a -> Gen (Set a) +genSet genA = fromList <$> genList genA + genHashSet :: (Eq a, Hashable a) => Gen a -> Gen (HashSet a) genHashSet genA = fromList <$> genList genA @@ -255,19 +261,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 [ ",", ".", ":", ";", "'", "?", "!", "`" , "-", "_", "*", "$", "#", "@", "(", ")" @@ -275,23 +284,23 @@ ] -- | 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 text from different symbols. -genText :: MonadGen m => m Text +genText :: Gen Text genText = genNotEscape $ fmap Text.concat $ Gen.list (Range.constant 0 256) $ Gen.choice [ Text.singleton <$> Gen.alphaNum , genEscapeSequence @@ -313,19 +322,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 @@ -333,12 +342,30 @@ 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, GenBase m ~ Identity) => 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] @@ -346,8 +373,13 @@ -- filters -- | Discards strings that end with \ -genNotEscape :: MonadGen m => m Text -> m Text +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 diff --git a/test/Test/Toml/Parser.hs b/test/Test/Toml/Parser.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Parser.hs @@ -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 diff --git a/test/Test/Toml/Parser/Array.hs b/test/Test/Toml/Parser/Array.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Parser/Array.hs @@ -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 "" + 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]" diff --git a/test/Test/Toml/Parser/Bool.hs b/test/Test/Toml/Parser/Bool.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Parser/Bool.hs @@ -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" diff --git a/test/Test/Toml/Parser/Common.hs b/test/Test/Toml/Parser/Common.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Parser/Common.hs @@ -0,0 +1,135 @@ +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, Stream, parse) + +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, 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 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 diff --git a/test/Test/Toml/Parser/Date.hs b/test/Test/Toml/Parser/Date.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Parser/Date.hs @@ -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)) diff --git a/test/Test/Toml/Parser/Double.hs b/test/Test/Toml/Parser/Double.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Parser/Double.hs @@ -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 diff --git a/test/Test/Toml/Parser/Examples.hs b/test/Test/Toml/Parser/Examples.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Parser/Examples.hs @@ -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/" diff --git a/test/Test/Toml/Parser/Integer.hs b/test/Test/Toml/Parser/Integer.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Parser/Integer.hs @@ -0,0 +1,83 @@ +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 + 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 diff --git a/test/Test/Toml/Parser/Key.hs b/test/Test/Toml/Parser/Key.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Parser/Key.hs @@ -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 "\".\"" $ "\".\"" :|| [] diff --git a/test/Test/Toml/Parser/Property.hs b/test/Test/Toml/Parser/Property.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Parser/Property.hs @@ -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 diff --git a/test/Test/Toml/Parser/Text.hs b/test/Test/Toml/Parser/Text.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Parser/Text.hs @@ -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") diff --git a/test/Test/Toml/Parser/Toml.hs b/test/Test/Toml/Parser/Toml.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Parser/Toml.hs @@ -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 diff --git a/test/Test/Toml/Parser/Validate.hs b/test/Test/Toml/Parser/Validate.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Parser/Validate.hs @@ -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 diff --git a/test/Test/Toml/Parsing/Examples.hs b/test/Test/Toml/Parsing/Examples.hs deleted file mode 100644 --- a/test/Test/Toml/Parsing/Examples.hs +++ /dev/null @@ -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/" diff --git a/test/Test/Toml/Parsing/Property.hs b/test/Test/Toml/Parsing/Property.hs deleted file mode 100644 --- a/test/Test/Toml/Parsing/Property.hs +++ /dev/null @@ -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 diff --git a/test/Test/Toml/Parsing/Unit.hs b/test/Test/Toml/Parsing/Unit.hs deleted file mode 100644 --- a/test/Test/Toml/Parsing/Unit.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Test.Toml.Parsing.Unit where - -import Test.Tasty.Hspec (Spec) - -import Test.Toml.Parsing.Unit.Array (arraySpecs) -import Test.Toml.Parsing.Unit.Bool (boolSpecs) -import Test.Toml.Parsing.Unit.Date (dateSpecs) -import Test.Toml.Parsing.Unit.Double (doubleSpecs) -import Test.Toml.Parsing.Unit.Integer (integerSpecs) -import Test.Toml.Parsing.Unit.Key (keySpecs) -import Test.Toml.Parsing.Unit.Text (textSpecs) -import Test.Toml.Parsing.Unit.Toml (tomlSpecs) - -spec_Parser :: Spec -spec_Parser = do - arraySpecs - boolSpecs - dateSpecs - doubleSpecs - integerSpecs - keySpecs - textSpecs - tomlSpecs diff --git a/test/Test/Toml/Parsing/Unit/Array.hs b/test/Test/Toml/Parsing/Unit/Array.hs deleted file mode 100644 --- a/test/Test/Toml/Parsing/Unit/Array.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Test.Toml.Parsing.Unit.Array where - -import Data.Time (TimeOfDay (..)) -import Test.Tasty.Hspec (Spec, describe, it) - -import Toml.Type (UValue (..)) - -import Test.Toml.Parsing.Unit.Common (arrayFailOn, day1, day2, int1, int2, int3, int4, parseArray) - -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 "" - 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]" diff --git a/test/Test/Toml/Parsing/Unit/Bool.hs b/test/Test/Toml/Parsing/Unit/Bool.hs deleted file mode 100644 --- a/test/Test/Toml/Parsing/Unit/Bool.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Test.Toml.Parsing.Unit.Bool where - -import Test.Tasty.Hspec (Spec, describe, it) - -import Test.Toml.Parsing.Unit.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" diff --git a/test/Test/Toml/Parsing/Unit/Common.hs b/test/Test/Toml/Parsing/Unit/Common.hs deleted file mode 100644 --- a/test/Test/Toml/Parsing/Unit/Common.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Test.Toml.Parsing.Unit.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.Semigroup ((<>)) -import Data.Text (Text) -import Data.Time (Day, LocalTime (..), TimeOfDay (..), TimeZone, ZonedTime (..), fromGregorian, - minutesToTimeZone) -import Test.Hspec.Megaparsec (shouldFailOn, shouldParse) -import Test.Tasty.Hspec (Expectation) -import Text.Megaparsec (Parsec, ShowErrorComponent, Stream, parse) - -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.PrefixTree (Key (..)) -import Toml.Type (TOML (..), UValue (..)) - ----------------------------------------------------------------------------- --- 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 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 diff --git a/test/Test/Toml/Parsing/Unit/Date.hs b/test/Test/Toml/Parsing/Unit/Date.hs deleted file mode 100644 --- a/test/Test/Toml/Parsing/Unit/Date.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Test.Toml.Parsing.Unit.Date where - -import Data.Time (LocalTime (..), TimeOfDay (..)) - -import Toml.Type (UValue (..)) - -import Test.Tasty.Hspec (Spec, describe, it) - -import Test.Toml.Parsing.Unit.Common (dateTimeFailOn, day1, hours1, makeOffset, makeZoned, offset0, - offset710, parseDateTime) - -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)) diff --git a/test/Test/Toml/Parsing/Unit/Double.hs b/test/Test/Toml/Parsing/Unit/Double.hs deleted file mode 100644 --- a/test/Test/Toml/Parsing/Unit/Double.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Test.Toml.Parsing.Unit.Double where - -import Test.Hspec.Megaparsec (parseSatisfies) -import Test.Tasty.Hspec (Spec, describe, it) -import Text.Megaparsec (parse) - -import Toml.Parser.Value (doubleP) - -import Test.Toml.Parsing.Unit.Common (doubleFailOn, parseDouble) - -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 diff --git a/test/Test/Toml/Parsing/Unit/Integer.hs b/test/Test/Toml/Parsing/Unit/Integer.hs deleted file mode 100644 --- a/test/Test/Toml/Parsing/Unit/Integer.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Test.Toml.Parsing.Unit.Integer where - -import Test.Tasty.Hspec (Spec, context, describe, it) - -import Test.Toml.Parsing.Unit.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 - 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 diff --git a/test/Test/Toml/Parsing/Unit/Key.hs b/test/Test/Toml/Parsing/Unit/Key.hs deleted file mode 100644 --- a/test/Test/Toml/Parsing/Unit/Key.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PatternSynonyms #-} - -module Test.Toml.Parsing.Unit.Key where - -import Test.Tasty.Hspec (Spec, context, describe, it) -import Toml.PrefixTree (pattern (:||)) - -import Test.Toml.Parsing.Unit.Common (dquote, parseKey, squote) - -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\""]) - -- it "ignores whitespaces around dot-separated parts" $ do - -- parseKey "a . b . c. d" (makeKey ["a", "b", "c", "d"]) diff --git a/test/Test/Toml/Parsing/Unit/Text.hs b/test/Test/Toml/Parsing/Unit/Text.hs deleted file mode 100644 --- a/test/Test/Toml/Parsing/Unit/Text.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Test.Toml.Parsing.Unit.Text where - -import Test.Tasty.Hspec (Spec, context, describe, it) - -import Test.Toml.Parsing.Unit.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") diff --git a/test/Test/Toml/Parsing/Unit/Toml.hs b/test/Test/Toml/Parsing/Unit/Toml.hs deleted file mode 100644 --- a/test/Test/Toml/Parsing/Unit/Toml.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PatternSynonyms #-} - -module Test.Toml.Parsing.Unit.Toml where - -import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.Semigroup ((<>)) -import Data.Text (Text) - -import Test.Tasty.Hspec (Spec, describe, it) - -import Toml.Edsl (empty, mkToml, table, tableArray, (=:)) -import Toml.PrefixTree (pattern (:||)) -import Toml.Type (TOML (..), Value (..)) - -import qualified Data.List.NonEmpty as NE -import qualified Data.Text as T - -import Test.Toml.Parsing.Unit.Common (day2, parseToml, tomlFailOn) - -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 - -- 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]" $ 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 diff --git a/test/Test/Toml/PrefixTree/Property.hs b/test/Test/Toml/PrefixTree/Property.hs deleted file mode 100644 --- a/test/Test/Toml/PrefixTree/Property.hs +++ /dev/null @@ -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 diff --git a/test/Test/Toml/PrefixTree/Unit.hs b/test/Test/Toml/PrefixTree/Unit.hs deleted file mode 100644 --- a/test/Test/Toml/PrefixTree/Unit.hs +++ /dev/null @@ -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 diff --git a/test/Test/Toml/Printer/Golden.hs b/test/Test/Toml/Printer/Golden.hs deleted file mode 100644 --- a/test/Test/Toml/Printer/Golden.hs +++ /dev/null @@ -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 diff --git a/test/Test/Toml/Property.hs b/test/Test/Toml/Property.hs --- a/test/Test/Toml/Property.hs +++ b/test/Test/Toml/Property.hs @@ -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 diff --git a/test/Test/Toml/TOML/Property.hs b/test/Test/Toml/TOML/Property.hs deleted file mode 100644 --- a/test/Test/Toml/TOML/Property.hs +++ /dev/null @@ -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 diff --git a/test/Test/Toml/Type.hs b/test/Test/Toml/Type.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Type.hs @@ -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 diff --git a/test/Test/Toml/Type/Key.hs b/test/Test/Toml/Type/Key.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Type/Key.hs @@ -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" diff --git a/test/Test/Toml/Type/PrefixTree.hs b/test/Test/Toml/Type/PrefixTree.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Type/PrefixTree.hs @@ -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 diff --git a/test/Test/Toml/Type/Printer.hs b/test/Test/Toml/Type/Printer.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Type/Printer.hs @@ -0,0 +1,68 @@ +-- | 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) +import Test.Hspec.Golden (defaultGolden) + +import Toml.Type.Edsl (empty, mkToml, table, tableArray, (=:)) +import Toml.Type.Key (Key (..), (<|)) +import Toml.Type.Printer (PrintOptions (..), defaultOptions, prettyOptions) +import Toml.Type.TOML (TOML) +import Toml.Type.Value (Value (..)) + +import qualified Data.Text 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 } + where + test :: String -> PrintOptions -> SpecWith (Arg Expectation) + test name options = it ("Golden " ++ name) $ + defaultGolden + ("test/golden/" ++ name ++ ".golden") + (T.unpack $ 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 + 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 diff --git a/test/Test/Toml/Type/TOML.hs b/test/Test/Toml/Type/TOML.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Type/TOML.hs @@ -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 diff --git a/tomland.cabal b/tomland.cabal --- a/tomland.cabal +++ b/tomland.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: tomland -version: 1.2.1.0 +version: 1.3.0.0 synopsis: Bidirectional TOML serialization description: Implementation of bidirectional TOML serialization. Simple codecs look like this: @@ -27,37 +27,41 @@ license-file: LICENSE author: Dmitrii Kovanikov, Veronika Romashkina maintainer: Kowainik -copyright: 2018-2019 Kowainik +copyright: 2018-2020 Kowainik category: TOML, Text, Configuration build-type: Simple extra-doc-files: README.md CHANGELOG.md extra-source-files: test/golden/*.golden test/examples/*.toml -tested-with: GHC == 8.2.2 - GHC == 8.4.4 +tested-with: GHC == 8.4.4 GHC == 8.6.5 - GHC == 8.8.1 + GHC == 8.8.3 + GHC == 8.10.1 source-repository head type: git location: https://github.com/kowainik/tomland.git common common-options - build-depends: base >= 4.10 && < 4.14 + build-depends: base >= 4.11 && < 4.15 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 default-language: Haskell2010 default-extensions: DeriveGeneric @@ -75,13 +79,25 @@ 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 @@ -89,10 +105,12 @@ Toml.Parser.String Toml.Parser.Validate Toml.Parser.Value - 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 @@ -101,13 +119,14 @@ , containers >= 0.5.7 && < 0.7 , deepseq ^>= 1.4 , hashable >= 1.2 && < 1.4 - , megaparsec ^>= 7.0.5 + , megaparsec >= 7.0.5 && < 8.1 , mtl ^>= 2.2 , parser-combinators >= 1.1.0 && < 1.3 , text ^>= 1.2 - , time >= 1.8 && < 1.10 + , time >= 1.8 && < 1.11 , transformers ^>= 0.5 , unordered-containers ^>= 0.2.7 + , validation-selective ^>= 0.1.0.0 executable readme import: common-options @@ -115,16 +134,21 @@ if 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 + -- We are using DerivingVia that works only with > 8.6 + if impl(ghc < 8.6) + buildable: False main-is: Main.hs build-depends: tomland + , bytestring , containers , hashable , text @@ -140,38 +164,59 @@ 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.Unit.Array - Test.Toml.Parsing.Unit.Bool - Test.Toml.Parsing.Unit.Common - Test.Toml.Parsing.Unit.Date - Test.Toml.Parsing.Unit.Double - Test.Toml.Parsing.Unit.Integer - Test.Toml.Parsing.Unit.Key - Test.Toml.Parsing.Unit.Text - Test.Toml.Parsing.Unit.Toml - 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 , hashable , hedgehog ^>= 1.0.1 - , hspec-megaparsec ^>= 2.0.0 + , hspec ^>= 2.7.1 + , hspec-hedgehog ^>= 0.0.1 + , hspec-golden ^>= 0.1.0 + , hspec-megaparsec >= 2.0.0 && < 2.2.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