diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for toml-parser +## 1.1.1.0 -- 2023-07-03 + +* Add support for GHC 8.10.7 and 9.0.2 + ## 1.1.0.0 -- 2023-07-03 * Add Toml.FromValue.Generic and Toml.ToValue.Generic diff --git a/src/Toml/FromValue.hs b/src/Toml/FromValue.hs --- a/src/Toml/FromValue.hs +++ b/src/Toml/FromValue.hs @@ -187,7 +187,10 @@ -- | A 'Matcher' that tracks a current set of unmatched key-value -- pairs from a table. -- --- Use 'optKey', 'reqKey', 'rej +-- Use 'optKey' and 'reqKey' to extract keys. +-- +-- Use 'getTable' and 'setTable' to override the table and implement +-- other primitives. newtype ParseTable a = ParseTable (StateT Table Matcher a) deriving (Functor, Applicative, Monad, Alternative, MonadPlus) diff --git a/src/Toml/Lexer/Token.hs b/src/Toml/Lexer/Token.hs --- a/src/Toml/Lexer/Token.hs +++ b/src/Toml/Lexer/Token.hs @@ -36,8 +36,9 @@ mkError, ) where +import Data.Char (digitToInt) import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime) -import Numeric (readBin, readHex, readOct) +import Numeric (readInt, readHex, readOct) -- | Lexical token data Token @@ -89,6 +90,13 @@ mkBinInteger :: String -> Token mkBinInteger ('0':'b':xs) = TokInteger (fst (head (readBin (scrub xs)))) mkBinInteger _ = error "processHex: bad input" + +-- This wasn't added to base until 4.16 +readBin :: (Eq a, Num a) => ReadS a +readBin = readInt 2 isBinDigit digitToInt + +isBinDigit :: Char -> Bool +isBinDigit x = x == '0' || x == '1' -- | Construct a 'TokFloat' from a floating-point literal lexeme. mkFloat :: String -> Token diff --git a/src/Toml/Parser.y b/src/Toml/Parser.y --- a/src/Toml/Parser.y +++ b/src/Toml/Parser.y @@ -121,7 +121,7 @@ : sepBy1_(p,q) { NonEmpty.reverse $1 } sepBy1_(p,q) :: { NonEmpty p } - : p { NonEmpty.singleton $1 } + : p { pure $1 } | sepBy1_(p,q) q p { NonEmpty.cons $3 $1 } { diff --git a/src/Toml/Pretty.hs b/src/Toml/Pretty.hs --- a/src/Toml/Pretty.hs +++ b/src/Toml/Pretty.hs @@ -36,7 +36,7 @@ import Data.Char (ord, isAsciiLower, isAsciiUpper, isDigit, isPrint) import Data.Foldable (fold) import Data.List (partition) -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty((:|))) import Data.List.NonEmpty qualified as NonEmpty import Data.Map qualified as Map import Data.String (fromString) @@ -130,7 +130,7 @@ TokEOF -> "end-of-input" prettyAssignment :: String -> Value -> TomlDoc -prettyAssignment = go . NonEmpty.singleton +prettyAssignment = go . pure where go ks (Table (Map.assocs -> [(k,v)])) = go (NonEmpty.cons k ks) v go ks v = prettyKey (NonEmpty.reverse ks) <+> equals <+> prettyValue v @@ -139,23 +139,23 @@ -- of an equals sign. This value will always occupy a single line. prettyValue :: Value -> TomlDoc prettyValue = \case - Integer i -> annotate NumberClass (pretty i) + Integer i -> annotate NumberClass (pretty i) Float f - | isNaN f -> annotate NumberClass "nan" - | isInfinite f -> annotate NumberClass (if f > 0 then "inf" else "-inf") - | otherwise -> annotate NumberClass (pretty f) - Array a -> align (list [prettyValue v | v <- a]) - Table t -> lbrace <> concatWith (surround ", ") [prettyAssignment k v | (k,v) <- Map.assocs t] <> rbrace - Bool True -> annotate BoolClass "true" - Bool False -> annotate BoolClass "false" - String str -> annotate StringClass (fromString (quoteString str)) - TimeOfDay tod -> annotate DateClass (fromString (formatTime defaultTimeLocale "%H:%M:%S%Q" tod)) + | isNaN f -> annotate NumberClass "nan" + | isInfinite f -> annotate NumberClass (if f > 0 then "inf" else "-inf") + | otherwise -> annotate NumberClass (pretty f) + Array a -> align (list [prettyValue v | v <- a]) + Table t -> lbrace <> concatWith (surround ", ") [prettyAssignment k v | (k,v) <- Map.assocs t] <> rbrace + Bool True -> annotate BoolClass "true" + Bool False -> annotate BoolClass "false" + String str -> annotate StringClass (fromString (quoteString str)) + TimeOfDay tod -> annotate DateClass (fromString (formatTime defaultTimeLocale "%H:%M:%S%Q" tod)) ZonedTime zt - | timeZoneMinutes (zonedTimeZone zt) == 0 -> - annotate DateClass (fromString (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" zt)) - | otherwise -> annotate DateClass (fromString (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%Ez" zt)) - LocalTime lt -> annotate DateClass (fromString (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q" lt)) - Day d -> annotate DateClass (fromString (formatTime defaultTimeLocale "%Y-%m-%d" d)) + | timeZoneMinutes (zonedTimeZone zt) == 0 -> + annotate DateClass (fromString (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" zt)) + | otherwise -> annotate DateClass (fromString (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%Ez" zt)) + LocalTime lt -> annotate DateClass (fromString (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q" lt)) + Day d -> annotate DateClass (fromString (formatTime defaultTimeLocale "%Y-%m-%d" d)) isAlwaysSimple :: Value -> Bool isAlwaysSimple = \case @@ -199,7 +199,11 @@ assignments = [prettyAssignment k v <> hardline | (k,v) <- simple] - subtables = [prettySection (prefix `NonEmpty.prependList` pure k) v | (k,v) <- sections] + subtables = [prettySection (prefix `snoc` k) v | (k,v) <- sections] + +snoc :: [a] -> a -> NonEmpty a +snoc [] y = y :| [] +snoc (x : xs) y = x :| xs ++ [y] prettySection :: NonEmpty String -> Value -> TomlDoc prettySection key (Table t) = diff --git a/src/Toml/Semantics.hs b/src/Toml/Semantics.hs --- a/src/Toml/Semantics.hs +++ b/src/Toml/Semantics.hs @@ -120,7 +120,7 @@ Nothing -> case kind of TableKind -> go (FrameTable Closed) Map.empty - ArrayTableKind -> go (FrameArray . NonEmpty.singleton) Map.empty + ArrayTableKind -> go (FrameArray . pure) Map.empty -- defining a super table of a previously defined subtable Just (FrameTable Open t) -> diff --git a/test/DecodeSpec.hs b/test/DecodeSpec.hs --- a/test/DecodeSpec.hs +++ b/test/DecodeSpec.hs @@ -4,13 +4,14 @@ import Data.Map qualified as Map import Data.Maybe (fromMaybe) import GHC.Generics (Generic) -import QuoteStr (quoteStr ) +import QuoteStr (quoteStr) import Test.Hspec (it, shouldBe, Spec) import Toml (decode, Result(Success), encode) import Toml.FromValue (FromTable(..), FromValue(..), defaultTableFromValue, runParseTable, reqKey, optKey) import Toml.FromValue.Generic (genericFromTable) -import Toml.ToValue +import Toml.ToValue (ToTable(..), ToValue(toValue), (.=), defaultTableToValue) import Toml.ToValue.Generic (genericToTable) +import Toml (Result(..)) newtype Fruits = Fruits { fruits :: [Fruit] } deriving (Eq, Show, Generic) @@ -126,3 +127,13 @@ "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` + Failure ["Missing key: name in top.fruits[0]"] + + it "handles parse errors while decoding" $ + (decode "x =" :: Result Fruits) + `shouldBe` + Failure ["1:4: parse error: unexpected end-of-input"] 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.1.0.0 +version: 1.1.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 == 9.2.8, GHC == 9.4.5, GHC == 9.6.2 +tested-with: GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.8, GHC == 9.4.5, GHC == 9.6.2 extra-doc-files: ChangeLog.md @@ -65,10 +65,10 @@ Toml.Value build-depends: array ^>= 0.5, - base ^>= 4.16 || ^>= 4.17 || ^>= 4.18, + base >= 4.14 && < 4.19, containers ^>= 0.5 || ^>= 0.6, prettyprinter ^>= 1.7, - time ^>= 1.11 || ^>= 1.12, + time >= 1.9 && < 1.13, transformers ^>= 0.5 || ^>= 0.6, build-tool-depends: alex:alex >= 3.2, @@ -87,7 +87,7 @@ base, containers, hspec >= 2.10 && < 2.12, - template-haskell ^>= 2.18 || ^>= 2.19 || ^>= 2.20, + template-haskell >= 2.16 && < 2.21, time, toml-parser, other-modules: