diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Revision history for toml-parser +## 1.0.1.0 -- + +* Add ToTable and ToValue instances for Map +* Refine error messages +* More test coverage + ## 1.0.0.0 -- 2023-06-29 * Complete rewrite including 1.0.0 compliance and pretty-printing. 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 @@ -16,8 +16,6 @@ Result(..), ) 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.Writer.CPS (runWriterT, tell, WriterT) diff --git a/src/Toml/Lexer.x b/src/Toml/Lexer.x --- a/src/Toml/Lexer.x +++ b/src/Toml/Lexer.x @@ -19,7 +19,7 @@ -} module Toml.Lexer (scanTokens, lexValue, Token(..)) where -import Control.Monad.Trans.State.Strict (runState) +import Control.Monad.Trans.State.Strict (evalState, runState) import Toml.Lexer.Token import Toml.Lexer.Utils import Toml.Located @@ -41,12 +41,6 @@ @barekey = [0-9 A-Z a-z \- _]+ -@escape_seq_char = [\x22 \x5C \x62 \x66 \x6E \x72 \x74] | "u" $hexdig{4} - | "U0010" $hexdig{4} - | "U000" $hexdig{5} -@escaped = \\ @escape_seq_char -@basic_char = $basic_unescaped | @escaped - @unsigned_dec_int = $digit | [1-9] ($digit | _ $digit)+ @dec_int = [\-\+]? @unsigned_dec_int @zero_prefixable_int = $digit ($digit | _ $digit)* @@ -64,8 +58,7 @@ $non_eol = [\x09 \x20-\x7E $non_ascii] @comment = $comment_start_symbol $non_eol* -$literal_char = [ \x09 \x20-\x26 \x28-\x7E $non_ascii ] -@basic_string = \" @basic_char* \" +$literal_char = [\x09 \x20-\x26 \x28-\x7E $non_ascii] @literal_string = "'" $literal_char* "'" @ml_literal_string_delim = "'''" @@ -75,25 +68,19 @@ @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 -@ml_basic_string_delim = \" \" \" -@mlb_quotes = \" \"? @mlb_escaped_nl = \\ @ws @newline ($wschar | @newline)* -$mlb_unescaped = [$wschar \x21 \x23-\x5B \x5D-\x7E $non_ascii] -@mlb_char = $mlb_unescaped | @escaped -@mlb_content = @mlb_char | @newline | @mlb_escaped_nl -@ml_basic_body = @mlb_content* (@mlb_quotes @mlb_content+)* @mlb_quotes? -@ml_basic_string = @ml_basic_string_delim @newline? @ml_basic_body @ml_basic_string_delim +$unescaped = [$wschar \x21 \x23-\x5B \x5D-\x7E $non_ascii] -@date_fullyear = $digit {4} -@date_month = $digit {2} -@date_mday = $digit {2} -$time_delim = [Tt\ ] -@time_hour = $digit {2} -@time_minute = $digit {2} -@time_second = $digit {2} -@time_secfrac = "." $digit+ +@date_fullyear = $digit {4} +@date_month = $digit {2} +@date_mday = $digit {2} +$time_delim = [Tt\ ] +@time_hour = $digit {2} +@time_minute = $digit {2} +@time_second = $digit {2} +@time_secfrac = "." $digit+ @time_numoffset = [\+\-] @time_hour ":" @time_minute -@time_offset = [Zz] | @time_numoffset +@time_offset = [Zz] | @time_numoffset @partial_time = @time_hour ":" @time_minute ":" @time_second @time_secfrac? @full_date = @date_fullyear "-" @date_month "-" @date_mday @@ -108,9 +95,6 @@ { -"[" { enterList } -"]" { exitList } -"{" { enterTable } @dec_int { value mkDecInteger } @hex_int { value mkHexInteger } @oct_int { value mkOctInteger } @@ -131,27 +115,55 @@ "]]" { token_ Tok2SquareC } } +<0,val> { @newline { token_ TokNewline } @comment; $wschar+; -@basic_string { value mkBasicString } @literal_string { value mkLiteralString } @ml_literal_string { value mkMlLiteralString } -@ml_basic_string { value mkMlBasicString } -"}" { exitTable } "=" { equals } "." { token_ TokPeriod } "," { token_ TokComma } -"[" { token_ TokSquareO } -"]" { token_ TokSquareC } -"{" { token_ TokCurlyO } +"[" { squareO } +"]" { squareC } +"{" { curlyO } +"}" { curlyC } -@barekey { token TokBareKey } +@barekey { token TokBareKey } +\"{3} @newline? { startMlStr } +\" { startStr } + +} + + { + $unescaped+ { strFrag } + \" { endStr . fmap (drop 1) } +} + + { + @mlb_escaped_nl; + ($unescaped | @newline)+ { strFrag } + \" {1,2} { strFrag } + \" {3,5} { endStr . fmap (drop 3) } +} + + { + \\ U $hexdig{8} { unicodeEscape } + \\ u $hexdig{4} { unicodeEscape } + \\ n { strFrag . ("\n" <$) } + \\ t { strFrag . ("\t" <$) } + \\ r { strFrag . ("\r" <$) } + \\ f { strFrag . ("\f" <$) } + \\ b { strFrag . ("\b" <$) } + \\ \\ { strFrag . ("\\" <$) } + \\ \" { strFrag . ("\"" <$) } +} + { -- | Generate a lazy-list of tokens from the input string. @@ -163,21 +175,23 @@ scanTokens' :: [Context] -> AlexInput -> [Located Token] scanTokens' st str = case alexScan str (stateInt st) of - AlexEOF -> [TokEOF <$ str] + AlexEOF -> [eofToken st str] AlexError str' -> [mkError <$> str'] AlexSkip str' _ -> scanTokens' st str' AlexToken str' n action -> - case runState (traverse (action . take n) str) st of - (t, st') -> t : scanTokens' st' str' + case runState (action (take n <$> str)) st of + (t, st') -> t ++ scanTokens' st' str' stateInt :: [Context] -> Int -stateInt (ValueContext : _) = val -stateInt (ListContext : _) = val -stateInt _ = 0 +stateInt (ValueContext : _) = val +stateInt (ListContext {} : _) = val +stateInt (StrContext {} : _) = bstr +stateInt (MlStrContext{} : _) = mlbstr +stateInt _ = 0 -- | 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 str = lexValue_ Located { locPosition = startPos, locThing = str } lexValue_ :: Located String -> Token lexValue_ str = @@ -185,6 +199,9 @@ AlexEOF -> TokError "end of input" AlexError{} -> TokError "lexer error" AlexSkip str' _ -> lexValue_ str' - AlexToken _ n action -> fst (runState (action (take n (locThing str))) [ValueContext]) + AlexToken _ n action -> + case evalState (action (take n <$> str)) [ValueContext] of + t:_ -> locThing t + [] -> TokError "lexer error" } 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 @@ -12,12 +12,10 @@ -} module Toml.Lexer.Token ( Token(..), - - mkBasicString, + mkLiteralString, - mkMlBasicString, mkMlLiteralString, - + -- * integer literals mkBinInteger, mkDecInteger, @@ -37,7 +35,6 @@ mkError, ) where -import Data.Char (chr, isSpace) import Data.Time (Day, LocalTime, TimeOfDay, ZonedTime) import Numeric (readBin, readHex, readOct) @@ -107,51 +104,6 @@ mkLiteralString :: String -> Token mkLiteralString = TokString . tail . init --- | Construct a 'TokString' from a basic string lexeme. -mkBasicString :: String -> Token -mkBasicString "" = error "processBasic: missing initializer" -mkBasicString (_:start) = enforceScalar TokString (go start) - where - go [] = error "processBasic: missing terminator" - go "\"" = "" - go ('\\':'"':xs) = '"' : go xs - go ('\\':'\\':xs) = '\\' : go xs - go ('\\':'b':xs) = '\b' : go xs - go ('\\':'f':xs) = '\f' : go xs - go ('\\':'n':xs) = '\n' : go xs - go ('\\':'r':xs) = '\r' : go xs - go ('\\':'t':xs) = '\t' : go xs - go ('\\':'u':a:b:c:d:xs) = chr (fst (head (readHex [a,b,c,d]))) : go xs - go ('\\':'U':a:b:c:d:e:f:g:h:xs) = chr (fst (head (readHex [a,b,c,d,e,f,g,h]))) : go xs - go (x:xs) = x : go xs - --- | Construct a 'TokMlString' from a basic multi-line string lexeme. -mkMlBasicString :: String -> Token -mkMlBasicString str = - enforceScalar TokMlString - case str of - '"':'"':'"':'\r':'\n':start -> go start - '"':'"':'"':'\n':start -> go start - '"':'"':'"':start -> go start - _ -> error "processMlBasic: missing initializer" - where - go "\"\"\"" = "" - go ('\\':'"':xs) = '"' : go xs - go ('\\':'\\':xs) = '\\' : go xs - go ('\\':'b':xs) = '\b' : go xs - go ('\\':'f':xs) = '\f' : go xs - go ('\\':'n':xs) = '\n' : go xs - go ('\\':'r':xs) = '\r' : go xs - go ('\\':'t':xs) = '\t' : go xs - go ('\\':'u':a:b:c:d:xs) = chr (fst (head (readHex [a,b,c,d]))) : go xs - go ('\\':'U':a:b:c:d:e:f:g:h:xs) = chr (fst (head (readHex [a,b,c,d,e,f,g,h]))) : go xs - go ('\\':'\r':xs) = go (dropWhile isSpace xs) - go ('\\':'\n':xs) = go (dropWhile isSpace xs) - go ('\\':' ':xs) = go (dropWhile isSpace xs) - go ('\\':'\t':xs) = go (dropWhile isSpace xs) - go (x:xs) = x : go xs - go [] = error "processMlBasic: missing terminator" - -- | Construct a 'TokMlString' from a literal multi-line string lexeme. mkMlLiteralString :: String -> Token mkMlLiteralString str = @@ -166,16 +118,10 @@ go (x:xs) = x : go xs go "" = error "processMlLiteral: missing terminator" -enforceScalar :: (String -> Token) -> String -> Token -enforceScalar f str - | any isInvalid str = TokError "string literal controls non-scalar value" - | otherwise = f str - where - isInvalid x = '\xd800' <= x && x < '\xe000' - -- | Make a 'TokError' from a lexical error message. mkError :: String -> Token -mkError str = TokError ("Lexical error: " ++ show (head str)) +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 @@ -11,9 +11,9 @@ -} module Toml.Lexer.Utils ( - + -- * Types - M, Action, + Action, Context(..), -- * Actions @@ -21,86 +21,127 @@ value_, token, token_, - enterList, - exitList, - enterTable, - exitTable, + + squareO, + squareC, + curlyO, + curlyC, + equals, timeValue, + strFrag, + startMlStr, + startStr, + endStr, + unicodeEscape, + + eofToken, + -- * Alex extension points AlexInput, alexGetByte, ) where -import Control.Monad.Trans.State.Strict (State, modify, state) -import Data.Char (ord, isAscii) +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) +import Numeric (readHex) import Toml.Located (Located(..)) -import Toml.Position (move) +import Toml.Position (move, Position) import Toml.Lexer.Token (Token(..)) -type M a = State [Context] a - -type Action = String -> M Token +type Action = Located String -> State [Context] [Located Token] data Context - = ListContext -- ^ processing an inline list, lex values - | TableContext -- ^ processing an inline table, don't lex values + = 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] + | StrContext Position [String] deriving Show -pushContext :: Context -> M () -pushContext cxt = modify \st -> - case st of - ValueContext : st' -> cxt : st' - _ -> cxt : st +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" +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" + +startStr :: Action +startStr t = state \case + ValueContext : st -> ([], StrContext (locPosition t) [] : st) + st -> ([], StrContext (locPosition t) [] : st) + +startMlStr :: Action +startMlStr t = state \case + ValueContext : st -> ([], MlStrContext (locPosition t) [] : st) + st -> ([], MlStrContext (locPosition t) [] : st) + +unicodeEscape :: Action +unicodeEscape (Located p lexeme) = + 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]) + _ -> error "unicodeEscape: panic" + equals :: Action -equals _ = TokEquals <$ pushContext ValueContext +equals t = state \case + st -> ([TokEquals <$ t], ValueContext : st) -enterList :: Action -enterList _ = TokSquareO <$ pushContext ListContext +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) -enterTable :: Action -enterTable _ = TokCurlyO <$ pushContext TableContext +squareC :: Action +squareC t = state \case + ListContext _ : st -> ([TokSquareC <$ t], st) + st -> ([TokSquareC <$ t], st) -exitTable :: Action -exitTable _ = state \case - TableContext : st -> (TokCurlyC , st) - st -> (TokError "Unmatched }", st) +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) -exitList :: Action -exitList _ = state \case - ListContext : st -> (TokSquareC , st) - [] -> (TokSquareC , []) - st -> (TokError "Unmatched ]", st) +curlyC :: Action +curlyC t = state \case + TableContext _ : st -> ([TokCurlyC <$ t], st) + st -> ([TokCurlyC <$ t], st) token_ :: Token -> Action -token_ t _ = pure t +token_ t x = pure [t <$ x] token :: (String -> Token) -> Action -token f x = pure (f x) +token f x = pure [f <$> x] value_ :: Token -> Action -value_ t _ = emitValue t +value_ t x = emitValue (t <$ x) value :: (String -> Token) -> Action -value f x = emitValue (f x) +value f x = emitValue (f <$> x) -emitValue :: a -> M a +emitValue :: Located Token -> State [Context] [Located Token] emitValue v = state \st -> case st of - ValueContext:st' -> (v, st') - _ -> (v, st ) + ValueContext : st' -> ([v], st') + _ -> ([v], st ) timeValue :: ParseTime a => String -> [String] -> (a -> Token) -> Action timeValue description patterns constructor = value \str -> case asum [parseTimeM False defaultTimeLocale pattern str | pattern <- patterns] of - Nothing -> TokError ("Malformed " ++ description) + Nothing -> TokError ("malformed " ++ description) Just t -> constructor t type AlexInput = Located String @@ -115,3 +156,11 @@ | otherwise -> Just (1, rest) where rest = Located { locPosition = move x p, locThing = xs } + +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 diff --git a/src/Toml/Semantics.hs b/src/Toml/Semantics.hs --- a/src/Toml/Semantics.hs +++ b/src/Toml/Semantics.hs @@ -26,6 +26,7 @@ import Toml.Value (Table, Value(..)) import Toml.Position (Position(..)) import Toml.Pretty (prettySimpleKey) +import Control.Applicative ((<|>)) -- | Extract semantic value from sequence of raw TOML expressions -- or report an error string. @@ -79,7 +80,7 @@ constructTable :: [(Key, Value)] -> Either String Table constructTable entries = case findBadKey (map fst entries) of - Just bad -> invalidKey (NonEmpty.last bad) "is overlapped" + Just bad -> invalidKey bad "is already assigned" 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) @@ -89,14 +90,23 @@ singleValue k (k1:ks) v = Map.singleton k (Table (singleValue k1 ks v)) -- | Finds a key that overlaps with another in the same list -findBadKey :: [Key] -> Maybe Key +findBadKey :: [Key] -> Maybe (Located String) findBadKey = check . sortOn (fmap locThing) where - check (x:y:_) - | NonEmpty.toList (fmap locThing x) `NonEmpty.isPrefixOf` fmap locThing y = Just x - check (_:xs) = check xs - check [] = Nothing + check :: [Key] -> Maybe (Located String) + check (x:y:z) = check1 x y <|> check (y:z) + check _ = Nothing + check1 (x :| xs) (y1 :| y2 : ys) + | locThing x == locThing y1 = + case xs of + [] -> Just y1 + x' : xs' -> check1 (x' :| xs') (y2 :| ys) + check1 _ _ = Nothing + + + + addSection :: SectionKind {- ^ section kind -} -> KeyVals {- ^ values to install -} -> @@ -127,7 +137,7 @@ -- failure cases Just (FrameTable Closed _) -> invalidKey k1 "is a closed table" Just (FrameTable Dotted _) -> error "addSection: dotted table left unclosed" - Just (FrameValue {}) -> invalidKey k1 "is assigned" + Just (FrameValue {}) -> invalidKey k1 "is already assigned" where go g t = Just . g . closeDots <$> assignKeyVals kvs t @@ -135,7 +145,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 assigned" + Just (FrameValue _) -> invalidKey k1 "is already assigned" where go g t = Just . g <$> walk (k2 :| ks) t @@ -157,15 +167,15 @@ assign (key :| []) val = flip Map.alterF (locThing key) \case Nothing -> Just . FrameValue <$> valToValue val - Just{} -> invalidKey key "is assigned" + Just{} -> invalidKey key "is already assigned" 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 closed" - Just (FrameArray _) -> invalidKey key "is closed" - Just (FrameValue _) -> invalidKey key "is assigned" + Just (FrameTable Closed _) -> invalidKey key "is a closed table" + Just (FrameArray _) -> invalidKey key "is a closed table" + Just (FrameValue _) -> invalidKey key "is already assigned" where go t = Just . FrameTable Dotted <$> assign (k1 :| keys) val t diff --git a/src/Toml/ToValue.hs b/src/Toml/ToValue.hs --- a/src/Toml/ToValue.hs +++ b/src/Toml/ToValue.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeOperators, TypeFamilies #-} {-| Module : Toml.ToValue Description : Automation for converting application values to TOML. @@ -17,6 +18,7 @@ ) where import Data.Int (Int8, Int16, Int32, Int64) +import Data.Map (Map) import Data.Map qualified as Map import Data.Time (Day, TimeOfDay, LocalTime, ZonedTime) import Data.Word (Word8, Word16, Word32, Word64) @@ -56,6 +58,14 @@ -- | Convert a single value into a table 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] + +-- | @since 1.0.1.0 +instance (k ~ String, ToValue v) => ToValue (Map k v) where + toValue = defaultTableToValue -- | Convenience function for building 'ToValue' instances. defaultTableToValue :: ToTable a => a -> Value diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -12,18 +12,85 @@ -} module Main (main) where -import Data.Either (isLeft) import Data.Map (Map) import Data.Map qualified as Map import Data.Time (Day, TimeOfDay, LocalTime, ZonedTime) import QuoteStr (quoteStr) import Test.Hspec (hspec, describe, it, shouldBe, shouldSatisfy, Spec) -import Toml (Value(..), parse, decode, Result(Success), prettyToml, Table) +import Toml (Value(..), parse, decode, encode, Result(Success), prettyToml, Table) import Toml.FromValue (FromValue(..), defaultTableFromValue, reqKey, optKey, runParseTable, ParseTable, FromTable (fromTable)) -import Toml.ToValue (table, (.=)) +import Toml.ToValue (table, (.=), toValue) main :: IO () main = hspec do + + describe "lexer" + do it "handles special cased control character" $ + parse "x = '\SOH'" + `shouldBe` + Left "1:6: lexical error: unexpected '\\SOH'" + + -- These seem boring, but they provide test coverage of an error case in the state machine + it "handles unexpected '}'" $ + parse "}" + `shouldBe` + Left "1:1: parse error: unexpected '}'" + + it "handles unexpected '{'" $ + parse "{" + `shouldBe` + Left "1:1: parse error: unexpected '{'" + + it "accepts tabs" $ + parse "x\t=\t1" + `shouldBe` + Right (Map.singleton "x" (Integer 1)) + + it "computes columns correctly with tabs" $ + parse "x\t=\t=" + `shouldBe` + Left "1:17: parse error: unexpected '='" + + it "detects non-scalars in strings" $ + parse "x = \"\\udfff\"" + `shouldBe` + Left "1:6: lexical error: non-scalar unicode escape" + + it "catches unclosed [" $ + parse "x = [1,2,3" + `shouldBe` + Left "1:5: lexical error: unterminated '['" + + it "catches unclosed {" $ + parse "x = { y" + `shouldBe` + Left "1:5: lexical error: unterminated '{'" + + it "catches unclosed \"" $ + parse "x = \"abc" + `shouldBe` + Left "1:5: lexical error: unterminated string literal" + + it "catches unclosed \"\"\"" $ + parse "x = \"\"\"test" + `shouldBe` + Left "1:5: lexical error: unterminated multi-line string literal" + + it "handles escapes at the end of input" $ + parse "x = \"\\" + `shouldBe` + Left "1:7: lexical error: unexpected end-of-input" + + it "handles invalid escapes" $ + parse "x = \"\\p\"" + `shouldBe` + Left "1:7: lexical error: unexpected 'p'" + + describe "ToValue" + do + it "converts characters as singleton strings" $ + toValue '!' `shouldBe` String "!" + describe "parse" do describe "comment" do it "ignores comments" $ @@ -39,10 +106,14 @@ parse "key = \"value\"" `shouldBe` Right (Map.singleton "key" (String "value")) it "requires a value after equals" $ - parse "key = # INVALID" `shouldSatisfy` isLeft + parse "key = # INVALID" + `shouldBe` + Left "1:16: parse error: unexpected end-of-input" it "requires newlines between assignments" $ - parse "first = \"Tom\" last = \"Preston-Werner\" # INVALID" `shouldSatisfy` isLeft + parse "first = \"Tom\" last = \"Preston-Werner\" # INVALID" + `shouldBe` + Left "1:15: parse error: unexpected bare key" describe "keys" do it "allows bare keys" $ @@ -89,13 +160,13 @@ parse [quoteStr| name = "Tom" name = "Pradyun"|] - `shouldSatisfy` isLeft + `shouldBe` Left "2:1: key error: name is already assigned" it "prevents duplicate keys even between bare and quoted" $ parse [quoteStr| spelling = "favorite" "spelling" = "favourite"|] - `shouldSatisfy` isLeft + `shouldBe` Left "2:1: key error: spelling is already assigned" it "allows out of order definitions" $ parse [quoteStr| @@ -189,7 +260,7 @@ it "disallows triple quotes inside a multiline string" $ parse [quoteStr| str5 = """Here are three quotation marks: """.""" # INVALID|] - `shouldSatisfy` isLeft + `shouldBe` Left "1:46: parse error: unexpected '.'" it "ignores escapes in literal strings" $ parse [quoteStr| @@ -231,7 +302,7 @@ it "rejects out of range unicode escapes" $ parse [quoteStr| x = "\U11111111"|] - `shouldSatisfy` isLeft + `shouldBe` Left "1:6: lexical error: unicode escape too large" describe "integer" do it "parses literals correctly" $ @@ -355,6 +426,12 @@ "ldt2" .= LocalTime (read "1979-05-27 00:32:00.999999"), "ldt3" .= LocalTime (read "1979-05-28 00:32:00.999999")]) + it "catches invalid date-times" $ + parse [quoteStr| + ldt = 9999-99-99T99:99:99|] + `shouldBe` + Left "1:7: lexical error: malformed local date-time" + describe "local date" do it "parses dates" $ parse [quoteStr| @@ -485,7 +562,7 @@ apple.color = 'red' apple.taste.sweet = true [fruit.apple]|] - `shouldSatisfy` isLeft + `shouldBe` Left "4:8: key error: apple is a closed table" it "can add subtables" $ parse [quoteStr| @@ -521,14 +598,14 @@ [product] type = { name = "Nail" } type.edible = false # INVALID|] - `shouldSatisfy` isLeft + `shouldBe` Left "3:1: key error: type is already assigned" it "prevents using inline tables to add keys to existing tables" $ parse [quoteStr| [product] type.name = "Nail" type = { edible = false } # INVALID|] - `shouldSatisfy` isLeft + `shouldBe` Left "3:1: key error: type is already assigned" describe "array of tables" do it "supports array of tables syntax" $ @@ -602,7 +679,7 @@ [[fruit]] # parser must throw an error upon discovering that "fruit" is # an array rather than a table name = "apple"|] - `shouldSatisfy` isLeft + `shouldBe` Left "6:3: key error: fruit is already a table" it "prevents redefining an inline array" $ parse [quoteStr| @@ -610,7 +687,7 @@ fruits = [] [[fruits]] # Not allowed|] - `shouldSatisfy` isLeft + `shouldBe` Left "4:3: key error: fruits is already assigned" -- these cases are needed to complete coverage checking on Semantics module describe "corner cases" @@ -626,7 +703,7 @@ parse [quoteStr| [x.y] [x] - [x.y]|] `shouldSatisfy` isLeft + [x.y]|] `shouldBe` Left "3:4: key error: y is a closed table" it "super tables of array tables preserve array tables" $ parse [quoteStr| @@ -647,7 +724,7 @@ it "detects conflicting inline keys" $ parse [quoteStr| x = { y = 1, y.z = 2}|] - `shouldSatisfy` isLeft + `shouldBe` Left "1:14: key error: y is already assigned" it "handles merging dotted inline table keys" $ parse [quoteStr| @@ -665,7 +742,7 @@ parse [quoteStr| x = 1 [x.y]|] - `shouldSatisfy` isLeft + `shouldBe` Left "2:2: key error: x is already assigned" it "handles super super tables" $ parse [quoteStr| @@ -689,14 +766,14 @@ [x] y.q = 1 [x.y]|] - `shouldSatisfy` isLeft + `shouldBe` Left "4:4: key error: y is a closed table" it "dotted tables can't assign through closed tables!" $ parse [quoteStr| [x.y] [x] y.z.w = 1|] - `shouldSatisfy` isLeft + `shouldBe` Left "3:1: key error: y is a closed table" it "super tables can't add new subtables to array tables via dotted keys" $ parse [quoteStr| @@ -704,7 +781,7 @@ [x] y.z.a = 1 y.z.b = 2|] - `shouldSatisfy` isLeft + `shouldBe` Left "3:1: key error: y is a closed table" it "the previous example preserves closeness" $ parse [quoteStr| @@ -712,20 +789,20 @@ [x] y.z.a = 1 y.w = 2|] - `shouldSatisfy` isLeft + `shouldBe` Left "3:1: key error: y is a closed table" it "defining a supertable closes the supertable" $ parse [quoteStr| [x.y] [x] [x]|] - `shouldSatisfy` isLeft + `shouldBe` Left "3:2: key error: x is a closed table" it "prevents redefining an array of tables" $ parse [quoteStr| [[x.y]] [x.y]|] - `shouldSatisfy` isLeft + `shouldBe` Left "2:4: key error: y is already an array of tables" describe "deserialization" deserializationTests describe "pretty-printing" prettyTests @@ -736,8 +813,8 @@ prettyTests :: Spec prettyTests = do it "renders example 1" $ - fmap tomlString (parse "x=1") - `shouldBe` Right [quoteStr| + show (encode (Map.singleton "x" (1 :: Integer))) + `shouldBe` [quoteStr| x = 1|] it "renders example 2" $ @@ -780,9 +857,9 @@ y = 4|] it "renders escapes in strings" $ - fmap tomlString (parse "a=\"\\b\\t\\r\\f\\\"\\u007f\\U0001000c\"") + fmap tomlString (parse "a=\"\\\\\\b\\t\\r\\n\\f\\\"\\u007f\\U0001000c\"") `shouldBe` Right [quoteStr| - a = "\b\t\r\f\"\u007F\U0001000C"|] + a = "\\\b\t\r\n\f\"\u007F\U0001000C"|] it "renders floats" $ fmap tomlString (parse "a=0.0\nb=-0.1\nc=0.1\nd=3.141592653589793\ne=4e123") @@ -824,6 +901,13 @@ fmap tomlString (parse "''.'a b'.'\"' = 10") `shouldBe` Right [quoteStr| ""."a b"."\"" = 10|] + + it "renders inline tables" $ + fmap tomlString (parse [quoteStr| + x = [[{a = 'this is a longer example', b = 'and it will linewrap'},{c = 'all on its own'}]]|]) + `shouldBe` Right [quoteStr| + x = [ [ {a = "this is a longer example", b = "and it will linewrap"} + , {c = "all on its own"} ] ]|] newtype Fruits = Fruits [Fruit] deriving (Eq, Show) 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.0.0.0 +version: 1.0.1.0 synopsis: TOML 1.0.0 parser description: TOML parser using generated lexers and parsers with @@ -73,7 +73,7 @@ build-depends: base, containers, - hspec ^>= 2.11, + hspec >= 2.10 && < 2.12, template-haskell ^>= 2.18 || ^>= 2.19 || ^>= 2.20, time, toml-parser,