diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,14 @@ # Revision history for toml-parser +## 1.3.0.0 -- 2023-07-16 + +* Make more structured error messages available in the low-level modules. + Consumers of the `Toml` module can keep getting simple error strings + and users interested in structured errors can run the different layers + independently to get more detailed error reporting. +* `FromValue` and `ToValue` instances for: `Ratio`, `NonEmpty`, `Seq` +* Add `FromKey` and `ToKey` for allowing codecs for `Map` to use various key types. + ## 1.2.1.0 -- 2023-07-12 * Added `Toml.Pretty.prettyTomlOrdered` to allow user-specified section ordering. diff --git a/src/Toml.hs b/src/Toml.hs --- a/src/Toml.hs +++ b/src/Toml.hs @@ -35,11 +35,10 @@ import Text.Printf (printf) import Toml.FromValue (FromValue (fromValue), Result(..)) import Toml.FromValue.Matcher (runMatcher) -import Toml.Lexer (scanTokens, Token(TokError)) import Toml.Located (Located(Located)) import Toml.Parser (parseRawToml) import Toml.Position (Position(posColumn, posLine)) -import Toml.Pretty (TomlDoc, DocClass(..), prettyToken, prettyToml) +import Toml.Pretty (TomlDoc, DocClass(..), prettyToml, prettySemanticError, prettyMatchMessage) import Toml.Semantics (semantics) import Toml.ToValue (ToTable (toTable)) import Toml.Value (Table, Value(..)) @@ -47,16 +46,23 @@ -- | Parse a TOML formatted 'String' or report an error message. parse :: String -> Either String Table parse str = - case parseRawToml (scanTokens str) of - Left (Located p (TokError e)) -> - Left (printf "%d:%d: lexical error: %s" (posLine p) (posColumn p) e) - Left (Located p t) -> - Left (printf "%d:%d: parse error: unexpected %s" (posLine p) (posColumn p) (prettyToken t)) - Right exprs -> semantics exprs + case parseRawToml str of + Left (Located p e) -> Left (printf "%d:%d: %s" (posLine p) (posColumn p) e) + Right exprs -> + case semantics exprs of + Left (Located p e) -> + Left (printf "%d:%d: %s" (posLine p) (posColumn p) (prettySemanticError e)) + Right tab -> Right tab -- | Use the 'FromValue' instance to decode a value from a TOML string. -decode :: FromValue a => String -> Result a -decode = either (Failure . pure) (runMatcher . fromValue . Table) . parse +decode :: FromValue a => String -> Result String a +decode str = + case parse str of + Left e -> Failure [e] + Right tab -> + case runMatcher (fromValue (Table tab)) of + Failure es -> Failure (prettyMatchMessage <$> es) + Success ws x -> Success (prettyMatchMessage <$> ws) x -- | Use the 'ToTable' instance to encode a value to a TOML string. encode :: ToTable a => a -> TomlDoc diff --git a/src/Toml/FromValue.hs b/src/Toml/FromValue.hs --- a/src/Toml/FromValue.hs +++ b/src/Toml/FromValue.hs @@ -1,3 +1,4 @@ +{-# Language TypeFamilies #-} {-| Module : Toml.FromValue Description : Automation for converting TOML values to application values. @@ -24,9 +25,11 @@ module Toml.FromValue ( -- * Deserialization classes FromValue(..), + FromKey(..), -- * Matcher Matcher, + MatchMessage(..), Result(..), warning, @@ -48,24 +51,24 @@ liftMatcher, ) where -import Control.Applicative (Alternative) -import Control.Monad (MonadPlus, zipWithM) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State.Strict (StateT(..), put, get) +import Control.Monad (zipWithM) import Data.Int (Int8, Int16, Int32, Int64) -import Data.List (intercalate) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NonEmpty import Data.Map (Map) import Data.Map qualified as Map +import Data.Ratio (Ratio) +import Data.Sequence (Seq) +import Data.Sequence qualified as Seq 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.Matcher (Matcher, Result(..), MatchMessage(..), warning, inIndex, inKey) import Toml.FromValue.ParseTable -import Toml.Pretty (prettySimpleKey, prettyValue) -import Toml.Value (Value(..), Table) +import Toml.Value (Value(..)) -- | Class for types that can be decoded from a TOML value. class FromValue a where @@ -77,12 +80,36 @@ listFromValue (Array xs) = zipWithM (\i v -> inIndex i (fromValue v)) [0..] xs listFromValue v = typeError "array" v -instance (Ord k, IsString k, FromValue v) => FromValue (Map k v) where +instance (Ord k, FromKey k, FromValue v) => FromValue (Map k v) where fromValue (Table t) = Map.fromList <$> traverse f (Map.assocs t) where - f (k,v) = (,) (fromString k) <$> inKey k (fromValue v) + f (k,v) = (,) <$> fromKey k <*> inKey k (fromValue v) fromValue v = typeError "table" v +-- | Convert from a table key +-- +-- @since 1.3.0.0 +class FromKey a where + fromKey :: String -> Matcher a + +-- | Matches all strings +-- +-- @since 1.3.0.0 +instance a ~ Char => FromKey [a] where + fromKey = pure + +-- | Matches all strings +-- +-- @since 1.3.0.0 +instance FromKey Data.Text.Text where + fromKey = pure . Data.Text.pack + +-- | Matches all strings +-- +-- @since 1.3.0.0 +instance FromKey Data.Text.Lazy.Text where + fromKey = pure . Data.Text.Lazy.pack + -- | Report a type error typeError :: String {- ^ expected type -} -> Value {- ^ actual value -} -> Matcher a typeError wanted got = fail ("type error. wanted: " ++ wanted ++ " got: " ++ valueType got) @@ -148,6 +175,8 @@ listFromValue v = typeError "string" v -- | Matches string literals +-- +-- @since 1.2.1.0 instance FromValue Data.Text.Text where fromValue v = Data.Text.pack <$> fromValue v @@ -158,8 +187,6 @@ 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) @@ -170,6 +197,37 @@ fromValue (Float x) = pure (realToFrac x) fromValue (Integer x) = pure (fromInteger x) fromValue v = typeError "float" v + +-- | Matches floating-point and integer values. +-- +-- TOML specifies @Floats should be implemented as IEEE 754 binary64 values.@ +-- so note that the given 'Rational' will be converted from a double +-- representation and will often be an approximation rather than the exact +-- value. +-- +-- @since 1.3.0.0 +instance Integral a => FromValue (Ratio a) where + fromValue (Float x) + | isNaN x || isInfinite x = fail "finite float required" + | otherwise = pure (realToFrac x) + fromValue (Integer x) = pure (fromInteger x) + fromValue v = typeError "float" v + +-- | Matches non-empty arrays or reports an error. +-- +-- @since 1.3.0.0 +instance FromValue a => FromValue (NonEmpty a) where + fromValue v = + do xs <- fromValue v + case NonEmpty.nonEmpty xs of + Nothing -> fail "non-empty list required" + Just ne -> pure ne + +-- | Matches arrays +-- +-- @since 1.3.0.0 +instance FromValue a => FromValue (Seq a) where + fromValue v = Seq.fromList <$> fromValue v -- | Matches @true@ and @false@ instance FromValue Bool where diff --git a/src/Toml/FromValue/Generic.hs b/src/Toml/FromValue/Generic.hs --- a/src/Toml/FromValue/Generic.hs +++ b/src/Toml/FromValue/Generic.hs @@ -16,10 +16,8 @@ ) where import GHC.Generics -import Toml.FromValue.ParseTable (ParseTable, runParseTable) -import Toml.FromValue.Matcher (Matcher) -import Toml.FromValue (FromValue, fromValue, optKey, reqKey) -import Toml.Value (Table, Value(Table)) +import Toml.FromValue.ParseTable (ParseTable) +import Toml.FromValue (FromValue, optKey, reqKey) -- | Match a 'Table' using the field names in a record. -- 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 @@ -14,55 +14,90 @@ It supports tracking multiple error messages when you have more than one decoding option and all of them have failed. +Use 'Toml.Pretty.prettyMatchMessage' for an easy way to make human +readable strings from matcher outputs. + -} -module Toml.FromValue.Matcher ( +module Toml.FromValue.Matcher ( + -- * Types Matcher, Result(..), + MatchMessage(..), + + -- * Operations runMatcher, withScope, getScope, warning, -- * Scope helpers + Scope(..), inKey, inIndex, ) where +import Control.Applicative (Alternative(..)) +import Control.Monad (MonadPlus) import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader (asks, local, ReaderT(..)) import Control.Monad.Trans.Except (Except, runExcept, throwE) +import Control.Monad.Trans.Reader (asks, local, ReaderT(..)) import Control.Monad.Trans.Writer.CPS (runWriterT, tell, WriterT) import Data.Monoid (Endo(..)) -import Control.Applicative (Alternative(..)) -import Control.Monad (MonadPlus) -import Toml.Pretty (prettySimpleKey) -- | Computations that result in a 'Result' and which track a list -- of nested contexts to assist in generating warnings and error -- messages. -- -- Use 'withScope' to run a 'Matcher' in a new, nested scope. -newtype Matcher a = Matcher (ReaderT [String] (WriterT Strings (Except Strings)) a) +newtype Matcher a = Matcher (ReaderT [Scope] (WriterT (DList MatchMessage) (Except (DList MatchMessage))) a) deriving (Functor, Applicative, Monad, Alternative, MonadPlus) +-- | Scopes for TOML message. +-- +-- @since 1.3.0.0 +data Scope + = ScopeIndex Int -- ^ zero-based array index + | ScopeKey String -- ^ key in a table + deriving ( + Read {- ^ Default instance -}, + Show {- ^ Default instance -}, + Eq {- ^ Default instance -}, + Ord {- ^ Default instance -}) + +-- | A message emitted while matching a TOML value. The message is paired +-- with the path to the value that was in focus when the message was +-- generated. These message get used for both warnings and errors. +-- +-- @since 1.3.0.0 +data MatchMessage = MatchMessage { + matchPath :: [Scope], -- ^ path to message location + matchMessage :: String -- ^ error and warning message body + } deriving ( + Read {- ^ Default instance -}, + Show {- ^ Default instance -}, + Eq {- ^ Default instance -}, + Ord {- ^ Default instance -}) + -- | List of strings that supports efficient left- and right-biased append -newtype Strings = Strings (Endo [String]) +newtype DList a = DList (Endo [a]) deriving (Semigroup, Monoid) -- | Create a singleton list of strings -string :: String -> Strings -string x = Strings (Endo (x:)) +one :: a -> DList a +one x = DList (Endo (x:)) -- | Extract the list of strings -runStrings :: Strings -> [String] -runStrings (Strings s) = s `appEndo` [] +runDList :: DList a -> [a] +runDList (DList x) = x `appEndo` [] -- | Computation outcome with error and warning messages. Multiple error -- 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 -- ^ warning messages and result +-- +-- @since 1.3.0.0 +data Result e a + = Failure [e] -- ^ error messages + | Success [e] a -- ^ warning messages and result deriving ( Read {- ^ Default instance -}, Show {- ^ Default instance -}, @@ -70,40 +105,46 @@ Ord {- ^ Default instance -}) -- | Run a 'Matcher' with an empty scope. -runMatcher :: Matcher a -> Result a +-- +-- @since 1.3.0.0 +runMatcher :: Matcher a -> Result MatchMessage a runMatcher (Matcher m) = case runExcept (runWriterT (runReaderT m [])) of - Left e -> Failure (runStrings e) - Right (x,w) -> Success (runStrings w) x + Left e -> Failure (runDList e) + Right (x,w) -> Success (runDList w) x -- | Run a 'Matcher' with a locally extended scope. -withScope :: String -> Matcher a -> Matcher a -withScope ctx (Matcher m) = Matcher (local (ctx:) m) +-- +-- @since 1.3.0.0 +withScope :: Scope -> Matcher a -> Matcher a +withScope ctx (Matcher m) = Matcher (local (ctx :) m) -- | Get the current list of scopes. -getScope :: Matcher [String] +-- +-- @since 1.3.0.0 +getScope :: Matcher [Scope] getScope = Matcher (asks reverse) -- | Emit a warning mentioning the current scope. warning :: String -> Matcher () warning w = do loc <- getScope - Matcher (lift (tell (string (w ++ " in top" ++ concat loc)))) + Matcher (lift (tell (one (MatchMessage loc w)))) -- | Fail with an error message annotated to the current location. instance MonadFail Matcher where fail e = do loc <- getScope - Matcher (lift (lift (throwE (string (e ++ " in top" ++ concat loc))))) + Matcher (lift (lift (throwE (one (MatchMessage loc e))))) -- | Update the scope with the message corresponding to a table key -- --- @since 1.2.0.0 +-- @since 1.3.0.0 inKey :: String -> Matcher a -> Matcher a -inKey key = withScope ('.' : show (prettySimpleKey key)) +inKey = withScope . ScopeKey -- | Update the scope with the message corresponding to an array index -- --- @since 1.2.0.0 +-- @since 1.3.0.0 inIndex :: Int -> Matcher a -> Matcher a -inIndex i = withScope ("[" ++ show i ++ "]") +inIndex = withScope . ScopeIndex 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 @@ -110,7 +110,7 @@ do t <- getTable foldr (f t) errCase xs where - f t (Else m) _ = liftMatcher m + f _ (Else m) _ = liftMatcher m f t (Key k c) continue = case Map.lookup k t of Nothing -> continue diff --git a/src/Toml/Lexer.x b/src/Toml/Lexer.x --- a/src/Toml/Lexer.x +++ b/src/Toml/Lexer.x @@ -17,9 +17,8 @@ "LexerUtils". -} -module Toml.Lexer (scanTokens, lexValue, Token(..)) where +module Toml.Lexer (Context(..), scanToken, lexValue, Token(..)) where -import Control.Monad.Trans.State.Strict (evalState, runState) import Toml.Lexer.Token import Toml.Lexer.Utils import Toml.Located @@ -55,18 +54,15 @@ @float_int_part = @dec_int @float = @float_int_part ( @exp | @frac @exp? ) | @special_float +@bad_dec_int = [\-\+]? 0 ($digit | _ $digit)+ + $non_eol = [\x09 \x20-\x7E $non_ascii] @comment = $comment_start_symbol $non_eol* $literal_char = [\x09 \x20-\x26 \x28-\x7E $non_ascii] -@literal_string = "'" $literal_char* "'" -@ml_literal_string_delim = "'''" $mll_char = [\x09 \x20-\x26 \x28-\x7E] -@mll_quotes = "'" "'"? @mll_content = $mll_char | @newline -@ml_literal_body = @mll_content* (@mll_quotes @mll_content+)* @mll_quotes? -@ml_literal_string = @ml_literal_string_delim @newline? @ml_literal_body @ml_literal_string_delim @mlb_escaped_nl = \\ @ws @newline ($wschar | @newline)* $unescaped = [$wschar \x21 \x23-\x5B \x5D-\x7E $non_ascii] @@ -95,13 +91,14 @@ { -@dec_int { value mkDecInteger } -@hex_int { value mkHexInteger } -@oct_int { value mkOctInteger } -@bin_int { value mkBinInteger } -@float { value mkFloat } -"true" { value_ TokTrue } -"false" { value_ TokFalse } +@bad_dec_int { failure "leading zero prohibited" } +@dec_int { token mkDecInteger } +@hex_int { token mkHexInteger } +@oct_int { token mkOctInteger } +@bin_int { token mkBinInteger } +@float { token mkFloat } +"true" { token_ TokTrue } +"false" { token_ TokFalse } @offset_date_time { timeValue "offset date-time" offsetDateTimePatterns TokOffsetDateTime } @local_date { timeValue "local date" localDatePatterns TokLocalDate } @@ -115,36 +112,45 @@ "]]" { token_ Tok2SquareC } } -<0,val> { +<0,val,tab> { @newline { token_ TokNewline } @comment; $wschar+; -@literal_string { value mkLiteralString } - -@ml_literal_string { value mkMlLiteralString } - -"=" { equals } +"=" { token_ TokEquals } "." { token_ TokPeriod } "," { token_ TokComma } -"[" { squareO } -"]" { squareC } -"{" { curlyO } -"}" { curlyC } +"[" { token_ TokSquareO } +"]" { token_ TokSquareC } +"{" { token_ TokCurlyO } +"}" { token_ TokCurlyC } @barekey { token TokBareKey } -\"{3} @newline? { startMlStr } -\" { startStr } +\"{3} @newline? { startMlBstr } +\" { startBstr } +"'''" @newline? { startMlLstr } +"'" { startLstr } } + { + $literal_char+ { strFrag } + "'" { endStr . fmap (drop 1) } +} + { $unescaped+ { strFrag } \" { endStr . fmap (drop 1) } } + { + @mll_content+ { strFrag } + "'" {1,2} { strFrag } + "'" {3,5} { endStr . fmap (drop 3) } +} + { @mlb_escaped_nl; ($unescaped | @newline)+ { strFrag } @@ -154,7 +160,9 @@ { \\ U $hexdig{8} { unicodeEscape } + \\ U { failure "\\U requires exactly 8 hex digits"} \\ u $hexdig{4} { unicodeEscape } + \\ u { failure "\\u requires exactly 4 hex digits"} \\ n { strFrag . ("\n" <$) } \\ t { strFrag . ("\t" <$) } \\ r { strFrag . ("\r" <$) } @@ -171,42 +179,34 @@ alexGetByte :: AlexInput -> Maybe (Int, AlexInput) alexGetByte = locatedUncons --- | Generate a lazy-list of tokens from the input string. --- The token stream is guaranteed to be terminated either with --- 'TokEOF' or 'TokError'. -scanTokens :: String -> [Located Token] -scanTokens str = scanTokens' [] Located { locPosition = startPos, locThing = str } - -scanTokens' :: [Context] -> AlexInput -> [Located Token] -scanTokens' st str = +-- | Get the next token from a located string. This function can be total +-- because one of the possible token outputs is an error token. +scanToken :: Context -> Located String -> Either (Located String) (Located Token, Located String) +scanToken st str = case alexScan str (stateInt st) of - AlexEOF -> [eofToken st str] - AlexError str' -> [mkError <$> str'] - AlexSkip str' _ -> scanTokens' st str' + AlexEOF -> eofToken st str + AlexError str' -> Left (mkError <$> str') + AlexSkip str' _ -> scanToken st str' AlexToken str' n action -> - case runState (action (take n <$> str)) st of - (t, st') -> t ++ scanTokens' st' str' + case action (take n <$> str) st of + Resume st' -> scanToken st' str' + LexerError e -> Left e + EmitToken t -> Right (t, str') -stateInt :: [Context] -> Int -stateInt (ValueContext : _) = val -stateInt (ListContext {} : _) = val -stateInt (StrContext {} : _) = bstr -stateInt (MlStrContext{} : _) = mlbstr -stateInt _ = 0 +stateInt :: Context -> Int +stateInt TopContext = 0 +stateInt TableContext = tab +stateInt ValueContext = val +stateInt BstrContext {} = bstr +stateInt MlBstrContext{} = mlbstr +stateInt LstrContext {} = lstr +stateInt MlLstrContext{} = mllstr -- | Lex a single token in a value context. This is mostly useful for testing. -lexValue :: String -> Token -lexValue str = lexValue_ Located { locPosition = startPos, locThing = str } - -lexValue_ :: Located String -> Token -lexValue_ str = - case alexScan str val of - AlexEOF -> TokError "end of input" - AlexError{} -> TokError "lexer error" - AlexSkip str' _ -> lexValue_ str' - AlexToken _ n action -> - case evalState (action (take n <$> str)) [ValueContext] of - t:_ -> locThing t - [] -> TokError "lexer error" +lexValue :: String -> Either String Token +lexValue str = + case scanToken ValueContext Located{ locPosition = startPos, locThing = str } of + Left e -> Left (locThing e) + Right (t,_) -> Right (locThing t) } 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 @@ -13,10 +13,6 @@ -- * Types Token(..), - -- * String literals - mkLiteralString, - mkMlLiteralString, - -- * Integer literals mkBinInteger, mkDecInteger, @@ -31,9 +27,6 @@ localTimePatterns, localDateTimePatterns, offsetDateTimePatterns, - - -- * Errors - mkError, ) where import Data.Char (digitToInt) @@ -46,7 +39,7 @@ | TokFalse -- ^ @false@ | TokComma -- ^ @','@ | TokEquals -- ^ @'='@ - | TokNewline -- ^ @'\\n'@ + | TokNewline -- ^ @end-of-line@ | TokPeriod -- ^ @'.'@ | TokSquareO -- ^ @'['@ | TokSquareC -- ^ @']'@ @@ -63,8 +56,7 @@ | TokLocalDateTime !LocalTime -- ^ local date-time | TokLocalDate !Day -- ^ local date | TokLocalTime !TimeOfDay -- ^ local time - | TokError String -- ^ lexical error - | TokEOF -- ^ end of file + | TokEOF -- ^ @end-of-input@ deriving (Read, Show) -- | Remove underscores from number literals @@ -108,29 +100,6 @@ mkFloat "-inf" = TokFloat (-1/0) mkFloat ('+':x) = TokFloat (read (scrub x)) mkFloat x = TokFloat (read (scrub x)) - --- | Construct a 'TokString' from a literal string lexeme. -mkLiteralString :: String -> Token -mkLiteralString = TokString . tail . init - --- | Construct a 'TokMlString' from a literal multi-line string lexeme. -mkMlLiteralString :: String -> Token -mkMlLiteralString str = - TokMlString - case str of - '\'':'\'':'\'':'\r':'\n':start -> go start - '\'':'\'':'\'':'\n':start -> go start - '\'':'\'':'\'':start -> go start - _ -> error "processMlLiteral: mising initializer" - where - go "'''" = "" - go (x:xs) = x : go xs - go "" = error "processMlLiteral: missing terminator" - --- | Make a 'TokError' from a lexical error message. -mkError :: String -> Token -mkError "" = TokError "unexpected end-of-input" -mkError (x:_) = TokError ("unexpected " ++ show x) -- | Format strings for local date lexemes. localDatePatterns :: [String] diff --git a/src/Toml/Lexer/Utils.hs b/src/Toml/Lexer/Utils.hs --- a/src/Toml/Lexer/Utils.hs +++ b/src/Toml/Lexer/Utils.hs @@ -18,34 +18,32 @@ -- * Types Action, Context(..), + Outcome(..), -- * Input processing locatedUncons, -- * Actions - value, - value_, token, token_, - squareO, - squareC, - curlyO, - curlyC, - - equals, timeValue, eofToken, + failure, + -- * String literals strFrag, - startMlStr, - startStr, + startMlBstr, + startBstr, + startMlLstr, + startLstr, endStr, unicodeEscape, + + mkError, ) where -import Control.Monad.Trans.State.Strict (State, state) import Data.Char (ord, chr, isAscii) import Data.Foldable (asum) import Data.Time.Format (parseTimeM, defaultTimeLocale, ParseTime) @@ -56,101 +54,74 @@ import Toml.Lexer.Token (Token(..)) -- | Type of actions associated with lexer patterns -type Action = Located String -> State [Context] [Located Token] +type Action = Located String -> Context -> Outcome +data Outcome + = Resume Context + | LexerError (Located String) + | EmitToken (Located Token) + -- | Representation of the current lexer state. data Context - = ListContext Position -- ^ processing an inline list, lex values - | TableContext Position -- ^ processing an inline table, don't lex values - | ValueContext -- ^ processing after an equals, lex one value - | MlStrContext Position [String] -- ^ position of opening delimiter and list of fragments - | StrContext Position [String] -- ^ position of opening delimiter and list of fragments + = TopContext -- ^ top-level where @[[@ and @]]@ have special meaning + | TableContext -- ^ inline table - lex key names + | ValueContext -- ^ value lexer - lex number literals + | MlBstrContext Position [String] -- ^ multiline basic string: position of opening delimiter and list of fragments + | BstrContext Position [String] -- ^ basic string: position of opening delimiter and list of fragments + | MlLstrContext Position [String] -- ^ multiline literal string: position of opening delimiter and list of fragments + | LstrContext Position [String] -- ^ literal string: position of opening delimiter and list of fragments deriving Show -- | Add a literal fragment of a string to the current string state. strFrag :: Action -strFrag s = state \case - StrContext p acc : st -> ([], StrContext p (locThing s : acc) : st) - MlStrContext p acc : st -> ([], MlStrContext p (locThing s : acc) : st) - _ -> error "strFrag: panic" +strFrag (Located _ s) = \case + BstrContext p acc -> Resume (BstrContext p (s : acc)) + MlBstrContext p acc -> Resume (MlBstrContext p (s : acc)) + LstrContext p acc -> Resume (LstrContext p (s : acc)) + MlLstrContext p acc -> Resume (MlLstrContext p (s : acc)) + _ -> error "strFrag: panic" -- | End the current string state and emit the string literal token. endStr :: Action -endStr x = state \case - StrContext p acc : st -> ([Located p (TokString (concat (reverse (locThing x : acc))))], st) - MlStrContext p acc : st -> ([Located p (TokMlString (concat (reverse (locThing x : acc))))], st) - _ -> error "endStr: panic" +endStr (Located _ x) = \case + BstrContext p acc -> EmitToken (Located p (TokString (concat (reverse (x : acc))))) + MlBstrContext p acc -> EmitToken (Located p (TokMlString (concat (reverse (x : acc))))) + LstrContext p acc -> EmitToken (Located p (TokString (concat (reverse (x : acc))))) + MlLstrContext p acc -> EmitToken (Located p (TokMlString (concat (reverse (x : acc))))) + _ -> error "endStr: panic" -- | Start a basic string literal -startStr :: Action -startStr t = state \case - ValueContext : st -> ([], StrContext (locPosition t) [] : st) - st -> ([], StrContext (locPosition t) [] : st) +startBstr :: Action +startBstr (Located p _) _ = Resume (BstrContext p []) +-- | Start a literal string literal +startLstr :: Action +startLstr (Located p _) _ = Resume (LstrContext p []) + -- | Start a multi-line basic string literal -startMlStr :: Action -startMlStr t = state \case - ValueContext : st -> ([], MlStrContext (locPosition t) [] : st) - st -> ([], MlStrContext (locPosition t) [] : st) +startMlBstr :: Action +startMlBstr (Located p _) _ = Resume (MlBstrContext p []) +-- | Start a multi-line literal string literal +startMlLstr :: Action +startMlLstr (Located p _) _ = Resume (MlLstrContext p []) + -- | Resolve a unicode escape sequence and add it to the current string literal unicodeEscape :: Action -unicodeEscape (Located p lexeme) = +unicodeEscape (Located p lexeme) ctx = case readHex (drop 2 lexeme) of - [(n,_)] | 0xd800 <= n, n < 0xe000 -> pure [Located p (TokError "non-scalar unicode escape")] - | n >= 0x110000 -> pure [Located p (TokError "unicode escape too large")] - | otherwise -> strFrag (Located p [chr n]) + [(n,_)] | 0xd800 <= n, n < 0xe000 -> LexerError (Located p "non-scalar unicode escape") + | n >= 0x110000 -> LexerError (Located p "unicode escape too large") + | otherwise -> strFrag (Located p [chr n]) ctx _ -> error "unicodeEscape: panic" --- | Record an @=@ token and update the state -equals :: Action -equals t = state \case - st -> ([TokEquals <$ t], ValueContext : st) - --- | Record an opening square bracket and update the state -squareO :: Action -squareO t = state \case - ValueContext : st -> ([TokSquareO <$ t], ListContext (locPosition t) : st) - ListContext p : st -> ([TokSquareO <$ t], ListContext (locPosition t): ListContext p : st) - st -> ([TokSquareO <$ t], st) - --- | Record a closing square bracket and update the state -squareC :: Action -squareC t = state \case - ListContext _ : st -> ([TokSquareC <$ t], st) - st -> ([TokSquareC <$ t], st) - --- | Record an opening curly bracket and update the state -curlyO :: Action -curlyO t = state \case - ValueContext : st -> ([TokCurlyO <$ t], TableContext (locPosition t) : st) - ListContext p : st -> ([TokCurlyO <$ t], TableContext (locPosition t) : ListContext p : st) - st -> ([TokCurlyO <$ t], st) - --- | Record a closing curly bracket and update the state -curlyC :: Action -curlyC t = state \case - TableContext _ : st -> ([TokCurlyC <$ t], st) - st -> ([TokCurlyC <$ t], st) - -- | Emit a token ignoring the current lexeme token_ :: Token -> Action -token_ t x = pure [t <$ x] +token_ t x _ = EmitToken (t <$ x) -- | Emit a token using the current lexeme token :: (String -> Token) -> Action -token f x = pure [f <$> x] - --- | Emit a value token and update the current state -value_ :: Token -> Action -value_ t = value (const t) - --- | Emit a value token using the current lexeme and update the current state -value :: (String -> Token) -> Action -value f x = state \st -> - case st of - ValueContext : st' -> ([f <$> x], st') - _ -> ([f <$> x], st ) +token f x _ = EmitToken (f <$> x) -- | Attempt to parse the current lexeme as a date-time token. timeValue :: @@ -159,10 +130,10 @@ [String] {- ^ possible valid patterns -} -> (a -> Token) {- ^ token constructor -} -> Action -timeValue description patterns constructor = value \str -> +timeValue description patterns constructor (Located p str) _ = case asum [parseTimeM False defaultTimeLocale pat str | pat <- patterns] of - Nothing -> TokError ("malformed " ++ description) - Just t -> constructor t + Nothing -> LexerError (Located p ("malformed " ++ description)) + Just t -> EmitToken (Located p (constructor t)) -- | Pop the first character off a located string if it's not empty. -- The resulting 'Int' will either be the ASCII value of the character @@ -173,6 +144,7 @@ case str of "" -> Nothing x:xs + | rest `seq` False -> undefined | x == '\1' -> Just (0, rest) | isAscii x -> Just (ord x, rest) | otherwise -> Just (1, rest) @@ -180,10 +152,19 @@ rest = Located { locPosition = move x p, locThing = xs } -- | Generate the correct terminating token given the current lexer state. -eofToken :: [Context] -> Located String -> Located Token -eofToken (MlStrContext p _ : _) _ = Located p (TokError "unterminated multi-line string literal") -eofToken (StrContext p _ : _) _ = Located p (TokError "unterminated string literal") -eofToken (ListContext p : _) _ = Located p (TokError "unterminated '['") -eofToken (TableContext p : _) _ = Located p (TokError "unterminated '{'") -eofToken (ValueContext : s) t = eofToken s t -eofToken _ t = TokEOF <$ t +eofToken :: Context -> Located String -> Either (Located String) (Located Token, Located String) +eofToken (MlBstrContext p _) _ = Left (Located p "unterminated multi-line basic string") +eofToken (BstrContext p _) _ = Left (Located p "unterminated basic string") +eofToken (MlLstrContext p _) _ = Left (Located p "unterminated multi-line literal string") +eofToken (LstrContext p _) _ = Left (Located p "unterminated literal string") +eofToken _ t = Right (TokEOF <$ t, t) + +failure :: String -> Action +failure err t _ = LexerError (err <$ t) + +-- | Generate an error message given the current string being lexed. +mkError :: String -> String +mkError "" = "unexpected end-of-input" +mkError ('\n':_) = "unexpected end-of-line" +mkError ('\r':'\n':_) = "unexpected end-of-line" +mkError (x:_) = "unexpected " ++ show x diff --git a/src/Toml/Parser.y b/src/Toml/Parser.y --- a/src/Toml/Parser.y +++ b/src/Toml/Parser.y @@ -23,12 +23,12 @@ import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty -import Data.Time (Day, TimeOfDay, LocalTime, ZonedTime) -import Toml.Located (Located(Located, locPosition, locThing)) -import Toml.Position (posLine) -import Toml.Parser.Types -import Toml.Lexer (Token(..)) +import Toml.Lexer (Context(..), Token(..)) +import Toml.Located (Located(Located, locThing)) +import Toml.Parser.Types (Expr(..), Key, Val(..), SectionKind(..)) +import Toml.Parser.Utils (Parser, runParser, lexerP, errorP, push, pop, thenP, pureP, asString) +import Toml.Position (startPos) } @@ -55,17 +55,17 @@ LOCALDATETIME { Located _ (TokLocalDateTime $$) } LOCALDATE { Located _ (TokLocalDate $$) } LOCALTIME { Located _ (TokLocalTime $$) } -EOF { Located _ TokEOF } -%monad { Either (Located Token) } -%error { errorP } +%monad { Parser r } { thenP } { pureP } +%lexer { lexerP } { Located _ TokEOF } +%error { errorP } -%name parseRawToml toml +%name parseRawToml_ toml %% -toml :: { [Expr] } - : sepBy1(expression, NEWLINE) EOF { concat $1 } +toml :: { [Expr] } + : sepBy1(expression, NEWLINE) { concat $1 } expression :: { [Expr] } : { [] } @@ -74,7 +74,7 @@ | '[[' key ']]' { [ArrayTableExpr $2 ] } keyval :: { (Key, Val) } - : key '=' val { ($1,$3) } + : key rhs '=' pop val { ($1,$5) } key :: { Key } : sepBy1(simplekey, '.') { $1 } @@ -97,48 +97,49 @@ | array { ValArray $1 } | inlinetable { ValTable $1 } -inlinetable :: { [(Key, Val)] } - : '{' sepBy(keyval, ',') '}' { $2 } +inlinetable :: { [(Key, Val)] } + : lhs '{' sepBy(keyval, ',') pop '}' + { $3 } -array :: { [Val] } - : '[' newlines ']' { [] } - | '[' newlines arrayvalues ']' { reverse $3 } - | '[' newlines arrayvalues ',' newlines ']' { reverse $3 } +array :: { [Val] } + : rhs '[' newlines pop ']' { [] } + | rhs '[' newlines arrayvalues pop ']' { reverse $4 } + | rhs '[' newlines arrayvalues ',' newlines pop ']' { reverse $4 } -arrayvalues :: { [Val] } - : val newlines { [$1] } - | arrayvalues ',' newlines val newlines { $4 : $1 } +arrayvalues :: { [Val] } + : val newlines { [$1] } + | arrayvalues ',' newlines val newlines { $4 : $1 } -newlines :: {} - : {} - | newlines NEWLINE {} +newlines :: { () } + : { () } + | newlines NEWLINE{ () } -sepBy(p,q) :: { [p] } - : { [] } - | sepBy1(p,q) { NonEmpty.toList $1 } +sepBy(p,q) :: { [p] } + : { [] } + | sepBy1(p,q) { NonEmpty.toList $1 } -sepBy1(p,q) :: { NonEmpty p } - : sepBy1_(p,q) { NonEmpty.reverse $1 } +sepBy1(p,q) :: { NonEmpty p } + : sepBy1_(p,q) { NonEmpty.reverse $1 } -sepBy1_(p,q) :: { NonEmpty p } - : p { pure $1 } - | sepBy1_(p,q) q p { NonEmpty.cons $3 $1 } +sepBy1_(p,q) :: { NonEmpty p } + : p{ pure $1 } + | sepBy1_(p,q) q p{ NonEmpty.cons $3 $1 } +rhs :: { () } + : {% push ValueContext } + +lhs :: { () } + : {% push TableContext } + +pop :: { () } + : {% pop } + { -- | Parse a list of tokens either returning the first unexpected -- token or a list of the TOML statements in the file to be -- processed by "Toml.Semantics". -parseRawToml :: [Located Token] -> Either (Located Token) [Expr] --- implementation generated by happy - -errorP :: [Located Token] -> Either (Located Token) a -errorP (t:_) = Left t -errorP [] = error "Parser.errorP: unterminated token stream" - -asString :: Token -> String -asString (TokString x) = x -asString (TokBareKey x) = x -asString _ = error "simpleKeyLexeme: panic" +parseRawToml :: String -> Either (Located String) [Expr] +parseRawToml = runParser parseRawToml_ TopContext . Located startPos } diff --git a/src/Toml/Parser/Utils.hs b/src/Toml/Parser/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Toml/Parser/Utils.hs @@ -0,0 +1,87 @@ +{-| +Module : Toml.Parser.Utils +Description : Primitive operations used by the happy-generated parser +Copyright : (c) Eric Mertens, 2023 +License : ISC +Maintainer : emertens@gmail.com + +This module contains all the primitives used by the Parser module. +By extracting it from the @.y@ file we minimize the amount of code +that has warnings disabled and get better editor support. + +@since 1.3.0.0 + +-} +module Toml.Parser.Utils ( + Parser, + runParser, + pureP, + thenP, + asString, + lexerP, + errorP, + + -- * Lexer-state management + push, + pop, + ) where + +import Toml.Lexer (scanToken, Context(..)) +import Toml.Lexer.Token (Token(TokBareKey, TokString)) +import Toml.Located (Located) +import Toml.Pretty (prettyToken) + +-- continuation passing implementation of a state monad with errors +newtype Parser r a = P { + getP :: + [Context] -> Located String -> + ([Context] -> Located String -> a -> Either (Located String) r) -> + Either (Located String) r + } + +-- | Run the top-level parser +runParser :: Parser r r -> Context -> Located String -> Either (Located String) r +runParser (P k) ctx str = k [ctx] str \_ _ r -> Right r + +-- | Bind implementation used in the happy-generated parser +thenP :: Parser r a -> (a -> Parser r b) -> Parser r b +thenP (P m) f = P \ctx str k -> m ctx str \ctx' str' x -> getP (f x) ctx' str' k +{-# Inline thenP #-} + +-- | Return implementation used in the happy-generated parser +pureP :: a -> Parser r a +pureP x = P \ctx str k -> k ctx str x +{-# Inline pureP #-} + +-- | Add a new context to the lexer context stack +push :: Context -> Parser r () +push x = P \st str k -> k (x : st) str () +{-# Inline push #-} + +-- | Pop the top context off the lexer context stack. It is a program +-- error to pop without first pushing. +pop :: Parser r () +pop = P \ctx str k -> + case ctx of + [] -> error "Toml.Parser.Utils.pop: PANIC! malformed production in parser" + _ : ctx' -> k ctx' str () +{-# Inline pop #-} + +-- | Operation the parser generator uses when it reaches an unexpected token. +errorP :: Located Token -> Parser r a +errorP e = P \_ _ _ -> Left (fmap (\t -> "parse error: unexpected " ++ prettyToken t) e) + +-- | Operation the parser generator uses to request the next token. +lexerP :: (Located Token -> Parser r a) -> Parser r a +lexerP f = P \st str k -> + case scanToken (head st) str of + Left le -> Left (("lexical error: " ++) <$> le) + Right (t, str') -> getP (f t) st str' k +{-# Inline lexerP #-} + +-- | Extract the string content of a bare-key or a quoted string. +asString :: Token -> String +asString (TokString x) = x +asString (TokBareKey x) = x +asString _ = error "simpleKeyLexeme: panic" +{-# Inline asString #-} diff --git a/src/Toml/Pretty.hs b/src/Toml/Pretty.hs --- a/src/Toml/Pretty.hs +++ b/src/Toml/Pretty.hs @@ -32,6 +32,10 @@ -- * Printing keys prettySimpleKey, prettyKey, + + -- * Pretty errors + prettySemanticError, + prettyMatchMessage, ) where import Data.Char (ord, isAsciiLower, isAsciiUpper, isDigit, isPrint) @@ -45,8 +49,10 @@ import Data.Time.Format (formatTime, defaultTimeLocale) import Prettyprinter import Text.Printf (printf) -import Toml.Parser (SectionKind(..)) +import Toml.FromValue.Matcher (MatchMessage(..), Scope (..)) import Toml.Lexer (Token(..)) +import Toml.Parser.Types (SectionKind(..)) +import Toml.Semantics (SemanticError (..), SemanticErrorKind (..)) import Toml.Value (Value(..), Table) -- | Annotation used to enable styling pretty-printed TOML @@ -115,7 +121,7 @@ Tok2SquareC -> "']]'" TokCurlyO -> "'{'" TokCurlyC -> "'}'" - TokNewline -> "newline" + TokNewline -> "end-of-line" TokBareKey _ -> "bare key" TokTrue -> "true literal" TokFalse -> "false literal" @@ -127,7 +133,6 @@ TokLocalDateTime _ -> "local date-time" TokLocalDate _ -> "local date" TokLocalTime _ -> "local time" - TokError e -> "lexical error: " ++ e TokEOF -> "end-of-input" prettyAssignment :: String -> Value -> TomlDoc @@ -159,6 +164,8 @@ 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)) +-- | Predicate for values that should be completely rendered on the +-- righthand-side of an @=@. isAlwaysSimple :: Value -> Bool isAlwaysSimple = \case Integer _ -> True @@ -172,10 +179,14 @@ Table x -> isSingularTable x Array x -> null x || not (all isTable x) +-- | Predicate for table values. isTable :: Value -> Bool isTable Table {} = True isTable _ = False +-- | Predicate for tables that can be rendered with a single assignment. +-- These can be collapsed using dotted-key notation on the lefthand-side +-- of a @=@. isSingularTable :: Table -> Bool isSingularTable (Map.elems -> [v]) = isAlwaysSimple v isSingularTable _ = False @@ -262,13 +273,34 @@ subtables = [prettySection (prefix `snoc` k) v | (k,v) <- sections] - prettySection key (Table t) = - prettyToml_ mbKeyProj TableKind (NonEmpty.toList key) t + prettySection key (Table tab) = + prettyToml_ mbKeyProj TableKind (NonEmpty.toList key) tab prettySection key (Array a) = - vcat [prettyToml_ mbKeyProj ArrayTableKind (NonEmpty.toList key) t | Table t <- a] + vcat [prettyToml_ mbKeyProj ArrayTableKind (NonEmpty.toList key) tab | Table tab <- 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] + +-- | Render a semantic TOML error in a human-readable string. +-- +-- @since 1.3.0.0 +prettySemanticError :: SemanticError -> String +prettySemanticError (SemanticError key kind) = + printf "key error: %s %s" (show (prettySimpleKey key)) + case kind of + AlreadyAssigned -> "is already assigned" :: String + ClosedTable -> "is a closed table" + ImplicitlyTable -> "is already implicitly defined to be a table" + +-- | Render a TOML decoding error as a human-readable string. +-- +-- @since 1.3.0.0 +prettyMatchMessage :: MatchMessage -> String +prettyMatchMessage (MatchMessage scope msg) = + msg ++ " in top" ++ foldr f "" scope + where + f (ScopeIndex i) = ('[' :) . shows i . (']':) + f (ScopeKey key) = ('.' :) . shows (prettySimpleKey key) diff --git a/src/Toml/Semantics.hs b/src/Toml/Semantics.hs --- a/src/Toml/Semantics.hs +++ b/src/Toml/Semantics.hs @@ -12,25 +12,51 @@ key assignments. -} -module Toml.Semantics (semantics) where +module Toml.Semantics (SemanticError(..), SemanticErrorKind(..), semantics) where +import Control.Applicative ((<|>)) import Control.Monad (foldM) import Data.List (sortOn) import Data.List.NonEmpty (NonEmpty((:|))) import Data.List.NonEmpty qualified as NonEmpty import Data.Map (Map) import Data.Map qualified as Map -import Text.Printf (printf) -import Toml.Located (locThing, Located, locPosition) -import Toml.Parser (SectionKind(..), Key, Val(..), Expr(..)) +import Toml.Located (locThing, Located) +import Toml.Parser.Types (SectionKind(..), Key, Val(..), Expr(..)) import Toml.Value (Table, Value(..)) -import Toml.Position (Position(..)) -import Toml.Pretty (prettySimpleKey) -import Control.Applicative ((<|>)) +-- | The type of errors that can be generated when resolving all the key +-- used in a TOML document. These errors always pertain to some key to +-- caused one of three conflicts. +-- +-- @since 1.3.0.0 +data SemanticError = SemanticError { + errorKey :: String, + errorKind :: SemanticErrorKind + } deriving ( + Read {- ^ Default instance -}, + Show {- ^ Default instance -}, + Eq {- ^ Default instance -}, + Ord {- ^ Default instance -}) + +-- | Enumeration of the kinds of conflicts a key can generate. +-- +-- @since 1.3.0.0 +data SemanticErrorKind + = AlreadyAssigned -- ^ Attempted to assign to a key that was already assigned + | ClosedTable -- ^ Attempted to open a table already closed + | ImplicitlyTable -- ^ Attempted to open a tables as an array of tables that was implicitly defined to be a table + deriving ( + Read {- ^ Default instance -}, + Show {- ^ Default instance -}, + Eq {- ^ Default instance -}, + Ord {- ^ Default instance -}) + -- | Extract semantic value from sequence of raw TOML expressions --- or report an error string. -semantics :: [Expr] -> Either String Table +-- or report a semantic error. +-- +-- @since 1.3.0.0 +semantics :: [Expr] -> Either (Located SemanticError) Table semantics exprs = do let (topKVs, tables) = gather exprs m1 <- assignKeyVals topKVs Map.empty @@ -81,10 +107,10 @@ -- reverses the list while converting the frames to tables toArray = foldl (\acc frame -> Table (framesToTable frame) : acc) [] -constructTable :: [(Key, Value)] -> Either String Table +constructTable :: [(Key, Value)] -> Either (Located SemanticError) Table constructTable entries = case findBadKey (map fst entries) of - Just bad -> invalidKey bad "is already assigned" + Just bad -> invalidKey bad AlreadyAssigned Nothing -> Right (Map.unionsWith merge [singleValue (locThing k) (locThing <$> ks) v | (k:|ks, v) <- entries]) where merge (Table x) (Table y) = Table (Map.unionWith merge x y) @@ -107,16 +133,15 @@ [] -> Just y1 x' : xs' -> check1 (x' :| xs') (y2 :| ys) check1 _ _ = Nothing - - - +-- | Attempts to insert the key-value pairs given into a new section +-- located at the given key-path in a frame map. addSection :: SectionKind {- ^ section kind -} -> KeyVals {- ^ values to install -} -> Key {- ^ section key -} -> Map String Frame {- ^ local frame map -} -> - Either String (Map String Frame) {- ^ error message or updated local frame map -} + Either (Located SemanticError) (Map String Frame) {- ^ error message or updated local frame map -} addSection kind kvs = walk where walk (k1 :| []) = flip Map.alterF (locThing k1) \case @@ -130,18 +155,18 @@ Just (FrameTable Open t) -> case kind of TableKind -> go (FrameTable Closed) t - ArrayTableKind -> invalidKey k1 "is already a table" + ArrayTableKind -> invalidKey k1 ImplicitlyTable -- Add a new array element to an existing table array Just (FrameArray a) -> case kind of ArrayTableKind -> go (FrameArray . (`NonEmpty.cons` a)) Map.empty - TableKind -> invalidKey k1 "is already an array of tables" + TableKind -> invalidKey k1 ClosedTable -- failure cases - Just (FrameTable Closed _) -> invalidKey k1 "is a closed table" + Just (FrameTable Closed _) -> invalidKey k1 ClosedTable Just (FrameTable Dotted _) -> error "addSection: dotted table left unclosed" - Just (FrameValue {}) -> invalidKey k1 "is already assigned" + Just (FrameValue {}) -> invalidKey k1 AlreadyAssigned where go g t = Just . g . closeDots <$> assignKeyVals kvs t @@ -149,7 +174,7 @@ Nothing -> go (FrameTable Open ) Map.empty Just (FrameTable tk t) -> go (FrameTable tk ) t Just (FrameArray (t :| ts)) -> go (FrameArray . (:| ts)) t - Just (FrameValue _) -> invalidKey k1 "is already assigned" + Just (FrameValue _) -> invalidKey k1 AlreadyAssigned where go g t = Just . g <$> walk (k2 :| ks) t @@ -161,31 +186,31 @@ FrameTable Dotted t -> FrameTable Closed (closeDots t) frame -> frame -assignKeyVals :: KeyVals -> Map String Frame -> Either String (Map String Frame) +assignKeyVals :: KeyVals -> Map String Frame -> Either (Located SemanticError) (Map String Frame) assignKeyVals kvs t = closeDots <$> foldM f t kvs where f m (k,v) = assign k v m -- | Assign a single dotted key in a frame. -assign :: Key -> Val -> Map String Frame -> Either String (Map String Frame) +assign :: Key -> Val -> Map String Frame -> Either (Located SemanticError) (Map String Frame) assign (key :| []) val = flip Map.alterF (locThing key) \case Nothing -> Just . FrameValue <$> valToValue val - Just{} -> invalidKey key "is already assigned" + Just{} -> invalidKey key AlreadyAssigned assign (key :| k1 : keys) val = flip Map.alterF (locThing key) \case Nothing -> go Map.empty Just (FrameTable Open t) -> go t Just (FrameTable Dotted t) -> go t - Just (FrameTable Closed _) -> invalidKey key "is a closed table" - Just (FrameArray _) -> invalidKey key "is a closed table" - Just (FrameValue _) -> invalidKey key "is already assigned" + Just (FrameTable Closed _) -> invalidKey key ClosedTable + Just (FrameArray _) -> invalidKey key ClosedTable + Just (FrameValue _) -> invalidKey key AlreadyAssigned where go t = Just . FrameTable Dotted <$> assign (k1 :| keys) val t -- | Convert 'Val' to 'Value' potentially raising an error if -- it has inline tables with key-conflicts. -valToValue :: Val -> Either String Value +valToValue :: Val -> Either (Located SemanticError) Value valToValue = \case ValInteger x -> Right (Integer x) ValFloat x -> Right (Float x) @@ -199,9 +224,5 @@ ValTable kvs -> do entries <- (traverse . traverse) valToValue kvs Table <$> constructTable entries -invalidKey :: Located String -> String -> Either String a -invalidKey k msg = Left (printf "%d:%d: key error: %s %s" - (posLine (locPosition k)) - (posColumn (locPosition k)) - (show (prettySimpleKey (locThing k))) - msg) +invalidKey :: Located String -> SemanticErrorKind -> Either (Located SemanticError) a +invalidKey key kind = Left ((`SemanticError` kind) <$> key) diff --git a/src/Toml/ToValue.hs b/src/Toml/ToValue.hs --- a/src/Toml/ToValue.hs +++ b/src/Toml/ToValue.hs @@ -22,14 +22,20 @@ -- * Table construction ToTable(..), + ToKey(..), defaultTableToValue, table, (.=), ) where +import Data.Foldable (toList) import Data.Int (Int8, Int16, Int32, Int64) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NonEmpty import Data.Map (Map) import Data.Map qualified as Map +import Data.Ratio (Ratio) +import Data.Sequence (Seq) import Data.Text qualified import Data.Text.Lazy qualified import Data.Time (Day, TimeOfDay, LocalTime, ZonedTime) @@ -40,8 +46,11 @@ -- | Build a 'Table' from a list of key-value pairs. -- -- Use '.=' for a convenient way to build the pairs. -table :: [(String, Value)] -> Value -table = Table . Map.fromList +-- +-- @since 1.3.0.0 +table :: [(String, Value)] -> Table +table = Map.fromList +{-# INLINE table #-} -- | Convenience function for building key-value pairs while -- constructing a 'Table'. @@ -72,13 +81,37 @@ toTable :: a -> Table -- | @since 1.0.1.0 -instance (k ~ String, ToValue v) => ToTable (Map k v) where - toTable m = Map.fromList [(k, toValue v) | (k,v) <- Map.assocs m] +instance (ToKey k, ToValue v) => ToTable (Map k v) where + toTable m = table [(toKey k, toValue v) | (k,v) <- Map.assocs m] -- | @since 1.0.1.0 -instance (k ~ String, ToValue v) => ToValue (Map k v) where +instance (ToKey k, ToValue v) => ToValue (Map k v) where toValue = defaultTableToValue +-- | Convert to a table key +-- +-- @since 1.3.0.0 +class ToKey a where + toKey :: a -> String + +-- | toKey = id +-- +-- @since 1.3.0.0 +instance Char ~ a => ToKey [a] where + toKey = id + +-- | toKey = unpack +-- +-- @since 1.3.0.0 +instance ToKey Data.Text.Text where + toKey =Data.Text.unpack + +-- | toKey = unpack +-- +-- @since 1.3.0.0 +instance ToKey Data.Text.Lazy.Text where + toKey = Data.Text.Lazy.unpack + -- | Convenience function for building 'ToValue' instances. defaultTableToValue :: ToTable a => a -> Value defaultTableToValue = Table . toTable @@ -108,6 +141,24 @@ -- | This instance defers to the list element's 'toValueList' implementation. instance ToValue a => ToValue [a] where toValue = toValueList + +-- | Converts to list and encodes that to value +-- +-- @since 1.3.0.0 +instance ToValue a => ToValue (NonEmpty a) where + toValue = toValue . NonEmpty.toList + +-- | Converts to list and encodes that to value +-- +-- @since 1.3.0.0 +instance ToValue a => ToValue (Seq a) where + toValue = toValue . toList + +-- | Converts to a 'Double'. This can overflow to infinity. +-- +-- @since 1.3.0.0 +instance Integral a => ToValue (Ratio a) where + toValue = Float . realToFrac instance ToValue Double where toValue = Float instance ToValue Float where toValue = Float . realToFrac diff --git a/test/DecodeSpec.hs b/test/DecodeSpec.hs --- a/test/DecodeSpec.hs +++ b/test/DecodeSpec.hs @@ -9,7 +9,7 @@ import Toml (decode, Result(Success), encode) import Toml.FromValue (FromValue(..), runParseTable, reqKey, optKey) import Toml.FromValue.Generic (genericParseTable) -import Toml.ToValue (ToTable(..), ToValue(toValue), (.=), defaultTableToValue) +import Toml.ToValue (ToTable(..), ToValue(toValue), table, (.=), defaultTableToValue) import Toml.ToValue.Generic (genericToTable) import Toml (Result(..)) import Toml.FromValue (parseTableFromValue) @@ -52,7 +52,7 @@ <*> (fromMaybe [] <$> optKey "varieties")) instance ToTable Fruit where - toTable (Fruit n mbp vs) = Map.fromList $ + toTable (Fruit n mbp vs) = table $ ["varieties" .= vs | not (null vs)] ++ ["physical" .= p | Just p <- [mbp]] ++ ["name" .= n] @@ -125,11 +125,11 @@ (Fruits [Fruit "peach" Nothing [], Fruit "pineapple" Nothing []]) it "handles missing key errors" $ - (decode "[[fruits]]" :: Result Fruits) + (decode "[[fruits]]" :: Result String Fruits) `shouldBe` Failure ["missing key: name in top.fruits[0]"] it "handles parse errors while decoding" $ - (decode "x =" :: Result Fruits) + (decode "x =" :: Result String Fruits) `shouldBe` Failure ["1:4: parse error: unexpected end-of-input"] diff --git a/test/FromValueSpec.hs b/test/FromValueSpec.hs --- a/test/FromValueSpec.hs +++ b/test/FromValueSpec.hs @@ -9,64 +9,71 @@ module FromValueSpec (spec) where import Control.Applicative ((<|>), empty) +import Control.Monad (when) 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 (Result(..), FromValue(fromValue), optKey, parseTableFromValue, reqKey, warnTable, pickKey, runParseTable) +import Toml.FromValue.Matcher (Matcher, runMatcher) import Toml.FromValue.ParseTable (KeyAlt(..)) +import Toml.Pretty (prettyMatchMessage) +import Toml.ToValue (table, (.=)) +humanMatcher :: Matcher a -> Result String a +humanMatcher m = + case runMatcher m of + Failure e -> Failure (prettyMatchMessage <$> e) + Success w x -> Success (prettyMatchMessage <$> w) x + spec :: Spec spec = do it "handles one reqKey" $ - runMatcher (parseTableFromValue (reqKey "test") (table [("test", String "val")])) + humanMatcher (runParseTable (reqKey "test") (table ["test" .= "val"])) `shouldBe` Success [] "val" it "handles one optKey" $ - runMatcher (parseTableFromValue (optKey "test") (table [("test", String "val")])) + humanMatcher (runParseTable (optKey "test") (table ["test" .= "val"])) `shouldBe` Success [] (Just "val") it "handles one missing optKey" $ - runMatcher (parseTableFromValue (optKey "test") (table [("nottest", String "val")])) + humanMatcher (runParseTable (optKey "test") (table ["nottest" .= "val"])) `shouldBe` Success ["unexpected key: nottest in top"] (Nothing :: Maybe String) it "handles one missing reqKey" $ - runMatcher (parseTableFromValue (reqKey "test") (table [("nottest", String "val")])) + humanMatcher (runParseTable (reqKey "test") (table ["nottest" .= "val"])) `shouldBe` - (Failure ["missing key: test in top"] :: Result String) + (Failure ["missing key: test in top"] :: Result String String) it "handles one mismatched reqKey" $ - runMatcher (parseTableFromValue (reqKey "test") (table [("test", String "val")])) + humanMatcher (runParseTable (reqKey "test") (table ["test" .= "val"])) `shouldBe` - (Failure ["type error. wanted: integer got: string in top.test"] :: Result Integer) + (Failure ["type error. wanted: integer got: string in top.test"] :: Result String Integer) it "handles one mismatched optKey" $ - runMatcher (parseTableFromValue (optKey "test") (table [("test", String "val")])) + humanMatcher (runParseTable (optKey "test") (table ["test" .= "val"])) `shouldBe` - (Failure ["type error. wanted: integer got: string in top.test"] :: Result (Maybe Integer)) + (Failure ["type error. wanted: integer got: string in top.test"] :: Result String (Maybe Integer)) it "handles concurrent errors" $ - runMatcher (parseTableFromValue (reqKey "a" <|> empty <|> reqKey "b") (table [])) + humanMatcher (runParseTable (reqKey "a" <|> empty <|> reqKey "b") (table [])) `shouldBe` - (Failure ["missing key: a in top", "missing key: b in top"] :: Result Integer) + (Failure ["missing key: a in top", "missing key: b in top"] :: Result String Integer) it "handles concurrent value mismatch" $ let v = String "" in - runMatcher (Left <$> fromValue v <|> empty <|> Right <$> fromValue v) + humanMatcher (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)) + :: Result String (Either Bool Int)) it "doesn't emit an error for empty" $ - runMatcher (parseTableFromValue empty (table [])) + humanMatcher (runParseTable empty (table [])) `shouldBe` - (Failure [] :: Result Integer) + (Failure [] :: Result String Integer) it "matches single characters" $ runMatcher (fromValue (String "x")) @@ -74,9 +81,9 @@ Success [] 'x' it "rejections non-single characters" $ - runMatcher (fromValue (String "xy")) + humanMatcher (fromValue (String "xy")) `shouldBe` - (Failure ["type error. wanted: character got: string in top"] :: Result Char) + (Failure ["type error. wanted: character got: string in top"] :: Result String Char) it "collects warnings in table matching" $ let pt = @@ -86,20 +93,20 @@ 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)])) + humanMatcher (runParseTable pt (table ["k1" .= (1 :: Integer), "k2" .= (2 :: Integer)])) `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 [])) + humanMatcher (runParseTable pt (table [])) `shouldBe` - (Failure ["possible keys: this, \".\" in top"] :: Result Char) + (Failure ["possible keys: this, \".\" in top"] :: Result String Char) it "generates an error message on an empty pickKey" $ let pt = pickKey [] in - runMatcher (parseTableFromValue pt (table [])) + humanMatcher (runParseTable pt (table [])) `shouldBe` - (Failure [] :: Result Char) + (Failure [] :: Result String Char) diff --git a/test/HieDemoSpec.hs b/test/HieDemoSpec.hs --- a/test/HieDemoSpec.hs +++ b/test/HieDemoSpec.hs @@ -1,3 +1,4 @@ +{-# Language GADTs #-} {-| Module : HieDemoSpec Description : Exercise various components of FromValue on a life-sized example @@ -130,13 +131,13 @@ instance FromValue CradleComponent where fromValue = parseTableFromValue $ - pickKey [ - Key "multi" (fmap Multi . fromValue), - Key "cabal" (fmap Cabal . fromValue), - Key "stack" (fmap Stack . fromValue), - Key "direct" (fmap Direct . fromValue), - Key "bios" (fmap Bios . fromValue), - Key "none" (fmap None . fromValue)] + reqAlts [ + KeyCase Multi "multi", + KeyCase Cabal "cabal", + KeyCase Stack "stack", + KeyCase Direct "direct", + KeyCase Bios "bios", + KeyCase None "none"] instance FromValue MultiSubComponent where fromValue = parseTableFromValue genericParseTable @@ -181,14 +182,26 @@ <*> optKey "with-ghc" where getCallable = - pickKey [ - Key "program" (fmap Program . fromValue), - Key "shell" (fmap Shell . fromValue)] + reqAlts [ + KeyCase Program "program", + KeyCase Shell "shell"] getDepsCallable = - optional (pickKey [ - Key "dependency-program" (fmap Program . fromValue), - Key "dependency-shell" (fmap Shell . fromValue)]) + optAlts [ + KeyCase Program "dependency-program", + KeyCase Shell "dependency-shell"] +data KeyCase a where + KeyCase :: FromValue b => (b -> a) -> String -> KeyCase a + +reqAlts :: [KeyCase a] -> ParseTable a +reqAlts xs = pickKey + [Key key (fmap con . fromValue) | KeyCase con key <- xs] + +optAlts :: [KeyCase a] -> ParseTable (Maybe a) +optAlts xs = pickKey $ + [Key key (fmap (Just . con) . fromValue) | KeyCase con key <- xs] ++ + [Else (pure Nothing)] + instance FromValue NoneConfig where fromValue = parseTableFromValue genericParseTable @@ -267,7 +280,7 @@ |] `shouldBe` (Failure ["type error. wanted: string got: integer in top.cradle.cabal.component"] - :: Result CradleConfig) + :: Result String CradleConfig) it "detects unusd keys" $ decode [quoteStr| diff --git a/test/LexerSpec.hs b/test/LexerSpec.hs --- a/test/LexerSpec.hs +++ b/test/LexerSpec.hs @@ -40,22 +40,37 @@ it "catches unclosed [" $ parse "x = [1,2,3" `shouldBe` - Left "1:5: lexical error: unterminated '['" + Left "1:11: parse error: unexpected end-of-input" it "catches unclosed {" $ parse "x = { y" `shouldBe` - Left "1:5: lexical error: unterminated '{'" + Left "1:8: parse error: unexpected end-of-input" it "catches unclosed \"" $ parse "x = \"abc" `shouldBe` - Left "1:5: lexical error: unterminated string literal" + Left "1:5: lexical error: unterminated basic string" it "catches unclosed \"\"\"" $ parse "x = \"\"\"test" `shouldBe` - Left "1:5: lexical error: unterminated multi-line string literal" + Left "1:5: lexical error: unterminated multi-line basic string" + + it "catches unclosed '" $ + parse "x = 'abc\ny = 2" + `shouldBe` + Left "1:9: lexical error: unexpected end-of-line" + + it "catches unclosed '" $ + parse "x = 'abc" + `shouldBe` + Left "1:5: lexical error: unterminated literal string" + + it "catches unclosed '''" $ + parse "x = '''test\n\n" + `shouldBe` + Left "1:5: lexical error: unterminated multi-line literal string" it "handles escapes at the end of input" $ parse "x = \"\\" diff --git a/test/TomlSpec.hs b/test/TomlSpec.hs --- a/test/TomlSpec.hs +++ b/test/TomlSpec.hs @@ -28,7 +28,7 @@ key = "value" # This is a comment at the end of a line another = "# This is not a comment"|] `shouldBe` - Right (Map.fromList [("another",String "# This is not a comment"),("key",String "value")]) + Right (table [("another",String "# This is not a comment"),("key",String "value")]) describe "key/value pair" do it "supports the most basic assignments" $ @@ -52,7 +52,7 @@ bare-key = "value" 1234 = "value"|] `shouldBe` - Right (Map.fromList [ + Right (table [ "1234" .= "value", "bare-key" .= "value", "bare_key" .= "value", @@ -66,7 +66,7 @@ 'key2' = "value" 'quoted "value"' = "value"|] `shouldBe` - Right (Map.fromList [ + Right (table [ "127.0.0.1" .= "value", "character encoding" .= "value", "key2" .= "value", @@ -80,7 +80,7 @@ physical.shape = "round" site."google.com" = true|] `shouldBe` - Right (Map.fromList [ + Right (table [ "name" .= "Orange", "physical" .= table ["color" .= "orange", "shape" .= "round"], "site" .= table ["google.com" .= True]]) @@ -108,7 +108,7 @@ apple.color = "red" orange.color = "orange"|] `shouldBe` - Right (Map.fromList [ + Right (table [ "apple" .= table [ "color" .= "red", "skin" .= "thin", @@ -119,7 +119,8 @@ "type" .= "fruit"]]) it "allows numeric bare keys" $ - parse "3.14159 = 'pi'" `shouldBe` Right (Map.singleton "3" (table [("14159", String "pi")])) + parse "3.14159 = 'pi'" `shouldBe` Right (table [ + "3" .= table [("14159", String "pi")]]) it "allows keys that look like other values" $ parse [quoteStr| @@ -128,7 +129,7 @@ 1900-01-01 = 1900-01-01 1_2 = 2_3|] `shouldBe` - Right (Map.fromList [ + Right (table [ "1900-01-01" .= (read "1900-01-01" :: Day), "1_2" .= (23::Int), "false" .= False, @@ -166,7 +167,7 @@ the lazy dog.\ """|] `shouldBe` - Right (Map.fromList [ + Right (table [ "str1" .= "The quick brown fox jumps over the lazy dog.", "str2" .= "The quick brown fox jumps over the lazy dog.", "str3" .= "The quick brown fox jumps over the lazy dog."]) @@ -180,7 +181,7 @@ # "This," she said, "is just a pointless statement." str7 = """"This," she said, "is just a pointless statement.""""|] `shouldBe` - Right (Map.fromList [ + Right (table [ "str4" .= "Here are two quotation marks: \"\". Simple enough.", "str5" .= "Here are three quotation marks: \"\"\".", "str6" .= "Here are fifteen quotation marks: \"\"\"\"\"\"\"\"\"\"\"\"\"\"\".", @@ -199,7 +200,7 @@ quoted = 'Tom "Dubs" Preston-Werner' regex = '<\i\c*\s*>'|] `shouldBe` - Right (Map.fromList [ + Right (table [ "quoted" .= "Tom \"Dubs\" Preston-Werner", "regex" .= "<\\i\\c*\\s*>", "winpath" .= "C:\\Users\\nodejs\\templates", @@ -215,7 +216,7 @@ is preserved. '''|] `shouldBe` - Right (Map.fromList [ + Right (table [ "lines" .= "The first newline is\ntrimmed in raw strings.\nAll other whitespace\nis preserved.\n", "regex2" .= "I [dw]on't need \\d{2} apples"]) @@ -224,7 +225,7 @@ x = "\\\b\f\r\U0010abcd" y = """\\\b\f\r\u7bca\U0010abcd\n\r\t"""|] `shouldBe` - Right (Map.fromList [ + Right (table [ "x" .= "\\\b\f\r\x0010abcd", "y" .= "\\\b\f\r\x7bca\x0010abcd\n\r\t"]) @@ -233,6 +234,12 @@ x = "\U11111111"|] `shouldBe` Left "1:6: lexical error: unicode escape too large" + it "handles unexpected end of line" $ + parse [quoteStr| + x = "example + y = 42|] + `shouldBe` Left "1:13: lexical error: unexpected end-of-line" + describe "integer" do it "parses literals correctly" $ parse [quoteStr| @@ -256,7 +263,7 @@ # binary with prefix `0b` bin1 = 0b11010110|] `shouldBe` Right - (Map.fromList [ + (table [ "bin1" .= Integer 214, "hex1" .= Integer 0xDEADBEEF, "hex2" .= Integer 0xDEADBEEF, @@ -272,6 +279,12 @@ "oct1" .= Integer 0o01234567, "oct2" .= Integer 0o755]) + it "handles leading zeros gracefully" $ + parse "x = 01" + `shouldBe` + Left "1:5: lexical error: leading zero prohibited" + + describe "float" do it "parses floats" $ parse [quoteStr| @@ -293,7 +306,7 @@ sf2 = +inf # positive infinity sf3 = -inf # negative infinity|] `shouldBe` - Right (Map.fromList [ + Right (table [ "flt1" .= Float 1.0, "flt2" .= Float 3.1415, "flt3" .= Float (-1.0e-2), @@ -319,13 +332,21 @@ Left{} -> False Right x -> all checkNaN x + -- code using Numeric.readFloat can use significant + -- resources. this makes sure this doesn't start happening + -- in the future + it "parses huge floats without great delays" $ + parse "x = 1e1000000000000" + `shouldBe` + Right (Map.singleton "x" (Float (1/0))) + describe "boolean" do it "parses boolean literals" $ parse [quoteStr| bool1 = true bool2 = false|] `shouldBe` - Right (Map.fromList [ + Right (table [ "bool1" .= True, "bool2" .= False]) @@ -337,7 +358,7 @@ odt3 = 1979-05-27T00:32:00.999999-07:00 odt4 = 1979-05-27 07:32:00Z|] `shouldBe` - Right (Map.fromList [ + Right (table [ "odt1" .= ZonedTime (read "1979-05-27 07:32:00 +0000"), "odt2" .= ZonedTime (read "1979-05-27 00:32:00 -0700"), "odt3" .= ZonedTime (read "1979-05-27 00:32:00.999999 -0700"), @@ -350,7 +371,7 @@ ldt2 = 1979-05-27T00:32:00.999999 ldt3 = 1979-05-28 00:32:00.999999|] `shouldBe` - Right (Map.fromList [ + Right (table [ "ldt1" .= LocalTime (read "1979-05-27 07:32:00"), "ldt2" .= LocalTime (read "1979-05-27 00:32:00.999999"), "ldt3" .= LocalTime (read "1979-05-28 00:32:00.999999")]) @@ -374,7 +395,7 @@ lt1 = 07:32:00 lt2 = 00:32:00.999999|] `shouldBe` - Right (Map.fromList [ + Right (table [ "lt1" .= TimeOfDay (read "07:32:00"), "lt2" .= TimeOfDay (read "00:32:00.999999")]) @@ -394,14 +415,14 @@ { name = "Baz Qux", email = "bazqux@example.com", url = "https://example.com/bazqux" } ]|] `shouldBe` - Right (Map.fromList [ + Right (table [ "colors" .= ["red", "yellow", "green"], "contributors" .= [ String "Foo Bar ", - table [ + Table (table [ "email" .= "bazqux@example.com", "name" .= "Baz Qux", - "url" .= "https://example.com/bazqux"]], + "url" .= "https://example.com/bazqux"])], "integers" .= [1, 2, 3 :: Integer], "nested_arrays_of_ints" .= [[1, 2], [3, 4, 5 :: Integer]], "nested_mixed_array" .= [[Integer 1, Integer 2], [String "a", String "b", String "c"]], @@ -419,7 +440,7 @@ 2, # this is ok ]|] `shouldBe` - Right (Map.fromList [ + Right (table [ "integers2" .= [1, 2, 3 :: Int], "integers3" .= [1, 2 :: Int]]) @@ -428,7 +449,7 @@ describe "table" do it "allows empty tables" $ - parse "[table]" `shouldBe` Right (Map.singleton "table" (table [])) + parse "[table]" `shouldBe` Right (table ["table" .= table []]) it "parses simple tables" $ parse [quoteStr| @@ -440,7 +461,7 @@ key1 = "another string" key2 = 456|] `shouldBe` - Right (Map.fromList [ + Right (table [ "table-1" .= table [ "key1" .= "some string", "key2" .= Integer 123], @@ -453,7 +474,7 @@ [dog."tater.man"] type.name = "pug"|] `shouldBe` - Right (Map.fromList [("dog", table [("tater.man", table [("type", table [("name",String "pug")])])])]) + Right (table ["dog" .= table ["tater.man" .= table ["type" .= table ["name" .= "pug"]]]]) it "allows whitespace around keys" $ parse [quoteStr| @@ -462,7 +483,7 @@ [ g . h . i ] # same as [g.h.i] [ j . "ʞ" . 'l' ] # same as [j."ʞ".'l']|] `shouldBe` - Right (Map.fromList [ + Right (table [ "a" .= table ["b" .= table ["c" .= table []]], "d" .= table ["e" .= table ["f" .= table []]], "g" .= table ["h" .= table ["i" .= table []]], @@ -478,7 +499,7 @@ [x] # defining a super-table afterward is ok q=1|] `shouldBe` - Right (Map.fromList [ + Right (table [ "x" .= table [ "q" .= Integer 1, "y" .= table [ @@ -501,7 +522,7 @@ [fruit.apple.texture] # you can add sub-tables smooth = true|] `shouldBe` - Right (Map.fromList [ + Right (table [ "fruit" .= table [ "apple" .= table [ "color" .= "red", @@ -517,7 +538,7 @@ point = { x = 1, y = 2 } animal = { type.name = "pug" }|] `shouldBe` - Right (Map.fromList [ + Right (table [ "animal" .= table ["type" .= table ["name" .= "pug"]], "name" .= table ["first" .= "Tom", "last" .= "Preston-Werner"], "point" .= table ["x" .= Integer 1, "y" .= Integer 2]]) @@ -552,11 +573,11 @@ color = "gray"|] `shouldBe` Success mempty (Map.singleton "products" [ - Map.fromList [ + table [ "name" .= "Hammer", "sku" .= Integer 738594937], Map.empty, - Map.fromList [ + table [ "color" .= "gray", "name" .= "Nail", "sku" .= Integer 284758393]]) @@ -583,7 +604,7 @@ [[fruits.varieties]] name = "plantain"|] `shouldBe` - Right (Map.fromList [ + Right (table [ "fruits" .= [ table [ "name" .= "apple", @@ -608,7 +629,7 @@ [[fruit]] # parser must throw an error upon discovering that "fruit" is # an array rather than a table name = "apple"|] - `shouldBe` Left "6:3: key error: fruit is already a table" + `shouldBe` Left "6:3: key error: fruit is already implicitly defined to be a table" it "prevents redefining an inline array" $ parse [quoteStr| @@ -659,13 +680,13 @@ parse [quoteStr| t = { a.x.y = 1, a.x.z = 2, a.q = 3}|] `shouldBe` - Right (Map.fromList [ - ("t", table [ - ("a", table [ - ("q",Integer 3), - ("x", table [ + Right (table [ + "t" .= table [ + "a" .= table [ + "q" .= Integer 3, + "x" .= table [ ("y",Integer 1), - ("z",Integer 2)])])])]) + ("z",Integer 2)]]]]) it "disallows overwriting assignments with tables" $ parse [quoteStr| @@ -731,4 +752,10 @@ parse [quoteStr| [[x.y]] [x.y]|] - `shouldBe` Left "2:4: key error: y is already an array of tables" + `shouldBe` Left "2:4: key error: y is a closed table" + + it "quotes table names in semantic errors" $ + parse [quoteStr| + [[x.""]] + [x.""]|] + `shouldBe` Left "2:4: key error: \"\" is a closed table" 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.1.0 +version: 1.3.0.0 synopsis: TOML 1.0.0 parser description: TOML parser using generated lexers and parsers with @@ -54,7 +54,6 @@ Toml.FromValue.ParseTable Toml.Lexer Toml.Lexer.Token - Toml.Lexer.Utils Toml.Located Toml.Parser Toml.Parser.Types @@ -64,6 +63,9 @@ Toml.ToValue Toml.ToValue.Generic Toml.Value + other-modules: + Toml.Lexer.Utils + Toml.Parser.Utils build-depends: array ^>= 0.5, base ^>= {4.14, 4.15, 4.16, 4.17, 4.18}, @@ -84,7 +86,7 @@ default-extensions: QuasiQuotes build-tool-depends: - hspec-discover:hspec-discover ^>= 2 + hspec-discover:hspec-discover ^>= {2.10, 2.11} build-depends: base, containers,