diff --git a/benchmarks/Benchmarks.hs b/benchmarks/Benchmarks.hs --- a/benchmarks/Benchmarks.hs +++ b/benchmarks/Benchmarks.hs @@ -30,4 +30,9 @@ , bench "repeated-4x" $ whnf (parseTomlDoc "") repeatedToml ] + , bgroup "file-check" + [ bench "example" $ whnf (checkTomlDoc "") exampleToml + , bench "repeated-4x" $ whnf (checkTomlDoc "") repeatedToml + ] + ] diff --git a/htoml-megaparsec.cabal b/htoml-megaparsec.cabal --- a/htoml-megaparsec.cabal +++ b/htoml-megaparsec.cabal @@ -1,5 +1,5 @@ name: htoml-megaparsec -version: 1.0.1.3 +version: 1.0.1.4 synopsis: Parser for TOML files description: TOML is an obvious and minimal format for config files. This package provides a TOML parser @@ -32,6 +32,7 @@ exposed-modules: Text.Toml , Text.Toml.Parser , Text.Toml.Types + , Text.Megaparsec.CharRW hs-source-dirs: src default-language: Haskell2010 build-depends: base >= 4.8 && < 5 diff --git a/src/Text/Megaparsec/CharRW.hs b/src/Text/Megaparsec/CharRW.hs new file mode 100644 --- /dev/null +++ b/src/Text/Megaparsec/CharRW.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE GADTs #-} + +module Text.Megaparsec.CharRW ( module X + , oneOf + , noneOf + ) where + +import Text.Megaparsec +import Text.Megaparsec.Char as X hiding (noneOf, oneOf) +import qualified Text.Megaparsec.Char as Megaparsec + +{-# RULES +"noneOf/char" forall c. noneOf [c] = char 'c' +"noneOf/satsify" forall c c'. noneOf [c, c'] = satisfy (\x -> x /= c && x /= c') +"oneOf/notChar" forall c. oneOf [c] = notChar 'c' +"oneOf/satisfy" forall c c'. oneOf [c, c'] = satisfy (\x -> x == c || x == c') + #-} + +{-# RULES +"noneOf/satsify" forall c c' c''. noneOf [c, c', c''] = satisfy (\x -> x /= c && x /= c' && x /= c'') +"oneOf/satsify" forall c c' c''. oneOf [c, c', c''] = satisfy (\x -> x == c || x == c' || x == c'') + #-} + +{-# INLINE [1] noneOf #-} +noneOf :: (Foldable f, MonadParsec e s m, Token s ~ Char) => f Char -> m Char +noneOf = Megaparsec.noneOf + +{-# INLINE [1] oneOf #-} +oneOf :: (Foldable f, MonadParsec e s m, Token s ~ Char) => f Char -> m Char +oneOf = Megaparsec.oneOf diff --git a/src/Text/Toml.hs b/src/Text/Toml.hs --- a/src/Text/Toml.hs +++ b/src/Text/Toml.hs @@ -11,3 +11,6 @@ -- of the document as a 'Table'. parseTomlDoc :: String -> Text -> Either TomlError Table parseTomlDoc = flip evalState mempty .* runParserT tomlDoc + +checkTomlDoc :: String -> Text -> Either TomlError () +checkTomlDoc = flip evalState mempty .* runParserT tomlCheck diff --git a/src/Text/Toml/Parser.hs b/src/Text/Toml/Parser.hs --- a/src/Text/Toml/Parser.hs +++ b/src/Text/Toml/Parser.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-} @@ -9,33 +10,32 @@ , module Text.Toml.Types ) where -import Control.Applicative hiding (many, optional, (<|>)) +import Control.Applicative hiding (many, optional, (<|>)) import Control.Monad -import Control.Monad.State (evalState) -import Data.Char (isAsciiLower, isAsciiUpper, isDigit) -import qualified Data.HashMap.Strict as M -import qualified Data.Set as S -import Data.Text (Text, pack, unpack) -import qualified Data.Text as T -import qualified Data.Vector as V +import Control.Monad.State (evalState) +import qualified Data.HashMap.Strict as M +import qualified Data.Set as S +import Data.Text (Text, pack, unpack) +import qualified Data.Text as T +import qualified Data.Vector as V import Data.Void -import Text.Megaparsec.Char +import Text.Megaparsec.CharRW #if MIN_VERSION_time(1,5,0) -import Data.Time.Format (defaultTimeLocale, iso8601DateFormat, - parseTimeM) +import Data.Time.Format (defaultTimeLocale, iso8601DateFormat, + parseTimeM) #else -import Data.Time.Format (parseTime) -import System.Locale (defaultTimeLocale, iso8601DateFormat) +import Data.Time.Format (parseTime) +import System.Locale (defaultTimeLocale, iso8601DateFormat) #endif -import Numeric (readHex) -import Text.Megaparsec hiding (runParser) +import Numeric (readHex) +import Text.Megaparsec hiding (runParser) import Text.Toml.Types -- Imported last to fix redundancy warning -import Prelude hiding (concat, takeWhile) +import Prelude hiding (concat, takeWhile) type TomlError = ParseError (Token Text) Void @@ -44,6 +44,17 @@ parseOnly :: Parser Toml a -> Text -> Either TomlError a parseOnly parser = flip evalState mempty . runParserT parser "noneSrc" +-- | Checks a complete document formatted according to the TOML spec. +tomlCheck :: (TomlM m) => Parser m () +tomlCheck = do + skipBlanks + table + many namedSection + -- Ensure the input is completely consumed + eof + -- make a set of named sections. + pure () + -- | Parses a complete document formatted according to the TOML spec. tomlDoc :: (TomlM m) => Parser m Table tomlDoc = do @@ -58,7 +69,7 @@ -- | Parses a table of key-value pairs. table :: (TomlM m) => Parser m Table table = do - pairs <- many (assignment <* skipBlanks) <|> (skipBlanks >> return []) + pairs <- many (assignment <* skipBlanks) <|> (skipBlanks >> pure []) case maybeDupe (map fst pairs) of Just k -> throwParser $ "Cannot redefine key " ++ unpack k Nothing -> return $ M.fromList pairs @@ -88,7 +99,7 @@ -- 'NTable' or 'NTArray' in the second. namedSection :: (TomlM m) => Parser m ([Text], Node) namedSection = do - eitherHdr <- try (Left <$> tableHeader) <|> try (Right <$> tableArrayHeader) + eitherHdr <- try (Left <$> tableHeader) <|> (Right <$> tableArrayHeader) skipBlanks tbl <- table skipBlanks @@ -134,7 +145,7 @@ <|> (try datetime "datetime") <|> (try float "float") <|> (try integer "integer") - <|> (inlineTable "inline table") + <|> (inlineTable "inline table") -- @@ -147,7 +158,7 @@ <|> (try (arrayOf anyStr) "array of strings") <|> (try (arrayOf datetime) "array of datetimes") <|> (try (arrayOf float) "array of floats") - <|> (try (arrayOf integer) "array of integers") + <|> (arrayOf integer "array of integers") boolean :: (TomlM m) => Parser m Node @@ -159,31 +170,30 @@ anyStr = VString <$> anyStr' anyStr' :: (TomlM m) => Parser m Text -anyStr' = try multiBasicStr <|> try basicStr <|> try multiLiteralStr <|> try literalStr +anyStr' = try multiBasicStr <|> try basicStr <|> try multiLiteralStr <|> literalStr basicStr :: (TomlM m) => Parser m Text basicStr = between dQuote dQuote (pack <$> many strChar) where - strChar = escSeq <|> noneOf ("\"\\" :: String) --satisfy (\c -> c /= '"' && c /= '\\')) + strChar = escSeq <|> noneOf ("\"\\" :: String) dQuote = char '\"' - multiBasicStr :: (TomlM m) => Parser m Text multiBasicStr = openDQuote3 *> escWhiteSpc *> (pack <$> manyTill strChar (try dQuote3)) where -- | Parse the a tripple-double quote, with possibly a newline attached - openDQuote3 = try (dQuote3 <* char '\n') <|> try dQuote3 + openDQuote3 = try (dQuote3 <* char '\n') <|> dQuote3 -- | Parse tripple-double quotes dQuote3 = count 3 $ char '"' -- | Parse a string char, accepting escaped codes, ignoring escaped white space - strChar = escSeq <|> satisfy (/= '\\') <* escWhiteSpc + strChar = escSeq <|> noneOf ("\\" :: String) <* escWhiteSpc -- | Parse escaped white space, if any - escWhiteSpc = many $ char '\\' >> char '\n' >> many (satisfy (\c -> isSpc c || c == '\n')) + escWhiteSpc = many $ char '\\' >> char '\n' >> many (oneOf ("\n\t " :: String)) literalStr :: (TomlM m) => Parser m Text -literalStr = between sQuote sQuote (pack <$> many (satisfy (/= '\''))) +literalStr = between sQuote sQuote (pack <$> many (noneOf ("'" :: String))) where sQuote = char '\'' @@ -192,14 +202,14 @@ multiLiteralStr = openSQuote3 *> (pack <$> manyTill anyChar sQuote3) where -- | Parse the a tripple-single quote, with possibly a newline attached - openSQuote3 = try (sQuote3 <* char '\n') <|> try sQuote3 + openSQuote3 = try (sQuote3 <* char '\n') <|> sQuote3 -- | Parse tripple-single quotes sQuote3 = try . count 3 . char $ '\'' datetime :: (TomlM m) => Parser m Node datetime = do - d <- try $ manyTill anyChar (char 'Z') + d <- manyTill anyChar (char 'Z') #if MIN_VERSION_time(1,5,0) let mt = parseTimeM True defaultTimeLocale (iso8601DateFormat $ Just "%X") d #else @@ -221,7 +231,7 @@ uintStr = (:) <$> digitChar <*> many (optional (char '_') *> digitChar) intStr = do s <- T.unpack <$> sign u <- uintStr - return . join $ [s, u] + return . join $ s : [u] integer :: (TomlM m) => Parser m Node @@ -263,11 +273,11 @@ -- | Parser for unicode hexadecimal values of representation length 'n'. unicodeHex :: (TomlM m) => Int -> Parser m Char unicodeHex n = do - h <- count n (satisfy isHex) + h <- count n hexDigitChar -- (satisfy isHex) let v = fst . head . readHex $ h return $ if v <= maxChar then toEnum v else '_' where - isHex = or . sequence [isDigit, isAsciiUpper, isAsciiLower] + -- isHex x = or . sequence [isDigit, isAsciiUpper, isAsciiLower] maxChar = fromEnum (maxBound :: Char) diff --git a/src/Text/Toml/Types.hs b/src/Text/Toml/Types.hs --- a/src/Text/Toml/Types.hs +++ b/src/Text/Toml/Types.hs @@ -125,6 +125,7 @@ Just _ -> commonInsertError node fullName +-- FIXME use a Set here (?) -- | Merge two tables, resulting in an error when overlapping keys are -- found ('Left' will contain those keys). When no overlapping keys are -- found the result will contain the union of both tables in a 'Right'.