tomland 0.4.0 → 0.5.0
raw patch · 26 files changed
+1982/−984 lines, 26 filesdep +aesondep +bytestringdep +containersdep ~basedep ~hashabledep ~hedgehog
Dependencies added: aeson, bytestring, containers, deepseq, gauge, htoml, htoml-megaparsec, parsec, tasty-silver
Dependency ranges changed: base, hashable, hedgehog, megaparsec, mtl, tasty, tasty-hedgehog, tasty-hspec, text, time, transformers, unordered-containers
Files
- CHANGELOG.md +71/−25
- benchmark/Benchmark/Htoml.hs +43/−0
- benchmark/Benchmark/HtomlMegaparsec.hs +42/−0
- benchmark/Benchmark/Tomland.hs +40/−0
- benchmark/Benchmark/Type.hs +55/−0
- benchmark/Main.hs +36/−0
- examples/Playground.hs +13/−13
- src/Toml/Bi/Code.hs +28/−15
- src/Toml/Bi/Combinators.hs +121/−73
- src/Toml/Bi/Monad.hs +61/−54
- src/Toml/BiMap.hs +196/−44
- src/Toml/Edsl.hs +4/−4
- src/Toml/Parser.hs +10/−295
- src/Toml/Parser/Core.hs +43/−0
- src/Toml/Parser/TOML.hs +47/−0
- src/Toml/Parser/Value.hs +293/−0
- src/Toml/PrefixTree.hs +12/−9
- src/Toml/Printer.hs +87/−34
- src/Toml/Type/AnyValue.hs +16/−8
- src/Toml/Type/TOML.hs +5/−1
- src/Toml/Type/Value.hs +21/−2
- test/Test/Toml/Gen.hs +129/−17
- test/Test/Toml/Parsing/Property.hs +2/−2
- test/Test/Toml/Parsing/Unit.hs +479/−363
- test/Test/Toml/Printer/Golden.hs +44/−0
- tomland.cabal +84/−25
CHANGELOG.md view
@@ -1,35 +1,89 @@-Change log-==========+# Change log tomland uses [PVP Versioning][1]. The change log is available [on GitHub][2]. -0.4.0-=====+## 0.5.0 — Nov 12, 2018 +* [#81](https://github.com/kowainik/tomland/issues/81):+ **Breaking change:** Rename data types.++ _Migration guide:_ rename `Bijection` to `Codec`, `Bi` to `BiCodec` and+ `BiToml` to `TomlCodec`.+* [#82](https://github.com/kowainik/tomland/issues/82):+ **Breaking change:** Remove `maybeT`. Add `dioptional` instead.++ _Migration guide:_ replace `Toml.maybeT Toml.int "foo"` with `Toml.dioptional (Toml.int "foo")`.+* [#95](https://github.com/kowainik/tomland/issues/95):+ **Breaking change:** Swap fields in `BiMap`s for consistency with `lens` package.++ _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.+* [#130](https://github.com/kowainik/tomland/issues/130):+ Added combinators to `Toml.Bi.Combinators`.+* [#115](https://github.com/kowainik/tomland/issues/115):+ Added time combinators to `Toml.BiMap` and `Toml.Bi.Combinators`.+* [#99](https://github.com/kowainik/tomland/issues/99):+ Split `Toml.Parser` file into smaller files.+* [#22](https://github.com/kowainik/tomland/issues/22):+ Report proper type checking error during parsing.+* [#14](https://github.com/kowainik/tomland/issues/14):+ Add support for inline tables parsing.+* [#70](https://github.com/kowainik/tomland/issues/70):+ Add `_TextBy` and `_Read` combinators.+* [#11](https://github.com/kowainik/tomland/issues/11):+ Add `PrintOptions` (sorting, indentation) for pretty printer.+* [#17](https://github.com/kowainik/tomland/issues/17):+ Allow underscores in integers*.+* [#90](https://github.com/kowainik/tomland/issues/90):+ Migrate to megaparsec 7.0.+* [#85](https://github.com/kowainik/tomland/issues/85):+ Add `Date` generator for property-based tests.+* [#88](https://github.com/kowainik/tomland/issues/88):+ Add `Array` generator for property-based tests.+* [#86](https://github.com/kowainik/tomland/issues/86):+ Improve `String` generator for property-based tests.+* [#87](https://github.com/kowainik/tomland/issues/87):+ Improve `Double` generator for property-based tests.+* Add support for GHC 8.6.1.+ Add support for GHC 8.4.4.+ Drop support for GHC 8.0.2.+* [#109](https://github.com/kowainik/tomland/issues/109):+ Add function `decodeToml`.++## 0.4.0+ * [#54](https://github.com/kowainik/tomland/issues/54): Add support for sum types. Rename `Prism` to `BiMap`. Rename `bijectionMaker` to `match`. Add `string` codec. -0.3.1-=====+## 0.3.1+ * [#19](https://github.com/kowainik/tomland/issues/19): Add proper parsing of floating point numbers. * [#15](https://github.com/kowainik/tomland/issues/15):- Add parsing of multiline strings+ Add parsing of multiline strings. * [#40](https://github.com/kowainik/tomland/issues/40):- Support full-featured string parser+ Support full-featured string parser. * [#18](https://github.com/kowainik/tomland/issues/18): Add dates parsing. * Add useful combinators for `newtype` wrappers. * [#58](https://github.com/kowainik/tomland/issues/58): Add `decodeFile` function. -0.3-=====+## 0.3 +* [#60](https://github.com/kowainik/tomland/issues/60):+ **Breaking change:** Replace `Valuer` with `Prism`.++ _Migration guide:_ replace any `fooV` with corresponding prism `_Foo`.+* [#66](https://github.com/kowainik/tomland/issues/66):+ **Breaking change:** Introduce consistent names according to Haskell types.++ _Migration guide:_ see issue details to know which names to use. * [#8](https://github.com/kowainik/tomland/issues/8): Create EDSL for easier TOML data type writing. * [#10](https://github.com/kowainik/tomland/issues/10):@@ -42,31 +96,23 @@ Allow terminating commas inside an array. Allow comments before and after any value inside an array. Allow keys to be literal strings.-* **Breaking change:** [#60](https://github.com/kowainik/tomland/issues/60):- Replace `Valuer` with `Prism`. - _Migration guide:_ replace any `fooV` with corresponding prism `_Foo`.-* **Breaking change:** [#66](https://github.com/kowainik/tomland/issues/66):- Introduce consistent names according to Haskell types.-- _Migration guide:_ see issue details to know which names to use.+## 0.2.1 -0.2.1-===== * Make `table` parser work with `maybeP`. * [#39](https://github.com/kowainik/tomland/issues/39): Implement `prettyException` function for `DecodeException`. -0.2.0-=====+## 0.2.0+ * Switch names for `decode` and `encode` functions. * [#47](https://github.com/kowainik/tomland/issues/47): Rename `dimapBijection` to `dimap`. Introduce `mdimap` combinator. * [#37](https://github.com/kowainik/tomland/issues/37): Add tables support for bidirectional conversion. -0.1.0-=====+## 0.1.0+ * [#16](https://github.com/kowainik/tomland/issues/16): Add parser for literal strings. * Add `IsString` instance for `Key` data type.@@ -77,8 +123,8 @@ * [#44](https://github.com/kowainik/tomland/issues/44): Add bidirectional converter for `Maybe`. -0.0.0-=====+## 0.0.0+ * [#3](https://github.com/kowainik/tomland/issues/3): Implement basic TOML parser with `megaparsec`. * [#7](https://github.com/kowainik/tomland/issues/7):
+ benchmark/Benchmark/Htoml.hs view
@@ -0,0 +1,43 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE StandaloneDeriving #-}++module Benchmark.Htoml+ ( decode+ , convert+ , parse+ ) where++import Benchmark.Type (HaskellType)+import Control.DeepSeq (NFData, rnf, rwhnf)+import Data.Aeson.Types (parseEither, parseJSON)+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)+++-- | Decode toml file to Haskell type.+decode :: Text -> Either String HaskellType+decode txt = case parseTomlDoc "" txt of+ Left _ -> error "Parsing failed"+ Right toml -> convert toml++-- | 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++instance NFData ParseError where+ rnf = rwhnf
+ benchmark/Benchmark/HtomlMegaparsec.hs view
@@ -0,0 +1,42 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE PackageImports #-}++module Benchmark.HtomlMegaparsec+ ( convert+ , decode+ , parse+ ) where++import Data.Aeson.Types (ToJSON, parseEither, parseJSON, toJSON)+import Data.Text (Text)+import "htoml-megaparsec" Text.Toml (Node (..), Table, TomlError, parseTomlDoc)++import Benchmark.Type (HaskellType)+++-- | 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++-- | 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.+instance ToJSON Node where+ toJSON (VTable v) = toJSON v+ toJSON (VTArray v) = toJSON v+ toJSON (VString v) = toJSON v+ toJSON (VInteger v) = toJSON v+ toJSON (VFloat v) = toJSON v+ toJSON (VBoolean v) = toJSON v+ toJSON (VDatetime v) = toJSON v+ toJSON (VArray v) = toJSON v
+ benchmark/Benchmark/Tomland.hs view
@@ -0,0 +1,40 @@+module Benchmark.Tomland+ ( convert+ , decode+ , parse+ ) where++import Data.Text (Text)++import Benchmark.Type (FruitInside (..), HaskellType (..), SizeInside (..))+import Toml (DecodeException, TOML, TomlCodec, parse, (.=))++import qualified Toml+++-- | 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.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.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
+ benchmark/Benchmark/Type.hs view
@@ -0,0 +1,55 @@+{-# 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+ , 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 .: "fruit"+ <*> o .: "size"++data FruitInside = FruitInside+ { fiName :: Text+ , fiDescription :: Text+ } deriving (Show, NFData, Generic)++instance FromJSON FruitInside where+ parseJSON = withObject "FruitInside" $ \o -> FruitInside+ <$> o .: "name"+ <*> o .: "description"++newtype SizeInside = SizeInside+ { unSize :: [[Double]]+ } deriving (Show, NFData, Generic)++instance FromJSON SizeInside where+ parseJSON = withObject "SizeInside" $ \o -> SizeInside <$> o .: "dimensions"
+ benchmark/Main.hs view
@@ -0,0 +1,36 @@+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 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+ defaultMain+ [ bgroup "Parse"+ [ bench "tomland" $ nf Tomland.parse txt+ , bench "htoml" $ nf Htoml.parse txt+ , bench "htoml-megaparsec" $ nf HtomlM.parse txt+ ]+ , bgroup "Convert"+ [ bench "tomland" $ nf Tomland.convert tomlandVal+ , bench "htoml" $ nf Htoml.convert htomlVal+ , bench "htoml-megaparsec" $ nf HtomlM.convert htomlMegaVal+ ]+ , bgroup "Decode"+ [ bench "tomland" $ nf Tomland.decode txt+ , bench "htoml" $ nf Htoml.decode txt+ , bench "htoml-megaparsec" $ nf HtomlM.decode txt+ ]+ ]
examples/Playground.hs view
@@ -5,7 +5,7 @@ import Data.Text (Text) import Data.Time (fromGregorian) -import Toml (BiToml, ParseException (..), prettyToml, (.=), (<!>))+import Toml (ParseException (..), TomlCodec, pretty, (.=), (<!>)) import Toml.Edsl (mkToml, table, (=:)) import Toml.Type (DateTime (..), TOML (..), Value (..)) @@ -31,46 +31,46 @@ newtype TestInside = TestInside { unInside :: Text } -insideT :: BiToml TestInside+insideT :: TomlCodec TestInside insideT = Toml.dimap unInside TestInside $ Toml.text "inside" -testT :: BiToml Test+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.maybeT Toml.bool "testM" .= testM+ <*> Toml.dioptional (Toml.bool "testM") .= testM <*> Toml.table insideT "testX" .= testX- <*> Toml.maybeT (Toml.table insideT) "testY" .= testY+ <*> Toml.dioptional ((Toml.table insideT) "testY") .= testY <*> Toml.wrapper Toml.text "testN" .= testN <*> eitherT1 .= testE1 <*> eitherT2 .= testE2 where -- different keys for sum type- eitherT1 :: BiToml (Either Integer String)- eitherT1 = Toml.match (Toml._Integer >>> Toml._Left) "either.Left"- <|> Toml.match (Toml._String >>> Toml._Right) "either.Right"+ 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 :: BiToml (Either String Double)- eitherT2 = ( Toml.match (Toml._String >>> Toml._Left)- <!> Toml.match (Toml._Double >>> Toml._Right)+ 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 $ prettyToml myToml+ 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 $ prettyToml toml+ Right toml -> TIO.putStrLn $ pretty toml TIO.putStrLn "=== Testing bidirectional conversion ===" biFile <- TIO.readFile "examples/biTest.toml"
src/Toml/Bi/Code.hs view
@@ -1,6 +1,8 @@+{-# LANGUAGE DeriveAnyClass #-}+ module Toml.Bi.Code ( -- * Types- BiToml+ TomlCodec , Env , St @@ -12,9 +14,12 @@ -- * Encode/Decode , decode , decodeFile+ , runTomlCodec , encode+ , execTomlCodec ) where +import Control.DeepSeq (NFData) import Control.Exception (Exception, throwIO) import Control.Monad.Except (ExceptT, runExceptT) import Control.Monad.IO.Class (MonadIO (..))@@ -25,11 +30,12 @@ import Data.Foldable (toList) import Data.Semigroup (Semigroup (..)) import Data.Text (Text)+import GHC.Generics (Generic) -import Toml.Bi.Monad (Bi, Bijection (..))+import Toml.Bi.Monad (BiCodec, Codec (..)) import Toml.Parser (ParseException (..), parse) import Toml.PrefixTree (Key (..), unPiece)-import Toml.Printer (prettyToml)+import Toml.Printer (pretty) import Toml.Type (TOML (..), TValue, showType) import qualified Data.Text as Text@@ -42,7 +48,7 @@ | TableNotFound Key -- ^ No such table | TypeMismatch Key Text TValue -- ^ Expected type vs actual type | ParseError ParseException -- ^ Exception during parsing- deriving (Eq, Show) -- TODO: manual pretty show instances+ deriving (Eq, Show, Generic, NFData) -- TODO: manual pretty show instances instance Semigroup DecodeException where TrivialError <> e = e@@ -66,11 +72,11 @@ joinKey = Text.intercalate "." . map unPiece . toList . unKey -- | Immutable environment for 'Toml' conversion.--- This is @r@ type variable in 'Bijection' data type.+-- This is @r@ type variable in 'Codec' data type. type Env = ExceptT DecodeException (Reader TOML) {- | Mutable context for 'Toml' conversion.-This is @w@ type variable in 'Bijection' data type.+This is @w@ type variable in 'Codec' data type. @ MaybeT (State TOML) a@@ -82,18 +88,25 @@ -- | Specialied 'Bi' type alias for 'Toml' monad. Keeps 'TOML' object either as -- environment or state.-type BiToml a = Bi Env St a+type TomlCodec a = BiCodec Env St a -- | Convert textual representation of toml into user data type.-decode :: BiToml a -> Text -> Either DecodeException a-decode biToml text = do+decode :: TomlCodec a -> Text -> Either DecodeException a+decode codec text = do toml <- first ParseError (parse text)- runReader (runExceptT $ biRead biToml) toml+ runTomlCodec codec toml +-- | Convert toml into user data type.+runTomlCodec :: TomlCodec a -> TOML -> Either DecodeException a+runTomlCodec codec = runReader (runExceptT $ codecRead codec)+ -- | Convert object to textual representation.-encode :: BiToml a -> a -> Text-encode bi obj = prettyToml $ execState (runMaybeT $ biWrite bi obj) mempty+encode :: TomlCodec a -> a -> Text+encode codec obj = pretty $ execTomlCodec codec obj +execTomlCodec :: TomlCodec a -> a -> TOML+execTomlCodec codec obj = execState (runMaybeT $ codecWrite codec obj) mempty+ -- | File loading error data type. data LoadTomlException = LoadTomlException FilePath Text @@ -103,9 +116,9 @@ instance Exception LoadTomlException -- | Decode a value from a file. In case of parse errors, throws 'LoadTomlException'.-decodeFile :: (MonadIO m) => BiToml a -> FilePath -> m a-decodeFile biToml filePath = liftIO $- (decode biToml <$> TIO.readFile filePath) >>= errorWhenLeft+decodeFile :: (MonadIO m) => TomlCodec a -> FilePath -> m a+decodeFile codec filePath = liftIO $+ (decode codec <$> TIO.readFile filePath) >>= errorWhenLeft where errorWhenLeft :: Either DecodeException a -> IO a errorWhenLeft (Left e) = throwIO $ LoadTomlException filePath $ prettyException e
src/Toml/Bi/Combinators.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE ScopedTypeVariables #-} -- | Contains TOML-specific combinators for converting between TOML and user data types. @@ -10,17 +9,29 @@ bool , int , integer+ , natural+ , word , double+ , float , text+ , read , string+ , byteString+ , lazyByteString+ , zonedTime+ , localTime+ , day+ , timeOfDay , arrayOf+ , arraySetOf+ , arrayIntSet+ , arrayHashSetOf+ , arrayNonEmptyOf -- * Combinators , match- , maybeT , table , wrapper- , dimapNum , mdimap ) where @@ -34,18 +45,33 @@ import Data.Semigroup ((<>)) 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 (BiToml, DecodeException (..), Env, St)-import Toml.Bi.Monad (Bi, Bijection (..), dimap)-import Toml.BiMap (BiMap (..), matchValueForward, _Array, _Bool, _Double, _Integer, _String, _Text)+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.PrefixTree (Key)-import Toml.Type (AnyValue (..), TOML (..), TValue (..), Value (..), insertKeyAnyVal, insertTable,- valueType)+import Toml.Type (AnyValue (..), TOML (..), insertKeyAnyVal, insertTable, valueType) +import Prelude hiding (read)+ 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 ---------------------------------------------------------------------------- -- Generalized versions of parsers@@ -56,29 +82,23 @@ {- | General function to create bidirectional converters for values. -}-match :: forall a . Typeable a => BiMap AnyValue a -> Key -> BiToml a-match BiMap{..} key = Bijection input output+match :: forall a . Typeable a => BiMap a AnyValue -> Key -> TomlCodec a+match BiMap{..} key = Codec input output where input :: Env a input = do mVal <- asks $ HashMap.lookup key . tomlPairs case mVal of Nothing -> throwError $ KeyNotFound key- Just anyVal@(AnyValue val) -> case forward anyVal of+ Just anyVal@(AnyValue val) -> case backward anyVal of Just v -> pure v Nothing -> throwError $ TypeMismatch key (typeName @a) (valueType val) output :: a -> St a output a = do- anyVal <- MaybeT $ pure $ backward a+ anyVal <- MaybeT $ pure $ forward a a <$ modify (insertKeyAnyVal key anyVal) --- | Helper dimapper to turn 'integer' parser into parser for 'Int', 'Natural', 'Word', etc.-dimapNum :: forall n r w . (Integral n, Functor r, Functor w)- => Bi r w Integer- -> Bi r w n-dimapNum = dimap toInteger fromIntegral- {- | Almost same as 'dimap'. Useful when you want to have fields like this inside your configuration: @@ -102,15 +122,15 @@ 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- -> Bijection r w d a -- ^ Source 'Bijection' object- -> Bijection r w c b-mdimap toString toMaybe bi = Bijection- { biRead = (toMaybe <$> biRead bi) >>= \case+ -> 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 - , biWrite = \s -> do- retS <- biWrite bi $ toString s+ , 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@@ -121,82 +141,110 @@ ---------------------------------------------------------------------------- -- | Parser for boolean values.-bool :: Key -> BiToml Bool+bool :: Key -> TomlCodec Bool bool = match _Bool -- | Parser for integer values.-integer :: Key -> BiToml Integer+integer :: Key -> TomlCodec Integer integer = match _Integer -- | Parser for integer values.-int :: Key -> BiToml Int-int = dimapNum . integer+int :: Key -> TomlCodec Int+int = match _Int --- | Parser for floating values.-double :: Key -> BiToml Double+-- | Parser for natural values.+natural :: Key -> TomlCodec Natural+natural = match _Natural++-- | Parser for word values.+word :: Key -> TomlCodec Word+word = match _Word++-- | Parser for floating point values as double.+double :: Key -> TomlCodec Double double = match _Double --- | Parser for string values.-text :: Key -> BiToml Text+-- | Parser for floating point values as float.+float :: Key -> TomlCodec Float+float = match _Float++-- | Parser for string values as text.+text :: Key -> TomlCodec Text text = match _Text --- | Codec for 'String'.-string :: Key -> BiToml String+-- | Parser for string values as string.+string :: Key -> TomlCodec String string = match _String --- TODO: implement using bijectionMaker--- | Parser for array of values. Takes converter for single array element and--- returns list of values.-arrayOf :: forall a . Typeable a => BiMap AnyValue a -> Key -> BiToml [a]-arrayOf bimap key = Bijection input output- where- input :: Env [a]- input = do- mVal <- asks $ HashMap.lookup key . tomlPairs- case mVal of- Nothing -> throwError $ KeyNotFound key- Just (AnyValue (Array arr)) -> case arr of- [] -> pure []- l@(x:_) -> case mapM (matchValueForward bimap) l of- Nothing -> throwError $ TypeMismatch key (typeName @a) (valueType x)- Just vals -> pure vals- Just _ -> throwError $ TypeMismatch key (typeName @a) TArray+-- | Parser for values with a `Read` and `Show` instance.+read :: (Show a, Read a, Typeable a) => Key -> TomlCodec a+read = match _Read - output :: [a] -> St [a]- output a = do- anyVal <- MaybeT $ pure $ backward (_Array bimap) a- a <$ modify (\(TOML vals tables) -> TOML (HashMap.insert key anyVal vals) tables)+-- | Parser for byte vectors values as strict bytestring.+byteString :: Key -> TomlCodec ByteString+byteString = match _ByteString --- | Bidirectional converter for @Maybe smth@ values.-maybeT :: forall a . (Key -> BiToml a) -> Key -> BiToml (Maybe a)-maybeT converter key = let bi = converter key in Bijection- { biRead = (Just <$> biRead bi) `catchError` handleNotFound- , biWrite = \case- Nothing -> pure Nothing- Just v -> biWrite bi v >> pure (Just v)- }- where- handleNotFound :: DecodeException -> Env (Maybe a)- handleNotFound e- | e `elem` [KeyNotFound key, TableNotFound key] = pure Nothing- | otherwise = throwError e+-- | Parser for byte vectors values as lazy bytestring.+lazyByteString :: Key -> TomlCodec BL.ByteString+lazyByteString = match _LByteString +-- | Parser for zoned time values.+zonedTime :: Key -> TomlCodec ZonedTime+zonedTime = match _ZonedTime++-- | Parser for local time values.+localTime :: Key -> TomlCodec LocalTime+localTime = match _LocalTime++-- | Parser for day values.+day :: Key -> TomlCodec Day+day = match _Day++-- | Parser for time of day values.+timeOfDay :: Key -> TomlCodec TimeOfDay+timeOfDay = match _TimeOfDay++-- | Parser 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 = match . _Array++-- | Parser 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 = match . _Set++-- | Parser 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+-- returns a set of hashable values.+arrayHashSetOf :: (Typeable a, Hashable a, Eq a) => BiMap a AnyValue -> Key -> TomlCodec (HashSet a)+arrayHashSetOf = match . _HashSet++-- | Parser 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 = match . _NonEmpty+ -- | Parser for tables. Use it when when you have nested objects.-table :: forall a . BiToml a -> Key -> BiToml a-table bi key = Bijection input output+table :: forall a . TomlCodec a -> Key -> TomlCodec a+table codec key = Codec input output where input :: Env a input = do mTable <- asks $ Prefix.lookup key . tomlTables case mTable of Nothing -> throwError $ TableNotFound key- Just toml -> local (const toml) (biRead bi) `catchError` handleTableName+ Just toml -> local (const toml) (codecRead codec) `catchError` handleTableName output :: a -> St a output a = do mTable <- gets $ Prefix.lookup key . tomlTables let toml = fromMaybe mempty mTable- let newToml = execState (runMaybeT $ biWrite bi a) toml+ let newToml = execState (runMaybeT $ codecWrite codec a) toml a <$ modify (insertTable key newToml) handleTableName :: DecodeException -> Env a@@ -206,5 +254,5 @@ handleTableName e = throwError e -- | Used for @newtype@ wrappers.-wrapper :: forall b a . Coercible a b => (Key -> BiToml a) -> Key -> BiToml b+wrapper :: forall b a . Coercible a b => (Key -> TomlCodec a) -> Key -> TomlCodec b wrapper bi key = dimap coerce coerce (bi key)
src/Toml/Bi/Monad.hs view
@@ -3,17 +3,18 @@ -- | Contains general underlying monad for bidirectional TOML converion. module Toml.Bi.Monad- ( Bijection (..)- , Bi+ ( Codec (..)+ , BiCodec , dimap+ , dioptional , (<!>) , (.=) ) where -import Control.Applicative (Alternative (..))+import Control.Applicative (Alternative (..), optional) import Control.Monad (MonadPlus (..)) -{- | Monad for bidirectional Toml conversion. Contains pair of functions:+{- | Monad for bidirectional conversion. Contains pair of functions: 1. How to read value of type @a@ from immutable environment context @r@? 2. How to store value of type @a@ in stateful context @w@?@@ -25,7 +26,7 @@ In practice this type will always be used in the following way: @-type 'Bi' r w a = 'Bijection' r w a a+type 'BiCodec' r w a = 'Codec' r w a a @ Type parameter @c@ if fictional. Here some trick is used. This trick is@@ -33,71 +34,70 @@ described in more details in [related blog post](https://blog.poisson.chat/posts/2016-10-12-bidirectional-serialization.html). -}-data Bijection r w c a = Bijection+data Codec r w c a = Codec { -- | Extract value of type @a@ from monadic context @r@.- biRead :: r a+ codecRead :: r a -- | Store value of type @c@ inside monadic context @w@ and returning -- value of type @a@. Type of this function actually should be @a -> w ()@ but with -- such type it's impossible to have 'Monad' and other instances.- , biWrite :: c -> w a+ , codecWrite :: c -> w a } --- | Specialized version of 'Bijection' data type. This type alias is used in practice.-type Bi r w a = Bijection r w a a+-- | Specialized version of 'Codec' data type. This type alias is used in practice.+type BiCodec r w a = Codec r w a a -instance (Functor r, Functor w) => Functor (Bijection r w c) where- fmap :: (a -> b) -> Bijection r w c a -> Bijection r w c b- fmap f bi = Bijection- { biRead = f <$> biRead bi- , biWrite = fmap f . biWrite bi+instance (Functor r, Functor w) => Functor (Codec r w c) where+ fmap :: (a -> b) -> Codec r w c a -> Codec r w c b+ fmap f codec = Codec+ { codecRead = f <$> codecRead codec+ , codecWrite = fmap f . codecWrite codec } -instance (Applicative r, Applicative w) => Applicative (Bijection r w c) where- pure :: a -> Bijection r w c a- pure a = Bijection- { biRead = pure a- , biWrite = \_ -> pure a+instance (Applicative r, Applicative w) => Applicative (Codec r w c) where+ pure :: a -> Codec r w c a+ pure a = Codec+ { codecRead = pure a+ , codecWrite = \_ -> pure a } - (<*>) :: Bijection r w c (a -> b) -> Bijection r w c a -> Bijection r w c b- bif <*> bia = Bijection- { biRead = biRead bif <*> biRead bia- , biWrite = \c -> biWrite bif c <*> biWrite bia c+ (<*>) :: Codec r w c (a -> b) -> Codec r w c a -> Codec r w c b+ codecf <*> codeca = Codec+ { codecRead = codecRead codecf <*> codecRead codeca+ , codecWrite = \c -> codecWrite codecf c <*> codecWrite codeca c } -instance (Monad r, Monad w) => Monad (Bijection r w c) where- (>>=) :: Bijection r w c a -> (a -> Bijection r w c b) -> Bijection r w c b- bi >>= f = Bijection- { biRead = biRead bi >>= \a -> biRead (f a)- , biWrite = \c -> biWrite bi c >>= \a -> biWrite (f a) c+instance (Monad r, Monad w) => Monad (Codec r w c) where+ (>>=) :: Codec r w c a -> (a -> Codec r w c b) -> Codec r w c b+ codec >>= f = Codec+ { codecRead = codecRead codec >>= \a -> codecRead (f a)+ , codecWrite = \c -> codecWrite codec c >>= \a -> codecWrite (f a) c } -instance (Alternative r, Alternative w) => Alternative (Bijection r w c) where- empty :: Bijection r w c a- empty = Bijection- { biRead = empty- , biWrite = \_ -> empty+instance (Alternative r, Alternative w) => Alternative (Codec r w c) where+ empty :: Codec r w c a+ empty = Codec+ { codecRead = empty+ , codecWrite = \_ -> empty } - (<|>) :: Bijection r w c a -> Bijection r w c a -> Bijection r w c a- bi1 <|> bi2 = Bijection- { biRead = biRead bi1 <|> biRead bi2- , biWrite = \c -> biWrite bi1 c <|> biWrite bi2 c+ (<|>) :: Codec r w c a -> Codec r w c a -> Codec r w c a+ codec1 <|> codec2 = Codec+ { codecRead = codecRead codec1 <|> codecRead codec2+ , codecWrite = \c -> codecWrite codec1 c <|> codecWrite codec2 c } -instance (MonadPlus r, MonadPlus w) => MonadPlus (Bijection r w c) where+instance (MonadPlus r, MonadPlus w) => MonadPlus (Codec r w c) where mzero = empty mplus = (<|>) -infixl 3 <!> -- | Alternative instance for function arrow but without 'empty'.+infixl 3 <!> (<!>) :: Alternative f => (a -> f x) -> (a -> f x) -> (a -> f x) f <!> g = \a -> f a <|> g a -{- | This is an instance of 'Profunctor' for 'Bijection'. 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:@@ -112,7 +112,7 @@ toml bidirectional converter for this type will look like this: @-exampleT :: BiToml Example+exampleT :: TomlCodec Example exampleT = Example <$> bool "foo" .= foo <*> str "bar" .= bar@@ -132,22 +132,29 @@ you need to patch your toml parser like this: @-exampleT :: BiToml Example+exampleT :: TomlCodec Example exampleT = Example <$> bool "foo" .= foo- <*> dimap unEmail Email (str "bar") .= bar+ <*> dimap unEmail Email (str "bar") .= bar @ -} dimap :: (Functor r, Functor w) => (c -> d) -- ^ Mapper for consumer -> (a -> b) -- ^ Mapper for producer- -> Bijection r w d a -- ^ Source 'Bijection' object- -> Bijection r w c b-dimap f g bi = Bijection- { biRead = g <$> biRead bi- , biWrite = fmap g . biWrite bi . f+ -> Codec r w d a -- ^ Source 'Codec' object+ -> Codec r w c b+dimap f g codec = Codec+ { 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)+dioptional Codec{..} = Codec+ { codecRead = optional codecRead+ , codecWrite = traverse codecWrite+ }+ {- | Operator to connect two operations: 1. How to get field from object?@@ -158,12 +165,12 @@ @ data Foo = Foo { fooBar :: Int, fooBaz :: String } -foo :: BiToml Foo+foo :: TomlCodec Foo foo = Foo <$> int "bar" .= fooBar <*> str "baz" .= fooBaz @ -} infixl 5 .=-(.=) :: Bijection r w field a -> (object -> field) -> Bijection r w object a-bijection .= getter = bijection { biWrite = biWrite bijection . getter }+(.=) :: Codec r w field a -> (object -> field) -> Codec r w object a+codec .= getter = codec { codecWrite = codecWrite codec . getter }
src/Toml/BiMap.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE Rank2Types #-} {- | Implementation of partial bidirectional mapping as a data type. -}@@ -13,20 +13,41 @@ , prism -- * Helpers for BiMap and AnyValue- , matchValueForward , mkAnyValueBiMap+ , _TextBy+ , _NaturalInteger+ , _StringText+ , _ReadString+ , _BoundedInteger+ , _ByteStringText+ , _LByteStringText -- * Some predefined bi mappings , _Array , _Bool , _Double , _Integer- , _String , _Text- , _TextToString+ , _ZonedTime+ , _LocalTime+ , _Day+ , _TimeOfDay+ , _String+ , _Read+ , _Natural+ , _Word+ , _Int+ , _Float+ , _ByteString+ , _LByteString+ , _Set+ , _IntSet+ , _HashSet+ , _NonEmpty , _Left , _Right+ , _Just -- * Useful utility functions , toMArray@@ -34,14 +55,29 @@ 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 (..), TValue (TArray), Value (..), liftMatch, matchArray, matchBool,- matchDouble, matchInteger, matchText, reifyAnyValues)+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@@ -76,19 +112,25 @@ iso f g = BiMap (Just . f) (Just . g) -- | Creates 'BiMap' from prism-like pair of functions.-prism :: (object -> Maybe field) -> (field -> object) -> BiMap object field-prism preview review = BiMap preview (Just . review)+prism :: (field -> object) -> (object -> Maybe field) -> BiMap object field+prism review preview = BiMap preview (Just . review) ---------------------------------------------------------------------------- -- General purpose bimaps ---------------------------------------------------------------------------- -_Left :: BiMap l (Either l r)-_Left = invert $ prism (either Just (const Nothing)) Left+-- | Bimap for 'Either' and its left type+_Left :: BiMap (Either l r) l+_Left = prism Left (either Just (const Nothing)) -_Right :: BiMap r (Either l r)-_Right = invert $ prism (either (const Nothing) Just) Right+-- | 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 ----------------------------------------------------------------------------@@ -96,48 +138,158 @@ -- | Creates prism for 'AnyValue'. mkAnyValueBiMap :: (forall t . Value t -> Maybe a) -> (a -> Value tag)- -> BiMap AnyValue a+ -> BiMap a AnyValue mkAnyValueBiMap matchValue toValue =- prism (\(AnyValue value) -> matchValue value) (AnyValue . toValue)+ BiMap (Just . AnyValue . toValue) (\(AnyValue value) -> matchValue value) --- | Allows to match against given 'Value' using provided prism for 'AnyValue'.-matchValueForward :: BiMap AnyValue a -> Value t -> Maybe a-matchValueForward = liftMatch . forward+-- | 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 'arrayOf' combinator.-_Bool :: BiMap AnyValue Bool+-- | 'Bool' bimap for 'AnyValue'. Usually used with 'bool' combinator.+_Bool :: BiMap Bool AnyValue _Bool = mkAnyValueBiMap matchBool Bool --- | 'Integer' bimap for 'AnyValue'. Usually used with 'arrayOf' combinator.-_Integer :: BiMap AnyValue Integer+-- | 'Integer' bimap for 'AnyValue'. Usually used with 'integer' combinator.+_Integer :: BiMap Integer AnyValue _Integer = mkAnyValueBiMap matchInteger Integer --- | 'Double' bimap for 'AnyValue'. Usually used with 'arrayOf' combinator.-_Double :: BiMap AnyValue Double+-- | 'Double' bimap for 'AnyValue'. Usually used with 'double' combinator.+_Double :: BiMap Double AnyValue _Double = mkAnyValueBiMap matchDouble Double --- | 'Text' bimap for 'AnyValue'. Usually used with 'arrayOf' combinator.-_Text :: BiMap AnyValue Text+-- | 'Text' bimap for 'AnyValue'. Usually used with 'text' combinator.+_Text :: BiMap Text AnyValue _Text = mkAnyValueBiMap matchText Text -_TextToString :: BiMap Text String-_TextToString = iso T.unpack T.pack+-- | 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 -_String :: BiMap AnyValue String-_String = _Text >>> _TextToString+-- | 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 --- | 'Array' bimap for 'AnyValue'. Usually used with 'arrayOf' combinator.-_Array :: BiMap AnyValue a -> BiMap AnyValue [a]+-- | 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 = \(AnyValue val) -> matchArray (forward elementBimap) val- , backward = mapM (backward elementBimap) >=> fmap AnyValue . toMArray+ { forward = mapM (forward elementBimap) >=> fmap AnyValue . toMArray+ , backward = \(AnyValue val) -> matchArray (backward elementBimap) val } --- TODO: move somewhere else?-{- | Function for creating 'Array' from list of 'AnyValue'.--}-toMArray :: [AnyValue] -> Maybe (Value 'TArray)-toMArray [] = Just $ Array []-toMArray (AnyValue x : xs) = case reifyAnyValues x xs of- Left _ -> Nothing- Right vals -> Just $ Array (x : vals)+-- | 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
@@ -5,10 +5,10 @@ @ exampleToml :: TOML exampleToml = mkToml $ do- "key1" =: 1- "key2" =: Bool True- table "tableName" $- "tableKey" =: Array ["Oh", "Hi", "Mark"]+ \"key1\" =: 1+ \"key2\" =: Bool True+ table \"tableName\" $+ \"tableKey\" =: Array [\"Oh\", \"Hi\", \"Mark\"] @ -}
src/Toml/Parser.hs view
@@ -1,311 +1,26 @@-{- | Parser of TOML language. Implemented with the help of @megaparsec@ package. -}+{-# LANGUAGE DeriveAnyClass #-} module Toml.Parser ( ParseException (..) , parse- , arrayP- , boolP- , dateTimeP- , doubleP- , integerP- , keyP- , keyValP- , textP- , tableHeaderP- , tomlP ) where --- I hate default Prelude... Do I really need to import all this stuff manually?..-import Control.Applicative (Alternative (..))-import Control.Applicative.Combinators (between, count, manyTill, optional, sepEndBy, skipMany)-import Control.Monad (void)-import Data.Char (chr, digitToInt, isControl)-import Data.Fixed (Pico)-import Data.List (foldl')-import Data.Semigroup ((<>))-import Data.Text (Text)-import Data.Time (LocalTime (..), ZonedTime (..), fromGregorianValid, makeTimeOfDayValid,- minutesToTimeZone)-import Data.Void (Void)-import Text.Megaparsec (Parsec, parseErrorPretty', try)-import Text.Megaparsec.Char (alphaNumChar, anyChar, char, digitChar, eol, hexDigitChar, oneOf,- satisfy, space, space1, string, tab)+import Control.DeepSeq (NFData)+import Data.Text (Text, pack)+import GHC.Generics (Generic) -import Toml.PrefixTree (Key (..), Piece (..), fromList)-import Toml.Type (AnyValue, DateTime (..), TOML (..), UValue (..), typeCheck)+import Toml.Parser.TOML (tomlP)+import Toml.Type (TOML) -import qualified Control.Applicative.Combinators.NonEmpty as NC-import qualified Data.HashMap.Lazy as HashMap-import qualified Data.Text as Text-import qualified Text.Megaparsec as Mega (parse)-import qualified Text.Megaparsec.Char.Lexer as L+import qualified Toml.Parser.Core as P (errorBundlePretty, parse) -------------------------------------------------------------------------------- Library for parsing (boilerplate copy-pasted from megaparsec tutorial)----------------------------------------------------------------------------- -type Parser = Parsec Void Text---- space consumer-sc :: Parser ()-sc = L.space space1 lineComment blockComment- where- lineComment = L.skipLineComment "#"- blockComment = empty---- wrapper for consuming spaces after every lexeme (not before it!)-lexeme :: Parser a -> Parser a-lexeme = L.lexeme sc---- parser for "fixed" string-text :: Text -> Parser Text-text = L.symbol sc--text_ :: Text -> Parser ()-text_ = void . text--------------------------------------------------------------------------------- TOML parser--------------------------------------------------------------------------------- Strings--textP :: Parser Text-textP = multilineBasicStringP <|> multilineLiteralStringP <|> literalStringP <|> basicStringP--nonControlCharP :: Parser Text-nonControlCharP = Text.singleton <$> satisfy (not . isControl)--escapeSequenceP :: Parser Text-escapeSequenceP = char '\\' >> anyChar >>= \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 '-'---- adds " or ' to both sides-quote :: Text -> Text -> Text-quote q t = q <> t <> q--keyComponentP :: Parser Piece-keyComponentP = Piece <$> (bareKeyP <|> (quote "\"" <$> basicStringP) <|> (quote "'" <$> literalStringP))--keyP :: Parser Key-keyP = Key <$> NC.sepBy1 keyComponentP (char '.')--tableNameP :: Parser Key-tableNameP = lexeme $ between (char '[') (char ']') keyP---- Values--integerP :: Parser Integer-integerP = lexeme $ binary <|> octal <|> hexadecimal <|> decimal- where- decimal = L.signed sc L.decimal- binary = try (char '0' >> char 'b') >> mkNum 2 <$> (some binDigitChar)- octal = try (char '0' >> char 'o') >> L.octal- hexadecimal = try (char '0' >> char 'x') >> L.hexadecimal- binDigitChar = oneOf ['0', '1']- mkNum b = foldl' (step b) 0- step b a c = a * b + fromIntegral (digitToInt c)--doubleP :: Parser Double-doubleP = lexeme $ L.signed sc (num <|> inf <|> nan)- where- num, inf, nan :: Parser Double- num = L.float- inf = 1 / 0 <$ string "inf"- nan = 0 / 0 <$ string "nan"--boolP :: Parser Bool-boolP = False <$ text "false"- <|> True <$ text "true"--dateTimeP :: Parser DateTime-dateTimeP = lexeme $ try hoursP <|> dayLocalZoned- 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- Just hours -> do- maybeOffset <- optional (try timeOffsetP)- case maybeOffset of- Nothing -> return (makeLocal day hours)- Just offset -> return (makeZoned (makeLocal day hours) offset)-- timeOffsetP :: Parser Int- timeOffsetP = z <|> numOffset- where- z = pure 0 <* char 'Z'- numOffset = do- sign <- char '+' <|> char '-'- hours <- int2DigitsP- _ <- char ':'- minutes <- int2DigitsP- let totalMinutes = hours * 60 + minutes- if sign == '+'- then return totalMinutes- else return (negate totalMinutes)-- 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-- 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-- 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')--arrayP :: Parser [UValue]-arrayP = lexeme $ between (char '[' *> sc) (char ']') elements- where- elements :: Parser [UValue]- elements = valueP `sepEndBy` spComma <* skipMany (text ",")-- spComma :: Parser ()- spComma = char ',' *> sc--valueP :: Parser UValue-valueP = UBool <$> boolP- <|> UDate <$> dateTimeP- <|> UDouble <$> try doubleP- <|> UInteger <$> integerP- <|> UText <$> textP- <|> UArray <$> arrayP---- TOML--keyValP :: Parser (Key, AnyValue)-keyValP = do- k <- keyP- text_ "="- uval <- valueP- case typeCheck uval of- Left err -> fail $ show err- Right v -> pure (k, v)--tableHeaderP :: Parser (Key, TOML)-tableHeaderP = do- k <- tableNameP- toml <- makeToml <$> many keyValP- pure (k, toml)- where- makeToml :: [(Key, AnyValue)] -> TOML- makeToml kv = TOML (HashMap.fromList kv) mempty--tomlP :: Parser TOML-tomlP = do- sc- kvs <- many keyValP- tables <- many tableHeaderP- pure TOML { tomlPairs = HashMap.fromList kvs- , tomlTables = fromList tables- }-------------------------------------------------------------------------------- Exposed API------------------------------------------------------------------------------ -- | Pretty parse exception for parsing toml. newtype ParseException = ParseException Text- deriving (Show, Eq)+ deriving (Show, Eq, Generic, NFData) -- | Parses 'Text' as 'TOML' object. parse :: Text -> Either ParseException TOML-parse t = case Mega.parse tomlP "" t of- Left err -> Left $ ParseException $ Text.pack $ parseErrorPretty' t err+parse t = case P.parse tomlP "" t of+ Left err -> Left $ ParseException $ pack $ P.errorBundlePretty err Right toml -> Right toml
+ src/Toml/Parser/Core.hs view
@@ -0,0 +1,43 @@+module Toml.Parser.Core+ ( module Text.Megaparsec+ , module Text.Megaparsec.Char+ , module Text.Megaparsec.Char.Lexer+ , Parser+ , lexeme+ , sc+ , text+ ) where++import Control.Applicative (Alternative (empty))++import Data.Text (Text)+import Data.Void (Void)++import Text.Megaparsec (Parsec, anySingle, errorBundlePretty, match, parse, satisfy, try, (<?>))+import Text.Megaparsec.Char (alphaNumChar, char, digitChar, eol, hexDigitChar, space, space1,+ string, tab)+import Text.Megaparsec.Char.Lexer (binary, float, hexadecimal, octal, signed, skipLineComment,+ symbol)+import qualified Text.Megaparsec.Char.Lexer as L (lexeme, space)+++-- The parser+type Parser = Parsec Void Text+++-- space consumer+sc :: Parser ()+sc = L.space space1 lineComment blockComment+ where+ lineComment = skipLineComment "#"+ blockComment = empty+++-- wrapper for consuming spaces after every lexeme (not before it!)+lexeme :: Parser a -> Parser a+lexeme = L.lexeme sc+++-- parser for "fixed" string+text :: Text -> Parser Text+text = symbol sc
+ src/Toml/Parser/TOML.hs view
@@ -0,0 +1,47 @@+module Toml.Parser.TOML+ ( hasKeyP+ , tableHeaderP+ , inlineTableP+ , tomlP+ ) where++import Control.Applicative (Alternative (many))+import Control.Applicative.Combinators (sepEndBy, between, eitherP)++import Toml.Parser.Core (Parser, sc, text)+import Toml.Parser.Value (keyP, tableNameP, anyValueP)+import Toml.PrefixTree (Key (..), fromList)+import Toml.Type (AnyValue, TOML (..))++import qualified Data.HashMap.Lazy as HashMap++hasKeyP :: Parser (Key, Either AnyValue TOML)+hasKeyP = (,) <$> keyP <* text "=" <*> eitherP anyValueP inlineTableP++inlineTableP :: Parser TOML+inlineTableP = between (text "{") (text "}")+ (makeToml <$> hasKeyP `sepEndBy` text ",")++tableHeaderP :: Parser (Key, TOML)+tableHeaderP = (,) <$> tableNameP <*> (makeToml <$> many hasKeyP)++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, 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+ }
+ src/Toml/Parser/Value.hs view
@@ -0,0 +1,293 @@+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,+ 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 '.')+++tableNameP :: Parser Key+tableNameP = between (text "[") (text "]") keyP+++-- Values++decimalP :: Parser Integer+decimalP = mkInteger <$> decimalStringP+ 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 (/= '_')+++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+++doubleP :: Parser Double+doubleP = lexeme (signed sc (num <|> inf <|> nan)) <?> "double"+ where+ num, inf, nan :: Parser Double+ num = float+ inf = 1 / 0 <$ string "inf"+ nan = 0 / 0 <$ string "nan"+++boolP :: Parser Bool+boolP = False <$ text "false"+ <|> True <$ text "true"+ <?> "bool"+++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+ Just hours -> do+ maybeOffset <- optional (try timeOffsetP)+ return $ case maybeOffset of+ Nothing -> makeLocal day hours+ Just offset -> makeZoned (makeLocal day hours) 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++ 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++ 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++ 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')+++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)++ element :: UValue -> Parser UValue+ element = \case+ UBool _ -> UBool <$> boolP+ UDate _ -> UDate <$> dateTimeP+ UDouble _ -> UDouble <$> try doubleP+ UInteger _ -> UInteger <$> integerP+ UText _ -> UText <$> textP+ UArray _ -> UArray <$> arrayP++ spComma :: Parser ()+ spComma = char ',' *> sc+++valueP :: Parser UValue+valueP = UBool <$> boolP+ <|> UDate <$> dateTimeP+ <|> UDouble <$> try doubleP+ <|> UInteger <$> integerP+ <|> UText <$> textP+ <|> UArray <$> arrayP+++anyValueP :: Parser AnyValue+anyValueP = typeCheck <$> valueP >>= \case+ Left err -> fail $ show err+ Right v -> return v
src/Toml/PrefixTree.hs view
@@ -1,8 +1,11 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ViewPatterns #-} module Toml.PrefixTree ( PrefixTree (..)+ , (<|) , singleT , insertT , lookupT@@ -25,7 +28,7 @@ import Prelude hiding (lookup) -import Control.Arrow ((&&&))+import Control.DeepSeq (NFData) import Data.Bifunctor (first) import Data.Coerce (coerce) import Data.Foldable (foldl')@@ -43,7 +46,8 @@ -- | Represents the key piece of some layer. newtype Piece = Piece { unPiece :: Text }- deriving (Show, Eq, Ord, Hashable, IsString)+ 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@@ -60,9 +64,8 @@ -} newtype Key = Key { unKey :: NonEmpty Piece }- deriving (Show, Eq, Ord, Semigroup, Generic)--instance Hashable Key+ 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@@ -78,9 +81,9 @@ x:xs -> coerce @(NonEmpty Text) @Key (x :| xs) pattern (:||) :: Piece -> [Piece] -> Key-pattern x :|| xs <- ((NonEmpty.head &&& NonEmpty.tail) . unKey -> (x, xs))+pattern x :|| xs <- Key (x :| xs) where- x :|| xs = Key $ x :| xs+ x :|| xs = Key (x :| xs) {-# COMPLETE (:||) #-} @@ -97,7 +100,7 @@ , bVal :: !(Maybe a) -- ^ value by key = prefix , bPrefixMap :: !(PrefixMap a) -- ^ suffixes of prefix }- deriving (Show, Eq)+ deriving (Show, Eq, NFData, Generic) instance Semigroup (PrefixTree a) where a <> b = foldl' (\tree (k, v) -> insertT k v tree) a (toListT b)
src/Toml/Printer.hs view
@@ -3,13 +3,18 @@ {- | Contains functions for pretty printing @toml@ types. -} module Toml.Printer- ( prettyToml+ ( PrintOptions(..)+ , defaultOptions+ , pretty+ , prettyOptions , prettyTomlInd ) where import Data.HashMap.Strict (HashMap)-import Data.Monoid ((<>))+import Data.Monoid ((<>), mconcat) import Data.Text (Text)+import Data.Time (formatTime, defaultTimeLocale, ZonedTime)+import Data.List (splitAt, sortOn) import Toml.PrefixTree (Key (..), Piece (..), PrefixMap, PrefixTree (..)) import Toml.Type (AnyValue (..), DateTime (..), TOML (..), Value (..))@@ -18,26 +23,42 @@ import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Text as Text --- Tab is equal to 2 spaces now.-tab :: Int -> Text-tab n = Text.cons '\n' (Text.replicate (2*n) " ")+{- | Configures the pretty printer. -}+data PrintOptions = PrintOptions+ { shouldSort :: Bool -- ^ should table keys be sorted ot shouldn't+ , indent :: Int -- ^ indentation size+ } deriving (Show) -{- | Converts 'TOML' type into 'Text'.+{- | Default printing options. -}+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').+ For example, this @ TOML- { tomlPairs = HashMap.fromList [(Key "title", String "TOML example")]- , tomlTables = HashMap.fromList- [( TableId (NonEmpty.fromList ["example", "owner"])- , TOML- { tomlPairs = HashMap.fromList [(Key "name", String "Kowainik")]- , tomlTables = mempty- , tomlTableArrays = mempty+ { tomlPairs = HashMap.fromList+ [("title", AnyValue $ Text "TOML example")]+ , tomlTables = PrefixTree.fromList+ [( "example" <| "owner"+ , mempty+ { tomlPairs = HashMap.fromList+ [("name", AnyValue $ Text "Kowainik")] } )]- , tomlTableArrays = mempty } @ @@ -51,34 +72,45 @@ @ -}-prettyToml :: TOML -> Text-prettyToml = Text.drop 1 . prettyTomlInd 0 ""+pretty :: TOML -> Text+pretty = prettyOptions defaultOptions +{- | Converts 'TOML' type into 'Text' using provided 'PrintOptions' -}+prettyOptions :: PrintOptions -> TOML -> Text+prettyOptions options = Text.drop 1 . prettyTomlInd options 0 ""+ -- | Converts 'TOML' into 'Text' with the given indent.-prettyTomlInd :: Int -- ^ Number of spaces for indentation- -> Text -- ^ Accumulator for table names- -> TOML -- ^ Given 'TOML'- -> Text -- ^ Pretty result-prettyTomlInd i prefix TOML{..} = prettyKeyValue i tomlPairs <> "\n"- <> prettyTables i prefix tomlTables+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 -- | Returns pretty formatted key-value pairs of the 'TOML'.-prettyKeyValue :: Int -> HashMap Key AnyValue -> Text-prettyKeyValue i = Text.concat . map kvText . HashMap.toList+prettyKeyValue :: PrintOptions -> Int -> HashMap Key AnyValue -> Text+prettyKeyValue options i =+ Text.concat . map kvText . orderWith options . HashMap.toList where kvText :: (Key, AnyValue) -> Text- kvText (k, AnyValue v) = tab i <> prettyKey k <> " = " <> valText v+ kvText (k, AnyValue v) = mconcat+ [ 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) = showText d+ valText (Double d) = showDouble d valText (Text s) = showText s valText (Date d) = timeText d valText (Array a) = "[" <> Text.intercalate ", " (map valText a) <> "]" timeText :: DateTime -> Text- timeText (Zoned z) = showText z+ timeText (Zoned z) = showZonedTime z timeText (Local l) = showText l timeText (Day d) = showText d timeText (Hours h) = showText h@@ -86,22 +118,43 @@ showText :: Show a => a -> Text showText = Text.pack . show + showDouble :: Double -> Text+ showDouble d | isInfinite d && d < 0 = "-inf"+ | isInfinite d = "inf"+ | isNaN d = "nan"+ | otherwise = showText d++ showZonedTime :: ZonedTime -> Text+ showZonedTime t = Text.pack $ showZonedDateTime t <> showZonedZone t+ where+ showZonedDateTime = formatTime defaultTimeLocale "%FT%T%Q"+ showZonedZone+ = (\(x,y) -> x ++ ":" ++ y)+ . (\z -> splitAt (length z - 2) z)+ . formatTime defaultTimeLocale "%z"+ -- | Returns pretty formatted tables section of the 'TOML'.-prettyTables :: Int -> Text -> PrefixMap TOML -> Text-prettyTables i pref = Text.concat . map prettyTable . HashMap.elems+prettyTables :: PrintOptions -> Int -> Text -> PrefixMap TOML -> Text+prettyTables options i pref =+ Text.concat . map (prettyTable . snd) . orderWith options . HashMap.toList where prettyTable :: PrefixTree TOML -> Text prettyTable (Leaf k toml) =- let name = getPref k in- tab i <> prettyTableName name- <> prettyTomlInd (succ i) name toml+ let name = getPref k in mconcat+ [ tabWith options i+ , prettyTableName name+ , prettyTomlInd options (succ i) name toml ] prettyTable (Branch k mToml prefMap) = let name = getPref k nextI = succ i toml = case mToml of Nothing -> ""- Just t -> prettyTomlInd nextI name t- in tab i <> prettyTableName name <> toml <> prettyTables nextI name prefMap+ 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
src/Toml/Type/AnyValue.hs view
@@ -6,6 +6,7 @@ module Toml.Type.AnyValue ( AnyValue (..) , reifyAnyValues+ , toMArray -- * Matching , liftMatch@@ -17,10 +18,11 @@ , matchArray ) where +import Control.DeepSeq (NFData, rnf) import Data.Text (Text) import Data.Type.Equality ((:~:) (..)) -import Toml.Type.Value (DateTime, TValue, TypeMismatchError, Value (..), eqValueList, sameValue)+import Toml.Type.Value (DateTime, TValue (..), TypeMismatchError, Value (..), sameValue) -- | Existential wrapper for 'Value'. data AnyValue = forall (t :: TValue) . AnyValue (Value t)@@ -29,14 +31,13 @@ show (AnyValue v) = show v instance Eq AnyValue where- (AnyValue (Bool b1)) == (AnyValue (Bool b2)) = b1 == b2- (AnyValue (Integer i1)) == (AnyValue (Integer i2)) = i1 == i2- (AnyValue (Double f1)) == (AnyValue (Double f2)) = f1 == f2- (AnyValue (Text s1)) == (AnyValue (Text s2)) = s1 == s2- (AnyValue (Date d1)) == (AnyValue (Date d2)) = d1 == d2- (AnyValue (Array a1)) == (AnyValue (Array a2)) = eqValueList a1 a2- _ == _ = False+ (AnyValue val1) == (AnyValue val2) = case sameValue val1 val2 of+ Right Refl -> val1 == val2+ Left _ -> False +instance NFData AnyValue where+ rnf (AnyValue val) = rnf val+ ---------------------------------------------------------------------------- -- Matching functions for values ----------------------------------------------------------------------------@@ -79,3 +80,10 @@ reifyAnyValues :: Value t -> [AnyValue] -> Either TypeMismatchError [Value t] reifyAnyValues _ [] = Right [] 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 x : xs) = case reifyAnyValues x xs of+ Left _ -> Nothing+ Right vals -> Just $ Array (x : vals)
src/Toml/Type/TOML.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveAnyClass #-}+ module Toml.Type.TOML ( TOML (..) , insertKeyVal@@ -5,8 +7,10 @@ , insertTable ) where +import Control.DeepSeq (NFData) import Data.HashMap.Strict (HashMap) import Data.Semigroup (Semigroup (..))+import GHC.Generics (Generic) import Toml.PrefixTree (Key (..), PrefixMap) import Toml.Type.AnyValue (AnyValue (..))@@ -22,7 +26,7 @@ { tomlPairs :: HashMap Key AnyValue , tomlTables :: PrefixMap TOML -- tomlTableArrays :: HashMap Key (NonEmpty TOML)- } deriving (Show, Eq)+ } deriving (Show, Eq, NFData, Generic) instance Semigroup TOML where (TOML pairsA tablesA) <> (TOML pairsB tablesB) = TOML
src/Toml/Type/Value.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-}@@ -21,14 +22,16 @@ , sameValue ) where +import Control.DeepSeq (NFData(..), rnf) import Data.String (IsString (..)) import Data.Text (Text) import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime, zonedTimeToUTC) import Data.Type.Equality ((:~:) (..))+import GHC.Generics (Generic) -- | Needed for GADT parameterization data TValue = TBool | TInteger | TDouble | TText | TDate | TArray- deriving (Eq, Show)+ deriving (Eq, Show, NFData, Generic) showType :: TValue -> String showType = drop 1 . show@@ -102,6 +105,14 @@ deriving instance Show (Value t) +instance NFData (Value t) where+ 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+ instance (t ~ 'TInteger) => Num (Value t) where (Integer a) + (Integer b) = Integer $ a + b (Integer a) * (Integer b) = Integer $ a * b@@ -116,7 +127,9 @@ instance Eq (Value t) where (Bool b1) == (Bool b2) = b1 == b2 (Integer i1) == (Integer i2) = i1 == i2- (Double f1) == (Double f2) = f1 == f2+ (Double f1) == (Double f2)+ | isNaN f1 && isNaN f2 = True+ | otherwise = f1 == f2 (Text s1) == (Text s2) = s1 == s2 (Date d1) == (Date d2) = d1 == d2 (Array a1) == (Array a2) = eqValueList a1 a2@@ -182,6 +195,12 @@ (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
test/Test/Toml/Gen.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}@@ -17,16 +18,23 @@ ) where import Control.Applicative (liftA2)-import Control.Monad (forM)+import Control.Monad (forM, replicateM)+import Data.Fixed (Fixed (..))+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Time (Day, LocalTime (..), TimeOfDay (..), ZonedTime (..), fromGregorian,+ minutesToTimeZone) import GHC.Stack (HasCallStack) import Hedgehog (MonadGen, PropertyT, property) 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 (..), TOML (..), Value (..))+import Toml.Type (AnyValue (..), DateTime (..), TOML (..), TValue (..), Value (..)) import qualified Data.HashMap.Strict as HashMap+import qualified Data.Text as Text import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range @@ -51,19 +59,10 @@ -- TODO: Arrays and Date. -- | Generates random value of 'AnyValue' type. genAnyValue :: MonadGen m => m AnyValue-genAnyValue = do- let randB = Gen.bool- let randI = toInteger <$> Gen.int (Range.constantBounded @Int)- let randD = Gen.double $ Range.constant @Double (-1000000.0) 1000000.0- let randT = Gen.text (Range.constant 0 256) Gen.alphaNum- Gen.choice- [ AnyValue . Bool <$> randB- , AnyValue . Integer <$> randI- , AnyValue . Double <$> randD- , AnyValue . Text <$> randT- ]+genAnyValue = Gen.choice $+ (AnyValue <$> genArray) : noneArrayList --- TODO: unicode support+ -- TODO: unicode support genPiece :: MonadGen m => m Piece genPiece = Piece <$> Gen.text (Range.constant 1 50) Gen.alphaNum @@ -78,9 +77,8 @@ -- Generates key-value pair for PrefixMap genEntry :: MonadGen m => m (Piece, Key)-genEntry = do- key@(piece :|| _) <- genKey- pure (piece, key)+genEntry = genKey >>= \case+ key@(piece :|| _) -> pure (piece, key) genPrefixMap :: MonadGen m => m (PrefixMap V) genPrefixMap = do@@ -119,3 +117,117 @@ kv <- HashMap.fromList <$> genKeyAnyValueList tables <- Gen.list (Range.linear 0 10) genTableHeader pure $ TOML kv (fromList tables)++genDay :: MonadGen m => m Day+genDay = do+ y <- toInteger <$> Gen.int (Range.constant 1968 2019)+ m <- Gen.int (Range.constant 1 12)+ d <- Gen.int (Range.constant 1 28)+ pure $ fromGregorian y m d++genHours :: MonadGen m => m TimeOfDay+genHours = do+ secs <- MkFixed <$> Gen.integral (Range.constant 0 61)+ mins <- Gen.int (Range.constant 0 59)+ hours <- Gen.int (Range.constant 0 23)+ pure $ TimeOfDay hours mins secs++genLocal :: MonadGen m => m LocalTime+genLocal = do+ day <- genDay+ LocalTime day <$> genHours++genZoned :: MonadGen m => m ZonedTime+genZoned = do+ local <- genLocal+ zMin <- Gen.int (Range.constant (-720) 720)+ let zTime = minutesToTimeZone zMin+ pure $ ZonedTime local zTime++genDate :: MonadGen m => m DateTime+genDate = Gen.choice+ [ Day <$> genDay+ , Hours <$> genHours+ , Local <$> genLocal+ , Zoned <$> genZoned+ ]++genBool :: MonadGen m => m Bool+genBool = Gen.bool++genInteger :: MonadGen m => m Integer+genInteger = toInteger <$> Gen.int (Range.constantBounded @Int)++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)+ ]++-- | Generatates control sympol.+genEscapeSequence :: MonadGen m => m Text+genEscapeSequence = Gen.element+ [ "\n", "\b", "\f", "\r", "\t", "\\", "\"" ]++-- | Generatates punctuation.+genPunctuation :: MonadGen m => m Text+genPunctuation = Gen.element+ [ ",", ".", ":", ";", "'", "?", "!", "`"+ , "-", "_", "*", "$", "#", "@", "(", ")"+ , " ", "^", "#", "/","&", ">", "<"+ ]++-- | Generatates n length list of hex chars.+genDiffHex :: MonadGen m => Int -> m String+genDiffHex n = replicateM n Gen.hexit++-- | Generates unicode color string (u1234)+genUniHex4Color :: MonadGen m => m Text+genUniHex4Color = do+ hex <- genDiffHex 4+ pure . Text.pack $ "\\u" ++ hex++-- | Generates unicode color string (u12345678)+genUniHex8Color :: MonadGen m => m Text+genUniHex8Color = do+ hex <- genDiffHex 8+ pure . Text.pack $ "\\U" ++ hex++-- | Generates text from different symbols.+genText :: MonadGen m => m Text+genText = fmap Text.concat $ Gen.list (Range.constant 0 256) $ Gen.choice+ [ Text.singleton <$> Gen.alphaNum+ , genEscapeSequence+ , genPunctuation+ , genUniHex4Color+ , genUniHex8Color+ ]++-- | List of AnyValue generators.+noneArrayList :: MonadGen m => [m AnyValue]+noneArrayList =+ [ AnyValue . Bool <$> genBool+ , AnyValue . Integer <$> genInteger+ , AnyValue . Double <$> genDouble+ , AnyValue . Text <$> genText+ , AnyValue . Date <$> genDate+ ]++genArrayFrom :: MonadGen m => m AnyValue -> m (Value 'TArray)+genArrayFrom noneArray+ = fromMaybe (error "Error in genArrayFrom")+ . toMArray+ <$> Gen.list (Range.constant 0 5) noneArray++{- | Generate arrays and nested arrays. For example:+Common array:+Array [Double (-563397.0197456297),Double (-308866.62837749254),Double (-29555.32072604308),Double 772371.8575471763,Double (-880016.1210667372),Double 182763.78796234122,Double (-462893.41157520143),Double 814856.6483699235,Double (-454629.17640282493)]+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 = Gen.recursive Gen.choice+ [Gen.choice $ map genArrayFrom noneArrayList]+ [Array <$> Gen.list (Range.constant 0 5) genArray]
test/Test/Toml/Parsing/Property.hs view
@@ -3,11 +3,11 @@ import Hedgehog (forAll, tripping) import Toml.Parser (parse)-import Toml.Printer (prettyToml)+import Toml.Printer (pretty) import Test.Toml.Gen (PropertyTest, genToml, prop) test_tomlRoundtrip :: PropertyTest test_tomlRoundtrip = prop "parse . prettyPrint == id" $ do toml <- forAll genToml- tripping toml prettyToml parse+ tripping toml pretty parse
test/Test/Toml/Parsing/Unit.hs view
@@ -8,8 +8,8 @@ import Test.Tasty.Hspec (Spec, context, describe, it) import Text.Megaparsec (parse) -import Toml.Parser (arrayP, boolP, dateTimeP, doubleP, integerP, keyP, keyValP, tableHeaderP, textP,- tomlP)+import Toml.Parser.Value (arrayP, boolP, dateTimeP, doubleP, integerP, keyP, textP)+import Toml.Parser.TOML (hasKeyP, tableHeaderP, tomlP) import Toml.PrefixTree (Key (..), Piece (..), fromList) import Toml.Type (AnyValue (..), DateTime (..), TOML (..), UValue (..), Value (..)) @@ -18,392 +18,508 @@ 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+ 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- parseKeyVal = parseX keyValP- parseText = parseX textP- parseTable = parseX tableHeaderP- parseToml = parseX tomlP+ 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- keyValFailOn = failOn keyValP- textFailOn = failOn textP+ arrayFailOn = failOn arrayP+ boolFailOn = failOn boolP+ dateTimeFailOn = failOn dateTimeP+ doubleFailOn = failOn doubleP+ hasKeyFailOn = failOn hasKeyP+ integerFailOn = failOn integerP+ textFailOn = failOn textP - doubleSatisfies = parseXSatisfies doubleP+ doubleSatisfies = parseXSatisfies doubleP - quoteWith q t = q <> t <> q- squote = quoteWith "'"- dquote = quoteWith "\""+ 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))+ 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)+ makeKey k = (Key . NE.fromList) (map Piece k) - tomlFromList kv = TOML (HashMap.fromList kv) mempty+ tomlFromList kv = TOML (HashMap.fromList kv) mempty - 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" $ do- parseArray "[\n1,\n2\n]" [UInteger 1, UInteger 2]- it "can parse an array of arrays" $ do- 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" $ do- 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" $ do- 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']"+ 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']" - 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 "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" $ do- 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"+ 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" - 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" $ do- 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- --xit "can parse numbers with underscores between digits" $ do- -- parseInt "1_000" 1000- -- parseInt "5_349_221" 5349221- -- parseInt "1_2_3_4_5" 12345- -- parseInt "1_2_3_" 1- -- parseInt "13_" 13- -- intFailOn "_123_"- -- intFailOn "_13"- -- intFailOn "_"- --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`" $ do- 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" $ do- parseInteger "-0b101" 0- it "does not parse numbers with non-valid binary digits" $ do- 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`" $ do- 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" $ do- parseInteger "-0o123" 0- it "does not parse numbers with non-valid octal digits" $ do- 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`" $ do- 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" $ do- parseInteger "-0xfff" 0- it "does not parse numbers with non-valid hexadecimal digits" $ do- parseInteger "0xfgh" 0xf- it "can parse numbers when hex digits are lowercase" $ do- parseInteger "0xabcdef" 0xabcdef- it "can parse numbers when hex digits are uppercase" $ do- parseInteger "0xABCDEF" 0xABCDEF- it "can parse numbers when hex digits are in both lowercase and uppercase" $ do- parseInteger "0xAbCdEf" 0xAbCdEf- parseInteger "0xaBcDeF" 0xaBcDeF+ 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 - 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" $ do- parseKey "1234" (makeKey ["1234"])- context "when the key is a quoted key" $ do- it "can parse keys that follow the exact same rules as basic strings" $ do- parseKey (dquote "127.0.0.1") (makeKey [dquote "127.0.0.1"])- parseKey (dquote "character encoding") (makeKey [dquote "character encoding"])- parseKey (dquote "ʎǝʞ") (makeKey [dquote "ʎǝʞ"])- it "can parse keys that follow the exact same rules as literal strings" $ do- parseKey (squote "key2") (makeKey [squote "key2"])- parseKey (squote "quoted \"value\"") (makeKey [squote "quoted \"value\""])- context "when the key is a dotted key" $ do- it "can parse a sequence of bare or quoted keys joined with a dot" $ do- parseKey "name" (makeKey ["name"])- parseKey "physical.color" (makeKey ["physical", "color"])- parseKey "physical.shape" (makeKey ["physical", "shape"])- parseKey "site.\"google.com\"" (makeKey ["site", dquote "google.com"])- --xit "ignores whitespaces around dot-separated parts" $ do- -- parseKey "a . b . c. d" (makeKey ["a", "b", "c", "d"])+ describe "keyP" $ do+ context "when the key is a bare key" $ do+ it+ "can parse keys which contain ASCII letters, digits, underscores, and dashes"+ $ do+ parseKey "key" (makeKey ["key"])+ parseKey "bare_key1" (makeKey ["bare_key1"])+ parseKey "bare-key2" (makeKey ["bare-key2"])+ it "can parse keys which contain only digits"+ $ parseKey "1234" (makeKey ["1234"])+ context "when the key is a quoted key" $ do+ it+ "can parse keys that follow the exact same rules as basic strings"+ $ do+ parseKey (dquote "127.0.0.1")+ (makeKey [dquote "127.0.0.1"])+ parseKey (dquote "character encoding")+ (makeKey [dquote "character encoding"])+ parseKey (dquote "ʎǝʞ") (makeKey [dquote "ʎǝʞ"])+ it+ "can parse keys that follow the exact same rules as literal strings"+ $ do+ parseKey (squote "key2") (makeKey [squote "key2"])+ parseKey (squote "quoted \"value\"")+ (makeKey [squote "quoted \"value\""])+ context "when the key is a dotted key"+ $ 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"]) - describe "keyValP" $ do- it "can parse key/value pairs" $ do- parseKeyVal "x='abcdef'" (makeKey ["x"], AnyValue (Text "abcdef"))- parseKeyVal "x=1" (makeKey ["x"], AnyValue (Integer 1))- parseKeyVal "x=5.2" (makeKey ["x"], AnyValue (Double 5.2))- parseKeyVal "x=true" (makeKey ["x"], AnyValue (Bool True))- parseKeyVal "x=[1, 2, 3]" (makeKey ["x"], AnyValue (Array [Integer 1, Integer 2, Integer 3]))- parseKeyVal "x = 1920-12-10" (makeKey ["x"], AnyValue (Date (makeDay 1920 12 10)))- --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- parseKeyVal "x=1 " (makeKey ["x"], AnyValue (Integer 1))- parseKeyVal "x= 1" (makeKey ["x"], AnyValue (Integer 1))- parseKeyVal "x =1" (makeKey ["x"], AnyValue (Integer 1))- parseKeyVal "x\t= 1 " (makeKey ["x"], AnyValue (Integer 1))- parseKeyVal "\"x\" = 1" (makeKey [dquote "x"], AnyValue (Integer 1))- --xit "fails if the key, equals sign, and value are not on the same line" $ do- -- keyValFailOn "x\n=\n1"- -- keyValFailOn "x=\n1"- -- keyValFailOn "\"x\"\n=\n1"- it "works if the value is broken over multiple lines" $ do- parseKeyVal "x=[1, \n2\n]" (makeKey ["x"], AnyValue (Array [Integer 1, Integer 2]))- it "fails if the value is not specified" $ do- keyValFailOn "x="+ describe "hasKeyP" $ do+ it "can parse key/value pairs" $ do+ parseHasKey "x='abcdef'" (makeKey ["x"], Left $ AnyValue (Text "abcdef"))+ 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)))+ --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+ parseHasKey "x=1 " (makeKey ["x"] , Left $ AnyValue (Integer 1))+ parseHasKey "x= 1" (makeKey ["x"] , Left $ AnyValue (Integer 1))+ parseHasKey "x =1" (makeKey ["x"] , Left $ AnyValue (Integer 1))+ parseHasKey "x\t= 1 " (makeKey ["x"] , Left $ AnyValue (Integer 1))+ parseHasKey "\"x\" = 1" (makeKey [dquote "x"], Left $ AnyValue (Integer 1))+ --xit "fails if the key, equals sign, and value are not on the same line" $ do+ -- keyValFailOn "x\n=\n1"+ -- keyValFailOn "x=\n1"+ -- keyValFailOn "\"x\"\n=\n1"+ it "works if the value is broken over multiple lines" $ parseHasKey+ "x=[1, \n2\n]"+ (makeKey ["x"], Left $ AnyValue (Array [Integer 1, Integer 2]))+ it "fails if the value is not specified" $ hasKeyFailOn "x=" - 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" $ do- 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 "\"\"\""+ 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 multi-line strings surrounded by three double quotes" $ do- 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" $ do- 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" $ do- parseText (dquote3 "\nabc \n xyz") "abc \n xyz"- it "ignores a newline only if it immediately follows the opening delimiter" $ do- parseText (dquote3 "\nThe quick brown") "The quick brown"- it "ignores whitespaces and newlines after line ending backslash" $ do- 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 "'''"+ parseHasKey "table-1={key1 = \"some string\", key2 = 123}" table+ it "can parse an empty TOML table"+ $ parseHasKey "table = {}" (makeKey ["table"], Right $ tomlFromList [])+ 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 []) - it "can parse multi-line strings surrounded by three single quotes" $ do- 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" $ do- 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" $ do- 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") - 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" $ do- 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" $ do- 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" $ do- 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)) + 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 "\"\"\"" - 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])+ 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 "'''" - parseTable "[table-1]\nkey1 = \"some string\"\nkey2 = 123" table- it "can parse an empty TOML table" $ do- 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 [])+ 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") - describe "tomlP" $ do- it "can parse TOML files" $ do- let tomlString = " # This is a TOML document.\n\n \+ 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))++ 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])++ 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 [])++ 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" - 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])]+ 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])] - parseToml tomlString (TOML tomlPairs tomlTables)+ parseToml tomlString (TOML tomlPairs tomlTables)
+ test/Test/Toml/Printer/Golden.hs view
@@ -0,0 +1,44 @@+-- | This module contains golden tests for @Toml.Printer@.++module Test.Toml.Printer.Golden+ ( test_prettyGolden+ ) where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Silver (goldenVsAction)+import Toml (TOML)+import Toml.Edsl ((=:), mkToml, table)+import Toml.PrefixTree ((<|))+import Toml.Printer (PrintOptions (..), defaultOptions, prettyOptions)++example :: TOML+example = mkToml $ do+ "b" =: "bb"+ "a" =: "a"+ "d" =: "ddd"+ "c" =: "cccc"+ table ("qux" <| "doo") $ do+ "spam" =: "!"+ "egg" =: "?"+ table "foo" $ pure ()+ table "doo" $ pure ()+ table "baz" $ pure ()++noFormatting :: PrintOptions+noFormatting = PrintOptions+ { shouldSort = False+ , indent = 0+ }++test_prettyGolden :: TestTree+test_prettyGolden =+ testGroup "Toml.Printer"+ [ test "pretty_default" defaultOptions+ , test "pretty_sorted_only" noFormatting{ shouldSort = True} + , test "pretty_indented_only" noFormatting{ indent = 4 }+ , test "pretty_unformatted" noFormatting+ ]+ where+ test name options =+ goldenVsAction name ("test/golden/" ++ name ++ ".golden")+ (pure $ prettyOptions options example) id
tomland.cabal view
@@ -1,5 +1,6 @@+cabal-version: 2.0 name: tomland-version: 0.4.0+version: 0.5.0 synopsis: Bidirectional TOML parser description: See README.md for details. homepage: https://github.com/kowainik/tomland@@ -13,11 +14,14 @@ build-type: Simple extra-doc-files: README.md , CHANGELOG.md-cabal-version: 1.24-tested-with: GHC == 8.4.3- , GHC == 8.2.2- , GHC == 8.0.2+tested-with: GHC == 8.2.2+ , GHC == 8.4.4+ , GHC == 8.6.1 +source-repository head+ type: git+ location: https://github.com/kowainik/tomland.git+ library hs-source-dirs: src @@ -29,6 +33,9 @@ Toml.BiMap Toml.Edsl Toml.Parser+ Toml.Parser.Core+ Toml.Parser.Value+ Toml.Parser.TOML Toml.PrefixTree Toml.Printer Toml.Type@@ -37,24 +44,36 @@ Toml.Type.UValue Toml.Type.Value - build-depends: base >= 4.9 && < 5- , hashable- , megaparsec- , mtl+ build-depends: base >= 4.10 && < 4.13+ , bytestring ^>= 0.10+ , containers >= 0.5.7 && < 0.7+ , deepseq ^>= 1.4+ , hashable ^>= 1.2+ , megaparsec ^>= 7.0.1+ , mtl ^>= 2.2 , parser-combinators- , text- , time- , transformers >= 0.5- , unordered-containers+ , text ^>= 1.2+ , time >= 1.8 && < 1.10+ , transformers ^>= 0.5+ , unordered-containers ^>= 0.2.7 ghc-options: -Wall+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wcompat+ -Widentities+ -Wredundant-constraints+ -fhide-source-paths+ -Wmissing-export-lists+ -Wpartial-fields+ default-language: Haskell2010 default-extensions: DeriveGeneric- GeneralizedNewtypeDeriving InstanceSigs LambdaCase OverloadedStrings RecordWildCards+ ScopedTypeVariables TypeApplications executable play-tomland@@ -78,32 +97,72 @@ main-is: Spec.hs other-modules: Test.Toml.Gen- other-modules: Test.Toml.Property+ Test.Toml.Property Test.Toml.Parsing.Property Test.Toml.Parsing.Unit Test.Toml.PrefixTree.Property Test.Toml.PrefixTree.Unit+ Test.Toml.Printer.Golden Test.Toml.TOML.Property - build-tool-depends: tasty-discover:tasty-discover+ build-tool-depends: tasty-discover:tasty-discover ^>= 4.2.1 build-depends: base- , tomland- , hedgehog+ , hedgehog ^>= 0.6 , hspec-megaparsec , megaparsec- , tasty- , tasty-hedgehog- , tasty-hspec+ , tasty ^>= 1.1.0.3+ , tasty-hedgehog ^>= 0.2.0.0+ , tasty-hspec ^>= 1.1+ , tasty-silver ^>= 3.1.11 , text , time+ , tomland , unordered-containers ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010- default-extensions: OverloadedStrings+ default-extensions: LambdaCase+ OverloadedStrings RecordWildCards -source-repository head- type: git- location: https://github.com/kowainik/tomland.git+benchmark tomland-benchmark+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: benchmark++ other-modules: Benchmark.Type+ Benchmark.Htoml+ Benchmark.HtomlMegaparsec+ Benchmark.Tomland++ ghc-options: -Wall+ -threaded+ -rtsopts+ -with-rtsopts=-N+ -O2+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wcompat+ -Widentities+ -Wredundant-constraints+ -fhide-source-paths+ -Wmissing-export-lists+ -Wpartial-fields++ build-depends: base+ , aeson+ , deepseq ^>= 1.4+ , gauge+ , htoml ^>= 1.0.0.3+ , htoml-megaparsec ^>= 2.1.0.3+ , parsec+ , text+ , time+ , tomland++ default-language: Haskell2010++ default-extensions: LambdaCase+ OverloadedStrings+ RecordWildCards