diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,12 @@ # Revision history for toml-parser -## 1.2.0.0 -- +## 1.2.1.0 -- 2023-07-12 + +* Added `Toml.Pretty.prettyTomlOrdered` to allow user-specified section ordering. +* Added `FromValue` and `ToValue` instances for `Text` +* Added `reqKeyOf` and `optKeyOf` for easier custom matching without `FromValue` instances. + +## 1.2.0.0 -- 2023-07-09 * Remove `FromTable` class. This class existed for things that could be matched specifically from tables, which is what the top-level values diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -0,0 +1,163 @@ +# TOML Parser + +This package implements a validating parser for [TOML 1.0.0](https://toml.io/en/v1.0.0). + +This package uses an [alex](https://haskell-alex.readthedocs.io/en/latest/)-generated +lexer and [happy](https://haskell-happy.readthedocs.io/en/latest/)-generated parser. + +It also provides a pair of classes for serializing into and out of TOML. + +## Package Structure + +```mermaid +--- +title: Package Structure +--- +stateDiagram-v2 + classDef important font-weight:bold; + + TOML:::important --> ApplicationTypes:::important : decode + ApplicationTypes --> TOML : encode + TOML --> [Token]: Toml.Lexer + [Token] --> [Expr]: Toml.Parser + [Expr] --> Table : Toml.Semantics + Table --> ApplicationTypes : Toml.FromValue + ApplicationTypes --> Table : Toml.ToValue + Table --> TOML : Toml.Pretty + +``` + +The highest-level interface to this package is to define `FromValue` and `ToTable` +instances for your application-specific datatypes. These can be used with `encode` +and `decode` to convert to and from TOML. + +For low-level access to the TOML format, the lexer, parser, and validator are available +for direct use. The diagram above shows how the different modules enable you to +advance through the increasingly high-level TOML representations. + +## Examples + +This file uses [markdown-unlit](https://hackage.haskell.org/package/markdown-unlit) +to ensure that its code typechecks and stays in sync with the rest of the package. + +```haskell +import Toml (parse, decode, Value(..)) +import Toml.FromValue (FromValue(fromValue), parseTableFromValue, reqKey, optKey) +import Toml.FromValue.Generic (genericParseTable) +import Toml.ToValue (ToValue(toValue), ToTable(toTable), defaultTableToValue) +import Toml.ToValue.Generic (genericToTable) +import GHC.Generics (Generic) +main = pure () +``` + +### Using the raw parser + +Consider this sample TOML text from the specification. + +```toml +[[fruits]] +name = "apple" + +[fruits.physical] # subtable +color = "red" +shape = "round" + +[[fruits.varieties]] # nested array of tables +name = "red delicious" + +[[fruits.varieties]] +name = "granny smith" + + +[[fruits]] +name = "banana" + +[[fruits.varieties]] +name = "plantain" +``` + +Parsing using this package generates the following value + +```haskell ignore +>>> parse fruitStr +Right (fromList [ + ("fruits",Array [ + Table (fromList [ + ("name",String "apple"), + ("physical",Table (fromList [ + ("color",String "red"), + ("shape",String "round")])), + ("varieties",Array [ + Table (fromList [("name",String "red delicious")]), + Table (fromList [("name",String "granny smith")])])]), + Table (fromList [ + ("name",String "banana"), + ("varieties",Array [ + Table (fromList [("name",String "plantain")])])])])]) +``` + +We can render this parsed value back to TOML text using `prettyToml fruitToml`. +In this case the input was already sorted, so the generated text will happen +to match almost exactly. + +### Using decoding classes + +Here's an example of defining datatypes and deserializers for the TOML above. + +```haskell +newtype Fruits = Fruits [Fruit] + deriving (Eq, Show) + +data Fruit = Fruit String (Maybe Physical) [Variety] + deriving (Eq, Show) + +data Physical = Physical String String + deriving (Eq, Show) + +newtype Variety = Variety String + deriving (Eq, Show) + +instance FromValue Fruits where + fromValue = parseTableFromValue (Fruits <$> reqKey "fruits") + +instance FromValue Fruit where + fromValue = parseTableFromValue (Fruit <$> reqKey "name" <*> optKey "physical" <*> reqKey "varieties") + +instance FromValue Physical where + fromValue = parseTableFromValue (Physical <$> reqKey "color" <*> reqKey "shape") + +instance FromValue Variety where + fromValue = parseTableFromValue (Variety <$> reqKey "name") +``` + +We can run this example on the original value to deserialize it into domain-specific datatypes. + +```haskell ignore +>>> decode fruitStr :: Result Fruits +Success [] (Fruits [ + Fruit "apple" (Just (Physical "red" "round")) [Variety "red delicious", Variety "granny smith"], + Fruit "banana" Nothing [Variety "plantain"]]) +``` + +### Generics + +Code for generating and matching tables to records can be derived +using GHC.Generics. This will generate tables using the field names +as table keys. + +```haskell +data ExampleRecord = ExampleRecord { + exString :: String, + exList :: [Int], + exOpt :: Maybe Bool} + deriving (Show, Generic, Eq) + +instance FromValue ExampleRecord where fromValue = parseTableFromValue genericParseTable +instance ToTable ExampleRecord where toTable = genericToTable +instance ToValue ExampleRecord where toValue = defaultTableToValue +``` + +### Larger Example + +A demonstration of using this package at a more realistic scale +can be found in [HieDemoSpec](test/HieDemoSpec.hs). diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -35,8 +35,23 @@ for direct use. The diagram above shows how the different modules enable you to advance through the increasingly high-level TOML representations. -## Example +## Examples +This file uses [markdown-unlit](https://hackage.haskell.org/package/markdown-unlit) +to ensure that its code typechecks and stays in sync with the rest of the package. + +```haskell +import Toml (parse, decode, Value(..)) +import Toml.FromValue (FromValue(fromValue), parseTableFromValue, reqKey, optKey) +import Toml.FromValue.Generic (genericParseTable) +import Toml.ToValue (ToValue(toValue), ToTable(toTable), defaultTableToValue) +import Toml.ToValue.Generic (genericToTable) +import GHC.Generics (Generic) +main = pure () +``` + +### Using the raw parser + Consider this sample TOML text from the specification. ```toml @@ -63,9 +78,8 @@ Parsing using this package generates the following value -```haskell ->>> Right fruitToml = parse fruitStr ->>> fruitToml +```haskell ignore +>>> parse fruitStr Right (fromList [ ("fruits",Array [ Table (fromList [ @@ -86,6 +100,8 @@ In this case the input was already sorted, so the generated text will happen to match almost exactly. +### Using decoding classes + Here's an example of defining datatypes and deserializers for the TOML above. ```haskell @@ -104,7 +120,7 @@ instance FromValue Fruits where fromValue = parseTableFromValue (Fruits <$> reqKey "fruits") -instance FroValue Fruit where +instance FromValue Fruit where fromValue = parseTableFromValue (Fruit <$> reqKey "name" <*> optKey "physical" <*> reqKey "varieties") instance FromValue Physical where @@ -116,14 +132,14 @@ We can run this example on the original value to deserialize it into domain-specific datatypes. -```haskell ->>> decode fruitToml :: Either String Fruits -Right (Fruits [ +```haskell ignore +>>> decode fruitStr :: Result Fruits +Success [] (Fruits [ Fruit "apple" (Just (Physical "red" "round")) [Variety "red delicious", Variety "granny smith"], Fruit "banana" Nothing [Variety "plantain"]]) ``` -## Generics +### Generics Code for generating and matching tables to records can be derived using GHC.Generics. This will generate tables using the field names @@ -141,7 +157,7 @@ instance ToValue ExampleRecord where toValue = defaultTableToValue ``` -## Larger Example +### Larger Example A demonstration of using this package at a more realistic scale can be found in [HieDemoSpec](test/HieDemoSpec.hs). diff --git a/src/Toml/FromValue.hs b/src/Toml/FromValue.hs --- a/src/Toml/FromValue.hs +++ b/src/Toml/FromValue.hs @@ -34,8 +34,10 @@ ParseTable, runParseTable, parseTableFromValue, - optKey, reqKey, + optKey, + reqKeyOf, + optKeyOf, warnTable, KeyAlt(..), pickKey, @@ -46,7 +48,7 @@ liftMatcher, ) where -import Control.Applicative (Alternative, optional) +import Control.Applicative (Alternative) import Control.Monad (MonadPlus, zipWithM) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State.Strict (StateT(..), put, get) @@ -55,13 +57,15 @@ import Data.Map (Map) import Data.Map qualified as Map import Data.String (IsString (fromString)) +import Data.Text qualified +import Data.Text.Lazy qualified import Data.Time (ZonedTime, LocalTime, Day, TimeOfDay) import Data.Word (Word8, Word16, Word32, Word64) import Numeric.Natural (Natural) import Toml.FromValue.Matcher (Matcher, Result(..), runMatcher, withScope, warning, inIndex, inKey) +import Toml.FromValue.ParseTable import Toml.Pretty (prettySimpleKey, prettyValue) import Toml.Value (Value(..), Table) -import Toml.FromValue.ParseTable -- | Class for types that can be decoded from a TOML value. class FromValue a where @@ -143,7 +147,19 @@ listFromValue (String xs) = pure xs listFromValue v = typeError "string" v +-- | Matches string literals +instance FromValue Data.Text.Text where + fromValue v = Data.Text.pack <$> fromValue v + +-- | Matches string literals +-- +-- @since 1.2.1.0 +instance FromValue Data.Text.Lazy.Text where + fromValue v = Data.Text.Lazy.pack <$> fromValue v + -- | Matches floating-point and integer values +-- +-- @since 1.2.1.0 instance FromValue Double where fromValue (Float x) = pure x fromValue (Integer x) = pure (fromInteger x) @@ -188,10 +204,35 @@ instance FromValue Value where fromValue = pure --- | Match a table entry by key if it exists or return 'Nothing' if not. +-- | Convenience function for matching an optional key with a 'FromValue' +-- instance. +-- +-- @optKey key = 'optKeyOf' key 'fromValue'@ optKey :: FromValue a => String -> ParseTable (Maybe a) -optKey = optional . reqKey +optKey key = optKeyOf key fromValue --- | Match a table entry by key or report an error if missing. +-- | Convenience function for matching a required key with a 'FromValue' +-- instance. +-- +-- @reqKey key = 'reqKeyOf' key 'fromValue'@ reqKey :: FromValue a => String -> ParseTable a -reqKey key = pickKey [Key key fromValue] +reqKey key = reqKeyOf key fromValue + +-- | Match a table entry by key if it exists or return 'Nothing' if not. +-- If the key is defined, it is matched by the given function. +-- +-- See 'pickKey' for more complex cases. +optKeyOf :: + String {- ^ key -} -> + (Value -> Matcher a) {- ^ value matcher -} -> + ParseTable (Maybe a) +optKeyOf key k = pickKey [Key key (fmap Just . k), Else (pure Nothing)] + +-- | Match a table entry by key or report an error if missing. +-- +-- See 'pickKey' for more complex cases. +reqKeyOf :: + String {- ^ key -} -> + (Value -> Matcher a) {- ^ value matcher -} -> + ParseTable a +reqKeyOf key k = pickKey [Key key k] diff --git a/src/Toml/FromValue/Matcher.hs b/src/Toml/FromValue/Matcher.hs --- a/src/Toml/FromValue/Matcher.hs +++ b/src/Toml/FromValue/Matcher.hs @@ -61,9 +61,13 @@ -- messages can occur when multiple alternatives all fail. Resolving any -- one of the error messages could allow the computation to succeed. data Result a - = Failure [String] -- error messages - | Success [String] a -- warnings and result - deriving (Read, Show, Eq, Ord) + = Failure [String] -- ^ error messages + | Success [String] a -- ^ warning messages and result + deriving ( + Read {- ^ Default instance -}, + Show {- ^ Default instance -}, + Eq {- ^ Default instance -}, + Ord {- ^ Default instance -}) -- | Run a 'Matcher' with an empty scope. runMatcher :: Matcher a -> Result a diff --git a/src/Toml/FromValue/ParseTable.hs b/src/Toml/FromValue/ParseTable.hs --- a/src/Toml/FromValue/ParseTable.hs +++ b/src/Toml/FromValue/ParseTable.hs @@ -31,7 +31,7 @@ getTable, ) where -import Control.Applicative (Alternative) +import Control.Applicative (Alternative, empty) import Control.Monad (MonadPlus) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State.Strict (StateT(..), get, put) @@ -44,7 +44,7 @@ -- | A 'Matcher' that tracks a current set of unmatched key-value -- pairs from a table. -- --- Use 'optKey' and 'reqKey' to extract keys. +-- Use 'Toml.FromValue.optKey' and 'Toml.FromValue.reqKey' to extract keys. -- -- Use 'getTable' and 'setTable' to override the table and implement -- other primitives. @@ -99,16 +99,16 @@ -- If no keys match, an error message is generated explaining which keys -- would have been accepted. -- --- This is provided as an alternative to chaining multiple 'reqKey' cases --- together with @('<|>')@ because that will generate one error message for --- each unmatched alternative as well as the error associate with the --- matched alternative. +-- This is provided as an alternative to chaining multiple +-- 'Toml.FromValue.reqKey' cases together with @('<|>')@ because that will +-- generate one error message for each unmatched alternative as well as +-- the error associate with the matched alternative. -- -- @since 1.2.0.0 pickKey :: [KeyAlt a] -> ParseTable a pickKey xs = do t <- getTable - foldr (f t) (fail errMsg) xs + foldr (f t) errCase xs where f t (Else m) _ = liftMatcher m f t (Key k c) continue = @@ -118,8 +118,8 @@ do setTable $! Map.delete k t liftMatcher (inKey k (c v)) - errMsg = + errCase = case xs of - [] -> "no alternatives" - [Key k _] -> "missing key: " ++ show (prettySimpleKey k) - _ -> "possible keys: " ++ intercalate ", " [show (prettySimpleKey k) | Key k _ <- xs] + [] -> empty -- there's nothing a user can do here + [Key k _] -> fail ("missing key: " ++ show (prettySimpleKey k)) + _ -> fail ("possible keys: " ++ intercalate ", " [show (prettySimpleKey k) | Key k _ <- xs]) diff --git a/src/Toml/Located.hs b/src/Toml/Located.hs --- a/src/Toml/Located.hs +++ b/src/Toml/Located.hs @@ -17,7 +17,12 @@ -- | A value annotated with its text file position data Located a = Located - { locPosition :: {-# UNPACK #-} !Position - , locThing :: !a + { locPosition :: {-# UNPACK #-} !Position -- ^ position + , locThing :: !a -- ^ thing at position } - deriving (Read, Show, Functor, Foldable, Traversable) + deriving ( + Read {- ^ Default instance -}, + Show {- ^ Default instance -}, + Functor {- ^ Default instance -}, + Foldable {- ^ Default instance -}, + Traversable {- ^ Default instance -}) diff --git a/src/Toml/Position.hs b/src/Toml/Position.hs --- a/src/Toml/Position.hs +++ b/src/Toml/Position.hs @@ -9,6 +9,8 @@ in files while doing lexing and parsing for providing more useful error messages. +This module assumes 8 column wide tab stops. + -} module Toml.Position ( Position(..), @@ -17,9 +19,15 @@ ) where -- | A position in a text file -data Position = Position - { posIndex, posLine, posColumn :: {-# UNPACK #-} !Int } - deriving (Read, Show, Ord, Eq) +data Position = Position { + posIndex :: {-# UNPACK #-} !Int, -- ^ code-point index (zero-based) + posLine :: {-# UNPACK #-} !Int, -- ^ line index (one-based) + posColumn :: {-# UNPACK #-} !Int -- ^ column index (one-based) + } deriving ( + Read {- ^ Default instance -}, + Show {- ^ Default instance -}, + Ord {- ^ Default instance -}, + Eq {- ^ Default instance -}) -- | The initial 'Position' for the start of a file startPos :: Position diff --git a/src/Toml/Pretty.hs b/src/Toml/Pretty.hs --- a/src/Toml/Pretty.hs +++ b/src/Toml/Pretty.hs @@ -1,4 +1,4 @@ -{-# Language OverloadedStrings #-} +{-# Language OverloadedStrings, GADTs #-} {-| Module : Toml.Pretty Description : Human-readable representations for error messages @@ -20,22 +20,23 @@ TomlDoc, DocClass(..), - -- * semantic values + -- * Printing semantic values prettyToml, + prettyTomlOrdered, prettyValue, - -- * syntactic components + -- * Printing syntactic components prettyToken, prettySectionKind, - -- * keys + -- * Printing keys prettySimpleKey, prettyKey, ) where import Data.Char (ord, isAsciiLower, isAsciiUpper, isDigit, isPrint) import Data.Foldable (fold) -import Data.List (partition) +import Data.List (partition, sortOn) import Data.List.NonEmpty (NonEmpty((:|))) import Data.List.NonEmpty qualified as NonEmpty import Data.Map qualified as Map @@ -136,7 +137,8 @@ go ks v = prettyKey (NonEmpty.reverse ks) <+> equals <+> prettyValue v -- | Render a value suitable for assignment on the right-hand side --- of an equals sign. This value will always occupy a single line. +-- of an equals sign. This value will always use inline table and list +-- syntax. prettyValue :: Value -> TomlDoc prettyValue = \case Integer i -> annotate NumberClass (pretty i) @@ -172,23 +174,82 @@ isTable :: Value -> Bool isTable Table {} = True -isTable _ = False +isTable _ = False isSingularTable :: Table -> Bool -isSingularTable (Map.elems -> [Table v]) = isSingularTable v -isSingularTable (Map.elems -> [v]) = isAlwaysSimple v -isSingularTable _ = False +isSingularTable (Map.elems -> [v]) = isAlwaysSimple v +isSingularTable _ = False --- | Render a complete TOML document using top-level table --- and array of table sections where appropriate. -prettyToml :: Table -> TomlDoc -prettyToml = prettyToml_ TableKind [] +-- | Render a complete TOML document using top-level table and array of +-- table sections where possible. +-- +-- Keys are sorted alphabetically. To provide a custom ordering, see +-- 'prettyTomlOrdered'. +prettyToml :: + Table {- ^ table to print -} -> + TomlDoc {- ^ TOML syntax -} +prettyToml = prettyToml_ NoProjection TableKind [] -prettyToml_ :: SectionKind -> [String] -> Table -> TomlDoc -prettyToml_ kind prefix t = vcat (topLines ++ subtables) +-- | Render a complete TOML document like 'prettyToml' but use a +-- custom key ordering. The comparison function has access to the +-- complete key path. Note that only keys in the same table will +-- every be compared. +-- +-- This operation allows you to render your TOML files with the +-- most important sections first. A TOML file describing a package +-- might desire to have the @[package]@ section first before any +-- of the ancilliary configuration sections. +-- +-- The /table path/ is the name of the table being sorted. This allows +-- the projection to be aware of which table is being sorted. +-- +-- The /key/ is the key in the table being sorted. These are the +-- keys that will be compared to each other. +-- +-- Here's a projection that puts the @package@ section first, the +-- @secondary@ section second, and then all remaining cases are +-- sorted alphabetically afterward. +-- +-- @ +-- example :: [String] -> String -> Either Int String +-- example [] "package" = Left 1 +-- example [] "second" = Left 2 +-- example _ other = Right other +-- @ +-- +-- We could also put the tables in reverse-alphabetical order +-- by leveraging an existing newtype. +-- +-- @ +-- reverseOrderProj :: [String] -> String -> Down String +-- reverseOrderProj _ = Down +-- @ +-- +-- @since 1.2.1.0 +prettyTomlOrdered :: + Ord a => + ([String] -> String -> a) {- ^ table path -> key -> projection -} -> + Table {- ^ table to print -} -> + TomlDoc {- ^ TOML syntax -} +prettyTomlOrdered proj = prettyToml_ (KeyProjection proj) TableKind [] + +-- | Optional projection used to order rendered tables +data KeyProjection where + -- | No projection provided; alphabetical order used + NoProjection :: KeyProjection + -- | Projection provided: table name and current key are available + KeyProjection :: Ord a => ([String] -> String -> a) -> KeyProjection + +prettyToml_ :: KeyProjection -> SectionKind -> [String] -> Table -> TomlDoc +prettyToml_ mbKeyProj kind prefix t = vcat (topLines ++ subtables) where - (simple, sections) = partition (isAlwaysSimple . snd) (Map.assocs t) + order = + case mbKeyProj of + NoProjection -> id + KeyProjection f -> sortOn (f prefix . fst) + (simple, sections) = partition (isAlwaysSimple . snd) (order (Map.assocs t)) + topLines = [fold topElts | let topElts = headers ++ assignments, not (null topElts)] headers = @@ -201,13 +262,13 @@ subtables = [prettySection (prefix `snoc` k) v | (k,v) <- sections] + prettySection key (Table t) = + prettyToml_ mbKeyProj TableKind (NonEmpty.toList key) t + prettySection key (Array a) = + vcat [prettyToml_ mbKeyProj ArrayTableKind (NonEmpty.toList key) t | Table t <- a] + prettySection _ _ = error "prettySection applied to simple value" + +-- | Create a 'NonEmpty' with a given prefix and last element. snoc :: [a] -> a -> NonEmpty a snoc [] y = y :| [] snoc (x : xs) y = x :| xs ++ [y] - -prettySection :: NonEmpty String -> Value -> TomlDoc -prettySection key (Table t) = - prettyToml_ TableKind (NonEmpty.toList key) t -prettySection key (Array a) = - vcat [prettyToml_ ArrayTableKind (NonEmpty.toList key) t | Table t <- a] -prettySection _ _ = error "prettySection applied to simple value" diff --git a/src/Toml/Semantics.hs b/src/Toml/Semantics.hs --- a/src/Toml/Semantics.hs +++ b/src/Toml/Semantics.hs @@ -36,7 +36,7 @@ m1 <- assignKeyVals topKVs Map.empty m2 <- foldM (\m (kind, key, kvs) -> addSection kind kvs key m) m1 tables - pure (fmap frameToValue m2) + pure (framesToTable m2) -- | Line number, key, value type KeyVals = [(Key, Val)] @@ -71,11 +71,15 @@ | Closed -- ^ table closed to further extension deriving Show -frameToValue :: Frame -> Value -frameToValue = \case - FrameTable _ t -> Table (frameToValue <$> t) - FrameArray a -> Array (reverse (Table . fmap frameToValue <$> NonEmpty.toList a)) - FrameValue v -> v +framesToTable :: Map String Frame -> Table +framesToTable = + fmap \case + FrameTable _ t -> Table (framesToTable t) + FrameArray a -> Array (toArray a) + FrameValue v -> v + where + -- reverses the list while converting the frames to tables + toArray = foldl (\acc frame -> Table (framesToTable frame) : acc) [] constructTable :: [(Key, Value)] -> Either String Table constructTable entries = diff --git a/src/Toml/ToValue.hs b/src/Toml/ToValue.hs --- a/src/Toml/ToValue.hs +++ b/src/Toml/ToValue.hs @@ -30,6 +30,8 @@ import Data.Int (Int8, Int16, Int32, Int64) import Data.Map (Map) import Data.Map qualified as Map +import Data.Text qualified +import Data.Text.Lazy qualified import Data.Time (Day, TimeOfDay, LocalTime, ZonedTime) import Data.Word (Word8, Word16, Word32, Word64) import Numeric.Natural (Natural) @@ -81,6 +83,7 @@ defaultTableToValue :: ToTable a => a -> Value defaultTableToValue = Table . toTable +-- | Identity function instance ToValue Value where toValue = id @@ -89,6 +92,18 @@ instance ToValue Char where toValue x = String [x] toValueList = String + +-- | Encodes as string literal +-- +-- @since 1.2.1.0 +instance ToValue Data.Text.Text where + toValue = toValue . Data.Text.unpack + +-- | Encodes as string literal +-- +-- @since 1.2.1.0 +instance ToValue Data.Text.Lazy.Text where + toValue = toValue . Data.Text.Lazy.unpack -- | This instance defers to the list element's 'toValueList' implementation. instance ToValue a => ToValue [a] where diff --git a/src/Toml/Value.hs b/src/Toml/Value.hs --- a/src/Toml/Value.hs +++ b/src/Toml/Value.hs @@ -35,7 +35,15 @@ | ZonedTime ZonedTime | LocalTime LocalTime | Day Day - deriving (Show, Read, Data, Generic) + deriving ( + Show {- ^ Default instance -}, + Read {- ^ Default instance -}, + Data {- ^ Default instance -}, + Generic {- ^ Default instance -}) + +-- | Nearly default instance except 'ZonedTime' doesn't have an +-- 'Eq' instance. 'ZonedTime' values are equal if their times and +-- timezones are both equal. instance Eq Value where Integer x == Integer y = x == y diff --git a/test/DecodeSpec.hs b/test/DecodeSpec.hs --- a/test/DecodeSpec.hs +++ b/test/DecodeSpec.hs @@ -123,7 +123,7 @@ "unexpected keys: count, taste in top.fruits[0]", "unexpected key: color in top.fruits[1]"] (Fruits [Fruit "peach" Nothing [], Fruit "pineapple" Nothing []]) - + it "handles missing key errors" $ (decode "[[fruits]]" :: Result Fruits) `shouldBe` diff --git a/test/FromValueSpec.hs b/test/FromValueSpec.hs new file mode 100644 --- /dev/null +++ b/test/FromValueSpec.hs @@ -0,0 +1,105 @@ +{-| +Module : FromValueSpec +Description : Exercise various components of FromValue +Copyright : (c) Eric Mertens, 2023 +License : ISC +Maintainer : emertens@gmail.com + +-} +module FromValueSpec (spec) where + +import Control.Applicative ((<|>), empty) +import Test.Hspec (it, shouldBe, Spec) +import Toml (Result(..), Value(..)) +import Toml.FromValue (Result(..), FromValue(fromValue), optKey, parseTableFromValue, reqKey, warnTable, pickKey) +import Toml.FromValue.Matcher (runMatcher) +import Toml.ToValue (table) +import Control.Monad (when) +import Toml.FromValue.ParseTable (KeyAlt(..)) + +spec :: Spec +spec = + do it "handles one reqKey" $ + runMatcher (parseTableFromValue (reqKey "test") (table [("test", String "val")])) + `shouldBe` + Success [] "val" + + it "handles one optKey" $ + runMatcher (parseTableFromValue (optKey "test") (table [("test", String "val")])) + `shouldBe` + Success [] (Just "val") + + it "handles one missing optKey" $ + runMatcher (parseTableFromValue (optKey "test") (table [("nottest", String "val")])) + `shouldBe` + Success ["unexpected key: nottest in top"] (Nothing :: Maybe String) + + it "handles one missing reqKey" $ + runMatcher (parseTableFromValue (reqKey "test") (table [("nottest", String "val")])) + `shouldBe` + (Failure ["missing key: test in top"] :: Result String) + + it "handles one mismatched reqKey" $ + runMatcher (parseTableFromValue (reqKey "test") (table [("test", String "val")])) + `shouldBe` + (Failure ["type error. wanted: integer got: string in top.test"] :: Result Integer) + + it "handles one mismatched optKey" $ + runMatcher (parseTableFromValue (optKey "test") (table [("test", String "val")])) + `shouldBe` + (Failure ["type error. wanted: integer got: string in top.test"] :: Result (Maybe Integer)) + + it "handles concurrent errors" $ + runMatcher (parseTableFromValue (reqKey "a" <|> empty <|> reqKey "b") (table [])) + `shouldBe` + (Failure ["missing key: a in top", "missing key: b in top"] :: Result Integer) + + it "handles concurrent value mismatch" $ + let v = String "" in + runMatcher (Left <$> fromValue v <|> empty <|> Right <$> fromValue v) + `shouldBe` + (Failure [ + "type error. wanted: boolean got: string in top", + "type error. wanted: integer got: string in top"] + :: Result (Either Bool Int)) + + it "doesn't emit an error for empty" $ + runMatcher (parseTableFromValue empty (table [])) + `shouldBe` + (Failure [] :: Result Integer) + + it "matches single characters" $ + runMatcher (fromValue (String "x")) + `shouldBe` + Success [] 'x' + + it "rejections non-single characters" $ + runMatcher (fromValue (String "xy")) + `shouldBe` + (Failure ["type error. wanted: character got: string in top"] :: Result Char) + + it "collects warnings in table matching" $ + let pt = + do i1 <- reqKey "k1" + i2 <- reqKey "k2" + let n = i1 + i2 + when (odd n) (warnTable "k1 and k2 sum to an odd value") + pure n + in + runMatcher (parseTableFromValue pt (table [("k1", Integer 1), ("k2", Integer 2)])) + `shouldBe` + Success ["k1 and k2 sum to an odd value in top"] (3 :: Integer) + + it "offers helpful messages when no keys match" $ + let pt = pickKey [Key "this" \_ -> pure 'a', Key "." \_ -> pure 'b'] + in + runMatcher (parseTableFromValue pt (table [])) + `shouldBe` + (Failure ["possible keys: this, \".\" in top"] :: Result Char) + + it "generates an error message on an empty pickKey" $ + let pt = pickKey [] + in + runMatcher (parseTableFromValue pt (table [])) + `shouldBe` + (Failure [] :: Result Char) diff --git a/test/HieDemoSpec.hs b/test/HieDemoSpec.hs --- a/test/HieDemoSpec.hs +++ b/test/HieDemoSpec.hs @@ -331,7 +331,7 @@ [cradle.cabal] cabalProject = "cabal.project" - + [[cradle.cabal.components]] path = "./src" component = "toml-parser:lib:toml-parser" diff --git a/test/LexerSpec.hs b/test/LexerSpec.hs --- a/test/LexerSpec.hs +++ b/test/LexerSpec.hs diff --git a/test/QuoteStr.hs b/test/QuoteStr.hs --- a/test/QuoteStr.hs +++ b/test/QuoteStr.hs @@ -27,7 +27,7 @@ processString :: String -> ExpQ processString ('\n':xs) = let ws = takeWhile (' '==) xs - + cleanup "" = pure "" cleanup x = case stripPrefix ws x of Nothing -> fail "bad prefix" diff --git a/test/ToValueSpec.hs b/test/ToValueSpec.hs --- a/test/ToValueSpec.hs +++ b/test/ToValueSpec.hs @@ -8,9 +8,9 @@ spec = do it "converts characters as singleton strings" $ toValue '!' `shouldBe` String "!" - + it "converts strings normally" $ toValue "demo" `shouldBe` String "demo" - + it "converts lists" $ toValue [1,2,3::Int] `shouldBe` Array [Integer 1, Integer 2, Integer 3] diff --git a/toml-parser.cabal b/toml-parser.cabal --- a/toml-parser.cabal +++ b/toml-parser.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: toml-parser -version: 1.2.0.0 +version: 1.2.1.0 synopsis: TOML 1.0.0 parser description: TOML parser using generated lexers and parsers with @@ -13,7 +13,7 @@ copyright: 2023 Eric Mertens category: Text build-type: Simple -tested-with: GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.8, GHC == 9.4.5, GHC == 9.6.2 +tested-with: GHC == {8.10.7, 9.0.2, 9.2.8, 9.4.5, 9.6.2} extra-doc-files: ChangeLog.md @@ -66,11 +66,12 @@ Toml.Value build-depends: array ^>= 0.5, - base >= 4.14 && < 4.19, - containers ^>= 0.5 || ^>= 0.6, + base ^>= {4.14, 4.15, 4.16, 4.17, 4.18}, + containers ^>= {0.5, 0.6}, prettyprinter ^>= 1.7, - time >= 1.9 && < 1.13, - transformers ^>= 0.5 || ^>= 0.6, + text >= 0.2 && < 3, + time ^>= {1.9, 1.10, 1.11, 1.12}, + transformers ^>= {0.5, 0.6}, build-tool-depends: alex:alex >= 3.2, happy:happy >= 1.19, @@ -83,19 +84,31 @@ default-extensions: QuasiQuotes build-tool-depends: - hspec-discover:hspec-discover == 2.* + hspec-discover:hspec-discover ^>= 2 build-depends: base, containers, - hspec >= 2.10 && < 2.12, - template-haskell >= 2.16 && < 2.21, + hspec ^>= {2.10, 2.11}, + template-haskell ^>= {2.16, 2.17, 2.18, 2.19, 2.20}, time, toml-parser, other-modules: DecodeSpec + FromValueSpec HieDemoSpec LexerSpec PrettySpec QuoteStr TomlSpec ToValueSpec + +test-suite readme + import: extensions + type: exitcode-stdio-1.0 + main-is: README.lhs + ghc-options: -pgmL markdown-unlit + build-depends: + base, + toml-parser, + build-tool-depends: + markdown-unlit:markdown-unlit ^>= {0.5.1, 0.6.0},