diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Revision history for config-parser +## 1.1.0.0 -- 2018-1-19 + +* Made parsing errors significantly more informative. +* The `keyValue` parser in `ConfigParser` now takes a `Parser Key`, rather than + a `Key`, to facilitate easier detection of bad keys. +* Fixed some broken haddocks. + ## 1.0.0.0 -- 2017-12-04 * Removed 'ConfigParser' constructor with janky call to 'error'. Non-unique keys diff --git a/Text/ConfigParser.hs b/Text/ConfigParser.hs --- a/Text/ConfigParser.hs +++ b/Text/ConfigParser.hs @@ -61,13 +61,7 @@ > main :: IO () > main = parseFromFile cp "./config.txt" >>= print -} -{-# OPTIONS_HADDOCK ignore_exports #-} module Text.ConfigParser - ( module Types - , module Parser - ) where - -import Text.ConfigParser.Types as Types ( Key , ConfigOption(..) , ConfigParser(..) @@ -76,10 +70,7 @@ , configParser , defaultKeyValue , defaultLineCommentInit - ) - -import Text.ConfigParser.Parser as Parser - ( config + , config , string , integer , boundedIntegral @@ -87,4 +78,7 @@ , list , parseFromText , parseFromFile - ) + ) where + +import Text.ConfigParser.Types as Types +import Text.ConfigParser.Parser as Parser diff --git a/Text/ConfigParser/Parser.hs b/Text/ConfigParser/Parser.hs --- a/Text/ConfigParser/Parser.hs +++ b/Text/ConfigParser/Parser.hs @@ -1,15 +1,19 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_HADDOCK hide #-} module Text.ConfigParser.Parser where import Control.Monad (void, unless, when) import Data.List (nub, (\\), intercalate) import Data.String (IsString(..)) -import Text.Parsec (SourceName, ParseError, State(..), parserFail, alphaNum) -import Text.Parsec (getParserState, setParserState, unexpected, newline, unexpected) -import Text.Parsec (manyTill, char, choice, digit, sepBy, many, many1, try) -import Text.Parsec (spaces, eof, parse, (<|>), ()) +import Text.Parsec (ParseError, unexpected, parserFail) +import Text.Parsec (newline, manyTill, char, choice, digit, sepBy, many, many1) +import Text.Parsec (try, spaces, eof, parse, (<|>), (), lookAhead) import Text.Parsec.Char (noneOf, oneOf, anyChar) +import Text.Parsec.Pos (SourceName, initialPos, sourceName) +import Text.Parsec.Prim (setInput, getPosition, setPosition) import Text.Parsec.Text (Parser) import qualified Data.Text as T (Text) import qualified Data.Text.IO as T (readFile) @@ -63,23 +67,15 @@ separator = try $ spaces *> char ',' <* spaces terminator = try $ spaces *> char ']' --- | Ignore zero or more spaces, tabs, or vertical tabs. -whitespace :: Parser () -whitespace = () <$ many (oneOf " \t\v\r") "whitespace" - --- | Extract a parser for a transformation on @c@s from a 'ConfigOption'. -actionParser :: ConfigParser c -> ConfigOption c -> Parser (c -> c) -actionParser c ConfigOption {..} = - whitespace *> keyValue c key (action <$> parser) - --- Parse a string and replace the input of the parser with the result. +-- | Parse a string and replace the input of the parser with the result. replaceParserInput :: Parser String -> Parser () -replaceParserInput p = do - s <- getParserState - i <- p - void $ setParserState s {stateInput = fromString i} +replaceParserInput parser = void $ do + input <- parser + source <- sourceName <$> getPosition + setInput $ fromString input + setPosition $ initialPos source --- Replace each line comment with a single newline. +-- | Replace each line comment with a single newline. removeLineComments :: ConfigParser c -> Parser () removeLineComments ConfigParser {..} = replaceParserInput $ mconcat <$> many (escapedComment <|> comment <|> content) @@ -90,50 +86,50 @@ escapedComment = try $ char '\\' *> startComment content = (:[]) <$> anyChar --- Remove spaces from the start and end of each line, at the start of the --- input, and at the end of the input. -removeExtraSpaces :: Parser () -removeExtraSpaces = replaceParserInput $ - whitespace *> contentChar `manyTill` try (whitespace *> eof) - where - contentChar = try strippedNL <|> anyChar - strippedNL = whitespace *> newline <* whitespace - --- Replace sequences of multiple newlines with a single newline. -removeExtraLines :: Parser () -removeExtraLines = replaceParserInput $ - optionalNLs *> contentChar `manyTill` try (optionalNLs *> eof) - where - contentChar = combinedNLs <|> anyChar - optionalNLs = () <$ many newline - combinedNLs = '\n' <$ many1 newline - --- Parse a config file as specified by a 'ConfigParser'. +-- | Parse a config file as specified by a 'ConfigParser'. config :: ConfigParser c -> Parser c config p = do unless optionKeysUniq $ parserFail "non-unique keys in ConfigParser" removeLineComments p - removeExtraSpaces - removeExtraLines - (ks,c) <- go [] (defaults p) + (ks,c) <- go ([]::[Key]) (defaults p) let missingKeys = requiredKeys \\ ks unless (null missingKeys) $ parserFail ("missing required keys: " ++ intercalate ", " (fmap show missingKeys)) return c where - actionParser' o = (,) (key o) <$> actionParser p o - optionParser = choice $ try . actionParser' <$> options p - requiredKeys = fmap key . filter required $ options p - optionKeysUniq = length (nub $ key <$> options p) == length (options p) - go ks c = (ks,c) <$ eof <|> do - (k,f) <- optionParser <|> do - k <- many1 alphaNum - unexpected $ "key: \"" ++ k ++ "\"" - when (k `elem` (ks::[Key])) $ - unexpected ("duplicate key: \"" ++ k ++ "\"") - let c' = f c - newline *> go (k:ks) c' <|> (k:ks,c') <$ eof + whitespace = void . many $ oneOf " \t\v\r" :: Parser () + line = many $ noneOf "\n\r" :: Parser String + identifier = many1 $ noneOf "\n\r\t\v =" :: Parser String + requiredKeys = fmap key . filter required $ options p + optionKeysUniq = length (nub $ key <$> options p) == length (options p) + maybeP parser = Just <$> try parser <|> Nothing <$ try identifier + optionParsers = choice $ try . keyActionP <$> options p + dummyActionP = (Nothing,Nothing) <$ keyValue p identifier (try line) + configLineP = optionParsers <|> dummyActionP <|> parserFail "Parsing failed" + keyActionP o = (Just o,) <$> mbActionParser o + actionParser ConfigOption {..} = keyValue p (P.string key) $ action <$> parser + mbActionParser ConfigOption {..} = keyValue p (P.string key) . maybeP $ action <$> parser + go ks c = whitespace *> go' ks c <* whitespace + go' ks c = (ks,c) <$ eof -- End of document + <|> newline *> go ks c -- Empty line + <|> do -- Config line + (mbo,mbv) <- lookAhead configLineP + case mbo of + -- Key is bad + Nothing -> do + k <- identifier + unexpected $ "key " ++ show k + -- Key is good + Just o@(ConfigOption {..}) -> do + when (key `elem` ks) $ unexpected ("duplicate key " ++ show key) + case mbv of + -- Value is bad + Nothing -> do + _ <- actionParser o -- This should error out, but... + parserFail $ "Couldn't parse value for key " ++ show key + -- Value is good + Just f -> actionParser o >> go (key:ks) (f c) -- Parse a config file from 'Text'. parseFromText :: ConfigParser c -> SourceName -> T.Text -> Either ParseError c diff --git a/Text/ConfigParser/Types.hs b/Text/ConfigParser/Types.hs --- a/Text/ConfigParser/Types.hs +++ b/Text/ConfigParser/Types.hs @@ -1,13 +1,14 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} +{-# OPTIONS_HADDOCK hide #-} module Text.ConfigParser.Types where -import Text.Parsec (string, spaces, char, ()) +import Text.Parsec (spaces, char) import Text.Parsec.Text (Parser) type Key = String --- Key-value pair to parse from a config file. +-- ^ Key-value pair to parse from a config file. data ConfigOption c = forall a. ConfigOption { key :: Key -- ^ Key name. @@ -24,18 +25,18 @@ -- the 'ConfigParser' constructor if you want to specify your own 'lineParser' -- or 'commentStart'. Otherwise, use the 'configParser' smart constructor. data ConfigParser c = ConfigParser - { keyValue :: forall a. Key -> Parser a -> Parser a + { keyValue :: forall a. Parser Key -> Parser a -> Parser a -- ^ Specifies how a key and a value parser should be represented in the -- config file, e.g., @key = value@, or @key: value@. , lineCommentInit :: [String] - -- Strings to start a line comment, such as @#@, @--@, or @//@. All + -- ^ Strings to start a line comment, such as @#@, @--@, or @//@. All -- characters following this string up to the following newline or EOF -- will be removed. You can use the string without starting a comment by -- escaping it with a backslash, e.g. @\#@ or @\--@. , defaults :: c - -- Initial @c@ to fold each 'ConfigOption's action over. + -- ^ Initial @c@ to fold each 'ConfigOption's action over. , options :: [ConfigOption c] - -- List of key-value pairs to parse from the config file. Any key in the + -- ^ List of key-value pairs to parse from the config file. Any key in the -- config file that doesn't appear here will result in parse error. } @@ -45,10 +46,9 @@ configParser = ConfigParser defaultKeyValue defaultLineCommentInit -- | Default syntax like @key = value@. -defaultKeyValue :: Key -> Parser a -> Parser a -defaultKeyValue k p = keyParser *> separator *> p +defaultKeyValue :: Parser Key -> Parser a -> Parser a +defaultKeyValue k p = k *> separator *> p where - keyParser = string k "key \"" ++ k ++ "\"" separator = spaces *> char '=' <* spaces -- | Default line comment like @# comment text@. diff --git a/config-parser.cabal b/config-parser.cabal --- a/config-parser.cabal +++ b/config-parser.cabal @@ -1,5 +1,5 @@ name: config-parser -version: 1.0.0.0 +version: 1.1.0.0 synopsis: Parse config files using parsec and generate parse errors on unhandled keys description: This is yet another entry in Haskell's enourmous collection @@ -59,6 +59,7 @@ main-is: tests/Parsing.hs default-language: Haskell2010 build-depends: base >=4.9 && <4.10, + extra >=1.5 && <1.7, hspec >=2.4 && <2.5, lens >=4.15 && <4.16, parsec >=3.1 && <3.2, diff --git a/tests/Parsing.hs b/tests/Parsing.hs --- a/tests/Parsing.hs +++ b/tests/Parsing.hs @@ -6,8 +6,8 @@ import Prelude hiding (unlines) import Control.Lens -import Control.Monad (void) import Data.Int (Int8) +import Data.List.Extra (isInfixOf) import Data.Text (unlines) import Data.Word (Word8) import Test.Hspec @@ -17,8 +17,7 @@ import qualified Text.Parsec as P (string) import Text.ConfigParser -import Text.ConfigParser.Parser (whitespace, actionParser, removeLineComments) -import Text.ConfigParser.Parser (removeExtraSpaces, removeExtraLines) +import Text.ConfigParser.Parser (removeLineComments) data C = C { _f1 :: String @@ -101,8 +100,8 @@ cp = configParser defC [co1,co2,co3,co4,co5,co6,co7] cp' = ConfigParser lp lcs defC [co1,co2,co3,co4,co5,co6,co7] where - lp :: Key -> Parser a -> Parser a - lp k q = q <* spaces <* P.string "->" <* spaces <* P.string k + lp :: Parser Key -> Parser a -> Parser a + lp k q = q <* spaces <* P.string "->" <* spaces <* k lcs = ["--","//"] shouldFailOnLine :: Show a => Either ParseError a -> Int -> Expectation @@ -118,10 +117,7 @@ , testBool , testList , testDefaultKeyValue - , testActionParser , testRemoveLineComments - , testRemoveExtraSpaces - , testRemoveExtraLines , testConfig ] @@ -252,52 +248,30 @@ it "fails on an unterminated list after a comma" $ parse (list integer) "test" "[42," `shouldFailOnLine` 1 -testWhitespace :: Spec -testWhitespace = describe "whitespace" $ do - it "parses spaces" $ - parse whitespace "test" " " `shouldBe` Right () - it "parses tabs" $ - parse whitespace "test" "\t\t\t\t" `shouldBe` Right () - it "parses a mix of spaces and tabs" $ - parse whitespace "test" " \t \t \t\t " `shouldBe` Right () - it "fails on newlines" $ - parse (whitespace <* eof) "test" "\n" `shouldFailOnLine` 1 - it "fails on carriage return" $ - parse (whitespace <* eof) "test" "\r" `shouldFailOnLine` 1 - testDefaultKeyValue :: Spec testDefaultKeyValue = describe "defaultKeyValue" $ do it "parses \"=\"" $ - parse (defaultKeyValue "foo" integer) "test" "foo=42" + parse (defaultKeyValue (P.string "foo") integer) "test" "foo=42" `shouldBe` Right 42 it "parses \" = \"" $ - parse (defaultKeyValue "foo" integer) "test" "foo = 42" + parse (defaultKeyValue (P.string "foo") integer) "test" "foo = 42" `shouldBe` Right 42 it "parses \"\\t=\\t\"" $ - parse (defaultKeyValue "foo" integer) "test" "foo\t=\t42" + parse (defaultKeyValue (P.string "foo") integer) "test" "foo\t=\t42" `shouldBe` Right 42 it "parses \"\\n=\\n\"" $ - parse (defaultKeyValue "foo" integer) "test" "foo\n=\n42" + parse (defaultKeyValue (P.string "foo") integer) "test" "foo\n=\n42" `shouldBe` Right 42 it "parses \"\\n =\\n \"" $ - parse (defaultKeyValue "foo" integer) "test" "foo\n =\n 42" + parse (defaultKeyValue (P.string "foo") integer) "test" "foo\n =\n 42" `shouldBe` Right 42 it "parses \" \\n= \\n\"" $ - parse (defaultKeyValue "foo" integer) "test" "foo \n= \n42" + parse (defaultKeyValue (P.string "foo") integer) "test" "foo \n= \n42" `shouldBe` Right 42 it "fails on incorrect key" $ - parse (defaultKeyValue "foo" integer) "test" "bar = 42" + parse (defaultKeyValue (P.string "foo") integer) "test" "bar = 42" `shouldFailOnLine` 1 -testActionParser :: Spec -testActionParser = describe "actionParser" $ do - it "doesn't require whitespace at the start of a line" $ - parse (actionParser' co2) "test" "f2 = 42" `shouldBe` Right () - it "allows whitespace at the start of a line" $ - parse (actionParser' co2) "test" " f2 = 42" `shouldBe` Right () - where - actionParser' = void . actionParser cp - testRemoveLineComments :: Spec testRemoveLineComments = describe "removeLineComments" $ do it "preserves an empty file" $ @@ -364,67 +338,6 @@ where removeLineComments' = removeLineComments cp >> getInput -testRemoveExtraSpaces :: Spec -testRemoveExtraSpaces = describe "removeExtraSpaces" $ do - it "preserves an empty file" $ - parse removeExtraSpaces' "test" "" `shouldBe` Right "" - it "preserves a file with one simple line" $ - parse removeExtraSpaces' "test" "foobaz" `shouldBe` Right "foobaz" - it "preserves spaces in the middle of a simple line" $ - parse removeExtraSpaces' "test" "foo baz" `shouldBe` Right "foo baz" - it "preserves a simple multiline file" $ - parse removeExtraSpaces' "test" "foo\nbar\nzap" - `shouldBe` Right "foo\nbar\nzap" - it "preserves a multiline file with spaces" $ - parse removeExtraSpaces' "test" "foo\nwiz woz\nzap" - `shouldBe` Right "foo\nwiz woz\nzap" - it "removes space alternatives" $ - parse removeExtraSpaces' "test" " \t\r\vbaz" `shouldBe` Right "baz" - it "removes spaces at the start of a simple line" $ - parse removeExtraSpaces' "test" " baz" `shouldBe` Right "baz" - it "removes spaces at the end of a simple line" $ - parse removeExtraSpaces' "test" "foo " `shouldBe` Right "foo" - it "removes spaces at the start of a multi-line file" $ - parse removeExtraSpaces' "test" " foo\nwiz woz\nzap" - `shouldBe` Right "foo\nwiz woz\nzap" - it "removes spaces at the end of a multi-line file" $ - parse removeExtraSpaces' "test" "foo\nwiz woz\nzap " - `shouldBe` Right "foo\nwiz woz\nzap" - it "removes spaces at the start of a line in a multi-line file" $ - parse removeExtraSpaces' "test" "foo\n wiz woz\nzap" - `shouldBe` Right "foo\nwiz woz\nzap" - it "removes spaces at the end of a line in a multi-line file" $ - parse removeExtraSpaces' "test" "foo\nwiz woz \nzap" - `shouldBe` Right "foo\nwiz woz\nzap" - where - removeExtraSpaces' = removeExtraSpaces >> getInput - -testRemoveExtraLines :: Spec -testRemoveExtraLines = describe "removeExtraLines" $ do - it "preserves an empty file" $ - parse removeExtraLines' "test" "" `shouldBe` Right "" - it "preserves a file with one simple line" $ - parse removeExtraLines' "test" "foobaz" `shouldBe` Right "foobaz" - it "preserves spaces in the middle of a simple line" $ - parse removeExtraLines' "test" "foo baz" `shouldBe` Right "foo baz" - it "preserves a simple multiline file" $ - parse removeExtraLines' "test" "foo\nbar\nzap" - `shouldBe` Right "foo\nbar\nzap" - it "preserves a multiline file with spaces" $ - parse removeExtraLines' "test" "foo\nwiz woz\nzap" - `shouldBe` Right "foo\nwiz woz\nzap" - it "removes newlines at the start of a multi-line file" $ - parse removeExtraLines' "test" "\n\n\nfoo\nwiz woz\nzap" - `shouldBe` Right "foo\nwiz woz\nzap" - it "removes newlines at the end of a multi-line file" $ - parse removeExtraLines' "test" "foo\nwiz woz\nzap\n\n\n" - `shouldBe` Right "foo\nwiz woz\nzap" - it "removes newlines in the middle of a multi-line file" $ - parse removeExtraLines' "test" "foo\nwiz woz\n\n\nzap" - `shouldBe` Right "foo\nwiz woz\nzap" - where - removeExtraLines' = removeExtraLines >> getInput - testConfig :: Spec testConfig = describe "config" $ do it "parses an empty config file" $ @@ -763,7 +676,7 @@ ]) `shouldSatisfy` \res -> case res of Right _ -> False Left e -> sourceLine (errorPos e) == 6 - && "unexpected key: \"badkey\"" `elem` lines (show e) + && "unexpected key \"badkey\"" `isInfixOf` show e it "errors on duplicate keys in config file with a pertinent message" $ parseFromText cp "test" (unlines [ "f1 = \"foo\"" @@ -771,4 +684,4 @@ ]) `shouldSatisfy` \res -> case res of Right _ -> False Left e -> sourceLine (errorPos e) == 2 - && "unexpected duplicate key: \"f1\"" `elem` lines (show e) + && "duplicate key \"f1\"" `isInfixOf` show e