From fcc10f018da281e8bded9635f05d33b95c0bd07c Mon Sep 17 00:00:00 2001 From: Alex Chen Date: Sat, 12 May 2018 14:16:22 -0600 Subject: [PATCH] lib: merge parsing of date-tags with that of tags --- hledger-lib/Hledger/Read/Common.hs | 106 +++++++++++++---------------- 1 file changed, 47 insertions(+), 59 deletions(-) diff --git a/hledger-lib/Hledger/Read/Common.hs b/hledger-lib/Hledger/Read/Common.hs index 720e4d64a..fe1cf19ec 100644 --- a/hledger-lib/Hledger/Read/Common.hs +++ b/hledger-lib/Hledger/Read/Common.hs @@ -853,23 +853,38 @@ followingcommentandtagsp mdefdate = do -- pdbg 0 $ "commentws:" ++ show commentLines -- Reparse the comment for any tags. - tags <- case traverse (runTextParserAt tagsp) commentLines of + tagsWithPositions <- case traverse (runTextParserAt tagswithvaluepositions) commentLines of Right tss -> pure $ concat tss Left e -> throwError $ parseErrorPretty e - -- Reparse the comment for any posting dates. + -- Extract date-tag style posting dates from the tags. -- Use the transaction date for defaults, if provided. - epdates <- fmap sequence + journal <- fmap + (\j -> j{jparsedefaultyear=first3.toGregorian <$> mdefdate}) get + + let eTagDates = traverse (tagDate journal) + $ filter (isDateLabel . fst . snd) tagsWithPositions + where isDateLabel txt = txt == "date" || txt == "date2" + tagDates <- case eTagDates of + Right ds -> pure ds + Left e -> throwError e + + -- Reparse the comment for any bracketed style posting dates. + -- Use the transaction date for defaults, if provided. + eBracketedDates <- fmap sequence $ traverse (runErroringJournalParserAt (postingdatesp mdefdate)) commentLines - pdates <- case epdates of + bracketedDates <- case eBracketedDates of Right dss -> pure $ concat dss Left e -> throwError e - -- pdbg 0 $ "pdates: "++show pdates + + let pdates = tagDates ++ bracketedDates + -- pdbg 0 $ "allDates: "++show pdates let mdate = headMay $ map snd $ filter ((=="date") .fst) pdates mdate2 = headMay $ map snd $ filter ((=="date2").fst) pdates let strippedComment = T.unlines $ map (T.strip . snd) commentLines + tags = map snd tagsWithPositions -- pdbg 0 $ "comment:"++show strippedComment pure (strippedComment, tags, mdate, mdate2) @@ -877,9 +892,22 @@ followingcommentandtagsp mdefdate = do where runTextParserAt parser (pos, txt) = runTextParser (setPosition pos *> parser) txt + runErroringJournalParserAt parser (pos, txt) = runErroringJournalParser (setPosition pos *> parser) txt + parseWithStateAt' st parser (pos, txt) = + parseWithState' st (setPosition pos *> parser) txt + + tagDate + :: Journal + -> (SourcePos, Tag) + -> Either String (TagName, Day) + tagDate journal (pos, (name, value)) = + case parseWithStateAt' journal datep (pos, value) of + Left e -> Left $ parseErrorPretty e + Right day -> Right (name, day) + -- A transaction/posting comment must start with a semicolon. -- This parser discards the leading whitespace of the comment -- and returns the source position of the comment's first non-whitespace character. @@ -929,7 +957,10 @@ commentTags s = -- | Parse all tags found in a string. tagsp :: SimpleTextParser [Tag] -tagsp = do +tagsp = map snd <$> tagswithvaluepositions + +tagswithvaluepositions :: SimpleTextParser [(SourcePos, Tag)] +tagswithvaluepositions = do -- pdbg 0 $ "tagsp" -- If we parse in a single pass, we cannot know whether some text @@ -953,25 +984,22 @@ tagsp = do tagValue = T.strip . T.pack <$> anyChar `manyTill` (void (char ',') <|> eolof) - atSpaceChar :: SimpleTextParser [Tag] - atSpaceChar = skipSome spaceChar *> tagsp + atSpaceChar :: SimpleTextParser [(SourcePos, Tag)] + atSpaceChar = skipSome spaceChar *> tagswithvaluepositions - atColon :: Text -> SimpleTextParser [Tag] + atColon :: Text -> SimpleTextParser [(SourcePos, Tag)] atColon tagName = do char ':' if T.null tagName - then tagsp - else (:) <$> fmap (tagName,) tagValue <*> tagsp + then tagswithvaluepositions + else do + pos <- getPosition + (:) <$> fmap (\val -> (pos, (tagName, val))) tagValue + <*> tagswithvaluepositions - atEof :: SimpleTextParser [Tag] + atEof :: SimpleTextParser [(SourcePos, Tag)] atEof = eof *> pure [] -tagvaluep :: TextParser m Text -tagvaluep = do - -- ptrace "tagvalue" - v <- anyChar `manyTill` (void (try (char ',')) <|> eolof) - return $ T.pack $ strip $ reverse $ dropWhile (==',') $ reverse $ strip v - --- ** posting dates -- | Parse all posting dates found in a string. Posting dates can be @@ -982,52 +1010,12 @@ tagvaluep = do postingdatesp :: Monad m => Maybe Day -> ErroringJournalParser m [(TagName,Day)] postingdatesp mdefdate = do -- pdbg 0 $ "postingdatesp" - let p = ((:[]) <$> datetagp mdefdate) <|> bracketeddatetagsp mdefdate + let p = bracketeddatetagsp mdefdate nonp = many (notFollowedBy p >> anyChar) -- anyChar `manyTill` (lookAhead (try (p >> return ()) <|> eof)) concat <$> many (try (nonp >> p)) ---- ** date tags - --- | Date tags are tags with name "date" or "date2". Their value is --- parsed as a date, using the provided default date if any for --- inferring a missing year if needed. Any error in date parsing is --- reported and terminates parsing. --- --- >>> rejp (datetagp Nothing) "date: 2000/1/2 " --- Right ("date",2000-01-02) --- --- >>> rejp (datetagp (Just $ fromGregorian 2001 2 3)) "date2:3/4" --- Right ("date2",2001-03-04) --- --- >>> rejp (datetagp Nothing) "date: 3/4" --- Left ...1:9...partial date 3/4 found, but the current year is unknown... --- -datetagp :: Monad m => Maybe Day -> ErroringJournalParser m (TagName,Day) -datetagp mdefdate = do - -- pdbg 0 "datetagp" - string "date" - n <- fromMaybe "" <$> optional (mptext "2") - char ':' - startpos <- getPosition - v <- lift tagvaluep - -- re-parse value as a date. - j <- get - let ep :: Either (ParseError Char MPErr) Day - ep = parseWithState' - j{jparsedefaultyear=first3.toGregorian <$> mdefdate} - -- The value extends to a comma, newline, or end of file. - -- It seems like ignoring any extra stuff following a date - -- gives better errors here. - (do - setPosition startpos - datep) -- <* eof) - v - case ep - of Left e -> throwError $ parseErrorPretty e - Right d -> return ("date"<>n, d) - --- ** bracketed dates -- tagorbracketeddatetagsp :: Monad m => Maybe Day -> TextParser u m [Tag]