toml-parser 1.0.0.0 → 1.0.1.0
raw patch · 9 files changed
+305/−185 lines, 9 files
Files
- ChangeLog.md +6/−0
- src/Toml/FromValue/Matcher.hs +0/−2
- src/Toml/Lexer.x +60/−43
- src/Toml/Lexer/Token.hs +4/−58
- src/Toml/Lexer/Utils.hs +90/−41
- src/Toml/Semantics.hs +22/−12
- src/Toml/ToValue.hs +10/−0
- test/Main.hs +111/−27
- toml-parser.cabal +2/−2
ChangeLog.md view
@@ -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.
src/Toml/FromValue/Matcher.hs view
@@ -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)
src/Toml/Lexer.x view
@@ -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 @@ <val> { -"[" { 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 }++}++<bstr> {+ $unescaped+ { strFrag }+ \" { endStr . fmap (drop 1) }+}++<mlbstr> {+ @mlb_escaped_nl;+ ($unescaped | @newline)+ { strFrag }+ \" {1,2} { strFrag }+ \" {3,5} { endStr . fmap (drop 3) }+}++<mlbstr, bstr> {+ \\ 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" }
src/Toml/Lexer/Token.hs view
@@ -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]
src/Toml/Lexer/Utils.hs view
@@ -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
src/Toml/Semantics.hs view
@@ -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
src/Toml/ToValue.hs view
@@ -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
test/Main.hs view
@@ -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)
toml-parser.cabal view
@@ -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,