tomland 0.5.0 → 1.0.0
raw patch · 37 files changed
+3172/−1549 lines, 37 filesdep +toml-parserdep ~basedep ~hashabledep ~tastynew-component:exe:readme
Dependencies added: toml-parser
Dependency ranges changed: base, hashable, tasty, tasty-hspec, text
Files
- CHANGELOG.md +46/−3
- README.lhs +177/−0
- README.md +172/−3
- benchmark/Benchmark/Htoml.hs +9/−7
- benchmark/Benchmark/HtomlMegaparsec.hs +9/−8
- benchmark/Benchmark/TomlParser.hs +91/−0
- benchmark/Benchmark/Tomland.hs +9/−10
- benchmark/Benchmark/Type.hs +13/−11
- benchmark/Main.hs +5/−0
- examples/Playground.hs +29/−15
- src/Toml.hs +26/−4
- src/Toml/Bi.hs +12/−1
- src/Toml/Bi/Code.hs +24/−12
- src/Toml/Bi/Combinators.hs +150/−119
- src/Toml/Bi/Map.hs +471/−0
- src/Toml/Bi/Monad.hs +95/−40
- src/Toml/BiMap.hs +0/−295
- src/Toml/Edsl.hs +46/−10
- src/Toml/Parser.hs +6/−1
- src/Toml/Parser/Core.hs +10/−8
- src/Toml/Parser/String.hs +116/−0
- src/Toml/Parser/TOML.hs +132/−25
- src/Toml/Parser/Value.hs +135/−224
- src/Toml/PrefixTree.hs +47/−35
- src/Toml/Printer.hs +84/−67
- src/Toml/Type.hs +2/−0
- src/Toml/Type/AnyValue.hs +70/−32
- src/Toml/Type/TOML.hs +77/−7
- src/Toml/Type/UValue.hs +28/−5
- src/Toml/Type/Value.hs +109/−79
- test/Test/Toml/BiCode/Property.hs +178/−0
- test/Test/Toml/BiMap/Property.hs +64/−0
- test/Test/Toml/Gen.hs +124/−40
- test/Test/Toml/Parsing/Unit.hs +524/−470
- test/Test/Toml/PrefixTree/Property.hs +15/−2
- test/Test/Toml/Printer/Golden.hs +14/−6
- tomland.cabal +53/−10
CHANGELOG.md view
@@ -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):
+ README.lhs view
@@ -0,0 +1,177 @@+# tomland+++[](https://travis-ci.org/kowainik/tomland)+[](https://hackage.haskell.org/package/tomland)+[](http://stackage.org/lts/package/tomland)+[](http://stackage.org/nightly/package/tomland)+[](https://github.com/kowainik/tomland/blob/master/LICENSE)++> “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/).
README.md view
@@ -1,8 +1,177 @@ # tomland -[](https://hackage.haskell.org/package/tomland)+ [](https://travis-ci.org/kowainik/tomland)-[](https://ci.appveyor.com/project/kowainik/tomland)+[](https://hackage.haskell.org/package/tomland)+[](http://stackage.org/lts/package/tomland)+[](http://stackage.org/nightly/package/tomland) [](https://github.com/kowainik/tomland/blob/master/LICENSE) -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/).
benchmark/Benchmark/Htoml.hs view
@@ -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
benchmark/Benchmark/HtomlMegaparsec.hs view
@@ -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.
+ benchmark/Benchmark/TomlParser.hs view
@@ -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
benchmark/Benchmark/Tomland.hs view
@@ -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"
benchmark/Benchmark/Type.hs view
@@ -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"
benchmark/Main.hs view
@@ -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 ] ]
examples/Playground.hs view
@@ -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]
src/Toml.hs view
@@ -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
src/Toml/Bi.hs view
@@ -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
src/Toml/Bi/Code.hs view
@@ -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
src/Toml/Bi/Combinators.hs view
@@ -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
+ src/Toml/Bi/Map.hs view
@@ -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' also implements 'Cat.Category' typeclass. And this instance can be described+clearly by this illustration:+++-}+data BiMap e a b = BiMap+ { forward :: a -> Either e b+ , backward :: b -> Either e a+ }++instance Cat.Category (BiMap e) where+ id :: BiMap e a a+ id = BiMap Right Right++ (.) :: BiMap e b c -> BiMap e a b -> BiMap e a c+ bc . ab = BiMap+ { forward = forward ab >=> forward bc+ , backward = backward bc >=> backward ab+ }++-- | Inverts bidirectional mapping.+invert :: BiMap e a b -> BiMap e b a+invert (BiMap f g) = BiMap g f++{- | Creates 'BiMap' from isomorphism. Can be used in the following way:++@+__newtype__ Even = Even Integer+__newtype__ Odd = Odd Integer++succEven :: Even -> Odd+succEven (Even n) = Odd (n + 1)++predOdd :: Odd -> Even+predOdd (Odd n) = Even (n - 1)++_EvenOdd :: 'BiMap' e Even Odd+_EvenOdd = 'iso' succEven predOdd+@+-}+iso :: (a -> b) -> (b -> a) -> BiMap e a b+iso f g = BiMap (Right . f) (Right . g)++{- | Creates 'BiMap' from prism-like pair of functions. This combinator can be+used to create 'BiMap' for custom data types like this:++@+__data__ User+ = Admin Integer -- id of admin+ | Client Text -- name of the client+ __deriving__ (Show)++_Admin :: 'TomlBiMap' User Integer+_Admin = Toml.'prism' Admin $ \\__case__+ Admin i -> Right i+ other -> Toml.'wrongConstructor' \"Admin\" other++_Client :: 'TomlBiMap' User Text+_Client = Toml.'prism' Client $ \\__case__+ Client n -> Right n+ other -> Toml.'wrongConstructor' \"Client\" other+@+-}+prism :: (field -> object) -> (object -> Either error field) -> BiMap error object field+prism review preview = BiMap preview (Right . review)++----------------------------------------------------------------------------+-- BiMap error types+----------------------------------------------------------------------------++-- | 'BiMap' specialized to TOML error.+type TomlBiMap = BiMap TomlBiMapError++-- | Type of errors for TOML 'BiMap'.+data TomlBiMapError+ = WrongConstructor -- ^ Error for cases with wrong constructors. For+ -- example, you're trying to convert 'Left' but+ -- bidirectional converter expects 'Right'.+ Text -- ^ Expected constructor name+ Text -- ^ Actual value+ | WrongValue -- ^ Error for cases with wrong values+ MatchError -- ^ Information about failed matching+ | ArbitraryError -- ^ Arbitrary textual error+ Text -- ^ Error message+ deriving (Eq, Show, Generic, NFData)++-- | Converts 'TomlBiMapError' into pretty human-readable text.+prettyBiMapError :: TomlBiMapError -> Text+prettyBiMapError = \case+ WrongConstructor expected actual -> T.unlines+ [ "Invalid constructor"+ , " * Expected: " <> expected+ , " * Actual: " <> actual+ ]+ WrongValue (MatchError expected actual) -> T.unlines+ [ "Invalid constructor"+ , " * Expected: " <> tShow expected+ , " * Actual: " <> tShow actual+ ]+ ArbitraryError text -> text++-- | Helper to construct WrongConstuctor error.+wrongConstructor+ :: Show a+ => Text -- ^ Name of the expected constructor+ -> a -- ^ Actual value+ -> Either TomlBiMapError b+wrongConstructor constructor x = Left $ WrongConstructor constructor (tShow x)++----------------------------------------------------------------------------+-- General purpose bimaps+----------------------------------------------------------------------------++-- | Bimap for 'Either' and its left type+_Left :: (Show l, Show r) => TomlBiMap (Either l r) l+_Left = prism Left $ \case+ Left l -> Right l+ x -> wrongConstructor "Left" x++-- | Bimap for 'Either' and its right type+_Right :: (Show l, Show r) => TomlBiMap (Either l r) r+_Right = prism Right $ \case+ Right r -> Right r+ x -> wrongConstructor "Right" x++-- | Bimap for 'Maybe'+_Just :: Show r => TomlBiMap (Maybe r) r+_Just = prism Just $ \case+ Just r -> Right r+ x -> wrongConstructor "Just" x++----------------------------------------------------------------------------+-- BiMaps for value+----------------------------------------------------------------------------++-- | Creates prism for 'AnyValue'.+mkAnyValueBiMap+ :: forall a (tag :: TValue) . (forall (t :: TValue) . Value t -> Either MatchError a)+ -> (a -> Value tag)+ -> TomlBiMap a AnyValue+mkAnyValueBiMap matchValue toValue = BiMap+ { forward = Right . toAnyValue+ , backward = fromAnyValue+ }+ where+ toAnyValue :: a -> AnyValue+ toAnyValue = AnyValue . toValue++ fromAnyValue :: AnyValue -> Either TomlBiMapError a+ fromAnyValue (AnyValue value) = first WrongValue $ matchValue value++-- | Creates bimap for 'Data.Text.Text' to 'AnyValue' with custom functions+_TextBy+ :: forall a .+ (a -> Text) -- ^ @show@ function for @a@+ -> (Text -> Either Text a) -- ^ Parser of @a@ from 'Data.Text.Text'+ -> TomlBiMap a AnyValue+_TextBy toText parseText = BiMap toAnyValue fromAnyValue+ where+ toAnyValue :: a -> Either TomlBiMapError AnyValue+ toAnyValue = Right . AnyValue . Text . toText++ fromAnyValue :: AnyValue -> Either TomlBiMapError a+ fromAnyValue (AnyValue v) =+ first WrongValue (matchText v) >>= first ArbitraryError . parseText++{- | 'Prelude.Bool' bimap for 'AnyValue'. Usually used as+'Toml.Bi.Combinators.bool' combinator.+-}+_Bool :: TomlBiMap Bool AnyValue+_Bool = mkAnyValueBiMap matchBool Bool++{- | 'Prelude.Integer' bimap for 'AnyValue'. Usually used as+'Toml.Bi.Combinators.integer' combinator.+-}+_Integer :: TomlBiMap Integer AnyValue+_Integer = mkAnyValueBiMap matchInteger Integer++{- | 'Prelude.Double' bimap for 'AnyValue'. Usually used as+'Toml.Bi.Combinators.double' combinator.+-}+_Double :: TomlBiMap Double AnyValue+_Double = mkAnyValueBiMap matchDouble Double++{- | 'Data.Text.Text' bimap for 'AnyValue'. Usually used as+'Toml.Bi.Combinators.text' combinator.+-}+_Text :: TomlBiMap Text AnyValue+_Text = mkAnyValueBiMap matchText Text++-- | Helper bimap for 'Data.Text.Lazy.Text' and 'Data.Text.Text'.+_LTextText :: BiMap e TL.Text Text+_LTextText = iso TL.toStrict TL.fromStrict++{- | 'Data.Text.Lazy.Text' bimap for 'AnyValue'. Usually used as+'Toml.Bi.Combinators.lazyText' combinator.+-}+_LText :: TomlBiMap TL.Text AnyValue+_LText = _LTextText >>> _Text++{- | 'Data.Time.ZonedTime' bimap for 'AnyValue'. Usually used as+'Toml.Bi.Combinators.zonedTime' combinator.+-}+_ZonedTime :: TomlBiMap ZonedTime AnyValue+_ZonedTime = mkAnyValueBiMap matchZoned Zoned++{- | 'Data.Time.LocalTime' bimap for 'AnyValue'. Usually used as+'Toml.Bi.Combinators.localTime' combinator.+-}+_LocalTime :: TomlBiMap LocalTime AnyValue+_LocalTime = mkAnyValueBiMap matchLocal Local++{- | 'Data.Time.Day' bimap for 'AnyValue'. Usually used as+'Toml.Bi.Combinators.day' combinator.+-}+_Day :: TomlBiMap Day AnyValue+_Day = mkAnyValueBiMap matchDay Day++{- | 'Data.Time.TimeOfDay' bimap for 'AnyValue'. Usually used as+'Toml.Bi.Combinators.timeOfDay' combinator.+-}+_TimeOfDay :: TomlBiMap TimeOfDay AnyValue+_TimeOfDay = mkAnyValueBiMap matchHours Hours++-- | Helper bimap for 'String' and 'Data.Text.Text'.+_StringText :: BiMap e String Text+_StringText = iso T.pack T.unpack++{- | 'String' bimap for 'AnyValue'. Usually used as+'Toml.Bi.Combinators.string' combinator.+-}+_String :: TomlBiMap String AnyValue+_String = _StringText >>> _Text++-- | Helper bimap for 'String' and types with 'Read' and 'Show' instances.+_ReadString :: (Show a, Read a) => TomlBiMap a String+_ReadString = BiMap (Right . show) (first (ArbitraryError . T.pack) . readEither)++-- | Bimap for 'AnyValue' and values with a 'Read' and 'Show' instance.+-- Usually used as 'Toml.Bi.Combinators.read' combinator.+_Read :: (Show a, Read a) => TomlBiMap a AnyValue+_Read = _ReadString >>> _String++-- | Helper bimap for 'Natural' and 'Prelude.Integer'.+_NaturalInteger :: TomlBiMap Natural Integer+_NaturalInteger = BiMap (Right . toInteger) eitherInteger+ where+ eitherInteger :: Integer -> Either TomlBiMapError Natural+ eitherInteger n+ | n < 0 = Left $ ArbitraryError $ "Value is below zero, but expected Natural: " <> tShow n+ | otherwise = Right (fromIntegral n)++{- | 'String' bimap for 'AnyValue'. Usually used as+'Toml.Bi.Combinators.natural' combinator.+-}+_Natural :: TomlBiMap Natural AnyValue+_Natural = _NaturalInteger >>> _Integer++-- | Helper bimap for 'Prelude.Integer' and integral, bounded values.+_BoundedInteger :: (Integral a, Bounded a, Show a) => TomlBiMap a Integer+_BoundedInteger = BiMap (Right . toInteger) eitherBounded+ where+ eitherBounded :: forall a. (Integral a, Bounded a, Show a) => Integer -> Either TomlBiMapError a+ eitherBounded n+ | n < toInteger (minBound @a) =+ let msg = "Value " <> tShow n <> " is less than minBound: " <> tShow (minBound @a)+ in Left $ ArbitraryError msg+ | n > toInteger (maxBound @a) =+ let msg = "Value " <> tShow n <> " is greater than maxBound: " <> tShow (maxBound @a)+ in Left $ ArbitraryError msg+ | otherwise = Right (fromIntegral n)++{- | '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
src/Toml/Bi/Monad.hs view
@@ -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:+<https://blog.poisson.chat/posts/2016-10-12-bidirectional-serialization.html>. -} data Codec r w c a = Codec { -- | Extract value of type @a@ from monadic context @r@.@@ -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 .=
− src/Toml/BiMap.hs
@@ -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
src/Toml/Edsl.hs view
@@ -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
src/Toml/Parser.hs view
@@ -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
src/Toml/Parser/Core.hs view
@@ -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
+ src/Toml/Parser/String.hs view
@@ -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
src/Toml/Parser/TOML.hs view
@@ -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)
src/Toml/Parser/Value.hs view
@@ -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
src/Toml/PrefixTree.hs view
@@ -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 []
src/Toml/Printer.hs view
@@ -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
src/Toml/Type.hs view
@@ -1,3 +1,5 @@+-- | Core types for TOML AST.+ module Toml.Type ( module Toml.Type.AnyValue , module Toml.Type.TOML
src/Toml/Type/AnyValue.hs view
@@ -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)
src/Toml/Type/TOML.hs view
@@ -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) }
src/Toml/Type/UValue.hs view
@@ -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
src/Toml/Type/Value.hs view
@@ -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
+ test/Test/Toml/BiCode/Property.hs view
@@ -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{..}
+ test/Test/Toml/BiMap/Property.hs view
@@ -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
test/Test/Toml/Gen.hs view
@@ -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:
test/Test/Toml/Parsing/Unit.hs view
@@ -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 "<true, false>"- it "fails if the elements are not separated by commas" $ do- arrayFailOn "[1 2 3]"- arrayFailOn "[1 . 2 . 3]"- arrayFailOn "['x' - 'y' - 'z']"+arraySpecs :: Spec+arraySpecs = describe "arrayP" $ do+ it "can parse arrays" $ do+ parseArray "[]" []+ parseArray "[1]" [int1]+ parseArray "[1, 2, 3]" [int1, int2, int3]+ parseArray "[1.2, 2.3, 3.4]" [UDouble 1.2, UDouble 2.3, UDouble 3.4]+ parseArray "['x', 'y']" [UText "x", UText "y"]+ parseArray "[[1], [2]]" [UArray [UInteger 1], UArray [UInteger 2]]+ parseArray "[1920-12-10, 1979-05-27]" [UDay day2, UDay day1]+ parseArray "[16:33:05, 10:15:30]" [UHours (TimeOfDay 16 33 5), UHours (TimeOfDay 10 15 30)]+ it "can parse multiline arrays" $+ parseArray "[\n1,\n2\n]" [int1, int2]+ it "can parse an array of arrays" $+ parseArray "[[1], [2.3, 5.1]]" [UArray [int1], UArray [UDouble 2.3, UDouble 5.1]]+ it "can parse an array with terminating commas (trailing commas)" $ do+ parseArray "[1, 2,]" [int1, int2]+ parseArray "[1, 2, 3, , ,]" [int1, int2, int3]+ it "allows an arbitrary number of comments and newlines before or after a value" $+ parseArray "[\n\n#c\n1, #c 2 \n 2, \n\n\n 3, #c \n #c \n 4]" [int1, int2, int3, int4]+ it "ignores white spaces" $+ parseArray "[ 1 , 2,3, 4 ]" [int1, int2, int3, int4]+ it "fails if the elements are not surrounded by square brackets" $ do+ arrayFailOn "1, 2, 3"+ arrayFailOn "[1, 2, 3"+ arrayFailOn "1, 2, 3]"+ arrayFailOn "{'x', 'y', 'z'}"+ arrayFailOn "(\"ab\", \"cd\")"+ arrayFailOn "<true, false>"+ it "fails if the elements are not separated by commas" $ do+ arrayFailOn "[1 2 3]"+ arrayFailOn "[1 . 2 . 3]"+ arrayFailOn "['x' - 'y' - 'z']"+ arrayFailOn "[1920-12-10, 10:15:30]" - 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
test/Test/Toml/PrefixTree/Property.hs view
@@ -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
test/Test/Toml/Printer/Golden.hs view
@@ -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 ]
tomland.cabal view
@@ -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