diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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): diff --git a/benchmark/Benchmark/Htoml.hs b/benchmark/Benchmark/Htoml.hs new file mode 100644 --- /dev/null +++ b/benchmark/Benchmark/Htoml.hs @@ -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 diff --git a/benchmark/Benchmark/HtomlMegaparsec.hs b/benchmark/Benchmark/HtomlMegaparsec.hs new file mode 100644 --- /dev/null +++ b/benchmark/Benchmark/HtomlMegaparsec.hs @@ -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 diff --git a/benchmark/Benchmark/Tomland.hs b/benchmark/Benchmark/Tomland.hs new file mode 100644 --- /dev/null +++ b/benchmark/Benchmark/Tomland.hs @@ -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 diff --git a/benchmark/Benchmark/Type.hs b/benchmark/Benchmark/Type.hs new file mode 100644 --- /dev/null +++ b/benchmark/Benchmark/Type.hs @@ -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" diff --git a/benchmark/Main.hs b/benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main.hs @@ -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 + ] + ] diff --git a/examples/Playground.hs b/examples/Playground.hs --- a/examples/Playground.hs +++ b/examples/Playground.hs @@ -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" diff --git a/src/Toml/Bi/Code.hs b/src/Toml/Bi/Code.hs --- a/src/Toml/Bi/Code.hs +++ b/src/Toml/Bi/Code.hs @@ -1,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 diff --git a/src/Toml/Bi/Combinators.hs b/src/Toml/Bi/Combinators.hs --- a/src/Toml/Bi/Combinators.hs +++ b/src/Toml/Bi/Combinators.hs @@ -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) diff --git a/src/Toml/Bi/Monad.hs b/src/Toml/Bi/Monad.hs --- a/src/Toml/Bi/Monad.hs +++ b/src/Toml/Bi/Monad.hs @@ -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 } diff --git a/src/Toml/BiMap.hs b/src/Toml/BiMap.hs --- a/src/Toml/BiMap.hs +++ b/src/Toml/BiMap.hs @@ -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 diff --git a/src/Toml/Edsl.hs b/src/Toml/Edsl.hs --- a/src/Toml/Edsl.hs +++ b/src/Toml/Edsl.hs @@ -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\"] @ -} diff --git a/src/Toml/Parser.hs b/src/Toml/Parser.hs --- a/src/Toml/Parser.hs +++ b/src/Toml/Parser.hs @@ -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 diff --git a/src/Toml/Parser/Core.hs b/src/Toml/Parser/Core.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Parser/Core.hs @@ -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 diff --git a/src/Toml/Parser/TOML.hs b/src/Toml/Parser/TOML.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Parser/TOML.hs @@ -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 + } diff --git a/src/Toml/Parser/Value.hs b/src/Toml/Parser/Value.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Parser/Value.hs @@ -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 diff --git a/src/Toml/PrefixTree.hs b/src/Toml/PrefixTree.hs --- a/src/Toml/PrefixTree.hs +++ b/src/Toml/PrefixTree.hs @@ -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) diff --git a/src/Toml/Printer.hs b/src/Toml/Printer.hs --- a/src/Toml/Printer.hs +++ b/src/Toml/Printer.hs @@ -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 diff --git a/src/Toml/Type/AnyValue.hs b/src/Toml/Type/AnyValue.hs --- a/src/Toml/Type/AnyValue.hs +++ b/src/Toml/Type/AnyValue.hs @@ -6,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) diff --git a/src/Toml/Type/TOML.hs b/src/Toml/Type/TOML.hs --- a/src/Toml/Type/TOML.hs +++ b/src/Toml/Type/TOML.hs @@ -1,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 diff --git a/src/Toml/Type/Value.hs b/src/Toml/Type/Value.hs --- a/src/Toml/Type/Value.hs +++ b/src/Toml/Type/Value.hs @@ -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 diff --git a/test/Test/Toml/Gen.hs b/test/Test/Toml/Gen.hs --- a/test/Test/Toml/Gen.hs +++ b/test/Test/Toml/Gen.hs @@ -1,3 +1,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] diff --git a/test/Test/Toml/Parsing/Property.hs b/test/Test/Toml/Parsing/Property.hs --- a/test/Test/Toml/Parsing/Property.hs +++ b/test/Test/Toml/Parsing/Property.hs @@ -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 diff --git a/test/Test/Toml/Parsing/Unit.hs b/test/Test/Toml/Parsing/Unit.hs --- a/test/Test/Toml/Parsing/Unit.hs +++ b/test/Test/Toml/Parsing/Unit.hs @@ -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 "" - 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 "" + 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) diff --git a/test/Test/Toml/Printer/Golden.hs b/test/Test/Toml/Printer/Golden.hs new file mode 100644 --- /dev/null +++ b/test/Test/Toml/Printer/Golden.hs @@ -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 diff --git a/tomland.cabal b/tomland.cabal --- a/tomland.cabal +++ b/tomland.cabal @@ -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