Replace Parsec with Megaparsec (see #289) (#366)

* Replace Parsec with Megaparsec (see #289)

This builds upon PR #289 by @rasendubi

* Revert renaming of parseWithState to parseWithCtx

* Fix doctests

* Update for Megaparsec 5

* Specialize parser to improve performance

* Pretty print errors

* Swap StateT and ParsecT

This is necessary to get the correct backtracking behavior, i.e. discard
state changes if the parsing fails.
This commit is contained in:
Moritz Kiefer 2016-07-29 17:57:10 +02:00 committed by Simon Michael
parent 90c0d40777
commit 4141067428
33 changed files with 730 additions and 649 deletions

View File

@ -1,6 +1,8 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE NoMonoLocalBinds #-} {-# LANGUAGE NoMonoLocalBinds #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-| {-|
Date parsing and utilities for hledger. Date parsing and utilities for hledger.
@ -68,6 +70,8 @@ import Prelude.Compat
import Control.Monad import Control.Monad
import Data.List.Compat import Data.List.Compat
import Data.Maybe import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
#if MIN_VERSION_time(1,5,0) #if MIN_VERSION_time(1,5,0)
import Data.Time.Format hiding (months) import Data.Time.Format hiding (months)
#else #else
@ -80,7 +84,8 @@ import Data.Time.Calendar.WeekDate
import Data.Time.Clock import Data.Time.Clock
import Data.Time.LocalTime import Data.Time.LocalTime
import Safe (headMay, lastMay, readMay) import Safe (headMay, lastMay, readMay)
import Text.Parsec import Text.Megaparsec
import Text.Megaparsec.Text
import Text.Printf import Text.Printf
import Hledger.Data.Types import Hledger.Data.Types
@ -298,10 +303,10 @@ earliest (Just d1) (Just d2) = Just $ min d1 d2
-- | Parse a period expression to an Interval and overall DateSpan using -- | Parse a period expression to an Interval and overall DateSpan using
-- the provided reference date, or return a parse error. -- the provided reference date, or return a parse error.
parsePeriodExpr :: Day -> String -> Either ParseError (Interval, DateSpan) parsePeriodExpr :: Day -> Text -> Either (ParseError Char Dec) (Interval, DateSpan)
parsePeriodExpr refdate = parsewith (periodexpr refdate <* eof) parsePeriodExpr refdate = parsewith (periodexpr refdate <* eof)
maybePeriod :: Day -> String -> Maybe (Interval,DateSpan) maybePeriod :: Day -> Text -> Maybe (Interval,DateSpan)
maybePeriod refdate = either (const Nothing) Just . parsePeriodExpr refdate maybePeriod refdate = either (const Nothing) Just . parsePeriodExpr refdate
-- | Show a DateSpan as a human-readable pseudo-period-expression string. -- | Show a DateSpan as a human-readable pseudo-period-expression string.
@ -354,18 +359,18 @@ spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e)
-- | Convert a smart date string to an explicit yyyy\/mm\/dd string using -- | Convert a smart date string to an explicit yyyy\/mm\/dd string using
-- the provided reference date, or raise an error. -- the provided reference date, or raise an error.
fixSmartDateStr :: Day -> String -> String fixSmartDateStr :: Day -> Text -> String
fixSmartDateStr d s = either fixSmartDateStr d s = either
(\e->error' $ printf "could not parse date %s %s" (show s) (show e)) (\e->error' $ printf "could not parse date %s %s" (show s) (show e))
id id
$ fixSmartDateStrEither d s $ (fixSmartDateStrEither d s :: Either (ParseError Char Dec) String)
-- | A safe version of fixSmartDateStr. -- | A safe version of fixSmartDateStr.
fixSmartDateStrEither :: Day -> String -> Either ParseError String fixSmartDateStrEither :: Day -> Text -> Either (ParseError Char Dec) String
fixSmartDateStrEither d = either Left (Right . showDate) . fixSmartDateStrEither' d fixSmartDateStrEither d = either Left (Right . showDate) . fixSmartDateStrEither' d
fixSmartDateStrEither' :: Day -> String -> Either ParseError Day fixSmartDateStrEither' :: Day -> Text -> Either (ParseError Char Dec) Day
fixSmartDateStrEither' d s = case parsewith smartdateonly (lowercase s) of fixSmartDateStrEither' d s = case parsewith smartdateonly (T.toLower s) of
Right sd -> Right $ fixSmartDate d sd Right sd -> Right $ fixSmartDate d sd
Left e -> Left e Left e -> Left e
@ -591,22 +596,23 @@ and maybe some others:
Returns a SmartDate, to be converted to a full date later (see fixSmartDate). Returns a SmartDate, to be converted to a full date later (see fixSmartDate).
Assumes any text in the parse stream has been lowercased. Assumes any text in the parse stream has been lowercased.
-} -}
smartdate :: Stream s m Char => ParsecT s st m SmartDate smartdate :: Parser SmartDate
smartdate = do smartdate = do
-- XXX maybe obscures date errors ? see ledgerdate -- XXX maybe obscures date errors ? see ledgerdate
(y,m,d) <- choice' [yyyymmdd, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow, lastthisnextthing] (y,m,d) <- choice' [yyyymmdd, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow, lastthisnextthing]
return (y,m,d) return (y,m,d)
-- | Like smartdate, but there must be nothing other than whitespace after the date. -- | Like smartdate, but there must be nothing other than whitespace after the date.
smartdateonly :: Stream s m Char => ParsecT s st m SmartDate smartdateonly :: Parser SmartDate
smartdateonly = do smartdateonly = do
d <- smartdate d <- smartdate
many spacenonewline many spacenonewline
eof eof
return d return d
datesepchars :: [Char]
datesepchars = "/-." datesepchars = "/-."
datesepchar :: Stream s m Char => ParsecT s st m Char datesepchar :: TextParser m Char
datesepchar = oneOf datesepchars datesepchar = oneOf datesepchars
validYear, validMonth, validDay :: String -> Bool validYear, validMonth, validDay :: String -> Bool
@ -619,54 +625,54 @@ failIfInvalidYear s = unless (validYear s) $ fail $ "bad year number: " ++ s
failIfInvalidMonth s = unless (validMonth s) $ fail $ "bad month number: " ++ s failIfInvalidMonth s = unless (validMonth s) $ fail $ "bad month number: " ++ s
failIfInvalidDay s = unless (validDay s) $ fail $ "bad day number: " ++ s failIfInvalidDay s = unless (validDay s) $ fail $ "bad day number: " ++ s
yyyymmdd :: Stream s m Char => ParsecT s st m SmartDate yyyymmdd :: Parser SmartDate
yyyymmdd = do yyyymmdd = do
y <- count 4 digit y <- count 4 digitChar
m <- count 2 digit m <- count 2 digitChar
failIfInvalidMonth m failIfInvalidMonth m
d <- count 2 digit d <- count 2 digitChar
failIfInvalidDay d failIfInvalidDay d
return (y,m,d) return (y,m,d)
ymd :: Stream s m Char => ParsecT s st m SmartDate ymd :: Parser SmartDate
ymd = do ymd = do
y <- many1 digit y <- some digitChar
failIfInvalidYear y failIfInvalidYear y
sep <- datesepchar sep <- datesepchar
m <- many1 digit m <- some digitChar
failIfInvalidMonth m failIfInvalidMonth m
char sep char sep
d <- many1 digit d <- some digitChar
failIfInvalidDay d failIfInvalidDay d
return $ (y,m,d) return $ (y,m,d)
ym :: Stream s m Char => ParsecT s st m SmartDate ym :: Parser SmartDate
ym = do ym = do
y <- many1 digit y <- some digitChar
failIfInvalidYear y failIfInvalidYear y
datesepchar datesepchar
m <- many1 digit m <- some digitChar
failIfInvalidMonth m failIfInvalidMonth m
return (y,m,"") return (y,m,"")
y :: Stream s m Char => ParsecT s st m SmartDate y :: Parser SmartDate
y = do y = do
y <- many1 digit y <- some digitChar
failIfInvalidYear y failIfInvalidYear y
return (y,"","") return (y,"","")
d :: Stream s m Char => ParsecT s st m SmartDate d :: Parser SmartDate
d = do d = do
d <- many1 digit d <- some digitChar
failIfInvalidDay d failIfInvalidDay d
return ("","",d) return ("","",d)
md :: Stream s m Char => ParsecT s st m SmartDate md :: Parser SmartDate
md = do md = do
m <- many1 digit m <- some digitChar
failIfInvalidMonth m failIfInvalidMonth m
datesepchar datesepchar
d <- many1 digit d <- some digitChar
failIfInvalidDay d failIfInvalidDay d
return ("",m,d) return ("",m,d)
@ -679,24 +685,24 @@ monthabbrevs = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","n
monthIndex s = maybe 0 (+1) $ lowercase s `elemIndex` months monthIndex s = maybe 0 (+1) $ lowercase s `elemIndex` months
monIndex s = maybe 0 (+1) $ lowercase s `elemIndex` monthabbrevs monIndex s = maybe 0 (+1) $ lowercase s `elemIndex` monthabbrevs
month :: Stream s m Char => ParsecT s st m SmartDate month :: Parser SmartDate
month = do month = do
m <- choice $ map (try . string) months m <- choice $ map (try . string) months
let i = monthIndex m let i = monthIndex m
return ("",show i,"") return ("",show i,"")
mon :: Stream s m Char => ParsecT s st m SmartDate mon :: Parser SmartDate
mon = do mon = do
m <- choice $ map (try . string) monthabbrevs m <- choice $ map (try . string) monthabbrevs
let i = monIndex m let i = monIndex m
return ("",show i,"") return ("",show i,"")
today,yesterday,tomorrow :: Stream s m Char => ParsecT s st m SmartDate today,yesterday,tomorrow :: Parser SmartDate
today = string "today" >> return ("","","today") today = string "today" >> return ("","","today")
yesterday = string "yesterday" >> return ("","","yesterday") yesterday = string "yesterday" >> return ("","","yesterday")
tomorrow = string "tomorrow" >> return ("","","tomorrow") tomorrow = string "tomorrow" >> return ("","","tomorrow")
lastthisnextthing :: Stream s m Char => ParsecT s st m SmartDate lastthisnextthing :: Parser SmartDate
lastthisnextthing = do lastthisnextthing = do
r <- choice [ r <- choice [
string "last" string "last"
@ -717,7 +723,7 @@ lastthisnextthing = do
return ("",r,p) return ("",r,p)
-- | -- |
-- >>> let p = parsewith (periodexpr (parsedate "2008/11/26")) -- >>> let p = parsewith (periodexpr (parsedate "2008/11/26")) :: T.Text -> Either (ParseError Char Dec) (Interval, DateSpan)
-- >>> p "from aug to oct" -- >>> p "from aug to oct"
-- Right (NoInterval,DateSpan 2008/08/01-2008/09/30) -- Right (NoInterval,DateSpan 2008/08/01-2008/09/30)
-- >>> p "aug to oct" -- >>> p "aug to oct"
@ -728,7 +734,7 @@ lastthisnextthing = do
-- Right (Days 1,DateSpan 2008/08/01-) -- Right (Days 1,DateSpan 2008/08/01-)
-- >>> p "every week to 2009" -- >>> p "every week to 2009"
-- Right (Weeks 1,DateSpan -2008/12/31) -- Right (Weeks 1,DateSpan -2008/12/31)
periodexpr :: Stream s m Char => Day -> ParsecT s st m (Interval, DateSpan) periodexpr :: Day -> Parser (Interval, DateSpan)
periodexpr rdate = choice $ map try [ periodexpr rdate = choice $ map try [
intervalanddateperiodexpr rdate, intervalanddateperiodexpr rdate,
intervalperiodexpr, intervalperiodexpr,
@ -736,7 +742,7 @@ periodexpr rdate = choice $ map try [
(return (NoInterval,DateSpan Nothing Nothing)) (return (NoInterval,DateSpan Nothing Nothing))
] ]
intervalanddateperiodexpr :: Stream s m Char => Day -> ParsecT s st m (Interval, DateSpan) intervalanddateperiodexpr :: Day -> Parser (Interval, DateSpan)
intervalanddateperiodexpr rdate = do intervalanddateperiodexpr rdate = do
many spacenonewline many spacenonewline
i <- reportinginterval i <- reportinginterval
@ -744,20 +750,20 @@ intervalanddateperiodexpr rdate = do
s <- periodexprdatespan rdate s <- periodexprdatespan rdate
return (i,s) return (i,s)
intervalperiodexpr :: Stream s m Char => ParsecT s st m (Interval, DateSpan) intervalperiodexpr :: Parser (Interval, DateSpan)
intervalperiodexpr = do intervalperiodexpr = do
many spacenonewline many spacenonewline
i <- reportinginterval i <- reportinginterval
return (i, DateSpan Nothing Nothing) return (i, DateSpan Nothing Nothing)
dateperiodexpr :: Stream s m Char => Day -> ParsecT s st m (Interval, DateSpan) dateperiodexpr :: Day -> Parser (Interval, DateSpan)
dateperiodexpr rdate = do dateperiodexpr rdate = do
many spacenonewline many spacenonewline
s <- periodexprdatespan rdate s <- periodexprdatespan rdate
return (NoInterval, s) return (NoInterval, s)
-- Parse a reporting interval. -- Parse a reporting interval.
reportinginterval :: Stream s m Char => ParsecT s st m Interval reportinginterval :: Parser Interval
reportinginterval = choice' [ reportinginterval = choice' [
tryinterval "day" "daily" Days, tryinterval "day" "daily" Days,
tryinterval "week" "weekly" Weeks, tryinterval "week" "weekly" Weeks,
@ -770,7 +776,7 @@ reportinginterval = choice' [
return $ Months 2, return $ Months 2,
do string "every" do string "every"
many spacenonewline many spacenonewline
n <- fmap read $ many1 digit n <- fmap read $ some digitChar
thsuffix thsuffix
many spacenonewline many spacenonewline
string "day" string "day"
@ -781,7 +787,7 @@ reportinginterval = choice' [
return $ DayOfWeek n, return $ DayOfWeek n,
do string "every" do string "every"
many spacenonewline many spacenonewline
n <- fmap read $ many1 digit n <- fmap read $ some digitChar
thsuffix thsuffix
many spacenonewline many spacenonewline
string "day" string "day"
@ -797,7 +803,7 @@ reportinginterval = choice' [
thsuffix = choice' $ map string ["st","nd","rd","th"] thsuffix = choice' $ map string ["st","nd","rd","th"]
-- Parse any of several variants of a basic interval, eg "daily", "every day", "every N days". -- Parse any of several variants of a basic interval, eg "daily", "every day", "every N days".
tryinterval :: Stream s m Char => String -> String -> (Int -> Interval) -> ParsecT s st m Interval tryinterval :: String -> String -> (Int -> Interval) -> Parser Interval
tryinterval singular compact intcons = tryinterval singular compact intcons =
choice' [ choice' [
do string compact do string compact
@ -808,14 +814,14 @@ reportinginterval = choice' [
return $ intcons 1, return $ intcons 1,
do string "every" do string "every"
many spacenonewline many spacenonewline
n <- fmap read $ many1 digit n <- fmap read $ some digitChar
many spacenonewline many spacenonewline
string plural string plural
return $ intcons n return $ intcons n
] ]
where plural = singular ++ "s" where plural = singular ++ "s"
periodexprdatespan :: Stream s m Char => Day -> ParsecT s st m DateSpan periodexprdatespan :: Day -> Parser DateSpan
periodexprdatespan rdate = choice $ map try [ periodexprdatespan rdate = choice $ map try [
doubledatespan rdate, doubledatespan rdate,
fromdatespan rdate, fromdatespan rdate,
@ -823,7 +829,7 @@ periodexprdatespan rdate = choice $ map try [
justdatespan rdate justdatespan rdate
] ]
doubledatespan :: Stream s m Char => Day -> ParsecT s st m DateSpan doubledatespan :: Day -> Parser DateSpan
doubledatespan rdate = do doubledatespan rdate = do
optional (string "from" >> many spacenonewline) optional (string "from" >> many spacenonewline)
b <- smartdate b <- smartdate
@ -832,7 +838,7 @@ doubledatespan rdate = do
e <- smartdate e <- smartdate
return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e) return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e)
fromdatespan :: Stream s m Char => Day -> ParsecT s st m DateSpan fromdatespan :: Day -> Parser DateSpan
fromdatespan rdate = do fromdatespan rdate = do
b <- choice [ b <- choice [
do do
@ -846,13 +852,13 @@ fromdatespan rdate = do
] ]
return $ DateSpan (Just $ fixSmartDate rdate b) Nothing return $ DateSpan (Just $ fixSmartDate rdate b) Nothing
todatespan :: Stream s m Char => Day -> ParsecT s st m DateSpan todatespan :: Day -> Parser DateSpan
todatespan rdate = do todatespan rdate = do
choice [string "to", string "-"] >> many spacenonewline choice [string "to", string "-"] >> many spacenonewline
e <- smartdate e <- smartdate
return $ DateSpan Nothing (Just $ fixSmartDate rdate e) return $ DateSpan Nothing (Just $ fixSmartDate rdate e)
justdatespan :: Stream s m Char => Day -> ParsecT s st m DateSpan justdatespan :: Day -> Parser DateSpan
justdatespan rdate = do justdatespan rdate = do
optional (string "in" >> many spacenonewline) optional (string "in" >> many spacenonewline)
d <- smartdate d <- smartdate

View File

@ -23,6 +23,7 @@ module Hledger.Data.RawOptions (
where where
import Data.Maybe import Data.Maybe
import qualified Data.Text as T
import Safe import Safe
import Hledger.Utils import Hledger.Utils
@ -32,7 +33,7 @@ import Hledger.Utils
type RawOpts = [(String,String)] type RawOpts = [(String,String)]
setopt :: String -> String -> RawOpts -> RawOpts setopt :: String -> String -> RawOpts -> RawOpts
setopt name val = (++ [(name, quoteIfNeeded val)]) setopt name val = (++ [(name, quoteIfNeeded $ val)])
setboolopt :: String -> RawOpts -> RawOpts setboolopt :: String -> RawOpts -> RawOpts
setboolopt name = (++ [(name,"")]) setboolopt name = (++ [(name,"")])
@ -45,7 +46,7 @@ boolopt :: String -> RawOpts -> Bool
boolopt = inRawOpts boolopt = inRawOpts
maybestringopt :: String -> RawOpts -> Maybe String maybestringopt :: String -> RawOpts -> Maybe String
maybestringopt name = maybe Nothing (Just . stripquotes) . lookup name . reverse maybestringopt name = maybe Nothing (Just . T.unpack . stripquotes . T.pack) . lookup name . reverse
stringopt :: String -> RawOpts -> String stringopt :: String -> RawOpts -> String
stringopt name = fromMaybe "" . maybestringopt name stringopt name = fromMaybe "" . maybestringopt name

View File

@ -2,7 +2,7 @@
-- hledger's report item fields. The formats are used by -- hledger's report item fields. The formats are used by
-- report-specific renderers like renderBalanceReportItem. -- report-specific renderers like renderBalanceReportItem.
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts, TypeFamilies #-}
module Hledger.Data.StringFormat ( module Hledger.Data.StringFormat (
parseStringFormat parseStringFormat
@ -19,7 +19,8 @@ import Numeric
import Data.Char (isPrint) import Data.Char (isPrint)
import Data.Maybe import Data.Maybe
import Test.HUnit import Test.HUnit
import Text.Parsec import Text.Megaparsec
import Text.Megaparsec.String
import Hledger.Utils.String (formatString) import Hledger.Utils.String (formatString)
@ -79,15 +80,15 @@ data ReportItemField =
-- | Parse a string format specification, or return a parse error. -- | Parse a string format specification, or return a parse error.
parseStringFormat :: String -> Either String StringFormat parseStringFormat :: String -> Either String StringFormat
parseStringFormat input = case (runParser (stringformatp <* eof) () "(unknown)") input of parseStringFormat input = case (runParser (stringformatp <* eof) "(unknown)") input of
Left y -> Left $ show y Left y -> Left $ show y
Right x -> Right x Right x -> Right x
defaultStringFormatStyle = BottomAligned defaultStringFormatStyle = BottomAligned
stringformatp :: Stream [Char] m Char => ParsecT [Char] st m StringFormat stringformatp :: Parser StringFormat
stringformatp = do stringformatp = do
alignspec <- optionMaybe (try $ char '%' >> oneOf "^_,") alignspec <- optional (try $ char '%' >> oneOf "^_,")
let constructor = let constructor =
case alignspec of case alignspec of
Just '^' -> TopAligned Just '^' -> TopAligned
@ -96,24 +97,24 @@ stringformatp = do
_ -> defaultStringFormatStyle _ -> defaultStringFormatStyle
constructor <$> many componentp constructor <$> many componentp
componentp :: Stream [Char] m Char => ParsecT [Char] st m StringFormatComponent componentp :: Parser StringFormatComponent
componentp = formatliteralp <|> formatfieldp componentp = formatliteralp <|> formatfieldp
formatliteralp :: Stream [Char] m Char => ParsecT [Char] st m StringFormatComponent formatliteralp :: Parser StringFormatComponent
formatliteralp = do formatliteralp = do
s <- many1 c s <- some c
return $ FormatLiteral s return $ FormatLiteral s
where where
isPrintableButNotPercentage x = isPrint x && (not $ x == '%') isPrintableButNotPercentage x = isPrint x && (not $ x == '%')
c = (satisfy isPrintableButNotPercentage <?> "printable character") c = (satisfy isPrintableButNotPercentage <?> "printable character")
<|> try (string "%%" >> return '%') <|> try (string "%%" >> return '%')
formatfieldp :: Stream [Char] m Char => ParsecT [Char] st m StringFormatComponent formatfieldp :: Parser StringFormatComponent
formatfieldp = do formatfieldp = do
char '%' char '%'
leftJustified <- optionMaybe (char '-') leftJustified <- optional (char '-')
minWidth <- optionMaybe (many1 $ digit) minWidth <- optional (some $ digitChar)
maxWidth <- optionMaybe (do char '.'; many1 $ digit) -- TODO: Can this be (char '1') *> (many1 digit) maxWidth <- optional (do char '.'; some $ digitChar) -- TODO: Can this be (char '1') *> (some digitChar)
char '(' char '('
f <- fieldp f <- fieldp
char ')' char ')'
@ -123,14 +124,14 @@ formatfieldp = do
Just text -> Just m where ((m,_):_) = readDec text Just text -> Just m where ((m,_):_) = readDec text
_ -> Nothing _ -> Nothing
fieldp :: Stream [Char] m Char => ParsecT [Char] st m ReportItemField fieldp :: Parser ReportItemField
fieldp = do fieldp = do
try (string "account" >> return AccountField) try (string "account" >> return AccountField)
<|> try (string "depth_spacer" >> return DepthSpacerField) <|> try (string "depth_spacer" >> return DepthSpacerField)
<|> try (string "date" >> return DescriptionField) <|> try (string "date" >> return DescriptionField)
<|> try (string "description" >> return DescriptionField) <|> try (string "description" >> return DescriptionField)
<|> try (string "total" >> return TotalField) <|> try (string "total" >> return TotalField)
<|> try (many1 digit >>= (\s -> return $ FieldNo $ read s)) <|> try (some digitChar >>= (\s -> return $ FieldNo $ read s))
---------------------------------------------------------------------- ----------------------------------------------------------------------

View File

@ -5,7 +5,7 @@ transactions..) by various criteria, and a parser for query expressions.
-} -}
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable, OverloadedStrings, ViewPatterns #-}
module Hledger.Query ( module Hledger.Query (
-- * Query and QueryOpt -- * Query and QueryOpt
@ -48,15 +48,16 @@ import Data.Data
import Data.Either import Data.Either
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Data.Monoid ((<>))
-- import Data.Text (Text) -- import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Calendar import Data.Time.Calendar
import Safe (readDef, headDef) import Safe (readDef, headDef)
import Test.HUnit import Test.HUnit
-- import Text.ParserCombinators.Parsec import Text.Megaparsec
import Text.Parsec hiding (Empty) import Text.Megaparsec.Text
import Hledger.Utils import Hledger.Utils hiding (words')
import Hledger.Data.Types import Hledger.Data.Types
import Hledger.Data.AccountName import Hledger.Data.AccountName
import Hledger.Data.Amount (amount, nullamt, usd) import Hledger.Data.Amount (amount, nullamt, usd)
@ -154,7 +155,7 @@ data QueryOpt = QueryOptInAcctOnly AccountName -- ^ show an account register fo
-- 1. multiple account patterns are OR'd together -- 1. multiple account patterns are OR'd together
-- 2. multiple description patterns are OR'd together -- 2. multiple description patterns are OR'd together
-- 3. then all terms are AND'd together -- 3. then all terms are AND'd together
parseQuery :: Day -> String -> (Query,[QueryOpt]) parseQuery :: Day -> T.Text -> (Query,[QueryOpt])
parseQuery d s = (q, opts) parseQuery d s = (q, opts)
where where
terms = words'' prefixes s terms = words'' prefixes s
@ -178,21 +179,27 @@ tests_parseQuery = [
-- | Quote-and-prefix-aware version of words - don't split on spaces which -- | Quote-and-prefix-aware version of words - don't split on spaces which
-- are inside quotes, including quotes which may have one of the specified -- are inside quotes, including quotes which may have one of the specified
-- prefixes in front, and maybe an additional not: prefix in front of that. -- prefixes in front, and maybe an additional not: prefix in front of that.
words'' :: [String] -> String -> [String] words'' :: [T.Text] -> T.Text -> [T.Text]
words'' prefixes = fromparse . parsewith maybeprefixedquotedphrases -- XXX words'' prefixes = fromparse . parsewith maybeprefixedquotedphrases -- XXX
where where
maybeprefixedquotedphrases = choice' [prefixedQuotedPattern, singleQuotedPattern, doubleQuotedPattern, pattern] `sepBy` many1 spacenonewline maybeprefixedquotedphrases :: Parser [T.Text]
maybeprefixedquotedphrases = choice' [prefixedQuotedPattern, singleQuotedPattern, doubleQuotedPattern, pattern] `sepBy` some spacenonewline
prefixedQuotedPattern :: Parser T.Text
prefixedQuotedPattern = do prefixedQuotedPattern = do
not' <- fromMaybe "" `fmap` (optionMaybe $ string "not:") not' <- fromMaybe "" `fmap` (optional $ string "not:")
let allowednexts | null not' = prefixes let allowednexts | null not' = prefixes
| otherwise = prefixes ++ [""] | otherwise = prefixes ++ [""]
next <- choice' $ map string allowednexts next <- fmap T.pack $ choice' $ map (string . T.unpack) allowednexts
let prefix = not' ++ next let prefix :: T.Text
prefix = T.pack not' <> next
p <- singleQuotedPattern <|> doubleQuotedPattern p <- singleQuotedPattern <|> doubleQuotedPattern
return $ prefix ++ stripquotes p return $ prefix <> stripquotes p
singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf "'") >>= return . stripquotes singleQuotedPattern :: Parser T.Text
doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf "\"") >>= return . stripquotes singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf ("'" :: [Char])) >>= return . stripquotes . T.pack
pattern = many (noneOf " \n\r") doubleQuotedPattern :: Parser T.Text
doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf ("\"" :: [Char])) >>= return . stripquotes . T.pack
pattern :: Parser T.Text
pattern = fmap T.pack $ many (noneOf (" \n\r" :: [Char]))
tests_words'' = [ tests_words'' = [
"words''" ~: do "words''" ~: do
@ -209,7 +216,8 @@ tests_words'' = [
-- XXX -- XXX
-- keep synced with patterns below, excluding "not" -- keep synced with patterns below, excluding "not"
prefixes = map (++":") [ prefixes :: [T.Text]
prefixes = map (<>":") [
"inacctonly" "inacctonly"
,"inacct" ,"inacct"
,"amt" ,"amt"
@ -226,6 +234,7 @@ prefixes = map (++":") [
,"tag" ,"tag"
] ]
defaultprefix :: T.Text
defaultprefix = "acct" defaultprefix = "acct"
-- -- | Parse the query string as a boolean tree of match patterns. -- -- | Parse the query string as a boolean tree of match patterns.
@ -240,36 +249,37 @@ defaultprefix = "acct"
-- | Parse a single query term as either a query or a query option, -- | Parse a single query term as either a query or a query option,
-- or raise an error if it has invalid syntax. -- or raise an error if it has invalid syntax.
parseQueryTerm :: Day -> String -> Either Query QueryOpt parseQueryTerm :: Day -> T.Text -> Either Query QueryOpt
parseQueryTerm _ ('i':'n':'a':'c':'c':'t':'o':'n':'l':'y':':':s) = Right $ QueryOptInAcctOnly $ T.pack s parseQueryTerm _ (T.stripPrefix "inacctonly:" -> Just s) = Right $ QueryOptInAcctOnly s
parseQueryTerm _ ('i':'n':'a':'c':'c':'t':':':s) = Right $ QueryOptInAcct $ T.pack s parseQueryTerm _ (T.stripPrefix "inacct:" -> Just s) = Right $ QueryOptInAcct s
parseQueryTerm d ('n':'o':'t':':':s) = case parseQueryTerm d s of parseQueryTerm d (T.stripPrefix "not:" -> Just s) =
Left m -> Left $ Not m case parseQueryTerm d s of
Right _ -> Left Any -- not:somequeryoption will be ignored Left m -> Left $ Not m
parseQueryTerm _ ('c':'o':'d':'e':':':s) = Left $ Code s Right _ -> Left Any -- not:somequeryoption will be ignored
parseQueryTerm _ ('d':'e':'s':'c':':':s) = Left $ Desc s parseQueryTerm _ (T.stripPrefix "code:" -> Just s) = Left $ Code $ T.unpack s
parseQueryTerm _ ('a':'c':'c':'t':':':s) = Left $ Acct s parseQueryTerm _ (T.stripPrefix "desc:" -> Just s) = Left $ Desc $ T.unpack s
parseQueryTerm d ('d':'a':'t':'e':'2':':':s) = parseQueryTerm _ (T.stripPrefix "acct:" -> Just s) = Left $ Acct $ T.unpack s
case parsePeriodExpr d s of Left e -> error' $ "\"date2:"++s++"\" gave a "++showDateParseError e parseQueryTerm d (T.stripPrefix "date2:" -> Just s) =
case parsePeriodExpr d s of Left e -> error' $ "\"date2:"++T.unpack s++"\" gave a "++showDateParseError e
Right (_,span) -> Left $ Date2 span Right (_,span) -> Left $ Date2 span
parseQueryTerm d ('d':'a':'t':'e':':':s) = parseQueryTerm d (T.stripPrefix "date:" -> Just s) =
case parsePeriodExpr d s of Left e -> error' $ "\"date:"++s++"\" gave a "++showDateParseError e case parsePeriodExpr d s of Left e -> error' $ "\"date:"++T.unpack s++"\" gave a "++showDateParseError e
Right (_,span) -> Left $ Date span Right (_,span) -> Left $ Date span
parseQueryTerm _ ('s':'t':'a':'t':'u':'s':':':s) = parseQueryTerm _ (T.stripPrefix "status:" -> Just s) =
case parseStatus s of Left e -> error' $ "\"status:"++s++"\" gave a parse error: " ++ e case parseStatus s of Left e -> error' $ "\"status:"++T.unpack s++"\" gave a parse error: " ++ e
Right st -> Left $ Status st Right st -> Left $ Status st
parseQueryTerm _ ('r':'e':'a':'l':':':s) = Left $ Real $ parseBool s || null s parseQueryTerm _ (T.stripPrefix "real:" -> Just s) = Left $ Real $ parseBool s || T.null s
parseQueryTerm _ ('a':'m':'t':':':s) = Left $ Amt ord q where (ord, q) = parseAmountQueryTerm s parseQueryTerm _ (T.stripPrefix "amt:" -> Just s) = Left $ Amt ord q where (ord, q) = parseAmountQueryTerm s
parseQueryTerm _ ('e':'m':'p':'t':'y':':':s) = Left $ Empty $ parseBool s parseQueryTerm _ (T.stripPrefix "empty:" -> Just s) = Left $ Empty $ parseBool s
parseQueryTerm _ ('d':'e':'p':'t':'h':':':s) parseQueryTerm _ (T.stripPrefix "depth:" -> Just s)
| n >= 0 = Left $ Depth n | n >= 0 = Left $ Depth n
| otherwise = error' "depth: should have a positive number" | otherwise = error' "depth: should have a positive number"
where n = readDef 0 s where n = readDef 0 (T.unpack s)
parseQueryTerm _ ('c':'u':'r':':':s) = Left $ Sym s -- support cur: as an alias parseQueryTerm _ (T.stripPrefix "cur:" -> Just s) = Left $ Sym (T.unpack s) -- support cur: as an alias
parseQueryTerm _ ('t':'a':'g':':':s) = Left $ Tag n v where (n,v) = parseTag s parseQueryTerm _ (T.stripPrefix "tag:" -> Just s) = Left $ Tag n v where (n,v) = parseTag s
parseQueryTerm _ "" = Left $ Any parseQueryTerm _ "" = Left $ Any
parseQueryTerm d s = parseQueryTerm d $ defaultprefix++":"++s parseQueryTerm d s = parseQueryTerm d $ defaultprefix<>":"<>s
tests_parseQueryTerm = [ tests_parseQueryTerm = [
"parseQueryTerm" ~: do "parseQueryTerm" ~: do
@ -298,35 +308,40 @@ data OrdPlus = Lt | LtEq | Gt | GtEq | Eq | AbsLt | AbsLtEq | AbsGt | AbsGtEq |
deriving (Show,Eq,Data,Typeable) deriving (Show,Eq,Data,Typeable)
-- can fail -- can fail
parseAmountQueryTerm :: String -> (OrdPlus, Quantity) parseAmountQueryTerm :: T.Text -> (OrdPlus, Quantity)
parseAmountQueryTerm s' = parseAmountQueryTerm s' =
case s' of case s' of
-- feel free to do this a smarter way -- feel free to do this a smarter way
"" -> err "" -> err
'<':'+':s -> (Lt, readDef err s) (T.stripPrefix "<+" -> Just s) -> (Lt, readDef err (T.unpack s))
'<':'=':'+':s -> (LtEq, readDef err s) (T.stripPrefix "<=+" -> Just s) -> (LtEq, readDef err (T.unpack s))
'>':'+':s -> (Gt, readDef err s) (T.stripPrefix ">+" -> Just s) -> (Gt, readDef err (T.unpack s))
'>':'=':'+':s -> (GtEq, readDef err s) (T.stripPrefix ">=+" -> Just s) -> (GtEq, readDef err (T.unpack s))
'=':'+':s -> (Eq, readDef err s) (T.stripPrefix "=+" -> Just s) -> (Eq, readDef err (T.unpack s))
'+':s -> (Eq, readDef err s) (T.stripPrefix "+" -> Just s) -> (Eq, readDef err (T.unpack s))
'<':'-':s -> (Lt, negate $ readDef err s) (T.stripPrefix "<-" -> Just s) -> (Lt, negate $ readDef err (T.unpack s))
'<':'=':'-':s -> (LtEq, negate $ readDef err s) (T.stripPrefix "<=-" -> Just s) -> (LtEq, negate $ readDef err (T.unpack s))
'>':'-':s -> (Gt, negate $ readDef err s) (T.stripPrefix ">-" -> Just s) -> (Gt, negate $ readDef err (T.unpack s))
'>':'=':'-':s -> (GtEq, negate $ readDef err s) (T.stripPrefix ">=-" -> Just s) -> (GtEq, negate $ readDef err (T.unpack s))
'=':'-':s -> (Eq, negate $ readDef err s) (T.stripPrefix "=-" -> Just s) -> (Eq, negate $ readDef err (T.unpack s))
'-':s -> (Eq, negate $ readDef err s) (T.stripPrefix "-" -> Just s) -> (Eq, negate $ readDef err (T.unpack s))
'<':'=':s -> let n = readDef err s in case n of 0 -> (LtEq, 0) (T.stripPrefix "<=" -> Just s) -> let n = readDef err (T.unpack s) in
_ -> (AbsLtEq, n) case n of
'<':s -> let n = readDef err s in case n of 0 -> (Lt, 0) 0 -> (LtEq, 0)
_ -> (AbsLt, n) _ -> (AbsLtEq, n)
'>':'=':s -> let n = readDef err s in case n of 0 -> (GtEq, 0) (T.stripPrefix "<" -> Just s) -> let n = readDef err (T.unpack s) in
_ -> (AbsGtEq, n) case n of 0 -> (Lt, 0)
'>':s -> let n = readDef err s in case n of 0 -> (Gt, 0) _ -> (AbsLt, n)
_ -> (AbsGt, n) (T.stripPrefix ">=" -> Just s) -> let n = readDef err (T.unpack s) in
'=':s -> (AbsEq, readDef err s) case n of 0 -> (GtEq, 0)
s -> (AbsEq, readDef err s) _ -> (AbsGtEq, n)
(T.stripPrefix ">" -> Just s) -> let n = readDef err (T.unpack s) in
case n of 0 -> (Gt, 0)
_ -> (AbsGt, n)
(T.stripPrefix "=" -> Just s) -> (AbsEq, readDef err (T.unpack s))
s -> (AbsEq, readDef err (T.unpack s))
where where
err = error' $ "could not parse as '=', '<', or '>' (optional) followed by a (optionally signed) numeric quantity: " ++ s' err = error' $ "could not parse as '=', '<', or '>' (optional) followed by a (optionally signed) numeric quantity: " ++ T.unpack s'
tests_parseAmountQueryTerm = [ tests_parseAmountQueryTerm = [
"parseAmountQueryTerm" ~: do "parseAmountQueryTerm" ~: do
@ -340,13 +355,13 @@ tests_parseAmountQueryTerm = [
"-0.23" `gives` (Eq,(-0.23)) "-0.23" `gives` (Eq,(-0.23))
] ]
parseTag :: String -> (Regexp, Maybe Regexp) parseTag :: T.Text -> (Regexp, Maybe Regexp)
parseTag s | '=' `elem` s = (n, Just $ tail v) parseTag s | "=" `T.isInfixOf` s = (T.unpack n, Just $ tail $ T.unpack v)
| otherwise = (s, Nothing) | otherwise = (T.unpack s, Nothing)
where (n,v) = break (=='=') s where (n,v) = T.break (=='=') s
-- | Parse the value part of a "status:" query, or return an error. -- | Parse the value part of a "status:" query, or return an error.
parseStatus :: String -> Either String ClearedStatus parseStatus :: T.Text -> Either String ClearedStatus
parseStatus s | s `elem` ["*","1"] = Right Cleared parseStatus s | s `elem` ["*","1"] = Right Cleared
| s `elem` ["!"] = Right Pending | s `elem` ["!"] = Right Pending
| s `elem` ["","0"] = Right Uncleared | s `elem` ["","0"] = Right Uncleared
@ -354,10 +369,10 @@ parseStatus s | s `elem` ["*","1"] = Right Cleared
-- | Parse the boolean value part of a "status:" query. "1" means true, -- | Parse the boolean value part of a "status:" query. "1" means true,
-- anything else will be parsed as false without error. -- anything else will be parsed as false without error.
parseBool :: String -> Bool parseBool :: T.Text -> Bool
parseBool s = s `elem` truestrings parseBool s = s `elem` truestrings
truestrings :: [String] truestrings :: [T.Text]
truestrings = ["1"] truestrings = ["1"]
simplifyQuery :: Query -> Query simplifyQuery :: Query -> Query

View File

@ -21,10 +21,12 @@ where
import Prelude () import Prelude ()
import Prelude.Compat hiding (readFile) import Prelude.Compat hiding (readFile)
import Control.Monad.Compat import Control.Monad.Compat
import Control.Monad.Except (ExceptT(..), liftIO, runExceptT, throwError) --, catchError) import Control.Monad.Except (ExceptT(..), runExceptT, throwError) --, catchError)
import Control.Monad.State.Strict
import Data.Char (isNumber) import Data.Char (isNumber)
import Data.Functor.Identity import Data.Functor.Identity
import Data.List.Compat import Data.List.Compat
import Data.List.NonEmpty (NonEmpty(..))
import Data.List.Split (wordsBy) import Data.List.Split (wordsBy)
import Data.Maybe import Data.Maybe
import Data.Monoid import Data.Monoid
@ -34,7 +36,8 @@ import Data.Time.Calendar
import Data.Time.LocalTime import Data.Time.LocalTime
import Safe import Safe
import System.Time (getClockTime) import System.Time (getClockTime)
import Text.Parsec hiding (parse) import Text.Megaparsec hiding (parse,State)
import Text.Megaparsec.Text
import Hledger.Data import Hledger.Data
import Hledger.Utils import Hledger.Utils
@ -43,40 +46,27 @@ import Hledger.Utils
--- * parsing utils --- * parsing utils
-- | A parser of strings with generic user state, monad and return type.
type StringParser u m a = ParsecT String u m a
-- | A parser of strict text with generic user state, monad and return type.
type TextParser u m a = ParsecT Text u m a
-- | A text parser with journal-parsing state.
type JournalParser m a = TextParser Journal m a
-- | A journal parser that runs in IO and can throw an error mid-parse.
type ErroringJournalParser a = JournalParser (ExceptT String IO) a
-- | Run a string parser with no state in the identity monad. -- | Run a string parser with no state in the identity monad.
runStringParser, rsp :: StringParser () Identity a -> String -> Either ParseError a runTextParser, rtp :: TextParser Identity a -> Text -> Either (ParseError Char Dec) a
runStringParser p s = runIdentity $ runParserT p () "" s runTextParser p t = runParser p "" t
rsp = runStringParser
-- | Run a string parser with no state in the identity monad.
runTextParser, rtp :: TextParser () Identity a -> Text -> Either ParseError a
runTextParser p t = runIdentity $ runParserT p () "" t
rtp = runTextParser rtp = runTextParser
-- | Run a journal parser with a null journal-parsing state. -- | Run a journal parser with a null journal-parsing state.
runJournalParser, rjp :: Monad m => JournalParser m a -> Text -> m (Either ParseError a) runJournalParser, rjp :: Monad m => TextParser m a -> Text -> m (Either (ParseError Char Dec) a)
runJournalParser p t = runParserT p mempty "" t runJournalParser p t = runParserT p "" t
rjp = runJournalParser rjp = runJournalParser
-- | Run an error-raising journal parser with a null journal-parsing state. -- | Run an error-raising journal parser with a null journal-parsing state.
runErroringJournalParser, rejp :: ErroringJournalParser a -> Text -> IO (Either String a) runErroringJournalParser, rejp :: ErroringJournalParser a -> Text -> IO (Either String a)
runErroringJournalParser p t = runExceptT $ runJournalParser p t >>= either (throwError.show) return runErroringJournalParser p t =
runExceptT $
runJournalParser (evalStateT p mempty)
t >>=
either (throwError . parseErrorPretty) return
rejp = runErroringJournalParser rejp = runErroringJournalParser
genericSourcePos :: SourcePos -> GenericSourcePos genericSourcePos :: SourcePos -> GenericSourcePos
genericSourcePos p = GenericSourcePos (sourceName p) (sourceLine p) (sourceColumn p) genericSourcePos p = GenericSourcePos (sourceName p) (fromIntegral . unPos $ sourceLine p) (fromIntegral . unPos $ sourceColumn p)
-- | Given a parsec ParsedJournal parser, file path and data string, -- | Given a parsec ParsedJournal parser, file path and data string,
-- parse and post-process a ready-to-use Journal, or give an error. -- parse and post-process a ready-to-use Journal, or give an error.
@ -84,60 +74,71 @@ parseAndFinaliseJournal :: ErroringJournalParser ParsedJournal -> Bool -> FilePa
parseAndFinaliseJournal parser assrt f txt = do parseAndFinaliseJournal parser assrt f txt = do
t <- liftIO getClockTime t <- liftIO getClockTime
y <- liftIO getCurrentYear y <- liftIO getCurrentYear
ep <- runParserT parser nulljournal{jparsedefaultyear=Just y} f txt ep <- runParserT (evalStateT parser nulljournal {jparsedefaultyear=Just y}) f txt
case ep of case ep of
Right pj -> case journalFinalise t f txt assrt pj of Right pj -> case journalFinalise t f txt assrt pj of
Right j -> return j Right j -> return j
Left e -> throwError e Left e -> throwError e
Left e -> throwError $ show e Left e -> throwError $ parseErrorPretty e
setYear :: Monad m => Integer -> JournalParser m () parseAndFinaliseJournal' :: JournalParser ParsedJournal -> Bool -> FilePath -> Text -> ExceptT String IO Journal
setYear y = modifyState (\j -> j{jparsedefaultyear=Just y}) parseAndFinaliseJournal' parser assrt f txt = do
t <- liftIO getClockTime
y <- liftIO getCurrentYear
let ep = runParser (evalStateT parser nulljournal {jparsedefaultyear=Just y}) f txt
case ep of
Right pj -> case journalFinalise t f txt assrt pj of
Right j -> return j
Left e -> throwError e
Left e -> throwError $ parseErrorPretty e
getYear :: Monad m => JournalParser m (Maybe Integer) setYear :: Monad m => Year -> JournalStateParser m ()
getYear = fmap jparsedefaultyear getState setYear y = modify' (\j -> j{jparsedefaultyear=Just y})
setDefaultCommodityAndStyle :: Monad m => (CommoditySymbol,AmountStyle) -> JournalParser m () getYear :: Monad m => JournalStateParser m (Maybe Year)
setDefaultCommodityAndStyle cs = modifyState (\j -> j{jparsedefaultcommodity=Just cs}) getYear = fmap jparsedefaultyear get
getDefaultCommodityAndStyle :: Monad m => JournalParser m (Maybe (CommoditySymbol,AmountStyle)) setDefaultCommodityAndStyle :: (CommoditySymbol,AmountStyle) -> ErroringJournalParser ()
getDefaultCommodityAndStyle = jparsedefaultcommodity `fmap` getState setDefaultCommodityAndStyle cs = modify' (\j -> j{jparsedefaultcommodity=Just cs})
pushAccount :: Monad m => AccountName -> JournalParser m () getDefaultCommodityAndStyle :: Monad m => JournalStateParser m (Maybe (CommoditySymbol,AmountStyle))
pushAccount acct = modifyState (\j -> j{jaccounts = acct : jaccounts j}) getDefaultCommodityAndStyle = jparsedefaultcommodity `fmap` get
pushParentAccount :: Monad m => AccountName -> JournalParser m () pushAccount :: AccountName -> ErroringJournalParser ()
pushParentAccount acct = modifyState (\j -> j{jparseparentaccounts = acct : jparseparentaccounts j}) pushAccount acct = modify' (\j -> j{jaccounts = acct : jaccounts j})
popParentAccount :: Monad m => JournalParser m () pushParentAccount :: AccountName -> ErroringJournalParser ()
pushParentAccount acct = modify' (\j -> j{jparseparentaccounts = acct : jparseparentaccounts j})
popParentAccount :: ErroringJournalParser ()
popParentAccount = do popParentAccount = do
j <- getState j <- get
case jparseparentaccounts j of case jparseparentaccounts j of
[] -> unexpected "End of apply account block with no beginning" [] -> unexpected (Tokens ('E' :| "nd of apply account block with no beginning"))
(_:rest) -> setState j{jparseparentaccounts=rest} (_:rest) -> put j{jparseparentaccounts=rest}
getParentAccount :: Monad m => JournalParser m AccountName getParentAccount :: ErroringJournalParser AccountName
getParentAccount = fmap (concatAccountNames . reverse . jparseparentaccounts) getState getParentAccount = fmap (concatAccountNames . reverse . jparseparentaccounts) get
addAccountAlias :: Monad m => AccountAlias -> JournalParser m () addAccountAlias :: MonadState Journal m => AccountAlias -> m ()
addAccountAlias a = modifyState (\(j@Journal{..}) -> j{jparsealiases=a:jparsealiases}) addAccountAlias a = modify' (\(j@Journal{..}) -> j{jparsealiases=a:jparsealiases})
getAccountAliases :: Monad m => JournalParser m [AccountAlias] getAccountAliases :: MonadState Journal m => m [AccountAlias]
getAccountAliases = fmap jparsealiases getState getAccountAliases = fmap jparsealiases get
clearAccountAliases :: Monad m => JournalParser m () clearAccountAliases :: MonadState Journal m => m ()
clearAccountAliases = modifyState (\(j@Journal{..}) -> j{jparsealiases=[]}) clearAccountAliases = modify' (\(j@Journal{..}) -> j{jparsealiases=[]})
getTransactionCount :: Monad m => JournalParser m Integer getTransactionCount :: MonadState Journal m => m Integer
getTransactionCount = fmap jparsetransactioncount getState getTransactionCount = fmap jparsetransactioncount get
setTransactionCount :: Monad m => Integer -> JournalParser m () setTransactionCount :: MonadState Journal m => Integer -> m ()
setTransactionCount i = modifyState (\j -> j{jparsetransactioncount=i}) setTransactionCount i = modify' (\j -> j{jparsetransactioncount=i})
-- | Increment the transaction index by one and return the new value. -- | Increment the transaction index by one and return the new value.
incrementTransactionCount :: Monad m => JournalParser m Integer incrementTransactionCount :: MonadState Journal m => m Integer
incrementTransactionCount = do incrementTransactionCount = do
modifyState (\j -> j{jparsetransactioncount=jparsetransactioncount j + 1}) modify' (\j -> j{jparsetransactioncount=jparsetransactioncount j + 1})
getTransactionCount getTransactionCount
journalAddFile :: (FilePath,Text) -> Journal -> Journal journalAddFile :: (FilePath,Text) -> Journal -> Journal
@ -155,12 +156,12 @@ journalAddFile f j@Journal{jfiles=fs} = j{jfiles=fs++[f]}
-- | Terminate parsing entirely, returning the given error message -- | Terminate parsing entirely, returning the given error message
-- with the given parse position prepended. -- with the given parse position prepended.
parserErrorAt :: SourcePos -> String -> ErroringJournalParser a parserErrorAt :: SourcePos -> String -> ErroringJournalParser a
parserErrorAt pos s = throwError $ show pos ++ ":\n" ++ s parserErrorAt pos s = throwError $ sourcePosPretty pos ++ ":\n" ++ s
--- * parsers --- * parsers
--- ** transaction bits --- ** transaction bits
statusp :: Monad m => JournalParser m ClearedStatus statusp :: TextParser m ClearedStatus
statusp = statusp =
choice' choice'
[ many spacenonewline >> char '*' >> return Cleared [ many spacenonewline >> char '*' >> return Cleared
@ -169,11 +170,11 @@ statusp =
] ]
<?> "cleared status" <?> "cleared status"
codep :: Monad m => JournalParser m String codep :: TextParser m String
codep = try (do { many1 spacenonewline; char '(' <?> "codep"; anyChar `manyTill` char ')' } ) <|> return "" codep = try (do { some spacenonewline; char '(' <?> "codep"; anyChar `manyTill` char ')' } ) <|> return ""
descriptionp :: Monad m => JournalParser m String descriptionp :: ErroringJournalParser String
descriptionp = many (noneOf ";\n") descriptionp = many (noneOf (";\n" :: [Char]))
--- ** dates --- ** dates
@ -181,14 +182,14 @@ descriptionp = many (noneOf ";\n")
-- Hyphen (-) and period (.) are also allowed as separators. -- Hyphen (-) and period (.) are also allowed as separators.
-- The year may be omitted if a default year has been set. -- The year may be omitted if a default year has been set.
-- Leading zeroes may be omitted. -- Leading zeroes may be omitted.
datep :: Monad m => JournalParser m Day datep :: Monad m => JournalStateParser m Day
datep = do datep = do
-- hacky: try to ensure precise errors for invalid dates -- hacky: try to ensure precise errors for invalid dates
-- XXX reported error position is not too good -- XXX reported error position is not too good
-- pos <- genericSourcePos <$> getPosition -- pos <- genericSourcePos <$> getPosition
datestr <- do datestr <- do
c <- digit c <- digitChar
cs <- many $ choice' [digit, datesepchar] cs <- lift $ many $ choice' [digitChar, datesepchar]
return $ c:cs return $ c:cs
let sepchars = nub $ sort $ filter (`elem` datesepchars) datestr let sepchars = nub $ sort $ filter (`elem` datesepchars) datestr
when (length sepchars /= 1) $ fail $ "bad date, different separators used: " ++ datestr when (length sepchars /= 1) $ fail $ "bad date, different separators used: " ++ datestr
@ -211,35 +212,35 @@ datep = do
-- Seconds are optional. -- Seconds are optional.
-- The timezone is optional and ignored (the time is always interpreted as a local time). -- The timezone is optional and ignored (the time is always interpreted as a local time).
-- Leading zeroes may be omitted (except in a timezone). -- Leading zeroes may be omitted (except in a timezone).
datetimep :: Monad m => JournalParser m LocalTime datetimep :: ErroringJournalParser LocalTime
datetimep = do datetimep = do
day <- datep day <- datep
many1 spacenonewline lift $ some spacenonewline
h <- many1 digit h <- some digitChar
let h' = read h let h' = read h
guard $ h' >= 0 && h' <= 23 guard $ h' >= 0 && h' <= 23
char ':' char ':'
m <- many1 digit m <- some digitChar
let m' = read m let m' = read m
guard $ m' >= 0 && m' <= 59 guard $ m' >= 0 && m' <= 59
s <- optionMaybe $ char ':' >> many1 digit s <- optional $ char ':' >> some digitChar
let s' = case s of Just sstr -> read sstr let s' = case s of Just sstr -> read sstr
Nothing -> 0 Nothing -> 0
guard $ s' >= 0 && s' <= 59 guard $ s' >= 0 && s' <= 59
{- tz <- -} {- tz <- -}
optionMaybe $ do optional $ do
plusminus <- oneOf "-+" plusminus <- oneOf ("-+" :: [Char])
d1 <- digit d1 <- digitChar
d2 <- digit d2 <- digitChar
d3 <- digit d3 <- digitChar
d4 <- digit d4 <- digitChar
return $ plusminus:d1:d2:d3:d4:"" return $ plusminus:d1:d2:d3:d4:""
-- ltz <- liftIO $ getCurrentTimeZone -- ltz <- liftIO $ getCurrentTimeZone
-- let tz' = maybe ltz (fromMaybe ltz . parseTime defaultTimeLocale "%z") tz -- let tz' = maybe ltz (fromMaybe ltz . parseTime defaultTimeLocale "%z") tz
-- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s') -- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s') return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s')
secondarydatep :: Monad m => Day -> JournalParser m Day secondarydatep :: Day -> ErroringJournalParser Day
secondarydatep primarydate = do secondarydatep primarydate = do
char '=' char '='
-- kludgy way to use primary date for default year -- kludgy way to use primary date for default year
@ -256,20 +257,20 @@ secondarydatep primarydate = do
-- >> parsewith twoorthreepartdatestringp "2016/01/2" -- >> parsewith twoorthreepartdatestringp "2016/01/2"
-- Right "2016/01/2" -- Right "2016/01/2"
-- twoorthreepartdatestringp = do -- twoorthreepartdatestringp = do
-- n1 <- many1 digit -- n1 <- some digitChar
-- c <- datesepchar -- c <- datesepchar
-- n2 <- many1 digit -- n2 <- some digitChar
-- mn3 <- optionMaybe $ char c >> many1 digit -- mn3 <- optional $ char c >> some digitChar
-- return $ n1 ++ c:n2 ++ maybe "" (c:) mn3 -- return $ n1 ++ c:n2 ++ maybe "" (c:) mn3
--- ** account names --- ** account names
-- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect. -- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect.
modifiedaccountnamep :: Monad m => JournalParser m AccountName modifiedaccountnamep :: ErroringJournalParser AccountName
modifiedaccountnamep = do modifiedaccountnamep = do
parent <- getParentAccount parent <- getParentAccount
aliases <- getAccountAliases aliases <- getAccountAliases
a <- accountnamep a <- lift accountnamep
return $ return $
accountNameApplyAliases aliases $ accountNameApplyAliases aliases $
-- XXX accountNameApplyAliasesMemo ? doesn't seem to make a difference -- XXX accountNameApplyAliasesMemo ? doesn't seem to make a difference
@ -281,7 +282,7 @@ modifiedaccountnamep = do
-- spaces (or end of input). Also they have one or more components of -- spaces (or end of input). Also they have one or more components of
-- at least one character, separated by the account separator char. -- at least one character, separated by the account separator char.
-- (This parser will also consume one following space, if present.) -- (This parser will also consume one following space, if present.)
accountnamep :: Monad m => TextParser u m AccountName accountnamep :: TextParser m AccountName
accountnamep = do accountnamep = do
astr <- do astr <- do
c <- nonspace c <- nonspace
@ -304,10 +305,10 @@ accountnamep = do
-- | Parse whitespace then an amount, with an optional left or right -- | Parse whitespace then an amount, with an optional left or right
-- currency symbol and optional price, or return the special -- currency symbol and optional price, or return the special
-- "missing" marker amount. -- "missing" marker amount.
spaceandamountormissingp :: Monad m => JournalParser m MixedAmount spaceandamountormissingp :: ErroringJournalParser MixedAmount
spaceandamountormissingp = spaceandamountormissingp =
try (do try (do
many1 spacenonewline lift $ some spacenonewline
(Mixed . (:[])) `fmap` amountp <|> return missingmixedamt (Mixed . (:[])) `fmap` amountp <|> return missingmixedamt
) <|> return missingmixedamt ) <|> return missingmixedamt
@ -328,7 +329,7 @@ test_spaceandamountormissingp = do
-- | Parse a single-commodity amount, with optional symbol on the left or -- | Parse a single-commodity amount, with optional symbol on the left or
-- right, optional unit or total price, and optional (ignored) -- right, optional unit or total price, and optional (ignored)
-- ledger-style balance assertion or fixed lot price declaration. -- ledger-style balance assertion or fixed lot price declaration.
amountp :: Monad m => JournalParser m Amount amountp :: Monad m => JournalStateParser m Amount
amountp = try leftsymbolamountp <|> try rightsymbolamountp <|> nosymbolamountp amountp = try leftsymbolamountp <|> try rightsymbolamountp <|> nosymbolamountp
#ifdef TESTS #ifdef TESTS
@ -348,7 +349,7 @@ test_amountp = do
-- | Parse an amount from a string, or get an error. -- | Parse an amount from a string, or get an error.
amountp' :: String -> Amount amountp' :: String -> Amount
amountp' s = amountp' s =
case runParser (amountp <* eof) mempty "" (T.pack s) of case runParser (evalStateT (amountp <* eof) mempty) "" (T.pack s) of
Right amt -> amt Right amt -> amt
Left err -> error' $ show err -- XXX should throwError Left err -> error' $ show err -- XXX should throwError
@ -356,37 +357,37 @@ amountp' s =
mamountp' :: String -> MixedAmount mamountp' :: String -> MixedAmount
mamountp' = Mixed . (:[]) . amountp' mamountp' = Mixed . (:[]) . amountp'
signp :: Monad m => JournalParser m String signp :: TextParser m String
signp = do signp = do
sign <- optionMaybe $ oneOf "+-" sign <- optional $ oneOf ("+-" :: [Char])
return $ case sign of Just '-' -> "-" return $ case sign of Just '-' -> "-"
_ -> "" _ -> ""
leftsymbolamountp :: Monad m => JournalParser m Amount leftsymbolamountp :: Monad m => JournalStateParser m Amount
leftsymbolamountp = do leftsymbolamountp = do
sign <- signp sign <- lift signp
c <- commoditysymbolp c <- lift commoditysymbolp
sp <- many spacenonewline sp <- lift $ many spacenonewline
(q,prec,mdec,mgrps) <- numberp (q,prec,mdec,mgrps) <- lift numberp
let s = amountstyle{ascommodityside=L, ascommodityspaced=not $ null sp, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps} let s = amountstyle{ascommodityside=L, ascommodityspaced=not $ null sp, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}
p <- priceamountp p <- priceamountp
let applysign = if sign=="-" then negate else id let applysign = if sign=="-" then negate else id
return $ applysign $ Amount c q p s return $ applysign $ Amount c q p s
<?> "left-symbol amount" <?> "left-symbol amount"
rightsymbolamountp :: Monad m => JournalParser m Amount rightsymbolamountp :: Monad m => JournalStateParser m Amount
rightsymbolamountp = do rightsymbolamountp = do
(q,prec,mdec,mgrps) <- numberp (q,prec,mdec,mgrps) <- lift numberp
sp <- many spacenonewline sp <- lift $ many spacenonewline
c <- commoditysymbolp c <- lift commoditysymbolp
p <- priceamountp p <- priceamountp
let s = amountstyle{ascommodityside=R, ascommodityspaced=not $ null sp, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps} let s = amountstyle{ascommodityside=R, ascommodityspaced=not $ null sp, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}
return $ Amount c q p s return $ Amount c q p s
<?> "right-symbol amount" <?> "right-symbol amount"
nosymbolamountp :: Monad m => JournalParser m Amount nosymbolamountp :: Monad m => JournalStateParser m Amount
nosymbolamountp = do nosymbolamountp = do
(q,prec,mdec,mgrps) <- numberp (q,prec,mdec,mgrps) <- lift numberp
p <- priceamountp p <- priceamountp
-- apply the most recently seen default commodity and style to this commodityless amount -- apply the most recently seen default commodity and style to this commodityless amount
defcs <- getDefaultCommodityAndStyle defcs <- getDefaultCommodityAndStyle
@ -396,66 +397,66 @@ nosymbolamountp = do
return $ Amount c q p s return $ Amount c q p s
<?> "no-symbol amount" <?> "no-symbol amount"
commoditysymbolp :: Monad m => JournalParser m CommoditySymbol commoditysymbolp :: TextParser m CommoditySymbol
commoditysymbolp = (quotedcommoditysymbolp <|> simplecommoditysymbolp) <?> "commodity symbol" commoditysymbolp = (quotedcommoditysymbolp <|> simplecommoditysymbolp) <?> "commodity symbol"
quotedcommoditysymbolp :: Monad m => JournalParser m CommoditySymbol quotedcommoditysymbolp :: TextParser m CommoditySymbol
quotedcommoditysymbolp = do quotedcommoditysymbolp = do
char '"' char '"'
s <- many1 $ noneOf ";\n\"" s <- some $ noneOf (";\n\"" :: [Char])
char '"' char '"'
return $ T.pack s return $ T.pack s
simplecommoditysymbolp :: Monad m => JournalParser m CommoditySymbol simplecommoditysymbolp :: TextParser m CommoditySymbol
simplecommoditysymbolp = T.pack <$> many1 (noneOf nonsimplecommoditychars) simplecommoditysymbolp = T.pack <$> some (noneOf nonsimplecommoditychars)
priceamountp :: Monad m => JournalParser m Price priceamountp :: Monad m => JournalStateParser m Price
priceamountp = priceamountp =
try (do try (do
many spacenonewline lift (many spacenonewline)
char '@' char '@'
try (do try (do
char '@' char '@'
many spacenonewline lift (many spacenonewline)
a <- amountp -- XXX can parse more prices ad infinitum, shouldn't a <- amountp -- XXX can parse more prices ad infinitum, shouldn't
return $ TotalPrice a) return $ TotalPrice a)
<|> (do <|> (do
many spacenonewline lift (many spacenonewline)
a <- amountp -- XXX can parse more prices ad infinitum, shouldn't a <- amountp -- XXX can parse more prices ad infinitum, shouldn't
return $ UnitPrice a)) return $ UnitPrice a))
<|> return NoPrice <|> return NoPrice
partialbalanceassertionp :: Monad m => JournalParser m (Maybe MixedAmount) partialbalanceassertionp :: ErroringJournalParser (Maybe MixedAmount)
partialbalanceassertionp = partialbalanceassertionp =
try (do try (do
many spacenonewline lift (many spacenonewline)
char '=' char '='
many spacenonewline lift (many spacenonewline)
a <- amountp -- XXX should restrict to a simple amount a <- amountp -- XXX should restrict to a simple amount
return $ Just $ Mixed [a]) return $ Just $ Mixed [a])
<|> return Nothing <|> return Nothing
-- balanceassertion :: Monad m => JournalParser m (Maybe MixedAmount) -- balanceassertion :: Monad m => TextParser m (Maybe MixedAmount)
-- balanceassertion = -- balanceassertion =
-- try (do -- try (do
-- many spacenonewline -- lift (many spacenonewline)
-- string "==" -- string "=="
-- many spacenonewline -- lift (many spacenonewline)
-- a <- amountp -- XXX should restrict to a simple amount -- a <- amountp -- XXX should restrict to a simple amount
-- return $ Just $ Mixed [a]) -- return $ Just $ Mixed [a])
-- <|> return Nothing -- <|> return Nothing
-- http://ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices -- http://ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices
fixedlotpricep :: Monad m => JournalParser m (Maybe Amount) fixedlotpricep :: ErroringJournalParser (Maybe Amount)
fixedlotpricep = fixedlotpricep =
try (do try (do
many spacenonewline lift (many spacenonewline)
char '{' char '{'
many spacenonewline lift (many spacenonewline)
char '=' char '='
many spacenonewline lift (many spacenonewline)
a <- amountp -- XXX should restrict to a simple amount a <- amountp -- XXX should restrict to a simple amount
many spacenonewline lift (many spacenonewline)
char '}' char '}'
return $ Just a) return $ Just a)
<|> return Nothing <|> return Nothing
@ -472,13 +473,13 @@ fixedlotpricep =
-- seen following the decimal point), the decimal point character used if any, -- seen following the decimal point), the decimal point character used if any,
-- and the digit group style if any. -- and the digit group style if any.
-- --
numberp :: Monad m => JournalParser m (Quantity, Int, Maybe Char, Maybe DigitGroupStyle) numberp :: TextParser m (Quantity, Int, Maybe Char, Maybe DigitGroupStyle)
numberp = do numberp = do
-- a number is an optional sign followed by a sequence of digits possibly -- a number is an optional sign followed by a sequence of digits possibly
-- interspersed with periods, commas, or both -- interspersed with periods, commas, or both
-- ptrace "numberp" -- ptrace "numberp"
sign <- signp sign <- signp
parts <- many1 $ choice' [many1 digit, many1 $ char ',', many1 $ char '.'] parts <- some $ choice' [some digitChar, some $ char ',', some $ char '.']
dbg8 "numberp parsed" (sign,parts) `seq` return () dbg8 "numberp parsed" (sign,parts) `seq` return ()
-- check the number is well-formed and identify the decimal point and digit -- check the number is well-formed and identify the decimal point and digit
@ -546,26 +547,26 @@ numberp = do
--- ** comments --- ** comments
multilinecommentp :: Monad m => JournalParser m () multilinecommentp :: ErroringJournalParser ()
multilinecommentp = do multilinecommentp = do
string "comment" >> many spacenonewline >> newline string "comment" >> lift (many spacenonewline) >> newline
go go
where where
go = try (eof <|> (string "end comment" >> newline >> return ())) go = try (eof <|> (string "end comment" >> newline >> return ()))
<|> (anyLine >> go) <|> (anyLine >> go)
anyLine = anyChar `manyTill` newline anyLine = anyChar `manyTill` newline
emptyorcommentlinep :: Monad m => JournalParser m () emptyorcommentlinep :: ErroringJournalParser ()
emptyorcommentlinep = do emptyorcommentlinep = do
many spacenonewline >> (commentp <|> (many spacenonewline >> newline >> return "")) lift (many spacenonewline) >> (commentp <|> (lift (many spacenonewline) >> newline >> return ""))
return () return ()
-- | Parse a possibly multi-line comment following a semicolon. -- | Parse a possibly multi-line comment following a semicolon.
followingcommentp :: Monad m => JournalParser m Text followingcommentp :: ErroringJournalParser Text
followingcommentp = followingcommentp =
-- ptrace "followingcommentp" -- ptrace "followingcommentp"
do samelinecomment <- many spacenonewline >> (try semicoloncommentp <|> (newline >> return "")) do samelinecomment <- lift (many spacenonewline) >> (try semicoloncommentp <|> (newline >> return ""))
newlinecomments <- many (try (many1 spacenonewline >> semicoloncommentp)) newlinecomments <- many (try (lift (some spacenonewline) >> semicoloncommentp))
return $ T.unlines $ samelinecomment:newlinecomments return $ T.unlines $ samelinecomment:newlinecomments
-- | Parse a possibly multi-line comment following a semicolon, and -- | Parse a possibly multi-line comment following a semicolon, and
@ -580,7 +581,7 @@ followingcommentp =
-- --
-- Year unspecified and no default provided -> unknown year error, at correct position: -- Year unspecified and no default provided -> unknown year error, at correct position:
-- >>> rejp (followingcommentandtagsp Nothing) " ; xxx date:3/4\n ; second line" -- >>> rejp (followingcommentandtagsp Nothing) " ; xxx date:3/4\n ; second line"
-- Left ...line 1, column 22...year is unknown... -- Left ...1:22...partial date 3/4 found, but the current year is unknown...
-- --
-- Date tag value contains trailing text - forgot the comma, confused: -- Date tag value contains trailing text - forgot the comma, confused:
-- the syntaxes ? We'll accept the leading date anyway -- the syntaxes ? We'll accept the leading date anyway
@ -597,9 +598,9 @@ followingcommentandtagsp mdefdate = do
startpos <- getPosition startpos <- getPosition
commentandwhitespace :: String <- do commentandwhitespace :: String <- do
let semicoloncommentp' = (:) <$> char ';' <*> anyChar `manyTill` eolof let semicoloncommentp' = (:) <$> char ';' <*> anyChar `manyTill` eolof
sp1 <- many spacenonewline sp1 <- lift (many spacenonewline)
l1 <- try semicoloncommentp' <|> (newline >> return "") l1 <- try (lift semicoloncommentp') <|> (newline >> return "")
ls <- many $ try ((++) <$> many1 spacenonewline <*> semicoloncommentp') ls <- lift . many $ try ((++) <$> some spacenonewline <*> semicoloncommentp')
return $ unlines $ (sp1 ++ l1) : ls return $ unlines $ (sp1 ++ l1) : ls
let comment = T.pack $ unlines $ map (lstrip . dropWhile (==';') . strip) $ lines commentandwhitespace let comment = T.pack $ unlines $ map (lstrip . dropWhile (==';') . strip) $ lines commentandwhitespace
-- pdbg 0 $ "commentws:"++show commentandwhitespace -- pdbg 0 $ "commentws:"++show commentandwhitespace
@ -608,7 +609,7 @@ followingcommentandtagsp mdefdate = do
-- Reparse the comment for any tags. -- Reparse the comment for any tags.
tags <- case runTextParser (setPosition startpos >> tagsp) $ T.pack commentandwhitespace of tags <- case runTextParser (setPosition startpos >> tagsp) $ T.pack commentandwhitespace of
Right ts -> return ts Right ts -> return ts
Left e -> throwError $ show e Left e -> throwError $ parseErrorPretty e
-- pdbg 0 $ "tags: "++show tags -- pdbg 0 $ "tags: "++show tags
-- Reparse the comment for any posting dates. Use the transaction date for defaults, if provided. -- Reparse the comment for any posting dates. Use the transaction date for defaults, if provided.
@ -622,21 +623,21 @@ followingcommentandtagsp mdefdate = do
return (comment, tags, mdate, mdate2) return (comment, tags, mdate, mdate2)
commentp :: Monad m => JournalParser m Text commentp :: ErroringJournalParser Text
commentp = commentStartingWithp commentchars commentp = commentStartingWithp commentchars
commentchars :: [Char] commentchars :: [Char]
commentchars = "#;*" commentchars = "#;*"
semicoloncommentp :: Monad m => JournalParser m Text semicoloncommentp :: ErroringJournalParser Text
semicoloncommentp = commentStartingWithp ";" semicoloncommentp = commentStartingWithp ";"
commentStartingWithp :: Monad m => [Char] -> JournalParser m Text commentStartingWithp :: [Char] -> ErroringJournalParser Text
commentStartingWithp cs = do commentStartingWithp cs = do
-- ptrace "commentStartingWith" -- ptrace "commentStartingWith"
oneOf cs oneOf cs
many spacenonewline lift (many spacenonewline)
l <- anyChar `manyTill` eolof l <- anyChar `manyTill` (lift eolof)
optional newline optional newline
return $ T.pack l return $ T.pack l
@ -662,7 +663,7 @@ commentTags s =
Left _ -> [] -- shouldn't happen Left _ -> [] -- shouldn't happen
-- | Parse all tags found in a string. -- | Parse all tags found in a string.
tagsp :: TextParser u Identity [Tag] tagsp :: Parser [Tag]
tagsp = -- do tagsp = -- do
-- pdbg 0 $ "tagsp" -- pdbg 0 $ "tagsp"
many (try (nontagp >> tagp)) many (try (nontagp >> tagp))
@ -671,7 +672,7 @@ tagsp = -- do
-- --
-- >>> rtp nontagp "\na b:, \nd:e, f" -- >>> rtp nontagp "\na b:, \nd:e, f"
-- Right "\na " -- Right "\na "
nontagp :: TextParser u Identity String nontagp :: Parser String
nontagp = -- do nontagp = -- do
-- pdbg 0 "nontagp" -- pdbg 0 "nontagp"
-- anyChar `manyTill` (lookAhead (try (tagorbracketeddatetagsp Nothing >> return ()) <|> eof)) -- anyChar `manyTill` (lookAhead (try (tagorbracketeddatetagsp Nothing >> return ()) <|> eof))
@ -685,7 +686,7 @@ nontagp = -- do
-- >>> rtp tagp "a:b b , c AuxDate: 4/2" -- >>> rtp tagp "a:b b , c AuxDate: 4/2"
-- Right ("a","b b") -- Right ("a","b b")
-- --
tagp :: Monad m => TextParser u m Tag tagp :: Parser Tag
tagp = do tagp = do
-- pdbg 0 "tagp" -- pdbg 0 "tagp"
n <- tagnamep n <- tagnamep
@ -695,12 +696,12 @@ tagp = do
-- | -- |
-- >>> rtp tagnamep "a:" -- >>> rtp tagnamep "a:"
-- Right "a" -- Right "a"
tagnamep :: Monad m => TextParser u m Text tagnamep :: Parser Text
tagnamep = -- do tagnamep = -- do
-- pdbg 0 "tagnamep" -- pdbg 0 "tagnamep"
T.pack <$> many1 (noneOf ": \t\n") <* char ':' T.pack <$> some (noneOf (": \t\n" :: [Char])) <* char ':'
tagvaluep :: Monad m => TextParser u m Text tagvaluep :: TextParser m Text
tagvaluep = do tagvaluep = do
-- ptrace "tagvalue" -- ptrace "tagvalue"
v <- anyChar `manyTill` (void (try (char ',')) <|> eolof) v <- anyChar `manyTill` (void (try (char ',')) <|> eolof)
@ -736,29 +737,30 @@ postingdatesp mdefdate = do
-- Right ("date2",2001-03-04) -- Right ("date2",2001-03-04)
-- --
-- >>> rejp (datetagp Nothing) "date: 3/4" -- >>> rejp (datetagp Nothing) "date: 3/4"
-- Left ...line 1, column 9...year is unknown... -- Left ...1:9...partial date 3/4 found, but the current year is unknown...
-- --
datetagp :: Maybe Day -> ErroringJournalParser (TagName,Day) datetagp :: Maybe Day -> ErroringJournalParser (TagName,Day)
datetagp mdefdate = do datetagp mdefdate = do
-- pdbg 0 "datetagp" -- pdbg 0 "datetagp"
string "date" string "date"
n <- T.pack . fromMaybe "" <$> optionMaybe (string "2") n <- T.pack . fromMaybe "" <$> optional (string "2")
char ':' char ':'
startpos <- getPosition startpos <- getPosition
v <- tagvaluep v <- lift tagvaluep
-- re-parse value as a date. -- re-parse value as a date.
j <- getState j <- get
ep <- parseWithState let ep :: Either (ParseError Char Dec) Day
j{jparsedefaultyear=first3.toGregorian <$> mdefdate} ep = parseWithState'
-- The value extends to a comma, newline, or end of file. j{jparsedefaultyear=first3.toGregorian <$> mdefdate}
-- It seems like ignoring any extra stuff following a date -- The value extends to a comma, newline, or end of file.
-- gives better errors here. -- It seems like ignoring any extra stuff following a date
(do -- gives better errors here.
setPosition startpos (do
datep) -- <* eof) setPosition startpos
v datep) -- <* eof)
v
case ep case ep
of Left e -> throwError $ show e of Left e -> throwError $ parseErrorPretty e
Right d -> return ("date"<>n, d) Right d -> return ("date"<>n, d)
--- ** bracketed dates --- ** bracketed dates
@ -785,13 +787,13 @@ datetagp mdefdate = do
-- Left ...not a bracketed date... -- Left ...not a bracketed date...
-- --
-- >>> rejp (bracketeddatetagsp Nothing) "[2016/1/32]" -- >>> rejp (bracketeddatetagsp Nothing) "[2016/1/32]"
-- Left ...line 1, column 11...bad date... -- Left ...1:11:...bad date: 2016/1/32...
-- --
-- >>> rejp (bracketeddatetagsp Nothing) "[1/31]" -- >>> rejp (bracketeddatetagsp Nothing) "[1/31]"
-- Left ...line 1, column 6...year is unknown... -- Left ...1:6:...partial date 1/31 found, but the current year is unknown...
-- --
-- >>> rejp (bracketeddatetagsp Nothing) "[0123456789/-.=/-.=]" -- >>> rejp (bracketeddatetagsp Nothing) "[0123456789/-.=/-.=]"
-- Left ...line 1, column 15...bad date, different separators... -- Left ...1:15:...bad date, different separators...
-- --
bracketeddatetagsp :: Maybe Day -> ErroringJournalParser [(TagName, Day)] bracketeddatetagsp :: Maybe Day -> ErroringJournalParser [(TagName, Day)]
bracketeddatetagsp mdefdate = do bracketeddatetagsp mdefdate = do
@ -799,27 +801,28 @@ bracketeddatetagsp mdefdate = do
char '[' char '['
startpos <- getPosition startpos <- getPosition
let digits = "0123456789" let digits = "0123456789"
s <- many1 (oneOf $ '=':digits++datesepchars) s <- some (oneOf $ '=':digits++datesepchars)
char ']' char ']'
unless (any (`elem` s) digits && any (`elem` datesepchars) s) $ unless (any (`elem` s) digits && any (`elem` datesepchars) s) $
parserFail "not a bracketed date" fail "not a bracketed date"
-- looks sufficiently like a bracketed date, now we -- looks sufficiently like a bracketed date, now we
-- re-parse as dates and throw any errors -- re-parse as dates and throw any errors
j <- getState j <- get
ep <- parseWithState let ep :: Either (ParseError Char Dec) (Maybe Day, Maybe Day)
j{jparsedefaultyear=first3.toGregorian <$> mdefdate} ep = parseWithState'
(do j{jparsedefaultyear=first3.toGregorian <$> mdefdate}
setPosition startpos (do
md1 <- optionMaybe datep setPosition startpos
maybe (return ()) (setYear.first3.toGregorian) md1 md1 <- optional datep
md2 <- optionMaybe $ char '=' >> datep maybe (return ()) (setYear.first3.toGregorian) md1
eof md2 <- optional $ char '=' >> datep
return (md1,md2) eof
) return (md1,md2)
(T.pack s) )
(T.pack s)
case ep case ep
of Left e -> throwError $ show e of Left e -> throwError $ parseErrorPretty e
Right (md1,md2) -> return $ catMaybes Right (md1,md2) -> return $ catMaybes
[("date",) <$> md1, ("date2",) <$> md2] [("date",) <$> md1, ("date2",) <$> md2]

View File

@ -6,6 +6,9 @@ A reader for CSV data, using an extra rules file to help interpret the data.
-} -}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Hledger.Read.CsvReader ( module Hledger.Read.CsvReader (
-- * Reader -- * Reader
@ -25,11 +28,13 @@ import Prelude.Compat hiding (getContents)
import Control.Exception hiding (try) import Control.Exception hiding (try)
import Control.Monad import Control.Monad
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.State.Strict (StateT, State, get, modify', evalStateT)
-- import Test.HUnit -- import Test.HUnit
import Data.Char (toLower, isDigit, isSpace) import Data.Char (toLower, isDigit, isSpace)
import Data.List.Compat import Data.List.Compat
import Data.Maybe import Data.Maybe
import Data.Ord import Data.Ord
import qualified Data.Set as S
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Calendar (Day) import Data.Time.Calendar (Day)
@ -43,11 +48,11 @@ import Safe
import System.Directory (doesFileExist) import System.Directory (doesFileExist)
import System.FilePath import System.FilePath
import System.IO (stderr) import System.IO (stderr)
import Test.HUnit import Test.HUnit hiding (State)
import Text.CSV (parseCSV, CSV) import Text.CSV (parseCSV, CSV)
import Text.Parsec hiding (parse) import Text.Megaparsec hiding (parse, State)
import Text.Parsec.Pos import Text.Megaparsec.Text
import Text.Parsec.Error import qualified Text.Parsec as Parsec
import Text.Printf (hPrintf,printf) import Text.Printf (hPrintf,printf)
import Hledger.Data import Hledger.Data
@ -126,7 +131,12 @@ readJournalFromCsv mrulesfile csvfile csvdata =
-- convert to transactions and return as a journal -- convert to transactions and return as a journal
let txns = snd $ mapAccumL let txns = snd $ mapAccumL
(\pos r -> (pos, transactionFromCsvRecord (incSourceLine pos 1) rules r)) (\pos r -> (pos,
transactionFromCsvRecord
(let SourcePos name line col = pos in
SourcePos name (unsafePos $ unPos line + 1) col)
rules
r))
(initialPos parsecfilename) records (initialPos parsecfilename) records
-- heuristic: if the records appear to have been in reverse date order, -- heuristic: if the records appear to have been in reverse date order,
@ -136,14 +146,14 @@ readJournalFromCsv mrulesfile csvfile csvdata =
| otherwise = txns | otherwise = txns
return $ Right nulljournal{jtxns=sortBy (comparing tdate) txns'} return $ Right nulljournal{jtxns=sortBy (comparing tdate) txns'}
parseCsv :: FilePath -> String -> IO (Either ParseError CSV) parseCsv :: FilePath -> String -> IO (Either Parsec.ParseError CSV)
parseCsv path csvdata = parseCsv path csvdata =
case path of case path of
"-" -> liftM (parseCSV "(stdin)") getContents "-" -> liftM (parseCSV "(stdin)") getContents
_ -> return $ parseCSV path csvdata _ -> return $ parseCSV path csvdata
-- | Return the cleaned up and validated CSV data, or an error. -- | Return the cleaned up and validated CSV data, or an error.
validateCsv :: Int -> Either ParseError CSV -> Either String [CsvRecord] validateCsv :: Int -> Either Parsec.ParseError CSV -> Either String [CsvRecord]
validateCsv _ (Left e) = Left $ show e validateCsv _ (Left e) = Left $ show e
validateCsv numhdrlines (Right rs) = validate $ drop numhdrlines $ filternulls rs validateCsv numhdrlines (Right rs) = validate $ drop numhdrlines $ filternulls rs
where where
@ -298,6 +308,8 @@ data CsvRules = CsvRules {
rconditionalblocks :: [ConditionalBlock] rconditionalblocks :: [ConditionalBlock]
} deriving (Show, Eq) } deriving (Show, Eq)
type CsvRulesParser a = StateT CsvRules Parser a
type DirectiveName = String type DirectiveName = String
type CsvFieldName = String type CsvFieldName = String
type CsvFieldIndex = Int type CsvFieldIndex = Int
@ -354,26 +366,27 @@ parseRulesFile f = do
Left e -> return $ Left $ show $ toParseError e Left e -> return $ Left $ show $ toParseError e
Right r -> return $ Right r Right r -> return $ Right r
where where
toParseError s = newErrorMessage (Message s) (initialPos "") toParseError :: forall s. Ord s => s -> ParseError Char s
toParseError s = (mempty :: ParseError Char s) { errorCustom = S.singleton s}
-- | Pre-parse csv rules to interpolate included files, recursively. -- | Pre-parse csv rules to interpolate included files, recursively.
-- This is a cheap hack to avoid rewriting the existing parser. -- This is a cheap hack to avoid rewriting the existing parser.
expandIncludes :: FilePath -> String -> IO String expandIncludes :: FilePath -> T.Text -> IO T.Text
expandIncludes basedir content = do expandIncludes basedir content = do
let (ls,rest) = break (isPrefixOf "include") $ lines content let (ls,rest) = break (T.isPrefixOf "include") $ T.lines content
case rest of case rest of
[] -> return $ unlines ls [] -> return $ T.unlines ls
(('i':'n':'c':'l':'u':'d':'e':f):ls') -> do ((T.stripPrefix "include" -> Just f):ls') -> do
let f' = basedir </> dropWhile isSpace f let f' = basedir </> dropWhile isSpace (T.unpack f)
basedir' = takeDirectory f' basedir' = takeDirectory f'
included <- readFile f' >>= expandIncludes basedir' included <- readFile' f' >>= expandIncludes basedir'
return $ unlines [unlines ls, included, unlines ls'] return $ T.unlines [T.unlines ls, included, T.unlines ls']
ls' -> return $ unlines $ ls ++ ls' -- should never get here ls' -> return $ T.unlines $ ls ++ ls' -- should never get here
parseCsvRules :: FilePath -> String -> Either ParseError CsvRules parseCsvRules :: FilePath -> T.Text -> Either (ParseError Char Dec) CsvRules
-- parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s -- parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s
parseCsvRules rulesfile s = parseCsvRules rulesfile s =
runParser rulesp rules rulesfile s runParser (evalStateT rulesp rules) rulesfile s
-- | Return the validated rules, or an error. -- | Return the validated rules, or an error.
validateRules :: CsvRules -> ExceptT String IO CsvRules validateRules :: CsvRules -> ExceptT String IO CsvRules
@ -391,40 +404,40 @@ validateRules rules = do
-- parsers -- parsers
rulesp :: Stream [Char] m t => ParsecT [Char] CsvRules m CsvRules rulesp :: CsvRulesParser CsvRules
rulesp = do rulesp = do
many $ choice' many $ choiceInState
[blankorcommentlinep <?> "blank or comment line" [blankorcommentlinep <?> "blank or comment line"
,(directivep >>= modifyState . addDirective) <?> "directive" ,(directivep >>= modify' . addDirective) <?> "directive"
,(fieldnamelistp >>= modifyState . setIndexesAndAssignmentsFromList) <?> "field name list" ,(fieldnamelistp >>= modify' . setIndexesAndAssignmentsFromList) <?> "field name list"
,(fieldassignmentp >>= modifyState . addAssignment) <?> "field assignment" ,(fieldassignmentp >>= modify' . addAssignment) <?> "field assignment"
,(conditionalblockp >>= modifyState . addConditionalBlock) <?> "conditional block" ,(conditionalblockp >>= modify' . addConditionalBlock) <?> "conditional block"
] ]
eof eof
r <- getState r <- get
return r{rdirectives=reverse $ rdirectives r return r{rdirectives=reverse $ rdirectives r
,rassignments=reverse $ rassignments r ,rassignments=reverse $ rassignments r
,rconditionalblocks=reverse $ rconditionalblocks r ,rconditionalblocks=reverse $ rconditionalblocks r
} }
blankorcommentlinep :: Stream [Char] m t => ParsecT [Char] CsvRules m () blankorcommentlinep :: CsvRulesParser ()
blankorcommentlinep = pdbg 3 "trying blankorcommentlinep" >> choice' [blanklinep, commentlinep] blankorcommentlinep = lift (pdbg 3 "trying blankorcommentlinep") >> choiceInState [blanklinep, commentlinep]
blanklinep :: Stream [Char] m t => ParsecT [Char] CsvRules m () blanklinep :: CsvRulesParser ()
blanklinep = many spacenonewline >> newline >> return () <?> "blank line" blanklinep = lift (many spacenonewline) >> newline >> return () <?> "blank line"
commentlinep :: Stream [Char] m t => ParsecT [Char] CsvRules m () commentlinep :: CsvRulesParser ()
commentlinep = many spacenonewline >> commentcharp >> restofline >> return () <?> "comment line" commentlinep = lift (many spacenonewline) >> commentcharp >> lift restofline >> return () <?> "comment line"
commentcharp :: Stream [Char] m t => ParsecT [Char] CsvRules m Char commentcharp :: CsvRulesParser Char
commentcharp = oneOf ";#*" commentcharp = oneOf (";#*" :: [Char])
directivep :: Stream [Char] m t => ParsecT [Char] CsvRules m (DirectiveName, String) directivep :: CsvRulesParser (DirectiveName, String)
directivep = (do directivep = (do
pdbg 3 "trying directive" lift $ pdbg 3 "trying directive"
d <- choice' $ map string directives d <- choiceInState $ map string directives
v <- (((char ':' >> many spacenonewline) <|> many1 spacenonewline) >> directivevalp) v <- (((char ':' >> lift (many spacenonewline)) <|> lift (some spacenonewline)) >> directivevalp)
<|> (optional (char ':') >> many spacenonewline >> eolof >> return "") <|> (optional (char ':') >> lift (many spacenonewline) >> lift eolof >> return "")
return (d,v) return (d,v)
) <?> "directive" ) <?> "directive"
@ -438,46 +451,46 @@ directives =
-- ,"base-currency" -- ,"base-currency"
] ]
directivevalp :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char] directivevalp :: CsvRulesParser String
directivevalp = anyChar `manyTill` eolof directivevalp = anyChar `manyTill` lift eolof
fieldnamelistp :: Stream [Char] m t => ParsecT [Char] CsvRules m [CsvFieldName] fieldnamelistp :: CsvRulesParser [CsvFieldName]
fieldnamelistp = (do fieldnamelistp = (do
pdbg 3 "trying fieldnamelist" lift $ pdbg 3 "trying fieldnamelist"
string "fields" string "fields"
optional $ char ':' optional $ char ':'
many1 spacenonewline lift (some spacenonewline)
let separator = many spacenonewline >> char ',' >> many spacenonewline let separator = lift (many spacenonewline) >> char ',' >> lift (many spacenonewline)
f <- fromMaybe "" <$> optionMaybe fieldnamep f <- fromMaybe "" <$> optional fieldnamep
fs <- many1 $ (separator >> fromMaybe "" <$> optionMaybe fieldnamep) fs <- some $ (separator >> fromMaybe "" <$> optional fieldnamep)
restofline lift restofline
return $ map (map toLower) $ f:fs return $ map (map toLower) $ f:fs
) <?> "field name list" ) <?> "field name list"
fieldnamep :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char] fieldnamep :: CsvRulesParser String
fieldnamep = quotedfieldnamep <|> barefieldnamep fieldnamep = quotedfieldnamep <|> barefieldnamep
quotedfieldnamep :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char] quotedfieldnamep :: CsvRulesParser String
quotedfieldnamep = do quotedfieldnamep = do
char '"' char '"'
f <- many1 $ noneOf "\"\n:;#~" f <- some $ noneOf ("\"\n:;#~" :: [Char])
char '"' char '"'
return f return f
barefieldnamep :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char] barefieldnamep :: CsvRulesParser String
barefieldnamep = many1 $ noneOf " \t\n,;#~" barefieldnamep = some $ noneOf (" \t\n,;#~" :: [Char])
fieldassignmentp :: Stream [Char] m t => ParsecT [Char] CsvRules m (JournalFieldName, FieldTemplate) fieldassignmentp :: CsvRulesParser (JournalFieldName, FieldTemplate)
fieldassignmentp = do fieldassignmentp = do
pdbg 3 "trying fieldassignment" lift $ pdbg 3 "trying fieldassignmentp"
f <- journalfieldnamep f <- journalfieldnamep
assignmentseparatorp assignmentseparatorp
v <- fieldvalp v <- fieldvalp
return (f,v) return (f,v)
<?> "field assignment" <?> "field assignment"
journalfieldnamep :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char] journalfieldnamep :: CsvRulesParser String
journalfieldnamep = pdbg 2 "trying journalfieldnamep" >> choice' (map string journalfieldnames) journalfieldnamep = lift (pdbg 2 "trying journalfieldnamep") >> choiceInState (map string journalfieldnames)
journalfieldnames = journalfieldnames =
[-- pseudo fields: [-- pseudo fields:
@ -496,74 +509,74 @@ journalfieldnames =
,"comment" ,"comment"
] ]
assignmentseparatorp :: Stream [Char] m t => ParsecT [Char] CsvRules m () assignmentseparatorp :: CsvRulesParser ()
assignmentseparatorp = do assignmentseparatorp = do
pdbg 3 "trying assignmentseparatorp" lift $ pdbg 3 "trying assignmentseparatorp"
choice [ choice [
-- try (many spacenonewline >> oneOf ":="), -- try (lift (many spacenonewline) >> oneOf ":="),
try (many spacenonewline >> char ':'), try (void $ lift (many spacenonewline) >> char ':'),
space space
] ]
_ <- many spacenonewline _ <- lift (many spacenonewline)
return () return ()
fieldvalp :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char] fieldvalp :: CsvRulesParser String
fieldvalp = do fieldvalp = do
pdbg 2 "trying fieldval" lift $ pdbg 2 "trying fieldvalp"
anyChar `manyTill` eolof anyChar `manyTill` lift eolof
conditionalblockp :: Stream [Char] m t => ParsecT [Char] CsvRules m ConditionalBlock conditionalblockp :: CsvRulesParser ConditionalBlock
conditionalblockp = do conditionalblockp = do
pdbg 3 "trying conditionalblockp" lift $ pdbg 3 "trying conditionalblockp"
string "if" >> many spacenonewline >> optional newline string "if" >> lift (many spacenonewline) >> optional newline
ms <- many1 recordmatcherp ms <- some recordmatcherp
as <- many (many1 spacenonewline >> fieldassignmentp) as <- many (lift (some spacenonewline) >> fieldassignmentp)
when (null as) $ when (null as) $
fail "start of conditional block found, but no assignment rules afterward\n(assignment rules in a conditional block should be indented)\n" fail "start of conditional block found, but no assignment rules afterward\n(assignment rules in a conditional block should be indented)\n"
return (ms, as) return (ms, as)
<?> "conditional block" <?> "conditional block"
recordmatcherp :: Stream [Char] m t => ParsecT [Char] CsvRules m [[Char]] recordmatcherp :: CsvRulesParser [String]
recordmatcherp = do recordmatcherp = do
pdbg 2 "trying recordmatcherp" lift $ pdbg 2 "trying recordmatcherp"
-- pos <- currentPos -- pos <- currentPos
_ <- optional (matchoperatorp >> many spacenonewline >> optional newline) _ <- optional (matchoperatorp >> lift (many spacenonewline) >> optional newline)
ps <- patternsp ps <- patternsp
when (null ps) $ when (null ps) $
fail "start of record matcher found, but no patterns afterward\n(patterns should not be indented)\n" fail "start of record matcher found, but no patterns afterward\n(patterns should not be indented)\n"
return ps return ps
<?> "record matcher" <?> "record matcher"
matchoperatorp :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char] matchoperatorp :: CsvRulesParser String
matchoperatorp = choice' $ map string matchoperatorp = choiceInState $ map string
["~" ["~"
-- ,"!~" -- ,"!~"
-- ,"=" -- ,"="
-- ,"!=" -- ,"!="
] ]
patternsp :: Stream [Char] m t => ParsecT [Char] CsvRules m [[Char]] patternsp :: CsvRulesParser [String]
patternsp = do patternsp = do
pdbg 3 "trying patternsp" lift $ pdbg 3 "trying patternsp"
ps <- many regexp ps <- many regexp
return ps return ps
regexp :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char] regexp :: CsvRulesParser String
regexp = do regexp = do
pdbg 3 "trying regexp" lift $ pdbg 3 "trying regexp"
notFollowedBy matchoperatorp notFollowedBy matchoperatorp
c <- nonspace c <- lift nonspace
cs <- anyChar `manyTill` eolof cs <- anyChar `manyTill` lift eolof
return $ strip $ c:cs return $ strip $ c:cs
-- fieldmatcher = do -- fieldmatcher = do
-- pdbg 2 "trying fieldmatcher" -- pdbg 2 "trying fieldmatcher"
-- f <- fromMaybe "all" `fmap` (optionMaybe $ do -- f <- fromMaybe "all" `fmap` (optional $ do
-- f' <- fieldname -- f' <- fieldname
-- many spacenonewline -- lift (many spacenonewline)
-- return f') -- return f')
-- char '~' -- char '~'
-- many spacenonewline -- lift (many spacenonewline)
-- ps <- patterns -- ps <- patterns
-- let r = "(" ++ intercalate "|" ps ++ ")" -- let r = "(" ++ intercalate "|" ps ++ ")"
-- return (f,r) -- return (f,r)
@ -607,7 +620,9 @@ transactionFromCsvRecord sourcepos rules record = t
status = status =
case mfieldtemplate "status" of case mfieldtemplate "status" of
Nothing -> Uncleared Nothing -> Uncleared
Just str -> either statuserror id $ runParser (statusp <* eof) mempty "" $ T.pack $ render str Just str -> either statuserror id .
runParser (statusp <* eof) "" .
T.pack $ render str
where where
statuserror err = error' $ unlines statuserror err = error' $ unlines
["error: could not parse \""++str++"\" as a cleared status (should be *, ! or empty)" ["error: could not parse \""++str++"\" as a cleared status (should be *, ! or empty)"
@ -619,7 +634,7 @@ transactionFromCsvRecord sourcepos rules record = t
precomment = maybe "" render $ mfieldtemplate "precomment" precomment = maybe "" render $ mfieldtemplate "precomment"
currency = maybe (fromMaybe "" mdefaultcurrency) render $ mfieldtemplate "currency" currency = maybe (fromMaybe "" mdefaultcurrency) render $ mfieldtemplate "currency"
amountstr = (currency++) $ negateIfParenthesised $ getAmountStr rules record amountstr = (currency++) $ negateIfParenthesised $ getAmountStr rules record
amount = either amounterror (Mixed . (:[])) $ runParser (amountp <* eof) mempty "" $ T.pack amountstr amount = either amounterror (Mixed . (:[])) $ runParser (evalStateT (amountp <* eof) mempty) "" $ T.pack amountstr
amounterror err = error' $ unlines amounterror err = error' $ unlines
["error: could not parse \""++amountstr++"\" as an amount" ["error: could not parse \""++amountstr++"\" as an amount"
,showRecord record ,showRecord record
@ -786,10 +801,10 @@ test_parser = [
-- ([("A",Nothing)], "a") -- ([("A",Nothing)], "a")
,"convert rules parsing: trailing comments" ~: do ,"convert rules parsing: trailing comments" ~: do
assertParse (parseWithState rules rulesp "skip\n# \n#\n") assertParse (parseWithState' rules rulesp "skip\n# \n#\n")
,"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")
-- not supported -- not supported
-- ,"convert rules parsing: no final newline" ~: do -- ,"convert rules parsing: no final newline" ~: do

View File

@ -40,8 +40,6 @@ module Hledger.Read.JournalReader (
-- * Parsing utils -- * Parsing utils
genericSourcePos, genericSourcePos,
parseAndFinaliseJournal, parseAndFinaliseJournal,
runStringParser,
rsp,
runJournalParser, runJournalParser,
rjp, rjp,
runErroringJournalParser, runErroringJournalParser,
@ -78,7 +76,8 @@ import Prelude ()
import Prelude.Compat hiding (readFile) import Prelude.Compat hiding (readFile)
import qualified Control.Exception as C import qualified Control.Exception as C
import Control.Monad import Control.Monad
import Control.Monad.Except (ExceptT(..), liftIO, runExceptT, throwError) import Control.Monad.Except (ExceptT(..), runExceptT, throwError)
import Control.Monad.State.Strict
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.Monoid import Data.Monoid
import Data.Text (Text) import Data.Text (Text)
@ -89,9 +88,9 @@ import Safe
import Test.HUnit import Test.HUnit
#ifdef TESTS #ifdef TESTS
import Test.Framework import Test.Framework
import Text.Parsec.Error import Text.Megaparsec.Error
#endif #endif
import Text.Parsec hiding (parse) import Text.Megaparsec hiding (parse)
import Text.Printf import Text.Printf
import System.FilePath import System.FilePath
@ -137,7 +136,7 @@ journalp :: ErroringJournalParser ParsedJournal
journalp = do journalp = do
many addJournalItemP many addJournalItemP
eof eof
getState get
-- | A side-effecting parser; parses any kind of journal item -- | A side-effecting parser; parses any kind of journal item
-- and updates the parse state accordingly. -- and updates the parse state accordingly.
@ -147,10 +146,10 @@ addJournalItemP =
-- character, can use choice without backtracking -- character, can use choice without backtracking
choice [ choice [
directivep directivep
, transactionp >>= modifyState . addTransaction , transactionp >>= modify' . addTransaction
, modifiertransactionp >>= modifyState . addModifierTransaction , modifiertransactionp >>= modify' . addModifierTransaction
, periodictransactionp >>= modifyState . addPeriodicTransaction , periodictransactionp >>= modify' . addPeriodicTransaction
, marketpricedirectivep >>= modifyState . addMarketPrice , marketpricedirectivep >>= modify' . addMarketPrice
, void emptyorcommentlinep , void emptyorcommentlinep
, void multilinecommentp , void multilinecommentp
] <?> "transaction or directive" ] <?> "transaction or directive"
@ -163,7 +162,7 @@ addJournalItemP =
directivep :: ErroringJournalParser () directivep :: ErroringJournalParser ()
directivep = (do directivep = (do
optional $ char '!' optional $ char '!'
choice' [ choiceInState [
includedirectivep includedirectivep
,aliasdirectivep ,aliasdirectivep
,endaliasesdirectivep ,endaliasesdirectivep
@ -183,24 +182,27 @@ directivep = (do
includedirectivep :: ErroringJournalParser () includedirectivep :: ErroringJournalParser ()
includedirectivep = do includedirectivep = do
string "include" string "include"
many1 spacenonewline lift (some spacenonewline)
filename <- restofline filename <- lift restofline
parentpos <- getPosition parentpos <- getPosition
parentj <- getState parentj <- get
let childj = newJournalWithParseStateFrom parentj let childj = newJournalWithParseStateFrom parentj
(ej :: Either String ParsedJournal) <- (ej :: Either String ParsedJournal) <-
liftIO $ runExceptT $ do liftIO $ runExceptT $ do
let curdir = takeDirectory (sourceName parentpos) let curdir = takeDirectory (sourceName parentpos)
filepath <- expandPath curdir filename `orRethrowIOError` (show parentpos ++ " locating " ++ filename) filepath <- expandPath curdir filename `orRethrowIOError` (show parentpos ++ " locating " ++ filename)
txt <- readFileAnyLineEnding filepath `orRethrowIOError` (show parentpos ++ " reading " ++ filepath) txt <- readFileAnyLineEnding filepath `orRethrowIOError` (show parentpos ++ " reading " ++ filepath)
(ej1::Either ParseError ParsedJournal) <- (ej1::Either (ParseError Char Dec) ParsedJournal) <-
runParserT runParserT
(choice' [journalp (evalStateT
,timeclockfilep (choiceInState
,timedotfilep [journalp
-- can't include a csv file yet, that reader is special ,timeclockfilep
]) ,timedotfilep
childj filepath txt -- can't include a csv file yet, that reader is special
])
childj)
filepath txt
either either
(throwError (throwError
. ((show parentpos ++ " in included file " ++ show filename ++ ":\n") ++) . ((show parentpos ++ " in included file " ++ show filename ++ ":\n") ++)
@ -209,7 +211,7 @@ includedirectivep = do
ej1 ej1
case ej of case ej of
Left e -> throwError e Left e -> throwError e
Right childj -> modifyState (\parentj -> childj <> parentj) Right childj -> modify' (\parentj -> childj <> parentj)
-- discard child's parse info, prepend its (reversed) list data, combine other fields -- discard child's parse info, prepend its (reversed) list data, combine other fields
newJournalWithParseStateFrom :: Journal -> Journal newJournalWithParseStateFrom :: Journal -> Journal
@ -233,13 +235,13 @@ orRethrowIOError io msg =
accountdirectivep :: ErroringJournalParser () accountdirectivep :: ErroringJournalParser ()
accountdirectivep = do accountdirectivep = do
string "account" string "account"
many1 spacenonewline lift (some spacenonewline)
acct <- accountnamep acct <- lift accountnamep
newline newline
_ <- many indentedlinep _ <- many indentedlinep
modifyState (\j -> j{jaccounts = acct : jaccounts j}) modify' (\j -> j{jaccounts = acct : jaccounts j})
indentedlinep = many1 spacenonewline >> (rstrip <$> restofline) indentedlinep = lift (some spacenonewline) >> (rstrip <$> lift restofline)
-- | Parse a one-line or multi-line commodity directive. -- | Parse a one-line or multi-line commodity directive.
-- --
@ -257,12 +259,12 @@ commoditydirectivep = try commoditydirectiveonelinep <|> commoditydirectivemulti
commoditydirectiveonelinep :: ErroringJournalParser () commoditydirectiveonelinep :: ErroringJournalParser ()
commoditydirectiveonelinep = do commoditydirectiveonelinep = do
string "commodity" string "commodity"
many1 spacenonewline lift (some spacenonewline)
Amount{acommodity,astyle} <- amountp Amount{acommodity,astyle} <- amountp
many spacenonewline lift (many spacenonewline)
_ <- followingcommentp <|> (eolof >> return "") _ <- followingcommentp <|> (lift eolof >> return "")
let comm = Commodity{csymbol=acommodity, cformat=Just astyle} let comm = Commodity{csymbol=acommodity, cformat=Just astyle}
modifyState (\j -> j{jcommodities=M.insert acommodity comm $ jcommodities j}) modify' (\j -> j{jcommodities=M.insert acommodity comm $ jcommodities j})
-- | Parse a multi-line commodity directive, containing 0 or more format subdirectives. -- | Parse a multi-line commodity directive, containing 0 or more format subdirectives.
-- --
@ -270,24 +272,24 @@ commoditydirectiveonelinep = do
commoditydirectivemultilinep :: ErroringJournalParser () commoditydirectivemultilinep :: ErroringJournalParser ()
commoditydirectivemultilinep = do commoditydirectivemultilinep = do
string "commodity" string "commodity"
many1 spacenonewline lift (some spacenonewline)
sym <- commoditysymbolp sym <- lift commoditysymbolp
_ <- followingcommentp <|> (eolof >> return "") _ <- followingcommentp <|> (lift eolof >> return "")
mformat <- lastMay <$> many (indented $ formatdirectivep sym) mformat <- lastMay <$> many (indented $ formatdirectivep sym)
let comm = Commodity{csymbol=sym, cformat=mformat} let comm = Commodity{csymbol=sym, cformat=mformat}
modifyState (\j -> j{jcommodities=M.insert sym comm $ jcommodities j}) modify' (\j -> j{jcommodities=M.insert sym comm $ jcommodities j})
where where
indented = (many1 spacenonewline >>) indented = (lift (some spacenonewline) >>)
-- | Parse a format (sub)directive, throwing a parse error if its -- | Parse a format (sub)directive, throwing a parse error if its
-- symbol does not match the one given. -- symbol does not match the one given.
formatdirectivep :: CommoditySymbol -> ErroringJournalParser AmountStyle formatdirectivep :: CommoditySymbol -> ErroringJournalParser AmountStyle
formatdirectivep expectedsym = do formatdirectivep expectedsym = do
string "format" string "format"
many1 spacenonewline lift (some spacenonewline)
pos <- getPosition pos <- getPosition
Amount{acommodity,astyle} <- amountp Amount{acommodity,astyle} <- amountp
_ <- followingcommentp <|> (eolof >> return "") _ <- followingcommentp <|> (lift eolof >> return "")
if acommodity==expectedsym if acommodity==expectedsym
then return astyle then return astyle
else parserErrorAt pos $ else parserErrorAt pos $
@ -295,41 +297,41 @@ formatdirectivep expectedsym = do
applyaccountdirectivep :: ErroringJournalParser () applyaccountdirectivep :: ErroringJournalParser ()
applyaccountdirectivep = do applyaccountdirectivep = do
string "apply" >> many1 spacenonewline >> string "account" string "apply" >> lift (some spacenonewline) >> string "account"
many1 spacenonewline lift (some spacenonewline)
parent <- accountnamep parent <- lift accountnamep
newline newline
pushParentAccount parent pushParentAccount parent
endapplyaccountdirectivep :: ErroringJournalParser () endapplyaccountdirectivep :: ErroringJournalParser ()
endapplyaccountdirectivep = do endapplyaccountdirectivep = do
string "end" >> many1 spacenonewline >> string "apply" >> many1 spacenonewline >> string "account" string "end" >> lift (some spacenonewline) >> string "apply" >> lift (some spacenonewline) >> string "account"
popParentAccount popParentAccount
aliasdirectivep :: ErroringJournalParser () aliasdirectivep :: ErroringJournalParser ()
aliasdirectivep = do aliasdirectivep = do
string "alias" string "alias"
many1 spacenonewline lift (some spacenonewline)
alias <- accountaliasp alias <- lift accountaliasp
addAccountAlias alias addAccountAlias alias
accountaliasp :: Monad m => TextParser u m AccountAlias accountaliasp :: TextParser m AccountAlias
accountaliasp = regexaliasp <|> basicaliasp accountaliasp = regexaliasp <|> basicaliasp
basicaliasp :: Monad m => TextParser u m AccountAlias basicaliasp :: TextParser m AccountAlias
basicaliasp = do basicaliasp = do
-- pdbg 0 "basicaliasp" -- pdbg 0 "basicaliasp"
old <- rstrip <$> many1 (noneOf "=") old <- rstrip <$> (some $ noneOf ("=" :: [Char]))
char '=' char '='
many spacenonewline many spacenonewline
new <- rstrip <$> anyChar `manyTill` eolof -- don't require a final newline, good for cli options new <- rstrip <$> anyChar `manyTill` eolof -- don't require a final newline, good for cli options
return $ BasicAlias (T.pack old) (T.pack new) return $ BasicAlias (T.pack old) (T.pack new)
regexaliasp :: Monad m => TextParser u m AccountAlias regexaliasp :: TextParser m AccountAlias
regexaliasp = do regexaliasp = do
-- pdbg 0 "regexaliasp" -- pdbg 0 "regexaliasp"
char '/' char '/'
re <- many1 $ noneOf "/\n\r" -- paranoid: don't try to read past line end re <- some $ noneOf ("/\n\r" :: [Char]) -- paranoid: don't try to read past line end
char '/' char '/'
many spacenonewline many spacenonewline
char '=' char '='
@ -345,22 +347,22 @@ endaliasesdirectivep = do
tagdirectivep :: ErroringJournalParser () tagdirectivep :: ErroringJournalParser ()
tagdirectivep = do tagdirectivep = do
string "tag" <?> "tag directive" string "tag" <?> "tag directive"
many1 spacenonewline lift (some spacenonewline)
_ <- many1 nonspace _ <- lift $ some nonspace
restofline lift restofline
return () return ()
endtagdirectivep :: ErroringJournalParser () endtagdirectivep :: ErroringJournalParser ()
endtagdirectivep = do endtagdirectivep = do
(string "end tag" <|> string "pop") <?> "end tag or pop directive" (string "end tag" <|> string "pop") <?> "end tag or pop directive"
restofline lift restofline
return () return ()
defaultyeardirectivep :: ErroringJournalParser () defaultyeardirectivep :: ErroringJournalParser ()
defaultyeardirectivep = do defaultyeardirectivep = do
char 'Y' <?> "default year" char 'Y' <?> "default year"
many spacenonewline lift (many spacenonewline)
y <- many1 digit y <- some digitChar
let y' = read y let y' = read y
failIfInvalidYear y failIfInvalidYear y
setYear y' setYear y'
@ -368,41 +370,41 @@ defaultyeardirectivep = do
defaultcommoditydirectivep :: ErroringJournalParser () defaultcommoditydirectivep :: ErroringJournalParser ()
defaultcommoditydirectivep = do defaultcommoditydirectivep = do
char 'D' <?> "default commodity" char 'D' <?> "default commodity"
many1 spacenonewline lift (some spacenonewline)
Amount{..} <- amountp Amount{..} <- amountp
restofline lift restofline
setDefaultCommodityAndStyle (acommodity, astyle) setDefaultCommodityAndStyle (acommodity, astyle)
marketpricedirectivep :: ErroringJournalParser MarketPrice marketpricedirectivep :: ErroringJournalParser MarketPrice
marketpricedirectivep = do marketpricedirectivep = do
char 'P' <?> "market price" char 'P' <?> "market price"
many spacenonewline lift (many spacenonewline)
date <- try (do {LocalTime d _ <- datetimep; return d}) <|> datep -- a time is ignored date <- try (do {LocalTime d _ <- datetimep; return d}) <|> datep -- a time is ignored
many1 spacenonewline lift (some spacenonewline)
symbol <- commoditysymbolp symbol <- lift commoditysymbolp
many spacenonewline lift (many spacenonewline)
price <- amountp price <- amountp
restofline lift restofline
return $ MarketPrice date symbol price return $ MarketPrice date symbol price
ignoredpricecommoditydirectivep :: ErroringJournalParser () ignoredpricecommoditydirectivep :: ErroringJournalParser ()
ignoredpricecommoditydirectivep = do ignoredpricecommoditydirectivep = do
char 'N' <?> "ignored-price commodity" char 'N' <?> "ignored-price commodity"
many1 spacenonewline lift (some spacenonewline)
commoditysymbolp lift commoditysymbolp
restofline lift restofline
return () return ()
commodityconversiondirectivep :: ErroringJournalParser () commodityconversiondirectivep :: ErroringJournalParser ()
commodityconversiondirectivep = do commodityconversiondirectivep = do
char 'C' <?> "commodity conversion" char 'C' <?> "commodity conversion"
many1 spacenonewline lift (some spacenonewline)
amountp amountp
many spacenonewline lift (many spacenonewline)
char '=' char '='
many spacenonewline lift (many spacenonewline)
amountp amountp
restofline lift restofline
return () return ()
--- ** transactions --- ** transactions
@ -410,16 +412,16 @@ commodityconversiondirectivep = do
modifiertransactionp :: ErroringJournalParser ModifierTransaction modifiertransactionp :: ErroringJournalParser ModifierTransaction
modifiertransactionp = do modifiertransactionp = do
char '=' <?> "modifier transaction" char '=' <?> "modifier transaction"
many spacenonewline lift (many spacenonewline)
valueexpr <- T.pack <$> restofline valueexpr <- T.pack <$> lift restofline
postings <- postingsp Nothing postings <- postingsp Nothing
return $ ModifierTransaction valueexpr postings return $ ModifierTransaction valueexpr postings
periodictransactionp :: ErroringJournalParser PeriodicTransaction periodictransactionp :: ErroringJournalParser PeriodicTransaction
periodictransactionp = do periodictransactionp = do
char '~' <?> "periodic transaction" char '~' <?> "periodic transaction"
many spacenonewline lift (many spacenonewline)
periodexpr <- T.pack <$> restofline periodexpr <- T.pack <$> lift restofline
postings <- postingsp Nothing postings <- postingsp Nothing
return $ PeriodicTransaction periodexpr postings return $ PeriodicTransaction periodexpr postings
@ -429,10 +431,10 @@ transactionp = do
-- ptrace "transactionp" -- ptrace "transactionp"
sourcepos <- genericSourcePos <$> getPosition sourcepos <- genericSourcePos <$> getPosition
date <- datep <?> "transaction" date <- datep <?> "transaction"
edate <- optionMaybe (secondarydatep date) <?> "secondary date" edate <- optional (secondarydatep date) <?> "secondary date"
lookAhead (spacenonewline <|> newline) <?> "whitespace or newline" lookAhead (lift spacenonewline <|> newline) <?> "whitespace or newline"
status <- statusp <?> "cleared status" status <- lift statusp <?> "cleared status"
code <- T.pack <$> codep <?> "transaction code" code <- T.pack <$> lift codep <?> "transaction code"
description <- T.pack . strip <$> descriptionp description <- T.pack . strip <$> descriptionp
comment <- try followingcommentp <|> (newline >> return "") comment <- try followingcommentp <|> (newline >> return "")
let tags = commentTags comment let tags = commentTags comment
@ -542,23 +544,23 @@ postingsp mdate = many (try $ postingp mdate) <?> "postings"
-- linebeginningwithspaces :: Monad m => JournalParser m String -- linebeginningwithspaces :: Monad m => JournalParser m String
-- linebeginningwithspaces = do -- linebeginningwithspaces = do
-- sp <- many1 spacenonewline -- sp <- lift (some spacenonewline)
-- c <- nonspace -- c <- nonspace
-- cs <- restofline -- cs <- lift restofline
-- return $ sp ++ (c:cs) ++ "\n" -- return $ sp ++ (c:cs) ++ "\n"
postingp :: Maybe Day -> ErroringJournalParser Posting postingp :: Maybe Day -> ErroringJournalParser Posting
postingp mtdate = do postingp mtdate = do
-- pdbg 0 "postingp" -- pdbg 0 "postingp"
many1 spacenonewline lift (some spacenonewline)
status <- statusp status <- lift statusp
many spacenonewline lift (many spacenonewline)
account <- modifiedaccountnamep account <- modifiedaccountnamep
let (ptype, account') = (accountNamePostingType account, textUnbracket account) let (ptype, account') = (accountNamePostingType account, textUnbracket account)
amount <- spaceandamountormissingp amount <- spaceandamountormissingp
massertion <- partialbalanceassertionp massertion <- partialbalanceassertionp
_ <- fixedlotpricep _ <- fixedlotpricep
many spacenonewline lift (many spacenonewline)
(comment,tags,mdate,mdate2) <- (comment,tags,mdate,mdate2) <-
try (followingcommentandtagsp mtdate) <|> (newline >> return ("",[],Nothing,Nothing)) try (followingcommentandtagsp mtdate) <|> (newline >> return ("",[],Nothing,Nothing))
return posting return posting

View File

@ -51,22 +51,22 @@ module Hledger.Read.TimeclockReader (
tests_Hledger_Read_TimeclockReader tests_Hledger_Read_TimeclockReader
) )
where where
import Prelude () import Prelude ()
import Prelude.Compat import Prelude.Compat
import Control.Monad import Control.Monad
import Control.Monad.IO.Class (liftIO) import Control.Monad.Except (ExceptT)
import Control.Monad.Except (ExceptT) import Control.Monad.State.Strict
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Test.HUnit import Test.HUnit
import Text.Parsec hiding (parse) import Text.Megaparsec hiding (parse)
import System.FilePath import System.FilePath
import Hledger.Data import Hledger.Data
-- XXX too much reuse ? -- XXX too much reuse ?
import Hledger.Read.Common import Hledger.Read.Common
import Hledger.Utils import Hledger.Utils
reader :: Reader reader :: Reader
@ -90,7 +90,7 @@ parse _ = parseAndFinaliseJournal timeclockfilep
timeclockfilep :: ErroringJournalParser ParsedJournal timeclockfilep :: ErroringJournalParser ParsedJournal
timeclockfilep = do many timeclockitemp timeclockfilep = do many timeclockitemp
eof eof
j@Journal{jtxns=ts, jparsetimeclockentries=es} <- getState j@Journal{jtxns=ts, jparsetimeclockentries=es} <- get
-- Convert timeclock entries in this journal to transactions, closing any unfinished sessions. -- Convert timeclock entries in this journal to transactions, closing any unfinished sessions.
-- Doing this here rather than in journalFinalise means timeclock sessions can't span file boundaries, -- Doing this here rather than in journalFinalise means timeclock sessions can't span file boundaries,
-- but it simplifies code above. -- but it simplifies code above.
@ -103,18 +103,18 @@ timeclockfilep = do many timeclockitemp
-- comment-only) lines, can use choice w/o try -- comment-only) lines, can use choice w/o try
timeclockitemp = choice [ timeclockitemp = choice [
void emptyorcommentlinep void emptyorcommentlinep
, timeclockentryp >>= \e -> modifyState (\j -> j{jparsetimeclockentries = e : jparsetimeclockentries j}) , timeclockentryp >>= \e -> modify' (\j -> j{jparsetimeclockentries = e : jparsetimeclockentries j})
] <?> "timeclock entry, or default year or historical price directive" ] <?> "timeclock entry, or default year or historical price directive"
-- | Parse a timeclock entry. -- | Parse a timeclock entry.
timeclockentryp :: ErroringJournalParser TimeclockEntry timeclockentryp :: ErroringJournalParser TimeclockEntry
timeclockentryp = do timeclockentryp = do
sourcepos <- genericSourcePos <$> getPosition sourcepos <- genericSourcePos <$> lift getPosition
code <- oneOf "bhioO" code <- oneOf ("bhioO" :: [Char])
many1 spacenonewline lift (some spacenonewline)
datetime <- datetimep datetime <- datetimep
account <- fromMaybe "" <$> optionMaybe (many1 spacenonewline >> modifiedaccountnamep) account <- fromMaybe "" <$> optional (lift (some spacenonewline) >> modifiedaccountnamep)
description <- T.pack . fromMaybe "" <$> optionMaybe (many1 spacenonewline >> restofline) description <- T.pack . fromMaybe "" <$> lift (optional (some spacenonewline >> restofline))
return $ TimeclockEntry sourcepos (read [code]) datetime account description return $ TimeclockEntry sourcepos (read [code]) datetime account description
tests_Hledger_Read_TimeclockReader = TestList [ tests_Hledger_Read_TimeclockReader = TestList [

View File

@ -36,13 +36,14 @@ import Prelude ()
import Prelude.Compat import Prelude.Compat
import Control.Monad import Control.Monad
import Control.Monad.Except (ExceptT) import Control.Monad.Except (ExceptT)
import Control.Monad.State.Strict
import Data.Char (isSpace) import Data.Char (isSpace)
import Data.List (foldl') import Data.List (foldl')
import Data.Maybe import Data.Maybe
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Test.HUnit import Test.HUnit
import Text.Parsec hiding (parse) import Text.Megaparsec hiding (parse)
import System.FilePath import System.FilePath
import Hledger.Data import Hledger.Data
@ -73,13 +74,14 @@ parse _ = parseAndFinaliseJournal timedotfilep
timedotfilep :: ErroringJournalParser ParsedJournal timedotfilep :: ErroringJournalParser ParsedJournal
timedotfilep = do many timedotfileitemp timedotfilep = do many timedotfileitemp
eof eof
getState get
where where
timedotfileitemp :: ErroringJournalParser ()
timedotfileitemp = do timedotfileitemp = do
ptrace "timedotfileitemp" ptrace "timedotfileitemp"
choice [ choice [
void emptyorcommentlinep void emptyorcommentlinep
,timedotdayp >>= \ts -> modifyState (addTransactions ts) ,timedotdayp >>= \ts -> modify' (addTransactions ts)
] <?> "timedot day entry, or default year or comment line or blank line" ] <?> "timedot day entry, or default year or comment line or blank line"
addTransactions :: [Transaction] -> Journal -> Journal addTransactions :: [Transaction] -> Journal -> Journal
@ -95,7 +97,7 @@ addTransactions ts j = foldl' (flip ($)) j (map addTransaction ts)
timedotdayp :: ErroringJournalParser [Transaction] timedotdayp :: ErroringJournalParser [Transaction]
timedotdayp = do timedotdayp = do
ptrace " timedotdayp" ptrace " timedotdayp"
d <- datep <* eolof d <- datep <* lift eolof
es <- catMaybes <$> many (const Nothing <$> try emptyorcommentlinep <|> es <- catMaybes <$> many (const Nothing <$> try emptyorcommentlinep <|>
Just <$> (notFollowedBy datep >> timedotentryp)) Just <$> (notFollowedBy datep >> timedotentryp))
return $ map (\t -> t{tdate=d}) es -- <$> many timedotentryp return $ map (\t -> t{tdate=d}) es -- <$> many timedotentryp
@ -108,9 +110,9 @@ timedotentryp :: ErroringJournalParser Transaction
timedotentryp = do timedotentryp = do
ptrace " timedotentryp" ptrace " timedotentryp"
pos <- genericSourcePos <$> getPosition pos <- genericSourcePos <$> getPosition
many spacenonewline lift (many spacenonewline)
a <- modifiedaccountnamep a <- modifiedaccountnamep
many spacenonewline lift (many spacenonewline)
hours <- hours <-
try (followingcommentp >> return 0) try (followingcommentp >> return 0)
<|> (timedotdurationp <* <|> (timedotdurationp <*
@ -137,10 +139,10 @@ timedotdurationp = try timedotnumberp <|> timedotdotsp
-- @ -- @
timedotnumberp :: ErroringJournalParser Quantity timedotnumberp :: ErroringJournalParser Quantity
timedotnumberp = do timedotnumberp = do
(q, _, _, _) <- numberp (q, _, _, _) <- lift numberp
many spacenonewline lift (many spacenonewline)
optional $ char 'h' optional $ char 'h'
many spacenonewline lift (many spacenonewline)
return q return q
-- | Parse a quantity written as a line of dots, each representing 0.25. -- | Parse a quantity written as a line of dots, each representing 0.25.
@ -149,7 +151,7 @@ timedotnumberp = do
-- @ -- @
timedotdotsp :: ErroringJournalParser Quantity timedotdotsp :: ErroringJournalParser Quantity
timedotdotsp = do timedotdotsp = do
dots <- filter (not.isSpace) <$> many (oneOf ". ") dots <- filter (not.isSpace) <$> many (oneOf (". " :: [Char]))
return $ (/4) $ fromIntegral $ length dots return $ (/4) $ fromIntegral $ length dots
tests_Hledger_Read_TimedotReader = TestList [ tests_Hledger_Read_TimedotReader = TestList [

View File

@ -34,6 +34,7 @@ import Data.Data (Data)
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
import Data.Functor.Compat ((<$>)) import Data.Functor.Compat ((<$>))
#endif #endif
import qualified Data.Text as T
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Data.Time.Calendar import Data.Time.Calendar
import System.Console.CmdArgs.Default -- some additional default stuff import System.Console.CmdArgs.Default -- some additional default stuff
@ -194,7 +195,7 @@ maybesmartdateopt d name rawopts =
Just s -> either Just s -> either
(\e -> optserror $ "could not parse "++name++" date: "++show e) (\e -> optserror $ "could not parse "++name++" date: "++show e)
Just Just
$ fixSmartDateStrEither' d s $ fixSmartDateStrEither' d (T.pack s)
type DisplayExp = String type DisplayExp = String
@ -203,7 +204,7 @@ maybedisplayopt d rawopts =
maybe Nothing (Just . regexReplaceBy "\\[.+?\\]" fixbracketeddatestr) $ maybestringopt "display" rawopts maybe Nothing (Just . regexReplaceBy "\\[.+?\\]" fixbracketeddatestr) $ maybestringopt "display" rawopts
where where
fixbracketeddatestr "" = "" fixbracketeddatestr "" = ""
fixbracketeddatestr s = "[" ++ fixSmartDateStr d (init $ tail s) ++ "]" fixbracketeddatestr s = "[" ++ fixSmartDateStr d (T.pack $ init $ tail s) ++ "]"
maybeperiodopt :: Day -> RawOpts -> Maybe (Interval,DateSpan) maybeperiodopt :: Day -> RawOpts -> Maybe (Interval,DateSpan)
maybeperiodopt d rawopts = maybeperiodopt d rawopts =
@ -212,7 +213,7 @@ maybeperiodopt d rawopts =
Just s -> either Just s -> either
(\e -> optserror $ "could not parse period option: "++show e) (\e -> optserror $ "could not parse period option: "++show e)
Just Just
$ parsePeriodExpr d s $ parsePeriodExpr d (T.pack s)
-- | Legacy-compatible convenience aliases for accountlistmode_. -- | Legacy-compatible convenience aliases for accountlistmode_.
tree_ :: ReportOpts -> Bool tree_ :: ReportOpts -> Bool
@ -283,7 +284,7 @@ queryFromOpts d opts@ReportOpts{..} = simplifyQuery $ And $ [flagsq, argsq]
++ (if empty_ then [Empty True] else []) -- ? ++ (if empty_ then [Empty True] else []) -- ?
++ (maybe [] ((:[]) . Status) (clearedValueFromOpts opts)) ++ (maybe [] ((:[]) . Status) (clearedValueFromOpts opts))
++ (maybe [] ((:[]) . Depth) depth_) ++ (maybe [] ((:[]) . Depth) depth_)
argsq = fst $ parseQuery d query_ argsq = fst $ parseQuery d (T.pack query_)
-- | Convert report options to a query, ignoring any non-flag command line arguments. -- | Convert report options to a query, ignoring any non-flag command line arguments.
queryFromOptsOnly :: Day -> ReportOpts -> Query queryFromOptsOnly :: Day -> ReportOpts -> Query
@ -317,7 +318,7 @@ queryOptsFromOpts :: Day -> ReportOpts -> [QueryOpt]
queryOptsFromOpts d ReportOpts{..} = flagsqopts ++ argsqopts queryOptsFromOpts d ReportOpts{..} = flagsqopts ++ argsqopts
where where
flagsqopts = [] flagsqopts = []
argsqopts = snd $ parseQuery d query_ argsqopts = snd $ parseQuery d (T.pack query_)
tests_queryOptsFromOpts :: [Test] tests_queryOptsFromOpts :: [Test]
tests_queryOptsFromOpts = [ tests_queryOptsFromOpts = [

View File

@ -137,11 +137,11 @@ firstJust ms = case dropWhile (==Nothing) ms of
(md:_) -> md (md:_) -> md
-- | Read a file in universal newline mode, handling any of the usual line ending conventions. -- | Read a file in universal newline mode, handling any of the usual line ending conventions.
readFile' :: FilePath -> IO String readFile' :: FilePath -> IO Text
readFile' name = do readFile' name = do
h <- openFile name ReadMode h <- openFile name ReadMode
hSetNewlineMode h universalNewlineMode hSetNewlineMode h universalNewlineMode
hGetContents h T.hGetContents h
-- | Read a file in universal newline mode, handling any of the usual line ending conventions. -- | Read a file in universal newline mode, handling any of the usual line ending conventions.
readFileAnyLineEnding :: FilePath -> IO Text readFileAnyLineEnding :: FilePath -> IO Text

View File

@ -1,4 +1,4 @@
{-# LANGUAGE CPP, FlexibleContexts #-} {-# LANGUAGE CPP, FlexibleContexts, TypeFamilies #-}
-- | Debugging helpers -- | Debugging helpers
-- more: -- more:
@ -16,19 +16,21 @@ module Hledger.Utils.Debug (
) )
where where
import Control.Monad (when) import Control.Monad (when)
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Data.List import Data.List hiding (uncons)
import Debug.Trace import qualified Data.Text as T
import Safe (readDef) import Debug.Trace
import System.Environment (getArgs) import Hledger.Utils.Parse
import System.Exit import Safe (readDef)
import System.IO.Unsafe (unsafePerformIO) import System.Environment (getArgs)
import Text.Parsec import System.Exit
import Text.Printf import System.IO.Unsafe (unsafePerformIO)
import Text.Megaparsec
import Text.Printf
#if __GLASGOW_HASKELL__ >= 704 #if __GLASGOW_HASKELL__ >= 704
import Text.Show.Pretty (ppShow) import Text.Show.Pretty (ppShow)
#else #else
-- the required pretty-show version requires GHC >= 7.4 -- the required pretty-show version requires GHC >= 7.4
ppShow :: Show a => a -> String ppShow :: Show a => a -> String
@ -58,12 +60,12 @@ traceWith f e = trace (f e) e
-- | Parsec trace - show the current parsec position and next input, -- | Parsec trace - show the current parsec position and next input,
-- and the provided label if it's non-null. -- and the provided label if it's non-null.
ptrace :: Stream [Char] m t => String -> ParsecT [Char] st m () ptrace :: String -> TextParser m ()
ptrace msg = do ptrace msg = do
pos <- getPosition pos <- getPosition
next <- take peeklength `fmap` getInput next <- (T.take peeklength) `fmap` getInput
let (l,c) = (sourceLine pos, sourceColumn pos) let (l,c) = (sourceLine pos, sourceColumn pos)
s = printf "at line %2d col %2d: %s" l c (show next) :: String s = printf "at line %2d col %2d: %s" (unPos l) (unPos c) (show next) :: String
s' = printf ("%-"++show (peeklength+30)++"s") s ++ " " ++ msg s' = printf ("%-"++show (peeklength+30)++"s") s ++ " " ++ msg
trace s' $ return () trace s' $ return ()
where where
@ -233,7 +235,7 @@ dbgExit msg = const (unsafePerformIO exitFailure) . dbg msg
-- input) to the console when the debug level is at or above -- input) to the console when the debug level is at or above
-- this level. Uses unsafePerformIO. -- this level. Uses unsafePerformIO.
-- pdbgAt :: GenParser m => Float -> String -> m () -- pdbgAt :: GenParser m => Float -> String -> m ()
pdbg :: Stream [Char] m t => Int -> String -> ParsecT [Char] st m () pdbg :: Int -> String -> TextParser m ()
pdbg level msg = when (level <= debugLevel) $ ptrace msg pdbg level msg = when (level <= debugLevel) $ ptrace msg

View File

@ -1,47 +1,71 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts, TypeFamilies #-}
module Hledger.Utils.Parse where module Hledger.Utils.Parse where
import Control.Monad.Except
import Data.Char import Data.Char
import Data.List import Data.List
-- import Data.Text (Text) import Data.Text (Text)
-- import qualified Data.Text as T import Text.Megaparsec hiding (State)
import Text.Parsec import Data.Functor.Identity (Identity(..))
import Text.Printf import Text.Printf
import Control.Monad.State.Strict (StateT, evalStateT)
import Hledger.Data.Types
import Hledger.Utils.UTF8IOCompat (error') import Hledger.Utils.UTF8IOCompat (error')
-- | A parser of strict text with generic user state, monad and return type.
type TextParser m a = ParsecT Dec Text m a
type JournalStateParser m a = StateT Journal (ParsecT Dec Text m) a
type JournalParser a = StateT Journal (ParsecT Dec Text Identity) a
-- | A journal parser that runs in IO and can throw an error mid-parse.
type ErroringJournalParser a = StateT Journal (ParsecT Dec Text (ExceptT String IO)) a
-- | Backtracking choice, use this when alternatives share a prefix. -- | Backtracking choice, use this when alternatives share a prefix.
-- Consumes no input if all choices fail. -- Consumes no input if all choices fail.
choice' :: Stream s m t => [ParsecT s u m a] -> ParsecT s u m a choice' :: [TextParser m a] -> TextParser m a
choice' = choice . map Text.Parsec.try choice' = choice . map Text.Megaparsec.try
parsewith :: Parsec [Char] () a -> String -> Either ParseError a -- | Backtracking choice, use this when alternatives share a prefix.
parsewith p = runParser p () "" -- Consumes no input if all choices fail.
choiceInState :: [StateT s (ParsecT Dec Text m) a] -> StateT s (ParsecT Dec Text m) a
choiceInState = choice . map Text.Megaparsec.try
parseWithState :: Stream s m t => u -> ParsecT s u m a -> s -> m (Either ParseError a) parsewith :: Parsec e Text a -> Text -> Either (ParseError Char e) a
parseWithState jps p = runParserT p jps "" parsewith p = runParser p ""
fromparse :: Either ParseError a -> a parsewithString :: Parsec e String a -> String -> Either (ParseError Char e) a
parsewithString p = runParser p ""
parseWithState :: Monad m => st -> StateT st (ParsecT Dec Text m) a -> Text -> m (Either (ParseError Char Dec) a)
parseWithState ctx p s = runParserT (evalStateT p ctx) "" s
parseWithState' :: (Stream s, ErrorComponent e) => st -> StateT st (ParsecT e s Identity) a -> s -> (Either (ParseError (Token s) e) a)
parseWithState' ctx p s = runParser (evalStateT p ctx) "" s
fromparse :: (Show t, Show e) => Either (ParseError t e) a -> a
fromparse = either parseerror id fromparse = either parseerror id
parseerror :: ParseError -> a parseerror :: (Show t, Show e) => ParseError t e -> a
parseerror e = error' $ showParseError e parseerror e = error' $ showParseError e
showParseError :: ParseError -> String showParseError :: (Show t, Show e) => ParseError t e -> String
showParseError e = "parse error at " ++ show e showParseError e = "parse error at " ++ show e
showDateParseError :: ParseError -> String showDateParseError :: (Show t, Show e) => ParseError t e -> String
showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e) showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e)
nonspace :: (Stream s m Char) => ParsecT s st m Char nonspace :: TextParser m Char
nonspace = satisfy (not . isSpace) nonspace = satisfy (not . isSpace)
spacenonewline :: (Stream s m Char) => ParsecT s st m Char spacenonewline :: (Stream s, Char ~ Token s) => ParsecT Dec s m Char
spacenonewline = satisfy (`elem` " \v\f\t") spacenonewline = satisfy (`elem` " \v\f\t")
restofline :: (Stream s m Char) => ParsecT s st m String restofline :: TextParser m String
restofline = anyChar `manyTill` newline restofline = anyChar `manyTill` newline
eolof :: (Stream s m Char) => ParsecT s st m () eolof :: TextParser m ()
eolof = (newline >> return ()) <|> eof eolof = (newline >> return ()) <|> eof

View File

@ -8,19 +8,13 @@ module Hledger.Utils.String (
stripbrackets, stripbrackets,
unbracket, unbracket,
-- quoting -- quoting
quoteIfSpaced,
quoteIfNeeded, quoteIfNeeded,
singleQuoteIfNeeded, singleQuoteIfNeeded,
-- quotechars, -- quotechars,
-- whitespacechars, -- whitespacechars,
escapeDoubleQuotes,
escapeSingleQuotes,
escapeQuotes, escapeQuotes,
words', words',
unwords', unwords',
stripquotes,
isSingleQuoted,
isDoubleQuoted,
-- * single-line layout -- * single-line layout
strip, strip,
lstrip, lstrip,
@ -54,7 +48,7 @@ module Hledger.Utils.String (
import Data.Char import Data.Char
import Data.List import Data.List
import Text.Parsec import Text.Megaparsec
import Text.Printf (printf) import Text.Printf (printf)
import Hledger.Utils.Parse import Hledger.Utils.Parse
@ -107,20 +101,11 @@ underline s = s' ++ replicate (length s) '-' ++ "\n"
| last s == '\n' = s | last s == '\n' = s
| otherwise = s ++ "\n" | otherwise = s ++ "\n"
-- | Wrap a string in double quotes, and \-prefix any embedded single
-- quotes, if it contains whitespace and is not already single- or
-- double-quoted.
quoteIfSpaced :: String -> String
quoteIfSpaced s | isSingleQuoted s || isDoubleQuoted s = s
| not $ any (`elem` s) whitespacechars = s
| otherwise = "'"++escapeSingleQuotes s++"'"
-- | Double-quote this string if it contains whitespace, single quotes -- | Double-quote this string if it contains whitespace, single quotes
-- or double-quotes, escaping the quotes as needed. -- or double-quotes, escaping the quotes as needed.
quoteIfNeeded :: String -> String quoteIfNeeded :: String -> String
quoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars) = "\"" ++ escapeDoubleQuotes s ++ "\"" quoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars) = "\"" ++ escapeDoubleQuotes s ++ "\""
| otherwise = s | otherwise = s
-- | Single-quote this string if it contains whitespace or double-quotes. -- | Single-quote this string if it contains whitespace or double-quotes.
-- No good for strings containing single quotes. -- No good for strings containing single quotes.
singleQuoteIfNeeded :: String -> String singleQuoteIfNeeded :: String -> String
@ -134,9 +119,6 @@ whitespacechars = " \t\n\r"
escapeDoubleQuotes :: String -> String escapeDoubleQuotes :: String -> String
escapeDoubleQuotes = regexReplace "\"" "\"" escapeDoubleQuotes = regexReplace "\"" "\""
escapeSingleQuotes :: String -> String
escapeSingleQuotes = regexReplace "'" "\'"
escapeQuotes :: String -> String escapeQuotes :: String -> String
escapeQuotes = regexReplace "([\"'])" "\\1" escapeQuotes = regexReplace "([\"'])" "\\1"
@ -144,9 +126,9 @@ escapeQuotes = regexReplace "([\"'])" "\\1"
-- NB correctly handles "a'b" but not "''a''". Can raise an error if parsing fails. -- NB correctly handles "a'b" but not "''a''". Can raise an error if parsing fails.
words' :: String -> [String] words' :: String -> [String]
words' "" = [] words' "" = []
words' s = map stripquotes $ fromparse $ parsewith p s words' s = map stripquotes $ fromparse $ parsewithString p s
where where
p = do ss <- (singleQuotedPattern <|> doubleQuotedPattern <|> pattern) `sepBy` many1 spacenonewline p = do ss <- (singleQuotedPattern <|> doubleQuotedPattern <|> pattern) `sepBy` some spacenonewline
-- eof -- eof
return ss return ss
pattern = many (noneOf whitespacechars) pattern = many (noneOf whitespacechars)

View File

@ -1,7 +1,7 @@
module Hledger.Utils.Test where module Hledger.Utils.Test where
import Test.HUnit import Test.HUnit
import Text.Parsec import Text.Megaparsec
-- | Get a Test's label, or the empty string. -- | Get a Test's label, or the empty string.
testName :: Test -> String testName :: Test -> String
@ -25,15 +25,16 @@ is :: (Eq a, Show a) => a -> a -> Assertion
a `is` e = assertEqual "" e a a `is` e = assertEqual "" e a
-- | Assert a parse result is successful, printing the parse error on failure. -- | Assert a parse result is successful, printing the parse error on failure.
assertParse :: (Either ParseError a) -> Assertion assertParse :: (Show t, Show e) => (Either (ParseError t e) a) -> Assertion
assertParse parse = either (assertFailure.show) (const (return ())) parse assertParse parse = either (assertFailure.show) (const (return ())) parse
-- | Assert a parse result is successful, printing the parse error on failure. -- | Assert a parse result is successful, printing the parse error on failure.
assertParseFailure :: (Either ParseError a) -> Assertion assertParseFailure :: (Either (ParseError t e) a) -> Assertion
assertParseFailure parse = either (const $ return ()) (const $ assertFailure "parse should not have succeeded") parse assertParseFailure parse = either (const $ return ()) (const $ assertFailure "parse should not have succeeded") parse
-- | Assert a parse result is some expected value, printing the parse error on failure. -- | Assert a parse result is some expected value, printing the parse error on failure.
assertParseEqual :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion assertParseEqual :: (Show a, Eq a, Show t, Show e) => (Either (ParseError t e) a) -> a -> Assertion
assertParseEqual parse expected = either (assertFailure.show) (`is` expected) parse assertParseEqual parse expected = either (assertFailure.show) (`is` expected) parse
printParseError :: (Show a) => a -> IO () printParseError :: (Show a) => a -> IO ()

View File

@ -114,6 +114,14 @@ textElideRight width t =
-- | last s == '\n' = s -- | last s == '\n' = s
-- | otherwise = s ++ "\n" -- | otherwise = s ++ "\n"
-- | Wrap a string in double quotes, and \-prefix any embedded single
-- quotes, if it contains whitespace and is not already single- or
-- double-quoted.
quoteIfSpaced :: T.Text -> T.Text
quoteIfSpaced s | isSingleQuoted s || isDoubleQuoted s = s
| not $ any (`elem` (T.unpack s)) whitespacechars = s
| otherwise = "'"<>escapeSingleQuotes s<>"'"
-- -- | Wrap a string in double quotes, and \-prefix any embedded single -- -- | Wrap a string in double quotes, and \-prefix any embedded single
-- -- quotes, if it contains whitespace and is not already single- or -- -- quotes, if it contains whitespace and is not already single- or
-- -- double-quoted. -- -- double-quoted.
@ -124,8 +132,8 @@ textElideRight width t =
-- -- | Double-quote this string if it contains whitespace, single quotes -- -- | Double-quote this string if it contains whitespace, single quotes
-- -- or double-quotes, escaping the quotes as needed. -- -- or double-quotes, escaping the quotes as needed.
-- quoteIfNeeded :: String -> String -- quoteIfNeeded :: T.Text -> T.Text
-- quoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars) = "\"" ++ escapeDoubleQuotes s ++ "\"" -- quoteIfNeeded s | any (`elem` T.unpack s) (quotechars++whitespacechars) = "\"" <> escapeDoubleQuotes s <> "\""
-- | otherwise = s -- | otherwise = s
-- -- | Single-quote this string if it contains whitespace or double-quotes. -- -- | Single-quote this string if it contains whitespace or double-quotes.
@ -134,15 +142,15 @@ textElideRight width t =
-- singleQuoteIfNeeded s | any (`elem` s) whitespacechars = "'"++s++"'" -- singleQuoteIfNeeded s | any (`elem` s) whitespacechars = "'"++s++"'"
-- | otherwise = s -- | otherwise = s
-- quotechars, whitespacechars :: [Char] quotechars, whitespacechars :: [Char]
-- quotechars = "'\"" quotechars = "'\""
-- whitespacechars = " \t\n\r" whitespacechars = " \t\n\r"
-- escapeDoubleQuotes :: String -> String escapeDoubleQuotes :: T.Text -> T.Text
-- escapeDoubleQuotes = regexReplace "\"" "\"" escapeDoubleQuotes = T.replace "\"" "\""
-- escapeSingleQuotes :: String -> String escapeSingleQuotes :: T.Text -> T.Text
-- escapeSingleQuotes = regexReplace "'" "\'" escapeSingleQuotes = T.replace "'" "\'"
-- escapeQuotes :: String -> String -- escapeQuotes :: String -> String
-- escapeQuotes = regexReplace "([\"'])" "\\1" -- escapeQuotes = regexReplace "([\"'])" "\\1"
@ -161,18 +169,20 @@ textElideRight width t =
-- doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf "\"") -- doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf "\"")
-- -- | Quote-aware version of unwords - single-quote strings which contain whitespace -- -- | Quote-aware version of unwords - single-quote strings which contain whitespace
-- unwords' :: [String] -> String -- unwords' :: [Text] -> Text
-- unwords' = unwords . map quoteIfNeeded -- unwords' = T.unwords . map quoteIfNeeded
-- -- | Strip one matching pair of single or double quotes on the ends of a string. -- | Strip one matching pair of single or double quotes on the ends of a string.
-- stripquotes :: String -> String stripquotes :: Text -> Text
-- stripquotes s = if isSingleQuoted s || isDoubleQuoted s then init $ tail s else s stripquotes s = if isSingleQuoted s || isDoubleQuoted s then T.init $ T.tail s else s
-- isSingleQuoted s@(_:_:_) = head s == '\'' && last s == '\'' isSingleQuoted :: Text -> Bool
-- isSingleQuoted _ = False isSingleQuoted s =
T.length (T.take 2 s) == 2 && T.head s == '\'' && T.last s == '\''
-- isDoubleQuoted s@(_:_:_) = head s == '"' && last s == '"' isDoubleQuoted :: Text -> Bool
-- isDoubleQuoted _ = False isDoubleQuoted s =
T.length (T.take 2 s) == 2 && T.head s == '"' && T.last s == '"'
textUnbracket :: Text -> Text textUnbracket :: Text -> Text
textUnbracket s textUnbracket s

View File

@ -4,7 +4,7 @@ module Hledger.Utils.Tree where
import Data.List (foldl') import Data.List (foldl')
import qualified Data.Map as M import qualified Data.Map as M
import Data.Tree import Data.Tree
-- import Text.Parsec -- import Text.Megaparsec
-- import Text.Printf -- import Text.Printf
import Hledger.Utils.Regex import Hledger.Utils.Regex

View File

@ -77,7 +77,7 @@ dependencies:
- mtl - mtl
- mtl-compat - mtl-compat
- old-time - old-time
- parsec >= 3 - megaparsec >= 5
- regex-tdfa - regex-tdfa
- safe >= 0.2 - safe >= 0.2
- split >= 0.1 && < 0.3 - split >= 0.1 && < 0.3

View File

@ -78,9 +78,11 @@ library
, mtl , mtl
, mtl-compat , mtl-compat
, old-time , old-time
, parsec >= 3 , megaparsec >= 5
, parsec
, regex-tdfa , regex-tdfa
, safe >= 0.2 , safe >= 0.2
, semigroups
, split >= 0.1 && < 0.3 , split >= 0.1 && < 0.3
, text >= 1.2 && < 1.3 , text >= 1.2 && < 1.3
, transformers >= 0.2 && < 0.6 , transformers >= 0.2 && < 0.6
@ -159,7 +161,7 @@ test-suite hunittests
, mtl , mtl
, mtl-compat , mtl-compat
, old-time , old-time
, parsec >= 3 , megaparsec >= 5
, regex-tdfa , regex-tdfa
, safe >= 0.2 , safe >= 0.2
, split >= 0.1 && < 0.3 , split >= 0.1 && < 0.3

View File

@ -17,7 +17,7 @@ import Control.Monad.IO.Class (liftIO)
import Data.Monoid import Data.Monoid
import Data.Time.Calendar (Day) import Data.Time.Calendar (Day)
import Graphics.Vty (Event(..),Key(..)) import Graphics.Vty (Event(..),Key(..))
import Text.Parsec import Text.Megaparsec
import Hledger.Cli hiding (progname,prognameandversion,green) import Hledger.Cli hiding (progname,prognameandversion,green)
import Hledger.UI.UIOptions import Hledger.UI.UIOptions
@ -88,7 +88,7 @@ esHandle ui@UIState{
EvKey (KChar c) [] | c `elem` ['h','?'] -> continue $ setMode Help ui EvKey (KChar c) [] | c `elem` ['h','?'] -> continue $ setMode Help ui
EvKey (KChar 'E') [] -> suspendAndResume $ void (runEditor pos f) >> uiReloadJournalIfChanged copts d j (popScreen ui) EvKey (KChar 'E') [] -> suspendAndResume $ void (runEditor pos f) >> uiReloadJournalIfChanged copts d j (popScreen ui)
where where
(pos,f) = case parsewith hledgerparseerrorpositionp esError of (pos,f) = case parsewithString hledgerparseerrorpositionp esError of
Right (f,l,c) -> (Just (l, Just c),f) Right (f,l,c) -> (Just (l, Just c),f)
Left _ -> (endPos, journalFilePath j) Left _ -> (endPos, journalFilePath j)
EvKey (KChar 'g') [] -> liftIO (uiReloadJournalIfChanged copts d j (popScreen ui)) >>= continue . uiCheckBalanceAssertions d EvKey (KChar 'g') [] -> liftIO (uiReloadJournalIfChanged copts d j (popScreen ui)) >>= continue . uiCheckBalanceAssertions d
@ -103,13 +103,14 @@ esHandle _ _ = error "event handler called with wrong screen type, should not ha
-- | Parse the file name, line and column number from a hledger parse error message, if possible. -- | Parse the file name, line and column number from a hledger parse error message, if possible.
-- Temporary, we should keep the original parse error location. XXX -- Temporary, we should keep the original parse error location. XXX
hledgerparseerrorpositionp :: ParsecT Dec String t (String, Int, Int)
hledgerparseerrorpositionp = do hledgerparseerrorpositionp = do
anyChar `manyTill` char '"' anyChar `manyTill` char '"'
f <- anyChar `manyTill` (oneOf ['"','\n']) f <- anyChar `manyTill` (oneOf ['"','\n'])
string " (line " string " (line "
l <- read <$> many1 digit l <- read <$> some digitChar
string ", column " string ", column "
c <- read <$> many1 digit c <- read <$> some digitChar
return (f, l, c) return (f, l, c)
-- Unconditionally reload the journal, regenerating the current screen -- Unconditionally reload the journal, regenerating the current screen

View File

@ -69,7 +69,7 @@ executable hledger-ui
, HUnit , HUnit
, microlens >= 0.4 && < 0.5 , microlens >= 0.4 && < 0.5
, microlens-platform >= 0.2.3.1 && < 0.4 , microlens-platform >= 0.2.3.1 && < 0.4
, parsec >= 3 , megaparsec >= 5
, process >= 1.2 , process >= 1.2
, safe >= 0.2 , safe >= 0.2
, split >= 0.1 && < 0.3 , split >= 0.1 && < 0.3

View File

@ -85,7 +85,7 @@ executables:
- HUnit - HUnit
- microlens >= 0.4 && < 0.5 - microlens >= 0.4 && < 0.5
- microlens-platform >= 0.2.3.1 && < 0.4 - microlens-platform >= 0.2.3.1 && < 0.4
- parsec >= 3 - megaparsec >= 5
- process >= 1.2 - process >= 1.2
- safe >= 0.2 - safe >= 0.2
- split >= 0.1 && < 0.3 - split >= 0.1 && < 0.3

View File

@ -215,8 +215,8 @@ nullviewdata = viewdataWithDateAndParams nulldate "" "" ""
-- | Make a ViewData using the given date and request parameters, and defaults elsewhere. -- | Make a ViewData using the given date and request parameters, and defaults elsewhere.
viewdataWithDateAndParams :: Day -> String -> String -> String -> ViewData viewdataWithDateAndParams :: Day -> String -> String -> String -> ViewData
viewdataWithDateAndParams d q a p = viewdataWithDateAndParams d q a p =
let (querymatcher,queryopts) = parseQuery d q let (querymatcher,queryopts) = parseQuery d (pack q)
(acctsmatcher,acctsopts) = parseQuery d a (acctsmatcher,acctsopts) = parseQuery d (pack a)
in VD { in VD {
opts = defwebopts opts = defwebopts
,j = nulljournal ,j = nulljournal

View File

@ -1,4 +1,4 @@
{-# LANGUAGE CPP, FlexibleContexts, OverloadedStrings, QuasiQuotes, RecordWildCards #-} {-# LANGUAGE CPP, FlexibleContexts, OverloadedStrings, QuasiQuotes, RecordWildCards, TypeFamilies #-}
-- | Add form data & handler. (The layout and js are defined in -- | Add form data & handler. (The layout and js are defined in
-- Foundation so that the add form can be in the default layout for -- Foundation so that the add form can be in the default layout for
-- all views.) -- all views.)
@ -10,13 +10,14 @@ import Import
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
import Control.Applicative import Control.Applicative
#endif #endif
import Control.Monad.State.Strict (evalStateT)
import Data.Either (lefts,rights) import Data.Either (lefts,rights)
import Data.List (sort) import Data.List (sort)
import qualified Data.List as L (head) -- qualified keeps dev & prod builds warning-free import qualified Data.List as L (head) -- qualified keeps dev & prod builds warning-free
import Data.Text (append, pack, unpack) import Data.Text (append, pack, unpack)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Calendar import Data.Time.Calendar
import Text.Parsec (digit, eof, many1, string, runParser) import Text.Megaparsec (digitChar, eof, some, string, runParser, runParserT, ParseError, Dec)
import Hledger.Utils import Hledger.Utils
import Hledger.Data hiding (num) import Hledger.Data hiding (num)
@ -55,7 +56,7 @@ postAddForm = do
validateDate :: Text -> Handler (Either FormMessage Day) validateDate :: Text -> Handler (Either FormMessage Day)
validateDate s = return $ validateDate s = return $
case fixSmartDateStrEither' today $ strip $ unpack s of case fixSmartDateStrEither' today $ T.pack $ strip $ unpack s of
Right d -> Right d Right d -> Right d
Left _ -> Left $ MsgInvalidEntry $ pack "could not parse date \"" `append` s `append` pack "\":" -- ++ show e) Left _ -> Left $ MsgInvalidEntry $ pack "could not parse date \"" `append` s `append` pack "\":" -- ++ show e)
@ -83,11 +84,11 @@ postAddForm = do
let numberedParams s = let numberedParams s =
reverse $ dropWhile (T.null . snd) $ reverse $ sort reverse $ dropWhile (T.null . snd) $ reverse $ sort
[ (n,v) | (k,v) <- params [ (n,v) | (k,v) <- params
, let en = parsewith (paramnamep s) $ T.unpack k , let en = parsewith (paramnamep s) k :: Either (ParseError Char Dec) Int
, isRight en , isRight en
, let Right n = en , let Right n = en
] ]
where paramnamep s = do {string s; n <- many1 digit; eof; return (read n :: Int)} where paramnamep s = do {string s; n <- some digitChar; eof; return (read n :: Int)}
acctparams = numberedParams "account" acctparams = numberedParams "account"
amtparams = numberedParams "amount" amtparams = numberedParams "amount"
num = length acctparams num = length acctparams
@ -95,8 +96,8 @@ postAddForm = do
| map fst acctparams == [1..num] && | map fst acctparams == [1..num] &&
map fst amtparams `elem` [[1..num], [1..num-1]] = [] map fst amtparams `elem` [[1..num], [1..num-1]] = []
| otherwise = ["the posting parameters are malformed"] | otherwise = ["the posting parameters are malformed"]
eaccts = map (runParser (accountnamep <* eof) () "" . textstrip . snd) acctparams eaccts = map (runParser (accountnamep <* eof) "" . textstrip . snd) acctparams
eamts = map (runParser (amountp <* eof) mempty "" . textstrip . snd) amtparams eamts = map (runParser (evalStateT (amountp <* eof) mempty) "" . textstrip . snd) amtparams
(accts, acctErrs) = (rights eaccts, map show $ lefts eaccts) (accts, acctErrs) = (rights eaccts, map show $ lefts eaccts)
(amts', amtErrs) = (rights eamts, map show $ lefts eamts) (amts', amtErrs) = (rights eamts, map show $ lefts eamts)
amts | length amts' == num = amts' amts | length amts' == num = amts'

View File

@ -226,10 +226,10 @@ balanceReportAsHtml _ vd@VD{..} (items',total) =
acctonlyquery = (RegisterR, [("q", T.pack $ accountOnlyQuery acct)]) acctonlyquery = (RegisterR, [("q", T.pack $ accountOnlyQuery acct)])
accountQuery :: AccountName -> String accountQuery :: AccountName -> String
accountQuery a = "inacct:" ++ quoteIfSpaced (T.unpack a) -- (accountNameToAccountRegex a) accountQuery a = "inacct:" ++ T.unpack (quoteIfSpaced a) -- (accountNameToAccountRegex a)
accountOnlyQuery :: AccountName -> String accountOnlyQuery :: AccountName -> String
accountOnlyQuery a = "inacctonly:" ++ quoteIfSpaced (T.unpack a) -- (accountNameToAccountRegex a) accountOnlyQuery a = "inacctonly:" ++ T.unpack (quoteIfSpaced a ) -- (accountNameToAccountRegex a)
accountUrl :: AppRoute -> AccountName -> (AppRoute, [(Text, Text)]) accountUrl :: AppRoute -> AccountName -> (AppRoute, [(Text, Text)])
accountUrl r a = (r, [("q", T.pack $ accountQuery a)]) accountUrl r a = (r, [("q", T.pack $ accountQuery a)])

View File

@ -101,7 +101,8 @@ library
, http-client , http-client
, HUnit , HUnit
, conduit-extra >= 1.1 , conduit-extra >= 1.1
, parsec >= 3 , megaparsec >= 5
, mtl
, safe >= 0.2 , safe >= 0.2
, shakespeare >= 2.0 , shakespeare >= 2.0
, template-haskell , template-haskell

View File

@ -12,6 +12,8 @@ import Prelude ()
import Prelude.Compat import Prelude.Compat
import Control.Exception as E import Control.Exception as E
import Control.Monad import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.State.Strict (evalState, evalStateT)
import Control.Monad.Trans (liftIO) import Control.Monad.Trans (liftIO)
import Data.Char (toUpper, toLower) import Data.Char (toUpper, toLower)
import Data.List.Compat import Data.List.Compat
@ -28,7 +30,8 @@ import System.Console.Haskeline.Completion
import System.Console.Wizard import System.Console.Wizard
import System.Console.Wizard.Haskeline import System.Console.Wizard.Haskeline
import System.IO ( stderr, hPutStr, hPutStrLn ) import System.IO ( stderr, hPutStr, hPutStrLn )
import Text.Parsec import Text.Megaparsec
import Text.Megaparsec.Text
import Text.Printf import Text.Printf
import Hledger import Hledger
@ -86,7 +89,7 @@ add opts j
showHelp showHelp
today <- getCurrentDay today <- getCurrentDay
let es = defEntryState{esOpts=opts let es = defEntryState{esOpts=opts
,esArgs=map stripquotes $ listofstringopt "args" $ rawopts_ opts ,esArgs=map (T.unpack . stripquotes . T.pack) $ listofstringopt "args" $ rawopts_ opts
,esToday=today ,esToday=today
,esDefDate=today ,esDefDate=today
,esJournal=j ,esJournal=j
@ -183,11 +186,11 @@ dateAndCodeWizard EntryState{..} = do
where where
parseSmartDateAndCode refdate s = either (const Nothing) (\(d,c) -> return (fixSmartDate refdate d, c)) edc parseSmartDateAndCode refdate s = either (const Nothing) (\(d,c) -> return (fixSmartDate refdate d, c)) edc
where where
edc = runParser (dateandcodep <* eof) mempty "" $ T.pack $ lowercase s edc = runParser (dateandcodep <* eof) "" $ T.pack $ lowercase s
dateandcodep :: Monad m => JournalParser m (SmartDate, Text) dateandcodep :: Parser (SmartDate, Text)
dateandcodep = do dateandcodep = do
d <- smartdate d <- smartdate
c <- optionMaybe codep c <- optional codep
many spacenonewline many spacenonewline
eof eof
return (d, T.pack $ fromMaybe "" c) return (d, T.pack $ fromMaybe "" c)
@ -250,7 +253,7 @@ accountWizard EntryState{..} = do
parseAccountOrDotOrNull def@(_:_) _ "" = dbg1 $ Just def -- when there's a default, "" means use that parseAccountOrDotOrNull def@(_:_) _ "" = dbg1 $ Just def -- when there's a default, "" means use that
parseAccountOrDotOrNull _ _ s = dbg1 $ fmap T.unpack $ parseAccountOrDotOrNull _ _ s = dbg1 $ fmap T.unpack $
either (const Nothing) validateAccount $ either (const Nothing) validateAccount $
runParser (accountnamep <* eof) esJournal "" (T.pack s) -- otherwise, try to parse the input as an accountname flip evalState esJournal $ runParserT (accountnamep <* eof) "" (T.pack s) -- otherwise, try to parse the input as an accountname
where where
validateAccount :: Text -> Maybe Text validateAccount :: Text -> Maybe Text
validateAccount t | no_new_accounts_ esOpts && not (t `elem` journalAccountNames esJournal) = Nothing validateAccount t | no_new_accounts_ esOpts && not (t `elem` journalAccountNames esJournal) = Nothing
@ -276,13 +279,17 @@ amountAndCommentWizard EntryState{..} = do
maybeRestartTransaction $ maybeRestartTransaction $
line $ green $ printf "Amount %d%s: " pnum (showDefault def) line $ green $ printf "Amount %d%s: " pnum (showDefault def)
where where
parseAmountAndComment = either (const Nothing) Just . runParser (amountandcommentp <* eof) nodefcommodityj "" . T.pack parseAmountAndComment s = either (const Nothing) Just $
runParser
(evalStateT (amountandcommentp <* eof) nodefcommodityj)
""
(T.pack s)
nodefcommodityj = esJournal{jparsedefaultcommodity=Nothing} nodefcommodityj = esJournal{jparsedefaultcommodity=Nothing}
amountandcommentp :: Monad m => JournalParser m (Amount, Text) amountandcommentp :: JournalParser (Amount, Text)
amountandcommentp = do amountandcommentp = do
a <- amountp a <- amountp
many spacenonewline lift (many spacenonewline)
c <- T.pack <$> fromMaybe "" `fmap` optionMaybe (char ';' >> many anyChar) c <- T.pack <$> fromMaybe "" `fmap` optional (char ';' >> many anyChar)
-- eof -- eof
return (a,c) return (a,c)
balancingamt = negate $ sum $ map pamount realps where realps = filter isReal esPostings balancingamt = negate $ sum $ map pamount realps where realps = filter isReal esPostings

View File

@ -5,7 +5,7 @@ related utilities used by hledger commands.
-} -}
{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, FlexibleContexts #-} {-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, FlexibleContexts, TypeFamilies #-}
module Hledger.Cli.CliOptions ( module Hledger.Cli.CliOptions (
@ -69,6 +69,7 @@ import Control.Monad (when)
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
import Data.Functor.Compat ((<$>)) import Data.Functor.Compat ((<$>))
#endif #endif
import Data.Functor.Identity (Identity)
import Data.List.Compat import Data.List.Compat
import Data.List.Split (splitOneOf) import Data.List.Split (splitOneOf)
import Data.Maybe import Data.Maybe
@ -86,7 +87,7 @@ import System.Environment
import System.Exit (exitSuccess) import System.Exit (exitSuccess)
import System.FilePath import System.FilePath
import Test.HUnit import Test.HUnit
import Text.Parsec import Text.Megaparsec
import Hledger import Hledger
import Hledger.Cli.DocFiles import Hledger.Cli.DocFiles
@ -334,11 +335,11 @@ rawOptsToCliOpts rawopts = checkCliOpts <$> do
return defcliopts { return defcliopts {
rawopts_ = rawopts rawopts_ = rawopts
,command_ = stringopt "command" rawopts ,command_ = stringopt "command" rawopts
,file_ = map stripquotes $ listofstringopt "file" rawopts ,file_ = map (T.unpack . stripquotes . T.pack) $ listofstringopt "file" rawopts
,rules_file_ = maybestringopt "rules-file" rawopts ,rules_file_ = maybestringopt "rules-file" rawopts
,output_file_ = maybestringopt "output-file" rawopts ,output_file_ = maybestringopt "output-file" rawopts
,output_format_ = maybestringopt "output-format" rawopts ,output_format_ = maybestringopt "output-format" rawopts
,alias_ = map stripquotes $ listofstringopt "alias" rawopts ,alias_ = map (T.unpack . stripquotes . T.pack) $ listofstringopt "alias" rawopts
,debug_ = intopt "debug" rawopts ,debug_ = intopt "debug" rawopts
,ignore_assertions_ = boolopt "ignore-assertions" rawopts ,ignore_assertions_ = boolopt "ignore-assertions" rawopts
,no_new_accounts_ = boolopt "no-new-accounts" rawopts -- add ,no_new_accounts_ = boolopt "no-new-accounts" rawopts -- add
@ -387,7 +388,7 @@ getCliOpts mode' = do
-- | Get the account name aliases from options, if any. -- | Get the account name aliases from options, if any.
aliasesFromOpts :: CliOpts -> [AccountAlias] aliasesFromOpts :: CliOpts -> [AccountAlias]
aliasesFromOpts = map (\a -> fromparse $ runParser accountaliasp () ("--alias "++quoteIfNeeded a) $ T.pack a) aliasesFromOpts = map (\a -> fromparse $ runParser accountaliasp ("--alias "++quoteIfNeeded a) $ T.pack a)
. alias_ . alias_
-- | Get the (tilde-expanded, absolute) journal file path from -- | Get the (tilde-expanded, absolute) journal file path from
@ -453,7 +454,7 @@ rulesFilePathFromOpts opts = do
widthFromOpts :: CliOpts -> Int widthFromOpts :: CliOpts -> Int
widthFromOpts CliOpts{width_=Nothing, available_width_=w} = w widthFromOpts CliOpts{width_=Nothing, available_width_=w} = w
widthFromOpts CliOpts{width_=Just s} = widthFromOpts CliOpts{width_=Just s} =
case runParser (read `fmap` many1 digit <* eof) () "(unknown)" s of case runParser (read `fmap` some digitChar <* eof :: ParsecT Dec String Identity Int) "(unknown)" s of
Left e -> optserror $ "could not parse width option: "++show e Left e -> optserror $ "could not parse width option: "++show e
Right w -> w Right w -> w
@ -471,14 +472,14 @@ widthFromOpts CliOpts{width_=Just s} =
registerWidthsFromOpts :: CliOpts -> (Int, Maybe Int) registerWidthsFromOpts :: CliOpts -> (Int, Maybe Int)
registerWidthsFromOpts CliOpts{width_=Nothing, available_width_=w} = (w, Nothing) registerWidthsFromOpts CliOpts{width_=Nothing, available_width_=w} = (w, Nothing)
registerWidthsFromOpts CliOpts{width_=Just s} = registerWidthsFromOpts CliOpts{width_=Just s} =
case runParser registerwidthp () "(unknown)" s of case runParser registerwidthp "(unknown)" s of
Left e -> optserror $ "could not parse width option: "++show e Left e -> optserror $ "could not parse width option: "++show e
Right ws -> ws Right ws -> ws
where where
registerwidthp :: Stream [Char] m t => ParsecT [Char] st m (Int, Maybe Int) registerwidthp :: (Stream s, Char ~ Token s) => ParsecT Dec s m (Int, Maybe Int)
registerwidthp = do registerwidthp = do
totalwidth <- read `fmap` many1 digit totalwidth <- read `fmap` some digitChar
descwidth <- optionMaybe (char ',' >> read `fmap` many1 digit) descwidth <- optional (char ',' >> read `fmap` some digitChar)
eof eof
return (totalwidth, descwidth) return (totalwidth, descwidth)
@ -556,12 +557,12 @@ hledgerExecutablesInPath = do
-- isExecutable f = getPermissions f >>= (return . executable) -- isExecutable f = getPermissions f >>= (return . executable)
isHledgerExeName :: String -> Bool isHledgerExeName :: String -> Bool
isHledgerExeName = isRight . parsewith hledgerexenamep isHledgerExeName = isRight . parsewith hledgerexenamep . T.pack
where where
hledgerexenamep = do hledgerexenamep = do
_ <- string progname _ <- string progname
_ <- char '-' _ <- char '-'
_ <- many1 (noneOf ".") _ <- some (noneOf ".")
optional (string "." >> choice' (map string addonExtensions)) optional (string "." >> choice' (map string addonExtensions))
eof eof

View File

@ -27,6 +27,7 @@ import Data.List
import Data.Maybe import Data.Maybe
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Time (Day) import Data.Time (Day)
import Safe (readMay) import Safe (readMay)
import System.Console.CmdArgs import System.Console.CmdArgs
@ -186,19 +187,19 @@ openBrowserOn u = trybrowsers browsers u
-- overwrite it with this new text, or give an error, but only if the text -- overwrite it with this new text, or give an error, but only if the text
-- is different from the current file contents, and return a flag -- is different from the current file contents, and return a flag
-- indicating whether we did anything. -- indicating whether we did anything.
writeFileWithBackupIfChanged :: FilePath -> String -> IO Bool writeFileWithBackupIfChanged :: FilePath -> T.Text -> IO Bool
writeFileWithBackupIfChanged f t = do writeFileWithBackupIfChanged f t = do
s <- readFile' f s <- readFile' f
if t == s then return False if t == s then return False
else backUpFile f >> writeFile f t >> return True else backUpFile f >> T.writeFile f t >> return True
-- | Back up this file with a (incrementing) numbered suffix, then -- | Back up this file with a (incrementing) numbered suffix, then
-- overwrite it with this new text, or give an error. -- overwrite it with this new text, or give an error.
writeFileWithBackup :: FilePath -> String -> IO () writeFileWithBackup :: FilePath -> String -> IO ()
writeFileWithBackup f t = backUpFile f >> writeFile f t writeFileWithBackup f t = backUpFile f >> writeFile f t
readFileStrictly :: FilePath -> IO String readFileStrictly :: FilePath -> IO T.Text
readFileStrictly f = readFile' f >>= \s -> C.evaluate (length s) >> return s readFileStrictly f = readFile' f >>= \s -> C.evaluate (T.length s) >> return s
-- | Back up this file with a (incrementing) numbered suffix, or give an error. -- | Back up this file with a (incrementing) numbered suffix, or give an error.
backUpFile :: FilePath -> IO () backUpFile :: FilePath -> IO ()

View File

@ -100,11 +100,12 @@ library
, mtl , mtl
, mtl-compat , mtl-compat
, old-time , old-time
, parsec >= 3 , megaparsec >= 5
, process , process
, regex-tdfa , regex-tdfa
, safe >= 0.2 , safe >= 0.2
, split >= 0.1 && < 0.3 , split >= 0.1 && < 0.3
, transformers
, temporary , temporary
, text >= 0.11 , text >= 0.11
, tabular >= 0.2 && < 0.3 , tabular >= 0.2 && < 0.3

View File

@ -12,5 +12,6 @@ packages:
extra-deps: extra-deps:
- brick-0.8 - brick-0.8
- megaparsec-5.0.1
# https://docs.haskellstack.org/en/stable/yaml_configuration/ # https://docs.haskellstack.org/en/stable/yaml_configuration/

View File

@ -40,5 +40,5 @@ hledger -f- print
<<< <<<
2015/9/6* 2015/9/6*
a 0 a 0
>>>2 /unexpected "*"/ >>>2 /unexpected '*'/
>>>= 1 >>>= 1

View File

@ -23,7 +23,7 @@ end comment
b 0 b 0
; date: 3.32 ; date: 3.32
>>>2 /line 10, column 19/ >>>2 /10:19/
>>>=1 >>>=1
# 3. Ledger's bracketed date syntax is also supported: `[DATE]`, # 3. Ledger's bracketed date syntax is also supported: `[DATE]`,
@ -50,5 +50,5 @@ end comment
2000/1/2 2000/1/2
b 0 ; [1/1=1/2/3/4] bad second date, should error b 0 ; [1/1=1/2/3/4] bad second date, should error
>>>2 /line 9, column 25/ >>>2 /9:25/
>>>=1 >>>=1