diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +## v0.3.0.0 + +* Drop support for GHC < 9.8 +* Fix compatibility with toml-test 1.5.0 + * Allow specifying new table section in dotted table path + * Error when setting dotted path inside array + ## v0.2.2.0 * Add support for GHC 9.10 + 9.12 diff --git a/src/TOML/Decode.hs b/src/TOML/Decode.hs --- a/src/TOML/Decode.hs +++ b/src/TOML/Decode.hs @@ -52,30 +52,30 @@ import Data.Functor.Identity (Identity (..)) import Data.Int (Int16, Int32, Int64, Int8) import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap +import Data.IntMap qualified as IntMap import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet +import Data.IntSet qualified as IntSet import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty qualified as NonEmpty import Data.Map (Map) -import qualified Data.Map.Strict as Map +import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) -import qualified Data.Monoid as Monoid +import Data.Monoid qualified as Monoid import Data.Proxy (Proxy (..)) import Data.Ratio (Ratio) -import qualified Data.Semigroup as Semigroup +import Data.Semigroup qualified as Semigroup import Data.Sequence (Seq) -import qualified Data.Sequence as Seq +import Data.Sequence qualified as Seq import Data.Set (Set) -import qualified Data.Set as Set +import Data.Set qualified as Set import Data.String (IsString, fromString) import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.IO as Text -import qualified Data.Text.Lazy as Lazy (Text) -import qualified Data.Text.Lazy as Text.Lazy -import qualified Data.Time as Time -import qualified Data.Time.Clock.System as Time +import Data.Text qualified as Text +import Data.Text.IO qualified as Text +import Data.Text.Lazy qualified as Lazy (Text) +import Data.Text.Lazy qualified as Text.Lazy +import Data.Time qualified as Time +import Data.Time.Clock.System qualified as Time import Data.Version (Version, parseVersion) import Data.Void (Void) import Data.Word (Word16, Word32, Word64, Word8) diff --git a/src/TOML/Error.hs b/src/TOML/Error.hs --- a/src/TOML/Error.hs +++ b/src/TOML/Error.hs @@ -13,9 +13,9 @@ import Control.Exception (Exception (..)) import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty qualified as NonEmpty import Data.Text (Text) -import qualified Data.Text as Text +import Data.Text qualified as Text import TOML.Value (Table, Value (..), renderValue) diff --git a/src/TOML/Parser.hs b/src/TOML/Parser.hs --- a/src/TOML/Parser.hs +++ b/src/TOML/Parser.hs @@ -28,19 +28,19 @@ #endif import Data.Functor (($>)) import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) import Data.Text (Text) -import qualified Data.Text as Text +import Data.Text qualified as Text import Data.Time (Day, LocalTime, TimeOfDay, TimeZone) -import qualified Data.Time as Time +import Data.Time qualified as Time import Data.Void (Void) -import qualified Numeric +import Numeric qualified import Text.Megaparsec hiding (sepBy1) import Text.Megaparsec.Char hiding (space, space1) -import qualified Text.Megaparsec.Char.Lexer as L +import Text.Megaparsec.Char.Lexer qualified as L import TOML.Error (NormalizeError (..), TOMLError (..)) import TOML.Utils.Map (getPathLens) @@ -554,9 +554,10 @@ ValueAtPathOptions { shouldRecurse = \case InlineTable -> False - ImplicitKey -> False + ImplicitKey -> True ExplicitSection -> True ImplicitSection -> True + , recurseArray = True , implicitType = ImplicitSection , makeMidPathNotTableError = nonTableInNestedKeyError sectionKey table } @@ -609,9 +610,10 @@ ValueAtPathOptions { shouldRecurse = \case InlineTable -> False - ImplicitKey -> False + ImplicitKey -> True ExplicitSection -> True ImplicitSection -> True + , recurseArray = True , implicitType = ImplicitSection , makeMidPathNotTableError = \history existingValue -> NonTableInNestedImplicitArrayError @@ -643,6 +645,7 @@ ImplicitKey -> True ExplicitSection -> True ImplicitSection -> recurseImplicitSections + , recurseArray = False , implicitType = ImplicitKey , makeMidPathNotTableError = nonTableInNestedKeyError key table } @@ -674,6 +677,7 @@ data ValueAtPathOptions = ValueAtPathOptions { shouldRecurse :: TableType -> Bool + , recurseArray :: Bool , implicitType :: TableType , makeMidPathNotTableError :: Key -> AnnValue -> NormalizeError } @@ -716,7 +720,8 @@ -- Any reference to an array of tables points to the -- most recently defined table element of the array. Just (GenericArray aMeta vs) - | Just vs' <- NonEmpty.nonEmpty vs + | recurseArray + , Just vs' <- NonEmpty.nonEmpty vs , GenericTable tMeta subTable <- NonEmpty.last vs' -> do when (isStaticArray aMeta) $ normalizeError $ diff --git a/src/TOML/Utils/Map.hs b/src/TOML/Utils/Map.hs --- a/src/TOML/Utils/Map.hs +++ b/src/TOML/Utils/Map.hs @@ -8,7 +8,7 @@ import Data.Foldable (foldlM) import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +import Data.Map.Strict qualified as Map import TOML.Utils.NonEmpty (zipHistory) diff --git a/src/TOML/Utils/NonEmpty.hs b/src/TOML/Utils/NonEmpty.hs --- a/src/TOML/Utils/NonEmpty.hs +++ b/src/TOML/Utils/NonEmpty.hs @@ -6,7 +6,7 @@ import Data.List (scanl') import Data.List.NonEmpty (NonEmpty ((:|))) -import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty qualified as NonEmpty -- | -- Annotates each element with the history of all past elements. diff --git a/src/TOML/Value.hs b/src/TOML/Value.hs --- a/src/TOML/Value.hs +++ b/src/TOML/Value.hs @@ -8,9 +8,9 @@ ) where import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +import Data.Map.Strict qualified as Map import Data.Text (Text) -import qualified Data.Text as Text +import Data.Text qualified as Text import Data.Time (Day, LocalTime, TimeOfDay, TimeZone) type Table = Map Text Value diff --git a/test/specs/Main.hs b/test/specs/Main.hs new file mode 100644 --- /dev/null +++ b/test/specs/Main.hs @@ -0,0 +1,1 @@ +import Skeletest.Main diff --git a/test/specs/TOML/DecodeSpec.hs b/test/specs/TOML/DecodeSpec.hs new file mode 100644 --- /dev/null +++ b/test/specs/TOML/DecodeSpec.hs @@ -0,0 +1,303 @@ +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module TOML.DecodeSpec (spec) where + +import Data.Int (Int8) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Time qualified as Time +import Numeric.Natural (Natural) +import Skeletest +import Skeletest.Predicate qualified as P + +import TOML.Decode ( + DecodeTOML, + Decoder, + decodeWith, + getArrayOf, + getField, + getFieldOpt, + getFieldOptWith, + getFieldOr, + getFieldWith, + getFields, + getFieldsOpt, + getFieldsOptWith, + getFieldsWith, + tomlDecoder, + ) +import TOML.Error ( + ContextItem (..), + DecodeError (..), + TOMLError (..), + ) +import TOML.Value (Value (..)) + +-- | A test decoder +succDecoder :: (Enum a, DecodeTOML a) => Decoder a +succDecoder = succ <$> tomlDecoder + +spec :: Spec +spec = do + describe "getField" $ do + it "decodes field" $ + decodeWith (getField @Int "a") "a = 1" `shouldBe` Right 1 + + it "errors if field does not exist" $ + decodeWith (getField @Int "a") "" `shouldBe` Left (DecodeError [Key "a"] MissingField) + + it "errors if field is the wrong type" $ + decodeWith (getField @Int "a") "a = true" `shouldBe` Left (DecodeError [Key "a"] (TypeMismatch (Boolean True))) + + describe "getFieldOr" $ do + it "decodes field" $ + decodeWith (getFieldOr @Int 42 "a") "a = 1" `shouldBe` Right 1 + + it "returns default if field does not exist" $ + decodeWith (getFieldOr @Int 42 "a") "" `shouldBe` Right 42 + + it "errors if field is the wrong type" $ + decodeWith (getFieldOr @Int 42 "a") "a = true" `shouldBe` Left (DecodeError [Key "a"] (TypeMismatch (Boolean True))) + + describe "getFieldOpt" $ do + it "decodes field" $ + decodeWith (getFieldOpt @Int "a") "a = 1" `shouldBe` Right (Just 1) + + it "returns Nothing if field does not exist" $ + decodeWith (getFieldOpt @Int "a") "" `shouldBe` Right Nothing + + it "errors if field is the wrong type" $ + decodeWith (getFieldOpt @Int "a") "a = true" `shouldBe` Left (DecodeError [Key "a"] (TypeMismatch (Boolean True))) + + describe "getFieldWith" $ do + it "decodes field" $ + decodeWith (getFieldWith @Int succDecoder "a") "a = 1" `shouldBe` Right 2 + + it "errors if field does not exist" $ + decodeWith (getFieldWith @Int succDecoder "a") "" `shouldBe` Left (DecodeError [Key "a"] MissingField) + + it "errors if field is the wrong type" $ + decodeWith (getFieldWith @Int succDecoder "a") "a = true" `shouldBe` Left (DecodeError [Key "a"] (TypeMismatch (Boolean True))) + + describe "getFieldOptWith" $ do + it "decodes field" $ + decodeWith (getFieldOptWith @Int succDecoder "a") "a = 1" `shouldBe` Right (Just 2) + + it "returns Nothing if field does not exist" $ + decodeWith (getFieldOptWith @Int succDecoder "a") "" `shouldBe` Right Nothing + + it "errors if field is the wrong type" $ + decodeWith (getFieldOptWith @Int succDecoder "a") "a = true" `shouldBe` Left (DecodeError [Key "a"] (TypeMismatch (Boolean True))) + + describe "getFields" $ do + it "decodes field" $ + decodeWith (getFields @Int ["a", "b"]) "a = { b = 1 }" `shouldBe` Right 1 + + it "errors if field does not exist" $ + decodeWith (getFields @Int ["a", "b"]) "a = {}" `shouldBe` Left (DecodeError [Key "a", Key "b"] MissingField) + + it "errors if intermediate field does not exist" $ + decodeWith (getFields @Int ["a", "b", "c"]) "a = {}" `shouldBe` Left (DecodeError [Key "a", Key "b"] MissingField) + + it "errors if field is the wrong type" $ + decodeWith (getFields @Int ["a", "b"]) "a = { b = true }" `shouldBe` Left (DecodeError [Key "a", Key "b"] (TypeMismatch (Boolean True))) + + it "errors if intermediate field is the wrong type" $ + decodeWith (getFields @Int ["a", "b", "c"]) "a = { b = true }" `shouldBe` Left (DecodeError [Key "a", Key "b"] (TypeMismatch (Boolean True))) + + describe "getFieldsOpt" $ do + it "decodes field" $ + decodeWith (getFieldsOpt @Int ["a", "b"]) "a = { b = 1 }" `shouldBe` Right (Just 1) + + it "returns Nothing if field does not exist" $ + decodeWith (getFieldsOpt @Int ["a", "b"]) "a = {}" `shouldBe` Right Nothing + + it "returns Nothing if intermediate field does not exist" $ + decodeWith (getFieldsOpt @Int ["a", "b", "c"]) "a = {}" `shouldBe` Right Nothing + + it "errors if field is the wrong type" $ + decodeWith (getFieldsOpt @Int ["a", "b"]) "a = { b = true }" `shouldBe` Left (DecodeError [Key "a", Key "b"] (TypeMismatch (Boolean True))) + + it "errors if intermediate field is the wrong type" $ + decodeWith (getFieldsOpt @Int ["a", "b", "c"]) "a = { b = true }" `shouldBe` Left (DecodeError [Key "a", Key "b"] (TypeMismatch (Boolean True))) + + describe "getFieldsWith" $ do + it "decodes field" $ + decodeWith (getFieldsWith @Int succDecoder ["a", "b"]) "a = { b = 1 }" `shouldBe` Right 2 + + it "errors if field does not exist" $ + decodeWith (getFieldsWith @Int succDecoder ["a", "b"]) "a = {}" `shouldBe` Left (DecodeError [Key "a", Key "b"] MissingField) + + it "errors if intermediate field does not exist" $ + decodeWith (getFieldsWith @Int succDecoder ["a", "b", "c"]) "a = {}" `shouldBe` Left (DecodeError [Key "a", Key "b"] MissingField) + + it "errors if field is the wrong type" $ + decodeWith (getFieldsWith @Int succDecoder ["a", "b"]) "a = { b = true }" `shouldBe` Left (DecodeError [Key "a", Key "b"] (TypeMismatch (Boolean True))) + + it "errors if intermediate field is the wrong type" $ + decodeWith (getFieldsWith @Int succDecoder ["a", "b", "c"]) "a = { b = true }" `shouldBe` Left (DecodeError [Key "a", Key "b"] (TypeMismatch (Boolean True))) + + describe "getFieldsOptWith" $ do + it "decodes field" $ + decodeWith (getFieldsOptWith @Int succDecoder ["a", "b"]) "a = { b = 1 }" `shouldBe` Right (Just 2) + + it "returns Nothing if field does not exist" $ + decodeWith (getFieldsOptWith @Int succDecoder ["a", "b"]) "a = {}" `shouldBe` Right Nothing + + it "returns Nothing if intermediate field does not exist" $ + decodeWith (getFieldsOptWith @Int succDecoder ["a", "b", "c"]) "a = {}" `shouldBe` Right Nothing + + it "errors if field is the wrong type" $ + decodeWith (getFieldsOptWith @Int succDecoder ["a", "b"]) "a = { b = true }" `shouldBe` Left (DecodeError [Key "a", Key "b"] (TypeMismatch (Boolean True))) + + it "errors if intermediate field is the wrong type" $ + decodeWith (getFieldsOptWith @Int succDecoder ["a", "b", "c"]) "a = { b = true }" `shouldBe` Left (DecodeError [Key "a", Key "b"] (TypeMismatch (Boolean True))) + + describe "getArrayOf" $ do + it "decodes field" $ + decodeWith (getFieldWith (getArrayOf @Int succDecoder) "a") "a = [1, 2]" `shouldBe` Right [2, 3] + + it "errors if value is the wrong type" $ + decodeWith (getFieldWith (getArrayOf @Int succDecoder) "a") "a = true" `shouldBe` Left (DecodeError [Key "a"] (TypeMismatch (Boolean True))) + + it "errors if value in array is the wrong type" $ + decodeWith (getFieldWith (getArrayOf @Int succDecoder) "a") "a = [1, 2, true]" `shouldBe` Left (DecodeError [Key "a", Index 2] (TypeMismatch (Boolean True))) + + describe "decoding multiple fields at once" $ do + it "works" $ do + let decoder :: Decoder (Int, Maybe String, Maybe Int, Bool) + decoder = + (,,,) + <$> getField "a" + <*> getFieldOpt "b" + <*> getFieldOpt "missing" + <*> getFields ["c", "d"] + doc = + Text.unlines + [ "a = 1" + , "b = \"hello\"" + , "[c]" + , "d = true" + ] + decodeWith decoder doc `shouldBe` Right (1, Just "hello", Nothing, True) + + describe "DecodeTOML instances" $ do + describe "Bool" $ do + it "decodes successfully" $ do + decodeWith (getField @Bool "a") "a = true" `shouldBe` Right True + decodeWith (getField @Bool "a") "a = false" `shouldBe` Right False + + describe "String" $ do + it "decodes successfully" $ do + decodeWith (getField @String "a") "a = 'z'" `shouldBe` Right "z" + decodeWith (getField @String "a") "a = 'asdf'" `shouldBe` Right "asdf" + + describe "Char" $ do + it "decodes successfully" $ + decodeWith (getField @Char "a") "a = 'z'" `shouldBe` Right 'z' + + it "errors with multi-character string" $ + decodeWith (getField @Char "a") "a = 'asdf'" `shouldFailWith` "Expected single character string" + + describe "Int" $ do + it "decodes successfully" $ do + decodeWith (getField @Int "a") "a = 42" `shouldBe` Right 42 + decodeWith (getField @Int "a") "a = -13" `shouldBe` Right (-13) + + describe "Natural" $ do + it "decodes successfully" $ + decodeWith (getField @Natural "a") "a = 42" `shouldBe` Right 42 + + it "errors with negative numbers" $ + decodeWith (getField @Natural "a") "a = -13" `shouldFailWith` "Got negative number" + + describe "Int8" $ do + it "decodes successfully" $ do + decodeWith (getField @Int8 "a") "a = 127" `shouldBe` Right 127 + decodeWith (getField @Int8 "a") "a = 42" `shouldBe` Right 42 + decodeWith (getField @Int8 "a") "a = -13" `shouldBe` Right (-13) + decodeWith (getField @Int8 "a") "a = -128" `shouldBe` Right (-128) + + it "errors with underflow/overflow" $ do + decodeWith (getField @Int8 "a") "a = 128" `shouldFailWith` "Overflow" + decodeWith (getField @Int8 "a") "a = -129" `shouldFailWith` "Underflow" + + describe "Double" $ do + it "decodes successfully" $ do + decodeWith (getField @Double "a") "a = 42.0" `shouldBe` Right 42.0 + decodeWith (getField @Double "a") "a = -13.2" `shouldBe` Right (-13.2) + + describe "Array" $ + it "decodes successfully" $ do + decodeWith (getField @[Int] "a") "a = [1, 2]" `shouldBe` Right [1, 2] + + describe "UTCTime" $ + it "decodes successfully" $ do + decodeWith (getField @Time.UTCTime "a") "a = 2020-01-31T00:00:01-01:00" + `shouldBe` Right (Time.UTCTime (Time.fromGregorian 2020 1 31) 3601) + + describe "ZonedTime" $ + it "decodes successfully" $ do + -- ZonedTime does not have an Eq instance + decodeWith (getField @Time.ZonedTime "a") "a = 2020-01-31T00:00:01-01:00" + `shouldSatisfy` P.right + ( P.con $ + Time.ZonedTime + (P.eq $ Time.LocalTime (Time.fromGregorian 2020 1 31) (Time.TimeOfDay 0 0 1)) + (P.con $ Time.TimeZone (P.eq -60) P.anything P.anything) + ) + + describe "LocalTime" $ + it "decodes successfully" $ do + decodeWith (getField @Time.LocalTime "a") "a = 2020-01-31T00:00:01" + `shouldBe` Right (Time.LocalTime (Time.fromGregorian 2020 1 31) (Time.TimeOfDay 0 0 1)) + + describe "Day" $ + it "decodes successfully" $ do + decodeWith (getField @Time.Day "a") "a = 2020-01-31" + `shouldBe` Right (Time.fromGregorian 2020 1 31) + + describe "TimeOfDay" $ + it "decodes successfully" $ do + decodeWith (getField @Time.TimeOfDay "a") "a = 07:32:59.1" + `shouldBe` Right (Time.TimeOfDay 7 32 59.1) + + describe "Maybe" $ + it "decodes successfully" $ do + decodeWith (getField @(Maybe Int) "a") "a = 1" `shouldBe` Right (Just 1) + + describe "Either" $ do + it "decodes successfully" $ do + decodeWith (getField @(Either Int Double) "a") "a = 1" `shouldBe` Right (Left 1) + decodeWith (getField @(Either Int Double) "a") "a = 1.0" `shouldBe` Right (Right 1) + + describe "()" $ + it "decodes successfully" $ do + decodeWith (getField @() "a") "a = []" `shouldBe` Right () + + describe "(a, b)" $ do + it "decodes successfully" $ do + decodeWith (getField @(Int, Double) "a") "a = [1, 2.5]" `shouldBe` Right (1, 2.5) + + it "includes index in errors" $ + decodeWith (getField @(Int, Double) "a") "a = [1, true]" + `shouldSatisfy` P.left (P.con $ DecodeError (P.eq [Key "a", Index 1]) P.anything) + + describe "Map" $ do + it "decodes successfully" $ + decodeWith (getField @(Map Text Int) "a") "a = {x = 1, y = 2}" + `shouldBe` Right (Map.fromList [("x", 1), ("y", 2)]) + + it "includes key in errors" $ + decodeWith (getField @(Map Text Int) "a") "a = {x = true}" + `shouldSatisfy` P.left (P.con $ DecodeError (P.eq [Key "a", Key "x"]) P.anything) + +shouldFailWith :: Either TOMLError a -> Text -> IO () +result `shouldFailWith` message = result `shouldSatisfy` P.left decodeError + where + decodeError = P.con $ DecodeError P.anything invalidValue + invalidValue = P.con $ InvalidValue (P.eq message) P.anything diff --git a/test/specs/TOML/ErrorSpec.hs b/test/specs/TOML/ErrorSpec.hs new file mode 100644 --- /dev/null +++ b/test/specs/TOML/ErrorSpec.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TOML.ErrorSpec (spec) where + +import Control.Monad (forM_) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Skeletest +import Skeletest.Predicate qualified as P + +import TOML.Error ( + ContextItem (..), + DecodeError (..), + NormalizeError (..), + TOMLError (..), + renderTOMLError, + ) +import TOML.Value (Value (..)) + +spec :: Spec +spec = do + describe "renderTOMLError" $ do + forM_ allErrors $ \(label, e) -> + it ("renders " <> label) $ do + renderTOMLError e `shouldSatisfy` P.matchesSnapshot + + it "renders context items correctly" $ do + let msg = renderTOMLError (DecodeError [Key "a", Index 1, Key "b"] MissingField) + msg `shouldSatisfy` P.hasPrefix "Decode error at '.a[1].b':" + where + allErrors = + [ ("ParseError", ParseError "megaparsec error") + , + ( "NormalizeError.DuplicateKeyError" + , NormalizeError + DuplicateKeyError + { _path = fullPath + , _existingValue = value1 + , _valueToSet = value2 + } + ) + , + ( "NormalizeError.DuplicateSectionError" + , NormalizeError + DuplicateSectionError + { _sectionKey = fullPath + } + ) + , + ( "NormalizeError.ExtendTableError" + , NormalizeError + ExtendTableError + { _path = subPath + , _originalKey = fullPath + } + ) + , + ( "NormalizeError.ExtendTableInInlineArrayError" + , NormalizeError + ExtendTableInInlineArrayError + { _path = subPath + , _originalKey = fullPath + } + ) + , + ( "NormalizeError.ImplicitArrayForDefinedKeyError" + , NormalizeError + ImplicitArrayForDefinedKeyError + { _path = fullPath + , _existingValue = Array [value1] + , _tableSection = Map.fromList [("a", value2)] + } + ) + , + ( "NormalizeError.NonTableInNestedKeyError" + , NormalizeError + NonTableInNestedKeyError + { _path = subPath + , _existingValue = value1 + , _originalKey = fullPath + , _originalValue = value2 + } + ) + , + ( "NormalizeError.NonTableInNestedImplicitArrayError" + , NormalizeError + NonTableInNestedImplicitArrayError + { _path = subPath + , _existingValue = value1 + , _sectionKey = fullPath + , _tableSection = Map.fromList [("a", value2)] + } + ) + , ("DecodeError.MissingField", DecodeError ctx MissingField) + , ("DecodeError.InvalidValue", DecodeError ctx $ InvalidValue "bad value" value1) + , ("DecodeError.TypeMismatch", DecodeError ctx $ TypeMismatch value1) + , ("DecodeError.OtherDecodeError", DecodeError ctx $ OtherDecodeError "decode failure") + ] + fullPath = NonEmpty.fromList ["a", "b"] + subPath = NonEmpty.fromList ["a"] + value1 = Boolean True + value2 = Integer 1 + ctx = [Key "a", Key "b"] diff --git a/test/specs/TOML/ParserSpec.hs b/test/specs/TOML/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/test/specs/TOML/ParserSpec.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TOML.ParserSpec (spec) where + +import Data.Map.Strict qualified as Map +import Skeletest + +import TOML.Parser (parseTOML) +import TOML.Value (Value (..)) + +spec :: Spec +spec = do + it "parses large floats efficiently" $ do + let input = "a = 1e1000000000000000000000000000000000000000000000000000000000000000" + parseTOML "" input `shouldBe` Right (Table $ Map.singleton "a" (Float $ read "Infinity")) diff --git a/test/specs/TOML/Utils/MapSpec.hs b/test/specs/TOML/Utils/MapSpec.hs new file mode 100644 --- /dev/null +++ b/test/specs/TOML/Utils/MapSpec.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE LambdaCase #-} + +module TOML.Utils.MapSpec (spec) where + +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Skeletest + +import TOML.Utils.Map (getPath, getPathLens) + +spec :: Spec +spec = do + describe "getPathLens" $ do + it "gets and sets value at path" $ do + let obj = Map.fromList [("a", Map [("b", Map [("c", Int 1)])])] + + Right (mValue, setValue) <- pure $ getPathLens recurseMapOrInt (NonEmpty.fromList ["a", "b", "c"]) obj + + mValue `shouldBe` Just (Int 1) + + let newVal = Map [("foo", Int 100)] + setValue newVal `shouldBe` Map.fromList [("a", Map [("b", Map [("c", newVal)])])] + + describe "getPath" $ do + it "gets value at path" $ do + let obj = Map.fromList [("a", Map [("b", Map [("c", Int 1)])])] + + let doRecurse history = fmap fst . recurseMapOrInt history + Right mValue <- pure $ getPath doRecurse (NonEmpty.fromList ["a", "b", "c"]) obj + + mValue `shouldBe` Just (Int 1) + +data MapOrInt = Map [(String, MapOrInt)] | Int Int + deriving (Show, Eq) + +recurseMapOrInt :: + NonEmpty String + -> Maybe MapOrInt + -> Either String (Map String MapOrInt, Map String MapOrInt -> MapOrInt) +recurseMapOrInt _ = \case + Nothing -> Right (Map.empty, fromMap) + Just (Map kvs) -> Right (Map.fromList kvs, fromMap) + Just (Int x) -> Left $ "Could not recurse on: " ++ show x + where + fromMap = Map . Map.toList diff --git a/test/specs/TOML/Utils/NonEmptySpec.hs b/test/specs/TOML/Utils/NonEmptySpec.hs new file mode 100644 --- /dev/null +++ b/test/specs/TOML/Utils/NonEmptySpec.hs @@ -0,0 +1,22 @@ +module TOML.Utils.NonEmptySpec (spec) where + +import Data.List.NonEmpty qualified as NonEmpty +import Skeletest + +import TOML.Utils.NonEmpty (zipHistory) + +spec :: Spec +spec = do + describe "zipHistory" $ do + it "should zip already-seen keys with each key" $ + zipHistory (ne ["a", "b", "c"]) + `shouldBe` ne + [ (ne ["a"], "a") + , (ne ["a", "b"], "b") + , (ne ["a", "b", "c"], "c") + ] + it "works with one-element list" $ + zipHistory (ne ["a"]) `shouldBe` ne [(ne ["a"], "a")] + +ne :: [a] -> NonEmpty.NonEmpty a +ne = NonEmpty.fromList diff --git a/test/specs/TOML/__snapshots__/ErrorSpec.snap.md b/test/specs/TOML/__snapshots__/ErrorSpec.snap.md new file mode 100644 --- /dev/null +++ b/test/specs/TOML/__snapshots__/ErrorSpec.snap.md @@ -0,0 +1,83 @@ +# TOML.Error + +## renderTOMLError / renders DecodeError.InvalidValue + +``` +Decode error at '.a.b': Invalid value: bad value: true +``` + +## renderTOMLError / renders DecodeError.MissingField + +``` +Decode error at '.a.b': Field does not exist +``` + +## renderTOMLError / renders DecodeError.OtherDecodeError + +``` +Decode error at '.a.b': decode failure +``` + +## renderTOMLError / renders DecodeError.TypeMismatch + +``` +Decode error at '.a.b': Type mismatch, got: true +``` + +## renderTOMLError / renders NormalizeError.DuplicateKeyError + +``` +Could not add value to path "a.b": + Existing value: true + Value to set: 1 +``` + +## renderTOMLError / renders NormalizeError.DuplicateSectionError + +``` +Found duplicate section: "a.b" +``` + +## renderTOMLError / renders NormalizeError.ExtendTableError + +``` +Invalid table key: "a.b" + Table already statically defined at "a" +``` + +## renderTOMLError / renders NormalizeError.ExtendTableInInlineArrayError + +``` +Invalid table key: "a.b" + Table defined in inline array at "a" +``` + +## renderTOMLError / renders NormalizeError.ImplicitArrayForDefinedKeyError + +``` +Could not create implicit array at path "a.b": + Existing value: [true] + Array table section: {"a": 1} +``` + +## renderTOMLError / renders NormalizeError.NonTableInNestedImplicitArrayError + +``` +Found non-Table at path "a" when initializing implicit array at path "a.b": + Existing value: true + Array table section: {"a": 1} +``` + +## renderTOMLError / renders NormalizeError.NonTableInNestedKeyError + +``` +Found non-Table at path "a" when defining nested key "a.b": + Existing value: true + Original value: 1 +``` + +## renderTOMLError / renders ParseError + +``` +megaparsec error +``` diff --git a/test/tasty/Main.hs b/test/tasty/Main.hs deleted file mode 100644 --- a/test/tasty/Main.hs +++ /dev/null @@ -1,18 +0,0 @@ -import Test.Tasty - -import qualified TOML.DecodeTest -import qualified TOML.ErrorTest -import qualified TOML.ParserTest -import qualified TOML.Utils.MapTest -import qualified TOML.Utils.NonEmptyTest - -main :: IO () -main = - defaultMain $ - testGroup "toml-reader" $ - [ TOML.Utils.MapTest.test - , TOML.Utils.NonEmptyTest.test - , TOML.ErrorTest.test - , TOML.ParserTest.test - , TOML.DecodeTest.test - ] diff --git a/test/tasty/TOML/DecodeTest.hs b/test/tasty/TOML/DecodeTest.hs deleted file mode 100644 --- a/test/tasty/TOML/DecodeTest.hs +++ /dev/null @@ -1,260 +0,0 @@ -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module TOML.DecodeTest (test) where - -import Data.Int (Int8) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import qualified Data.Text as Text -import qualified Data.Time as Time -import Numeric.Natural (Natural) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit - -import TOML.Decode ( - DecodeTOML, - Decoder, - decodeWith, - getArrayOf, - getField, - getFieldOpt, - getFieldOptWith, - getFieldOr, - getFieldWith, - getFields, - getFieldsOpt, - getFieldsOptWith, - getFieldsWith, - tomlDecoder, - ) -import TOML.Error ( - ContextItem (..), - DecodeError (..), - TOMLError (..), - ) -import TOML.Value (Value (..)) - -test :: TestTree -test = - testGroup "TOML.Decode" . concat $ - [ getFieldTests - , [decoderInstanceTests] - ] - -getFieldTests :: [TestTree] -getFieldTests = - [ testGroup - "getField" - [ testCase "decodes field" $ - decodeWith (getField @Int "a") "a = 1" @?= Right 1 - , testCase "errors if field does not exist" $ - decodeWith (getField @Int "a") "" @?= Left (DecodeError [Key "a"] MissingField) - , testCase "errors if field is the wrong type" $ - decodeWith (getField @Int "a") "a = true" @?= Left (DecodeError [Key "a"] (TypeMismatch (Boolean True))) - ] - , testGroup - "getFieldOr" - [ testCase "decodes field" $ - decodeWith (getFieldOr @Int 42 "a") "a = 1" @?= Right 1 - , testCase "returns default if field does not exist" $ - decodeWith (getFieldOr @Int 42 "a") "" @?= Right 42 - , testCase "errors if field is the wrong type" $ - decodeWith (getFieldOr @Int 42 "a") "a = true" @?= Left (DecodeError [Key "a"] (TypeMismatch (Boolean True))) - ] - , testGroup - "getFieldOpt" - [ testCase "decodes field" $ - decodeWith (getFieldOpt @Int "a") "a = 1" @?= Right (Just 1) - , testCase "returns Nothing if field does not exist" $ - decodeWith (getFieldOpt @Int "a") "" @?= Right Nothing - , testCase "errors if field is the wrong type" $ - decodeWith (getFieldOpt @Int "a") "a = true" @?= Left (DecodeError [Key "a"] (TypeMismatch (Boolean True))) - ] - , testGroup - "getFieldWith" - [ testCase "decodes field" $ - decodeWith (getFieldWith @Int succDecoder "a") "a = 1" @?= Right 2 - , testCase "errors if field does not exist" $ - decodeWith (getFieldWith @Int succDecoder "a") "" @?= Left (DecodeError [Key "a"] MissingField) - , testCase "errors if field is the wrong type" $ - decodeWith (getFieldWith @Int succDecoder "a") "a = true" @?= Left (DecodeError [Key "a"] (TypeMismatch (Boolean True))) - ] - , testGroup - "getFieldOptWith" - [ testCase "decodes field" $ - decodeWith (getFieldOptWith @Int succDecoder "a") "a = 1" @?= Right (Just 2) - , testCase "returns Nothing if field does not exist" $ - decodeWith (getFieldOptWith @Int succDecoder "a") "" @?= Right Nothing - , testCase "errors if field is the wrong type" $ - decodeWith (getFieldOptWith @Int succDecoder "a") "a = true" @?= Left (DecodeError [Key "a"] (TypeMismatch (Boolean True))) - ] - , testGroup - "getFields" - [ testCase "decodes field" $ - decodeWith (getFields @Int ["a", "b"]) "a = { b = 1 }" @?= Right 1 - , testCase "errors if field does not exist" $ - decodeWith (getFields @Int ["a", "b"]) "a = {}" @?= Left (DecodeError [Key "a", Key "b"] MissingField) - , testCase "errors if intermediate field does not exist" $ - decodeWith (getFields @Int ["a", "b", "c"]) "a = {}" @?= Left (DecodeError [Key "a", Key "b"] MissingField) - , testCase "errors if field is the wrong type" $ - decodeWith (getFields @Int ["a", "b"]) "a = { b = true }" @?= Left (DecodeError [Key "a", Key "b"] (TypeMismatch (Boolean True))) - , testCase "errors if intermediate field is the wrong type" $ - decodeWith (getFields @Int ["a", "b", "c"]) "a = { b = true }" @?= Left (DecodeError [Key "a", Key "b"] (TypeMismatch (Boolean True))) - ] - , testGroup - "getFieldsOpt" - [ testCase "decodes field" $ - decodeWith (getFieldsOpt @Int ["a", "b"]) "a = { b = 1 }" @?= Right (Just 1) - , testCase "returns Nothing if field does not exist" $ - decodeWith (getFieldsOpt @Int ["a", "b"]) "a = {}" @?= Right Nothing - , testCase "returns Nothing if intermediate field does not exist" $ - decodeWith (getFieldsOpt @Int ["a", "b", "c"]) "a = {}" @?= Right Nothing - , testCase "errors if field is the wrong type" $ - decodeWith (getFieldsOpt @Int ["a", "b"]) "a = { b = true }" @?= Left (DecodeError [Key "a", Key "b"] (TypeMismatch (Boolean True))) - , testCase "errors if intermediate field is the wrong type" $ - decodeWith (getFieldsOpt @Int ["a", "b", "c"]) "a = { b = true }" @?= Left (DecodeError [Key "a", Key "b"] (TypeMismatch (Boolean True))) - ] - , testGroup - "getFieldsWith" - [ testCase "decodes field" $ - decodeWith (getFieldsWith @Int succDecoder ["a", "b"]) "a = { b = 1 }" @?= Right 2 - , testCase "errors if field does not exist" $ - decodeWith (getFieldsWith @Int succDecoder ["a", "b"]) "a = {}" @?= Left (DecodeError [Key "a", Key "b"] MissingField) - , testCase "errors if intermediate field does not exist" $ - decodeWith (getFieldsWith @Int succDecoder ["a", "b", "c"]) "a = {}" @?= Left (DecodeError [Key "a", Key "b"] MissingField) - , testCase "errors if field is the wrong type" $ - decodeWith (getFieldsWith @Int succDecoder ["a", "b"]) "a = { b = true }" @?= Left (DecodeError [Key "a", Key "b"] (TypeMismatch (Boolean True))) - , testCase "errors if intermediate field is the wrong type" $ - decodeWith (getFieldsWith @Int succDecoder ["a", "b", "c"]) "a = { b = true }" @?= Left (DecodeError [Key "a", Key "b"] (TypeMismatch (Boolean True))) - ] - , testGroup - "getFieldsOptWith" - [ testCase "decodes field" $ - decodeWith (getFieldsOptWith @Int succDecoder ["a", "b"]) "a = { b = 1 }" @?= Right (Just 2) - , testCase "returns Nothing if field does not exist" $ - decodeWith (getFieldsOptWith @Int succDecoder ["a", "b"]) "a = {}" @?= Right Nothing - , testCase "returns Nothing if intermediate field does not exist" $ - decodeWith (getFieldsOptWith @Int succDecoder ["a", "b", "c"]) "a = {}" @?= Right Nothing - , testCase "errors if field is the wrong type" $ - decodeWith (getFieldsOptWith @Int succDecoder ["a", "b"]) "a = { b = true }" @?= Left (DecodeError [Key "a", Key "b"] (TypeMismatch (Boolean True))) - , testCase "errors if intermediate field is the wrong type" $ - decodeWith (getFieldsOptWith @Int succDecoder ["a", "b", "c"]) "a = { b = true }" @?= Left (DecodeError [Key "a", Key "b"] (TypeMismatch (Boolean True))) - ] - , testGroup - "getArrayOf" - [ testCase "decodes field" $ - decodeWith (getFieldWith (getArrayOf @Int succDecoder) "a") "a = [1, 2]" @?= Right [2, 3] - , testCase "errors if value is the wrong type" $ - decodeWith (getFieldWith (getArrayOf @Int succDecoder) "a") "a = true" @?= Left (DecodeError [Key "a"] (TypeMismatch (Boolean True))) - , testCase "errors if value in array is the wrong type" $ - decodeWith (getFieldWith (getArrayOf @Int succDecoder) "a") "a = [1, 2, true]" @?= Left (DecodeError [Key "a", Index 2] (TypeMismatch (Boolean True))) - ] - , testCase "Decoding multiple fields at once" $ do - let decoder :: Decoder (Int, Maybe String, Maybe Int, Bool) - decoder = - (,,,) - <$> getField "a" - <*> getFieldOpt "b" - <*> getFieldOpt "missing" - <*> getFields ["c", "d"] - doc = - Text.unlines - [ "a = 1" - , "b = \"hello\"" - , "[c]" - , "d = true" - ] - decodeWith decoder doc @?= Right (1, Just "hello", Nothing, True) - ] - where - succDecoder :: (Enum a, DecodeTOML a) => Decoder a - succDecoder = succ <$> tomlDecoder - -decoderInstanceTests :: TestTree -decoderInstanceTests = - testGroup - "DecodeTOML instances" - [ testCase "Bool" $ do - decodeWith (getField @Bool "a") "a = true" @?= Right True - decodeWith (getField @Bool "a") "a = false" @?= Right False - , testCase "String" $ do - decodeWith (getField @String "a") "a = 'z'" @?= Right "z" - decodeWith (getField @String "a") "a = 'asdf'" @?= Right "asdf" - , testCase "Char" $ - decodeWith (getField @Char "a") "a = 'z'" @?= Right 'z' - , testCase "Char errors with multi-character string" $ - assertInvalidValue "Expected single character string" $ - decodeWith (getField @Char "a") "a = 'asdf'" - , testCase "Int" $ do - decodeWith (getField @Int "a") "a = 42" @?= Right 42 - decodeWith (getField @Int "a") "a = -13" @?= Right (-13) - , testCase "Natural" $ - decodeWith (getField @Natural "a") "a = 42" @?= Right 42 - , testCase "Natural errors with negative numbers" $ - assertInvalidValue "Got negative number" $ - decodeWith (getField @Natural "a") "a = -13" - , testCase "Int8" $ do - decodeWith (getField @Int8 "a") "a = 127" @?= Right 127 - decodeWith (getField @Int8 "a") "a = 42" @?= Right 42 - decodeWith (getField @Int8 "a") "a = -13" @?= Right (-13) - decodeWith (getField @Int8 "a") "a = -128" @?= Right (-128) - , testCase "Int8 errors with underflow/overflow" $ do - assertInvalidValue "Overflow" $ - decodeWith (getField @Int8 "a") "a = 128" - assertInvalidValue "Underflow" $ - decodeWith (getField @Int8 "a") "a = -129" - , testCase "Double" $ do - decodeWith (getField @Double "a") "a = 42.0" @?= Right 42.0 - decodeWith (getField @Double "a") "a = -13.2" @?= Right (-13.2) - , testCase "Array" $ - decodeWith (getField @[Int] "a") "a = [1, 2]" @?= Right [1, 2] - , testCase "UTCTime" $ - decodeWith (getField @Time.UTCTime "a") "a = 2020-01-31T00:00:01-01:00" - @?= Right (Time.UTCTime (Time.fromGregorian 2020 1 31) 3601) - , testCase "ZonedTime" $ - -- ZonedTime does not have an Eq instance - case decodeWith (getField @Time.ZonedTime "a") "a = 2020-01-31T00:00:01-01:00" of - Right (Time.ZonedTime (Time.LocalTime day time) (Time.TimeZone (-60) _ _)) - | day == Time.fromGregorian 2020 1 31 - , time == Time.TimeOfDay 0 0 1 -> - return () - result -> unexpectedResult result - , testCase "LocalTime" $ - decodeWith (getField @Time.LocalTime "a") "a = 2020-01-31T00:00:01" - @?= Right (Time.LocalTime (Time.fromGregorian 2020 1 31) (Time.TimeOfDay 0 0 1)) - , testCase "Day" $ - decodeWith (getField @Time.Day "a") "a = 2020-01-31" - @?= Right (Time.fromGregorian 2020 1 31) - , testCase "TimeOfDay" $ - decodeWith (getField @Time.TimeOfDay "a") "a = 07:32:59.1" - @?= Right (Time.TimeOfDay 7 32 59.1) - , testCase "Maybe" $ - decodeWith (getField @(Maybe Int) "a") "a = 1" @?= Right (Just 1) - , testCase "Either" $ do - decodeWith (getField @(Either Int Double) "a") "a = 1" @?= Right (Left 1) - decodeWith (getField @(Either Int Double) "a") "a = 1.0" @?= Right (Right 1) - , testCase "()" $ - decodeWith (getField @() "a") "a = []" @?= Right () - , testCase "(a, b)" $ - decodeWith (getField @(Int, Double) "a") "a = [1, 2.5]" @?= Right (1, 2.5) - , testCase "Map" $ - decodeWith (getField @(Map Text.Text Int) "a") "a = {x = 1, y = 2}" - @?= Right (Map.fromList [("x", 1), ("y", 2)]) - , testCase "Tuples show errors with index" $ - case decodeWith (getField @(Int, Double) "a") "a = [1, true]" of - Left (DecodeError [Key "a", Index 1] _) -> return () - result -> unexpectedResult result - , testCase "Maps show errors with key" $ - case decodeWith (getField @(Map Text.Text Int) "a") "a = {x = true}" of - Left (DecodeError [Key "a", Key "x"] _) -> return () - result -> unexpectedResult result - ] - where - assertInvalidValue expected result = - case result of - Left (DecodeError _ (InvalidValue actual _)) -> actual @?= expected - _ -> unexpectedResult result - - unexpectedResult result = assertFailure $ "Got unexpected result: " <> show result diff --git a/test/tasty/TOML/ErrorTest.hs b/test/tasty/TOML/ErrorTest.hs deleted file mode 100644 --- a/test/tasty/TOML/ErrorTest.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module TOML.ErrorTest (test) where - -import Control.Monad (unless) -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Map.Strict as Map -import qualified Data.Text as Text -import qualified Data.Text.Lazy as TextL -import qualified Data.Text.Lazy.Encoding as TextL -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Golden -import Test.Tasty.HUnit - -import TOML.Error ( - ContextItem (..), - DecodeError (..), - NormalizeError (..), - TOMLError (..), - renderTOMLError, - ) -import TOML.Value (Value (..)) - -test :: TestTree -test = - testGroup - "TOML.Error" - [ renderTOMLErrorTests - ] - -renderTOMLErrorTests :: TestTree -renderTOMLErrorTests = - testGroup - "renderTOMLError" - [ testGroup "renders errors correctly" $ - flip map allErrors $ \(label, e) -> - goldenVsString label ("test/tasty/goldens/renderTOMLError/" <> label <> ".golden") $ - pure (TextL.encodeUtf8 . TextL.fromStrict . renderTOMLError $ e) - , testCase "renders context items correctly" $ do - let msg = renderTOMLError (DecodeError [Key "a", Index 1, Key "b"] MissingField) - let expectedPrefix = "Decode error at '.a[1].b':" - unless (expectedPrefix `Text.isPrefixOf` msg) $ - assertFailure $ - "Expected message to start with prefix: " <> show expectedPrefix <> ", got: " <> Text.unpack msg - ] - where - allErrors = - [ ("ParseError", ParseError "megaparsec error") - , - ( "NormalizeError.DuplicateKeyError" - , NormalizeError - DuplicateKeyError - { _path = fullPath - , _existingValue = value1 - , _valueToSet = value2 - } - ) - , - ( "NormalizeError.DuplicateSectionError" - , NormalizeError - DuplicateSectionError - { _sectionKey = fullPath - } - ) - , - ( "NormalizeError.ExtendTableError" - , NormalizeError - ExtendTableError - { _path = subPath - , _originalKey = fullPath - } - ) - , - ( "NormalizeError.ExtendTableInInlineArrayError" - , NormalizeError - ExtendTableInInlineArrayError - { _path = subPath - , _originalKey = fullPath - } - ) - , - ( "NormalizeError.ImplicitArrayForDefinedKeyError" - , NormalizeError - ImplicitArrayForDefinedKeyError - { _path = fullPath - , _existingValue = Array [value1] - , _tableSection = Map.fromList [("a", value2)] - } - ) - , - ( "NormalizeError.NonTableInNestedKeyError" - , NormalizeError - NonTableInNestedKeyError - { _path = subPath - , _existingValue = value1 - , _originalKey = fullPath - , _originalValue = value2 - } - ) - , - ( "NormalizeError.NonTableInNestedImplicitArrayError" - , NormalizeError - NonTableInNestedImplicitArrayError - { _path = subPath - , _existingValue = value1 - , _sectionKey = fullPath - , _tableSection = Map.fromList [("a", value2)] - } - ) - , ("DecodeError.MissingField", DecodeError ctx MissingField) - , ("DecodeError.InvalidValue", DecodeError ctx $ InvalidValue "bad value" value1) - , ("DecodeError.TypeMismatch", DecodeError ctx $ TypeMismatch value1) - , ("DecodeError.OtherDecodeError", DecodeError ctx $ OtherDecodeError "decode failure") - ] - fullPath = NonEmpty.fromList ["a", "b"] - subPath = NonEmpty.fromList ["a"] - value1 = Boolean True - value2 = Integer 1 - ctx = [Key "a", Key "b"] diff --git a/test/tasty/TOML/ParserTest.hs b/test/tasty/TOML/ParserTest.hs deleted file mode 100644 --- a/test/tasty/TOML/ParserTest.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module TOML.ParserTest (test) where - -import qualified Data.Map.Strict as Map -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit - -import TOML.Parser (parseTOML) -import TOML.Value (Value (..)) - -test :: TestTree -test = - testGroup - "TOML.Parser" - [ testCase "Large floats are parsed efficiently" $ - case parseTOML "" "a = 1e1000000000000000000000000000000000000000000000000000000000000000" of - Right (Table t) -> Map.lookup "a" t @?= Just (Float (read "Infinity")) - result -> assertFailure $ "Got unexpected result: " ++ show result - ] diff --git a/test/tasty/TOML/Utils/MapTest.hs b/test/tasty/TOML/Utils/MapTest.hs deleted file mode 100644 --- a/test/tasty/TOML/Utils/MapTest.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module TOML.Utils.MapTest (test) where - -import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit - -import TOML.Utils.Map (getPath, getPathLens) - -test :: TestTree -test = - testGroup - "TOML.Utils.Map" - [ getPathLensTest - , getPathTest - ] - -data MapOrInt = Map [(String, MapOrInt)] | Int Int - deriving (Show, Eq) - -recurseMapOrInt :: - NonEmpty String - -> Maybe MapOrInt - -> Either String (Map String MapOrInt, Map String MapOrInt -> MapOrInt) -recurseMapOrInt _ = \case - Nothing -> Right (Map.empty, fromMap) - Just (Map kvs) -> Right (Map.fromList kvs, fromMap) - Just (Int x) -> Left $ "Could not recurse on: " ++ show x - where - fromMap = Map . Map.toList - -getPathLensTest :: TestTree -getPathLensTest = - testGroup - "getPathLens" - [ testCase "gets and sets value at path" $ do - let obj = Map.fromList [("a", Map [("b", Map [("c", Int 1)])])] - - Right (mValue, setValue) <- pure $ getPathLens recurseMapOrInt (NonEmpty.fromList ["a", "b", "c"]) obj - - mValue @?= Just (Int 1) - - let newVal = Map [("foo", Int 100)] - setValue newVal @?= Map.fromList [("a", Map [("b", Map [("c", newVal)])])] - ] - -getPathTest :: TestTree -getPathTest = - testGroup - "getPath" - [ testCase "gets value at path" $ do - let obj = Map.fromList [("a", Map [("b", Map [("c", Int 1)])])] - - let doRecurse history = fmap fst . recurseMapOrInt history - Right mValue <- pure $ getPath doRecurse (NonEmpty.fromList ["a", "b", "c"]) obj - - mValue @?= Just (Int 1) - ] diff --git a/test/tasty/TOML/Utils/NonEmptyTest.hs b/test/tasty/TOML/Utils/NonEmptyTest.hs deleted file mode 100644 --- a/test/tasty/TOML/Utils/NonEmptyTest.hs +++ /dev/null @@ -1,31 +0,0 @@ -module TOML.Utils.NonEmptyTest (test) where - -import qualified Data.List.NonEmpty as NonEmpty -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit - -import TOML.Utils.NonEmpty (zipHistory) - -test :: TestTree -test = - testGroup - "TOML.Utils.NonEmpty" - [ zipHistoryTest - ] - -zipHistoryTest :: TestTree -zipHistoryTest = - testGroup - "zipHistory" - [ testCase "should zip already-seen keys with each key" $ - zipHistory (ne ["a", "b", "c"]) - @?= ne - [ (ne ["a"], "a") - , (ne ["a", "b"], "b") - , (ne ["a", "b", "c"], "c") - ] - , testCase "works with one-element list" $ - zipHistory (ne ["a"]) @?= ne [(ne ["a"], "a")] - ] - where - ne = NonEmpty.fromList diff --git a/test/tasty/goldens/renderTOMLError/DecodeError.InvalidValue.golden b/test/tasty/goldens/renderTOMLError/DecodeError.InvalidValue.golden deleted file mode 100644 --- a/test/tasty/goldens/renderTOMLError/DecodeError.InvalidValue.golden +++ /dev/null @@ -1,1 +0,0 @@ -Decode error at '.a.b': Invalid value: bad value: true diff --git a/test/tasty/goldens/renderTOMLError/DecodeError.MissingField.golden b/test/tasty/goldens/renderTOMLError/DecodeError.MissingField.golden deleted file mode 100644 --- a/test/tasty/goldens/renderTOMLError/DecodeError.MissingField.golden +++ /dev/null @@ -1,1 +0,0 @@ -Decode error at '.a.b': Field does not exist diff --git a/test/tasty/goldens/renderTOMLError/DecodeError.OtherDecodeError.golden b/test/tasty/goldens/renderTOMLError/DecodeError.OtherDecodeError.golden deleted file mode 100644 --- a/test/tasty/goldens/renderTOMLError/DecodeError.OtherDecodeError.golden +++ /dev/null @@ -1,1 +0,0 @@ -Decode error at '.a.b': decode failure diff --git a/test/tasty/goldens/renderTOMLError/DecodeError.TypeMismatch.golden b/test/tasty/goldens/renderTOMLError/DecodeError.TypeMismatch.golden deleted file mode 100644 --- a/test/tasty/goldens/renderTOMLError/DecodeError.TypeMismatch.golden +++ /dev/null @@ -1,1 +0,0 @@ -Decode error at '.a.b': Type mismatch, got: true diff --git a/test/tasty/goldens/renderTOMLError/NormalizeError.DuplicateKeyError.golden b/test/tasty/goldens/renderTOMLError/NormalizeError.DuplicateKeyError.golden deleted file mode 100644 --- a/test/tasty/goldens/renderTOMLError/NormalizeError.DuplicateKeyError.golden +++ /dev/null @@ -1,3 +0,0 @@ -Could not add value to path "a.b": - Existing value: true - Value to set: 1 diff --git a/test/tasty/goldens/renderTOMLError/NormalizeError.DuplicateSectionError.golden b/test/tasty/goldens/renderTOMLError/NormalizeError.DuplicateSectionError.golden deleted file mode 100644 --- a/test/tasty/goldens/renderTOMLError/NormalizeError.DuplicateSectionError.golden +++ /dev/null @@ -1,1 +0,0 @@ -Found duplicate section: "a.b" diff --git a/test/tasty/goldens/renderTOMLError/NormalizeError.ExtendTableError.golden b/test/tasty/goldens/renderTOMLError/NormalizeError.ExtendTableError.golden deleted file mode 100644 --- a/test/tasty/goldens/renderTOMLError/NormalizeError.ExtendTableError.golden +++ /dev/null @@ -1,2 +0,0 @@ -Invalid table key: "a.b" - Table already statically defined at "a" diff --git a/test/tasty/goldens/renderTOMLError/NormalizeError.ExtendTableInInlineArrayError.golden b/test/tasty/goldens/renderTOMLError/NormalizeError.ExtendTableInInlineArrayError.golden deleted file mode 100644 --- a/test/tasty/goldens/renderTOMLError/NormalizeError.ExtendTableInInlineArrayError.golden +++ /dev/null @@ -1,2 +0,0 @@ -Invalid table key: "a.b" - Table defined in inline array at "a" diff --git a/test/tasty/goldens/renderTOMLError/NormalizeError.ImplicitArrayForDefinedKeyError.golden b/test/tasty/goldens/renderTOMLError/NormalizeError.ImplicitArrayForDefinedKeyError.golden deleted file mode 100644 --- a/test/tasty/goldens/renderTOMLError/NormalizeError.ImplicitArrayForDefinedKeyError.golden +++ /dev/null @@ -1,3 +0,0 @@ -Could not create implicit array at path "a.b": - Existing value: [true] - Array table section: {"a": 1} diff --git a/test/tasty/goldens/renderTOMLError/NormalizeError.NonTableInNestedImplicitArrayError.golden b/test/tasty/goldens/renderTOMLError/NormalizeError.NonTableInNestedImplicitArrayError.golden deleted file mode 100644 --- a/test/tasty/goldens/renderTOMLError/NormalizeError.NonTableInNestedImplicitArrayError.golden +++ /dev/null @@ -1,3 +0,0 @@ -Found non-Table at path "a" when initializing implicit array at path "a.b": - Existing value: true - Array table section: {"a": 1} diff --git a/test/tasty/goldens/renderTOMLError/NormalizeError.NonTableInNestedKeyError.golden b/test/tasty/goldens/renderTOMLError/NormalizeError.NonTableInNestedKeyError.golden deleted file mode 100644 --- a/test/tasty/goldens/renderTOMLError/NormalizeError.NonTableInNestedKeyError.golden +++ /dev/null @@ -1,3 +0,0 @@ -Found non-Table at path "a" when defining nested key "a.b": - Existing value: true - Original value: 1 diff --git a/test/tasty/goldens/renderTOMLError/ParseError.golden b/test/tasty/goldens/renderTOMLError/ParseError.golden deleted file mode 100644 --- a/test/tasty/goldens/renderTOMLError/ParseError.golden +++ /dev/null @@ -1,1 +0,0 @@ -megaparsec error diff --git a/test/toml-test/ValidateParser.hs b/test/toml-test/ValidateParser.hs --- a/test/toml-test/ValidateParser.hs +++ b/test/toml-test/ValidateParser.hs @@ -3,15 +3,15 @@ {-# LANGUAGE OverloadedStrings #-} import Data.Aeson ((.=)) -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Lazy.Char8 as Char8 +import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy.Char8 qualified as Char8 import Data.Map (Map) -import qualified Data.Map as Map +import Data.Map qualified as Map import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.IO as Text +import Data.Text qualified as Text +import Data.Text.IO qualified as Text import Data.Time (ZonedTime (..)) -import qualified Data.Vector as Vector +import Data.Vector qualified as Vector import System.Directory (findExecutable) import System.Environment (getArgs, getExecutablePath) import System.Exit (exitFailure) @@ -52,8 +52,10 @@ -- don't error, so that Hackage's test run doesn't fail putStrLn "WARNING: toml-test not installed. Skipping test suite..." Just tomlTestExe -> + -- don't run in parallel, in case we're running tests with coverage, which + -- behaves poorly if multiple processes try to read/write .tix files callProcess tomlTestExe $ - args ++ ["-color", "always", "--", thisExe, "--check"] + args ++ ["-color", "always", "-parallel", "1", "--", thisExe, "--check"] -- | Parse TOML data in stdin. checkTOML :: IO () diff --git a/toml-reader.cabal b/toml-reader.cabal --- a/toml-reader.cabal +++ b/toml-reader.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: toml-reader -version: 0.2.2.0 +version: 0.3.0.0 synopsis: TOML format parser compliant with v1.0.0. description: TOML format parser compliant with v1.0.0. See README.md for more details. category: TOML, Text, Configuration @@ -19,18 +19,7 @@ extra-source-files: README.md CHANGELOG.md - test/tasty/goldens/renderTOMLError/DecodeError.InvalidValue.golden - test/tasty/goldens/renderTOMLError/DecodeError.MissingField.golden - test/tasty/goldens/renderTOMLError/DecodeError.OtherDecodeError.golden - test/tasty/goldens/renderTOMLError/DecodeError.TypeMismatch.golden - test/tasty/goldens/renderTOMLError/NormalizeError.DuplicateKeyError.golden - test/tasty/goldens/renderTOMLError/NormalizeError.DuplicateSectionError.golden - test/tasty/goldens/renderTOMLError/NormalizeError.ExtendTableError.golden - test/tasty/goldens/renderTOMLError/NormalizeError.ExtendTableInInlineArrayError.golden - test/tasty/goldens/renderTOMLError/NormalizeError.ImplicitArrayForDefinedKeyError.golden - test/tasty/goldens/renderTOMLError/NormalizeError.NonTableInNestedImplicitArrayError.golden - test/tasty/goldens/renderTOMLError/NormalizeError.NonTableInNestedKeyError.golden - test/tasty/goldens/renderTOMLError/ParseError.golden + test/specs/TOML/__snapshots__/ErrorSpec.snap.md source-repository head type: git @@ -57,7 +46,7 @@ , parser-combinators , text , time - default-language: Haskell2010 + default-language: GHC2021 test-suite parser-validator type: exitcode-stdio-1.0 @@ -79,28 +68,28 @@ , toml-reader , unordered-containers , vector - default-language: Haskell2010 + default-language: GHC2021 test-suite toml-reader-tests type: exitcode-stdio-1.0 main-is: Main.hs other-modules: - TOML.DecodeTest - TOML.ErrorTest - TOML.ParserTest - TOML.Utils.MapTest - TOML.Utils.NonEmptyTest + TOML.DecodeSpec + TOML.ErrorSpec + TOML.ParserSpec + TOML.Utils.MapSpec + TOML.Utils.NonEmptySpec Paths_toml_reader hs-source-dirs: - test/tasty - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances -Wunused-packages + test/specs + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances -Wunused-packages -F -pgmF skeletest-preprocessor + build-tool-depends: + skeletest:skeletest-preprocessor build-depends: base , containers - , tasty - , tasty-golden - , tasty-hunit + , skeletest , text , time , toml-reader - default-language: Haskell2010 + default-language: GHC2021