diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,47 @@ tomland uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +## 1.1.0.0 — Jul 8, 2019 + +* [#154](https://github.com/kowainik/tomland/issues/154): + Implement `Generic` bidirectional codecs + (by [@chshersh](https://github.com/chshersh)). +* [#145](https://github.com/kowainik/tomland/issues/145): + Add support for inline table arrays + (by [@jiegillet](https://github.com/jiegillet)). +* [#195](https://github.com/kowainik/tomland/issues/195): + Fix an exponential parser behavior for parsing table of arrays + (by [@jiegillet](https://github.com/jiegillet)). +* [#190](https://github.com/kowainik/tomland/issues/190): + Add `enumBounded` codec for nullary sum types + (by [@mxxo](https://github.com/mxxo)). +* [#189](https://github.com/kowainik/tomland/issues/189): + **Breaking change:** Implement custom table sorting by keys. Also fields of + the `PrintOptions` data type were renamed according to style guide + (by [@ramanshah](https://github.com/ramanshah)). + + __Before:__ + + ```haskell + data PrintOptions = PrintOptions + { shouldSort :: Bool + , indent :: Int + } deriving (Show) + ``` + + __Now:__ + + ```haskell + data PrintOptions = PrintOptions + { printOptionsSorting :: !(Maybe (Key -> Key -> Ordering)) + , printOptionsIndent :: !Int + } + ``` + + __Migration guide:__ If you used `indent` field, use `printOptionsIndent` + instead. If you used `shouldSort`, use `printOptionsSorting` instead and pass + `Nothing` instead of `False` or `Just compare` instead of `True`. + ## 1.0.1.0 — May 17, 2019 * [#177](https://github.com/kowainik/tomland/issues/177): diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -152,10 +152,10 @@ | Library | parse :: Text -> AST | transform :: AST -> Haskell | |--------------------|----------------------|-----------------------------| -| `tomland` | `387.5 μs` | `1.313 μs` | -| `htoml` | `801.2 μs` | `32.54 μs` | -| `htoml-megaparsec` | `318.7 μs` | `34.74 μs` | -| `toml-parser` | `157.2 μs` | `1.156 μs` | +| `tomland` | `305.5 μs` | `1.280 μs` | +| `htoml` | `852.8 μs` | `33.37 μs` | +| `htoml-megaparsec` | `295.0 μs` | `33.62 μs` | +| `toml-parser` | `164.6 μs` | `1.101 μs` | You may see that `tomland` is not the fastest one (though still very fast). But performance hasn’t been optimized so far and: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -152,10 +152,10 @@ | Library | parse :: Text -> AST | transform :: AST -> Haskell | |--------------------|----------------------|-----------------------------| -| `tomland` | `387.5 μs` | `1.313 μs` | -| `htoml` | `801.2 μs` | `32.54 μs` | -| `htoml-megaparsec` | `318.7 μs` | `34.74 μs` | -| `toml-parser` | `157.2 μs` | `1.156 μs` | +| `tomland` | `305.5 μs` | `1.280 μs` | +| `htoml` | `852.8 μs` | `33.37 μs` | +| `htoml-megaparsec` | `295.0 μs` | `33.62 μs` | +| `toml-parser` | `164.6 μs` | `1.101 μs` | You may see that `tomland` is not the fastest one (though still very fast). But performance hasn’t been optimized so far and: diff --git a/examples/Playground.hs b/examples/Playground.hs --- a/examples/Playground.hs +++ b/examples/Playground.hs @@ -31,6 +31,11 @@ newtype N = N Text +data ColorScheme = Light + | Dark + | HighContrast + deriving (Show, Enum, Bounded) + data Test = Test { testB :: Bool , testI :: Int @@ -41,6 +46,7 @@ , testX :: TestInside , testY :: Maybe TestInside , testN :: N + , testC :: ColorScheme , testE1 :: Either Integer String , testE2 :: Either String Double , users :: [User] @@ -58,6 +64,7 @@ <*> Toml.table insideCodec "testX" .= testX <*> Toml.dioptional ((Toml.table insideCodec) "testY") .= testY <*> Toml.diwrap (Toml.text "testN") .= testN + <*> Toml.enumBounded "testC" .= testC <*> eitherT1 .= testE1 <*> eitherT2 .= testE2 <*> Toml.list userCodec "user" .= users diff --git a/src/Toml.hs b/src/Toml.hs --- a/src/Toml.hs +++ b/src/Toml.hs @@ -32,6 +32,7 @@ module Toml ( module Toml.Bi + , module Toml.Generic , module Toml.Parser , module Toml.PrefixTree , module Toml.Printer @@ -39,6 +40,7 @@ ) where import Toml.Bi +import Toml.Generic import Toml.Parser import Toml.PrefixTree import Toml.Printer 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 @@ -38,6 +38,7 @@ -- * Additional codecs for custom types , textBy , read + , enumBounded -- * Combinators for tables , table @@ -69,17 +70,18 @@ import Numeric.Natural (Natural) import Toml.Bi.Code (DecodeException (..), Env, St, TomlCodec, execTomlCodec) -import Toml.Bi.Map (BiMap (..), TomlBiMap, _Array, _Bool, _ByteString, _Day, _Double, _Float, - _HashSet, _Int, _IntSet, _Integer, _LByteString, _LText, _LocalTime, _Natural, - _NonEmpty, _Read, _Set, _String, _Text, _TextBy, _TimeOfDay, _Word, _ZonedTime) +import Toml.Bi.Map (BiMap (..), TomlBiMap, _Array, _Bool, _ByteString, _Day, _Double, _EnumBounded, + _Float, _HashSet, _Int, _IntSet, _Integer, _LByteString, _LText, _LocalTime, + _Natural, _NonEmpty, _Read, _Set, _String, _Text, _TextBy, _TimeOfDay, _Word, + _ZonedTime) import Toml.Bi.Monad (Codec (..)) import Toml.PrefixTree (Key) import Toml.Type (AnyValue (..), TOML (..), insertKeyAnyVal, insertTable, insertTableArrays) import qualified Data.ByteString.Lazy as BL import qualified Data.HashMap.Strict as HashMap -import qualified Toml.PrefixTree as Prefix import qualified Data.Text.Lazy as L +import qualified Toml.PrefixTree as Prefix {- | General function to create bidirectional converters for key-value pairs. In @@ -161,6 +163,15 @@ -- | Codec for values with a 'Read' and 'Show' instance. read :: (Show a, Read a) => Key -> TomlCodec a read = match _Read + +{- | Codec for general nullary sum data types with a 'Bounded', 'Enum', and +'Show' instance. This codec provides much better error messages than 'read' for +nullary sum types. + +@since 1.1.1.0 +-} +enumBounded :: (Bounded a, Enum a, Show a) => Key -> TomlCodec a +enumBounded = match _EnumBounded -- | Codec for text values as 'ByteString'. byteString :: Key -> TomlCodec ByteString diff --git a/src/Toml/Bi/Map.hs b/src/Toml/Bi/Map.hs --- a/src/Toml/Bi/Map.hs +++ b/src/Toml/Bi/Map.hs @@ -29,6 +29,7 @@ , _StringText , _ReadString , _BoundedInteger + , _EnumBoundedText , _ByteStringText , _LByteStringText @@ -58,6 +59,7 @@ , _Left , _Right + , _EnumBounded , _Just -- * Useful utility functions @@ -65,12 +67,12 @@ ) where import Control.Arrow ((>>>)) -import Control.Monad ((>=>)) - import Control.DeepSeq (NFData) +import Control.Monad ((>=>)) import Data.Bifunctor (bimap, first) import Data.ByteString (ByteString) import Data.Hashable (Hashable) +import Data.Map (Map) import Data.Semigroup (Semigroup (..)) import Data.Text (Text) import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime) @@ -88,6 +90,7 @@ import qualified Data.HashSet as HS import qualified Data.IntSet as IS import qualified Data.List.NonEmpty as NE +import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -381,6 +384,36 @@ in Left $ ArbitraryError msg | otherwise = Right (fromIntegral n) +{- | Helper bimap for 'EnumBounded' and 'Data.Text.Text'. + +@since 1.1.1.0 +-} +_EnumBoundedText :: forall a. (Show a, Enum a, Bounded a) => TomlBiMap a Text +_EnumBoundedText = BiMap + { forward = Right . tShow + , backward = toEnumBounded + } + where + toEnumBounded :: Text -> Either TomlBiMapError a + toEnumBounded value = case M.lookup value enumOptions of + Just a -> Right a + Nothing -> + let msg = "Value is '" <> value <> "' but expected one of: " <> T.intercalate ", " options + in Left (ArbitraryError msg) + where + enumOptions :: Map Text a + enumOptions = M.fromList $ zip options enums + options = fmap tShow enums + enums = [minBound @a .. maxBound @a] + +{- | Bimap for nullary sum data types with 'Show', 'Enum' and 'Bounded' +instances. Usually used as 'Toml.Bi.Combinators.enumBounded' combinator. + +@since 1.1.1.0 +-} +_EnumBounded :: (Show a, Enum a, Bounded a) => TomlBiMap a AnyValue +_EnumBounded = _EnumBoundedText >>> _Text + {- | 'Word' bimap for 'AnyValue'. Usually used as 'Toml.Bi.Combinators.word' combinator. -} @@ -462,7 +495,7 @@ _HashSet bi = iso HS.toList HS.fromList >>> _Array bi {- | 'IS.IntSet' bimap for 'AnyValue'. Usually used as -'Toml.Bi.Combinators.arrayIntSetOf' combinator. +'Toml.Bi.Combinators.arrayIntSet' combinator. -} _IntSet :: TomlBiMap IS.IntSet AnyValue _IntSet = iso IS.toList IS.fromList >>> _Array _Int diff --git a/src/Toml/Generic.hs b/src/Toml/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Generic.hs @@ -0,0 +1,393 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | This module contains implementation of the 'Generic' TOML codec. If your +data types are big and nested, and you want to have codecs for them without writing a lot of +boilerplate code, you can find this module helpful. Below you can find the detailed +explanation on how the 'Generic' codecs work. + +Consider the following Haskell data types: + +@ +__data__ User = User + { age :: Int + , address :: Address + , socials :: [Social] + } __deriving__ ('Generic') + +__data__ Address = Address + { street :: Text + , house :: Int + } __deriving__ ('Generic') + +__data__ Social = Social + { name :: Text + , link :: Text + } __deriving__ ('Generic') +@ + +Value of the @User@ type represents the following TOML: + +@ +age = 27 + +[address] + street = "Miami Beach" + house = 42 + +[[socials]] + name = \"Twitter\" + link = "https://twitter.com/foo" + +[[socials]] + name = \"GitHub\" + link = "https://github.com/bar" +@ + +Normally you would write 'TomlCodec' for this data type like this: + +@ +userCodec :: 'TomlCodec' User +userCodec = User + \<$\> Toml.int "age" .= age + \<*\> Toml.table addressCodec "address" .= address + \<*\> Toml.list socialCodec "socials" .= socials + +addressCodec :: 'TomlCodec' Address +addressCodec = Address + \<$\> Toml.text "street" .= street + \<*\> Toml.int "house" .= house + +socialCodec :: 'TomlCodec' Social +socialCodec = Social + \<$\> Toml.text "name" .= name + \<*\> Toml.text "link" .= link +@ + +However, if you derive 'Generic' instance for your data types (as we do in the +example), you can write your codecs in a simpler way. + +@ +userCodec :: 'TomlCodec' User +userCodec = 'genericCodec' + +__instance__ 'HasCodec' Address __where__ + hasCodec = Toml.table 'genericCodec' + +__instance__ 'HasItemCodec' Social __where__ + hasItemCodec = Right 'genericCodec' +@ + +Several notes about the interface: + +1. Your top-level data types are always implemented as 'genericCodec' (or other +generic codecs). +2. If you have a custom data type as a field of another type, you need to implement +the instance of the 'HasCodec' typeclass. +3. If the data type appears as an element of a list, you need to implement the instance +of the 'HasItemCodec' typeclass. + +@since 1.1.1.0 +-} + +module Toml.Generic + ( genericCodec + , genericCodecWithOptions + , stripTypeNameCodec + + -- * Options + , TomlOptions (..) + , GenericOptions (..) + , stripTypeNameOptions + , stripTypeNamePrefix + + -- * Core generic typeclass + , HasCodec (..) + , HasItemCodec (..) + , GenericCodec (..) + ) where + +import Data.Char (isLower, toLower) +import Data.IntSet (IntSet) +import Data.Kind (Type) +import Data.List (stripPrefix) +import Data.List.NonEmpty (NonEmpty) +import Data.Proxy (Proxy (..)) +import Data.String (IsString (..)) +import Data.Text (Text) +import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime) +import Data.Typeable (Typeable, typeRep) +import Data.Word (Word) +import GHC.Generics ((:*:) (..), (:+:), C1, D1, Generic (..), K1 (..), M1 (..), Rec0, S1, + Selector (..)) +import GHC.TypeLits (ErrorMessage (..), TypeError) +import Numeric.Natural (Natural) + +import Toml.Bi (TomlBiMap, TomlCodec, (.=)) +import Toml.PrefixTree (Key) +import Toml.Type (AnyValue) + +import qualified Data.Text.Lazy as L +import qualified Toml.Bi as Toml + + +{- | Generic codec for arbitrary data types. Uses field names as keys. +-} +genericCodec :: (Generic a, GenericCodec (Rep a)) => TomlCodec a +genericCodec = Toml.dimap from to $ genericTomlCodec (GenericOptions id) +{-# INLINE genericCodec #-} + +{- | Generic codec with options for arbitrary data types. +-} +genericCodecWithOptions + :: forall a + . (Generic a, GenericCodec (Rep a), Typeable a) + => TomlOptions a + -> TomlCodec a +genericCodecWithOptions = Toml.dimap from to . genericTomlCodec . toGenericOptions @a +{-# INLINE genericCodecWithOptions #-} + +{- | Generic codec that uses 'stripTypeNameOptions'. +-} +stripTypeNameCodec + :: forall a + . (Generic a, GenericCodec (Rep a), Typeable a) + => TomlCodec a +stripTypeNameCodec = genericCodecWithOptions $ stripTypeNameOptions @a +{-# INLINE stripTypeNameCodec #-} + +---------------------------------------------------------------------------- +-- Generic typeclasses +---------------------------------------------------------------------------- + +{- | Options to configure various parameters of generic encoding. Specifically: + +* __'tomlOptionsFieldModifier'__: how to translate field names to TOML keys? +-} +data TomlOptions a = TomlOptions + { tomlOptionsFieldModifier :: Typeable a => Proxy a -> String -> String + } + +{- | Same as 'TomlOptions' but with all data type information erased. This data +type is used internally. Define your options using 'TomlOptions' data type. +-} +newtype GenericOptions = GenericOptions + { genericOptionsFieldModifier :: String -> String + } + +toGenericOptions :: forall a . Typeable a => TomlOptions a -> GenericOptions +toGenericOptions TomlOptions{..} = GenericOptions + { genericOptionsFieldModifier = tomlOptionsFieldModifier (Proxy @a) + } + +-- | Options that use 'stripTypeNamePrefix' as 'tomlOptionsFieldModifier'. +stripTypeNameOptions :: Typeable a => TomlOptions a +stripTypeNameOptions = TomlOptions + { tomlOptionsFieldModifier = stripTypeNamePrefix + } + +{- | Strips name of the type name from field name prefix. + +>>> data UserData = UserData { userDataId :: Int, userDataShortInfo :: Text } +>>> stripTypeNamePrefix (Proxy @UserData) "userDataId" +"id" +>>> stripTypeNamePrefix (Proxy @UserData) "userDataShortInfo" +"shortInfo" +>>> stripTypeNamePrefix (Proxy @UserData) "udStats" +"stats" +>>> stripTypeNamePrefix (Proxy @UserData) "fooBar" +"bar" +>>> stripTypeNamePrefix (Proxy @UserData) "name" +"name" +-} +stripTypeNamePrefix :: forall a . Typeable a => Proxy a -> String -> String +stripTypeNamePrefix _ fieldName = + case stripPrefix (headToLower $ typeName @a) fieldName of + Just rest -> leaveIfEmpty rest + Nothing -> leaveIfEmpty (dropWhile isLower fieldName) + where + headToLower :: String -> String + headToLower = \case + [] -> error "Cannot use 'headToLower' on empty Text" + x:xs -> toLower x : xs + + -- if all lower case then leave field as it is + leaveIfEmpty :: String -> String + leaveIfEmpty rest = if null rest then fieldName else headToLower rest + +typeName :: forall a . Typeable a => String +typeName = show $ typeRep (Proxy @a) + +---------------------------------------------------------------------------- +-- Generic typeclasses +---------------------------------------------------------------------------- + +class GenericCodec (f :: k -> Type) where + genericTomlCodec :: GenericOptions -> TomlCodec (f p) + +instance GenericCodec f => GenericCodec (D1 d f) where + genericTomlCodec = Toml.dimap unM1 M1 . genericTomlCodec + {-# INLINE genericTomlCodec #-} + +type GenericSumTomlNotSupported = + 'Text "Generic TOML deriving for arbitrary sum types is not supported currently." + +instance (TypeError GenericSumTomlNotSupported) => GenericCodec (f :+: g) where + genericTomlCodec = error "Not supported" + +instance GenericCodec f => GenericCodec (C1 c f) where + genericTomlCodec = Toml.dimap unM1 M1 . genericTomlCodec + {-# INLINE genericTomlCodec #-} + +instance (GenericCodec f, GenericCodec g) => GenericCodec (f :*: g) where + genericTomlCodec options = (:*:) + <$> genericTomlCodec options .= fstG + <*> genericTomlCodec options .= sndG + where + fstG :: (f :*: g) p -> f p + fstG (f :*: _) = f + + sndG :: (f :*: g) p -> g p + sndG (_ :*: g) = g + {-# INLINE genericTomlCodec #-} + +instance (Selector s, HasCodec a) => GenericCodec (S1 s (Rec0 a)) where + genericTomlCodec GenericOptions{..} = genericWrap $ hasCodec @a fieldName + where + genericWrap :: TomlCodec a -> TomlCodec (S1 s (Rec0 a) p) + genericWrap = Toml.dimap (unK1 . unM1) (M1 . K1) + + fieldName :: Key + fieldName = + fromString + $ genericOptionsFieldModifier + $ selName (error "S1" :: S1 s Proxy ()) + {-# INLINE genericTomlCodec #-} + +---------------------------------------------------------------------------- +-- Helper typeclasses +---------------------------------------------------------------------------- + +{- | This typeclass tells how the data type should be coded as an item of a +list. Lists in TOML can have two types: __primitive__ and __table of arrays__. + +* If 'hasItemCodec' returns 'Left': __primitive__ arrays codec is used. +* If 'hasItemCodec' returns 'Right:' __table of arrays__ codec is used. +-} +class HasItemCodec a where + hasItemCodec :: Either (TomlBiMap a AnyValue) (TomlCodec a) + +instance HasItemCodec Bool where hasItemCodec = Left Toml._Bool +instance HasItemCodec Int where hasItemCodec = Left Toml._Int +instance HasItemCodec Word where hasItemCodec = Left Toml._Word +instance HasItemCodec Integer where hasItemCodec = Left Toml._Integer +instance HasItemCodec Natural where hasItemCodec = Left Toml._Natural +instance HasItemCodec Double where hasItemCodec = Left Toml._Double +instance HasItemCodec Float where hasItemCodec = Left Toml._Float +instance HasItemCodec Text where hasItemCodec = Left Toml._Text +instance HasItemCodec L.Text where hasItemCodec = Left Toml._LText +instance HasItemCodec ZonedTime where hasItemCodec = Left Toml._ZonedTime +instance HasItemCodec LocalTime where hasItemCodec = Left Toml._LocalTime +instance HasItemCodec Day where hasItemCodec = Left Toml._Day +instance HasItemCodec TimeOfDay where hasItemCodec = Left Toml._TimeOfDay +instance HasItemCodec IntSet where hasItemCodec = Left Toml._IntSet + +{- | If data type @a@ is not primitive then this instance returns codec for list +under key equal to @a@ type name. +-} +instance (HasItemCodec a, Typeable a) => HasItemCodec [a] where + hasItemCodec = case hasItemCodec @a of + Left prim -> Left $ Toml._Array prim + Right codec -> Right $ Toml.list codec (fromString $ typeName @a) + +{- | Helper typeclass for generic deriving. This instance tells how the data +type should be coded if it's a field of another data type. + +__NOTE:__ If you implement TOML codecs for your data types manually, prefer more +explicit @Toml.int@ or @Toml.text@ instead of implicit @Toml.hasCodec@. +Implement instances of this typeclass only when using 'genericCodec' and when +your custom data types are not covered here. +-} +class HasCodec a where + hasCodec :: Key -> TomlCodec a + +instance HasCodec Bool where hasCodec = Toml.bool +instance HasCodec Int where hasCodec = Toml.int +instance HasCodec Word where hasCodec = Toml.word +instance HasCodec Integer where hasCodec = Toml.integer +instance HasCodec Natural where hasCodec = Toml.natural +instance HasCodec Double where hasCodec = Toml.double +instance HasCodec Float where hasCodec = Toml.float +instance HasCodec Text where hasCodec = Toml.text +instance HasCodec L.Text where hasCodec = Toml.lazyText +instance HasCodec ZonedTime where hasCodec = Toml.zonedTime +instance HasCodec LocalTime where hasCodec = Toml.localTime +instance HasCodec Day where hasCodec = Toml.day +instance HasCodec TimeOfDay where hasCodec = Toml.timeOfDay +instance HasCodec IntSet where hasCodec = Toml.arrayIntSet + +instance HasCodec a => HasCodec (Maybe a) where + hasCodec = Toml.dioptional . hasCodec @a + +instance HasItemCodec a => HasCodec [a] where + hasCodec = case hasItemCodec @a of + Left prim -> Toml.arrayOf prim + Right codec -> Toml.list codec + +instance HasItemCodec a => HasCodec (NonEmpty a) where + hasCodec = case hasItemCodec @a of + Left prim -> Toml.arrayNonEmptyOf prim + Right codec -> Toml.nonEmpty codec + +{- +TODO: uncomment when higher-kinded roles will be implemented +* https://github.com/ghc-proposals/ghc-proposals/pull/233 + +{- | @newtype@ for generic deriving of 'HasCodec' typeclass for custom data +types that should we wrapped into separate table. Use it only for data types +that are fields of another data types. + +@ +data Person = Person + { personName :: Text + , personAddress :: Address + } deriving (Generic) + +data Address = Address + { addressStreet :: Text + , addressHouse :: Int + } deriving (Generic) + deriving HasCodec via TomlTable Address + +personCodec :: TomlCodec Person +personCodec = genericCodec +@ + +@personCodec@ corresponds to the TOML of the following structure: + +@ +name = "foo" +[address] + street = \"Bar\" + house = 42 +@ +-} +newtype TomlTable a = TomlTable + { unTomlTable :: a + } + +instance (Generic a, GenericCodec (Rep a)) => HasCodec (TomlTable a) where + hasCodec :: Key -> TomlCodec (TomlTable a) + hasCodec = Toml.diwrap . Toml.table (genericCodec @a) + +instance (Generic a, GenericCodec (Rep a)) => HasItemCodec (TomlTable a) where + hasItemCodec = Right $ Toml.diwrap $ genericCodec @a +-} diff --git a/src/Toml/Parser/Core.hs b/src/Toml/Parser/Core.hs --- a/src/Toml/Parser/Core.hs +++ b/src/Toml/Parser/Core.hs @@ -16,7 +16,8 @@ import Data.Text (Text) import Data.Void (Void) -import Text.Megaparsec (Parsec, anySingle, errorBundlePretty, match, parse, satisfy, try, ()) +import Text.Megaparsec (Parsec, anySingle, eof, 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, diff --git a/src/Toml/Parser/TOML.hs b/src/Toml/Parser/TOML.hs --- a/src/Toml/Parser/TOML.hs +++ b/src/Toml/Parser/TOML.hs @@ -4,23 +4,19 @@ module Toml.Parser.TOML ( keyP - , hasKeyP - , tableP - , tableArrayP - , inlineTableP , tomlP ) where import Control.Applicative (Alternative (..)) -import Control.Monad.Combinators (between, eitherP, optional, sepEndBy) -import Data.List.NonEmpty (NonEmpty (..), (<|)) +import Control.Monad.Combinators (between, sepEndBy) +import Data.List.NonEmpty (NonEmpty (..)) import Data.Semigroup ((<>)) import Data.Text (Text) -import Toml.Parser.Core (Parser, alphaNumChar, char, lexeme, sc, text, try) +import Toml.Parser.Core (Parser, alphaNumChar, char, eof, lexeme, sc, text, try) import Toml.Parser.String (basicStringP, literalStringP) import Toml.Parser.Value (anyValueP) -import Toml.PrefixTree (Key (..), KeysDiff (..), Piece (..), fromList, keysDiff) +import Toml.PrefixTree (Key (..), KeysDiff (..), Piece (..), keysDiff, single) import Toml.Type (AnyValue, TOML (..)) import qualified Control.Applicative.Combinators.NonEmpty as NC @@ -46,7 +42,7 @@ -- | Parser for 'Key': dot-separated list of 'Piece'. keyP :: Parser Key -keyP = Key <$> NC.sepBy1 keyComponentP (char '.') +keyP = Key <$> keyComponentP `NC.sepBy1` char '.' -- | Parser for table name: 'Key' inside @[]@. tableNameP :: Parser Key @@ -56,99 +52,83 @@ tableArrayNameP :: Parser Key tableArrayNameP = between (text "[[") (text "]]") keyP --- Tables +-- Helper functions for building TOML +tomlKV :: Key -> AnyValue -> TOML +tomlKV k v = mempty { tomlPairs = HashMap.singleton k v } --- | Parser for lines starting with 'key =', either values or inline tables. -hasKeyP :: Parser (Key, Either AnyValue TOML) -hasKeyP = (,) <$> keyP <* text "=" <*> eitherP anyValueP inlineTableP +tomlT :: Key -> TOML -> TOML +tomlT k t = mempty { tomlTables = single k t } +tomlA :: Key -> NonEmpty TOML -> TOML +tomlA k a = mempty { tomlTableArrays = HashMap.singleton k a } + +-- | Parser for lines starting with 'key =', either values, inline tables or +-- inline arrays of tables. +hasKeyP :: Maybe Key -> Parser TOML +hasKeyP key = do + k <- keyP <* text "=" + table k <|> try (tableArray k) <|> (tomlKV k <$> anyValueP) + where + table :: Key -> Parser TOML + table k = do + (kDiff, _) <- childKeyP key (pure k) + tomlT kDiff <$> inlineTableP + + tableArray :: Key -> Parser TOML + tableArray k = do + (kDiff, _) <- childKeyP key (pure k) + tomlA kDiff <$> inlineTableArrayP + -- | Parser for inline tables. inlineTableP :: Parser TOML -inlineTableP = between - (text "{") (text "}") - (tomlFromInline <$> hasKeyP `sepEndBy` text ",") +inlineTableP = between (text "{") (text "}") $ + mconcat <$> + (tomlKV <$> (keyP <* text "=") <*> anyValueP ) `sepEndBy` text "," --- | Parser for a table. -tableP :: Parser (Key, TOML) -tableP = do - key <- tableNameP - toml <- subTableContent key - pure (key, toml) +-- | Parser for inline arrays of tables. +inlineTableArrayP :: Parser (NonEmpty TOML) +inlineTableArrayP = between (text "[") (text "]") $ + inlineTableP `NC.sepEndBy1` text "," --- | Parser for an array of tables. -tableArrayP :: Parser (Key, NonEmpty TOML) -tableArrayP = do - key <- tableArrayNameP - localToml <- subTableContent key - more <- optional $ sameKeyP key tableArrayP - case more of - Nothing -> pure (key, localToml :| []) - Just (_, tomls) -> pure (key, localToml <| tomls) +-- | Parser for an array of tables under a certain key. +tableArrayP :: Key -> Parser (NonEmpty TOML) +tableArrayP key = + localTomlP (Just key) `NC.sepBy1` sameKeyP key tableArrayNameP -- | Parser for a '.toml' file tomlP :: Parser TOML -tomlP = do - sc - (val, inline) <- distributeEithers <$> many hasKeyP - (table, array) <- fmap distributeEithers - $ many - $ eitherPairP (try tableP) tableArrayP - - pure TOML - { tomlPairs = HashMap.fromList val - , tomlTables = fromList $ inline ++ table - , tomlTableArrays = HashMap.fromList array - } +tomlP = sc *> localTomlP Nothing <* eof --- | Parser for full 'TOML' under a certain key -subTableContent :: Key -> Parser TOML -subTableContent key = do - (val, inline) <- distributeEithers <$> many hasKeyP - (table, array) <- fmap distributeEithers - $ many - $ childKeyP key - $ eitherPairP (try tableP) tableArrayP +-- | Parser for a toml under a certain key +localTomlP :: Maybe Key -> Parser TOML +localTomlP key = mconcat <$> many (subArray <|> subTable <|> hasKeyP key) + where + subTable :: Parser TOML + subTable = do + (kDiff, k) <- try $ childKeyP key tableNameP + tomlT kDiff <$> localTomlP (Just k) - pure TOML - { tomlPairs = HashMap.fromList val - , tomlTables = fromList $ inline ++ table - , tomlTableArrays = HashMap.fromList array - } + subArray :: Parser TOML + subArray = do + (kDiff, k) <- try $ childKeyP key tableArrayNameP + tomlA kDiff <$> tableArrayP k --- | @childKeyP key p@ returns the result of @p@ if the key returned by @p@ is --- a child key of the @key@, and fails otherwise. -childKeyP :: Key -> Parser (Key, a) -> Parser (Key, a) -childKeyP key p = try $ do - (k, x) <- p +-- | @childKeyP (Just key) p@ checks if the result of @p@ if a child key of +-- @key@ and returns the difference of the keys and the child key. +-- @childKeyP Nothing p@ is only called from @tomlP@ (no parent key). +childKeyP :: Maybe Key -> Parser Key -> Parser (Key, Key) +childKeyP Nothing parser = (\k -> (k, k)) <$> parser +childKeyP (Just key) parser = do + k <- parser case keysDiff key k of - FstIsPref k' -> pure (k', x) - _ -> fail $ show k ++ " is not a child key of " ++ show key + FstIsPref d -> pure (d, k) + _ -> fail $ show k ++ " is not a child key of " ++ show key -- | @sameKeyP key p@ returns the result of @p@ if the key returned by @p@ is -- the same as @key@, and fails otherwise. -sameKeyP :: Key -> Parser (Key, a) -> Parser (Key, a) +sameKeyP :: Key -> Parser Key -> Parser Key sameKeyP key parser = try $ do - (k, x) <- parser + k <- parser case keysDiff key k of - Equal -> pure (k, x) + Equal -> pure k _ -> fail $ show k ++ " is not the same as " ++ show key - --- Helper functions - --- | Helper function to create a 'TOML' from a list of key/values or inline tables. -tomlFromInline :: [(Key, Either AnyValue TOML)] -> TOML -tomlFromInline kvs = - let (lefts, rights) = distributeEithers kvs - in TOML (HashMap.fromList lefts) (fromList rights) mempty - --- | Helper function to seperate the 'Either'. -distributeEithers :: [(c, Either a b)] -> ([(c, a)], [(c, b)]) -distributeEithers = foldr distribute ([], []) - where - distribute :: (c, Either a b) -> ([(c, a)], [(c, b)]) -> ([(c, a)], [(c, b)]) - distribute (k, Left a) (ls, rs) = ((k, a) : ls, rs) - distribute (k, Right b) (ls, rs) = (ls, (k, b) : rs) - --- | Helper function to make an 'Either' parser. -eitherPairP :: Alternative m => m (c, a) -> m (c, b) -> m (c, Either a b) -eitherPairP a b = (fmap Left <$> a) <|> (fmap Right <$> b) diff --git a/src/Toml/Printer.hs b/src/Toml/Printer.hs --- a/src/Toml/Printer.hs +++ b/src/Toml/Printer.hs @@ -10,8 +10,10 @@ , prettyKey ) where +import Data.Bifunctor (first) +import Data.Function (on) import Data.HashMap.Strict (HashMap) -import Data.List (sortOn, splitAt) +import Data.List (sortBy, splitAt) import Data.List.NonEmpty (NonEmpty) import Data.Monoid ((<>)) import Data.Text (Text) @@ -26,17 +28,24 @@ {- | Configures the pretty printer. -} data PrintOptions = PrintOptions - { shouldSort :: Bool -- ^ should table keys be sorted or not - , indent :: Int -- ^ indentation size - } deriving (Show) + { {- | How table keys should be sorted, if at all. + @since 1.1.1.0 + -} + printOptionsSorting :: !(Maybe (Key -> Key -> Ordering)) + + {- | Number of spaces by which to indent. + -} + , printOptionsIndent :: !Int + } + {- | Default printing options. 1. Sorts all keys and tables by name. 2. Indents with 2 spaces. -} defaultOptions :: PrintOptions -defaultOptions = PrintOptions True 2 +defaultOptions = PrintOptions (Just compare) 2 {- | Converts 'TOML' type into 'Data.Text.Text' (using 'defaultOptions'). @@ -78,7 +87,7 @@ -> Int -- ^ Current indentation -> Text -- ^ Accumulator for table names -> TOML -- ^ Given 'TOML' - -> [Text] -- ^ Pretty result + -> [Text] -- ^ Pretty result prettyTomlInd options i prefix TOML{..} = concat [ prettyKeyValue options i tomlPairs , prettyTables options i prefix tomlTables @@ -91,7 +100,7 @@ -- | Returns pretty formatted key-value pairs of the 'TOML'. prettyKeyValue :: PrintOptions -> Int -> HashMap Key AnyValue -> [Text] -prettyKeyValue options i = mapOrdered (\kv -> [kvText kv]) options +prettyKeyValue options i = mapOrdered (\kv -> [kvText kv]) options . HashMap.toList where kvText :: (Key, AnyValue) -> Text kvText (k, AnyValue v) = @@ -128,8 +137,14 @@ -- | Returns pretty formatted tables section of the 'TOML'. prettyTables :: PrintOptions -> Int -> Text -> PrefixMap TOML -> [Text] -prettyTables options i pref = mapOrdered (prettyTable . snd) options +prettyTables options i pref asPieces = mapOrdered (prettyTable . snd) options asKeys where + asKeys :: [(Key, PrefixTree TOML)] + asKeys = map (first pieceToKey) $ HashMap.toList asPieces + + pieceToKey :: Piece -> Key + pieceToKey = Key . pure + prettyTable :: PrefixTree TOML -> [Text] prettyTable (Leaf k toml) = let name = addPrefix k pref @@ -153,7 +168,7 @@ prettyTableName n = "[" <> n <> "]" prettyTableArrays :: PrintOptions -> Int -> Text -> HashMap Key (NonEmpty TOML) -> [Text] -prettyTableArrays options i pref = mapOrdered arrText options +prettyTableArrays options i pref = mapOrdered arrText options . HashMap.toList where arrText :: (Key, NonEmpty TOML) -> [Text] arrText (k, ne) = @@ -171,13 +186,13 @@ -- Returns an indentation prefix tabWith :: PrintOptions -> Int -> Text -tabWith options n = Text.replicate (n * indent options) " " +tabWith PrintOptions{..} n = Text.replicate (n * printOptionsIndent) " " -- Returns a proper sorting function -mapOrdered :: Ord k => ((k, v) -> [t]) -> PrintOptions -> HashMap k v -> [t] -mapOrdered f options - | shouldSort options = concatMap f . sortOn fst . HashMap.toList - | otherwise = concatMap f . HashMap.toList +mapOrdered :: ((Key, v) -> [t]) -> PrintOptions -> [(Key, v)] -> [t] +mapOrdered f options = case printOptionsSorting options of + Just sorter -> concatMap f . sortBy (sorter `on` fst) + Nothing -> concatMap f -- Adds next part of the table name to the accumulator. addPrefix :: Key -> Text -> Text diff --git a/test/Test/Toml/BiCode/Property.hs b/test/Test/Toml/BiCode/Property.hs --- a/test/Test/Toml/BiCode/Property.hs +++ b/test/Test/Toml/BiCode/Property.hs @@ -31,30 +31,30 @@ tripping bigType (encode bigTypeCodec) (decode bigTypeCodec) data BigType = BigType - { btBool :: Bool - , btInteger :: Integer - , btNatural :: Natural - , btInt :: Int - , btWord :: Word - , btDouble :: Batman Double - , btFloat :: Batman Float - , btText :: Text - , btString :: String - , btBS :: ByteString - , btLazyBS :: L.ByteString - , btLocalTime :: LocalTime - , btDay :: Day - , btTimeOfDay :: TimeOfDay - , btArray :: [Int] - , btArraySet :: Set Word - , btArrayIntSet :: IntSet - , btArrayHashSet :: HashSet Natural - , btArrayNonEmpty :: NonEmpty Text - , btNonEmpty :: NonEmpty ByteString - , btList :: [Bool] - , btNewtype :: BigTypeNewtype - , btSum :: BigTypeSum - , btRecord :: BigTypeRecord + { btBool :: !Bool + , btInteger :: !Integer + , btNatural :: !Natural + , btInt :: !Int + , btWord :: !Word + , btDouble :: !(Batman Double) + , btFloat :: !(Batman Float) + , btText :: !Text + , btString :: !String + , btBS :: !ByteString + , btLazyBS :: !L.ByteString + , btLocalTime :: !LocalTime + , btDay :: !Day + , btTimeOfDay :: !TimeOfDay + , btArray :: ![Int] + , btArraySet :: !(Set Word) + , btArrayIntSet :: !IntSet + , btArrayHashSet :: !(HashSet Natural) + , btArrayNonEmpty :: !(NonEmpty Text) + , btNonEmpty :: !(NonEmpty ByteString) + , btList :: ![Bool] + , btNewtype :: !BigTypeNewtype + , btSum :: !BigTypeSum + , btRecord :: !BigTypeRecord } deriving (Show, Eq) -- | Wrapper over 'Double' and 'Float' to be equal on @NaN@ values. 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 @@ -179,9 +179,9 @@ $ Gen.list (Range.linear 0 5) $ (,) <$> genKey <*> genToml arrays = fmap fromList $ - Gen.list (Range.linear 0 5) $ do + Gen.list (Range.linear 0 10) $ do key <- genKey - arr <- Gen.list (Range.linear 1 5) genToml + arr <- Gen.list (Range.linear 1 10) genToml return (key, NE.fromList arr) -- Date generators 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 @@ -13,7 +13,7 @@ import Toml.Edsl (mkToml, table, tableArray, (=:)) import Toml.Parser.String (textP) -import Toml.Parser.TOML (hasKeyP, tableArrayP, tableP, tomlP, keyP) +import Toml.Parser.TOML (keyP, tomlP) import Toml.Parser.Value (arrayP, boolP, dateTimeP, doubleP, integerP) import Toml.PrefixTree (Key (..), Piece (..), fromList) import Toml.Type (AnyValue (..), TOML (..), UValue (..), Value (..)) @@ -192,69 +192,31 @@ parseInteger "0xaBcDeF" 0xaBcDeF keySpecs :: Spec -keySpecs = do - describe "keyP" $ do - context "when the key is a bare key" $ do - it "can parse keys which contain ASCII letters, digits, underscores, and dashes" $ do - parseKey "key" (makeKey ["key"]) - parseKey "bare_key1" (makeKey ["bare_key1"]) - parseKey "bare-key2" (makeKey ["bare-key2"]) - it "can parse keys which contain only digits" $ - parseKey "1234" (makeKey ["1234"]) - 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"]) - -- it "ignores whitespaces around dot-separated parts" $ +keySpecs = 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" $ 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"]) + -- it "ignores whitespaces around dot-separated parts" $ do -- parseKey "a . b . c. d" (makeKey ["a", "b", "c", "d"]) - 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 (Day day2)) - --xit "can parse a key/value pair when the value is an inline table" $ do - -- pending - it "ignores white spaces around key names and values" $ do - 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=" - - it "can parse a TOML inline table" $ - parseHasKey "table-1={key1 = \"some string\", key2 = 123}" - (makeKey ["table-1"], Right $ tomlFromKeyVal [str, int]) - it "can parse an empty TOML table" $ - parseHasKey "table = {}" (makeKey ["table"], Right $ tomlFromKeyVal []) - it "allows the name of the table to be any valid TOML key" $ do - parseHasKey "dog.\"tater.man\"={}" - (makeKey ["dog", dquote "tater.man"], Right $ tomlFromKeyVal []) - parseHasKey "j.\"ʞ\".'l'={}" - (makeKey ["j", dquote "ʞ", squote "l"], Right $ tomlFromKeyVal []) - textSpecs :: Spec textSpecs = describe "textP" $ do context "when the string is a basic string" $ do @@ -392,91 +354,120 @@ parseDateTime "1979-05-27T00:32:0007:00" (ULocal $ LocalTime day1 (TimeOfDay 0 32 0)) -tableSpecs :: Spec -tableSpecs = do - describe "tableP" $ do +tomlSpecs :: Spec +tomlSpecs = do + describe "Key/values" $ do + it "can parse key/value pairs" $ do + parseToml "x='abcdef'" (tomlFromKeyVal [(makeKey ["x"], AnyValue (Text "abcdef"))]) + parseToml "x=1" (tomlFromKeyVal [(makeKey ["x"], AnyValue (Integer 1))]) + parseToml "x=5.2" (tomlFromKeyVal [(makeKey ["x"], AnyValue (Double 5.2))]) + parseToml "x=true" (tomlFromKeyVal [(makeKey ["x"], AnyValue (Bool True))]) + parseToml "x=[1, 2, 3]" (tomlFromKeyVal [(makeKey ["x"] , AnyValue (Array [Integer 1, Integer 2, Integer 3]))]) + parseToml "x = 1920-12-10" (tomlFromKeyVal [(makeKey ["x"], AnyValue (Day day2))]) + it "ignores white spaces around key names and values" $ do + let toml = tomlFromKeyVal [(makeKey ["x"], AnyValue (Integer 1))] + parseToml "x=1 " toml + parseToml "x= 1" toml + parseToml "x =1" toml + parseToml "x\t= 1 " toml + parseToml "\"x\" = 1" (tomlFromKeyVal [(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" $ + parseToml "x=[1, \n2\n]" (tomlFromKeyVal [(makeKey ["x"], AnyValue (Array [Integer 1, Integer 2]))]) + it "fails if the value is not specified" $ + tomlFailOn "x=" + + describe "tables" $ do it "can parse a TOML table" $ - parseTable "[table-1]\nkey1 = \"some string\"\nkey2 = 123" - (makeKey ["table-1"], tomlFromKeyVal [str, int]) + parseToml "[table] \n key1 = \"some string\"\nkey2 = 123" + $ tomlFromTable [(makeKey ["table"], tomlFromKeyVal [str, int])] it "can parse an empty TOML table" $ - parseTable "[table]" (makeKey ["table"], tomlFromKeyVal []) - it "allows the name of the table to be any valid TOML key" $ do - parseTable "[dog.\"tater.man\"]" - (makeKey ["dog", dquote "tater.man"], tomlFromKeyVal []) - parseTable "[j.\"ʞ\".'l']" - (makeKey ["j", dquote "ʞ", squote "l"], tomlFromKeyVal []) + parseToml "[table]" (tomlFromTable [(makeKey ["table"], mempty)]) it "can parse a table with subarrays" $ do - let arr1 = tomlFromArray [(makeKey ["array"], strT :| [intT])] - parseTable "[table]\n[[table.array]] \nkey1 = \"some string\"\n \ - \ [[table.array]] \nkey2 = 123" (makeKey ["table"], arr1) + let t = tomlFromTable [(makeKey ["table"], tomlFromArray [(makeKey ["array"], strT :| [intT])])] + parseToml "[table] \n [[table.array]] \nkey1 = \"some string\"\n \ + \[[table.array]] \nkey2 = 123" t + it "can parse a TOML inline table" $ + parseToml "table={key1 = \"some string\", key2 = 123}" + (tomlFromTable [(makeKey ["table"], tomlFromKeyVal [str, int])]) + it "can parse an empty inline TOML table" $ + parseToml "table = {}" (tomlFromTable [(makeKey ["table"], mempty)]) + it "allows the name of the table to be any valid TOML key" $ do + parseToml "dog.\"tater.man\"={}" + (tomlFromTable [(makeKey ["dog", dquote "tater.man"], mempty)]) + parseToml "j.\"ʞ\".'l'={}" + (tomlFromTable [(makeKey ["j", dquote "ʞ", squote "l"], mempty)]) - describe "tableArrayP" $ do + describe "array of tables" $ do it "can parse an empty array" $ - parseTableArray "[[tArray]]" (makeKey ["tArray"], mempty :| []) - it "allows the name of the table array to be any valid TOML key" $ do - parseTableArray "[[dog.\"tater.man\"]]" - (makeKey ["dog", dquote "tater.man"], mempty :| []) - parseTableArray "[[j.\"ʞ\".'l']]" - (makeKey ["j", dquote "ʞ", squote "l"], mempty :| []) + parseToml "[[array]]" (tomlFromArray [(makeKey ["array"], mempty :| [])]) it "can parse an array of key/values" $ do - let array = (makeKey ["tArray"], NE.fromList [strT, intT]) - parseTableArray "[[tArray]]\nkey1 = \"some string\"\n \ - \ [[tArray]]\nkey2 = 123" array + let array = tomlFromArray [(makeKey ["array"], NE.fromList [strT, intT])] + parseToml "[[array]]\n key1 = \"some string\"\n \ + \[[array]]\n key2 = 123" array it "can parse an array of tables" $ do let table1 = tomlFromTable [(makeKey ["table1"], strT)] table2 = tomlFromTable [(makeKey ["table2"], intT)] - array = (makeKey ["tArray"], NE.fromList [table1, table2]) - parseTableArray "[[tArray]]\n[tArray.table1] \n key1 = \"some string\"\n \ - \ [[tArray]]\n[tArray.table2] \n key2 = 123" array + array = tomlFromArray [(makeKey ["array"], NE.fromList [table1, table2])] + parseToml "[[array]]\n[array.table1] \n key1 = \"some string\"\n \ + \[[array]]\n[array.table2] \n key2 = 123" array it "can parse an array of array" $ do - let arr = tomlFromArray [(makeKey ["table-1-1"], NE.fromList [strT, intT])] - array = (makeKey ["table-1"], arr :| []) - parseTableArray "[[table-1]]\n[[table-1.table-1-1]] \nkey1 = \"some string\"\n \ - \ [[table-1.table-1-1]] \nkey2 = 123" array + let arr = tomlFromArray [(makeKey ["subarray"], NE.fromList [strT, intT])] + array = tomlFromArray [(makeKey ["array"], arr :| [])] + parseToml "[[array]] \n [[array.subarray]] \nkey1 = \"some string\"\n \ + \[[array.subarray]] \nkey2 = 123" array it "can parse an array of arrays" $ do - let arr1 = (makeKey ["table-1-1"], strT :| []) - arr2 = (makeKey ["table-1-2"], intT :| []) - array = (makeKey ["table-1"], tomlFromArray [arr1, arr2] :| []) - parseTableArray "[[table-1]]\n[[table-1.table-1-1]] \nkey1 = \"some string\"\n \ - \ [[table-1.table-1-2]] \nkey2 = 123" array + let arr1 = (makeKey ["table-1"], strT :| []) + arr2 = (makeKey ["table-2"], intT :| []) + array = tomlFromArray [(makeKey ["array"], tomlFromArray [arr1, arr2] :| [])] + parseToml "[[array]]\n [[array.table-1]] \nkey1 = \"some string\"\n \ + \[[array.table-2]] \nkey2 = 123" array + it "can parse very large arrays" $ do + let array = tomlFromArray [(makeKey ["array"], NE.fromList $ replicate 1000 mempty)] + parseToml (mconcat $ replicate 1000 "[[array]]\n") array + it "can parse an inline array of tables" $ do + let array = tomlFromArray [(makeKey ["table"], NE.fromList [strT, intT])] + parseToml "table = [{key1 = \"some string\"}, {key2 = 123}]" array -tomlSpecs :: Spec -tomlSpecs = describe "tomlP" $ do - it "can parse TOML files" $ - parseToml tomlStr1 toml1 - it "can parse mix of tables and arrays" $ - parseToml tomlStr2 toml2 - where - tomlStr1, tomlStr2 :: Text - tomlStr1 = T.unlines - [ " # This is a TOML document.\n\n" - , "title = \"TOML Example\" # Comment \n\n" - , "[owner]\n" - , " name = \"Tom Preston-Werner\" " - , " enabled = true # First class dates" - ] - tomlStr2 = T.unlines - [ "[[array1]]\n key1 = \"some string\" \n" - , "" - , "[table1] \n key2 = 123 \n" - , "[[array2]]\n key3 = 3.14 \n" - , " [table2] \n key4 = true" - ] + describe "TOML" $ do + it "can parse TOML files" $ + parseToml tomlStr1 toml1 + it "can parse mix of tables and arrays" $ + parseToml tomlStr2 toml2 + where + tomlStr1, tomlStr2 :: Text + tomlStr1 = T.unlines + [ " # This is a TOML document.\n\n" + , "title = \"TOML Example\" # Comment \n\n" + , "[owner]\n" + , " name = \"Tom Preston-Werner\" " + , " enabled = true # First class dates" + ] + tomlStr2 = T.unlines + [ "[[array1]]\n key1 = \"some string\" \n" + , "" + , "[table1] \n key2 = 123 \n" + , "[[array2]]\n key3 = 3.14 \n" + , " [table2] \n key4 = true" + ] - toml1, toml2 :: TOML - toml1 = mkToml $ do - "title" =: "TOML Example" - table "owner" $ do - "name" =: "Tom Preston-Werner" - "enabled" =: Bool True + toml1, toml2 :: TOML + toml1 = mkToml $ do + "title" =: "TOML Example" + table "owner" $ do + "name" =: "Tom Preston-Werner" + "enabled" =: Bool True - toml2 = mkToml $ do - tableArray "array1" $ - "key1" =: "some string" :| [] - table "table1" $ "key2" =: 123 - tableArray "array2" $ - "key3" =: Double 3.14 :| [] - table "table2" $ "key4" =: Bool True + toml2 = mkToml $ do + tableArray "array1" $ + "key1" =: "some string" :| [] + table "table1" $ "key2" =: 123 + tableArray "array2" $ + "key3" =: Double 3.14 :| [] + table "table2" $ "key4" =: Bool True ---------------------------------------------------------------------------- -- Utilities @@ -501,25 +492,20 @@ parseInteger = parseX integerP parseKey :: Text -> Key -> Expectation parseKey = parseX keyP -parseHasKey :: Text -> (Key, Either AnyValue TOML) -> Expectation -parseHasKey = parseX hasKeyP parseText :: Text -> Text -> Expectation parseText = parseX textP -parseTable :: Text -> (Key, TOML) -> Expectation -parseTable = parseX tableP -parseTableArray :: Text -> (Key, NonEmpty TOML) -> Expectation -parseTableArray = parseX tableArrayP + parseToml :: Text -> TOML -> Expectation parseToml = parseX tomlP -arrayFailOn, boolFailOn, dateTimeFailOn, doubleFailOn, hasKeyFailOn, integerFailOn, textFailOn :: Text -> Expectation +arrayFailOn, boolFailOn, dateTimeFailOn, doubleFailOn, integerFailOn, textFailOn, tomlFailOn :: Text -> Expectation arrayFailOn = failOn arrayP boolFailOn = failOn boolP dateTimeFailOn = failOn dateTimeP doubleFailOn = failOn doubleP -hasKeyFailOn = failOn hasKeyP integerFailOn = failOn integerP textFailOn = failOn textP +tomlFailOn = failOn tomlP -- UValue Util diff --git a/test/Test/Toml/Printer/Golden.hs b/test/Test/Toml/Printer/Golden.hs --- a/test/Test/Toml/Printer/Golden.hs +++ b/test/Test/Toml/Printer/Golden.hs @@ -4,13 +4,14 @@ ( test_prettyGolden ) where +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Ord (comparing) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Silver (goldenVsAction) -import Data.List.NonEmpty (NonEmpty ((:|))) import Toml (TOML, Value (..)) -import Toml.Edsl ((=:), mkToml, table, tableArray, empty) -import Toml.PrefixTree ((<|)) +import Toml.Edsl (empty, mkToml, table, tableArray, (=:)) +import Toml.PrefixTree (Key (..), (<|)) import Toml.Printer (PrintOptions (..), defaultOptions, prettyOptions) example :: TOML @@ -34,17 +35,28 @@ noFormatting :: PrintOptions noFormatting = PrintOptions - { shouldSort = False - , indent = 0 + { printOptionsSorting = Nothing + , printOptionsIndent = 0 } +-- | Decorate keys as tuples so spam comes before egg +spamEggDecorate :: Key -> (Int, Key) +spamEggDecorate k + | k == "spam" = (0, "spam") + | k == "egg" = (1, "egg") + | otherwise = (2, k) + +spamEgg :: Key -> Key -> Ordering +spamEgg = comparing spamEggDecorate + 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_sorted_only" noFormatting { printOptionsSorting = Just compare } + , test "pretty_indented_only" noFormatting { printOptionsIndent = 4 } , test "pretty_unformatted" noFormatting + , test "pretty_custom_sorted" noFormatting { printOptionsSorting = Just spamEgg } ] where test name options = diff --git a/test/golden/pretty_custom_sorted.golden b/test/golden/pretty_custom_sorted.golden new file mode 100644 --- /dev/null +++ b/test/golden/pretty_custom_sorted.golden @@ -0,0 +1,26 @@ +a = "a" +b = "bb" +c = "cccc" +d = "ddd" + +[baz] + +[doo] + +[foo] + +[qux.doo] +spam = "!" +egg = "?" + +[[deeper]] +green = true + +[[deeper]] +[deeper.blue] +red = 255 + +[[deepest]] +ping = "pong" + +[[deepest]] diff --git a/tomland.cabal b/tomland.cabal --- a/tomland.cabal +++ b/tomland.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: tomland -version: 1.0.1.0 +version: 1.1.0.0 synopsis: Bidirectional TOML serialization description: Implementation of bidirectional TOML serialization. Simple codecs look like this: @@ -74,6 +74,7 @@ Toml.Bi.Monad Toml.Bi.Map Toml.Edsl + Toml.Generic Toml.Parser Toml.Parser.Core Toml.Parser.String @@ -91,9 +92,9 @@ , containers >= 0.5.7 && < 0.7 , deepseq ^>= 1.4 , hashable ^>= 1.2 - , megaparsec ^>= 7.0.1 + , megaparsec ^>= 7.0.5 , mtl ^>= 2.2 - , parser-combinators + , parser-combinators ^>= 1.1.0 , text ^>= 1.2 , time >= 1.8 && < 1.10 , transformers ^>= 0.5 @@ -141,7 +142,7 @@ , containers >= 0.5.7 && < 0.7 , hashable , hedgehog ^>= 1.0 - , hspec-megaparsec + , hspec-megaparsec ^>= 2.0.0 , megaparsec , tasty ^>= 1.2 , tasty-hedgehog ^>= 1.0.0.0 @@ -171,10 +172,9 @@ -with-rtsopts=-N -O2 - build-depends: base - , aeson + build-depends: aeson , deepseq ^>= 1.4 - , gauge + , gauge ^>= 0.2.4 , htoml ^>= 1.0.0.3 , htoml-megaparsec ^>= 2.1.0.3 , parsec