diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,8 +1,51 @@ -# Change log +# Changelog tomland uses [PVP Versioning][1]. -The change log is available [on GitHub][2]. +The changelog is available [on GitHub][2]. +## 1.0.0 — Jan 14, 2019 + +* [#13](https://github.com/kowainik/tomland/issues/13): + Support array of tables. + + + [#131](https://github.com/kowainik/tomland/issues/131): + Uncommenting `tomlTableArrays` from `TOML`. + + [#134](https://github.com/kowainik/tomland/issues/134): + Pretty printer arrays of tables and golden tests. + + [#143](https://github.com/kowainik/tomland/issues/143): + Parser for arrays of tables. + + [#155](https://github.com/kowainik/tomland/issues/155): + Add `list` and `nonEmpty` combinators for coding lists of custom user types. + + [#142](https://github.com/kowainik/tomland/issues/142): + Adding EDSL support for arrays of tables. + + [#144](https://github.com/kowainik/tomland/issues/144): + Added tests for arrays of tables. + +* [#140](https://github.com/kowainik/tomland/issues/140): + **Breaking change:** Replace `wrapper` by `diwrap`. + + _Migration guide:_ change `Toml.wrapper Toml.text "foo"` to `Toml.diwrap (Toml.text "foo")`. +* [#152](https://github.com/kowainik/tomland/issues/152): + **Breaking change:** Removing `mdimap`. + + _Migration guide:_ change `Toml.mdimap showX parseX (Toml.text "foo")` to `Toml.textBy showX parseX "foo"`. +* [#137](https://github.com/kowainik/tomland/issues/137): + Replace `Maybe` with `Either` in `BiMap`. +* [#174](https://github.com/kowainik/tomland/issues/174): + Add `_LText` and `lazyText` codecs. +* [#163](https://github.com/kowainik/tomland/issues/163): + Move all time data types from nested `DateTime` to `Value`. +* [#146](https://github.com/kowainik/tomland/issues/146): + Allow underscores in floats. +* [#64](https://github.com/kowainik/tomland/issues/64): + Integer parser doesn't accept leading zeros. +* [#50](https://github.com/kowainik/tomland/issues/50): + Add property-based tests for encoder and decoder. +* [#119](https://github.com/kowainik/tomland/issues/119): + Add property-based tests for `BiMap`. +* [#149](https://github.com/kowainik/tomland/issues/149): + Removing records syntax from `PrefixTree`. + ## 0.5.0 — Nov 12, 2018 * [#81](https://github.com/kowainik/tomland/issues/81): @@ -19,7 +62,7 @@ _Migration guide:_ reverse order of composition when using `BiMap`s. * [#98](https://github.com/kowainik/tomland/issues/98): - Implement bencmarks for `tomland` and compare with `htoml` and `htoml-megaparsec` libraries. + Implement benchmarks for `tomland` and compare with `htoml` and `htoml-megaparsec` libraries. * [#130](https://github.com/kowainik/tomland/issues/130): Added combinators to `Toml.Bi.Combinators`. * [#115](https://github.com/kowainik/tomland/issues/115): diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -0,0 +1,177 @@ +# tomland + +![palm](https://user-images.githubusercontent.com/4276606/51088259-7a777000-176e-11e9-9d76-6be4023c0ac3.png) +[![Build status](https://secure.travis-ci.org/kowainik/tomland.svg)](https://travis-ci.org/kowainik/tomland) +[![Hackage](https://img.shields.io/hackage/v/tomland.svg)](https://hackage.haskell.org/package/tomland) +[![Stackage LTS](http://stackage.org/package/tomland/badge/lts)](http://stackage.org/lts/package/tomland) +[![Stackage Nightly](http://stackage.org/package/tomland/badge/nightly)](http://stackage.org/nightly/package/tomland) +[![MPL-2.0 license](https://img.shields.io/badge/license-MPL--2.0-blue.svg)](https://github.com/kowainik/tomland/blob/master/LICENSE) + +> “A library is like an island in the middle of a vast sea of ignorance, +> particularly if the library is very tall and the surrounding area has been +> flooded.” +> +> ― Lemony Snicket, Horseradish + +Bidirectional TOML serialization. The following blog post has more details about +library design: + +* [`tomland`: 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 +``` + +## Preamble: imports and language extensions + +Since this is a literate haskell file, we need to specify all our language +extensions and imports up front. + +```haskell +{-# OPTIONS -Wno-unused-top-binds #-} + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +import Control.Applicative ((<|>)) +import Control.Category ((>>>)) +import Data.Text (Text) +import Toml (TomlBiMap, TomlCodec, (.=)) + +import qualified Data.Text.IO as TIO +import qualified Toml +``` + +`tomland` is mostly designed for qualified imports and intended to be imported +as follows: + +```haskell ignore +import Toml (TomlCodec, (.=)) -- add 'TomlBiMap' and 'Key' here optionally +import qualified Toml +``` + +## Data type: parsing and printing + +We're going to parse TOML configuration from [`examples/readme.toml`](examples/readme.toml) file. + +This static configuration is captured by the following Haskell data type: + +```haskell +data Settings = Settings + { settingsPort :: !Port + , settingsDescription :: !Text + , settingsCodes :: [Int] + , settingsMail :: !Mail + , settingsUsers :: ![User] + } + +data Mail = Mail + { mailHost :: !Host + , mailSendIfInactive :: !Bool + } + +data User + = Admin Integer -- id of admin + | Client Text -- name of the client + deriving (Show) + +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: + +1. If your fields are some simple basic 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. +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 + like `Int`, `Bool`, `Double`, `Text` or time types, that you can use + `Toml.arrayOf` and parse arrays of values. +5. `tomland` separates conversion between Haskell types and TOML values from + matching values by keys. Converters between types and values have type + `TomlBiMap` and are named with capital letter started with underscore. Main + type for TOML codecs is called `TomlCodec`. To lift `TomlBiMap` to + `TomlCodec` you need to use `Toml.match` function. + +```haskell +settingsCodec :: TomlCodec Settings +settingsCodec = Settings + <$> Toml.diwrap (Toml.int "server.port") .= settingsPort + <*> Toml.text "server.description" .= settingsDescription + <*> Toml.arrayOf Toml._Int "server.codes" .= settingsCodes + <*> Toml.table mailCodec "mail" .= settingsMail + <*> Toml.list userCodec "user" .= settingsUsers + +mailCodec :: TomlCodec Mail +mailCodec = Mail + <$> 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 + +_Client :: TomlBiMap User Text +_Client = Toml.prism Client $ \case + Client n -> Right n + other -> Toml.wrongConstructor "Client" other + +userCodec :: TomlCodec User +userCodec = + Toml.match (_Admin >>> Toml._Integer) "id" + <|> Toml.match (_Client >>> Toml._Text) "name" +``` + +And now we're 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 + Right settings -> TIO.putStrLn $ Toml.encode settingsCodec settings +``` + +## Benchmarks and comparison with other libraries + +`tomland` is compared with other libraries. Since it uses 2-step approach with +converting text to intermediate AST and only then decoding Haskell type from +this AST, benchmarks are also implemented in a way to reflect this difference. + +| Library | parse :: Text -> AST | transform :: AST -> Haskell | +|--------------------|----------------------|-----------------------------| +| `tomland` | `387.5 μs` | `1.313 μs` | +| `htoml` | `801.2 μs` | `32.54 μs` | +| `htoml-megaparsec` | `318.7 μs` | `34.74 μs` | +| `toml-parser` | `157.2 μs` | `1.156 μs` | + +You may see that `tomland` is not the fastest one (though still very fast). But +performance hasn’t been optimized so far and: + +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: + +## 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/). diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,8 +1,177 @@ # tomland -[![Hackage](https://img.shields.io/hackage/v/tomland.svg)](https://hackage.haskell.org/package/tomland) +![palm](https://user-images.githubusercontent.com/4276606/51088259-7a777000-176e-11e9-9d76-6be4023c0ac3.png) [![Build status](https://secure.travis-ci.org/kowainik/tomland.svg)](https://travis-ci.org/kowainik/tomland) -[![Windows build status](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)](https://hackage.haskell.org/package/tomland) +[![Stackage LTS](http://stackage.org/package/tomland/badge/lts)](http://stackage.org/lts/package/tomland) +[![Stackage Nightly](http://stackage.org/package/tomland/badge/nightly)](http://stackage.org/nightly/package/tomland) [![MPL-2.0 license](https://img.shields.io/badge/license-MPL--2.0-blue.svg)](https://github.com/kowainik/tomland/blob/master/LICENSE) -TOML parser +> “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`: 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 +``` + +## Preamble: imports and language extensions + +Since this is a literate haskell file, we need to specify all our language +extensions and imports up front. + +```haskell +{-# OPTIONS -Wno-unused-top-binds #-} + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +import Control.Applicative ((<|>)) +import Control.Category ((>>>)) +import Data.Text (Text) +import Toml (TomlBiMap, TomlCodec, (.=)) + +import qualified Data.Text.IO as TIO +import qualified Toml +``` + +`tomland` is mostly designed for qualified imports and intended to be imported +as follows: + +```haskell ignore +import Toml (TomlCodec, (.=)) -- add 'TomlBiMap' and 'Key' here optionally +import qualified Toml +``` + +## Data type: parsing and printing + +We're going to parse TOML configuration from [`examples/readme.toml`](examples/readme.toml) file. + +This static configuration is captured by the following Haskell data type: + +```haskell +data Settings = Settings + { settingsPort :: !Port + , settingsDescription :: !Text + , settingsCodes :: [Int] + , settingsMail :: !Mail + , settingsUsers :: ![User] + } + +data Mail = Mail + { mailHost :: !Host + , mailSendIfInactive :: !Bool + } + +data User + = Admin Integer -- id of admin + | Client Text -- name of the client + deriving (Show) + +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: + +1. If your fields are some simple basic 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. +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 + like `Int`, `Bool`, `Double`, `Text` or time types, that you can use + `Toml.arrayOf` and parse arrays of values. +5. `tomland` separates conversion between Haskell types and TOML values from + matching values by keys. Converters between types and values have type + `TomlBiMap` and are named with capital letter started with underscore. Main + type for TOML codecs is called `TomlCodec`. To lift `TomlBiMap` to + `TomlCodec` you need to use `Toml.match` function. + +```haskell +settingsCodec :: TomlCodec Settings +settingsCodec = Settings + <$> Toml.diwrap (Toml.int "server.port") .= settingsPort + <*> Toml.text "server.description" .= settingsDescription + <*> Toml.arrayOf Toml._Int "server.codes" .= settingsCodes + <*> Toml.table mailCodec "mail" .= settingsMail + <*> Toml.list userCodec "user" .= settingsUsers + +mailCodec :: TomlCodec Mail +mailCodec = Mail + <$> 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 + +_Client :: TomlBiMap User Text +_Client = Toml.prism Client $ \case + Client n -> Right n + other -> Toml.wrongConstructor "Client" other + +userCodec :: TomlCodec User +userCodec = + Toml.match (_Admin >>> Toml._Integer) "id" + <|> Toml.match (_Client >>> Toml._Text) "name" +``` + +And now we're 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 + Right settings -> TIO.putStrLn $ Toml.encode settingsCodec settings +``` + +## Benchmarks and comparison with other libraries + +`tomland` is compared with other libraries. Since it uses 2-step approach with +converting text to intermediate AST and only then decoding Haskell type from +this AST, benchmarks are also implemented in a way to reflect this difference. + +| Library | parse :: Text -> AST | transform :: AST -> Haskell | +|--------------------|----------------------|-----------------------------| +| `tomland` | `387.5 μs` | `1.313 μs` | +| `htoml` | `801.2 μs` | `32.54 μs` | +| `htoml-megaparsec` | `318.7 μs` | `34.74 μs` | +| `toml-parser` | `157.2 μs` | `1.156 μs` | + +You may see that `tomland` is not the fastest one (though still very fast). But +performance hasn’t been optimized so far and: + +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: + +## 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/). diff --git a/benchmark/Benchmark/Htoml.hs b/benchmark/Benchmark/Htoml.hs --- a/benchmark/Benchmark/Htoml.hs +++ b/benchmark/Benchmark/Htoml.hs @@ -7,13 +7,13 @@ module Benchmark.Htoml ( decode - , convert , parse + , convert ) where -import Benchmark.Type (HaskellType) import Control.DeepSeq (NFData, rnf, rwhnf) import Data.Aeson.Types (parseEither, parseJSON) +import Data.Semigroup ((<>)) import Data.Text (Text) import GHC.Generics (Generic) import Text.Parsec.Error (ParseError) @@ -21,20 +21,22 @@ import "htoml" Text.Toml (parseTomlDoc) import "htoml" Text.Toml.Types (Node (..), Table, toJSON) +import Benchmark.Type (HaskellType) + -- | Decode toml file to Haskell type. decode :: Text -> Either String HaskellType decode txt = case parseTomlDoc "" txt of - Left _ -> error "Parsing failed" + Left err -> error $ "'htoml' parsing failed: " <> show err Right toml -> convert toml +-- | Wrapper on htoml's 'parseTomlDoc' +parse :: Text -> Either ParseError Table +parse = parseTomlDoc "" + -- | Convert from already parsed toml to Haskell type. convert :: Table -> Either String HaskellType convert = parseEither parseJSON . toJSON - --- | Wrapper on htoml's parseTomlDoc -parse :: Text -> Either ParseError Table -parse = parseTomlDoc "" deriving instance NFData Node deriving instance Generic Node diff --git a/benchmark/Benchmark/HtomlMegaparsec.hs b/benchmark/Benchmark/HtomlMegaparsec.hs --- a/benchmark/Benchmark/HtomlMegaparsec.hs +++ b/benchmark/Benchmark/HtomlMegaparsec.hs @@ -3,17 +3,24 @@ {-# LANGUAGE PackageImports #-} module Benchmark.HtomlMegaparsec - ( convert - , decode + ( decode , parse + , convert ) where import Data.Aeson.Types (ToJSON, parseEither, parseJSON, toJSON) +import Data.Semigroup ((<>)) import Data.Text (Text) + import "htoml-megaparsec" Text.Toml (Node (..), Table, TomlError, parseTomlDoc) import Benchmark.Type (HaskellType) +-- | Decode toml file to Haskell type. +decode :: Text -> Either String HaskellType +decode txt = case parseTomlDoc "log" txt of + Left err -> error $ "'htoml-megaparsec' parsing failed: " <> show err + Right toml -> convert toml -- | Wrapper on htoml-megaparsec's parseTomlDoc parse :: Text -> Either TomlError Table @@ -22,12 +29,6 @@ -- | Convert from already parsed toml to Haskell type. convert :: Table -> Either String HaskellType convert = parseEither parseJSON . toJSON - --- | Decode toml file to Haskell type. -decode :: Text -> Either String HaskellType -decode txt = case parseTomlDoc "log" txt of - Left _ -> error "Parsing failed" - Right toml -> convert toml -- | 'ToJSON' instances for the 'Node' type that produce Aeson (JSON) -- in line with the TOML specification. diff --git a/benchmark/Benchmark/TomlParser.hs b/benchmark/Benchmark/TomlParser.hs new file mode 100644 --- /dev/null +++ b/benchmark/Benchmark/TomlParser.hs @@ -0,0 +1,91 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Benchmark.TomlParser + ( decode + , parse + , convert + ) where + +import Control.DeepSeq (NFData, rnf, rwhnf) +import Data.Semigroup ((<>)) +import Data.Text (Text) +import GHC.Generics (Generic) + +import Benchmark.Type (FruitInside (..), HaskellType (..), SizeInside (..)) + +import qualified TOML + + +-- | Decode toml file to Haskell type. +decode :: Text -> Either String HaskellType +decode txt = case parse txt of + Left err -> error $ "'toml-parser' parsing failed: " <> show err + Right toml -> maybe (Left "Some error during conversion") Right $ convert toml + +-- | Wrapper over 'TOML.parseTOML' +parse :: Text -> Either TOML.TOMLError [(Text, TOML.Value)] +parse = TOML.parseTOML + +-- | Convert from already parsed toml to Haskell type. +convert :: [(Text, TOML.Value)] -> Maybe HaskellType +convert toml = do + TOML.String htTitle <- lookup "title" toml + TOML.Double htAtom <- lookup "atom" toml + TOML.Bool htCash <- lookup "cash" toml + + TOML.List tomlWords <- lookup "words" toml + htWords <- mapM matchText tomlWords + + TOML.List tomlBools <- lookup "bool" toml + htBool <- mapM matchBool tomlBools + + TOML.ZonedTimeV htToday <- lookup "today" toml + + TOML.List tomlInts <- lookup "ints" toml + htInteger <- mapM matchInteger tomlInts + + TOML.Table fruit <- lookup "fruit" toml + htFruit <- do + TOML.String fiName <- lookup "name" fruit + TOML.String fiDescription <- lookup "description" fruit + pure FruitInside{..} + + TOML.Table size <- lookup "size" toml + htSize <- do + TOML.List dimensions <- lookup "dimensions" size + arrays :: [[TOML.Value]] <- mapM matchArray dimensions + unSize <- mapM (mapM matchDouble) arrays + pure SizeInside{..} + + pure HaskellType{..} + +matchText :: TOML.Value -> Maybe Text +matchText (TOML.String t) = Just t +matchText _ = Nothing + +matchBool :: TOML.Value -> Maybe Bool +matchBool (TOML.Bool b) = Just b +matchBool _ = Nothing + +matchInteger :: TOML.Value -> Maybe Integer +matchInteger (TOML.Integer i) = Just i +matchInteger _ = Nothing + +matchArray :: TOML.Value -> Maybe [TOML.Value] +matchArray (TOML.List a) = Just a +matchArray _ = Nothing + +matchDouble :: TOML.Value -> Maybe Double +matchDouble (TOML.Double d) = Just d +matchDouble _ = Nothing + +deriving instance Generic TOML.Value +deriving instance NFData TOML.Value + +instance NFData TOML.TOMLError where + rnf = rwhnf diff --git a/benchmark/Benchmark/Tomland.hs b/benchmark/Benchmark/Tomland.hs --- a/benchmark/Benchmark/Tomland.hs +++ b/benchmark/Benchmark/Tomland.hs @@ -1,7 +1,7 @@ module Benchmark.Tomland - ( convert - , decode + ( decode , parse + , convert ) where import Data.Text (Text) @@ -11,7 +11,12 @@ import qualified Toml +decode :: Text -> Either DecodeException HaskellType +decode = Toml.decode codec +convert :: TOML -> Either DecodeException HaskellType +convert = Toml.runTomlCodec codec + -- | Codec to use in tomland decode and convert functions. codec :: TomlCodec HaskellType codec = HaskellType @@ -21,6 +26,7 @@ <*> Toml.arrayOf Toml._Text "words" .= htWords <*> Toml.arrayOf Toml._Bool "bool" .= htBool <*> Toml.zonedTime "today" .= htToday + <*> Toml.arrayOf Toml._Integer "ints" .= htInteger <*> Toml.table insideF "fruit" .= htFruit <*> Toml.table insideS "size" .= htSize @@ -30,11 +36,4 @@ <*> Toml.text "description" .= fiDescription insideS :: TomlCodec SizeInside -insideS = Toml.dimap unSize SizeInside $ - Toml.arrayOf (Toml._Array Toml._Double) "dimensions" - -convert :: TOML -> Either DecodeException HaskellType -convert = Toml.runTomlCodec codec - -decode :: Text -> Either DecodeException HaskellType -decode = Toml.decode codec +insideS = Toml.diwrap $ Toml.arrayOf (Toml._Array Toml._Double) "dimensions" diff --git a/benchmark/Benchmark/Type.hs b/benchmark/Benchmark/Type.hs --- a/benchmark/Benchmark/Type.hs +++ b/benchmark/Benchmark/Type.hs @@ -2,9 +2,9 @@ {-# LANGUAGE DeriveGeneric #-} module Benchmark.Type - ( HaskellType(..) - , FruitInside(..) - , SizeInside(..) + ( HaskellType (..) + , FruitInside (..) + , SizeInside (..) ) where import Control.DeepSeq (NFData) @@ -16,14 +16,15 @@ -- | Haskell type to convert to. data HaskellType = HaskellType - { htTitle :: Text - , htAtom :: Double - , htCash :: Bool - , htWords :: [Text] - , htBool :: [Bool] - , htToday :: ZonedTime - , htFruit :: FruitInside - , htSize :: SizeInside + { htTitle :: Text + , htAtom :: Double + , htCash :: Bool + , htWords :: [Text] + , htBool :: [Bool] + , htToday :: ZonedTime + , htInteger :: [Integer] + , htFruit :: FruitInside + , htSize :: SizeInside } deriving (Show, NFData, Generic) instance FromJSON HaskellType where @@ -34,6 +35,7 @@ <*> o .: "words" <*> o .: "bool" <*> o .: "today" + <*> o .: "ints" <*> o .: "fruit" <*> o .: "size" diff --git a/benchmark/Main.hs b/benchmark/Main.hs --- a/benchmark/Main.hs +++ b/benchmark/Main.hs @@ -7,6 +7,7 @@ import qualified Benchmark.Htoml as Htoml import qualified Benchmark.HtomlMegaparsec as HtomlM import qualified Benchmark.Tomland as Tomland +import qualified Benchmark.TomlParser as TomlParser import qualified Data.Text.IO as TIO @@ -17,20 +18,24 @@ Right tomlandVal <- pure $ Tomland.parse txt Right htomlVal <- pure $ Htoml.parse txt Right htomlMegaVal <- pure $ HtomlM.parse txt + Right tomlParserVal <- pure $ TomlParser.parse txt defaultMain [ bgroup "Parse" [ bench "tomland" $ nf Tomland.parse txt , bench "htoml" $ nf Htoml.parse txt , bench "htoml-megaparsec" $ nf HtomlM.parse txt + , bench "toml-parser" $ nf TomlParser.parse txt ] , bgroup "Convert" [ bench "tomland" $ nf Tomland.convert tomlandVal , bench "htoml" $ nf Htoml.convert htomlVal , bench "htoml-megaparsec" $ nf HtomlM.convert htomlMegaVal + , bench "toml-parser" $ nf TomlParser.convert tomlParserVal ] , bgroup "Decode" [ bench "tomland" $ nf Tomland.decode txt , bench "htoml" $ nf Htoml.decode txt , bench "htoml-megaparsec" $ nf HtomlM.decode txt + , bench "toml-parser" $ nf TomlParser.decode txt ] ] diff --git a/examples/Playground.hs b/examples/Playground.hs --- a/examples/Playground.hs +++ b/examples/Playground.hs @@ -1,5 +1,7 @@ -module Main where +{-# OPTIONS -Wno-unused-top-binds #-} +module Main (main) where + import Control.Applicative ((<|>)) import Control.Arrow ((>>>)) import Data.Text (Text) @@ -7,12 +9,26 @@ import Toml (ParseException (..), TomlCodec, pretty, (.=), ()) import Toml.Edsl (mkToml, table, (=:)) -import Toml.Type (DateTime (..), TOML (..), Value (..)) +import Toml.Type (TOML (..), Value (..)) import qualified Data.Text.IO as TIO import qualified Toml +newtype TestInside = TestInside { unInside :: Text } +insideCodec :: TomlCodec TestInside +insideCodec = Toml.dimap unInside TestInside $ Toml.text "inside" + +data User = User + { userName :: Text + , userAge :: Int + } + +userCodec :: TomlCodec User +userCodec = User + <$> Toml.text "name" .= userName + <*> Toml.int "age" .= userAge + newtype N = N Text data Test = Test @@ -27,13 +43,10 @@ , testN :: N , testE1 :: Either Integer String , testE2 :: Either String Double + , users :: [User] } -newtype TestInside = TestInside { unInside :: Text } -insideT :: TomlCodec TestInside -insideT = Toml.dimap unInside TestInside $ Toml.text "inside" - testT :: TomlCodec Test testT = Test <$> Toml.bool "testB" .= testB @@ -42,11 +55,12 @@ <*> Toml.text "testS" .= testS <*> Toml.arrayOf Toml._Text "testA" .= testA <*> Toml.dioptional (Toml.bool "testM") .= testM - <*> Toml.table insideT "testX" .= testX - <*> Toml.dioptional ((Toml.table insideT) "testY") .= testY - <*> Toml.wrapper Toml.text "testN" .= testN + <*> Toml.table insideCodec "testX" .= testX + <*> Toml.dioptional ((Toml.table insideCodec) "testY") .= testY + <*> Toml.diwrap (Toml.text "testN") .= testN <*> eitherT1 .= testE1 <*> eitherT2 .= testE2 + <*> Toml.list userCodec "user" .= users where -- different keys for sum type eitherT1 :: TomlCodec (Either Integer String) @@ -66,11 +80,11 @@ TIO.putStrLn "=== Printing manually specified TOML ===" TIO.putStrLn $ pretty myToml - TIO.putStrLn "=== Printing parsed TOML ===" - content <- TIO.readFile "test.toml" - case Toml.parse content of - Left (ParseException e) -> TIO.putStrLn e - Right toml -> TIO.putStrLn $ pretty toml + TIO.putStrLn "=== Trying to print invalid TOML ===" + content <- TIO.readFile "examples/invalid.toml" + TIO.putStrLn $ case Toml.parse content of + Left (ParseException e) -> e + Right toml -> pretty toml TIO.putStrLn "=== Testing bidirectional conversion ===" biFile <- TIO.readFile "examples/biTest.toml" @@ -82,7 +96,7 @@ myToml = mkToml $ do "a" =: Bool True "list" =: Array ["one", "two"] - "time" =: Array [Date $ Day (fromGregorian 2018 3 29)] + "time" =: Array [Day (fromGregorian 2018 3 29)] table "table.name.1" $ do "aInner" =: 1 "listInner" =: Array [Bool True, Bool False] diff --git a/src/Toml.hs b/src/Toml.hs --- a/src/Toml.hs +++ b/src/Toml.hs @@ -1,14 +1,37 @@ {- | This module reexports all functionality of @tomland@ package. It's -suggested to import this module qualified, like this: +recommended to import this module qualified, like this: @ -import qualified Toml +__import__ Toml (TomlCodec, (.=)) +__import__ __qualified__ Toml @ + +Simple @'TomlCodec'@ could be written in the following way: + +@ +__data__ User = User + { userName :: Text + , userAge :: Int + } + +userCodec :: 'TomlCodec' User +userCodec = User + \<$\> Toml.'text' "name" '.=' userName + \<*\> Toml.'int' "age" '.=' userAge +@ + +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.BiMap , module Toml.Parser , module Toml.PrefixTree , module Toml.Printer @@ -16,7 +39,6 @@ ) where import Toml.Bi -import Toml.BiMap import Toml.Parser import Toml.PrefixTree import Toml.Printer diff --git a/src/Toml/Bi.hs b/src/Toml/Bi.hs --- a/src/Toml/Bi.hs +++ b/src/Toml/Bi.hs @@ -1,11 +1,22 @@ --- | Reexports functions under @Toml.Bi.*@. +{- | 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 --- a/src/Toml/Bi/Code.hs +++ b/src/Toml/Bi/Code.hs @@ -1,5 +1,8 @@ {-# LANGUAGE DeriveAnyClass #-} +{- | Coding functions like 'decode' and 'encode'. Also contains specialization of 'Codec' for TOML. +-} + module Toml.Bi.Code ( -- * Types TomlCodec @@ -32,6 +35,7 @@ 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) @@ -41,15 +45,19 @@ 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. +-- | Type of exception for converting from TOML to user custom data type. data DecodeException = TrivialError + | BiMapError TomlBiMapError | KeyNotFound Key -- ^ No such key | TableNotFound Key -- ^ No such table | TypeMismatch Key Text TValue -- ^ Expected type vs actual type | ParseError ParseException -- ^ Exception during parsing - deriving (Eq, Show, Generic, NFData) -- TODO: manual pretty show instances + deriving (Eq, Generic, NFData) +instance Show DecodeException where + show = Text.unpack . prettyException + instance Semigroup DecodeException where TrivialError <> e = e e <> _ = e @@ -60,22 +68,24 @@ -- | Converts 'DecodeException' into pretty human-readable text. prettyException :: DecodeException -> Text -prettyException = \case - TrivialError -> "Using 'empty' parser" - KeyNotFound name -> "Key " <> joinKey name <> " not found" - TableNotFound name -> "Table [" <> joinKey name <> "] not found" - TypeMismatch name expected actual -> "Expected type " <> expected <> " for key " <> joinKey name - <> " but got: " <> Text.pack (showType actual) +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. +-- | 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. +{- | Mutable context for TOML conversion. This is @w@ type variable in 'Codec' data type. @ @@ -86,8 +96,9 @@ -} type St = MaybeT (State TOML) --- | Specialied 'Bi' type alias for 'Toml' monad. Keeps 'TOML' object either as --- environment or state. +{- | 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. @@ -104,6 +115,7 @@ 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 diff --git a/src/Toml/Bi/Combinators.hs b/src/Toml/Bi/Combinators.hs --- a/src/Toml/Bi/Combinators.hs +++ b/src/Toml/Bi/Combinators.hs @@ -5,84 +5,99 @@ -- | Contains TOML-specific combinators for converting between TOML and user data types. module Toml.Bi.Combinators - ( -- * Toml codecs + ( -- * Basic codecs for primitive values + -- ** Boolean bool - , int + -- ** Integral numbers , integer , natural + , int , word + -- ** Floating point numbers , double , float + -- ** Text types , text - , read - , string + , lazyText , byteString , lazyByteString + , string + -- ** Time types , zonedTime , localTime , day , timeOfDay + + -- * Codecs for containers of primitives , arrayOf , arraySetOf , arrayIntSet , arrayHashSetOf , arrayNonEmptyOf - -- * Combinators - , match + -- * Additional codecs for custom types + , textBy + , read + + -- * Combinators for tables , table - , wrapper - , mdimap + , nonEmpty + , list + + -- * General construction of codecs + , match ) where -import Control.Monad.Except (MonadError, catchError, throwError) +import Prelude hiding (read) + +import Control.Monad (forM) +import Control.Monad.Except (catchError, throwError) import Control.Monad.Reader (asks, local) import Control.Monad.State (execState, gets, modify) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) -import Data.Coerce (Coercible, coerce) +import Data.ByteString (ByteString) +import Data.Hashable (Hashable) +import Data.HashSet (HashSet) +import Data.IntSet (IntSet) +import Data.List.NonEmpty (NonEmpty (..), toList) import Data.Maybe (fromMaybe) -import Data.Proxy (Proxy (..)) import Data.Semigroup ((<>)) +import Data.Set (Set) import Data.Text (Text) -import Data.Typeable (Typeable, typeRep) import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime) -import Data.ByteString (ByteString) import Data.Word (Word) import Numeric.Natural (Natural) -import Data.Hashable (Hashable) -import Data.Set (Set) -import Data.HashSet (HashSet) -import Data.IntSet (IntSet) -import Data.List.NonEmpty (NonEmpty) -import Toml.Bi.Code (DecodeException (..), Env, St, TomlCodec) -import Toml.Bi.Monad (Codec (..), dimap) -import Toml.BiMap (BiMap (..), _Array, _Bool, _Double, - _Integer, _String, _Text, _ZonedTime, _LocalTime, _Day, - _TimeOfDay, _Int, _Word, _Natural, _Float, _Read, - _ByteString, _LByteString, _Set, _IntSet, _HashSet, - _NonEmpty) -import Toml.Parser (ParseException (..)) +import Toml.Bi.Code (DecodeException (..), Env, St, TomlCodec, execTomlCodec) +import Toml.Bi.Map (BiMap (..), TomlBiMap, _Array, _Bool, _ByteString, _Day, _Double, _Float, + _HashSet, _Int, _IntSet, _Integer, _LByteString, _LText, _LocalTime, _Natural, + _NonEmpty, _Read, _Set, _String, _Text, _TextBy, _TimeOfDay, _Word, _ZonedTime) +import Toml.Bi.Monad (Codec (..)) import Toml.PrefixTree (Key) -import Toml.Type (AnyValue (..), TOML (..), insertKeyAnyVal, insertTable, valueType) - -import Prelude hiding (read) +import Toml.Type (AnyValue (..), TOML (..), insertKeyAnyVal, insertTable, insertTableArrays) +import qualified Data.ByteString.Lazy as BL import qualified Data.HashMap.Strict as HashMap -import qualified Data.Text as Text import qualified Toml.PrefixTree as Prefix -import qualified Data.ByteString.Lazy as BL +import qualified Data.Text.Lazy as L ----------------------------------------------------------------------------- --- Generalized versions of parsers ----------------------------------------------------------------------------- -typeName :: forall a . Typeable a => Text -typeName = Text.pack $ show $ typeRep $ Proxy @a +{- | 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': -{- | General function to create bidirectional converters for values. +@ +_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 . Typeable a => BiMap a AnyValue -> Key -> TomlCodec a +match :: forall a . TomlBiMap a AnyValue -> Key -> TomlCodec a match BiMap{..} key = Codec input output where input :: Env a @@ -90,146 +105,132 @@ mVal <- asks $ HashMap.lookup key . tomlPairs case mVal of Nothing -> throwError $ KeyNotFound key - Just anyVal@(AnyValue val) -> case backward anyVal of - Just v -> pure v - Nothing -> throwError $ TypeMismatch key (typeName @a) (valueType val) + 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 $ forward a + anyVal <- MaybeT $ pure $ either (const Nothing) Just $ forward a a <$ modify (insertKeyAnyVal key anyVal) -{- | Almost same as 'dimap'. Useful when you want to have fields like this -inside your configuration: - -@ -data GhcVer = Ghc7103 | Ghc802 | Ghc822 | Ghc842 - -showGhcVer :: GhcVer -> Text -parseGhcVer :: Text -> Maybe GhcVer -@ - -When you specify couple of functions of the following types: - -@ -show :: a -> Text -parse :: Text -> Maybe a -@ - -they should satisfy property @parse . show == Just@ if you want to use your -converter for pretty-printing. --} -mdimap :: (Monad r, Monad w, MonadError DecodeException r) - => (c -> d) -- ^ Convert from safe to unsafe value - -> (a -> Maybe b) -- ^ Parser for more type safe value - -> Codec r w d a -- ^ Source 'Codec' object - -> Codec r w c b -mdimap toString toMaybe codec = Codec - { codecRead = (toMaybe <$> codecRead codec) >>= \case - Nothing -> throwError $ ParseError $ ParseException "Can't parse" -- TODO - Just b -> pure b - - , codecWrite = \s -> do - retS <- codecWrite codec $ toString s - case toMaybe retS of - Nothing -> error $ "Given pair of functions for 'mdimap' doesn't satisfy roundtrip property" - Just b -> pure b - } - ----------------------------------------------------------------------------- --- Toml parsers ----------------------------------------------------------------------------- - --- | Parser for boolean values. +-- | Codec for boolean values. bool :: Key -> TomlCodec Bool bool = match _Bool --- | Parser for integer values. +-- | Codec for integer values. integer :: Key -> TomlCodec Integer integer = match _Integer --- | Parser for integer values. +-- | Codec for integer values. int :: Key -> TomlCodec Int int = match _Int --- | Parser for natural values. +-- | Codec for natural values. natural :: Key -> TomlCodec Natural natural = match _Natural --- | Parser for word values. +-- | Codec for word values. word :: Key -> TomlCodec Word word = match _Word --- | Parser for floating point values as double. +-- | Codec for floating point values with double precision. double :: Key -> TomlCodec Double double = match _Double --- | Parser for floating point values as float. +-- | Codec for floating point values. float :: Key -> TomlCodec Float float = match _Float --- | Parser for string values as text. +-- | Codec for text values. text :: Key -> TomlCodec Text text = match _Text --- | Parser for string values as string. +-- | Codec for lazy text values. +lazyText :: Key -> TomlCodec L.Text +lazyText = match _LText + +-- | Codec for text values with custom error messages for parsing. +textBy :: (a -> Text) -> (Text -> Either Text a) -> Key -> TomlCodec a +textBy to from = match (_TextBy to from) + +-- | Codec for string values. string :: Key -> TomlCodec String string = match _String --- | Parser for values with a `Read` and `Show` instance. -read :: (Show a, Read a, Typeable a) => Key -> TomlCodec a +-- | Codec for values with a 'Read' and 'Show' instance. +read :: (Show a, Read a) => Key -> TomlCodec a read = match _Read --- | Parser for byte vectors values as strict bytestring. +-- | Codec for text values as 'ByteString'. byteString :: Key -> TomlCodec ByteString byteString = match _ByteString --- | Parser for byte vectors values as lazy bytestring. +-- | Codec for text values as 'BL.ByteString'. lazyByteString :: Key -> TomlCodec BL.ByteString lazyByteString = match _LByteString --- | Parser for zoned time values. +-- | Codec for zoned time values. zonedTime :: Key -> TomlCodec ZonedTime zonedTime = match _ZonedTime --- | Parser for local time values. +-- | Codec for local time values. localTime :: Key -> TomlCodec LocalTime localTime = match _LocalTime --- | Parser for day values. +-- | Codec for day values. day :: Key -> TomlCodec Day day = match _Day --- | Parser for time of day values. +-- | Codec for time of day values. timeOfDay :: Key -> TomlCodec TimeOfDay timeOfDay = match _TimeOfDay --- | Parser for list of values. Takes converter for single value and +-- | Codec for list of values. Takes converter for single value and -- returns a list of values. -arrayOf :: Typeable a => BiMap a AnyValue -> Key -> TomlCodec [a] +arrayOf :: TomlBiMap a AnyValue -> Key -> TomlCodec [a] arrayOf = match . _Array --- | Parser for sets. Takes converter for single value and +-- | Codec for sets. Takes converter for single value and -- returns a set of values. -arraySetOf :: (Typeable a, Ord a) => BiMap a AnyValue -> Key -> TomlCodec (Set a) +arraySetOf :: Ord a => TomlBiMap a AnyValue -> Key -> TomlCodec (Set a) arraySetOf = match . _Set --- | Parser for sets of ints. Takes converter for single value and +-- | Codec for sets of ints. Takes converter for single value and -- returns a set of ints. arrayIntSet :: Key -> TomlCodec IntSet arrayIntSet = match _IntSet --- | Parser for hash sets. Takes converter for single hashable value and +-- | Codec for hash sets. Takes converter for single hashable value and -- returns a set of hashable values. -arrayHashSetOf :: (Typeable a, Hashable a, Eq a) => BiMap a AnyValue -> Key -> TomlCodec (HashSet a) +arrayHashSetOf + :: (Hashable a, Eq a) + => TomlBiMap a AnyValue + -> Key + -> TomlCodec (HashSet a) arrayHashSetOf = match . _HashSet --- | Parser for non- empty lists of values. Takes converter for single value and +-- | Codec for non- empty lists of values. Takes converter for single value and -- returns a non-empty list of values. -arrayNonEmptyOf :: Typeable a => BiMap a AnyValue -> Key -> TomlCodec (NonEmpty a) +arrayNonEmptyOf :: TomlBiMap a AnyValue -> Key -> TomlCodec (NonEmpty a) arrayNonEmptyOf = match . _NonEmpty --- | Parser for tables. Use it when when you have nested objects. +{- | 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 @@ -238,7 +239,7 @@ mTable <- asks $ Prefix.lookup key . tomlTables case mTable of Nothing -> throwError $ TableNotFound key - Just toml -> local (const toml) (codecRead codec) `catchError` handleTableName + Just toml -> codecReadTOML toml codec `catchError` handleErrorInTable key output :: a -> St a output a = do @@ -247,12 +248,42 @@ let newToml = execState (runMaybeT $ codecWrite codec a) toml a <$ modify (insertTable key newToml) - handleTableName :: DecodeException -> Env a - handleTableName (KeyNotFound name) = throwError $ KeyNotFound (key <> name) - handleTableName (TableNotFound name) = throwError $ TableNotFound (key <> name) - handleTableName (TypeMismatch name t1 t2) = throwError $ TypeMismatch (key <> name) t1 t2 - handleTableName e = throwError e +{- | '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 --- | Used for @newtype@ wrappers. -wrapper :: forall b a . Coercible a b => (Key -> TomlCodec a) -> Key -> TomlCodec b -wrapper bi key = dimap coerce coerce (bi 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 diff --git a/src/Toml/Bi/Map.hs b/src/Toml/Bi/Map.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Bi/Map.hs @@ -0,0 +1,471 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} + +{- | Implementation of tagged partial bidirectional isomorphism. +-} + +module Toml.Bi.Map + ( -- * BiMap idea + BiMap (..) + , TomlBiMap + , invert + , iso + , prism + + -- * 'BiMap' errors for TOML + , TomlBiMapError (..) + , wrongConstructor + , prettyBiMapError + + -- * Helpers for BiMap and AnyValue + , mkAnyValueBiMap + , _TextBy + , _LTextText + , _NaturalInteger + , _StringText + , _ReadString + , _BoundedInteger + , _ByteStringText + , _LByteStringText + + -- * Some predefined bi mappings + , _Array + , _Bool + , _Double + , _Integer + , _Text + , _LText + , _ZonedTime + , _LocalTime + , _Day + , _TimeOfDay + , _String + , _Read + , _Natural + , _Word + , _Int + , _Float + , _ByteString + , _LByteString + , _Set + , _IntSet + , _HashSet + , _NonEmpty + + , _Left + , _Right + , _Just + + -- * Useful utility functions + , toMArray + ) where + +import Control.Arrow ((>>>)) +import Control.Monad ((>=>)) + +import Control.DeepSeq (NFData) +import Data.Bifunctor (bimap, first) +import Data.ByteString (ByteString) +import Data.Hashable (Hashable) +import Data.Semigroup (Semigroup (..)) +import Data.Text (Text) +import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime) +import Data.Word (Word) +import GHC.Generics (Generic) +import Numeric.Natural (Natural) +import Text.Read (readEither) + +import Toml.Type (AnyValue (..), MatchError (..), TValue (..), Value (..), applyAsToAny, matchBool, + matchDay, matchDouble, matchHours, matchInteger, matchLocal, matchText, + matchZoned, mkMatchError, toMArray) + +import qualified Control.Category as Cat +import qualified Data.ByteString.Lazy as BL +import qualified Data.HashSet as HS +import qualified Data.IntSet as IS +import qualified Data.List.NonEmpty as NE +import qualified Data.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 + + (.) :: BiMap e b c -> BiMap e a b -> BiMap e a c + bc . ab = BiMap + { forward = forward ab >=> forward bc + , backward = backward bc >=> backward ab + } + +-- | Inverts bidirectional mapping. +invert :: BiMap e a b -> BiMap e b a +invert (BiMap f g) = BiMap g f + +{- | Creates 'BiMap' from isomorphism. Can be used in the following way: + +@ +__newtype__ Even = Even Integer +__newtype__ Odd = Odd Integer + +succEven :: Even -> Odd +succEven (Even n) = Odd (n + 1) + +predOdd :: Odd -> Even +predOdd (Odd n) = Even (n - 1) + +_EvenOdd :: 'BiMap' e Even Odd +_EvenOdd = 'iso' succEven predOdd +@ +-} +iso :: (a -> b) -> (b -> a) -> BiMap e a b +iso f g = BiMap (Right . f) (Right . g) + +{- | Creates 'BiMap' from prism-like pair of functions. This combinator can be +used to create 'BiMap' for custom data types like this: + +@ +__data__ User + = Admin Integer -- id of admin + | Client Text -- name of the client + __deriving__ (Show) + +_Admin :: 'TomlBiMap' User Integer +_Admin = Toml.'prism' Admin $ \\__case__ + Admin i -> Right i + other -> Toml.'wrongConstructor' \"Admin\" other + +_Client :: 'TomlBiMap' User Text +_Client = Toml.'prism' Client $ \\__case__ + Client n -> Right n + other -> Toml.'wrongConstructor' \"Client\" other +@ +-} +prism :: (field -> object) -> (object -> Either error field) -> BiMap error object field +prism review preview = BiMap preview (Right . review) + +---------------------------------------------------------------------------- +-- BiMap error types +---------------------------------------------------------------------------- + +-- | 'BiMap' specialized to TOML error. +type TomlBiMap = BiMap TomlBiMapError + +-- | Type of errors for TOML 'BiMap'. +data TomlBiMapError + = WrongConstructor -- ^ Error for cases with wrong constructors. For + -- example, you're trying to convert 'Left' but + -- bidirectional converter expects 'Right'. + Text -- ^ Expected constructor name + Text -- ^ Actual value + | WrongValue -- ^ Error for cases with wrong values + MatchError -- ^ Information about failed matching + | ArbitraryError -- ^ Arbitrary textual error + Text -- ^ Error message + deriving (Eq, Show, Generic, NFData) + +-- | Converts 'TomlBiMapError' into pretty human-readable text. +prettyBiMapError :: TomlBiMapError -> Text +prettyBiMapError = \case + WrongConstructor expected actual -> T.unlines + [ "Invalid constructor" + , " * Expected: " <> expected + , " * Actual: " <> actual + ] + WrongValue (MatchError expected actual) -> T.unlines + [ "Invalid constructor" + , " * Expected: " <> tShow expected + , " * Actual: " <> tShow actual + ] + ArbitraryError text -> text + +-- | Helper to construct WrongConstuctor error. +wrongConstructor + :: Show a + => Text -- ^ Name of the expected constructor + -> a -- ^ Actual value + -> Either TomlBiMapError b +wrongConstructor constructor x = Left $ WrongConstructor constructor (tShow x) + +---------------------------------------------------------------------------- +-- General purpose bimaps +---------------------------------------------------------------------------- + +-- | Bimap for 'Either' and its left type +_Left :: (Show l, Show r) => TomlBiMap (Either l r) l +_Left = prism Left $ \case + Left l -> Right l + x -> wrongConstructor "Left" x + +-- | Bimap for 'Either' and its right type +_Right :: (Show l, Show r) => TomlBiMap (Either l r) r +_Right = prism Right $ \case + Right r -> Right r + x -> wrongConstructor "Right" x + +-- | Bimap for 'Maybe' +_Just :: Show r => TomlBiMap (Maybe r) r +_Just = prism Just $ \case + Just r -> Right r + x -> wrongConstructor "Just" x + +---------------------------------------------------------------------------- +-- BiMaps for value +---------------------------------------------------------------------------- + +-- | Creates prism for 'AnyValue'. +mkAnyValueBiMap + :: forall a (tag :: TValue) . (forall (t :: TValue) . Value t -> Either MatchError a) + -> (a -> Value tag) + -> TomlBiMap a AnyValue +mkAnyValueBiMap matchValue toValue = BiMap + { forward = Right . toAnyValue + , backward = fromAnyValue + } + where + toAnyValue :: a -> AnyValue + toAnyValue = AnyValue . toValue + + fromAnyValue :: AnyValue -> Either TomlBiMapError a + fromAnyValue (AnyValue value) = first WrongValue $ matchValue value + +-- | Creates bimap for 'Data.Text.Text' to 'AnyValue' with custom functions +_TextBy + :: forall a . + (a -> Text) -- ^ @show@ function for @a@ + -> (Text -> Either Text a) -- ^ Parser of @a@ from 'Data.Text.Text' + -> TomlBiMap a AnyValue +_TextBy toText parseText = BiMap toAnyValue fromAnyValue + where + toAnyValue :: a -> Either TomlBiMapError AnyValue + toAnyValue = Right . AnyValue . Text . toText + + fromAnyValue :: AnyValue -> Either TomlBiMapError a + fromAnyValue (AnyValue v) = + first WrongValue (matchText v) >>= first ArbitraryError . parseText + +{- | 'Prelude.Bool' bimap for 'AnyValue'. Usually used as +'Toml.Bi.Combinators.bool' combinator. +-} +_Bool :: TomlBiMap Bool AnyValue +_Bool = mkAnyValueBiMap matchBool Bool + +{- | 'Prelude.Integer' bimap for 'AnyValue'. Usually used as +'Toml.Bi.Combinators.integer' combinator. +-} +_Integer :: TomlBiMap Integer AnyValue +_Integer = mkAnyValueBiMap matchInteger Integer + +{- | 'Prelude.Double' bimap for 'AnyValue'. Usually used as +'Toml.Bi.Combinators.double' combinator. +-} +_Double :: TomlBiMap Double AnyValue +_Double = mkAnyValueBiMap matchDouble Double + +{- | 'Data.Text.Text' bimap for 'AnyValue'. Usually used as +'Toml.Bi.Combinators.text' combinator. +-} +_Text :: TomlBiMap Text AnyValue +_Text = mkAnyValueBiMap matchText Text + +-- | Helper bimap for 'Data.Text.Lazy.Text' and 'Data.Text.Text'. +_LTextText :: BiMap e TL.Text Text +_LTextText = iso TL.toStrict TL.fromStrict + +{- | 'Data.Text.Lazy.Text' bimap for 'AnyValue'. Usually used as +'Toml.Bi.Combinators.lazyText' combinator. +-} +_LText :: TomlBiMap TL.Text AnyValue +_LText = _LTextText >>> _Text + +{- | 'Data.Time.ZonedTime' bimap for 'AnyValue'. Usually used as +'Toml.Bi.Combinators.zonedTime' combinator. +-} +_ZonedTime :: TomlBiMap ZonedTime AnyValue +_ZonedTime = mkAnyValueBiMap matchZoned Zoned + +{- | 'Data.Time.LocalTime' bimap for 'AnyValue'. Usually used as +'Toml.Bi.Combinators.localTime' combinator. +-} +_LocalTime :: TomlBiMap LocalTime AnyValue +_LocalTime = mkAnyValueBiMap matchLocal Local + +{- | 'Data.Time.Day' bimap for 'AnyValue'. Usually used as +'Toml.Bi.Combinators.day' combinator. +-} +_Day :: TomlBiMap Day AnyValue +_Day = mkAnyValueBiMap matchDay Day + +{- | 'Data.Time.TimeOfDay' bimap for 'AnyValue'. Usually used as +'Toml.Bi.Combinators.timeOfDay' combinator. +-} +_TimeOfDay :: TomlBiMap TimeOfDay AnyValue +_TimeOfDay = mkAnyValueBiMap matchHours Hours + +-- | Helper bimap for 'String' and 'Data.Text.Text'. +_StringText :: BiMap e String Text +_StringText = iso T.pack T.unpack + +{- | 'String' bimap for 'AnyValue'. Usually used as +'Toml.Bi.Combinators.string' combinator. +-} +_String :: TomlBiMap String AnyValue +_String = _StringText >>> _Text + +-- | Helper bimap for 'String' and types with 'Read' and 'Show' instances. +_ReadString :: (Show a, Read a) => TomlBiMap a String +_ReadString = BiMap (Right . show) (first (ArbitraryError . T.pack) . readEither) + +-- | Bimap for 'AnyValue' and values with a 'Read' and 'Show' instance. +-- Usually used as 'Toml.Bi.Combinators.read' combinator. +_Read :: (Show a, Read a) => TomlBiMap a AnyValue +_Read = _ReadString >>> _String + +-- | Helper bimap for 'Natural' and 'Prelude.Integer'. +_NaturalInteger :: TomlBiMap Natural Integer +_NaturalInteger = BiMap (Right . toInteger) eitherInteger + where + eitherInteger :: Integer -> Either TomlBiMapError Natural + eitherInteger n + | n < 0 = Left $ ArbitraryError $ "Value is below zero, but expected Natural: " <> tShow n + | otherwise = Right (fromIntegral n) + +{- | 'String' bimap for 'AnyValue'. Usually used as +'Toml.Bi.Combinators.natural' combinator. +-} +_Natural :: TomlBiMap Natural AnyValue +_Natural = _NaturalInteger >>> _Integer + +-- | Helper bimap for 'Prelude.Integer' and integral, bounded values. +_BoundedInteger :: (Integral a, Bounded a, Show a) => TomlBiMap a Integer +_BoundedInteger = BiMap (Right . toInteger) eitherBounded + where + eitherBounded :: forall a. (Integral a, Bounded a, Show a) => Integer -> Either TomlBiMapError a + eitherBounded n + | n < toInteger (minBound @a) = + let msg = "Value " <> tShow n <> " is less than minBound: " <> tShow (minBound @a) + in Left $ ArbitraryError msg + | n > toInteger (maxBound @a) = + let msg = "Value " <> tShow n <> " is greater than maxBound: " <> tShow (maxBound @a) + in Left $ ArbitraryError msg + | otherwise = Right (fromIntegral n) + +{- | 'Word' bimap for 'AnyValue'. Usually used as +'Toml.Bi.Combinators.word' combinator. +-} +_Word :: TomlBiMap Word AnyValue +_Word = _BoundedInteger >>> _Integer + +{- | 'Int' bimap for 'AnyValue'. Usually used as +'Toml.Bi.Combinators.int' combinator. +-} +_Int :: TomlBiMap Int AnyValue +_Int = _BoundedInteger >>> _Integer + +{- | 'Float' bimap for 'AnyValue'. Usually used as +'Toml.Bi.Combinators.float' combinator. +-} +_Float :: TomlBiMap Float AnyValue +_Float = iso realToFrac realToFrac >>> _Double + +-- | Helper bimap for 'Data.Text.Text' and strict 'ByteString' +_ByteStringText :: TomlBiMap ByteString Text +_ByteStringText = prism T.encodeUtf8 eitherText + where + eitherText :: ByteString -> Either TomlBiMapError Text + eitherText = either (\err -> Left $ ArbitraryError $ tShow err) Right . T.decodeUtf8' + +-- | UTF8 encoded 'ByteString' bimap for 'AnyValue'. +-- Usually used as 'Toml.Bi.Combinators.byteString' combinator. +_ByteString :: TomlBiMap ByteString AnyValue +_ByteString = _ByteStringText >>> _Text + +-- | Helper bimap for 'Data.Text.Text' and lazy 'BL.ByteString'. +_LByteStringText :: TomlBiMap BL.ByteString Text +_LByteStringText = prism (TL.encodeUtf8 . TL.fromStrict) eitherText + where + eitherText :: BL.ByteString -> Either TomlBiMapError Text + eitherText = bimap (ArbitraryError . tShow) TL.toStrict . TL.decodeUtf8' + +-- | UTF8 encoded lazy 'BL.ByteString' bimap for 'AnyValue'. +-- Usually used as 'Toml.Bi.Combinators.lazyByteString' combinator. +_LByteString :: TomlBiMap BL.ByteString AnyValue +_LByteString = _LByteStringText >>> _Text + +-- | Takes a bimap of a value and returns a bimap between a list of values and 'AnyValue' +-- as an array. Usually used as 'Toml.Bi.Combinators.arrayOf' combinator. +_Array :: forall a . TomlBiMap a AnyValue -> TomlBiMap [a] AnyValue +_Array elementBimap = BiMap toAnyValue fromAnyValue + where + toAnyValue :: [a] -> Either TomlBiMapError AnyValue + toAnyValue = mapM (forward elementBimap) >=> bimap WrongValue AnyValue . toMArray + + fromAnyValue :: AnyValue -> Either TomlBiMapError [a] + fromAnyValue (AnyValue v) = matchElements (backward elementBimap) v + + -- can't reuse matchArray here :( + matchElements :: (AnyValue -> Either TomlBiMapError a) -> Value t -> Either TomlBiMapError [a] + matchElements match (Array a) = mapM (applyAsToAny match) a + matchElements _ val = first WrongValue $ mkMatchError TArray val + + +-- | Takes a bimap of a value and returns a bimap between a non-empty list of values and 'AnyValue' +-- as an array. Usually used as 'Toml.Bi.Combinators.nonEmpty' combinator. +_NonEmpty :: TomlBiMap a AnyValue -> TomlBiMap (NE.NonEmpty a) AnyValue +_NonEmpty bi = _NonEmptyArray >>> _Array bi + +_NonEmptyArray :: TomlBiMap (NE.NonEmpty a) [a] +_NonEmptyArray = BiMap + { forward = Right . NE.toList + , backward = maybe (Left $ ArbitraryError "Empty array list, but expected NonEmpty") Right . NE.nonEmpty + } + +-- | Takes a bimap of a value and returns a bimap between a set of values and 'AnyValue' +-- as an array. Usually used as 'Toml.Bi.Combinators.arraySetOf' combinator. +_Set :: (Ord a) => TomlBiMap a AnyValue -> TomlBiMap (S.Set a) AnyValue +_Set bi = iso S.toList S.fromList >>> _Array bi + +-- | Takes a bimap of a value and returns a bimap between a hash set of values and 'AnyValue' +-- as an array. Usually used as 'Toml.Bi.Combinators.arrayHashSetOf' combinator. +_HashSet :: (Eq a, Hashable a) => TomlBiMap a AnyValue -> TomlBiMap (HS.HashSet a) AnyValue +_HashSet bi = iso HS.toList HS.fromList >>> _Array bi + +{- | 'IS.IntSet' bimap for 'AnyValue'. Usually used as +'Toml.Bi.Combinators.arrayIntSetOf' combinator. +-} +_IntSet :: TomlBiMap IS.IntSet AnyValue +_IntSet = iso IS.toList IS.fromList >>> _Array _Int + +tShow :: Show a => a -> Text +tShow = T.pack . show diff --git a/src/Toml/Bi/Monad.hs b/src/Toml/Bi/Monad.hs --- a/src/Toml/Bi/Monad.hs +++ b/src/Toml/Bi/Monad.hs @@ -1,19 +1,20 @@ -{-# LANGUAGE UndecidableInstances #-} - --- | Contains general underlying monad for bidirectional TOML converion. +-- | Contains general underlying monad for bidirectional conversion. module Toml.Bi.Monad ( Codec (..) , BiCodec , dimap , dioptional + , diwrap , () , (.=) ) where import Control.Applicative (Alternative (..), optional) import Control.Monad (MonadPlus (..)) +import Data.Coerce (Coercible, coerce) + {- | Monad for bidirectional conversion. Contains pair of functions: 1. How to read value of type @a@ from immutable environment context @r@? @@ -21,7 +22,7 @@ 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. +have single description for from/to @TOML@ conversion. In practice this type will always be used in the following way: @@ -30,9 +31,9 @@ @ Type parameter @c@ if fictional. Here some trick is used. This trick is -implemented in [codec](http://hackage.haskell.org/package/codec) and -described in more details in [related blog post](https://blog.poisson.chat/posts/2016-10-12-bidirectional-serialization.html). - +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@. @@ -96,65 +97,116 @@ () :: Alternative f => (a -> f x) -> (a -> f x) -> (a -> f x) f g = \a -> f a <|> g a -{- | This is an instance of 'Profunctor' for 'Codec'. But since there's no -@Profunctor@ type class in @base@ or package with no dependencies (and we don't want to bring extra dependencies) this instance is implemented as a single +{- | 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: +Useful when you want to parse @newtype@s. For example, if you had data type like +this: @ -data Example = Example +__data__ Example = Example { foo :: Bool , bar :: Text } @ -toml bidirectional converter for this type will look like this: +Bidirectional TOML converter for this type will look like this: @ -exampleT :: TomlCodec Example -exampleT = Example - <$> bool "foo" .= foo - <*> str "bar" .= bar +exampleCodec :: TomlCodec Example +exampleCodec = Example + \<$\> Toml.bool "foo" '.=' foo + \<*\> Toml.text "bar" '.=' bar @ -Now if you change your time in the following way: +Now if you change your type in the following way: @ -newtype Email = Email { unEmail :: Text } +__newtype__ Email = Email { unEmail :: Text } -data Example = Example +__data__ Example = Example { foo :: Bool , bar :: Email } @ -you need to patch your toml parser like this: +you need to patch your TOML codec like this: @ -exampleT :: TomlCodec Example -exampleT = Example - <$> bool "foo" .= foo - <*> dimap unEmail Email (str "bar") .= bar +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 +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 - } + { codecRead = g <$> codecRead codec + , codecWrite = fmap g . codecWrite codec . f + } --- | Bidirectional converter for @Maybe smth@ values. -dioptional :: (Alternative r, Applicative w) => Codec r w c a -> Codec r w (Maybe c) (Maybe a) +{- | 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 + { codecRead = optional codecRead , codecWrite = traverse codecWrite } +{- | Combinator used for @newtype@ wrappers. For example, given the data types: + +@ +__newtype__ N = N Int + +__data__ Example = Example + { foo :: Bool + , bar :: N + } +@ + +the TOML codec can look like + +@ +exampleCodec :: TomlCodec Example +exampleCodec = Example + \<$\> Toml.bool "foo" '.=' foo + \<*\> 'diwrap' (Toml.int "bar") '.=' bar +@ +-} +diwrap + :: forall b a r w . + (Coercible a b, Functor r, Functor w) + => BiCodec r w a + -> BiCodec r w b +diwrap = dimap coerce coerce + {- | Operator to connect two operations: 1. How to get field from object? @@ -163,12 +215,15 @@ In code this should be used like this: @ -data Foo = Foo { fooBar :: Int, fooBaz :: String } +__data__ Foo = Foo + { fooBar :: Int + , fooBaz :: String + } -foo :: TomlCodec Foo -foo = Foo - <$> int "bar" .= fooBar - <*> str "baz" .= fooBaz +fooCodec :: TomlCodec Foo +fooCodec = Foo + \<$\> Toml.int "bar" '.=' fooBar + \<*\> Toml.str "baz" '.=' fooBaz @ -} infixl 5 .= diff --git a/src/Toml/BiMap.hs b/src/Toml/BiMap.hs deleted file mode 100644 --- a/src/Toml/BiMap.hs +++ /dev/null @@ -1,295 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE Rank2Types #-} - -{- | Implementation of partial bidirectional mapping as a data type. --} - -module Toml.BiMap - ( -- * BiMap idea - BiMap (..) - , invert - , iso - , prism - - -- * Helpers for BiMap and AnyValue - , mkAnyValueBiMap - , _TextBy - , _NaturalInteger - , _StringText - , _ReadString - , _BoundedInteger - , _ByteStringText - , _LByteStringText - - -- * Some predefined bi mappings - , _Array - , _Bool - , _Double - , _Integer - , _Text - , _ZonedTime - , _LocalTime - , _Day - , _TimeOfDay - , _String - , _Read - , _Natural - , _Word - , _Int - , _Float - , _ByteString - , _LByteString - , _Set - , _IntSet - , _HashSet - , _NonEmpty - - , _Left - , _Right - , _Just - - -- * Useful utility functions - , toMArray - ) where - -import Control.Arrow ((>>>)) -import Control.Monad ((>=>)) - -import Data.ByteString (ByteString) -import Data.Text (Text) -import Data.Word (Word) -import Numeric.Natural (Natural) -import Data.Hashable (Hashable) -import Text.Read (readMaybe) -import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime) - -import Toml.Type (AnyValue (..), Value (..), DateTime (..) , - matchArray, matchBool, matchDouble, matchInteger, - matchText, matchDate, toMArray) - -import qualified Control.Category as Cat -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.ByteString.Lazy as BL -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL -import qualified Data.Set as S -import qualified Data.HashSet as HS -import qualified Data.IntSet as IS -import qualified Data.List.NonEmpty as NE - ----------------------------------------------------------------------------- --- BiMap concepts and ideas ----------------------------------------------------------------------------- - -{- | Partial bidirectional isomorphism. @BiMap a b@ contains two function: - -1. @a -> Maybe b@ -2. @b -> Maybe a@ --} -data BiMap a b = BiMap - { forward :: a -> Maybe b - , backward :: b -> Maybe a - } - -instance Cat.Category BiMap where - id :: BiMap a a - id = BiMap Just Just - - (.) :: BiMap b c -> BiMap a b -> BiMap a c - bc . ab = BiMap - { forward = forward ab >=> forward bc - , backward = backward bc >=> backward ab - } - --- | Inverts bidirectional mapping. -invert :: BiMap a b -> BiMap b a -invert (BiMap f g) = BiMap g f - --- | Creates 'BiMap' from isomorphism. -iso :: (a -> b) -> (b -> a) -> BiMap a b -iso f g = BiMap (Just . f) (Just . g) - --- | Creates 'BiMap' from prism-like pair of functions. -prism :: (field -> object) -> (object -> Maybe field) -> BiMap object field -prism review preview = BiMap preview (Just . review) - ----------------------------------------------------------------------------- --- General purpose bimaps ----------------------------------------------------------------------------- - --- | Bimap for 'Either' and its left type -_Left :: BiMap (Either l r) l -_Left = prism Left (either Just (const Nothing)) - --- | Bimap for 'Either' and its right type -_Right :: BiMap (Either l r) r -_Right = prism Right (either (const Nothing) Just) - --- | Bimap for 'Maybe' -_Just :: BiMap (Maybe a) a -_Just = prism Just id - ----------------------------------------------------------------------------- --- BiMaps for value ----------------------------------------------------------------------------- - --- | Creates prism for 'AnyValue'. -mkAnyValueBiMap :: (forall t . Value t -> Maybe a) - -> (a -> Value tag) - -> BiMap a AnyValue -mkAnyValueBiMap matchValue toValue = - BiMap (Just . AnyValue . toValue) (\(AnyValue value) -> matchValue value) - --- | Creates bimap for 'Text' to 'AnyValue' with custom functions -_TextBy :: (a -> Text) -> (Text -> Maybe a) -> BiMap a AnyValue -_TextBy toText parseText = - mkAnyValueBiMap (matchText >=> parseText) (Text . toText) - --- | 'Bool' bimap for 'AnyValue'. Usually used with 'bool' combinator. -_Bool :: BiMap Bool AnyValue -_Bool = mkAnyValueBiMap matchBool Bool - --- | 'Integer' bimap for 'AnyValue'. Usually used with 'integer' combinator. -_Integer :: BiMap Integer AnyValue -_Integer = mkAnyValueBiMap matchInteger Integer - --- | 'Double' bimap for 'AnyValue'. Usually used with 'double' combinator. -_Double :: BiMap Double AnyValue -_Double = mkAnyValueBiMap matchDouble Double - --- | 'Text' bimap for 'AnyValue'. Usually used with 'text' combinator. -_Text :: BiMap Text AnyValue -_Text = mkAnyValueBiMap matchText Text - --- | Zoned time bimap for 'AnyValue'. Usually used with 'zonedTime' combinator. -_ZonedTime :: BiMap ZonedTime AnyValue -_ZonedTime = mkAnyValueBiMap (matchDate >=> getTime) (Date . Zoned) - where - getTime (Zoned z) = Just z - getTime _ = Nothing - --- | Local time bimap for 'AnyValue'. Usually used with 'localTime' combinator. -_LocalTime :: BiMap LocalTime AnyValue -_LocalTime = mkAnyValueBiMap (matchDate >=> getTime) (Date . Local) - where - getTime (Local l) = Just l - getTime _ = Nothing - --- | Day bimap for 'AnyValue'. Usually used with 'day' combinator. -_Day :: BiMap Day AnyValue -_Day = mkAnyValueBiMap (matchDate >=> getTime) (Date . Day) - where - getTime (Day d) = Just d - getTime _ = Nothing - --- | Time of day bimap for 'AnyValue'. Usually used with 'timeOfDay' combinator. -_TimeOfDay :: BiMap TimeOfDay AnyValue -_TimeOfDay = mkAnyValueBiMap (matchDate >=> getTime) (Date . Hours) - where - getTime (Hours h) = Just h - getTime _ = Nothing - --- | Helper bimap for 'String' and 'Text'. -_StringText :: BiMap String Text -_StringText = iso T.pack T.unpack - --- | 'String' bimap for 'AnyValue'. Usually used with 'string' combinator. -_String :: BiMap String AnyValue -_String = _StringText >>> _Text - --- | Helper bimap for 'String' and types with 'Read' and 'Show' instances. -_ReadString :: (Show a, Read a) => BiMap a String -_ReadString = BiMap (Just . show) readMaybe - --- | Bimap for 'AnyValue' and values with a `Read` and `Show` instance. --- Usually used with 'read' combinator. -_Read :: (Show a, Read a) => BiMap a AnyValue -_Read = _ReadString >>> _String - --- | Helper bimap for 'Natural' and 'Integer'. -_NaturalInteger :: BiMap Natural Integer -_NaturalInteger = BiMap (Just . toInteger) maybeInteger - where - maybeInteger :: Integer -> Maybe Natural - maybeInteger n - | n < 0 = Nothing - | otherwise = Just (fromIntegral n) - --- | 'Natural' bimap for 'AnyValue'. Usually used with 'natural' combinator. -_Natural :: BiMap Natural AnyValue -_Natural = _NaturalInteger >>> _Integer - --- | Helper bimap for 'Integer' and integral, bounded values. -_BoundedInteger :: (Integral a, Bounded a) => BiMap a Integer -_BoundedInteger = BiMap (Just . toInteger) maybeBounded - where - maybeBounded :: forall a. (Integral a, Bounded a) => Integer -> Maybe a - maybeBounded n - | n < toInteger (minBound :: a) = Nothing - | n > toInteger (maxBound :: a) = Nothing - | otherwise = Just (fromIntegral n) - --- | 'Word' bimap for 'AnyValue'. Usually used with 'word' combinator. -_Word :: BiMap Word AnyValue -_Word = _BoundedInteger >>> _Integer - --- | 'Int' bimap for 'AnyValue'. Usually used with 'int' combinator. -_Int :: BiMap Int AnyValue -_Int = _BoundedInteger >>> _Integer - --- | 'Float' bimap for 'AnyValue'. Usually used with 'float' combinator. -_Float :: BiMap Float AnyValue -_Float = iso realToFrac realToFrac >>> _Double - --- | Helper bimap for 'Text' and strict 'ByteString' -_ByteStringText :: BiMap ByteString Text -_ByteStringText = prism T.encodeUtf8 maybeText - where - maybeText :: ByteString -> Maybe Text - maybeText = either (const Nothing) Just . T.decodeUtf8' - --- | 'ByteString' bimap for 'AnyValue'. Usually used with 'byteString' combinator. -_ByteString:: BiMap ByteString AnyValue -_ByteString = _ByteStringText >>> _Text - --- | Helper bimap for 'Text' and lazy 'ByteString' -_LByteStringText :: BiMap BL.ByteString Text -_LByteStringText = prism (TL.encodeUtf8 . TL.fromStrict) maybeText - where - maybeText :: BL.ByteString -> Maybe Text - maybeText = either (const Nothing) (Just . TL.toStrict) . TL.decodeUtf8' - --- | Lazy 'ByteString' bimap for 'AnyValue'. Usually used with 'lazyByteString' --- combinator. -_LByteString:: BiMap BL.ByteString AnyValue -_LByteString = _LByteStringText >>> _Text - --- | Takes a bimap of a value and returns a bimap of a list of values and 'Anything' --- as an array. Usually used with 'arrayOf' combinator. -_Array :: BiMap a AnyValue -> BiMap [a] AnyValue -_Array elementBimap = BiMap - { forward = mapM (forward elementBimap) >=> fmap AnyValue . toMArray - , backward = \(AnyValue val) -> matchArray (backward elementBimap) val - } - --- | Takes a bimap of a value and returns a bimap of a non-empty list of values --- and 'Anything' as an array. Usually used with 'nonEmptyOf' combinator. -_NonEmpty :: BiMap a AnyValue -> BiMap (NE.NonEmpty a) AnyValue -_NonEmpty bimap = BiMap (Just . NE.toList) NE.nonEmpty >>> _Array bimap - --- | Takes a bimap of a value and returns a bimap of a set of values and 'Anything' --- as an array. Usually used with 'setOf' combinator. -_Set :: (Ord a) => BiMap a AnyValue -> BiMap (S.Set a) AnyValue -_Set bimap = iso S.toList S.fromList >>> _Array bimap - --- | Takes a bimap of a value and returns a bimap of a has set of values and --- 'Anything' as an array. Usually used with 'hashSetOf' combinator. -_HashSet :: (Eq a, Hashable a) => BiMap a AnyValue -> BiMap (HS.HashSet a) AnyValue -_HashSet bimap = iso HS.toList HS.fromList >>> _Array bimap - --- | Bimap of 'IntSet' and 'Anything' as an array. Usually used with --- 'intSet' combinator. -_IntSet :: BiMap IS.IntSet AnyValue -_IntSet = iso IS.toList IS.fromList >>> _Array _Int diff --git a/src/Toml/Edsl.hs b/src/Toml/Edsl.hs --- a/src/Toml/Edsl.hs +++ b/src/Toml/Edsl.hs @@ -1,36 +1,68 @@ {- | This module introduces EDSL for manually specifying 'TOML' data types. -__Example:__ +Consider the following raw TOML: @ -exampleToml :: TOML -exampleToml = mkToml $ do - \"key1\" =: 1 - \"key2\" =: Bool True - table \"tableName\" $ - \"tableKey\" =: Array [\"Oh\", \"Hi\", \"Mark\"] +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 - ( mkToml + ( TDSL + , mkToml + , empty , (=:) , table + , tableArray ) where -import Control.Monad.State (State, execState, modify) +import Control.Monad.State (State, execState, modify, put) +import Data.List.NonEmpty (NonEmpty) import Toml.PrefixTree (Key) -import Toml.Type (TOML (..), Value, insertKeyVal, insertTable) +import Toml.Type (TOML (..), Value, insertKeyVal, insertTable, insertTableArrays) +-- | Monad for creating TOML. type TDSL = State TOML () -- | Creates 'TOML' from the 'TDSL'. mkToml :: TDSL -> TOML mkToml env = execState env mempty +-- | Creates an empty 'TDSL'. +empty :: TDSL +empty = put mempty + -- | Adds key-value pair to the 'TDSL'. (=:) :: Key -> Value a -> TDSL (=:) k v = modify $ insertKeyVal k v @@ -38,3 +70,7 @@ -- | Adds table to the 'TDSL'. table :: Key -> TDSL -> TDSL table k = modify . insertTable k . mkToml + +-- | Adds array of tables to the 'TDSL'. +tableArray :: Key -> NonEmpty TDSL -> TDSL +tableArray k = modify . insertTableArrays k . fmap mkToml diff --git a/src/Toml/Parser.hs b/src/Toml/Parser.hs --- a/src/Toml/Parser.hs +++ b/src/Toml/Parser.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} +-- | Parser for text to TOML AST. + module Toml.Parser ( ParseException (..) , parse @@ -19,7 +21,10 @@ newtype ParseException = ParseException Text deriving (Show, Eq, Generic, NFData) --- | Parses 'Text' as 'TOML' object. +{- | 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. +-} parse :: Text -> Either ParseException TOML parse t = case P.parse tomlP "" t of Left err -> Left $ ParseException $ pack $ P.errorBundlePretty err 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,7 +1,10 @@ module Toml.Parser.Core - ( module Text.Megaparsec + ( -- * Reexports from @megaparsec@ + module Text.Megaparsec , module Text.Megaparsec.Char , module Text.Megaparsec.Char.Lexer + + -- * Core parsers for TOML , Parser , lexeme , sc @@ -21,23 +24,22 @@ import qualified Text.Megaparsec.Char.Lexer as L (lexeme, space) --- The parser +-- | The parser type Parser = Parsec Void Text - --- space consumer +-- | Space and comment consumer. Currently also consumes newlines. sc :: Parser () sc = L.space space1 lineComment blockComment where lineComment = skipLineComment "#" blockComment = empty - --- wrapper for consuming spaces after every lexeme (not before it!) +{- | Wrapper for consuming spaces after every lexeme (not before it!). Consumes +all characters according to 'sc' parser. +-} lexeme :: Parser a -> Parser a lexeme = L.lexeme sc - --- parser for "fixed" string +-- | 'Parser' for "fixed" string. text :: Text -> Parser Text text = symbol sc diff --git a/src/Toml/Parser/String.hs b/src/Toml/Parser/String.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Parser/String.hs @@ -0,0 +1,116 @@ +{- | Parsers for strings in TOML format, including basic and literal strings +both singleline and multiline. +-} + +module Toml.Parser.String + ( textP + , basicStringP + , literalStringP + ) where + +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, + tab, try, ()) + +import qualified Data.Text as Text + + +{- | Parser for TOML text. Includes: + +1. Basic single-line string. +2. Literal single-line string. +3. Basic multiline string. +4. Literal multiline string. +-} +textP :: Parser Text +textP = (multilineBasicStringP "multiline basic string") + <|> (multilineLiteralStringP "multiline literal string") + <|> (literalStringP "literal string") + <|> (basicStringP "basic string") + "text" + +{- | Parse a non-control character (control character is a non-printing +character of the Latin-1 subset of Unicode). +-} +nonControlCharP :: Parser Text +nonControlCharP = Text.singleton <$> satisfy (not . isControl) "non-control char" + +-- | Parse escape sequences inside basic strings. +escapeSequenceP :: Parser Text +escapeSequenceP = char '\\' *> anySingle >>= \case + 'b' -> pure "\b" + 't' -> pure "\t" + 'n' -> pure "\n" + 'f' -> pure "\f" + 'r' -> pure "\r" + '"' -> pure "\"" + '\\' -> pure "\\" + 'u' -> hexUnicodeP 4 + 'U' -> hexUnicodeP 8 + c -> fail $ "Invalid escape sequence: " <> "\\" <> [c] + where + hexUnicodeP :: Int -> Parser Text + hexUnicodeP n = count n hexDigitChar >>= \x -> case toUnicode $ hexToInt x of + Just c -> pure (Text.singleton c) + Nothing -> fail $ "Invalid unicode character: \\" + <> (if n == 4 then "u" else "U") + <> x + where + hexToInt :: String -> Int + hexToInt xs = read $ "0x" ++ xs + + toUnicode :: Int -> Maybe Char + toUnicode x + -- Ranges from "The Unicode Standard". + -- See definition D76 in Section 3.9, Unicode Encoding Forms. + | x >= 0 && x <= 0xD7FF = Just (chr x) + | x >= 0xE000 && x <= 0x10FFFF = Just (chr x) + | otherwise = Nothing + +-- | Parser for basic string in double quotes. +basicStringP :: Parser Text +basicStringP = lexeme $ mconcat <$> (char '"' *> charP `manyTill` char '"') + where + charP :: Parser Text + charP = escapeSequenceP <|> nonControlCharP + +-- | Parser for literal string in single quotes. +literalStringP :: Parser Text +literalStringP = lexeme $ Text.pack <$> (char '\'' *> nonEolCharP `manyTill` char '\'') + where + nonEolCharP :: Parser Char + nonEolCharP = satisfy (\c -> c /= '\n' && c /= '\r') + +-- | Generic parser for multiline string. Used in 'multilineBasicStringP' and +-- 'multilineLiteralStringP'. +multilineP :: Parser Text -> Parser Text -> Parser Text +multilineP quotesP allowedCharP = lexeme $ mconcat <$> + (quotesP *> optional eol *> allowedCharP `manyTill` quotesP) + +-- Parser for basic multiline string in """ quotes. +multilineBasicStringP :: Parser Text +multilineBasicStringP = multilineP quotesP allowedCharP + where + quotesP :: Parser Text + quotesP = string "\"\"\"" + + allowedCharP :: Parser Text + allowedCharP = lineEndingBackslashP <|> escapeSequenceP <|> nonControlCharP <|> eol + + lineEndingBackslashP :: Parser Text + lineEndingBackslashP = Text.empty <$ try (char '\\' >> eol >> space) + +-- Parser for literal multiline string in ''' quotes. +multilineLiteralStringP :: Parser Text +multilineLiteralStringP = multilineP quotesP allowedCharP + where + quotesP :: Parser Text + quotesP = string "'''" + + allowedCharP :: Parser Text + allowedCharP = nonControlCharP <|> eol <|> Text.singleton <$> tab diff --git a/src/Toml/Parser/TOML.hs b/src/Toml/Parser/TOML.hs --- a/src/Toml/Parser/TOML.hs +++ b/src/Toml/Parser/TOML.hs @@ -1,47 +1,154 @@ +{- | Parser for 'TOML' data type: keys, tables, array of tables. Uses value +parsers from "Toml.Parser.Value". +-} + module Toml.Parser.TOML - ( hasKeyP - , tableHeaderP + ( keyP + , hasKeyP + , tableP + , tableArrayP , inlineTableP , tomlP ) where -import Control.Applicative (Alternative (many)) -import Control.Applicative.Combinators (sepEndBy, between, eitherP) +import Control.Applicative (Alternative (..)) +import Control.Monad.Combinators (between, eitherP, optional, sepEndBy) +import Data.List.NonEmpty (NonEmpty (..), (<|)) +import Data.Semigroup ((<>)) +import Data.Text (Text) -import Toml.Parser.Core (Parser, sc, text) -import Toml.Parser.Value (keyP, tableNameP, anyValueP) -import Toml.PrefixTree (Key (..), fromList) +import Toml.Parser.Core (Parser, alphaNumChar, char, lexeme, sc, text, try) +import Toml.Parser.String (basicStringP, literalStringP) +import Toml.Parser.Value (anyValueP) +import Toml.PrefixTree (Key (..), KeysDiff (..), Piece (..), fromList, keysDiff) import Toml.Type (AnyValue, TOML (..)) +import qualified Control.Applicative.Combinators.NonEmpty as NC import qualified Data.HashMap.Lazy as HashMap +import qualified Data.Text as Text + +-- | Parser for bare key piece, like @foo@. +bareKeyPieceP :: Parser Text +bareKeyPieceP = lexeme $ Text.pack <$> bareStrP + where + bareStrP :: Parser String + bareStrP = some $ alphaNumChar <|> char '_' <|> char '-' + +-- | Parser for 'Piece'. +keyComponentP :: Parser Piece +keyComponentP = Piece <$> + (bareKeyPieceP <|> (quote "\"" <$> basicStringP) <|> (quote "'" <$> literalStringP)) + where + -- adds " or ' to both sides + quote :: Text -> Text -> Text + quote q t = q <> t <> q + +-- | Parser for 'Key': dot-separated list of 'Piece'. +keyP :: Parser Key +keyP = Key <$> NC.sepBy1 keyComponentP (char '.') + +-- | Parser for table name: 'Key' inside @[]@. +tableNameP :: Parser Key +tableNameP = between (text "[") (text "]") keyP + +-- | Parser for array of tables name: 'Key' inside @[[]]@. +tableArrayNameP :: Parser Key +tableArrayNameP = between (text "[[") (text "]]") keyP + +-- Tables + +-- | Parser for lines starting with 'key =', either values or inline tables. hasKeyP :: Parser (Key, Either AnyValue TOML) hasKeyP = (,) <$> keyP <* text "=" <*> eitherP anyValueP inlineTableP +-- | Parser for inline tables. inlineTableP :: Parser TOML -inlineTableP = between (text "{") (text "}") - (makeToml <$> hasKeyP `sepEndBy` text ",") +inlineTableP = between + (text "{") (text "}") + (tomlFromInline <$> hasKeyP `sepEndBy` text ",") -tableHeaderP :: Parser (Key, TOML) -tableHeaderP = (,) <$> tableNameP <*> (makeToml <$> many hasKeyP) +-- | Parser for a table. +tableP :: Parser (Key, TOML) +tableP = do + key <- tableNameP + toml <- subTableContent key + pure (key, toml) +-- | Parser for an array of tables. +tableArrayP :: Parser (Key, NonEmpty TOML) +tableArrayP = do + key <- tableArrayNameP + localToml <- subTableContent key + more <- optional $ sameKeyP key tableArrayP + case more of + Nothing -> pure (key, localToml :| []) + Just (_, tomls) -> pure (key, localToml <| tomls) + +-- | Parser for a '.toml' file +tomlP :: Parser TOML +tomlP = do + sc + (val, inline) <- distributeEithers <$> many hasKeyP + (table, array) <- fmap distributeEithers + $ many + $ eitherPairP (try tableP) tableArrayP + + pure TOML + { tomlPairs = HashMap.fromList val + , tomlTables = fromList $ inline ++ table + , tomlTableArrays = HashMap.fromList array + } + +-- | Parser for full 'TOML' under a certain key +subTableContent :: Key -> Parser TOML +subTableContent key = do + (val, inline) <- distributeEithers <$> many hasKeyP + (table, array) <- fmap distributeEithers + $ many + $ childKeyP key + $ eitherPairP (try tableP) tableArrayP + + pure TOML + { tomlPairs = HashMap.fromList val + , tomlTables = fromList $ inline ++ table + , tomlTableArrays = HashMap.fromList array + } + +-- | @childKeyP key p@ returns the result of @p@ if the key returned by @p@ is +-- a child key of the @key@, and fails otherwise. +childKeyP :: Key -> Parser (Key, a) -> Parser (Key, a) +childKeyP key p = try $ do + (k, x) <- p + case keysDiff key k of + FstIsPref k' -> pure (k', x) + _ -> fail $ show k ++ " is not a child key of " ++ show key + +-- | @sameKeyP key p@ returns the result of @p@ if the key returned by @p@ is +-- the same as @key@, and fails otherwise. +sameKeyP :: Key -> Parser (Key, a) -> Parser (Key, a) +sameKeyP key parser = try $ do + (k, x) <- parser + case keysDiff key k of + Equal -> pure (k, x) + _ -> fail $ show k ++ " is not the same as " ++ show key + +-- Helper functions + +-- | Helper function to create a 'TOML' from a list of key/values or inline tables. +tomlFromInline :: [(Key, Either AnyValue TOML)] -> TOML +tomlFromInline kvs = + let (lefts, rights) = distributeEithers kvs + in TOML (HashMap.fromList lefts) (fromList rights) mempty + +-- | Helper function to seperate the 'Either'. distributeEithers :: [(c, Either a b)] -> ([(c, a)], [(c, b)]) distributeEithers = foldr distribute ([], []) where distribute :: (c, Either a b) -> ([(c, a)], [(c, b)]) -> ([(c, a)], [(c, b)]) - distribute (k, Left a) (ls, rs) = ((k, a) : ls, rs) + distribute (k, Left a) (ls, rs) = ((k, a) : ls, rs) distribute (k, Right b) (ls, rs) = (ls, (k, b) : rs) -makeToml :: [(Key, Either AnyValue TOML)] -> TOML -makeToml kvs = TOML (HashMap.fromList lefts) (fromList rights) - where - (lefts, rights) = distributeEithers kvs - -tomlP :: Parser TOML -tomlP = do - sc - (val, inline) <- distributeEithers <$> many hasKeyP - tables <- many tableHeaderP - return TOML { tomlPairs = HashMap.fromList val - , tomlTables = fromList $ tables ++ inline - } +-- | Helper function to make an 'Either' parser. +eitherPairP :: Alternative m => m (c, a) -> m (c, b) -> m (c, Either a b) +eitherPairP a b = (fmap Left <$> a) <|> (fmap Right <$> b) 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,274 +1,185 @@ +-- | Parser for 'UValue'. + module Toml.Parser.Value ( arrayP , boolP , dateTimeP , doubleP , integerP - , keyP - , tableNameP - , textP , valueP , anyValueP ) where -import Control.Applicative (Alternative (many, some, (<|>))) -import Control.Applicative.Combinators (between, count, manyTill, option, optional, sepEndBy, +import Control.Applicative (Alternative (..)) +import Control.Applicative.Combinators (between, count, option, optional, sepBy1, sepEndBy, skipMany) - -import Data.Char (chr, isControl) -import Data.Either (fromRight) import Data.Fixed (Pico) import Data.Semigroup ((<>)) -import Data.Text (Text) -import Data.Time (LocalTime (..), ZonedTime (..), fromGregorianValid, makeTimeOfDayValid, - minutesToTimeZone) - -import Toml.Parser.Core (Parser, alphaNumChar, anySingle, binary, char, digitChar, eol, float, - hexDigitChar, hexadecimal, lexeme, match, octal, satisfy, sc, signed, - space, string, tab, text, try, ()) -import Toml.PrefixTree (Key (..), Piece (..)) -import Toml.Type (DateTime (..), UValue (..), AnyValue, typeCheck) - -import qualified Control.Applicative.Combinators.NonEmpty as NC -import qualified Data.Text as Text -import qualified Data.Text.Read as TR - - -textP :: Parser Text -textP = multilineBasicStringP - <|> multilineLiteralStringP - <|> literalStringP - <|> basicStringP - "text" - - -nonControlCharP :: Parser Text -nonControlCharP = Text.singleton <$> satisfy (not . isControl) - - -escapeSequenceP :: Parser Text -escapeSequenceP = char '\\' >> anySingle >>= \case - 'b' -> pure "\b" - 't' -> pure "\t" - 'n' -> pure "\n" - 'f' -> pure "\f" - 'r' -> pure "\r" - '"' -> pure "\"" - '\\' -> pure "\\" - 'u' -> hexUnicodeP 4 - 'U' -> hexUnicodeP 8 - c -> fail $ "Invalid escape sequence: " <> "\\" <> [c] - where - hexUnicodeP :: Int -> Parser Text - hexUnicodeP n = count n hexDigitChar - >>= \x -> case toUnicode $ hexToInt x of - Just c -> pure (Text.singleton c) - Nothing -> fail $ "Invalid unicode character: " - <> "\\" - <> (if n == 4 then "u" else "U") - <> x - where - hexToInt :: String -> Int - hexToInt xs = read $ "0x" ++ xs - - toUnicode :: Int -> Maybe Char - toUnicode x - -- Ranges from "The Unicode Standard". - -- See definition D76 in Section 3.9, Unicode Encoding Forms. - | x >= 0 && x <= 0xD7FF = Just (chr x) - | x >= 0xE000 && x <= 0x10FFFF = Just (chr x) - | otherwise = Nothing - - -basicStringP :: Parser Text -basicStringP = lexeme $ mconcat - <$> (char '"' *> (escapeSequenceP <|> nonControlCharP) `manyTill` char '"') - - -literalStringP :: Parser Text -literalStringP = lexeme $ Text.pack <$> (char '\'' *> nonEolCharP `manyTill` char '\'') - where - nonEolCharP :: Parser Char - nonEolCharP = satisfy (\c -> c /= '\n' && c /= '\r') - - -multilineP :: Parser Text -> Parser Text -> Parser Text -multilineP quotesP allowedCharP = lexeme $ fmap mconcat $ quotesP - >> optional eol - >> allowedCharP `manyTill` quotesP - - -multilineBasicStringP :: Parser Text -multilineBasicStringP = multilineP quotesP allowedCharP - where - quotesP = string "\"\"\"" - - allowedCharP :: Parser Text - allowedCharP = lineEndingBackslashP <|> escapeSequenceP <|> nonControlCharP <|> eol - - lineEndingBackslashP :: Parser Text - lineEndingBackslashP = Text.empty <$ try (char '\\' >> eol >> space) - - -multilineLiteralStringP :: Parser Text -multilineLiteralStringP = multilineP quotesP allowedCharP - where - quotesP = string "'''" - - allowedCharP :: Parser Text - allowedCharP = nonControlCharP <|> eol <|> Text.singleton <$> tab - - --- Keys - -bareKeyP :: Parser Text -bareKeyP = lexeme $ Text.pack <$> bareStrP - where - bareStrP :: Parser String - bareStrP = some $ alphaNumChar <|> char '_' <|> char '-' - - -keyComponentP :: Parser Piece -keyComponentP = Piece <$> ( - bareKeyP <|> (quote "\"" <$> basicStringP) <|> (quote "'" <$> literalStringP) - ) - where - -- adds " or ' to both sides - quote q t = q <> t <> q - - -keyP :: Parser Key -keyP = Key <$> NC.sepBy1 keyComponentP (char '.') - +import Data.Time (Day, LocalTime (..), TimeOfDay, ZonedTime (..), fromGregorianValid, + makeTimeOfDayValid, minutesToTimeZone) +import Text.Read (readMaybe) -tableNameP :: Parser Key -tableNameP = between (text "[") (text "]") keyP +import Toml.Parser.Core (Parser, binary, char, digitChar, hexadecimal, lexeme, octal, sc, signed, + string, text, try, ()) +import Toml.Parser.String (textP) +import Toml.Type (AnyValue, UValue (..), typeCheck) --- Values - +-- | Parser for decimap 'Integer': included parsing of underscore. decimalP :: Parser Integer -decimalP = mkInteger <$> decimalStringP +decimalP = zero <|> more where - decimalStringP = fst <$> match (some digitChar >> many _digitsP) - _digitsP = try (char '_') >> some digitChar - mkInteger = textToInt . stripUnderscores - textToInt = fst . fromRight (error "Underscore parser has a bug") . TR.decimal - stripUnderscores = Text.filter (/= '_') + zero, more :: Parser Integer + zero = 0 <$ char '0' + more = check =<< readMaybe . concat <$> sepBy1 (some digitChar) (char '_') + check :: Maybe Integer -> Parser Integer + check = maybe (fail "Not an integer") pure +-- | Parser for 'Integer' value. integerP :: Parser Integer integerP = lexeme (bin <|> oct <|> hex <|> dec) "integer" where - dec = signed sc decimalP - bin = try (char '0' >> char 'b') >> binary - oct = try (char '0' >> char 'o') >> octal - hex = try (char '0' >> char 'x') >> hexadecimal - + bin, oct, hex, dec :: Parser Integer + bin = try (char '0' *> char 'b') *> binary "bin" + oct = try (char '0' *> char 'o') *> octal "oct" + hex = try (char '0' *> char 'x') *> hexadecimal "hex" + dec = signed sc decimalP "dec" +-- | Parser for 'Double' value. doubleP :: Parser Double doubleP = lexeme (signed sc (num <|> inf <|> nan)) "double" where num, inf, nan :: Parser Double - num = float + num = floatP inf = 1 / 0 <$ string "inf" nan = 0 / 0 <$ string "nan" +-- | Parser for 'Double' numbers. Used in 'doubleP'. +floatP :: Parser Double +floatP = check . readMaybe =<< mconcat [ digits, expo <|> dot ] + where + check :: Maybe Double -> Parser Double + check = maybe (fail "Not a float") return + digits, dot, expo :: Parser String + digits = concat <$> sepBy1 (some digitChar) (char '_') + dot = mconcat [pure <$> char '.', digits, option "" expo] + expo = mconcat + [ pure <$> (char 'e' <|> char 'E') + , pure <$> option '+' (char '+' <|> char '-') + , digits + ] + +-- | Parser for 'Bool' value. boolP :: Parser Bool boolP = False <$ text "false" <|> True <$ text "true" "bool" +-- | Parser for datetime values. +dateTimeP :: Parser UValue +dateTimeP = lexeme (try (UHours <$> hoursP) <|> dayLocalZoned) "datetime" -dateTimeP :: Parser DateTime -dateTimeP = lexeme (try hoursP <|> dayLocalZoned) "datetime" - where - -- dayLocalZoned can parse: only a local date, a local date with time, or - -- a local date with a time and an offset - dayLocalZoned :: Parser DateTime - dayLocalZoned = do - let makeLocal (Day day) (Hours hours) = Local $ LocalTime day hours - makeLocal _ _ = error "Invalid arguments, unable to construct `Local`" - makeZoned (Local localTime) mins = Zoned $ ZonedTime localTime (minutesToTimeZone mins) - makeZoned _ _ = error "Invalid arguments, unable to construct `Zoned`" - day <- try dayP - maybeHours <- optional (try $ (char 'T' <|> char ' ') *> hoursP) - case maybeHours of - Nothing -> return day +-- dayLocalZoned can parse: only a local date, a local date with time, or +-- a local date with a time and an offset +dayLocalZoned :: Parser UValue +dayLocalZoned = do + day <- try dayP + maybeHours <- optional (try $ (char 'T' <|> char ' ') *> hoursP) + case maybeHours of + Nothing -> pure $ UDay day Just hours -> do - maybeOffset <- optional (try timeOffsetP) - return $ case maybeOffset of - Nothing -> makeLocal day hours - Just offset -> makeZoned (makeLocal day hours) offset + maybeOffset <- optional (try timeOffsetP) + let localTime = LocalTime day hours + pure $ case maybeOffset of + Nothing -> ULocal localTime + Just offset -> UZoned $ ZonedTime localTime (minutesToTimeZone offset) - timeOffsetP :: Parser Int - timeOffsetP = z <|> numOffset - where - z = 0 <$ char 'Z' - numOffset = do - sign <- char '+' <|> char '-' - hours <- int2DigitsP - _ <- char ':' - minutes <- int2DigitsP - let totalMinutes = hours * 60 + minutes - return $ if sign == '+' - then totalMinutes - else negate totalMinutes +-- | Parser for time-zone offset +timeOffsetP :: Parser Int +timeOffsetP = z <|> numOffset + where + z :: Parser Int + z = 0 <$ char 'Z' - hoursP :: Parser DateTime - hoursP = do - hours <- int2DigitsP - _ <- char ':' - minutes <- int2DigitsP - _ <- char ':' - seconds <- picoTruncated - case makeTimeOfDayValid hours minutes seconds of - Just time -> return (Hours time) - Nothing -> fail $ "Invalid time of day: " - <> show hours - <> ":" - <> show minutes - <> ":" <> show seconds + numOffset :: Parser Int + numOffset = do + sign <- char '+' <|> char '-' + hours <- int2DigitsP + _ <- char ':' + minutes <- int2DigitsP + let totalMinutes = hours * 60 + minutes + pure $ if sign == '+' + then totalMinutes + else negate totalMinutes - dayP :: Parser DateTime - dayP = do - year <- integer4DigitsP - _ <- char '-' - month <- int2DigitsP - _ <- char '-' - day <- int2DigitsP - case fromGregorianValid year month day of - Just date -> return (Day date) - Nothing -> fail $ "Invalid date: " <> show year <> "-" <> show month <> "-" <> show day +-- | Parser for offset in day. +hoursP :: Parser TimeOfDay +hoursP = do + hours <- int2DigitsP + _ <- char ':' + minutes <- int2DigitsP + _ <- char ':' + seconds <- picoTruncated + case makeTimeOfDayValid hours minutes seconds of + Just time -> pure time + Nothing -> fail $ + "Invalid time of day: " <> show hours <> ":" <> show minutes <> ":" <> show seconds - integer4DigitsP = (read :: String -> Integer) <$> count 4 digitChar - int2DigitsP = (read :: String -> Int) <$> count 2 digitChar - picoTruncated = do - let rdPico = read :: String -> Pico - int <- count 2 digitChar - frc <- optional (char '.' >> take 12 <$> some digitChar) - case frc of - Nothing -> return (rdPico int) - Just frc' -> return (rdPico $ int ++ "." ++ frc') +-- | Parser for 'Day'. +dayP :: Parser Day +dayP = do + year <- yearP + _ <- char '-' + month <- int2DigitsP + _ <- char '-' + day <- int2DigitsP + case fromGregorianValid year month day of + Just date -> pure date + Nothing -> fail $ + "Invalid date: " <> show year <> "-" <> show month <> "-" <> show day +-- | Parser for exactly 4 integer digits. +yearP :: Parser Integer +yearP = read <$> count 4 digitChar +-- | Parser for exactly two digits. Used to parse months or hours. +int2DigitsP :: Parser Int +int2DigitsP = read <$> count 2 digitChar + +-- | Parser for pico-chu. +picoTruncated :: Parser Pico +picoTruncated = do + int <- count 2 digitChar + frc <- optional $ char '.' *> (take 12 <$> some digitChar) + pure $ read $ case frc of + Nothing -> int + Just frc' -> int ++ "." ++ frc' + +{- | Parser for array of values. This parser tries to parse first element of +array, pattern-matches on this element and uses parser according to this first +element. This allows to prevent parsing of heterogeneous arrays. +-} arrayP :: Parser [UValue] arrayP = lexeme (between (char '[' *> sc) (char ']') elements) "array" where elements :: Parser [UValue] elements = option [] $ do -- Zero or more elements - v <- valueP -- Parse the first value to determine the type - sep <- optional spComma - vs <- case sep of - Nothing -> pure [] - Just _ -> (element v `sepEndBy` spComma) <* skipMany spComma - return (v:vs) + v <- valueP -- Parse the first value to determine the type + sep <- optional spComma + vs <- case sep of + Nothing -> pure [] + Just _ -> (element v `sepEndBy` spComma) <* skipMany spComma + pure (v:vs) element :: UValue -> Parser UValue element = \case UBool _ -> UBool <$> boolP - UDate _ -> UDate <$> dateTimeP + UZoned _ -> dayLocalZoned + ULocal _ -> dayLocalZoned + UDay _ -> UDay <$> dayP + UHours _ -> UHours <$> hoursP UDouble _ -> UDouble <$> try doubleP UInteger _ -> UInteger <$> integerP UText _ -> UText <$> textP @@ -277,17 +188,17 @@ spComma :: Parser () spComma = char ',' *> sc - +-- | Parser for 'UValue'. valueP :: Parser UValue -valueP = UBool <$> boolP - <|> UDate <$> dateTimeP +valueP = UText <$> textP + <|> UBool <$> boolP + <|> UArray <$> arrayP + <|> dateTimeP <|> UDouble <$> try doubleP <|> UInteger <$> integerP - <|> UText <$> textP - <|> UArray <$> arrayP - +-- | Uses 'valueP' and typechecks it. anyValueP :: Parser AnyValue anyValueP = typeCheck <$> valueP >>= \case Left err -> fail $ show err - Right v -> return v + Right v -> pure v diff --git a/src/Toml/PrefixTree.hs b/src/Toml/PrefixTree.hs --- a/src/Toml/PrefixTree.hs +++ b/src/Toml/PrefixTree.hs @@ -1,29 +1,36 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PatternSynonyms #-} +-- | Implementation of prefix tree for TOML AST. + module Toml.PrefixTree - ( 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 - - -- * Types - , Piece (..) - , Key (..) - , pattern (:||) - , Prefix - , KeysDiff (..) ) where import Prelude hiding (lookup) @@ -44,13 +51,14 @@ 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 +components — 'Piece's. Key like @ site."google.com" @@ -61,16 +69,17 @@ @ 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. +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 @@ -80,6 +89,8 @@ [] -> 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 @@ -95,32 +106,33 @@ -- | Data structure to represent table tree for @toml@. data PrefixTree a - = Leaf !Key !a - | Branch { bCommonPref :: !Prefix -- ^ greatest common prefix - , bVal :: !(Maybe a) -- ^ value by key = prefix - , bPrefixMap :: !(PrefixMap a) -- ^ suffixes of prefix - } + = Leaf -- ^ End of a key. + !Key -- ^ End piece of the key. + !a -- ^ Value at the end. + | Branch -- ^ Values along pieces of a key. + !Prefix -- ^ Greatest common key prefix. + !(Maybe a) -- ^ Possible value at that point. + !(PrefixMap a) -- ^ Values at suffixes of the prefix. deriving (Show, Eq, NFData, Generic) instance Semigroup (PrefixTree a) where a <> b = foldl' (\tree (k, v) -> insertT k v tree) a (toListT b) +-- | Data structure to compare keys. data KeysDiff - -- | Keys are equal - = Equal - -- | Keys don't have any common part. - | NoPrefix - -- | The first key is the prefix for the second one. - | FstIsPref { diff :: !Key} - -- | The second key is the prefix for the first one. - | SndIsPref { diff :: !Key} - -- | Key have same prefix. - | Diff { pref :: !Key - , diffFst :: !Key - , diffSnd :: !Key - } + = Equal -- ^ Keys are equal + | NoPrefix -- ^ Keys don't have any common part. + | FstIsPref -- ^ The first key is the prefix of the second one. + !Key -- ^ Rest of the second key. + | SndIsPref -- ^ The second key is the prefix of the first one. + !Key -- ^ Rest of the first key. + | Diff -- ^ Key have a common prefix. + !Key -- ^ Common prefix. + !Key -- ^ Rest of the first key. + !Key -- ^ Rest of the second key. deriving (Show, Eq) +-- | Compares two keys keysDiff :: Key -> Key -> KeysDiff keysDiff (x :|| xs) (y :|| ys) | x == y = listSame xs ys [] diff --git a/src/Toml/Printer.hs b/src/Toml/Printer.hs --- a/src/Toml/Printer.hs +++ b/src/Toml/Printer.hs @@ -7,17 +7,18 @@ , defaultOptions , pretty , prettyOptions - , prettyTomlInd + , prettyKey ) where import Data.HashMap.Strict (HashMap) -import Data.Monoid ((<>), mconcat) +import Data.List (sortOn, splitAt) +import Data.List.NonEmpty (NonEmpty) +import Data.Monoid ((<>)) import Data.Text (Text) -import Data.Time (formatTime, defaultTimeLocale, ZonedTime) -import Data.List (splitAt, sortOn) +import Data.Time (ZonedTime, defaultTimeLocale, formatTime) import Toml.PrefixTree (Key (..), Piece (..), PrefixMap, PrefixTree (..)) -import Toml.Type (AnyValue (..), DateTime (..), TOML (..), Value (..)) +import Toml.Type (AnyValue (..), TOML (..), Value (..)) import qualified Data.HashMap.Strict as HashMap import qualified Data.List.NonEmpty as NonEmpty @@ -25,26 +26,19 @@ {- | Configures the pretty printer. -} data PrintOptions = PrintOptions - { shouldSort :: Bool -- ^ should table keys be sorted ot shouldn't + { shouldSort :: Bool -- ^ should table keys be sorted or not , indent :: Int -- ^ indentation size } deriving (Show) -{- | Default printing options. -} +{- | Default printing options. + +1. Sorts all keys and tables by name. +2. Indents with 2 spaces. +-} defaultOptions :: PrintOptions defaultOptions = PrintOptions True 2 --- Returns an indentation prefix -tabWith :: PrintOptions -> Int -> Text -tabWith options n = - Text.cons '\n' (Text.replicate (n * indent options) " ") - --- Returns a proper sorting function -orderWith :: Ord k => PrintOptions -> [(k, v)] -> [(k, v)] -orderWith options - | shouldSort options = sortOn fst - | otherwise = id - -{- | Converts 'TOML' type into 'Text' (using 'defaultOptions'). +{- | Converts 'TOML' type into 'Data.Text.Text' (using 'defaultOptions'). For example, this @@ -59,6 +53,7 @@ [("name", AnyValue $ Text "Kowainik")] } )] + , tomlTableArrays = mempty } @ @@ -68,53 +63,51 @@ title = "TOML Example" [example.owner] - name = "Kowainik" - + name = \"Kowainik\" @ -} pretty :: TOML -> Text pretty = prettyOptions defaultOptions -{- | Converts 'TOML' type into 'Text' using provided 'PrintOptions' -} +-- | Converts 'TOML' type into 'Data.Text.Text' using provided 'PrintOptions' prettyOptions :: PrintOptions -> TOML -> Text -prettyOptions options = Text.drop 1 . prettyTomlInd options 0 "" +prettyOptions options = Text.unlines . prettyTomlInd options 0 "" --- | Converts 'TOML' into 'Text' with the given indent. +-- | 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{..} = - prettyKeyValue options i tomlPairs <> "\n" - <> prettyTables options i prefix tomlTables + -> [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 = - Text.concat . map kvText . orderWith options . HashMap.toList +prettyKeyValue :: PrintOptions -> Int -> HashMap Key AnyValue -> [Text] +prettyKeyValue options i = mapOrdered (\kv -> [kvText kv]) options where kvText :: (Key, AnyValue) -> Text - kvText (k, AnyValue v) = mconcat - [ tabWith options i - , prettyKey k - , " = " - , valText v ] + 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 (Date d) = timeText d + 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) <> "]" - timeText :: DateTime -> Text - timeText (Zoned z) = showZonedTime z - timeText (Local l) = showText l - timeText (Day d) = showText d - timeText (Hours h) = showText h - showText :: Show a => a -> Text showText = Text.pack . show @@ -134,36 +127,60 @@ . formatTime defaultTimeLocale "%z" -- | Returns pretty formatted tables section of the 'TOML'. -prettyTables :: PrintOptions -> Int -> Text -> PrefixMap TOML -> Text -prettyTables options i pref = - Text.concat . map (prettyTable . snd) . orderWith options . HashMap.toList +prettyTables :: PrintOptions -> Int -> Text -> PrefixMap TOML -> [Text] +prettyTables options i pref = mapOrdered (prettyTable . snd) options where - prettyTable :: PrefixTree TOML -> Text + prettyTable :: PrefixTree TOML -> [Text] prettyTable (Leaf k toml) = - let name = getPref k in mconcat - [ tabWith options i - , prettyTableName name - , prettyTomlInd options (succ i) name 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 = getPref k - nextI = succ i + let name = addPrefix k pref + nextI = i + 1 toml = case mToml of - Nothing -> "" + Nothing -> [] Just t -> prettyTomlInd options nextI name t - in mconcat - [ tabWith options i - , prettyTableName name - , toml - , prettyTables options nextI name prefMap ] - - -- Adds next part of the table name to the accumulator. - getPref :: Key -> Text - getPref k = case pref of - "" -> prettyKey k - _ -> pref <> "." <> prettyKey k + -- 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 <> "]" -prettyKey :: Key -> Text -prettyKey (Key k) = Text.intercalate "." $ map unPiece (NonEmpty.toList k) +prettyTableArrays :: PrintOptions -> Int -> Text -> HashMap Key (NonEmpty TOML) -> [Text] +prettyTableArrays options i pref = mapOrdered arrText options + 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 options n = Text.replicate (n * indent options) " " + +-- Returns a proper sorting function +mapOrdered :: Ord k => ((k, v) -> [t]) -> PrintOptions -> HashMap k v -> [t] +mapOrdered f options + | shouldSort options = concatMap f . sortOn fst . HashMap.toList + | otherwise = concatMap f . HashMap.toList + +-- 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,3 +1,5 @@ +-- | Core types for TOML AST. + module Toml.Type ( module Toml.Type.AnyValue , module Toml.Type.TOML 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 @@ -1,29 +1,41 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} +-- | Existential wrapper over 'Value' type and matching functions. + module Toml.Type.AnyValue ( AnyValue (..) , reifyAnyValues , toMArray -- * Matching - , liftMatch + , MatchError (..) + , mkMatchError , matchBool , matchInteger , matchDouble , matchText - , matchDate + , matchZoned + , matchLocal + , matchDay + , matchHours , matchArray + , applyAsToAny ) where import Control.DeepSeq (NFData, rnf) import Data.Text (Text) +import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime) import Data.Type.Equality ((:~:) (..)) +import GHC.Generics (Generic) -import Toml.Type.Value (DateTime, TValue (..), TypeMismatchError, Value (..), sameValue) +import Toml.Type.Value (TValue (..), TypeMismatchError (..), Value (..), sameValue) + -- | Existential wrapper for 'Value'. data AnyValue = forall (t :: TValue) . AnyValue (Value t) @@ -38,42 +50,68 @@ instance NFData AnyValue where rnf (AnyValue val) = rnf val +-- | Value type mismatch error. +data MatchError = MatchError + { valueExpected :: TValue + , valueActual :: AnyValue + } deriving (Eq, Show, Generic, NFData) + +-- | Helper function to create 'MatchError'. +mkMatchError :: TValue -> Value t -> Either MatchError a +mkMatchError t = Left . MatchError t . AnyValue + ---------------------------------------------------------------------------- -- Matching functions for values ---------------------------------------------------------------------------- --- | Extract 'Bool' from 'Value'. -matchBool :: Value t -> Maybe Bool -matchBool (Bool b) = Just b -matchBool _ = Nothing +-- | Extract 'Prelude.Bool' from 'Value'. +matchBool :: Value t -> Either MatchError Bool +matchBool (Bool b) = Right b +matchBool value = mkMatchError TBool value --- | Extract 'Integer' from 'Value'. -matchInteger :: Value t -> Maybe Integer -matchInteger (Integer n) = Just n -matchInteger _ = Nothing +-- | Extract 'Prelude.Integer' from 'Value'. +matchInteger :: Value t -> Either MatchError Integer +matchInteger (Integer n) = Right n +matchInteger value = mkMatchError TInteger value --- | Extract 'Double' from 'Value'. -matchDouble :: Value t -> Maybe Double -matchDouble (Double f) = Just f -matchDouble _ = Nothing +-- | Extract 'Prelude.Double' from 'Value'. +matchDouble :: Value t -> Either MatchError Double +matchDouble (Double f) = Right f +matchDouble value = mkMatchError TDouble value --- | Extract 'Text' from 'Value'. -matchText :: Value t -> Maybe Text -matchText (Text s) = Just s -matchText _ = Nothing +-- | Extract 'Data.Text.Text' from 'Value'. +matchText :: Value t -> Either MatchError Text +matchText (Text s) = Right s +matchText value = mkMatchError TText value --- | Extract 'DateTime' from 'Value'. -matchDate :: Value t -> Maybe DateTime -matchDate (Date d) = Just d -matchDate _ = Nothing +-- | Extract 'Data.Time.ZonedTime' from 'Value'. +matchZoned :: Value t -> Either MatchError ZonedTime +matchZoned (Zoned d) = Right d +matchZoned value = mkMatchError TZoned value +-- | Extract 'Data.Time.LocalTime' from 'Value'. +matchLocal :: Value t -> Either MatchError LocalTime +matchLocal (Local d) = Right d +matchLocal value = mkMatchError TLocal value + +-- | Extract 'Data.Time.Day' from 'Value'. +matchDay :: Value t -> Either MatchError Day +matchDay (Day d) = Right d +matchDay value = mkMatchError TDay value + +-- | Extract 'Data.Time.TimeOfDay' from 'Value'. +matchHours :: Value t -> Either MatchError TimeOfDay +matchHours (Hours d) = Right d +matchHours value = mkMatchError THours value + -- | Extract list of elements of type @a@ from array. -matchArray :: (AnyValue -> Maybe a) -> Value t -> Maybe [a] -matchArray matchValue (Array a) = mapM (liftMatch matchValue) a -matchArray _ _ = Nothing +matchArray :: (AnyValue -> Either MatchError a) -> Value t -> Either MatchError [a] +matchArray matchValue (Array a) = mapM (applyAsToAny matchValue) a +matchArray _ value = mkMatchError TArray value -liftMatch :: (AnyValue -> Maybe a) -> (Value t -> Maybe a) -liftMatch fromAnyValue = fromAnyValue . AnyValue +-- | Make function that works with 'AnyValue' also work with specific 'Value'. +applyAsToAny :: (AnyValue -> r) -> (Value t -> r) +applyAsToAny f = f . AnyValue -- | Checks whether all elements inside given list of 'AnyValue' have the same -- type as given 'Value'. Returns list of @Value t@ without given 'Value'. @@ -82,8 +120,8 @@ reifyAnyValues v (AnyValue av : xs) = sameValue v av >>= \Refl -> (av :) <$> reifyAnyValues v xs -- | Function for creating 'Array' from list of 'AnyValue'. -toMArray :: [AnyValue] -> Maybe (Value 'TArray) -toMArray [] = Just $ Array [] +toMArray :: [AnyValue] -> Either MatchError (Value 'TArray) +toMArray [] = Right $ Array [] toMArray (AnyValue x : xs) = case reifyAnyValues x xs of - Left _ -> Nothing - Right vals -> Just $ Array (x : vals) + Left TypeMismatchError{..} -> mkMatchError typeExpected x + Right vals -> Right $ Array (x : vals) 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,14 +1,18 @@ {-# LANGUAGE DeriveAnyClass #-} +-- | Type of TOML AST. This is intermediate representation of TOML parsed from text. + module Toml.Type.TOML ( TOML (..) , insertKeyVal , insertKeyAnyVal , insertTable + , insertTableArrays ) where import Control.DeepSeq (NFData) import Data.HashMap.Strict (HashMap) +import Data.List.NonEmpty (NonEmpty) import Data.Semigroup (Semigroup (..)) import GHC.Generics (Generic) @@ -20,22 +24,82 @@ import qualified Toml.PrefixTree as Prefix --- TODO: describe how some TOML document will look like with this type -{- | Represents TOML configuration value. -} +{- | Represents TOML configuration value. + +For example, if we have the following @TOML@ file: + +@ +server.port = 8080 +server.codes = [ 5, 10, 42 ] +server.description = "This is production server." + +[mail] + host = "smtp.gmail.com" + send-if-inactive = false + +[[user]] + id = 42 + +[[user]] + name = "Foo Bar" +@ + +corresponding 'TOML' looks like: + +@ +TOML + { tomlPairs = fromList + [ ( "server" :| [ "port" ] , Integer 8080) + , ( "server" :| [ "codes" ] , Array [ Integer 5 , Integer 10 , Integer 42]) + , ( "server" :| [ "description" ] , Text "This is production server.") + ] + , tomlTables = fromList + [ ( "mail" + , Leaf ( "mail" :| [] ) + ( TOML + { tomlPairs = fromList + [ ( "host" :| [] , Text "smtp.gmail.com") + , ( "send-if-inactive" :| [] , Bool False) + ] + , tomlTables = fromList [] + , tomlTableArrays = fromList [] + } + ) + ) + ] + , tomlTableArrays = fromList + [ ( "user" :| [] + , TOML + { tomlPairs = fromList [( "id" :| [] , Integer 42)] + , tomlTables = fromList [] + , tomlTableArrays = fromList [] + } :| + [ TOML + { tomlPairs = fromList [( "name" :| [] , Text "Foo Bar")] + , tomlTables = fromList [] + , tomlTableArrays = fromList [] + } + ] + ) + ] + } +@ +-} data TOML = TOML - { tomlPairs :: HashMap Key AnyValue - , tomlTables :: PrefixMap TOML - -- tomlTableArrays :: HashMap Key (NonEmpty TOML) + { tomlPairs :: HashMap Key AnyValue + , tomlTables :: PrefixMap TOML + , tomlTableArrays :: HashMap Key (NonEmpty TOML) } deriving (Show, Eq, NFData, Generic) instance Semigroup TOML where - (TOML pairsA tablesA) <> (TOML pairsB tablesB) = TOML + (TOML pairsA tablesA arraysA) <> (TOML pairsB tablesB arraysB) = TOML (pairsA <> pairsB) (HashMap.unionWith (<>) tablesA tablesB) + (arraysA <> arraysB) instance Monoid TOML where mappend = (<>) - mempty = TOML mempty mempty + mempty = TOML mempty mempty mempty -- | Inserts given key-value into the 'TOML'. insertKeyVal :: Key -> Value a -> TOML -> TOML @@ -49,4 +113,10 @@ insertTable :: Key -> TOML -> TOML -> TOML insertTable k inToml toml = toml { tomlTables = Prefix.insert k inToml (tomlTables toml) + } + +-- | Inserts given array of tables into the 'TOML'. +insertTableArrays :: Key -> NonEmpty TOML -> TOML -> TOML +insertTableArrays k arr toml = toml + { tomlTableArrays = HashMap.insert k arr (tomlTableArrays toml) } 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,34 +1,57 @@ {-# LANGUAGE GADTs #-} +-- | Intermediate untype value representation used for parsing. + module Toml.Type.UValue ( UValue (..) , typeCheck ) where import Data.Text (Text) +import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime, zonedTimeToUTC) import Data.Type.Equality ((:~:) (..)) import Toml.Type.AnyValue (AnyValue (..)) -import Toml.Type.Value (DateTime, TypeMismatchError, Value (..), sameValue) +import Toml.Type.Value (TypeMismatchError, Value (..), sameValue) --- | Untyped value of 'TOML'. You shouldn't use this type in your code. Use +-- | Untyped value of @TOML@. You shouldn't use this type in your code. Use -- 'Value' instead. data UValue = UBool !Bool | UInteger !Integer | UDouble !Double | UText !Text - | UDate !DateTime + | UZoned !ZonedTime + | ULocal !LocalTime + | UDay !Day + | UHours !TimeOfDay | UArray ![UValue] - deriving (Eq, Show) + deriving (Show) +instance Eq UValue where + (UBool b1) == (UBool b2) = b1 == b2 + (UInteger i1) == (UInteger i2) = i1 == i2 + (UDouble f1) == (UDouble f2) + | isNaN f1 && isNaN f2 = True + | otherwise = f1 == f2 + (UText s1) == (UText s2) = s1 == s2 + (UZoned a) == (UZoned b) = zonedTimeToUTC a == zonedTimeToUTC b + (ULocal a) == (ULocal b) = a == b + (UDay a) == (UDay b) = a == b + (UHours a) == (UHours b) = a == b + (UArray a1) == (UArray a2) = a1 == a2 + _ == _ = False + -- | Ensures that 'UValue's represents type-safe version of @toml@. typeCheck :: UValue -> Either TypeMismatchError AnyValue typeCheck (UBool b) = rightAny $ Bool b typeCheck (UInteger n) = rightAny $ Integer n typeCheck (UDouble f) = rightAny $ Double f typeCheck (UText s) = rightAny $ Text s -typeCheck (UDate d) = rightAny $ Date d +typeCheck (UZoned d) = rightAny $ Zoned d +typeCheck (ULocal d) = rightAny $ Local d +typeCheck (UDay d) = rightAny $ Day d +typeCheck (UHours d) = rightAny $ Hours d typeCheck (UArray a) = case a of [] -> rightAny $ Array [] x:xs -> do 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 @@ -6,6 +6,8 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} +-- | GADT value for TOML. + module Toml.Type.Value ( -- * Type of value TValue (..) @@ -13,7 +15,6 @@ -- * Value , Value (..) - , DateTime (..) , eqValueList , valueType @@ -22,7 +23,7 @@ , sameValue ) where -import Control.DeepSeq (NFData(..), rnf) +import Control.DeepSeq (NFData (..), rnf) import Data.String (IsString (..)) import Data.Text (Text) import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime, zonedTimeToUTC) @@ -30,14 +31,13 @@ import GHC.Generics (Generic) -- | Needed for GADT parameterization -data TValue = TBool | TInteger | TDouble | TText | TDate | TArray - deriving (Eq, Show, NFData, Generic) +data TValue = TBool | TInteger | TDouble | TText | TZoned | TLocal | TDay | THours | TArray + deriving (Eq, Show, Read, NFData, Generic) +-- | Convert 'TValue' constructors to 'String' without @T@ prefix. showType :: TValue -> String showType = drop 1 . show --- TODO: examples are copy-pasted from TOML specification. Probably most of them --- will be moved into parsing module in future. -- | Value in @key = value@ pair. data Value (t :: TValue) where {- | Boolean value: @@ -57,9 +57,9 @@ int3 = 0 int4 = -17 int5 = 5_349_221 -hex1 = 0xDEADBEEF -oct2 = 0o755 # useful for Unix file permissions -bin1 = 0b11010110 +hex1 = 0xDEADBEEF # hexadecimal +oct2 = 0o755 # octal, useful for Unix file permissions +bin1 = 0b11010110 # binary @ -} Integer :: Integer -> Value 'TInteger @@ -67,10 +67,28 @@ {- | Floating point number: @ -flt1 = -3.1415 # fractional -flt2 = 1e6 # exponent -flt3 = 6.626e-34 # both -flt4 = 9_224_617.445_991_228_313 +# fractional +flt1 = +1.0 +flt2 = 3.1415 +flt3 = -0.01 + +# exponent +flt4 = 5e+22 +flt5 = 1e6 +flt6 = -2E-2 + +# both +flt7 = 6.626e-34 + +# infinity +sf1 = inf # positive infinity +sf2 = +inf # positive infinity +sf3 = -inf # negative infinity + +# not a number +sf4 = nan # actual sNaN/qNaN encoding is implementation specific +sf5 = +nan # same as \`nan\` +sf6 = -nan # same as \`nan\` @ -} Double :: Double -> Value 'TDouble @@ -78,16 +96,62 @@ {- | String value: @ -key = "value" -bare_key = "value" -bare-key = "value" +# basic string +name = \"Orange\" +physical.color = "orange" +physical.shape = "round" + +# multiline basic string +str1 = """ +Roses are red +Violets are blue""" + +# literal string: What you see is what you get. +winpath = 'C:\Users\nodejs\templates' +winpath2 = '\\ServerX\admin$\system32\' +quoted = 'Tom \"Dubs\" Preston-Werner' +regex = '<\i\c*\s*>' @ -} Text :: Text -> Value 'TText - -- | Date-time. See documentation for 'DateTime' type. - Date :: DateTime -> Value 'TDate + {- | Offset date-time: +@ +odt1 = 1979-05-27T07:32:00Z +odt2 = 1979-05-27T00:32:00-07:00 +odt3 = 1979-05-27T00:32:00.999999-07:00 +@ + -} + Zoned :: ZonedTime -> Value 'TZoned + + {- | Local date-time (without offset): + +@ +ldt1 = 1979-05-27T07:32:00 +ldt2 = 1979-05-27T00:32:00.999999 +@ + -} + Local :: LocalTime -> Value 'TLocal + + {- | Local date (only day): + +@ +ld1 = 1979-05-27 +@ + -} + Day :: Day -> Value 'TDay + + {- | Local time (time of the day): + +@ +lt1 = 07:32:00 +lt2 = 00:32:00.999999 + +@ + -} + Hours :: TimeOfDay -> Value 'THours + {- | Array of values. According to TOML specification all values in array should have the same type. This is guaranteed statically with this type. @@ -95,7 +159,7 @@ arr1 = [ 1, 2, 3 ] arr2 = [ "red", "yellow", "green" ] arr3 = [ [ 1, 2 ], [3, 4, 5] ] -arr4 = [ "all", 'strings', """are the same""", '''type'''] +arr4 = [ "all", \'strings\', """are the same""", \'\'\'type\'\'\'] arr5 = [ [ 1, 2 ], ["a", "b", "c"] ] arr6 = [ 1, 2.0 ] # INVALID @@ -106,12 +170,15 @@ deriving instance Show (Value t) instance NFData (Value t) where - rnf (Bool n) = rnf n + rnf (Bool n) = rnf n rnf (Integer n) = rnf n - rnf (Double n) = rnf n - rnf (Text n) = rnf n - rnf (Date n) = rnf n - rnf (Array n) = rnf n + rnf (Double n) = rnf n + rnf (Text n) = rnf n + rnf (Zoned n) = rnf n + rnf (Local n) = rnf n + rnf (Day n) = rnf n + rnf (Hours n) = rnf n + rnf (Array n) = rnf n instance (t ~ 'TInteger) => Num (Value t) where (Integer a) + (Integer b) = Integer $ a + b @@ -131,9 +198,13 @@ | isNaN f1 && isNaN f2 = True | otherwise = f1 == f2 (Text s1) == (Text s2) = s1 == s2 - (Date d1) == (Date d2) = d1 == d2 + (Zoned a) == (Zoned b) = zonedTimeToUTC a == zonedTimeToUTC b + (Local a) == (Local b) = a == b + (Day a) == (Day b) = a == b + (Hours a) == (Hours b) = a == b (Array a1) == (Array a2) = eqValueList a1 a2 +-- | Compare list of 'Value' of possibly different types. eqValueList :: [Value a] -> [Value b] -> Bool eqValueList [] [] = True eqValueList (x:xs) (y:ys) = case sameValue x y of @@ -141,67 +212,19 @@ Left _ -> False eqValueList _ _ = False --- | Reifies type of 'Value' into 'ValueType'. Unfortunately, there's no way to +-- | Reifies type of 'Value' into 'TValue'. Unfortunately, there's no way to -- guarante that 'valueType' will return @t@ for object with type @Value \'t@. valueType :: Value t -> TValue valueType (Bool _) = TBool valueType (Integer _) = TInteger valueType (Double _) = TDouble valueType (Text _) = TText -valueType (Date _) = TDate +valueType (Zoned _) = TZoned +valueType (Local _) = TLocal +valueType (Day _) = TDay +valueType (Hours _) = THours valueType (Array _) = TArray -data DateTime - {- | Offset date-time: - -@ -odt1 = 1979-05-27T07:32:00Z -odt2 = 1979-05-27T00:32:00-07:00 -@ - -} - = Zoned !ZonedTime - - {- | Local date-time (without offset): - -@ -ldt1 = 1979-05-27T07:32:00 -ldt2 = 1979-05-27T00:32:00.999999 -@ - -} - | Local !LocalTime - - {- | Local date (only day): - -@ -ld1 = 1979-05-27 -@ - -} - | Day !Day - - {- | Local time (time of the day): - -@ -lt1 = 07:32:00 -lt2 = 00:32:00.999999 - -@ - -} - | Hours !TimeOfDay - deriving (Show) - -instance Eq DateTime where - (Zoned a) == (Zoned b) = zonedTimeToUTC a == zonedTimeToUTC b - (Local a) == (Local b) = a == b - (Day a) == (Day b) = a == b - (Hours a) == (Hours b) = a == b - _ == _ = False - -instance NFData DateTime where - rnf (Zoned n) = rnf n - rnf (Local n) = rnf n - rnf (Day n) = rnf n - rnf (Hours n) = rnf n - ---------------------------------------------------------------------------- -- Typechecking values ---------------------------------------------------------------------------- @@ -216,12 +239,19 @@ show TypeMismatchError{..} = "Expected type '" ++ showType typeExpected ++ "' but actual type: '" ++ showType typeActual ++ "'" +{- | 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. +-} sameValue :: Value a -> Value b -> Either TypeMismatchError (a :~: b) sameValue Bool{} Bool{} = Right Refl sameValue Integer{} Integer{} = Right Refl sameValue Double{} Double{} = Right Refl sameValue Text{} Text{} = Right Refl -sameValue Date{} Date{} = Right Refl +sameValue Zoned{} Zoned{} = Right Refl +sameValue Local{} Local{} = Right Refl +sameValue Day{} Day{} = Right Refl +sameValue Hours{} Hours{} = Right Refl sameValue Array{} Array{} = Right Refl sameValue l r = Left $ TypeMismatchError { typeExpected = valueType l diff --git a/test/Test/Toml/BiCode/Property.hs b/test/Test/Toml/BiCode/Property.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/BiCode/Property.hs @@ -0,0 +1,178 @@ +module Test.Toml.BiCode.Property where + +import Control.Applicative ((<|>)) +import Control.Category ((>>>)) +import Data.ByteString (ByteString) +import Data.HashSet (HashSet) +import Data.IntSet (IntSet) +import Data.List.NonEmpty (NonEmpty) +import Data.Set (Set) +import Data.Text (Text) +import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime, zonedTimeToUTC) +import GHC.Exts (fromList) +import Hedgehog (Gen, forAll, tripping) +import Numeric.Natural (Natural) + +import Toml (TomlBiMap, TomlCodec, (.=)) +import Toml.Bi.Code (decode, encode) + +import Test.Toml.Gen (PropertyTest, genBool, genByteString, genDay, genDouble, genFloat, genHashSet, + genHours, genInt, genIntSet, genInteger, genLByteString, genLocal, genNatural, + genNonEmpty, genString, genText, genWord, genZoned, prop) + +import qualified Data.ByteString.Lazy as L +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import qualified Toml + +test_encodeDecodeProp :: PropertyTest +test_encodeDecodeProp = prop "decode . encode == id" $ do + bigType <- forAll genBigType + tripping bigType (encode bigTypeCodec) (decode bigTypeCodec) + +data BigType = BigType + { btBool :: Bool + , btInteger :: Integer + , btNatural :: Natural + , btInt :: Int + , btWord :: Word + , btDouble :: Batman Double + , btFloat :: Batman Float + , btText :: Text + , btString :: String + , btBS :: ByteString + , btLazyBS :: L.ByteString + , btLocalTime :: LocalTime + , btDay :: Day + , btTimeOfDay :: TimeOfDay + , btArray :: [Int] + , btArraySet :: Set Word + , btArrayIntSet :: IntSet + , btArrayHashSet :: HashSet Natural + , btArrayNonEmpty :: NonEmpty Text + , btNonEmpty :: NonEmpty ByteString + , btList :: [Bool] + , btNewtype :: BigTypeNewtype + , btSum :: BigTypeSum + , btRecord :: BigTypeRecord + } deriving (Show, Eq) + +-- | Wrapper over 'Double' and 'Float' to be equal on @NaN@ values. +newtype Batman a = Batman a + deriving (Show) + +instance RealFloat a => Eq (Batman a) where + Batman a == Batman b = + if isNaN a + then isNaN b + else a == b + +newtype BigTypeNewtype = BigTypeNewtype ZonedTime + deriving (Show) + +instance Eq BigTypeNewtype where + (BigTypeNewtype a) == (BigTypeNewtype b) = zonedTimeToUTC a == zonedTimeToUTC b + +data BigTypeSum = BigTypeSumA Integer | BigTypeSumB Text + deriving (Show, Eq) + +data BigTypeRecord = BigTypeRecord + { btrBoolSet :: Set Bool + , btrNewtypeList :: [BigTypeSum] + } deriving (Show, Eq) + +bigTypeCodec :: TomlCodec BigType +bigTypeCodec = BigType + <$> Toml.bool "bool" .= btBool + <*> Toml.integer "integer" .= btInteger + <*> Toml.natural "natural" .= btNatural + <*> Toml.int "int" .= btInt + <*> Toml.word "word" .= btWord + <*> Toml.diwrap (Toml.double "double") .= btDouble + <*> Toml.diwrap (Toml.float "float") .= btFloat + <*> Toml.text "text" .= btText + <*> Toml.string "string" .= btString + <*> Toml.byteString "bs" .= btBS + <*> Toml.lazyByteString "lbs" .= btLazyBS + <*> Toml.localTime "localTime" .= btLocalTime + <*> Toml.day "day" .= btDay + <*> Toml.timeOfDay "timeOfDay" .= btTimeOfDay + <*> Toml.arrayOf Toml._Int "arrayOfInt" .= btArray + <*> Toml.arraySetOf Toml._Word "arraySetOfWord" .= btArraySet + <*> Toml.arrayIntSet "arrayIntSet" .= btArrayIntSet + <*> Toml.arrayHashSetOf Toml._Natural "arrayHashSetDouble" .= btArrayHashSet + <*> Toml.arrayNonEmptyOf Toml._Text "arrayNonEmptyOfText" .= btArrayNonEmpty + <*> Toml.nonEmpty (Toml.byteString "bs") "nonEmptyBS" .= btNonEmpty + <*> Toml.list (Toml.bool "bool") "listBool" .= btList + <*> Toml.diwrap (Toml.zonedTime "nt.zonedTime") .= btNewtype + <*> bigTypeSumCodec .= btSum + <*> Toml.table bigTypeRecordCodec "table-record" .= btRecord + +_BigTypeSumA :: TomlBiMap BigTypeSum Integer +_BigTypeSumA = Toml.prism BigTypeSumA $ \case + BigTypeSumA i -> Right i + other -> Toml.wrongConstructor "BigTypeSumA" other + +_BigTypeSumB :: TomlBiMap BigTypeSum Text +_BigTypeSumB = Toml.prism BigTypeSumB $ \case + BigTypeSumB n -> Right n + other -> Toml.wrongConstructor "BigTypeSumB" other + +bigTypeSumCodec :: TomlCodec BigTypeSum +bigTypeSumCodec = + Toml.match (_BigTypeSumA >>> Toml._Integer) "sum.integer" + <|> Toml.match (_BigTypeSumB >>> Toml._Text) "sum.text" + +bigTypeRecordCodec :: TomlCodec BigTypeRecord +bigTypeRecordCodec = BigTypeRecord + <$> Toml.arraySetOf Toml._Bool "rboolSet" .= btrBoolSet + <*> Toml.list bigTypeSumCodec "rnewtype" .= btrNewtypeList + +---------------------------------------------------------------------------- +-- Generator +---------------------------------------------------------------------------- + +genBigType :: Gen BigType +genBigType = do + btBool <- genBool + btInteger <- genInteger + btNatural <- genNatural + btInt <- genInt + btWord <- genWord + btDouble <- Batman <$> genDouble + btFloat <- Batman <$> genFloat + btText <- genText + btString <- genString + btBS <- genByteString + btLazyBS <- genLByteString + btLocalTime <- genLocal + btDay <- genDay + btTimeOfDay <- genHours + btArray <- Gen.list (Range.constant 0 5) genInt + btArraySet <- Gen.set (Range.constant 0 5) genWord + btArrayIntSet <- genIntSet + btArrayHashSet <- genHashSet genNatural + btArrayNonEmpty <- genNonEmpty genText + btNonEmpty <- genNonEmpty genByteString + btList <- Gen.list (Range.constant 0 5) genBool + btNewtype <- genNewType + btSum <- genSum + btRecord <- genRec + pure BigType {..} + +-- Custom generators + +genNewType :: Gen BigTypeNewtype +genNewType = BigTypeNewtype <$> genZoned + +genSum :: Gen BigTypeSum +genSum = Gen.choice + [ BigTypeSumA <$> genInteger + , BigTypeSumB <$> genText + ] + +genRec :: Gen BigTypeRecord +genRec = do + btrBoolSet <- fromList <$> Gen.list (Range.constant 0 5) genBool + btrNewtypeList <- Gen.list (Range.constant 0 5) genSum + pure BigTypeRecord{..} diff --git a/test/Test/Toml/BiMap/Property.hs b/test/Test/Toml/BiMap/Property.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/BiMap/Property.hs @@ -0,0 +1,64 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Test.Toml.BiMap.Property where + +import Hedgehog (Gen, PropertyT, assert, forAll, tripping, (===)) + +import Data.Time (ZonedTime (..)) +import Test.Tasty (testGroup) +import Test.Toml.Gen (PropertyTest, prop) +import Toml.Bi.Map (BiMap (..), TomlBiMap) + +import qualified Hedgehog.Gen as Gen +import qualified Test.Toml.Gen as G +import qualified Toml.Bi.Map as B + + +testBiMap + :: (Monad m, Show a, Show b, Eq a) + => TomlBiMap a b + -> Gen a + -> PropertyT m () +testBiMap bimap gen = do + x <- forAll gen + tripping x (forward bimap) (backward bimap =<<) + +-- Double needs a special test because NaN /= NaN +testDouble :: PropertyT IO () +testDouble = do + x <- forAll G.genDouble + if isNaN x + then assert $ + fmap isNaN (forward B._Double x >>= backward B._Double) == Right True + else (forward B._Double x >>= backward B._Double) === Right x + +test_BiMaps :: PropertyTest +test_BiMaps = pure $ testGroup "BiMap roundtrip tests" $ concat + [ prop "Bool" (testBiMap B._Bool G.genBool) + , prop "Integer" (testBiMap B._Integer G.genInteger) + , prop "Natural" (testBiMap B._Natural G.genNatural) + , prop "Int" (testBiMap B._Int G.genInt) + , prop "Word" (testBiMap B._Word G.genWord) + , prop "Double" testDouble + , prop "Float" (testBiMap B._Float G.genFloat) + , prop "Text" (testBiMap B._Text G.genText) + , prop "LazyText" (testBiMap B._LText G.genLText) + , prop "String" (testBiMap B._String G.genString) + , prop "Read (Integer)" (testBiMap B._Read G.genInteger) + , prop "ByteString" (testBiMap B._ByteString G.genByteString) + , prop "Lazy ByteString" (testBiMap B._LByteString G.genLByteString) + , prop "ZonedTime" (testBiMap B._ZonedTime G.genZoned) + , prop "LocalTime" (testBiMap B._LocalTime G.genLocal) + , prop "TimeOfDay" (testBiMap B._TimeOfDay G.genHours) + , prop "Day" (testBiMap B._Day G.genDay) + , prop "IntSet" (testBiMap B._IntSet G.genIntSet) + , prop "Array (Day)" (testBiMap (B._Array B._Day) (G.genList G.genDay)) + , prop "Set (Day)" (testBiMap (B._Set B._Day) (Gen.set G.range100 G.genDay)) + , prop "NonEmpty (Day)" (testBiMap (B._NonEmpty B._Day) (G.genNonEmpty G.genDay)) + , prop "HashSet (Integer)" (testBiMap (B._HashSet B._Integer) (G.genHashSet G.genInteger)) + ] + +-- Orphan instances + +instance Eq ZonedTime where + (ZonedTime a b) == (ZonedTime c d) = a == c && b == d 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 @@ -11,32 +11,72 @@ , prop -- * Generators + -- ** Primitive + , genInt + , genInteger + , genDouble + , genWord + , genNatural + , genFloat + + , genList + , genNonEmpty + , genHashSet + , genIntSet + + , genBool + + , genText + , genString + , genByteString + , genLByteString + , genLText + + -- ** Dates + , genDay + , genHours + , genLocal + , genZoned + + -- ** @TOML@ specific , genVal , genKey , genPrefixMap , genToml + + -- ** Other + , range100 ) where import Control.Applicative (liftA2) import Control.Monad (forM, replicateM) +import Data.ByteString (ByteString) import Data.Fixed (Fixed (..)) -import Data.Maybe (fromMaybe) +import Data.Hashable (Hashable) +import Data.HashSet (HashSet) +import Data.IntSet (IntSet) +import Data.List.NonEmpty (NonEmpty) import Data.Text (Text) import Data.Time (Day, LocalTime (..), TimeOfDay (..), ZonedTime (..), fromGregorian, minutesToTimeZone) +import GHC.Exts (fromList) import GHC.Stack (HasCallStack) -import Hedgehog (MonadGen, PropertyT, property) +import Hedgehog (Gen, MonadGen, PropertyT, Range, property) +import Numeric.Natural (Natural) import Test.Tasty (TestName, TestTree) import Test.Tasty.Hedgehog (testProperty) -import Toml.BiMap (toMArray) -import Toml.PrefixTree (pattern (:||), Key (..), Piece (..), PrefixMap, PrefixTree (..), fromList) -import Toml.Type (AnyValue (..), DateTime (..), TOML (..), TValue (..), Value (..)) +import Toml.Bi.Map (toMArray) +import Toml.PrefixTree (pattern (:||), Key (..), Piece (..), PrefixMap, PrefixTree (..)) +import Toml.Type (AnyValue (..), TOML (..), TValue (..), Value (..)) -import qualified Data.HashMap.Strict as HashMap +import qualified Data.ByteString.Lazy as LB +import qualified Data.List.NonEmpty as NE 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 @@ -51,18 +91,19 @@ -- Common generators ---------------------------------------------------------------------------- +-- @TOML@ specific + type V = Int genVal :: MonadGen m => m V genVal = Gen.int (Range.constant 0 256) --- TODO: Arrays and Date. -- | Generates random value of 'AnyValue' type. genAnyValue :: MonadGen m => m AnyValue genAnyValue = Gen.choice $ (AnyValue <$> genArray) : noneArrayList - -- TODO: unicode support +-- [#177]: see issue here: https://github.com/kowainik/tomland/issues/177 genPiece :: MonadGen m => m Piece genPiece = Piece <$> Gen.text (Range.constant 1 50) Gen.alphaNum @@ -87,7 +128,7 @@ tree <- genPrefixTree key pure (piece, tree) - pure $ HashMap.fromList kvps + pure $ fromList kvps genPrefixTree :: forall m . MonadGen m => Key -> m (PrefixTree V) genPrefixTree key = Gen.recursive @@ -103,21 +144,27 @@ prefVal <- Gen.maybe genVal pure $ Branch key prefVal prefMap -genTableHeader :: MonadGen m => m (Key, TOML) -genTableHeader = do - k <- genKey - toml <- makeToml <$> genKeyAnyValueList - pure (k, toml) - where - makeToml :: [(Key, AnyValue)] -> TOML - makeToml kv = TOML (HashMap.fromList kv) mempty +makeToml :: [(Key, AnyValue)] -> TOML +makeToml kv = TOML (fromList kv) mempty mempty genToml :: MonadGen m => m TOML -genToml = do - kv <- HashMap.fromList <$> genKeyAnyValueList - tables <- Gen.list (Range.linear 0 10) genTableHeader - pure $ TOML kv (fromList tables) +genToml = Gen.recursive + Gen.choice + [ makeToml <$> genKeyAnyValueList ] + [ TOML <$> keyValues <*> tables <*> arrays ] + where + keyValues = fromList <$> genKeyAnyValueList + tables = fmap Toml.fromList + $ Gen.list (Range.linear 0 5) + $ (,) <$> genKey <*> genToml + arrays = fmap fromList $ + Gen.list (Range.linear 0 5) $ do + key <- genKey + arr <- Gen.list (Range.linear 1 5) genToml + return (key, NE.fromList arr) +-- Date generators + genDay :: MonadGen m => m Day genDay = do y <- toInteger <$> Gen.int (Range.constant 1968 2019) @@ -144,28 +191,49 @@ let zTime = minutesToTimeZone zMin pure $ ZonedTime local zTime -genDate :: MonadGen m => m DateTime -genDate = Gen.choice - [ Day <$> genDay - , Hours <$> genHours - , Local <$> genLocal - , Zoned <$> genZoned - ] +-- Primitive generators -genBool :: MonadGen m => m Bool -genBool = Gen.bool +range100 :: Range Int +range100 = Range.constant 0 100 +genInt :: MonadGen m => m Int +genInt = Gen.int Range.constantBounded + genInteger :: MonadGen m => m Integer -genInteger = toInteger <$> Gen.int (Range.constantBounded @Int) +genInteger = toInteger <$> genInt genDouble :: MonadGen m => m Double genDouble = Gen.frequency - [ (50, Gen.double $ Range.constant @Double (-1000000.0) 1000000.0) - , (5, Gen.constant $ 1/0) - , (5, Gen.constant $ -1/0) - , (5, Gen.constant $ 0/0) + [ (10, Gen.double $ Range.constant @Double (-1000000.0) 1000000.0) + , (1, Gen.constant $ 1/0) + , (1, Gen.constant $ -1/0) + , (1, Gen.constant $ 0/0) ] +genWord :: MonadGen m => m Word +genWord = Gen.word Range.constantBounded + +genNatural :: MonadGen m => m Natural +genNatural = fromIntegral <$> genWord + +genFloat :: MonadGen m => m Float +genFloat = Gen.float (Range.constant (-10000.0) 10000.0) + +genHashSet :: (Eq a, Hashable a) => Gen a -> Gen (HashSet a) +genHashSet genA = fromList <$> genList genA + +genNonEmpty :: Gen a -> Gen (NonEmpty a) +genNonEmpty = Gen.nonEmpty (Range.constant 1 5) + +genList :: Gen a -> Gen [a] +genList = Gen.list range100 + +genIntSet :: Gen IntSet +genIntSet = fromList <$> genList genInt + +genBool :: MonadGen m => m Bool +genBool = Gen.bool + -- | Generatates control sympol. genEscapeSequence :: MonadGen m => m Text genEscapeSequence = Gen.element @@ -205,6 +273,18 @@ , genUniHex8Color ] +genString :: Gen String +genString = Text.unpack <$> genText + +genByteString :: Gen ByteString +genByteString = Gen.utf8 range100 Gen.alphaNum + +genLByteString :: Gen LB.ByteString +genLByteString = LB.fromStrict <$> genByteString + +genLText :: Gen L.Text +genLText = L.fromStrict <$> genText + -- | List of AnyValue generators. noneArrayList :: MonadGen m => [m AnyValue] noneArrayList = @@ -212,14 +292,18 @@ , AnyValue . Integer <$> genInteger , AnyValue . Double <$> genDouble , AnyValue . Text <$> genText - , AnyValue . Date <$> genDate + , AnyValue . Zoned <$> genZoned + , AnyValue . Local <$> genLocal + , AnyValue . Day <$> genDay + , AnyValue . Hours <$> genHours ] genArrayFrom :: MonadGen m => m AnyValue -> m (Value 'TArray) -genArrayFrom noneArray - = fromMaybe (error "Error in genArrayFrom") - . toMArray - <$> Gen.list (Range.constant 0 5) noneArray +genArrayFrom noneArray = do + eVal <- toMArray <$> Gen.list (Range.constant 0 5) noneArray + case eVal of + Left err -> error $ show err + Right val -> pure val {- | Generate arrays and nested arrays. For example: Common array: diff --git a/test/Test/Toml/Parsing/Unit.hs b/test/Test/Toml/Parsing/Unit.hs --- a/test/Test/Toml/Parsing/Unit.hs +++ b/test/Test/Toml/Parsing/Unit.hs @@ -2,259 +2,221 @@ module Test.Toml.Parsing.Unit where +import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Semigroup ((<>)) -import Data.Time (LocalTime (..), TimeOfDay (..), ZonedTime (..), fromGregorian, minutesToTimeZone) +import Data.Text (Text) +import Data.Time (Day, LocalTime (..), TimeOfDay (..), TimeZone, ZonedTime (..), fromGregorian, + minutesToTimeZone) import Test.Hspec.Megaparsec (parseSatisfies, shouldFailOn, shouldParse) -import Test.Tasty.Hspec (Spec, context, describe, it) -import Text.Megaparsec (parse) +import Test.Tasty.Hspec (Expectation, Spec, context, describe, it) +import Text.Megaparsec (Parsec, ShowErrorComponent, Stream, parse) -import Toml.Parser.Value (arrayP, boolP, dateTimeP, doubleP, integerP, keyP, textP) -import Toml.Parser.TOML (hasKeyP, tableHeaderP, tomlP) +import Toml.Edsl (mkToml, table, tableArray, (=:)) +import Toml.Parser.String (textP) +import Toml.Parser.TOML (hasKeyP, tableArrayP, tableP, tomlP, keyP) +import Toml.Parser.Value (arrayP, boolP, dateTimeP, doubleP, integerP) import Toml.PrefixTree (Key (..), Piece (..), fromList) -import Toml.Type (AnyValue (..), DateTime (..), TOML (..), UValue (..), Value (..)) +import Toml.Type (AnyValue (..), TOML (..), UValue (..), Value (..)) import qualified Data.HashMap.Lazy as HashMap import qualified Data.List.NonEmpty as NE +import qualified Data.Text as T spec_Parser :: Spec spec_Parser = do - let parseX p given expected = parse p "" given `shouldParse` expected - failOn p given = parse p "" `shouldFailOn` given - parseXSatisfies p given f = parse p "" given `parseSatisfies` f - - parseArray = parseX arrayP - parseBool = parseX boolP - parseDateTime = parseX dateTimeP - parseDouble = parseX doubleP - parseInteger = parseX integerP - parseKey = parseX keyP - parseHasKey = parseX hasKeyP - parseText = parseX textP - parseTable = parseX tableHeaderP - parseToml = parseX tomlP - - arrayFailOn = failOn arrayP - boolFailOn = failOn boolP - dateTimeFailOn = failOn dateTimeP - doubleFailOn = failOn doubleP - hasKeyFailOn = failOn hasKeyP - integerFailOn = failOn integerP - textFailOn = failOn textP - - doubleSatisfies = parseXSatisfies doubleP - - quoteWith q t = q <> t <> q - squote = quoteWith "'" - dquote = quoteWith "\"" - - makeDay year month day = Day $ fromGregorian year month day - makeHours hour minute second = Hours $ TimeOfDay hour minute second - makeLocal (Day day) (Hours hours) = Local $ LocalTime day hours - makeLocal _ _ = error "Invalid arguments, unable to construct `Local`" - makeZoned (Local local) offset = Zoned $ ZonedTime local offset - makeZoned _ _ = error "Invalid arguments, unable to construct `Zoned`" - makeOffset hours minutes = - minutesToTimeZone (hours * 60 + minutes * signum hours) - - makeKey k = (Key . NE.fromList) (map Piece k) - - tomlFromList kv = TOML (HashMap.fromList kv) mempty - + arraySpecs + boolSpecs + doubleSpecs + integerSpecs + keySpecs + textSpecs + dateSpecs + tomlSpecs - describe "arrayP" $ do - it "can parse arrays" $ do - parseArray "[]" [] - parseArray "[1]" [UInteger 1] - parseArray "[1, 2, 3]" [UInteger 1, UInteger 2, UInteger 3] - 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, 10:15:30]" - [UDate (makeDay 1920 12 10), UDate (makeHours 10 15 30)] - it "can parse multiline arrays" - $ parseArray "[\n1,\n2\n]" [UInteger 1, UInteger 2] - it "can parse an array of arrays" $ parseArray - "[[1], [2.3, 5.1]]" - [UArray [UInteger 1], UArray [UDouble 2.3, UDouble 5.1]] - it "can parse an array with terminating commas (trailing commas)" $ do - parseArray "[1, 2,]" [UInteger 1, UInteger 2] - parseArray "[1, 2, 3, , ,]" [UInteger 1, UInteger 2, UInteger 3] - 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]" - [UInteger 1, UInteger 2, UInteger 3, UInteger 4] - it "ignores white spaces" $ parseArray - "[ 1 , 2,3, 4 ]" - [UInteger 1, UInteger 2, UInteger 3, UInteger 4] - 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']" +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]" - 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" +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" - 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) - it - "can parse a number which consists of an integral part, and an exponent part" - $ do - parseDouble "5e+22" 5e+22 - parseDouble "1e6" 1e6 - parseDouble "-2E-2" (-2E-2) - it - "can parse a number which consists of an integral, a fractional, and an exponent part" - $ parseDouble "6.626e-34" 6.626e-34 - 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" +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 - 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 - integerFailOn "1_2_3_" - integerFailOn "13_" - integerFailOn "_123_" - integerFailOn "_13" - integerFailOn "_" - --xit "does not parse numbers with leading zeros" $ do - -- parseInt "0123" 0 - -- parseInt "-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 +integerSpecs :: Spec +integerSpecs = describe "integerP" $ do + context "when the integer is in decimal representation" $ do + it "can parse positive integer numbers" $ do + parseInteger "10" 10 + parseInteger "+3" 3 + parseInteger "0" 0 + it "can parse negative integer numbers" $ + parseInteger "-123" (-123) + it "can parse sign-prefixed zero as an unprefixed zero" $ do + parseInteger "+0" 0 + parseInteger "-0" 0 + it "can parse both the minimum and maximum numbers in the 64 bit range" $ do + parseInteger "-9223372036854775808" (-9223372036854775808) + parseInteger "9223372036854775807" 9223372036854775807 + it "can parse numbers with underscores between digits" $ do + parseInteger "1_000" 1000 + parseInteger "5_349_221" 5349221 + parseInteger "1_2_3_4_5" 12345 + it "does not parse incorrect underscores" $ do + integerFailOn "1_2_3_" + integerFailOn "13_" + integerFailOn "_123_" + integerFailOn "_13" + integerFailOn "_" + it "does not parse numbers with leading zeros" $ do + parseInteger "0123" 0 + parseInteger "-023" 0 + context "when the integer is in binary representation" $ do + it "can parse numbers prefixed with `0b`" $ do + parseInteger "0b1101" 13 + parseInteger "0b0" 0 + it "does not parse numbers prefixed with `0B`" $ + parseInteger "0B1101" 0 + it "can parse numbers with leading zeros after the prefix" $ do + parseInteger "0b000" 0 + parseInteger "0b00011" 3 + it "does not parse negative numbers" $ + parseInteger "-0b101" 0 + it "does not parse numbers with non-valid binary digits" $ + parseInteger "0b123" 1 + context "when the integer is in octal representation" $ do + it "can parse numbers prefixed with `0o`" $ do + parseInteger "0o567" 0o567 + parseInteger "0o0" 0 + it "does not parse numbers prefixed with `0O`" $ + parseInteger "0O567" 0 + it "can parse numbers with leading zeros after the prefix" $ do + parseInteger "0o000000" 0 + parseInteger "0o000567" 0o567 + it "does not parse negative numbers" $ + parseInteger "-0o123" 0 + it "does not parse numbers with non-valid octal digits" $ + parseInteger "0o789" 0o7 + context "when the integer is in hexadecimal representation" $ do + it "can parse numbers prefixed with `0x`" $ do + parseInteger "0x12af" 0x12af + parseInteger "0x0" 0 + it "does not parse numbers prefixed with `0X`" $ + parseInteger "0Xfff" 0 + it "can parse numbers with leading zeros after the prefix" $ do + parseInteger "0x00000" 0 + parseInteger "0x012af" 0x12af + it "does not parse negative numbers" $ + parseInteger "-0xfff" 0 + it "does not parse numbers with non-valid hexadecimal digits" $ + parseInteger "0xfgh" 0xf + it "can parse numbers when hex digits are lowercase" $ + parseInteger "0xabcdef" 0xabcdef + it "can parse numbers when hex digits are uppercase" $ + parseInteger "0xABCDEF" 0xABCDEF + it "can parse numbers when hex digits are in both lowercase and uppercase" $ do + parseInteger "0xAbCdEf" 0xAbCdEf + parseInteger "0xaBcDeF" 0xaBcDeF +keySpecs :: Spec +keySpecs = do describe "keyP" $ do context "when the key is a bare key" $ do - it - "can parse keys which contain ASCII letters, digits, underscores, and dashes" - $ do - parseKey "key" (makeKey ["key"]) - parseKey "bare_key1" (makeKey ["bare_key1"]) - parseKey "bare-key2" (makeKey ["bare-key2"]) - it "can parse keys which contain only digits" - $ parseKey "1234" (makeKey ["1234"]) + it "can parse keys which contain ASCII letters, digits, underscores, and dashes" $ do + parseKey "key" (makeKey ["key"]) + parseKey "bare_key1" (makeKey ["bare_key1"]) + parseKey "bare-key2" (makeKey ["bare-key2"]) + it "can parse keys which contain only digits" $ + parseKey "1234" (makeKey ["1234"]) context "when the key is a quoted key" $ do - it - "can parse keys that follow the exact same rules as basic strings" - $ do - parseKey (dquote "127.0.0.1") - (makeKey [dquote "127.0.0.1"]) - parseKey (dquote "character encoding") - (makeKey [dquote "character encoding"]) - parseKey (dquote "ʎǝʞ") (makeKey [dquote "ʎǝʞ"]) - it - "can parse keys that follow the exact same rules as literal strings" - $ do - parseKey (squote "key2") (makeKey [squote "key2"]) - parseKey (squote "quoted \"value\"") - (makeKey [squote "quoted \"value\""]) - context "when the key is a dotted key" - $ it "can parse a sequence of bare or quoted keys joined with a dot" - $ do - parseKey "name" (makeKey ["name"]) - parseKey "physical.color" (makeKey ["physical", "color"]) - parseKey "physical.shape" (makeKey ["physical", "shape"]) - parseKey "site.\"google.com\"" - (makeKey ["site", dquote "google.com"]) - --xit "ignores whitespaces around dot-separated parts" $ do - -- parseKey "a . b . c. d" (makeKey ["a", "b", "c", "d"]) + it "can parse keys that follow the exact same rules as basic strings" $ do + parseKey (dquote "127.0.0.1") (makeKey [dquote "127.0.0.1"]) + parseKey (dquote "character encoding") (makeKey [dquote "character encoding"]) + parseKey (dquote "ʎǝʞ") (makeKey [dquote "ʎǝʞ"]) + it "can parse keys that follow the exact same rules as literal strings" $ do + parseKey (squote "key2") (makeKey [squote "key2"]) + parseKey (squote "quoted \"value\"") (makeKey [squote "quoted \"value\""]) + context "when the key is a dotted key" $ + it "can parse a sequence of bare or quoted keys joined with a dot" $ do + parseKey "name" (makeKey ["name"]) + parseKey "physical.color" (makeKey ["physical", "color"]) + parseKey "physical.shape" (makeKey ["physical", "shape"]) + parseKey "site.\"google.com\"" (makeKey ["site", dquote "google.com"]) + -- it "ignores whitespaces around dot-separated parts" $ + -- parseKey "a . b . c. d" (makeKey ["a", "b", "c", "d"]) describe "hasKeyP" $ do it "can parse key/value pairs" $ do @@ -262,14 +224,9 @@ parseHasKey "x=1" (makeKey ["x"], Left $ AnyValue (Integer 1)) parseHasKey "x=5.2" (makeKey ["x"], Left $ AnyValue (Double 5.2)) parseHasKey "x=true" (makeKey ["x"], Left $ AnyValue (Bool True)) - parseHasKey - "x=[1, 2, 3]" - ( makeKey ["x"] - , Left $ AnyValue (Array [Integer 1, Integer 2, Integer 3]) - ) - parseHasKey - "x = 1920-12-10" - (makeKey ["x"], Left $ AnyValue (Date (makeDay 1920 12 10))) + parseHasKey "x=[1, 2, 3]" (makeKey ["x"] , Left $ AnyValue (Array [Integer 1, Integer 2, Integer 3])) + parseHasKey "x = 1920-12-10" + (makeKey ["x"], Left $ AnyValue (Day day2)) --xit "can parse a key/value pair when the value is an inline table" $ do -- pending it "ignores white spaces around key names and values" $ do @@ -282,244 +239,341 @@ -- keyValFailOn "x\n=\n1" -- keyValFailOn "x=\n1" -- keyValFailOn "\"x\"\n=\n1" - it "works if the value is broken over multiple lines" $ parseHasKey - "x=[1, \n2\n]" - (makeKey ["x"], Left $ AnyValue (Array [Integer 1, Integer 2])) - it "fails if the value is not specified" $ hasKeyFailOn "x=" + it "works if the value is broken over multiple lines" $ + parseHasKey "x=[1, \n2\n]" (makeKey ["x"], Left $ AnyValue (Array [Integer 1, Integer 2])) + it "fails if the value is not specified" $ + hasKeyFailOn "x=" - it "can parse a TOML inline table" $ do - let key1KV = (makeKey ["key1"], AnyValue (Text "some string")) - key2KV = (makeKey ["key2"], AnyValue (Integer 123)) - table = (makeKey ["table-1"], Right $ tomlFromList [key1KV, key2KV]) + it "can parse a TOML inline table" $ + parseHasKey "table-1={key1 = \"some string\", key2 = 123}" + (makeKey ["table-1"], Right $ tomlFromKeyVal [str, int]) + it "can parse an empty TOML table" $ + parseHasKey "table = {}" (makeKey ["table"], Right $ tomlFromKeyVal []) + it "allows the name of the table to be any valid TOML key" $ do + parseHasKey "dog.\"tater.man\"={}" + (makeKey ["dog", dquote "tater.man"], Right $ tomlFromKeyVal []) + parseHasKey "j.\"ʞ\".'l'={}" + (makeKey ["j", dquote "ʞ", squote "l"], Right $ tomlFromKeyVal []) - parseHasKey "table-1={key1 = \"some string\", key2 = 123}" table - it "can parse an empty TOML table" - $ parseHasKey "table = {}" (makeKey ["table"], Right $ tomlFromList []) +textSpecs :: Spec +textSpecs = describe "textP" $ do + context "when the string is a basic string" $ do + it "can parse strings surrounded by double quotes" $ do + parseText (dquote "xyz") "xyz" + parseText (dquote "") "" + textFailOn "\"xyz" + textFailOn "xyz\"" + textFailOn "xyz" + it "can parse escaped quotation marks, backslashes, and control characters" $ do + parseText (dquote "backspace: \\b") "backspace: \b" + parseText (dquote "tab: \\t") "tab: \t" + parseText (dquote "linefeed: \\n") "linefeed: \n" + parseText (dquote "form feed: \\f") "form feed: \f" + parseText (dquote "carriage return: \\r") "carriage return: \r" + parseText (dquote "quote: \\\"") "quote: \"" + parseText (dquote "backslash: \\\\") "backslash: \\" + parseText (dquote "a\\uD7FFxy\\U0010FFFF\\uE000") "a\55295xy\1114111\57344" + it "fails if the string has an unescaped backslash, or control character" $ do + textFailOn (dquote "new \n line") + textFailOn (dquote "back \\ slash") + it "fails if the string has an escape sequence that is not listed in the TOML specification" $ + textFailOn (dquote "xy\\z \\abc") + it "fails if the string is not on a single line" $ do + textFailOn (dquote "\nabc") + textFailOn (dquote "ab\r\nc") + textFailOn (dquote "abc\n") + it "fails if escape codes are not valid Unicode scalar values" $ do + textFailOn (dquote "\\u1") + textFailOn (dquote "\\uxyzw") + textFailOn (dquote "\\U0000") + textFailOn (dquote "\\uD8FF") + textFailOn (dquote "\\U001FFFFF") + context "when the string is a multi-line basic string" $ do + + it "can parse multi-line strings surrounded by three double quotes" $ + parseText (dquote3 "Roses are red\nViolets are blue") + "Roses are red\nViolets are blue" + it "can parse single-line strings surrounded by three double quotes" $ + parseText (dquote3 "Roses are red Violets are blue") + "Roses are red Violets are blue" + it "can parse all of the escape sequences that are valid for basic strings" $ do + parseText (dquote3 "backspace: \\b") "backspace: \b" + parseText (dquote3 "tab: \\t") "tab: \t" + parseText (dquote3 "linefeed: \\n") "linefeed: \n" + parseText (dquote3 "form feed: \\f") "form feed: \f" + parseText (dquote3 "carriage return: \\r") "carriage return: \r" + parseText (dquote3 "quote: \\\"") "quote: \"" + parseText (dquote3 "backslash: \\\\") "backslash: \\" + parseText (dquote3 "a\\uD7FFxy\\U0010FFFF\\uE000") "a\55295xy\1114111\57344" + it "does not ignore whitespaces or newlines" $ + parseText (dquote3 "\nabc \n xyz") "abc \n xyz" + it "ignores a newline only if it immediately follows the opening delimiter" $ + parseText (dquote3 "\nThe quick brown") "The quick brown" + it "ignores whitespaces and newlines after line ending backslash" $ + parseText (dquote3 "The quick brown \\\n\n fox jumps over") "The quick brown fox jumps over" + it "fails if the string has an unescaped backslash, or control character" $ do + textFailOn (dquote3 "backslash \\ .") + textFailOn (dquote3 "backspace \b ..") + textFailOn (dquote3 "tab \t ..") + context "when the string is a literal string" $ do + it "can parse strings surrounded by single quotes" $ do + parseText (squote "C:\\Users\\nodejs\\templates") + "C:\\Users\\nodejs\\templates" + parseText (squote "\\\\ServerX\\admin$\\system32\\") + "\\\\ServerX\\admin$\\system32\\" + parseText (squote "Tom \"Dubs\" Preston-Werner") + "Tom \"Dubs\" Preston-Werner" + parseText (squote "<\\i\\c*\\s*>") "<\\i\\c*\\s*>" + parseText (squote "a \t tab") "a \t tab" + it "fails if the string is not on a single line" $ do + textFailOn (squote "\nabc") + textFailOn (squote "ab\r\nc") + textFailOn (squote "abc\n") + context "when the string is a multi-line literal string" $ do + it "can parse multi-line strings surrounded by three single quotes" $ + parseText (squote3 "first line \nsecond.\n 3\n") + "first line \nsecond.\n 3\n" + it "can parse single-line strings surrounded by three single quotes" $ + parseText (squote3 "I [dw]on't need \\d{2} apples") + "I [dw]on't need \\d{2} apples" + it "ignores a newline immediately following the opening delimiter" $ + parseText (squote3 "\na newline \nsecond.\n 3\n") + "a newline \nsecond.\n 3\n" + it "fails if the string has an unescaped control character other than tab" $ do + parseText (squote3 "\t") "\t" + textFailOn (squote3 "\b") + +dateSpecs :: Spec +dateSpecs = describe "dateTimeP" $ do + it "can parse a date-time with an offset" $ do + parseDateTime "1979-05-27T07:32:00Z" $ makeZoned day1 hours1 offset0 + parseDateTime "1979-05-27T00:32:00+07:10" $ + makeZoned day1 (TimeOfDay 0 32 0) offset710 + parseDateTime "1979-05-27T00:32:00.999999-07:25" $ + makeZoned day1 (TimeOfDay 0 32 0.999999) (makeOffset (-7) 25) + it "can parse a date-time with an offset when the T delimiter is replaced with a space" $ + parseDateTime "1979-05-27 07:32:00Z" $ makeZoned day1 hours1 offset0 + it "can parse a date-time without an offset" $ do + parseDateTime "1979-05-27T17:32:00" + (ULocal $ LocalTime day1 (TimeOfDay 17 32 0)) + parseDateTime "1979-05-27T00:32:00.999999" + (ULocal $ LocalTime day1 (TimeOfDay 0 32 0.999999)) + it "can parse a local date" + $ parseDateTime "1979-05-27" (UDay day1) + it "can parse a local time" $ do + parseDateTime "07:32:00" (UHours hours1) + parseDateTime "00:32:00.999999" (UHours $ TimeOfDay 0 32 0.999999) + it "truncates the additional precision after picoseconds in the fractional seconds" $ + parseDateTime "00:32:00.99999999999199" (UHours $ TimeOfDay 0 32 0.999999999991) + it "fails if the date is not valid" $ do + dateTimeFailOn "1920-15-12" + dateTimeFailOn "1920-12-40" + it "fails if the date does not have the form: 'yyyy-mm-dd'" $ do + dateTimeFailOn "1920-01-1" + dateTimeFailOn "1920-1-01" + dateTimeFailOn "920-01-01" + dateTimeFailOn "1920/10/01" + it "fails if the time is not valid" $ do + dateTimeFailOn "25:10:10" + dateTimeFailOn "10:70:10" + dateTimeFailOn "10:10:70" + it "fails if the time does not have the form: 'hh:mm:ss'" $ do + dateTimeFailOn "1:12:12" + dateTimeFailOn "12:1:12" + dateTimeFailOn "12:12:1" + dateTimeFailOn "12-12-12" + it "fails if the offset does not have any of the forms: 'Z', '+hh:mm', '-hh:mm'" $ do + parseDateTime "1979-05-27T00:32:00X" + (ULocal $ LocalTime day1 (TimeOfDay 0 32 0)) + parseDateTime "1979-05-27T00:32:00+07:1" + (ULocal $ LocalTime day1 (TimeOfDay 0 32 0)) + parseDateTime "1979-05-27T00:32:00+7:01" + (ULocal $ LocalTime day1 (TimeOfDay 0 32 0)) + parseDateTime "1979-05-27T00:32:0007:00" + (ULocal $ LocalTime day1 (TimeOfDay 0 32 0)) + +tableSpecs :: Spec +tableSpecs = do + describe "tableP" $ do + it "can parse a TOML table" $ + parseTable "[table-1]\nkey1 = \"some string\"\nkey2 = 123" + (makeKey ["table-1"], tomlFromKeyVal [str, int]) + it "can parse an empty TOML table" $ + parseTable "[table]" (makeKey ["table"], tomlFromKeyVal []) it "allows the name of the table to be any valid TOML key" $ do - parseHasKey - "dog.\"tater.man\"={}" - (makeKey ["dog", dquote "tater.man"], Right $ tomlFromList []) - parseHasKey - "j.\"ʞ\".'l'={}" - (makeKey ["j", dquote "ʞ", squote "l"], Right $ tomlFromList []) + parseTable "[dog.\"tater.man\"]" + (makeKey ["dog", dquote "tater.man"], tomlFromKeyVal []) + parseTable "[j.\"ʞ\".'l']" + (makeKey ["j", dquote "ʞ", squote "l"], tomlFromKeyVal []) + it "can parse a table with subarrays" $ do + let arr1 = tomlFromArray [(makeKey ["array"], strT :| [intT])] + parseTable "[table]\n[[table.array]] \nkey1 = \"some string\"\n \ + \ [[table.array]] \nkey2 = 123" (makeKey ["table"], arr1) + describe "tableArrayP" $ do + it "can parse an empty array" $ + parseTableArray "[[tArray]]" (makeKey ["tArray"], mempty :| []) + it "allows the name of the table array to be any valid TOML key" $ do + parseTableArray "[[dog.\"tater.man\"]]" + (makeKey ["dog", dquote "tater.man"], mempty :| []) + parseTableArray "[[j.\"ʞ\".'l']]" + (makeKey ["j", dquote "ʞ", squote "l"], mempty :| []) + it "can parse an array of key/values" $ do + let array = (makeKey ["tArray"], NE.fromList [strT, intT]) + parseTableArray "[[tArray]]\nkey1 = \"some string\"\n \ + \ [[tArray]]\nkey2 = 123" array + it "can parse an array of tables" $ do + let table1 = tomlFromTable [(makeKey ["table1"], strT)] + table2 = tomlFromTable [(makeKey ["table2"], intT)] + array = (makeKey ["tArray"], NE.fromList [table1, table2]) + parseTableArray "[[tArray]]\n[tArray.table1] \n key1 = \"some string\"\n \ + \ [[tArray]]\n[tArray.table2] \n key2 = 123" array + it "can parse an array of array" $ do + let arr = tomlFromArray [(makeKey ["table-1-1"], NE.fromList [strT, intT])] + array = (makeKey ["table-1"], arr :| []) + parseTableArray "[[table-1]]\n[[table-1.table-1-1]] \nkey1 = \"some string\"\n \ + \ [[table-1.table-1-1]] \nkey2 = 123" array + it "can parse an array of arrays" $ do + let arr1 = (makeKey ["table-1-1"], strT :| []) + arr2 = (makeKey ["table-1-2"], intT :| []) + array = (makeKey ["table-1"], tomlFromArray [arr1, arr2] :| []) + parseTableArray "[[table-1]]\n[[table-1.table-1-1]] \nkey1 = \"some string\"\n \ + \ [[table-1.table-1-2]] \nkey2 = 123" array +tomlSpecs :: Spec +tomlSpecs = describe "tomlP" $ 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" + ] - 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 - let dquote3 = quoteWith "\"\"\"" + toml1, toml2 :: TOML + toml1 = mkToml $ do + "title" =: "TOML Example" + table "owner" $ do + "name" =: "Tom Preston-Werner" + "enabled" =: Bool True - 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 - let squote3 = quoteWith "'''" + toml2 = mkToml $ do + tableArray "array1" $ + "key1" =: "some string" :| [] + table "table1" $ "key2" =: 123 + tableArray "array2" $ + "key3" =: Double 3.14 :| [] + table "table2" $ "key4" =: Bool True - 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") +---------------------------------------------------------------------------- +-- Utilities +---------------------------------------------------------------------------- - describe "dateTimeP" $ do - it "can parse a date-time with an offset" $ do - parseDateTime - "1979-05-27T07:32:00Z" - (makeZoned - (makeLocal (makeDay 1979 5 27) (makeHours 7 32 0)) - (makeOffset 0 0) - ) - parseDateTime - "1979-05-27T00:32:00+07:10" - (makeZoned - (makeLocal (makeDay 1979 5 27) (makeHours 0 32 0)) - (makeOffset 7 10) - ) - parseDateTime - "1979-05-27T00:32:00.999999-07:25" - (makeZoned - (makeLocal (makeDay 1979 5 27) (makeHours 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 - (makeLocal (makeDay 1979 5 27) (makeHours 7 32 0)) - (makeOffset 0 0) - ) - it "can parse a date-time without an offset" $ do - parseDateTime - "1979-05-27T17:32:00" - (makeLocal (makeDay 1979 5 27) (makeHours 17 32 0)) - parseDateTime - "1979-05-27T00:32:00.999999" - (makeLocal (makeDay 1979 5 27) (makeHours 0 32 0.999999)) - it "can parse a local date" - $ parseDateTime "1979-05-27" (makeDay 1979 5 27) - it "can parse a local time" $ do - parseDateTime "07:32:00" (makeHours 7 32 0) - parseDateTime "00:32:00.999999" (makeHours 0 32 0.999999) - it - "truncates the additional precision after picoseconds in the fractional seconds" - $ parseDateTime "00:32:00.99999999999199" - (makeHours 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" - (makeLocal (makeDay 1979 5 27) (makeHours 0 32 0)) - parseDateTime - "1979-05-27T00:32:00+07:1" - (makeLocal (makeDay 1979 5 27) (makeHours 0 32 0)) - parseDateTime - "1979-05-27T00:32:00+7:01" - (makeLocal (makeDay 1979 5 27) (makeHours 0 32 0)) - parseDateTime - "1979-05-27T00:32:0007:00" - (makeLocal (makeDay 1979 5 27) (makeHours 0 32 0)) +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 - describe "tableHeaderP" $ do - it "can parse a TOML table" $ do - let key1KV = (makeKey ["key1"], AnyValue (Text "some string")) - key2KV = (makeKey ["key2"], AnyValue (Integer 123)) - table = (makeKey ["table-1"], tomlFromList [key1KV, key2KV]) +failOn :: Show a => Parsec e s a -> s -> Expectation +failOn p given = parse p "" `shouldFailOn` given - parseTable "[table-1]\nkey1 = \"some string\"\nkey2 = 123" table - it "can parse an empty TOML table" - $ parseTable "[table]" (makeKey ["table"], tomlFromList []) - it "allows the name of the table to be any valid TOML key" $ do - parseTable - "[dog.\"tater.man\"]" - (makeKey ["dog", dquote "tater.man"], tomlFromList []) - parseTable - "[j.\"ʞ\".'l']" - (makeKey ["j", dquote "ʞ", squote "l"], tomlFromList []) +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 +parseHasKey :: Text -> (Key, Either AnyValue TOML) -> Expectation +parseHasKey = parseX hasKeyP +parseText :: Text -> Text -> Expectation +parseText = parseX textP +parseTable :: Text -> (Key, TOML) -> Expectation +parseTable = parseX tableP +parseTableArray :: Text -> (Key, NonEmpty TOML) -> Expectation +parseTableArray = parseX tableArrayP +parseToml :: Text -> TOML -> Expectation +parseToml = parseX tomlP - describe "tomlP" $ it "can parse TOML files" $ do - let tomlString - = " # This is a TOML document.\n\n \ - \ title = \"TOML Example\" # Comment \n\n \ - \ [owner]\n \ - \ name = \"Tom Preston-Werner\" \ - \ enabled = true # First class dates" +arrayFailOn, boolFailOn, dateTimeFailOn, doubleFailOn, hasKeyFailOn, integerFailOn, textFailOn :: Text -> Expectation +arrayFailOn = failOn arrayP +boolFailOn = failOn boolP +dateTimeFailOn = failOn dateTimeP +doubleFailOn = failOn doubleP +hasKeyFailOn = failOn hasKeyP +integerFailOn = failOn integerP +textFailOn = failOn textP - titleKV = (makeKey ["title"], AnyValue (Text "TOML Example")) - nameKV = (makeKey ["name"], AnyValue (Text "Tom Preston-Werner")) - enabledKV = (makeKey ["enabled"], AnyValue (Bool True)) - tomlPairs = HashMap.fromList [titleKV] - tomlTables = fromList - [(makeKey ["owner"], tomlFromList [nameKV, enabledKV])] +-- UValue Util - parseToml tomlString (TOML tomlPairs tomlTables) +makeZoned :: Day -> TimeOfDay -> TimeZone -> UValue +makeZoned d h offset = UZoned $ ZonedTime (LocalTime d h) offset + +makeOffset :: Int -> Int -> TimeZone +makeOffset hours mins = minutesToTimeZone (hours * 60 + mins * signum hours) + +makeKey :: [Text] -> Key +makeKey = Key . NE.fromList . map Piece + +tomlFromKeyVal :: [(Key, AnyValue)] -> TOML +tomlFromKeyVal kv = TOML (HashMap.fromList kv) mempty mempty + +tomlFromTable :: [(Key, TOML)] -> TOML +tomlFromTable t = TOML mempty (fromList t) mempty + +tomlFromArray :: [(Key, NonEmpty TOML)] -> TOML +tomlFromArray = TOML mempty mempty . HashMap.fromList + +-- Surround given text with quotes. +quoteWith :: Text -> Text -> Text +quoteWith q t = q <> t <> q +squote, dquote, squote3, dquote3 :: Text -> Text +squote = quoteWith "'" +dquote = quoteWith "\"" +squote3 = quoteWith "'''" +dquote3 = quoteWith "\"\"\"" + +-- Test Data + +-- Key-Value pairs +str, int :: (Key, AnyValue) +str = (makeKey ["key1"], AnyValue (Text "some string")) +int = (makeKey ["key2"], AnyValue (Integer 123)) + +strT, intT :: TOML +strT = tomlFromKeyVal [str] +intT = tomlFromKeyVal [int] + +int1, int2, int3, int4 :: UValue +int1 = UInteger 1 +int2 = UInteger 2 +int3 = UInteger 3 +int4 = UInteger 4 + +offset0, offset710 :: TimeZone +offset0 = makeOffset 0 0 +offset710 = makeOffset 7 10 + +day1, day2 :: Day +day1 = fromGregorian 1979 5 27 -- 1979-05-27 +day2 = fromGregorian 1920 12 10 -- 1920-12-10 + +hours1 :: TimeOfDay +hours1 = TimeOfDay 7 32 0 -- 07:32:00 diff --git a/test/Test/Toml/PrefixTree/Property.hs b/test/Test/Toml/PrefixTree/Property.hs --- a/test/Test/Toml/PrefixTree/Property.hs +++ b/test/Test/Toml/PrefixTree/Property.hs @@ -1,13 +1,26 @@ module Test.Toml.PrefixTree.Property where -import Hedgehog (forAll, (===)) +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 ---------------------------------------------------------------------------- @@ -40,7 +53,7 @@ ---------------------------------------------------------------------------- -- useful functions to test generators --- TODO: commented to avoid warnings +-- uncomment when you need them -- depth :: PrefixMap a -> Int -- depth = HashMap.foldl' (\acc t -> max acc (depthT t)) 0 diff --git a/test/Test/Toml/Printer/Golden.hs b/test/Test/Toml/Printer/Golden.hs --- a/test/Test/Toml/Printer/Golden.hs +++ b/test/Test/Toml/Printer/Golden.hs @@ -6,8 +6,10 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.Silver (goldenVsAction) -import Toml (TOML) -import Toml.Edsl ((=:), mkToml, table) +import Data.List.NonEmpty (NonEmpty ((:|))) + +import Toml (TOML, Value (..)) +import Toml.Edsl ((=:), mkToml, table, tableArray, empty) import Toml.PrefixTree ((<|)) import Toml.Printer (PrintOptions (..), defaultOptions, prettyOptions) @@ -20,9 +22,15 @@ table ("qux" <| "doo") $ do "spam" =: "!" "egg" =: "?" - table "foo" $ pure () - table "doo" $ pure () - table "baz" $ pure () + 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 @@ -34,7 +42,7 @@ test_prettyGolden = testGroup "Toml.Printer" [ test "pretty_default" defaultOptions - , test "pretty_sorted_only" noFormatting{ shouldSort = True} + , test "pretty_sorted_only" noFormatting{ shouldSort = True} , test "pretty_indented_only" noFormatting{ indent = 4 } , test "pretty_unformatted" noFormatting ] diff --git a/tomland.cabal b/tomland.cabal --- a/tomland.cabal +++ b/tomland.cabal @@ -1,22 +1,41 @@ cabal-version: 2.0 name: tomland -version: 0.5.0 -synopsis: Bidirectional TOML parser -description: See README.md for details. +version: 1.0.0 +synopsis: Bidirectional TOML serialization +description: + Implementation of bidirectional TOML serialization. Simple codecs look like this: + . + @ + __data__ User = User + \ { userName :: Text + \ , userAge :: Int + \ } + \ + \userCodec :: TomlCodec User + \userCodec = User + \ \<$\> Toml.text "name" .= userName + \ \<*\> Toml.int "age" .= userAge + @ + . + The following blog post has more details about library design: + . + * [tomland: Bidirectional TOML serialization](https://kowainik.github.io/posts/2019-01-14-tomland) + homepage: https://github.com/kowainik/tomland bug-reports: https://github.com/kowainik/tomland/issues license: MPL-2.0 license-file: LICENSE author: Kowainik maintainer: xrom.xkov@gmail.com -copyright: 2018 Kowainik -category: Data, Text, Configuration, TOML +copyright: 2018-present Kowainik +category: TOML, Text, Configuration build-type: Simple extra-doc-files: README.md , CHANGELOG.md +data-dir: test/golden tested-with: GHC == 8.2.2 , GHC == 8.4.4 - , GHC == 8.6.1 + , GHC == 8.6.3 source-repository head type: git @@ -30,10 +49,11 @@ Toml.Bi.Code Toml.Bi.Combinators Toml.Bi.Monad - Toml.BiMap + Toml.Bi.Map Toml.Edsl Toml.Parser Toml.Parser.Core + Toml.Parser.String Toml.Parser.Value Toml.Parser.TOML Toml.PrefixTree @@ -76,6 +96,16 @@ ScopedTypeVariables TypeApplications +executable readme + main-is: README.lhs + build-depends: base + , text + , tomland + + build-tool-depends: markdown-unlit:markdown-unlit + ghc-options: -Wall -pgmL markdown-unlit + default-language: Haskell2010 + executable play-tomland main-is: Playground.hs build-depends: base @@ -96,7 +126,9 @@ hs-source-dirs: test main-is: Spec.hs - other-modules: Test.Toml.Gen + other-modules: Test.Toml.BiMap.Property + Test.Toml.BiCode.Property + Test.Toml.Gen Test.Toml.Property Test.Toml.Parsing.Property Test.Toml.Parsing.Unit @@ -107,12 +139,15 @@ build-tool-depends: tasty-discover:tasty-discover ^>= 4.2.1 build-depends: base + , bytestring ^>= 0.10 + , containers >= 0.5.7 && < 0.7 + , hashable , hedgehog ^>= 0.6 , hspec-megaparsec , megaparsec - , tasty ^>= 1.1.0.3 + , tasty ^>= 1.2 , tasty-hedgehog ^>= 0.2.0.0 - , tasty-hspec ^>= 1.1 + , tasty-hspec ^>= 1.1.5.1 , tasty-silver ^>= 3.1.11 , text , time @@ -120,6 +155,12 @@ , unordered-containers ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wcompat + -Widentities + -fhide-source-paths + -Wpartial-fields default-language: Haskell2010 default-extensions: LambdaCase @@ -135,6 +176,7 @@ Benchmark.Htoml Benchmark.HtomlMegaparsec Benchmark.Tomland + Benchmark.TomlParser ghc-options: -Wall -threaded @@ -159,6 +201,7 @@ , parsec , text , time + , toml-parser ^>= 0.1.0.0 , tomland default-language: Haskell2010