toml-parser 1.2.1.0 → 1.3.0.0
raw patch · 20 files changed
+731/−413 lines, 20 filesdep ~basedep ~containers
Dependency ranges changed: base, containers
Files
- ChangeLog.md +9/−0
- src/Toml.hs +16/−10
- src/Toml/FromValue.hs +70/−12
- src/Toml/FromValue/Generic.hs +2/−4
- src/Toml/FromValue/Matcher.hs +67/−26
- src/Toml/FromValue/ParseTable.hs +1/−1
- src/Toml/Lexer.x +58/−58
- src/Toml/Lexer/Token.hs +2/−33
- src/Toml/Lexer/Utils.hs +72/−91
- src/Toml/Parser.y +44/−43
- src/Toml/Parser/Utils.hs +87/−0
- src/Toml/Pretty.hs +38/−6
- src/Toml/Semantics.hs +54/−33
- src/Toml/ToValue.hs +56/−5
- test/DecodeSpec.hs +4/−4
- test/FromValueSpec.hs +33/−26
- test/HieDemoSpec.hs +27/−14
- test/LexerSpec.hs +19/−4
- test/TomlSpec.hs +67/−40
- toml-parser.cabal +5/−3
ChangeLog.md view
@@ -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.
src/Toml.hs view
@@ -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
src/Toml/FromValue.hs view
@@ -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
src/Toml/FromValue/Generic.hs view
@@ -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. --
src/Toml/FromValue/Matcher.hs view
@@ -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
src/Toml/FromValue/ParseTable.hs view
@@ -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
src/Toml/Lexer.x view
@@ -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 @@ <val> { -@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 } } +<lstr> {+ $literal_char+ { strFrag }+ "'" { endStr . fmap (drop 1) }+}+ <bstr> { $unescaped+ { strFrag } \" { endStr . fmap (drop 1) } } +<mllstr> {+ @mll_content+ { strFrag }+ "'" {1,2} { strFrag }+ "'" {3,5} { endStr . fmap (drop 3) }+}+ <mlbstr> { @mlb_escaped_nl; ($unescaped | @newline)+ { strFrag }@@ -154,7 +160,9 @@ <mlbstr, bstr> { \\ 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) }
src/Toml/Lexer/Token.hs view
@@ -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]
src/Toml/Lexer/Utils.hs view
@@ -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
src/Toml/Parser.y view
@@ -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 }
+ src/Toml/Parser/Utils.hs view
@@ -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 #-}
src/Toml/Pretty.hs view
@@ -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)
src/Toml/Semantics.hs view
@@ -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)
src/Toml/ToValue.hs view
@@ -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
test/DecodeSpec.hs view
@@ -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"]
test/FromValueSpec.hs view
@@ -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)
test/HieDemoSpec.hs view
@@ -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|
test/LexerSpec.hs view
@@ -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 = \"\\"
test/TomlSpec.hs view
@@ -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 <foo@example.com>",- 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"
toml-parser.cabal view
@@ -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,