diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,39 @@ tomland uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +## 1.2.0.0 — Oct 12, 2019 + +* [#216](https://github.com/kowainik/tomland/issues/216): + Refactor TOML parser significantly. Check for some validation errors. + (by [@chshersh](https://github.com/chshersh)) +* [#213](https://github.com/kowainik/tomland/issues/213): + Support GHC-8.8.1. + (by [@vrom911](https://github.com/vrom911)) +* [#226](https://github.com/kowainik/tomland/issues/226): + Add `dimatch` combinator for better support of sum types. + (by [@Nimor111](https://github.com/Nimor111)) +* [#219](https://github.com/kowainik/tomland/issues/219): + Add INLINE pragmas to code. + (by [@willbasky](https://github.com/willbasky)) +* [#204](https://github.com/kowainik/tomland/issues/204): + Implement bidirectional codecs to work with `ByteString` as array of bytes. + (by [@crtschin](https://github.com/crtschin)) +* [#201](https://github.com/kowainik/tomland/issues/201): + Implement `set` and `hashSet` combinators for array of tables. + (by [@SanchayanMaity](https://github.com/SanchayanMaity)) +* [#215](https://github.com/kowainik/tomland/issues/215): + Move benchmarks to separate repository + [toml-benchmarks](https://github.com/kowainik/toml-benchmarks). + (by [@kutyel](https://github.com/kutyel)) +* [#209](https://github.com/kowainik/tomland/issues/209): + Bump up `parser-combinators` to `1.2.0`. + (by [@vrom911](https://github.com/vrom911)) +* [#198](https://github.com/kowainik/tomland/issues/198): + Improve test generators. + (by [@gabrielelana](https://github.com/gabrielelana) + , [@chshersh](https://github.com/chshersh) + ) + ## 1.1.0.1 — Jul 10, 2019 * [#206](https://github.com/kowainik/tomland/issues/206): diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -1,7 +1,9 @@ # tomland ![palm](https://user-images.githubusercontent.com/4276606/51088259-7a777000-176e-11e9-9d76-6be4023c0ac3.png) -[![Build status](https://img.shields.io/travis/kowainik/tomland.svg?logo=travis)](https://travis-ci.org/kowainik/tomland) +[![GitHub CI](https://github.com/kowainik/tomland/workflows/CI/badge.svg)](https://github.com/kowainik/tomland/actions) +[![Travis CI](https://img.shields.io/travis/kowainik/tomland.svg?logo=travis)](https://travis-ci.org/kowainik/tomland) +[![AppVeyor CI](https://ci.appveyor.com/api/projects/status/github/kowainik/tomland?branch=master&svg=true)](https://ci.appveyor.com/project/kowainik/tomland) [![Hackage](https://img.shields.io/hackage/v/tomland.svg?logo=haskell)](https://hackage.haskell.org/package/tomland) [![Stackage LTS](http://stackage.org/package/tomland/badge/lts)](http://stackage.org/lts/package/tomland) [![Stackage Nightly](http://stackage.org/package/tomland/badge/nightly)](http://stackage.org/nightly/package/tomland) @@ -74,9 +76,9 @@ } data User - = Admin Integer -- id of admin - | Client Text -- name of the client - deriving (Show) + = Admin !Integer -- id of admin + | Client !Text -- name of the client + deriving stock (Show) newtype Port = Port Int newtype Host = Host Text @@ -95,7 +97,11 @@ 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 +5. If you have sets of custom data types, use `Toml.set` or `Toml.HashSet`. Such + sets are represented as array of tables in TOML. +6. For parsing sum types, use `Toml.dimatch`. This requires writing matching functions + for the constructors of the sum type. +7. `tomland` separates conversion between Haskell types and TOML values from matching values by keys. Converters between types and values have type `TomlBiMap` and are named with capital letter started with underscore. Main type for TOML codecs is called `TomlCodec`. To lift `TomlBiMap` to @@ -146,7 +152,7 @@ ## Benchmarks and comparison with other libraries -`tomland` is compared with other libraries. Since it uses 2-step approach with +`tomland` is [compared](https://github.com/kowainik/toml-benchmarks) with other libraries. Since it uses 2-step approach with converting text to intermediate AST and only then decoding Haskell type from this AST, benchmarks are also implemented in a way to reflect this difference. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,9 @@ # tomland ![palm](https://user-images.githubusercontent.com/4276606/51088259-7a777000-176e-11e9-9d76-6be4023c0ac3.png) -[![Build status](https://img.shields.io/travis/kowainik/tomland.svg?logo=travis)](https://travis-ci.org/kowainik/tomland) +[![GitHub CI](https://github.com/kowainik/tomland/workflows/CI/badge.svg)](https://github.com/kowainik/tomland/actions) +[![Travis CI](https://img.shields.io/travis/kowainik/tomland.svg?logo=travis)](https://travis-ci.org/kowainik/tomland) +[![AppVeyor CI](https://ci.appveyor.com/api/projects/status/github/kowainik/tomland?branch=master&svg=true)](https://ci.appveyor.com/project/kowainik/tomland) [![Hackage](https://img.shields.io/hackage/v/tomland.svg?logo=haskell)](https://hackage.haskell.org/package/tomland) [![Stackage LTS](http://stackage.org/package/tomland/badge/lts)](http://stackage.org/lts/package/tomland) [![Stackage Nightly](http://stackage.org/package/tomland/badge/nightly)](http://stackage.org/nightly/package/tomland) @@ -74,9 +76,9 @@ } data User - = Admin Integer -- id of admin - | Client Text -- name of the client - deriving (Show) + = Admin !Integer -- id of admin + | Client !Text -- name of the client + deriving stock (Show) newtype Port = Port Int newtype Host = Host Text @@ -95,7 +97,11 @@ 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 +5. If you have sets of custom data types, use `Toml.set` or `Toml.HashSet`. Such + sets are represented as array of tables in TOML. +6. For parsing sum types, use `Toml.dimatch`. This requires writing matching functions + for the constructors of the sum type. +7. `tomland` separates conversion between Haskell types and TOML values from matching values by keys. Converters between types and values have type `TomlBiMap` and are named with capital letter started with underscore. Main type for TOML codecs is called `TomlCodec`. To lift `TomlBiMap` to @@ -146,7 +152,7 @@ ## Benchmarks and comparison with other libraries -`tomland` is compared with other libraries. Since it uses 2-step approach with +`tomland` is [compared](https://github.com/kowainik/toml-benchmarks) with other libraries. Since it uses 2-step approach with converting text to intermediate AST and only then decoding Haskell type from this AST, benchmarks are also implemented in a way to reflect this difference. diff --git a/benchmark/Benchmark/Htoml.hs b/benchmark/Benchmark/Htoml.hs deleted file mode 100644 --- a/benchmark/Benchmark/Htoml.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Benchmark.Htoml - ( decode - , parse - , convert - ) where - -import Control.DeepSeq (NFData, rnf, rwhnf) -import Data.Aeson.Types (parseEither, parseJSON) -import Data.Semigroup ((<>)) -import Data.Text (Text) -import GHC.Generics (Generic) -import Text.Parsec.Error (ParseError) - -import "htoml" Text.Toml (parseTomlDoc) -import "htoml" Text.Toml.Types (Node (..), Table, toJSON) - -import Benchmark.Type (HaskellType) - - --- | Decode toml file to Haskell type. -decode :: Text -> Either String HaskellType -decode txt = case parseTomlDoc "" txt of - Left err -> error $ "'htoml' parsing failed: " <> show err - Right toml -> convert toml - --- | Wrapper on htoml's 'parseTomlDoc' -parse :: Text -> Either ParseError Table -parse = parseTomlDoc "" - --- | Convert from already parsed toml to Haskell type. -convert :: Table -> Either String HaskellType -convert = parseEither parseJSON . toJSON - -deriving instance NFData Node -deriving instance Generic Node - -instance NFData ParseError where - rnf = rwhnf diff --git a/benchmark/Benchmark/HtomlMegaparsec.hs b/benchmark/Benchmark/HtomlMegaparsec.hs deleted file mode 100644 --- a/benchmark/Benchmark/HtomlMegaparsec.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -{-# LANGUAGE PackageImports #-} - -module Benchmark.HtomlMegaparsec - ( decode - , parse - , convert - ) where - -import Data.Aeson.Types (ToJSON, parseEither, parseJSON, toJSON) -import Data.Semigroup ((<>)) -import Data.Text (Text) - -import "htoml-megaparsec" Text.Toml (Node (..), Table, TomlError, parseTomlDoc) - -import Benchmark.Type (HaskellType) - --- | Decode toml file to Haskell type. -decode :: Text -> Either String HaskellType -decode txt = case parseTomlDoc "log" txt of - Left err -> error $ "'htoml-megaparsec' parsing failed: " <> show err - Right toml -> convert toml - --- | Wrapper on htoml-megaparsec's parseTomlDoc -parse :: Text -> Either TomlError Table -parse = parseTomlDoc "log" - --- | Convert from already parsed toml to Haskell type. -convert :: Table -> Either String HaskellType -convert = parseEither parseJSON . toJSON - --- | 'ToJSON' instances for the 'Node' type that produce Aeson (JSON) --- in line with the TOML specification. -instance ToJSON Node where - toJSON (VTable v) = toJSON v - toJSON (VTArray v) = toJSON v - toJSON (VString v) = toJSON v - toJSON (VInteger v) = toJSON v - toJSON (VFloat v) = toJSON v - toJSON (VBoolean v) = toJSON v - toJSON (VDatetime v) = toJSON v - toJSON (VArray v) = toJSON v diff --git a/benchmark/Benchmark/TomlParser.hs b/benchmark/Benchmark/TomlParser.hs deleted file mode 100644 --- a/benchmark/Benchmark/TomlParser.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} - -module Benchmark.TomlParser - ( decode - , parse - , convert - ) where - -import Control.DeepSeq (NFData, rnf, rwhnf) -import Data.Semigroup ((<>)) -import Data.Text (Text) -import GHC.Generics (Generic) - -import Benchmark.Type (FruitInside (..), HaskellType (..), SizeInside (..)) - -import qualified TOML - - --- | Decode toml file to Haskell type. -decode :: Text -> Either String HaskellType -decode txt = case parse txt of - Left err -> error $ "'toml-parser' parsing failed: " <> show err - Right toml -> maybe (Left "Some error during conversion") Right $ convert toml - --- | Wrapper over 'TOML.parseTOML' -parse :: Text -> Either TOML.TOMLError [(Text, TOML.Value)] -parse = TOML.parseTOML - --- | Convert from already parsed toml to Haskell type. -convert :: [(Text, TOML.Value)] -> Maybe HaskellType -convert toml = do - TOML.String htTitle <- lookup "title" toml - TOML.Double htAtom <- lookup "atom" toml - TOML.Bool htCash <- lookup "cash" toml - - TOML.List tomlWords <- lookup "words" toml - htWords <- mapM matchText tomlWords - - TOML.List tomlBools <- lookup "bool" toml - htBool <- mapM matchBool tomlBools - - TOML.ZonedTimeV htToday <- lookup "today" toml - - TOML.List tomlInts <- lookup "ints" toml - htInteger <- mapM matchInteger tomlInts - - TOML.Table fruit <- lookup "fruit" toml - htFruit <- do - TOML.String fiName <- lookup "name" fruit - TOML.String fiDescription <- lookup "description" fruit - pure FruitInside{..} - - TOML.Table size <- lookup "size" toml - htSize <- do - TOML.List dimensions <- lookup "dimensions" size - arrays :: [[TOML.Value]] <- mapM matchArray dimensions - unSize <- mapM (mapM matchDouble) arrays - pure SizeInside{..} - - pure HaskellType{..} - -matchText :: TOML.Value -> Maybe Text -matchText (TOML.String t) = Just t -matchText _ = Nothing - -matchBool :: TOML.Value -> Maybe Bool -matchBool (TOML.Bool b) = Just b -matchBool _ = Nothing - -matchInteger :: TOML.Value -> Maybe Integer -matchInteger (TOML.Integer i) = Just i -matchInteger _ = Nothing - -matchArray :: TOML.Value -> Maybe [TOML.Value] -matchArray (TOML.List a) = Just a -matchArray _ = Nothing - -matchDouble :: TOML.Value -> Maybe Double -matchDouble (TOML.Double d) = Just d -matchDouble _ = Nothing - -deriving instance Generic TOML.Value -deriving instance NFData TOML.Value - -instance NFData TOML.TOMLError where - rnf = rwhnf diff --git a/benchmark/Benchmark/Tomland.hs b/benchmark/Benchmark/Tomland.hs deleted file mode 100644 --- a/benchmark/Benchmark/Tomland.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Benchmark.Tomland - ( decode - , parse - , convert - ) where - -import Data.Text (Text) - -import Benchmark.Type (FruitInside (..), HaskellType (..), SizeInside (..)) -import Toml (DecodeException, TOML, TomlCodec, parse, (.=)) - -import qualified Toml - -decode :: Text -> Either DecodeException HaskellType -decode = Toml.decode codec - -convert :: TOML -> Either DecodeException HaskellType -convert = Toml.runTomlCodec codec - --- | Codec to use in tomland decode and convert functions. -codec :: TomlCodec HaskellType -codec = HaskellType - <$> Toml.text "title" .= htTitle - <*> Toml.double "atom" .= htAtom - <*> Toml.bool "cash" .= htCash - <*> Toml.arrayOf Toml._Text "words" .= htWords - <*> Toml.arrayOf Toml._Bool "bool" .= htBool - <*> Toml.zonedTime "today" .= htToday - <*> Toml.arrayOf Toml._Integer "ints" .= htInteger - <*> Toml.table insideF "fruit" .= htFruit - <*> Toml.table insideS "size" .= htSize - -insideF :: TomlCodec FruitInside -insideF = FruitInside - <$> Toml.text "name" .= fiName - <*> Toml.text "description" .= fiDescription - -insideS :: TomlCodec SizeInside -insideS = Toml.diwrap $ Toml.arrayOf (Toml._Array Toml._Double) "dimensions" diff --git a/benchmark/Benchmark/Type.hs b/benchmark/Benchmark/Type.hs deleted file mode 100644 --- a/benchmark/Benchmark/Type.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} - -module Benchmark.Type - ( HaskellType (..) - , FruitInside (..) - , SizeInside (..) - ) where - -import Control.DeepSeq (NFData) -import Data.Aeson.Types (FromJSON, parseJSON, withObject, (.:)) -import Data.Text (Text) -import Data.Time (ZonedTime) -import GHC.Generics (Generic) - - --- | Haskell type to convert to. -data HaskellType = HaskellType - { htTitle :: Text - , htAtom :: Double - , htCash :: Bool - , htWords :: [Text] - , htBool :: [Bool] - , htToday :: ZonedTime - , htInteger :: [Integer] - , htFruit :: FruitInside - , htSize :: SizeInside - } deriving (Show, NFData, Generic) - -instance FromJSON HaskellType where - parseJSON = withObject "HaskellType" $ \o -> HaskellType - <$> o .: "title" - <*> o .: "atom" - <*> o .: "cash" - <*> o .: "words" - <*> o .: "bool" - <*> o .: "today" - <*> o .: "ints" - <*> o .: "fruit" - <*> o .: "size" - -data FruitInside = FruitInside - { fiName :: Text - , fiDescription :: Text - } deriving (Show, NFData, Generic) - -instance FromJSON FruitInside where - parseJSON = withObject "FruitInside" $ \o -> FruitInside - <$> o .: "name" - <*> o .: "description" - -newtype SizeInside = SizeInside - { unSize :: [[Double]] - } deriving (Show, NFData, Generic) - -instance FromJSON SizeInside where - parseJSON = withObject "SizeInside" $ \o -> SizeInside <$> o .: "dimensions" diff --git a/benchmark/Main.hs b/benchmark/Main.hs deleted file mode 100644 --- a/benchmark/Main.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Main - ( main - ) where - -import Gauge.Main (bench, bgroup, defaultMain, nf) - -import qualified Benchmark.Htoml as Htoml -import qualified Benchmark.HtomlMegaparsec as HtomlM -import qualified Benchmark.Tomland as Tomland -import qualified Benchmark.TomlParser as TomlParser -import qualified Data.Text.IO as TIO - - --- | Benchmark. -main :: IO () -main = do - txt <- TIO.readFile "./benchmark/benchmark.toml" - Right tomlandVal <- pure $ Tomland.parse txt - Right htomlVal <- pure $ Htoml.parse txt - Right htomlMegaVal <- pure $ HtomlM.parse txt - Right tomlParserVal <- pure $ TomlParser.parse txt - defaultMain - [ bgroup "Parse" - [ bench "tomland" $ nf Tomland.parse txt - , bench "htoml" $ nf Htoml.parse txt - , bench "htoml-megaparsec" $ nf HtomlM.parse txt - , bench "toml-parser" $ nf TomlParser.parse txt - ] - , bgroup "Convert" - [ bench "tomland" $ nf Tomland.convert tomlandVal - , bench "htoml" $ nf Htoml.convert htomlVal - , bench "htoml-megaparsec" $ nf HtomlM.convert htomlMegaVal - , bench "toml-parser" $ nf TomlParser.convert tomlParserVal - ] - , bgroup "Decode" - [ bench "tomland" $ nf Tomland.decode txt - , bench "htoml" $ nf Htoml.decode txt - , bench "htoml-megaparsec" $ nf HtomlM.decode txt - , bench "toml-parser" $ nf TomlParser.decode txt - ] - ] diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Main.hs @@ -0,0 +1,153 @@ +{-# OPTIONS -Wno-unused-top-binds #-} +{-# LANGUAGE DeriveAnyClass #-} + +module Main (main) where + +import Control.Applicative ((<|>)) +import Control.Arrow ((>>>)) +import Data.Hashable (Hashable) +import Data.HashSet (HashSet) +import Data.Set (Set) +import Data.Text (Text) +import Data.Time (fromGregorian) +import GHC.Generics (Generic) + +import Toml (ParseException (..), TomlCodec, pretty, (.=), ()) +import Toml.Edsl (mkToml, table, (=:)) +import Toml.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 + } deriving stock (Eq, Ord, Generic) + deriving anyclass (Hashable) + +userCodec :: TomlCodec User +userCodec = User + <$> Toml.text "name" .= userName + <*> Toml.int "age" .= userAge + +newtype N = N + { unN :: Text + } + +data ColorScheme + = Light + | Dark + | HighContrast + deriving stock (Show, Enum, Bounded) + +data UserStatus + = Registered Text Text + | Anonymous Text + +matchRegistered :: UserStatus -> Maybe (Text, Text) +matchRegistered (Registered username password) = Just (username, password) +matchRegistered _ = Nothing + +matchAnonymous :: UserStatus -> Maybe Text +matchAnonymous (Anonymous username) = Just username +matchAnonymous _ = Nothing + +userPassCodec :: TomlCodec (Text, Text) +userPassCodec = (,) + <$> Toml.text "username" .= fst + <*> Toml.text "password" .= snd + +userStatusCodec :: TomlCodec UserStatus +userStatusCodec = + Toml.dimatch matchRegistered (uncurry Registered) (Toml.table userPassCodec "testStatus") + <|> Toml.dimatch matchAnonymous Anonymous (Toml.text "testStatus") + +data Test = Test + { testB :: !Bool + , testI :: !Int + , testF :: !Double + , testS :: !Text + , testA :: ![Text] + , testM :: !(Maybe Bool) + , testX :: !TestInside + , testY :: !(Maybe TestInside) + , testN :: !N + , testC :: !ColorScheme + , testE1 :: !(Either Integer String) + , testE2 :: !(Either String Double) + , testStatus :: !UserStatus + , users :: ![User] + , susers :: !(Set User) + , husers :: !(HashSet User) + } + + +testT :: TomlCodec Test +testT = Test + <$> Toml.bool "testB" .= testB + <*> Toml.int "testI" .= testI + <*> Toml.double "testF" .= testF + <*> Toml.text "testS" .= testS + <*> Toml.arrayOf Toml._Text "testA" .= testA + <*> Toml.dioptional (Toml.bool "testM") .= testM + <*> Toml.table insideCodec "testX" .= testX + <*> Toml.dioptional ((Toml.table insideCodec) "testY") .= testY + <*> Toml.diwrap (Toml.text "testN") .= testN + <*> Toml.enumBounded "testC" .= testC + <*> eitherT1 .= testE1 + <*> eitherT2 .= testE2 + <*> userStatusCodec .= testStatus + <*> Toml.list userCodec "user" .= users + <*> Toml.set userCodec "suser" .= susers + <*> Toml.hashSet userCodec "huser" .= husers + where + -- different keys for sum type + eitherT1 :: TomlCodec (Either Integer String) + eitherT1 = Toml.match (Toml._Left >>> Toml._Integer) "either.Left" + <|> Toml.match (Toml._Right >>> Toml._String) "either.Right" + + -- same key for sum type; + -- doesn't work if you have something like `Either String String`, + -- you should distinguish these cases by different keys like in `eitherT1` example + eitherT2 :: TomlCodec (Either String Double) + eitherT2 = ( Toml.match (Toml._Left >>> Toml._String) + Toml.match (Toml._Right >>> Toml._Double) + ) "either" + +main :: IO () +main = do + TIO.putStrLn "=== Printing manually specified TOML ===" + TIO.putStrLn $ pretty myToml + + TIO.putStrLn "=== Trying to print invalid TOML ===" + content <- TIO.readFile "examples/invalid.toml" + TIO.putStrLn $ case Toml.parse content of + Left (ParseException e) -> e + Right toml -> pretty toml + + TIO.putStrLn "=== Testing bidirectional conversion ===" + biFile <- TIO.readFile "examples/biTest.toml" + TIO.putStrLn $ case Toml.decode testT biFile of + Left msg -> Toml.prettyException msg + Right test -> Toml.encode testT test + +myToml :: TOML +myToml = mkToml $ do + "a" =: Bool True + "list" =: Array ["one", "two"] + "time" =: Array [Day (fromGregorian 2018 3 29)] + table "table.name.1" $ do + "aInner" =: 1 + "listInner" =: Array [Bool True, Bool False] + table "1" $ do + "aInner11" =: 11 + "listInner11" =: Array [0, 1] + table "2" $ + "Inner12" =: "12" + table "table.name.2" $ + "Inner2" =: 42 diff --git a/examples/Playground.hs b/examples/Playground.hs deleted file mode 100644 --- a/examples/Playground.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# OPTIONS -Wno-unused-top-binds #-} - -module Main (main) where - -import Control.Applicative ((<|>)) -import Control.Arrow ((>>>)) -import Data.Text (Text) -import Data.Time (fromGregorian) - -import Toml (ParseException (..), TomlCodec, pretty, (.=), ()) -import Toml.Edsl (mkToml, table, (=:)) -import Toml.Type (TOML (..), Value (..)) - -import qualified Data.Text.IO as TIO -import qualified Toml - -newtype TestInside = TestInside { unInside :: Text } - -insideCodec :: TomlCodec TestInside -insideCodec = Toml.dimap unInside TestInside $ Toml.text "inside" - -data User = User - { userName :: Text - , userAge :: Int - } - -userCodec :: TomlCodec User -userCodec = User - <$> Toml.text "name" .= userName - <*> Toml.int "age" .= userAge - -newtype N = N Text - -data ColorScheme = Light - | Dark - | HighContrast - deriving (Show, Enum, Bounded) - -data Test = Test - { testB :: Bool - , testI :: Int - , testF :: Double - , testS :: Text - , testA :: [Text] - , testM :: Maybe Bool - , testX :: TestInside - , testY :: Maybe TestInside - , testN :: N - , testC :: ColorScheme - , testE1 :: Either Integer String - , testE2 :: Either String Double - , users :: [User] - } - - -testT :: TomlCodec Test -testT = Test - <$> Toml.bool "testB" .= testB - <*> Toml.int "testI" .= testI - <*> Toml.double "testF" .= testF - <*> Toml.text "testS" .= testS - <*> Toml.arrayOf Toml._Text "testA" .= testA - <*> Toml.dioptional (Toml.bool "testM") .= testM - <*> Toml.table insideCodec "testX" .= testX - <*> Toml.dioptional ((Toml.table insideCodec) "testY") .= testY - <*> Toml.diwrap (Toml.text "testN") .= testN - <*> Toml.enumBounded "testC" .= testC - <*> eitherT1 .= testE1 - <*> eitherT2 .= testE2 - <*> Toml.list userCodec "user" .= users - where - -- different keys for sum type - eitherT1 :: TomlCodec (Either Integer String) - eitherT1 = Toml.match (Toml._Left >>> Toml._Integer) "either.Left" - <|> Toml.match (Toml._Right >>> Toml._String) "either.Right" - - -- same key for sum type; - -- doesn't work if you have something like `Either String String`, - -- you should distinguish these cases by different keys like in `eitherT1` example - eitherT2 :: TomlCodec (Either String Double) - eitherT2 = ( Toml.match (Toml._Left >>> Toml._String) - Toml.match (Toml._Right >>> Toml._Double) - ) "either" - -main :: IO () -main = do - TIO.putStrLn "=== Printing manually specified TOML ===" - TIO.putStrLn $ pretty myToml - - TIO.putStrLn "=== Trying to print invalid TOML ===" - content <- TIO.readFile "examples/invalid.toml" - TIO.putStrLn $ case Toml.parse content of - Left (ParseException e) -> e - Right toml -> pretty toml - - TIO.putStrLn "=== Testing bidirectional conversion ===" - biFile <- TIO.readFile "examples/biTest.toml" - TIO.putStrLn $ case Toml.decode testT biFile of - Left msg -> Toml.prettyException msg - Right test -> Toml.encode testT test - -myToml :: TOML -myToml = mkToml $ do - "a" =: Bool True - "list" =: Array ["one", "two"] - "time" =: Array [Day (fromGregorian 2018 3 29)] - table "table.name.1" $ do - "aInner" =: 1 - "listInner" =: Array [Bool True, Bool False] - table "1" $ do - "aInner11" =: 11 - "listInner11" =: Array [0, 1] - table "2" $ - "Inner12" =: "12" - table "table.name.2" $ - "Inner2" =: 42 diff --git a/src/Toml/Bi/Code.hs b/src/Toml/Bi/Code.hs --- a/src/Toml/Bi/Code.hs +++ b/src/Toml/Bi/Code.hs @@ -45,15 +45,17 @@ import qualified Data.Text as Text import qualified Data.Text.IO as TIO + -- | Type of exception for converting from TOML to user custom data type. data DecodeException = TrivialError - | BiMapError TomlBiMapError - | KeyNotFound Key -- ^ No such key - | TableNotFound Key -- ^ No such table - | TypeMismatch Key Text TValue -- ^ Expected type vs actual type - | ParseError ParseException -- ^ Exception during parsing - deriving (Eq, Generic, NFData) + | BiMapError !TomlBiMapError + | KeyNotFound !Key -- ^ No such key + | TableNotFound !Key -- ^ No such table + | TypeMismatch !Key !Text !TValue -- ^ Expected type vs actual type + | ParseError !ParseException -- ^ Exception during parsing + deriving stock (Eq, Generic) + deriving anyclass (NFData) instance Show DecodeException where show = Text.unpack . prettyException @@ -120,7 +122,7 @@ execTomlCodec codec obj = execState (runMaybeT $ codecWrite codec obj) mempty -- | File loading error data type. -data LoadTomlException = LoadTomlException FilePath Text +data LoadTomlException = LoadTomlException !FilePath !Text instance Show LoadTomlException where show (LoadTomlException filePath msg) = "Couldnt parse file " ++ filePath ++ ": " ++ show msg diff --git a/src/Toml/Bi/Combinators.hs b/src/Toml/Bi/Combinators.hs --- a/src/Toml/Bi/Combinators.hs +++ b/src/Toml/Bi/Combinators.hs @@ -13,6 +13,7 @@ , natural , int , word + , word8 -- ** Floating point numbers , double , float @@ -21,6 +22,8 @@ , lazyText , byteString , lazyByteString + , byteStringArray + , lazyByteStringArray , string -- ** Time types , zonedTime @@ -44,6 +47,8 @@ , table , nonEmpty , list + , set + , hashSet -- * General construction of codecs , match @@ -66,24 +71,25 @@ import Data.Set (Set) import Data.Text (Text) import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime) -import Data.Word (Word) +import Data.Word (Word8) import Numeric.Natural (Natural) import Toml.Bi.Code (DecodeException (..), Env, St, TomlCodec, execTomlCodec) -import Toml.Bi.Map (BiMap (..), TomlBiMap, _Array, _Bool, _ByteString, _Day, _Double, _EnumBounded, - _Float, _HashSet, _Int, _IntSet, _Integer, _LByteString, _LText, _LocalTime, - _Natural, _NonEmpty, _Read, _Set, _String, _Text, _TextBy, _TimeOfDay, _Word, - _ZonedTime) -import Toml.Bi.Monad (Codec (..)) +import Toml.Bi.Map (BiMap (..), TomlBiMap, _Array, _Bool, _ByteString, _ByteStringArray, _Day, + _Double, _EnumBounded, _Float, _HashSet, _Int, _IntSet, _Integer, _LByteString, + _LByteStringArray, _LText, _LocalTime, _Natural, _NonEmpty, _Read, _Set, + _String, _Text, _TextBy, _TimeOfDay, _Word, _Word8, _ZonedTime) +import Toml.Bi.Monad (Codec (..), dimap) import Toml.PrefixTree (Key) import Toml.Type (AnyValue (..), TOML (..), insertKeyAnyVal, insertTable, insertTableArrays) import qualified Data.ByteString.Lazy as BL import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashSet as HS +import qualified Data.Set as S import qualified Data.Text.Lazy as L import qualified Toml.PrefixTree as Prefix - {- | General function to create bidirectional converters for key-value pairs. In order to use this function you need to create 'TomlBiMap' for your type and 'AnyValue': @@ -119,50 +125,70 @@ -- | Codec for boolean values. bool :: Key -> TomlCodec Bool bool = match _Bool +{-# INLINE bool #-} -- | Codec for integer values. integer :: Key -> TomlCodec Integer integer = match _Integer +{-# INLINE integer #-} -- | Codec for integer values. int :: Key -> TomlCodec Int int = match _Int +{-# INLINE int #-} -- | Codec for natural values. natural :: Key -> TomlCodec Natural natural = match _Natural +{-# INLINE natural #-} -- | Codec for word values. word :: Key -> TomlCodec Word word = match _Word +{-# INLINE word #-} +{- | Codec for word8 values. + +@since 1.2.0.0 +-} +word8 :: Key -> TomlCodec Word8 +word8 = match _Word8 +{-# INLINE word8 #-} + -- | Codec for floating point values with double precision. double :: Key -> TomlCodec Double double = match _Double +{-# INLINE double #-} -- | Codec for floating point values. float :: Key -> TomlCodec Float float = match _Float +{-# INLINE float #-} -- | Codec for text values. text :: Key -> TomlCodec Text text = match _Text +{-# INLINE text #-} -- | Codec for lazy text values. lazyText :: Key -> TomlCodec L.Text lazyText = match _LText +{-# INLINE lazyText #-} -- | Codec for text values with custom error messages for parsing. textBy :: (a -> Text) -> (Text -> Either Text a) -> Key -> TomlCodec a textBy to from = match (_TextBy to from) +{-# INLINE textBy #-} -- | Codec for string values. string :: Key -> TomlCodec String string = match _String +{-# INLINE string #-} -- | Codec for values with a 'Read' and 'Show' instance. read :: (Show a, Read a) => Key -> TomlCodec a read = match _Read +{-# INLINE read #-} {- | Codec for general nullary sum data types with a 'Bounded', 'Enum', and 'Show' instance. This codec provides much better error messages than 'read' for @@ -172,45 +198,71 @@ -} enumBounded :: (Bounded a, Enum a, Show a) => Key -> TomlCodec a enumBounded = match _EnumBounded +{-# INLINE enumBounded #-} -- | Codec for text values as 'ByteString'. byteString :: Key -> TomlCodec ByteString byteString = match _ByteString +{-# INLINE byteString #-} -- | Codec for text values as 'BL.ByteString'. lazyByteString :: Key -> TomlCodec BL.ByteString lazyByteString = match _LByteString +{-# INLINE lazyByteString #-} +{- | Codec for positive integer array values as 'ByteString'. + +@since 1.2.0.0 +-} +byteStringArray :: Key -> TomlCodec ByteString +byteStringArray = match _ByteStringArray +{-# INLINE byteStringArray #-} + +{- | Codec for positive integer array values as lazy 'ByteString'. + +@since 1.2.0.0 +-} +lazyByteStringArray :: Key -> TomlCodec BL.ByteString +lazyByteStringArray = match _LByteStringArray +{-# INLINE lazyByteStringArray #-} + -- | Codec for zoned time values. zonedTime :: Key -> TomlCodec ZonedTime zonedTime = match _ZonedTime +{-# INLINE zonedTime #-} -- | Codec for local time values. localTime :: Key -> TomlCodec LocalTime localTime = match _LocalTime +{-# INLINE localTime #-} -- | Codec for day values. day :: Key -> TomlCodec Day day = match _Day +{-# INLINE day #-} -- | Codec for time of day values. timeOfDay :: Key -> TomlCodec TimeOfDay timeOfDay = match _TimeOfDay +{-# INLINE timeOfDay #-} -- | Codec for list of values. Takes converter for single value and -- returns a list of values. arrayOf :: TomlBiMap a AnyValue -> Key -> TomlCodec [a] arrayOf = match . _Array +{-# INLINE arrayOf #-} -- | Codec for sets. Takes converter for single value and -- returns a set of values. arraySetOf :: Ord a => TomlBiMap a AnyValue -> Key -> TomlCodec (Set a) arraySetOf = match . _Set +{-# INLINE arraySetOf #-} -- | Codec for sets of ints. Takes converter for single value and -- returns a set of ints. arrayIntSet :: Key -> TomlCodec IntSet arrayIntSet = match _IntSet +{-# INLINE arrayIntSet #-} -- | Codec for hash sets. Takes converter for single hashable value and -- returns a set of hashable values. @@ -220,11 +272,13 @@ -> Key -> TomlCodec (HashSet a) arrayHashSetOf = match . _HashSet +{-# INLINE arrayHashSetOf #-} -- | Codec for non- empty lists of values. Takes converter for single value and -- returns a non-empty list of values. arrayNonEmptyOf :: TomlBiMap a AnyValue -> Key -> TomlCodec (NonEmpty a) arrayNonEmptyOf = match . _NonEmpty +{-# INLINE arrayNonEmptyOf #-} {- | 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 @@ -298,3 +352,20 @@ where nonEmptyCodec :: TomlCodec (NonEmpty a) nonEmptyCodec = nonEmpty codec key + +{- | 'Codec' for set of values. Represented in TOML as array of tables. + +@since 1.2.0.0 +-} +set :: forall a . Ord a => TomlCodec a -> Key -> TomlCodec (Set a) +set codec key = dimap S.toList S.fromList (list codec key) +{-# INLINE set #-} + +{- | 'Codec' for HashSet of values. Represented in TOML as array of tables. + +@since 1.2.0.0 +-} + +hashSet :: forall a . (Hashable a, Eq a) => TomlCodec a -> Key -> TomlCodec (HashSet a) +hashSet codec key = dimap HS.toList HS.fromList (list codec key) +{-# INLINE hashSet #-} diff --git a/src/Toml/Bi/Map.hs b/src/Toml/Bi/Map.hs --- a/src/Toml/Bi/Map.hs +++ b/src/Toml/Bi/Map.hs @@ -21,18 +21,6 @@ , wrongConstructor , prettyBiMapError - -- * Helpers for BiMap and AnyValue - , mkAnyValueBiMap - , _TextBy - , _LTextText - , _NaturalInteger - , _StringText - , _ReadString - , _BoundedInteger - , _EnumBoundedText - , _ByteStringText - , _LByteStringText - -- * Some predefined bi mappings , _Array , _Bool @@ -48,15 +36,29 @@ , _Read , _Natural , _Word + , _Word8 , _Int , _Float , _ByteString , _LByteString + , _ByteStringArray + , _LByteStringArray + , _NonEmpty , _Set , _IntSet , _HashSet - , _NonEmpty + -- * Helpers for BiMap and AnyValue + , mkAnyValueBiMap + , _TextBy + , _LTextText + , _NaturalInteger + , _StringText + , _ReadString + , _BoundedInteger + , _EnumBoundedText + , _ByteStringText + , _LByteStringText , _Left , _Right , _EnumBounded @@ -76,7 +78,7 @@ import Data.Semigroup (Semigroup (..)) import Data.Text (Text) import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime) -import Data.Word (Word) +import Data.Word (Word8) import GHC.Generics (Generic) import Numeric.Natural (Natural) import Text.Read (readEither) @@ -86,6 +88,7 @@ matchZoned, mkMatchError, toMArray) import qualified Control.Category as Cat +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import qualified Data.HashSet as HS import qualified Data.IntSet as IS @@ -125,16 +128,19 @@ instance Cat.Category (BiMap e) where id :: BiMap e a a id = BiMap Right Right + {-# INLINE id #-} (.) :: BiMap e b c -> BiMap e a b -> BiMap e a c bc . ab = BiMap { forward = forward ab >=> forward bc , backward = backward bc >=> backward ab } + {-# INLINE (.) #-} -- | Inverts bidirectional mapping. invert :: BiMap e a b -> BiMap e b a invert (BiMap f g) = BiMap g f +{-# INLINE invert #-} {- | Creates 'BiMap' from isomorphism. Can be used in the following way: @@ -154,6 +160,7 @@ -} iso :: (a -> b) -> (b -> a) -> BiMap e a b iso f g = BiMap (Right . f) (Right . g) +{-# INLINE iso #-} {- | Creates 'BiMap' from prism-like pair of functions. This combinator can be used to create 'BiMap' for custom data types like this: @@ -175,8 +182,12 @@ other -> Toml.'wrongConstructor' \"Client\" other @ -} -prism :: (field -> object) -> (object -> Either error field) -> BiMap error object field +prism + :: (field -> object) + -> (object -> Either error field) + -> BiMap error object field prism review preview = BiMap preview (Right . review) +{-# INLINE prism #-} ---------------------------------------------------------------------------- -- BiMap error types @@ -190,13 +201,14 @@ = 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 + !Text -- ^ Expected constructor name + !Text -- ^ Actual value | WrongValue -- ^ Error for cases with wrong values - MatchError -- ^ Information about failed matching + !MatchError -- ^ Information about failed matching | ArbitraryError -- ^ Arbitrary textual error - Text -- ^ Error message - deriving (Eq, Show, Generic, NFData) + !Text -- ^ Error message + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) -- | Converts 'TomlBiMapError' into pretty human-readable text. prettyBiMapError :: TomlBiMapError -> Text @@ -283,77 +295,91 @@ -} _Bool :: TomlBiMap Bool AnyValue _Bool = mkAnyValueBiMap matchBool Bool +{-# INLINE _Bool #-} {- | 'Prelude.Integer' bimap for 'AnyValue'. Usually used as 'Toml.Bi.Combinators.integer' combinator. -} _Integer :: TomlBiMap Integer AnyValue _Integer = mkAnyValueBiMap matchInteger Integer +{-# INLINE _Integer #-} {- | 'Prelude.Double' bimap for 'AnyValue'. Usually used as 'Toml.Bi.Combinators.double' combinator. -} _Double :: TomlBiMap Double AnyValue _Double = mkAnyValueBiMap matchDouble Double +{-# INLINE _Double #-} {- | 'Data.Text.Text' bimap for 'AnyValue'. Usually used as 'Toml.Bi.Combinators.text' combinator. -} _Text :: TomlBiMap Text AnyValue _Text = mkAnyValueBiMap matchText Text +{-# INLINE _Text #-} -- | Helper bimap for 'Data.Text.Lazy.Text' and 'Data.Text.Text'. _LTextText :: BiMap e TL.Text Text _LTextText = iso TL.toStrict TL.fromStrict +{-# INLINE _LTextText #-} {- | 'Data.Text.Lazy.Text' bimap for 'AnyValue'. Usually used as 'Toml.Bi.Combinators.lazyText' combinator. -} _LText :: TomlBiMap TL.Text AnyValue _LText = _LTextText >>> _Text +{-# INLINE _LText #-} {- | 'Data.Time.ZonedTime' bimap for 'AnyValue'. Usually used as 'Toml.Bi.Combinators.zonedTime' combinator. -} _ZonedTime :: TomlBiMap ZonedTime AnyValue _ZonedTime = mkAnyValueBiMap matchZoned Zoned +{-# INLINE _ZonedTime #-} {- | 'Data.Time.LocalTime' bimap for 'AnyValue'. Usually used as 'Toml.Bi.Combinators.localTime' combinator. -} _LocalTime :: TomlBiMap LocalTime AnyValue _LocalTime = mkAnyValueBiMap matchLocal Local +{-# INLINE _LocalTime #-} {- | 'Data.Time.Day' bimap for 'AnyValue'. Usually used as 'Toml.Bi.Combinators.day' combinator. -} _Day :: TomlBiMap Day AnyValue _Day = mkAnyValueBiMap matchDay Day +{-# INLINE _Day #-} {- | 'Data.Time.TimeOfDay' bimap for 'AnyValue'. Usually used as 'Toml.Bi.Combinators.timeOfDay' combinator. -} _TimeOfDay :: TomlBiMap TimeOfDay AnyValue _TimeOfDay = mkAnyValueBiMap matchHours Hours +{-# INLINE _TimeOfDay #-} -- | Helper bimap for 'String' and 'Data.Text.Text'. _StringText :: BiMap e String Text _StringText = iso T.pack T.unpack +{-# INLINE _StringText #-} {- | 'String' bimap for 'AnyValue'. Usually used as 'Toml.Bi.Combinators.string' combinator. -} _String :: TomlBiMap String AnyValue _String = _StringText >>> _Text +{-# INLINE _String #-} -- | Helper bimap for 'String' and types with 'Read' and 'Show' instances. _ReadString :: (Show a, Read a) => TomlBiMap a String _ReadString = BiMap (Right . show) (first (ArbitraryError . T.pack) . readEither) +{-# INLINE _ReadString #-} -- | Bimap for 'AnyValue' and values with a 'Read' and 'Show' instance. -- Usually used as 'Toml.Bi.Combinators.read' combinator. _Read :: (Show a, Read a) => TomlBiMap a AnyValue _Read = _ReadString >>> _String +{-# INLINE _Read #-} -- | Helper bimap for 'Natural' and 'Prelude.Integer'. _NaturalInteger :: TomlBiMap Natural Integer @@ -369,6 +395,7 @@ -} _Natural :: TomlBiMap Natural AnyValue _Natural = _NaturalInteger >>> _Integer +{-# INLINE _Natural #-} -- | Helper bimap for 'Prelude.Integer' and integral, bounded values. _BoundedInteger :: (Integral a, Bounded a, Show a) => TomlBiMap a Integer @@ -384,7 +411,7 @@ in Left $ ArbitraryError msg | otherwise = Right (fromIntegral n) -{- | Helper bimap for 'EnumBounded' and 'Data.Text.Text'. +{- | Helper bimap for '_EnumBounded' and 'Data.Text.Text'. @since 1.1.1.0 -} @@ -413,24 +440,37 @@ -} _EnumBounded :: (Show a, Enum a, Bounded a) => TomlBiMap a AnyValue _EnumBounded = _EnumBoundedText >>> _Text +{-# INLINE _EnumBounded #-} {- | 'Word' bimap for 'AnyValue'. Usually used as 'Toml.Bi.Combinators.word' combinator. -} _Word :: TomlBiMap Word AnyValue _Word = _BoundedInteger >>> _Integer +{-# INLINE _Word #-} +{- | 'Word8' bimap for 'AnyValue'. Usually used as +'Toml.Bi.Combinators.word8' combinator. + +@since 1.2.0.0 +-} +_Word8 :: TomlBiMap Word8 AnyValue +_Word8 = _BoundedInteger >>> _Integer +{-# INLINE _Word8 #-} + {- | 'Int' bimap for 'AnyValue'. Usually used as 'Toml.Bi.Combinators.int' combinator. -} _Int :: TomlBiMap Int AnyValue _Int = _BoundedInteger >>> _Integer +{-# INLINE _Int #-} {- | 'Float' bimap for 'AnyValue'. Usually used as 'Toml.Bi.Combinators.float' combinator. -} _Float :: TomlBiMap Float AnyValue _Float = iso realToFrac realToFrac >>> _Double +{-# INLINE _Float #-} -- | Helper bimap for 'Data.Text.Text' and strict 'ByteString' _ByteStringText :: TomlBiMap ByteString Text @@ -438,11 +478,13 @@ where eitherText :: ByteString -> Either TomlBiMapError Text eitherText = either (\err -> Left $ ArbitraryError $ tShow err) Right . T.decodeUtf8' +{-# INLINE _ByteStringText #-} -- | UTF8 encoded 'ByteString' bimap for 'AnyValue'. -- Usually used as 'Toml.Bi.Combinators.byteString' combinator. _ByteString :: TomlBiMap ByteString AnyValue _ByteString = _ByteStringText >>> _Text +{-# INLINE _ByteString #-} -- | Helper bimap for 'Data.Text.Text' and lazy 'BL.ByteString'. _LByteStringText :: TomlBiMap BL.ByteString Text @@ -450,12 +492,32 @@ where eitherText :: BL.ByteString -> Either TomlBiMapError Text eitherText = bimap (ArbitraryError . tShow) TL.toStrict . TL.decodeUtf8' +{-# INLINE _LByteStringText #-} -- | UTF8 encoded lazy 'BL.ByteString' bimap for 'AnyValue'. -- Usually used as 'Toml.Bi.Combinators.lazyByteString' combinator. _LByteString :: TomlBiMap BL.ByteString AnyValue _LByteString = _LByteStringText >>> _Text +{-# INLINE _LByteString #-} +{- | 'ByteString' bimap for 'AnyValue' encoded as a list of non-negative integers. +Usually used as 'Toml.Bi.Combinators.byteStringArray' combinator. + +@since 1.2.0.0 +-} +_ByteStringArray :: TomlBiMap ByteString AnyValue +_ByteStringArray = iso BS.unpack BS.pack >>> _Array _Word8 +{-# INLINE _ByteStringArray #-} + +{- | Lazy 'ByteString' bimap for 'AnyValue' encoded as a list of non-negative integers. +Usually used as 'Toml.Bi.Combinators.lazyByteStringArray' combinator. + +@since 1.2.0.0 +-} +_LByteStringArray :: TomlBiMap BL.ByteString AnyValue +_LByteStringArray = iso BL.unpack BL.pack >>> _Array _Word8 +{-# INLINE _LByteStringArray #-} + -- | Takes a bimap of a value and returns a bimap between a list of values and 'AnyValue' -- as an array. Usually used as 'Toml.Bi.Combinators.arrayOf' combinator. _Array :: forall a . TomlBiMap a AnyValue -> TomlBiMap [a] AnyValue @@ -477,28 +539,34 @@ -- as an array. Usually used as 'Toml.Bi.Combinators.nonEmpty' combinator. _NonEmpty :: TomlBiMap a AnyValue -> TomlBiMap (NE.NonEmpty a) AnyValue _NonEmpty bi = _NonEmptyArray >>> _Array bi +{-# INLINE _NonEmpty #-} _NonEmptyArray :: TomlBiMap (NE.NonEmpty a) [a] _NonEmptyArray = BiMap { forward = Right . NE.toList , backward = maybe (Left $ ArbitraryError "Empty array list, but expected NonEmpty") Right . NE.nonEmpty } +{-# INLINE _NonEmptyArray #-} -- | Takes a bimap of a value and returns a bimap between a set of values and 'AnyValue' -- as an array. Usually used as 'Toml.Bi.Combinators.arraySetOf' combinator. _Set :: (Ord a) => TomlBiMap a AnyValue -> TomlBiMap (S.Set a) AnyValue _Set bi = iso S.toList S.fromList >>> _Array bi +{-# INLINE _Set #-} -- | Takes a bimap of a value and returns a bimap between a hash set of values and 'AnyValue' -- as an array. Usually used as 'Toml.Bi.Combinators.arrayHashSetOf' combinator. _HashSet :: (Eq a, Hashable a) => TomlBiMap a AnyValue -> TomlBiMap (HS.HashSet a) AnyValue _HashSet bi = iso HS.toList HS.fromList >>> _Array bi +{-# INLINE _HashSet #-} {- | 'IS.IntSet' bimap for 'AnyValue'. Usually used as 'Toml.Bi.Combinators.arrayIntSet' combinator. -} _IntSet :: TomlBiMap IS.IntSet AnyValue _IntSet = iso IS.toList IS.fromList >>> _Array _Int +{-# INLINE _IntSet #-} tShow :: Show a => a -> Text tShow = T.pack . show +{-# INLINE tShow #-} diff --git a/src/Toml/Bi/Monad.hs b/src/Toml/Bi/Monad.hs --- a/src/Toml/Bi/Monad.hs +++ b/src/Toml/Bi/Monad.hs @@ -6,6 +6,7 @@ , dimap , dioptional , diwrap + , dimatch , () , (.=) ) where @@ -54,6 +55,7 @@ { codecRead = f <$> codecRead codec , codecWrite = fmap f . codecWrite codec } + {-# INLINE fmap #-} instance (Applicative r, Applicative w) => Applicative (Codec r w c) where pure :: a -> Codec r w c a @@ -61,12 +63,14 @@ { codecRead = pure a , codecWrite = \_ -> pure a } + {-# INLINE pure #-} (<*>) :: Codec r w c (a -> b) -> Codec r w c a -> Codec r w c b codecf <*> codeca = Codec { codecRead = codecRead codecf <*> codecRead codeca , codecWrite = \c -> codecWrite codecf c <*> codecWrite codeca c } + {-# INLINE (<*>) #-} instance (Monad r, Monad w) => Monad (Codec r w c) where (>>=) :: Codec r w c a -> (a -> Codec r w c b) -> Codec r w c b @@ -74,6 +78,7 @@ { codecRead = codecRead codec >>= \a -> codecRead (f a) , codecWrite = \c -> codecWrite codec c >>= \a -> codecWrite (f a) c } + {-# INLINE (>>=) #-} instance (Alternative r, Alternative w) => Alternative (Codec r w c) where empty :: Codec r w c a @@ -81,21 +86,26 @@ { codecRead = empty , codecWrite = \_ -> empty } + {-# INLINE empty #-} (<|>) :: Codec r w c a -> Codec r w c a -> Codec r w c a codec1 <|> codec2 = Codec { codecRead = codecRead codec1 <|> codecRead codec2 , codecWrite = \c -> codecWrite codec1 c <|> codecWrite codec2 c } + {-# INLINE (<|>) #-} instance (MonadPlus r, MonadPlus w) => MonadPlus (Codec r w c) where mzero = empty + {-# INLINE mzero #-} mplus = (<|>) + {-# INLINE mplus #-} -- | Alternative instance for function arrow but without 'empty'. infixl 3 () :: Alternative f => (a -> f x) -> (a -> f x) -> (a -> f x) f g = \a -> f a <|> g a +{-# INLINE () #-} {- | This is an instance of @Profunctor@ for 'Codec'. But since there's no @Profunctor@ type class in @base@ or package with no dependencies (and we don't @@ -151,6 +161,7 @@ { codecRead = g <$> codecRead codec , codecWrite = fmap g . codecWrite codec . f } +{-# INLINE dimap #-} {- | Bidirectional converter for @Maybe a@ values. For example, given the data type: @@ -179,6 +190,7 @@ { codecRead = optional codecRead , codecWrite = traverse codecWrite } +{-# INLINE dioptional #-} {- | Combinator used for @newtype@ wrappers. For example, given the data types: @@ -206,7 +218,55 @@ => BiCodec r w a -> BiCodec r w b diwrap = dimap coerce coerce +{-# INLINE diwrap #-} +{- | Bidirectional converter for @sum types@. For example, given the data +type: + +@ +__data__ Example + = Foo Int + | Bar Bool Int +@ + +the TOML codec will look like + +@ +matchFoo :: Example -> Maybe Int +matchFoo (Foo num) = Just num +matchFoo _ = Nothing + +matchBar :: Example -> Maybe (Bool, Int) +matchBar (Bar b num) = Just (b, num) +matchBar _ = Nothing + +barCodec :: TomlCodec (Bool, Int) +barCodec = (,) + \<$\> Toml.bool "a" '.=' fst + \<*\> Toml.int "b" '.=' snd + +exampleCodec :: TomlCodec Example +exampleCodec = + dimatch matchFoo Foo (Toml.int "foo") + \<|\> dimatch matchBar (uncurry Bar) (Toml.table barCodec "bar") +@ + +@since 1.2.0.0 +-} +dimatch + :: (Functor r, Alternative w) + => (c -> Maybe d) -- ^ Mapper for consumer + -> (a -> b) -- ^ Mapper for producer + -> Codec r w d a -- ^ Source 'Codec' object + -> Codec r w c b -- ^ Target 'Codec' object +dimatch match ctor codec = Codec + { codecRead = ctor <$> codecRead codec + , codecWrite = \c -> case match c of + Nothing -> empty + Just d -> ctor <$> codecWrite codec d + } +{-# INLINE dimatch #-} + {- | Operator to connect two operations: 1. How to get field from object? @@ -229,3 +289,4 @@ infixl 5 .= (.=) :: Codec r w field a -> (object -> field) -> Codec r w object a codec .= getter = codec { codecWrite = codecWrite codec . getter } +{-# INLINE (.=) #-} diff --git a/src/Toml/Edsl.hs b/src/Toml/Edsl.hs --- a/src/Toml/Edsl.hs +++ b/src/Toml/Edsl.hs @@ -58,19 +58,24 @@ -- | Creates 'TOML' from the 'TDSL'. mkToml :: TDSL -> TOML mkToml env = execState env mempty +{-# INLINE mkToml #-} -- | Creates an empty 'TDSL'. empty :: TDSL empty = put mempty +{-# INLINE empty #-} -- | Adds key-value pair to the 'TDSL'. (=:) :: Key -> Value a -> TDSL (=:) k v = modify $ insertKeyVal k v +{-# INLINE (=:) #-} -- | Adds table to the 'TDSL'. table :: Key -> TDSL -> TDSL table k = modify . insertTable k . mkToml +{-# INLINE table #-} -- | Adds array of tables to the 'TDSL'. tableArray :: Key -> NonEmpty TDSL -> TDSL tableArray k = modify . insertTableArrays k . fmap mkToml +{-# INLINE tableArray #-} diff --git a/src/Toml/Generic.hs b/src/Toml/Generic.hs --- a/src/Toml/Generic.hs +++ b/src/Toml/Generic.hs @@ -116,16 +116,19 @@ ) where import Data.Char (isLower, toLower) +import Data.Hashable (Hashable) +import Data.HashSet (HashSet) import Data.IntSet (IntSet) import Data.Kind (Type) import Data.List (stripPrefix) import Data.List.NonEmpty (NonEmpty) import Data.Proxy (Proxy (..)) +import Data.Set (Set) import Data.String (IsString (..)) import Data.Text (Text) import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime) import Data.Typeable (Typeable, typeRep) -import Data.Word (Word) +import Data.Word (Word8) import GHC.Generics ((:*:) (..), (:+:), C1, D1, Generic (..), K1 (..), M1 (..), Rec0, S1, Selector (..)) import GHC.TypeLits (ErrorMessage (..), TypeError) @@ -230,6 +233,8 @@ -- Generic typeclasses ---------------------------------------------------------------------------- +{- | Helper class to derive TOML codecs generically. +-} class GenericCodec (f :: k -> Type) where genericTomlCodec :: GenericOptions -> TomlCodec (f p) @@ -288,6 +293,8 @@ instance HasItemCodec Bool where hasItemCodec = Left Toml._Bool instance HasItemCodec Int where hasItemCodec = Left Toml._Int instance HasItemCodec Word where hasItemCodec = Left Toml._Word +-- | @since 1.2.0.0 +instance HasItemCodec Word8 where hasItemCodec = Left Toml._Word8 instance HasItemCodec Integer where hasItemCodec = Left Toml._Integer instance HasItemCodec Natural where hasItemCodec = Left Toml._Natural instance HasItemCodec Double where hasItemCodec = Left Toml._Double @@ -322,6 +329,8 @@ instance HasCodec Bool where hasCodec = Toml.bool instance HasCodec Int where hasCodec = Toml.int instance HasCodec Word where hasCodec = Toml.word +-- | @since 1.2.0.0 +instance HasCodec Word8 where hasCodec = Toml.word8 instance HasCodec Integer where hasCodec = Toml.integer instance HasCodec Natural where hasCodec = Toml.natural instance HasCodec Double where hasCodec = Toml.double @@ -346,6 +355,18 @@ hasCodec = case hasItemCodec @a of Left prim -> Toml.arrayNonEmptyOf prim Right codec -> Toml.nonEmpty codec + +-- | @since 1.2.0.0 +instance (Ord a, HasItemCodec a) => HasCodec (Set a) where + hasCodec = case hasItemCodec @a of + Left prim -> Toml.arraySetOf prim + Right codec -> Toml.set codec + +-- | @since 1.2.0.0 +instance (Hashable a, Eq a, HasItemCodec a) => HasCodec (HashSet a) where + hasCodec = case hasItemCodec @a of + Left prim -> Toml.arrayHashSetOf prim + Right codec -> Toml.hashSet codec {- TODO: uncomment when higher-kinded roles will be implemented diff --git a/src/Toml/Parser.hs b/src/Toml/Parser.hs --- a/src/Toml/Parser.hs +++ b/src/Toml/Parser.hs @@ -8,18 +8,22 @@ ) where import Control.DeepSeq (NFData) -import Data.Text (Text, pack) +import Data.Text (Text) import GHC.Generics (Generic) -import Toml.Parser.TOML (tomlP) +import Toml.Parser.Item (tomlP) +import Toml.Parser.Validate (validateItems) import Toml.Type (TOML) +import qualified Data.Text as T import qualified Toml.Parser.Core as P (errorBundlePretty, parse) -- | Pretty parse exception for parsing toml. -newtype ParseException = ParseException Text - deriving (Show, Eq, Generic, NFData) +newtype ParseException = ParseException + { unParseException :: Text + } deriving stock (Show, Generic) + deriving newtype (Eq, NFData) {- | Parses 'Text' as 'TOML' AST object. If you want to convert 'Text' to your custom haskell data type, use 'Toml.Bi.Code.decode' or 'Toml.Bi.Code.decodeFile' @@ -27,5 +31,7 @@ -} parse :: Text -> Either ParseException TOML parse t = case P.parse tomlP "" t of - Left err -> Left $ ParseException $ pack $ P.errorBundlePretty err - Right toml -> Right toml + Left err -> Left $ ParseException $ T.pack $ P.errorBundlePretty err + Right items -> case validateItems items of + Left err -> Left $ ParseException $ T.pack $ show err + Right toml -> Right toml diff --git a/src/Toml/Parser/Item.hs b/src/Toml/Parser/Item.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Parser/Item.hs @@ -0,0 +1,104 @@ +{-| This module contains the definition of the 'TomlItem' data type which +represents either key-value pair or table name. This data type serves the +purpose to be the intermediate representation of parsing a TOML file which will +be assembled to TOML AST later. + +@since 1.2.0.0 +-} + +module Toml.Parser.Item + ( TomlItem (..) + , Table (..) + , setTableName + + , tomlP + ) where + +import Control.Applicative (liftA2, many) +import Control.Applicative.Combinators.NonEmpty (sepEndBy1) +import Control.Monad.Combinators (between, sepEndBy) +import Data.Foldable (asum) +import Data.List.NonEmpty (NonEmpty) + +import Toml.Parser.Core (Parser, eof, sc, text, try, ()) +import Toml.Parser.Key (keyP, tableArrayNameP, tableNameP) +import Toml.Parser.Value (anyValueP) +import Toml.PrefixTree (Key) +import Toml.Type (AnyValue) + + +{- | One item of a TOML file. It could be either: + +* A name of a table +* A name of a table array +* Key-value pair +* Inline table +* Inline array of tables + +Knowing a list of 'TomlItem's, it's possible to construct 'Toml.Type.TOML.TOML' +from this information. +-} +data TomlItem + = TableName !Key + | TableArrayName !Key + | KeyVal !Key !AnyValue + | InlineTable !Key !Table + | InlineTableArray !Key !(NonEmpty Table) + deriving stock (Show, Eq) + +{- | Changes name of table to a new one. Works only for 'TableName' and +'TableArrayName' constructors. +-} +setTableName :: Key -> TomlItem -> TomlItem +setTableName new = \case + TableName _ -> TableName new + TableArrayName _ -> TableArrayName new + item -> item + +{- | Table that contains only @key = val@ pairs. +-} +newtype Table = Table + { unTable :: [(Key, AnyValue)] + } deriving stock (Show) + deriving newtype (Eq) + +---------------------------------------------------------------------------- +-- Parser +---------------------------------------------------------------------------- + +-- | Parser for inline tables. +inlineTableP :: Parser Table +inlineTableP = + fmap Table + $ between (text "{") (text "}") + $ (liftA2 (,) (keyP <* text "=") anyValueP) `sepEndBy` text "," + +-- | Parser for inline arrays of tables. +inlineTableArrayP :: Parser (NonEmpty Table) +inlineTableArrayP = between (text "[") (text "]") + $ inlineTableP `sepEndBy1` text "," + +-- | Parser for a single item in the TOML file. +tomlItemP :: Parser TomlItem +tomlItemP = asum + [ TableName <$> try tableNameP "table name" + , TableArrayName <$> tableArrayNameP "array of tables name" + , keyValP + ] + where + -- parser for "key = val" pairs; can be one of three forms: + -- 1. key = { ... } + -- 2. key = [ {...}, {...}, ... ] + -- 3. key = ... + keyValP :: Parser TomlItem + keyValP = do + key <- keyP <* text "=" + asum + [ InlineTable key <$> inlineTableP "inline table" + , InlineTableArray key <$> try inlineTableArrayP "inline array of tables" + , KeyVal key <$> anyValueP "key-value pair" + ] + +-- | Parser for the full content of the .toml file. +tomlP :: Parser [TomlItem] +tomlP = sc *> many tomlItemP <* eof diff --git a/src/Toml/Parser/Key.hs b/src/Toml/Parser/Key.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Parser/Key.hs @@ -0,0 +1,51 @@ +{- | Parsers for keys and table names. + +@since 1.2.0.0 +-} + +module Toml.Parser.Key + ( keyP + , tableNameP + , tableArrayNameP + ) where + +import Control.Applicative (Alternative (..)) +import Control.Applicative.Combinators.NonEmpty (sepBy1) +import Control.Monad.Combinators (between) +import Data.Semigroup ((<>)) +import Data.Text (Text) + +import Toml.Parser.Core (Parser, alphaNumChar, char, lexeme, text) +import Toml.Parser.String (basicStringP, literalStringP) +import Toml.PrefixTree (Key (..), Piece (..)) + +import qualified Data.Text as Text + + +-- | Parser for bare key piece, like @foo@. +bareKeyPieceP :: Parser Text +bareKeyPieceP = lexeme $ Text.pack <$> bareStrP + where + bareStrP :: Parser String + bareStrP = some $ alphaNumChar <|> char '_' <|> char '-' + +-- | Parser for 'Piece'. +keyComponentP :: Parser Piece +keyComponentP = Piece <$> + (bareKeyPieceP <|> (quote "\"" <$> basicStringP) <|> (quote "'" <$> literalStringP)) + where + -- adds " or ' to both sides + quote :: Text -> Text -> Text + quote q t = q <> t <> q + +-- | Parser for 'Key': dot-separated list of 'Piece'. +keyP :: Parser Key +keyP = Key <$> keyComponentP `sepBy1` char '.' + +-- | Parser for table name: 'Key' inside @[]@. +tableNameP :: Parser Key +tableNameP = between (text "[") (text "]") keyP + +-- | Parser for array of tables name: 'Key' inside @[[]]@. +tableArrayNameP :: Parser Key +tableArrayNameP = between (text "[[") (text "]]") keyP diff --git a/src/Toml/Parser/TOML.hs b/src/Toml/Parser/TOML.hs deleted file mode 100644 --- a/src/Toml/Parser/TOML.hs +++ /dev/null @@ -1,134 +0,0 @@ -{- | Parser for 'TOML' data type: keys, tables, array of tables. Uses value -parsers from "Toml.Parser.Value". --} - -module Toml.Parser.TOML - ( keyP - , tomlP - ) where - -import Control.Applicative (Alternative (..)) -import Control.Monad.Combinators (between, sepEndBy) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Semigroup ((<>)) -import Data.Text (Text) - -import Toml.Parser.Core (Parser, alphaNumChar, char, eof, lexeme, sc, text, try) -import Toml.Parser.String (basicStringP, literalStringP) -import Toml.Parser.Value (anyValueP) -import Toml.PrefixTree (Key (..), KeysDiff (..), Piece (..), keysDiff, single) -import Toml.Type (AnyValue, TOML (..)) - -import qualified Control.Applicative.Combinators.NonEmpty as NC -import qualified Data.HashMap.Lazy as HashMap -import qualified Data.Text as Text - - --- | Parser for bare key piece, like @foo@. -bareKeyPieceP :: Parser Text -bareKeyPieceP = lexeme $ Text.pack <$> bareStrP - where - bareStrP :: Parser String - bareStrP = some $ alphaNumChar <|> char '_' <|> char '-' - --- | Parser for 'Piece'. -keyComponentP :: Parser Piece -keyComponentP = Piece <$> - (bareKeyPieceP <|> (quote "\"" <$> basicStringP) <|> (quote "'" <$> literalStringP)) - where - -- adds " or ' to both sides - quote :: Text -> Text -> Text - quote q t = q <> t <> q - --- | Parser for 'Key': dot-separated list of 'Piece'. -keyP :: Parser Key -keyP = Key <$> keyComponentP `NC.sepBy1` char '.' - --- | Parser for table name: 'Key' inside @[]@. -tableNameP :: Parser Key -tableNameP = between (text "[") (text "]") keyP - --- | Parser for array of tables name: 'Key' inside @[[]]@. -tableArrayNameP :: Parser Key -tableArrayNameP = between (text "[[") (text "]]") keyP - --- Helper functions for building TOML -tomlKV :: Key -> AnyValue -> TOML -tomlKV k v = mempty { tomlPairs = HashMap.singleton k v } - -tomlT :: Key -> TOML -> TOML -tomlT k t = mempty { tomlTables = single k t } - -tomlA :: Key -> NonEmpty TOML -> TOML -tomlA k a = mempty { tomlTableArrays = HashMap.singleton k a } - --- | Parser for lines starting with 'key =', either values, inline tables or --- inline arrays of tables. -hasKeyP :: Maybe Key -> Parser TOML -hasKeyP key = do - k <- keyP <* text "=" - table k <|> try (tableArray k) <|> (tomlKV k <$> anyValueP) - where - table :: Key -> Parser TOML - table k = do - (kDiff, _) <- childKeyP key (pure k) - tomlT kDiff <$> inlineTableP - - tableArray :: Key -> Parser TOML - tableArray k = do - (kDiff, _) <- childKeyP key (pure k) - tomlA kDiff <$> inlineTableArrayP - --- | Parser for inline tables. -inlineTableP :: Parser TOML -inlineTableP = between (text "{") (text "}") $ - mconcat <$> - (tomlKV <$> (keyP <* text "=") <*> anyValueP ) `sepEndBy` text "," - --- | Parser for inline arrays of tables. -inlineTableArrayP :: Parser (NonEmpty TOML) -inlineTableArrayP = between (text "[") (text "]") $ - inlineTableP `NC.sepEndBy1` text "," - --- | Parser for an array of tables under a certain key. -tableArrayP :: Key -> Parser (NonEmpty TOML) -tableArrayP key = - localTomlP (Just key) `NC.sepBy1` sameKeyP key tableArrayNameP - --- | Parser for a '.toml' file -tomlP :: Parser TOML -tomlP = sc *> localTomlP Nothing <* eof - --- | Parser for a toml under a certain key -localTomlP :: Maybe Key -> Parser TOML -localTomlP key = mconcat <$> many (subArray <|> subTable <|> (try $ hasKeyP key)) - where - subTable :: Parser TOML - subTable = do - (kDiff, k) <- try $ childKeyP key tableNameP - tomlT kDiff <$> localTomlP (Just k) - - subArray :: Parser TOML - subArray = do - (kDiff, k) <- try $ childKeyP key tableArrayNameP - tomlA kDiff <$> tableArrayP k - --- | @childKeyP (Just key) p@ checks if the result of @p@ if a child key of --- @key@ and returns the difference of the keys and the child key. --- @childKeyP Nothing p@ is only called from @tomlP@ (no parent key). -childKeyP :: Maybe Key -> Parser Key -> Parser (Key, Key) -childKeyP Nothing parser = (\k -> (k, k)) <$> parser -childKeyP (Just key) parser = do - k <- parser - case keysDiff key k of - FstIsPref d -> pure (d, k) - _ -> fail $ show k ++ " is not a child key of " ++ show key - --- | @sameKeyP key p@ returns the result of @p@ if the key returned by @p@ is --- the same as @key@, and fails otherwise. -sameKeyP :: Key -> Parser Key -> Parser Key -sameKeyP key parser = try $ do - k <- parser - case keysDiff key k of - Equal -> pure k - _ -> fail $ show k ++ " is not the same as " ++ show key diff --git a/src/Toml/Parser/Validate.hs b/src/Toml/Parser/Validate.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Parser/Validate.hs @@ -0,0 +1,181 @@ +{- | This module contains functions that aggregate the result of +'Toml.Parser.Item.tomlP' parser into 'TOML'. This approach allows to keep parser +fast and simple and delegate the process of creating tree structure to a +separate function. + +@since 1.2.0.0 +-} + +module Toml.Parser.Validate + ( -- * Decoding + validateItems + , ValidationError (..) + + -- * Internal helpers + , groupItems + , groupWithParent + , validateItemForest + ) where + +import Data.Bifunctor (first) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Semigroup ((<>)) +import Data.Tree (Forest, Tree (..)) + +import Toml.Parser.Item (Table (..), TomlItem (..), setTableName) +import Toml.PrefixTree (Key, KeysDiff (FstIsPref), keysDiff) +import Toml.Type (TOML (..), insertKeyAnyVal, insertTable, insertTableArrays) + +import qualified Data.HashMap.Strict as HashMap +import qualified Toml.PrefixTree as PrefixMap + + +{- | Validate list of 'TomlItem's and convert to 'TOML' if not validation +errors are found. +-} +validateItems :: [TomlItem] -> Either ValidationError TOML +validateItems = validateItemForest . groupItems + +---------------------------------------------------------------------------- +-- Grouping +---------------------------------------------------------------------------- + +{- | This function takes flat list of 'TomlItem's and groups it into list of +'Tree's by putting all corresponding items inside tables and table arrays. It +doesn't perform any validation, just groups items according to prefixes of their +keys. So, for example, if you have the following keys as flat list: + +@ +aaa # ordinary key +aaa.bbb # ordinary key +[foo] # table nam +foo.bar +foo.baz +[xxx] # table name +[xxx.yyy] # table name +zzz +@ + +the following tree structure will be created: + +@ +aaa +aaa.bbb +[foo] +├──── foo.bar +└──── foo.baz +[xxx] +└──── [yyy] + └──── zzz +@ +-} +groupItems :: [TomlItem] -> Forest TomlItem +groupItems = fst . groupWithParent Nothing + +{- | This function groups list of TOML items into 'Forest' and returns list of +items that are not children of specified parent. + +__Invariant:__ When this function is called with 'Nothing', second element in +the result tuple should be empty list. +-} +groupWithParent + :: Maybe Key -- ^ Parent name + -> [TomlItem] -- ^ List of items + -> (Forest TomlItem, [TomlItem]) -- ^ Forest of times and remaining items +groupWithParent _ [] = ([], []) +groupWithParent parent (item:items) = case item of + KeyVal{} -> Node item [] <:> groupWithParent parent items + InlineTable{} -> Node item [] <:> groupWithParent parent items + InlineTableArray{} -> Node item [] <:> groupWithParent parent items + TableName name -> groupTable item name + TableArrayName name -> groupTable item name + where + -- prepend to the first list, just to remove some code noise + (<:>) :: a -> ([a], b) -> ([a], b) + a <:> tup = first (a :) tup + + -- takes table item and its name, collects all children into table subforest + -- and returns all elements after the table + groupTable :: TomlItem -> Key -> (Forest TomlItem, [TomlItem]) + groupTable tableItem tableName = case parent of + Nothing -> tableWithChildren tableName + Just parentKey -> case keysDiff parentKey tableName of + FstIsPref diff -> tableWithChildren diff + _ -> ([], item:items) + where + tableWithChildren :: Key -> (Forest TomlItem, [TomlItem]) + tableWithChildren newName = + let (children, rest) = groupWithParent (Just tableName) items + newItem = setTableName newName tableItem + in Node newItem children <:> groupWithParent parent rest + +---------------------------------------------------------------------------- +-- Decoding +---------------------------------------------------------------------------- + +{- | Error that happens during validating TOML which is already syntactically +correct. For the list of all possible validation errors and their explanation, +see the following issue on GitHub: + +* https://github.com/kowainik/tomland/issues/5 +-} + +data ValidationError + = DuplicateKey !Key + | DuplicateTable !Key + | SameNameKeyTable !Key + | SameNameTableArray !Key + deriving stock (Show, Eq) + +{- | Construct 'TOML' from the 'Forest' of 'TomlItem' and performing validation +of TOML at the same time. +-} +validateItemForest :: Forest TomlItem -> Either ValidationError TOML +validateItemForest = go mempty + where + go :: TOML -> Forest TomlItem -> Either ValidationError TOML + go toml [] = Right toml + go toml@TOML{..} (node:nodes) = case rootLabel node of + -- ignore subforest here + KeyVal key val -> do + HashMap.lookup key tomlPairs `errorOnJust` DuplicateKey key + PrefixMap.lookup key tomlTables `errorOnJust` SameNameKeyTable key + go (insertKeyAnyVal key val toml) nodes + + -- ignore subforest here + InlineTable key table -> do + HashMap.lookup key tomlPairs `errorOnJust` SameNameKeyTable key + PrefixMap.lookup key tomlTables `errorOnJust` DuplicateTable key + tableToml <- createTomlFromTable table + go (insertTable key tableToml toml) nodes + + -- ignore subforest here + InlineTableArray key tables -> do + PrefixMap.lookup key tomlTables `errorOnJust` SameNameTableArray key + arrayToml <- mapM createTomlFromTable tables + go (insertTableArrays key arrayToml toml) nodes + + TableName key -> do + HashMap.lookup key tomlPairs `errorOnJust` SameNameKeyTable key + PrefixMap.lookup key tomlTables `errorOnJust` DuplicateTable key + subTable <- go mempty (subForest node) + go (insertTable key subTable toml) nodes + + TableArrayName key -> do + PrefixMap.lookup key tomlTables `errorOnJust` SameNameTableArray key + subTable <- go mempty (subForest node) + let newArray = case HashMap.lookup key tomlTableArrays of + Nothing -> HashMap.insert key (subTable :| []) tomlTableArrays + Just arr -> + HashMap.insert key (arr <> (subTable :| [])) tomlTableArrays + go (toml { tomlTableArrays = newArray }) nodes + + createTomlFromTable :: Table -> Either ValidationError TOML + createTomlFromTable (Table table) = + go mempty $ map (\(k, v) -> Node (KeyVal k v) []) table + + + +errorOnJust :: Maybe a -> e -> Either e () +errorOnJust (Just _) e = Left e +errorOnJust Nothing _ = Right () diff --git a/src/Toml/PrefixTree.hs b/src/Toml/PrefixTree.hs --- a/src/Toml/PrefixTree.hs +++ b/src/Toml/PrefixTree.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE PatternSynonyms #-} -- | Implementation of prefix tree for TOML AST. @@ -53,9 +51,10 @@ -- | Represents the key piece of some layer. -newtype Piece = Piece { unPiece :: Text } - deriving stock (Generic) - deriving newtype (Show, Eq, Ord, Hashable, IsString, NFData) +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 @@ -70,9 +69,10 @@ Key (Piece "site" :| [Piece "\\"google.com\\""]) @ -} -newtype Key = Key { unKey :: NonEmpty Piece } - deriving stock (Generic) - deriving newtype (Show, Eq, Ord, Hashable, NFData, Semigroup) +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'. @@ -113,7 +113,8 @@ !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) + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) instance Semigroup (PrefixTree a) where a <> b = foldl' (\tree (k, v) -> insertT k v tree) a (toListT b) @@ -130,7 +131,7 @@ !Key -- ^ Common prefix. !Key -- ^ Rest of the first key. !Key -- ^ Rest of the second key. - deriving (Show, Eq) + deriving stock (Show, Eq) -- | Compares two keys keysDiff :: Key -> Key -> KeysDiff @@ -150,10 +151,12 @@ -- | Prepends 'Piece' to the beginning of the 'Key'. (<|) :: Piece -> Key -> Key (<|) p k = Key (p NonEmpty.<| unKey k) +{-# INLINE (<|) #-} -- | Creates a 'PrefixTree' of one key-value element. singleT :: Key -> a -> PrefixTree a singleT = Leaf +{-# INLINE singleT #-} -- | Creates a 'PrefixMap' of one key-value element. single :: Key -> a -> PrefixMap a diff --git a/src/Toml/Printer.hs b/src/Toml/Printer.hs --- a/src/Toml/Printer.hs +++ b/src/Toml/Printer.hs @@ -13,7 +13,7 @@ import Data.Bifunctor (first) import Data.Function (on) import Data.HashMap.Strict (HashMap) -import Data.List (sortBy, splitAt) +import Data.List (sortBy) import Data.List.NonEmpty (NonEmpty) import Data.Monoid ((<>)) import Data.Text (Text) @@ -25,6 +25,7 @@ import qualified Data.HashMap.Strict as HashMap import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Text as Text + {- | Configures the pretty printer. -} data PrintOptions = PrintOptions diff --git a/src/Toml/Type/AnyValue.hs b/src/Toml/Type/AnyValue.hs --- a/src/Toml/Type/AnyValue.hs +++ b/src/Toml/Type/AnyValue.hs @@ -52,9 +52,10 @@ -- | Value type mismatch error. data MatchError = MatchError - { valueExpected :: TValue - , valueActual :: AnyValue - } deriving (Eq, Show, Generic, NFData) + { valueExpected :: !TValue + , valueActual :: !AnyValue + } deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) -- | Helper function to create 'MatchError'. mkMatchError :: TValue -> Value t -> Either MatchError a @@ -68,46 +69,55 @@ matchBool :: Value t -> Either MatchError Bool matchBool (Bool b) = Right b matchBool value = mkMatchError TBool value +{-# INLINE matchBool #-} -- | Extract 'Prelude.Integer' from 'Value'. matchInteger :: Value t -> Either MatchError Integer matchInteger (Integer n) = Right n matchInteger value = mkMatchError TInteger value +{-# INLINE matchInteger #-} -- | Extract 'Prelude.Double' from 'Value'. matchDouble :: Value t -> Either MatchError Double matchDouble (Double f) = Right f matchDouble value = mkMatchError TDouble value +{-# INLINE matchDouble #-} -- | Extract 'Data.Text.Text' from 'Value'. matchText :: Value t -> Either MatchError Text matchText (Text s) = Right s matchText value = mkMatchError TText value +{-# INLINE matchText #-} -- | Extract 'Data.Time.ZonedTime' from 'Value'. matchZoned :: Value t -> Either MatchError ZonedTime matchZoned (Zoned d) = Right d matchZoned value = mkMatchError TZoned value +{-# INLINE matchZoned #-} -- | Extract 'Data.Time.LocalTime' from 'Value'. matchLocal :: Value t -> Either MatchError LocalTime matchLocal (Local d) = Right d matchLocal value = mkMatchError TLocal value +{-# INLINE matchLocal #-} -- | Extract 'Data.Time.Day' from 'Value'. matchDay :: Value t -> Either MatchError Day matchDay (Day d) = Right d matchDay value = mkMatchError TDay value +{-# INLINE matchDay #-} -- | Extract 'Data.Time.TimeOfDay' from 'Value'. matchHours :: Value t -> Either MatchError TimeOfDay matchHours (Hours d) = Right d matchHours value = mkMatchError THours value +{-# INLINE matchHours #-} -- | Extract list of elements of type @a@ from array. matchArray :: (AnyValue -> Either MatchError a) -> Value t -> Either MatchError [a] matchArray matchValue (Array a) = mapM (applyAsToAny matchValue) a matchArray _ value = mkMatchError TArray value +{-# INLINE matchArray #-} -- | Make function that works with 'AnyValue' also work with specific 'Value'. applyAsToAny :: (AnyValue -> r) -> (Value t -> r) diff --git a/src/Toml/Type/TOML.hs b/src/Toml/Type/TOML.hs --- a/src/Toml/Type/TOML.hs +++ b/src/Toml/Type/TOML.hs @@ -86,37 +86,49 @@ @ -} data TOML = TOML - { tomlPairs :: HashMap Key AnyValue - , tomlTables :: PrefixMap TOML - , tomlTableArrays :: HashMap Key (NonEmpty TOML) - } deriving (Show, Eq, NFData, Generic) + { tomlPairs :: !(HashMap Key AnyValue) + , tomlTables :: !(PrefixMap TOML) + , tomlTableArrays :: !(HashMap Key (NonEmpty TOML)) + } deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) instance Semigroup TOML where - (TOML pairsA tablesA arraysA) <> (TOML pairsB tablesB arraysB) = TOML + (<>) :: TOML -> TOML -> TOML + TOML pairsA tablesA arraysA <> TOML pairsB tablesB arraysB = TOML (pairsA <> pairsB) (HashMap.unionWith (<>) tablesA tablesB) (arraysA <> arraysB) + {-# INLINE (<>) #-} instance Monoid TOML where - mappend = (<>) + mempty :: TOML mempty = TOML mempty mempty mempty + {-# INLINE mempty #-} + mappend :: TOML -> TOML -> TOML + mappend = (<>) + {-# INLINE mappend #-} + -- | Inserts given key-value into the 'TOML'. insertKeyVal :: Key -> Value a -> TOML -> TOML insertKeyVal k v = insertKeyAnyVal k (AnyValue v) +{-# INLINE insertKeyVal #-} -- | Inserts given key-value into the 'TOML'. insertKeyAnyVal :: Key -> AnyValue -> TOML -> TOML -insertKeyAnyVal k av toml =toml { tomlPairs = HashMap.insert k av (tomlPairs toml) } +insertKeyAnyVal k av toml = toml { tomlPairs = HashMap.insert k av (tomlPairs toml) } +{-# INLINE insertKeyAnyVal #-} -- | Inserts given table into the 'TOML'. insertTable :: Key -> TOML -> TOML -> TOML insertTable k inToml toml = toml { tomlTables = Prefix.insert k inToml (tomlTables toml) } +{-# INLINE insertTable #-} -- | Inserts given array of tables into the 'TOML'. insertTableArrays :: Key -> NonEmpty TOML -> TOML -> TOML insertTableArrays k arr toml = toml { tomlTableArrays = HashMap.insert k arr (tomlTableArrays toml) } +{-# INLINE insertTableArrays #-} diff --git a/src/Toml/Type/UValue.hs b/src/Toml/Type/UValue.hs --- a/src/Toml/Type/UValue.hs +++ b/src/Toml/Type/UValue.hs @@ -14,6 +14,7 @@ import Toml.Type.AnyValue (AnyValue (..)) import Toml.Type.Value (TypeMismatchError, Value (..), sameValue) + -- | Untyped value of @TOML@. You shouldn't use this type in your code. Use -- 'Value' instead. data UValue @@ -26,7 +27,7 @@ | UDay !Day | UHours !TimeOfDay | UArray ![UValue] - deriving (Show) + deriving stock (Show) instance Eq UValue where (UBool b1) == (UBool b2) = b1 == b2 diff --git a/src/Toml/Type/Value.hs b/src/Toml/Type/Value.hs --- a/src/Toml/Type/Value.hs +++ b/src/Toml/Type/Value.hs @@ -30,9 +30,20 @@ import Data.Type.Equality ((:~:) (..)) import GHC.Generics (Generic) + -- | Needed for GADT parameterization -data TValue = TBool | TInteger | TDouble | TText | TZoned | TLocal | TDay | THours | TArray - deriving (Eq, Show, Read, NFData, Generic) +data TValue + = TBool + | TInteger + | TDouble + | TText + | TZoned + | TLocal + | TDay + | THours + | TArray + deriving stock (Eq, Show, Read, Generic) + deriving anyclass (NFData) -- | Convert 'TValue' constructors to 'String' without @T@ prefix. showType :: TValue -> String @@ -167,7 +178,7 @@ -} Array :: [Value t] -> Value 'TArray -deriving instance Show (Value t) +deriving stock instance Show (Value t) instance NFData (Value t) where rnf (Bool n) = rnf n @@ -190,6 +201,7 @@ instance (t ~ 'TText) => IsString (Value t) where fromString = Text . fromString @Text + {-# INLINE fromString #-} instance Eq (Value t) where (Bool b1) == (Bool b2) = b1 == b2 @@ -231,9 +243,9 @@ -- | Data type that holds expected vs. actual type. data TypeMismatchError = TypeMismatchError - { typeExpected :: TValue - , typeActual :: TValue - } deriving (Eq) + { typeExpected :: !TValue + , typeActual :: !TValue + } deriving stock (Eq) instance Show TypeMismatchError where show TypeMismatchError{..} = "Expected type '" ++ showType typeExpected diff --git a/test/Test/Toml/BiCode/Property.hs b/test/Test/Toml/BiCode/Property.hs --- a/test/Test/Toml/BiCode/Property.hs +++ b/test/Test/Toml/BiCode/Property.hs @@ -25,6 +25,7 @@ import qualified Hedgehog.Range as Range import qualified Toml + test_encodeDecodeProp :: PropertyTest test_encodeDecodeProp = prop "decode . encode == id" $ do bigType <- forAll genBigType @@ -55,11 +56,12 @@ , btNewtype :: !BigTypeNewtype , btSum :: !BigTypeSum , btRecord :: !BigTypeRecord - } deriving (Show, Eq) + } deriving stock (Show, Eq) -- | Wrapper over 'Double' and 'Float' to be equal on @NaN@ values. -newtype Batman a = Batman a - deriving (Show) +newtype Batman a = Batman + { unBatman :: a + } deriving stock (Show) instance RealFloat a => Eq (Batman a) where Batman a == Batman b = @@ -67,19 +69,22 @@ then isNaN b else a == b -newtype BigTypeNewtype = BigTypeNewtype ZonedTime - deriving (Show) +newtype BigTypeNewtype = BigTypeNewtype + { unBigTypeNewtype :: ZonedTime + } deriving stock (Show) instance Eq BigTypeNewtype where (BigTypeNewtype a) == (BigTypeNewtype b) = zonedTimeToUTC a == zonedTimeToUTC b -data BigTypeSum = BigTypeSumA Integer | BigTypeSumB Text - deriving (Show, Eq) +data BigTypeSum + = BigTypeSumA !Integer + | BigTypeSumB !Text + deriving stock (Show, Eq) data BigTypeRecord = BigTypeRecord - { btrBoolSet :: Set Bool - , btrNewtypeList :: [BigTypeSum] - } deriving (Show, Eq) + { btrBoolSet :: !(Set Bool) + , btrNewtypeList :: ![BigTypeSum] + } deriving stock (Show, Eq) bigTypeCodec :: TomlCodec BigType bigTypeCodec = BigType diff --git a/test/Test/Toml/BiMap/Property.hs b/test/Test/Toml/BiMap/Property.hs --- a/test/Test/Toml/BiMap/Property.hs +++ b/test/Test/Toml/BiMap/Property.hs @@ -39,6 +39,7 @@ , prop "Natural" (testBiMap B._Natural G.genNatural) , prop "Int" (testBiMap B._Int G.genInt) , prop "Word" (testBiMap B._Word G.genWord) + , prop "Word8" (testBiMap B._Word8 G.genWord8) , prop "Double" testDouble , prop "Float" (testBiMap B._Float G.genFloat) , prop "Text" (testBiMap B._Text G.genText) @@ -47,6 +48,8 @@ , prop "Read (Integer)" (testBiMap B._Read G.genInteger) , prop "ByteString" (testBiMap B._ByteString G.genByteString) , prop "Lazy ByteString" (testBiMap B._LByteString G.genLByteString) + , prop "ByteStringArray" (testBiMap B._ByteStringArray G.genByteString) + , prop "Lazy ByteStringArray" (testBiMap B._LByteStringArray G.genLByteString) , prop "ZonedTime" (testBiMap B._ZonedTime G.genZoned) , prop "LocalTime" (testBiMap B._LocalTime G.genLocal) , prop "TimeOfDay" (testBiMap B._TimeOfDay G.genHours) diff --git a/test/Test/Toml/Gen.hs b/test/Test/Toml/Gen.hs --- a/test/Test/Toml/Gen.hs +++ b/test/Test/Toml/Gen.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -17,6 +18,7 @@ , genInteger , genDouble , genWord + , genWord8 , genNatural , genFloat @@ -61,6 +63,7 @@ import Data.Text (Text) import Data.Time (Day, LocalTime (..), TimeOfDay (..), ZonedTime (..), fromGregorian, minutesToTimeZone) +import Data.Word (Word8) import GHC.Exts (fromList) import GHC.Stack (HasCallStack) import Hedgehog (Gen, GenBase, MonadGen, PropertyT, Range, property) @@ -102,7 +105,7 @@ genVal = Gen.int (Range.constant 0 256) -- | Generates random value of 'AnyValue' type. -genAnyValue :: MonadGen m => m AnyValue +genAnyValue :: (MonadGen m, GenBase m ~ Identity) => m AnyValue genAnyValue = Gen.choice $ (AnyValue <$> genArray) : noneArrayList @@ -126,7 +129,7 @@ quotedWith c = wrapChar c <$> Gen.text (Range.constant 1 10) (Gen.filter (/= c) notControl) quoted :: m Text - quoted = Gen.choice [quotedWith '"', quotedWith '\''] + quoted = genNotEscape $ Gen.choice [quotedWith '"', quotedWith '\''] genKey :: (MonadGen m, GenBase m ~ Identity) => m Key genKey = Key <$> Gen.nonEmpty (Range.constant 1 10) genPiece @@ -234,6 +237,9 @@ genWord :: MonadGen m => m Word genWord = Gen.word Range.constantBounded +genWord8 :: MonadGen m => m Word8 +genWord8 = Gen.word8 Range.constantBounded + genNatural :: MonadGen m => m Natural genNatural = fromIntegral <$> genWord @@ -286,7 +292,7 @@ -- | Generates text from different symbols. genText :: MonadGen m => m Text -genText = fmap Text.concat $ Gen.list (Range.constant 0 256) $ Gen.choice +genText = genNotEscape $ fmap Text.concat $ Gen.list (Range.constant 0 256) $ Gen.choice [ Text.singleton <$> Gen.alphaNum , genEscapeSequence , genPunctuation @@ -332,7 +338,16 @@ Nested array of AnyValue: Array [Array [Text "ACyz38VcLz0hxwdFkHTU6PYK8h8CeaiEpI2xAaiZTKBQ3zC1W717cZY35lk8EAK6pPw3WvwIdNktxIV2LrvFSpU8ee6zkXvpvePitW9aspAeeOCF9Q9ry20y7skFZ2qShi7CSx8888zWIqyc8iBkoLNvq4fONLtuUqSw2SlNee4hDIwrnx5O4RuHW1dQfJcnC34h9S0DlIGYP08qq6QHxO4E0HE74cNmiViGm3xpDC8Ro5D8Y6p0FLSN1ELq9Lwm",Text "HhNv0LKICdlKxN"],Array [Integer 986479839551009895,Integer 8636972066308796678,Integer (-3464941350081979804),Integer (-6560688879547055621),Integer (-4749037439349044738)],Array []] -} -genArray :: MonadGen m => m (Value 'TArray) +genArray :: (MonadGen m, GenBase m ~ Identity) => m (Value 'TArray) genArray = Gen.recursive Gen.choice [Gen.choice $ map genArrayFrom noneArrayList] [Array <$> Gen.list (Range.constant 0 5) genArray] + +-- filters + +-- | Discards strings that end with \ +genNotEscape :: MonadGen m => m Text -> m Text +genNotEscape gen = gen >>= \t -> + if | Text.null t -> pure t + | Text.last t == '\\' -> Gen.discard + | otherwise -> pure t diff --git a/test/Test/Toml/Parsing/Unit.hs b/test/Test/Toml/Parsing/Unit.hs --- a/test/Test/Toml/Parsing/Unit.hs +++ b/test/Test/Toml/Parsing/Unit.hs @@ -12,8 +12,10 @@ import Text.Megaparsec (Parsec, ShowErrorComponent, Stream, parse) import Toml.Edsl (mkToml, table, tableArray, (=:)) +import Toml.Parser.Item (tomlP) +import Toml.Parser.Key (keyP) import Toml.Parser.String (textP) -import Toml.Parser.TOML (keyP, tomlP) +import Toml.Parser.Validate (validateItems) import Toml.Parser.Value (arrayP, boolP, dateTimeP, doubleP, integerP) import Toml.PrefixTree (Key (..), Piece (..), fromList) import Toml.Type (AnyValue (..), TOML (..), UValue (..), Value (..)) @@ -397,12 +399,21 @@ parseToml "table = {}" (tomlFromTable [(makeKey ["table"], mempty)]) it "can parse a table followed by an inline table" $ parseToml "[table1] \n key1 = \"some string\" \n table2 = {key2 = 123}" - (tomlFromTable [(makeKey ["table1"], tomlFromKeyVal [str]) - ,(makeKey ["table2"], tomlFromKeyVal [int])]) + (tomlFromTable + [ ( "table1" + , tomlFromKeyVal [str] + <> tomlFromTable [ ("table2", tomlFromKeyVal [int]) ] + ) + ] + ) it "can parse an empty table followed by an inline table" $ parseToml "[table1] \n table2 = {key2 = 123}" - (tomlFromTable [(makeKey ["table1"], mempty) - ,(makeKey ["table2"], tomlFromKeyVal [int])]) + (tomlFromTable + [ ( "table1" + , tomlFromTable [ ("table2", tomlFromKeyVal [int]) ] + ) + ] + ) it "allows the name of the table to be any valid TOML key" $ do parseToml "dog.\"tater.man\"={}" (tomlFromTable [(makeKey ["dog", dquote "tater.man"], mempty)]) @@ -481,8 +492,9 @@ -- Utilities ---------------------------------------------------------------------------- -parseX :: (ShowErrorComponent e, Stream s, Show a, Eq a) - => Parsec e s a -> s -> a -> Expectation +parseX + :: (ShowErrorComponent e, Stream s, Show a, Eq a) + => Parsec e s a -> s -> a -> Expectation parseX p given expected = parse p "" given `shouldParse` expected failOn :: Show a => Parsec e s a -> s -> Expectation @@ -490,23 +502,35 @@ parseArray :: Text -> [UValue] -> Expectation parseArray = parseX arrayP + parseBool :: Text -> Bool -> Expectation parseBool = parseX boolP + parseDateTime :: Text -> UValue -> Expectation parseDateTime = parseX dateTimeP + parseDouble :: Text -> Double -> Expectation parseDouble = parseX doubleP + parseInteger :: Text -> Integer -> Expectation parseInteger = parseX integerP + parseKey :: Text -> Key -> Expectation parseKey = parseX keyP + parseText :: Text -> Text -> Expectation parseText = parseX textP parseToml :: Text -> TOML -> Expectation -parseToml = parseX tomlP +parseToml test toml = parseX (validateItems <$> tomlP) test (Right toml) -arrayFailOn, boolFailOn, dateTimeFailOn, doubleFailOn, integerFailOn, textFailOn, tomlFailOn :: Text -> Expectation +arrayFailOn + , boolFailOn + , dateTimeFailOn + , doubleFailOn + , integerFailOn + , textFailOn + , tomlFailOn :: Text -> Expectation arrayFailOn = failOn arrayP boolFailOn = failOn boolP dateTimeFailOn = failOn dateTimeP diff --git a/tomland.cabal b/tomland.cabal --- a/tomland.cabal +++ b/tomland.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: tomland -version: 1.1.0.1 +version: 1.2.0.0 synopsis: Bidirectional TOML serialization description: Implementation of bidirectional TOML serialization. Simple codecs look like this: @@ -31,19 +31,20 @@ category: TOML, Text, Configuration build-type: Simple extra-doc-files: README.md - , CHANGELOG.md + CHANGELOG.md extra-source-files: test/golden/*.golden - , test/examples/*.toml + test/examples/*.toml tested-with: GHC == 8.2.2 - , GHC == 8.4.4 - , GHC == 8.6.5 + GHC == 8.4.4 + GHC == 8.6.5 + GHC == 8.8.1 source-repository head type: git location: https://github.com/kowainik/tomland.git common common-options - build-depends: base >= 4.10 && < 4.13 + build-depends: base >= 4.10 && < 4.14 ghc-options: -Wall -Wincomplete-uni-patterns @@ -54,9 +55,14 @@ -Wpartial-fields -fhide-source-paths -freverse-errors + if impl(ghc >= 8.8.1) + ghc-options: -Wmissing-deriving-strategies + -Werror=missing-deriving-strategies default-language: Haskell2010 default-extensions: DeriveGeneric + DerivingStrategies + GeneralizedNewtypeDeriving InstanceSigs LambdaCase OverloadedStrings @@ -78,9 +84,11 @@ Toml.Generic Toml.Parser Toml.Parser.Core + Toml.Parser.Item + Toml.Parser.Key Toml.Parser.String + Toml.Parser.Validate Toml.Parser.Value - Toml.Parser.TOML Toml.PrefixTree Toml.Printer Toml.Type @@ -92,10 +100,10 @@ build-depends: bytestring ^>= 0.10 , containers >= 0.5.7 && < 0.7 , deepseq ^>= 1.4 - , hashable ^>= 1.2 + , hashable >= 1.2 && < 1.4 , megaparsec ^>= 7.0.5 , mtl ^>= 2.2 - , parser-combinators ^>= 1.1.0 + , parser-combinators >= 1.1.0 && < 1.3 , text ^>= 1.2 , time >= 1.8 && < 1.10 , transformers ^>= 0.5 @@ -103,6 +111,9 @@ executable readme import: common-options + -- doesn't work on windows for unknown reasons + if os(windows) + buildable: False main-is: README.lhs build-depends: text , tomland @@ -112,8 +123,10 @@ executable play-tomland import: common-options - main-is: Playground.hs + main-is: Main.hs build-depends: tomland + , containers + , hashable , text , time , unordered-containers @@ -143,7 +156,7 @@ build-depends: bytestring ^>= 0.10 , containers >= 0.5.7 && < 0.7 , hashable - , hedgehog ^>= 1.0 + , hedgehog ^>= 1.0.1 , hspec-megaparsec ^>= 2.0.0 , megaparsec , tasty ^>= 1.2 @@ -157,31 +170,3 @@ , unordered-containers ghc-options: -threaded -rtsopts -with-rtsopts=-N - -benchmark tomland-benchmark - import: common-options - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: benchmark - - other-modules: Benchmark.Type - Benchmark.Htoml - Benchmark.HtomlMegaparsec - Benchmark.Tomland - Benchmark.TomlParser - - ghc-options: -threaded - -rtsopts - -with-rtsopts=-N - -O2 - - build-depends: aeson - , deepseq ^>= 1.4 - , gauge ^>= 0.2.4 - , htoml ^>= 1.0.0.3 - , htoml-megaparsec ^>= 2.1.0.3 - , parsec - , text - , time - , toml-parser ^>= 0.1.0.0 - , tomland