Fix csv rules parsing (#407)

* csv rules: Show prettier parsing errors

This goes from

  hledger: user error ("ParseError {errorPos = SourcePos {sourceName = \"foo.csv.rules\",
  sourceLine = Pos 20, sourceColumn = Pos 1} :| [], errorUnexpected =
  fromList [Tokens (' ' :| \"\")], errorExpected = fromList [Label ('b' :| \"lank or comment
  line\"),EndOfInput], errorCustom = fromList []}")

to

  hledger: user error (foo.csv.rules:20:1:
  unexpected space
  expecting blank or comment line or end of input
  )

* csv rules: Fix parsing of empty field values

A single line containing `account1 ` (note the space at the end) should
parse as assignment of the empty string to account1. At least it did
until commit 4141067.

The problem is that megaparsec's `space` parses multiple space
characters as opposed to parsec. So in the example above it would
incorrectly consume the newline.

This commit also adds a new test case for this bug.
This commit is contained in:
Hans-Peter Deifel 2016-09-25 21:56:28 +02:00 committed by Simon Michael
parent 3efa123812
commit ae73c525d8

View File

@ -9,6 +9,8 @@ A reader for CSV data, using an extra rules file to help interpret the data.
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module Hledger.Read.CsvReader ( module Hledger.Read.CsvReader (
-- * Reader -- * Reader
@ -108,7 +110,7 @@ readJournalFromCsv mrulesfile csvfile csvdata =
rules_ <- liftIO $ runExceptT $ parseRulesFile rulesfile rules_ <- liftIO $ runExceptT $ parseRulesFile rulesfile
let rules = case rules_ of let rules = case rules_ of
Right (t::CsvRules) -> t Right (t::CsvRules) -> t
Left err -> throwerr $ show err Left err -> throwerr err
dbg2IO "rules" rules dbg2IO "rules" rules
-- apply skip directive -- apply skip directive
@ -354,17 +356,19 @@ addConditionalBlock b r = r{rconditionalblocks=b:rconditionalblocks r}
getDirective :: DirectiveName -> CsvRules -> Maybe FieldTemplate getDirective :: DirectiveName -> CsvRules -> Maybe FieldTemplate
getDirective directivename = lookup directivename . rdirectives getDirective directivename = lookup directivename . rdirectives
instance ShowErrorComponent String where
showErrorComponent = id
parseRulesFile :: FilePath -> ExceptT String IO CsvRules parseRulesFile :: FilePath -> ExceptT String IO CsvRules
parseRulesFile f = do parseRulesFile f = do
s <- liftIO $ (readFile' f >>= expandIncludes (takeDirectory f)) s <- liftIO $ (readFile' f >>= expandIncludes (takeDirectory f))
let rules = parseCsvRules f s let rules = parseCsvRules f s
case rules of case rules of
Left e -> ExceptT $ return $ Left $ show e Left e -> ExceptT $ return $ Left $ parseErrorPretty e
Right r -> do Right r -> do
r_ <- liftIO $ runExceptT $ validateRules r r_ <- liftIO $ runExceptT $ validateRules r
ExceptT $ case r_ of ExceptT $ case r_ of
Left e -> return $ Left $ show $ toParseError e Left e -> return $ Left $ parseErrorPretty $ toParseError e
Right r -> return $ Right r Right r -> return $ Right r
where where
toParseError :: forall s. Ord s => s -> ParseError Char s toParseError :: forall s. Ord s => s -> ParseError Char s
@ -515,8 +519,8 @@ assignmentseparatorp = do
lift $ pdbg 3 "trying assignmentseparatorp" lift $ pdbg 3 "trying assignmentseparatorp"
choice [ choice [
-- try (lift (many spacenonewline) >> oneOf ":="), -- try (lift (many spacenonewline) >> oneOf ":="),
try (void $ lift (many spacenonewline) >> char ':'), try (lift (many spacenonewline) >> char ':'),
space spaceChar
] ]
_ <- lift (many spacenonewline) _ <- lift (many spacenonewline)
return () return ()
@ -807,6 +811,9 @@ test_parser = [
,"convert rules parsing: trailing blank lines" ~: do ,"convert rules parsing: trailing blank lines" ~: do
assertParse (parseWithState' rules rulesp "skip\n\n \n") assertParse (parseWithState' rules rulesp "skip\n\n \n")
,"convert rules parsing: empty field value" ~: do
assertParse (parseWithState' rules rulesp "account1 \nif foo\n account2 foo\n")
-- not supported -- not supported
-- ,"convert rules parsing: no final newline" ~: do -- ,"convert rules parsing: no final newline" ~: do
-- assertParse (parseWithState rules csvrulesfile "A\na") -- assertParse (parseWithState rules csvrulesfile "A\na")