* 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:
		
							parent
							
								
									90c0d40777
								
							
						
					
					
						commit
						4141067428
					
				@ -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
 | 
				
			||||||
 | 
				
			|||||||
@ -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
 | 
				
			||||||
 | 
				
			|||||||
@ -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))
 | 
				
			||||||
 | 
					
 | 
				
			||||||
----------------------------------------------------------------------
 | 
					----------------------------------------------------------------------
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
				
			|||||||
@ -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
 | 
				
			||||||
 | 
				
			|||||||
@ -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]
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
				
			|||||||
@ -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
 | 
				
			||||||
 | 
				
			|||||||
@ -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
 | 
				
			||||||
 | 
				
			|||||||
@ -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 [
 | 
				
			||||||
 | 
				
			|||||||
@ -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 [
 | 
				
			||||||
 | 
				
			|||||||
@ -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 = [
 | 
				
			||||||
 | 
				
			|||||||
@ -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
 | 
				
			||||||
 | 
				
			|||||||
@ -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
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
				
			|||||||
@ -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
 | 
				
			||||||
 | 
					 | 
				
			||||||
 | 
				
			|||||||
@ -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)
 | 
				
			||||||
 | 
				
			|||||||
@ -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 ()
 | 
				
			||||||
 | 
				
			|||||||
@ -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
 | 
				
			||||||
 | 
				
			|||||||
@ -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
 | 
				
			||||||
 | 
				
			|||||||
@ -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
 | 
				
			||||||
 | 
				
			|||||||
@ -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
 | 
				
			||||||
 | 
				
			|||||||
@ -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
 | 
				
			||||||
 | 
				
			|||||||
@ -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
 | 
				
			||||||
 | 
				
			|||||||
@ -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
 | 
				
			||||||
 | 
				
			|||||||
@ -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
 | 
				
			||||||
 | 
				
			|||||||
@ -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'
 | 
				
			||||||
 | 
				
			|||||||
@ -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)])
 | 
				
			||||||
 | 
				
			|||||||
@ -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
 | 
				
			||||||
 | 
				
			|||||||
@ -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
 | 
				
			||||||
 | 
				
			|||||||
@ -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
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
				
			|||||||
@ -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 ()
 | 
				
			||||||
 | 
				
			|||||||
@ -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
 | 
				
			||||||
 | 
				
			|||||||
@ -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/
 | 
				
			||||||
 | 
				
			|||||||
@ -40,5 +40,5 @@ hledger -f- print
 | 
				
			|||||||
<<<
 | 
					<<<
 | 
				
			||||||
2015/9/6*
 | 
					2015/9/6*
 | 
				
			||||||
   a  0
 | 
					   a  0
 | 
				
			||||||
>>>2 /unexpected "*"/
 | 
					>>>2 /unexpected '*'/
 | 
				
			||||||
>>>= 1
 | 
					>>>= 1
 | 
				
			||||||
 | 
				
			|||||||
@ -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
 | 
				
			||||||
 | 
				
			|||||||
		Loading…
	
		Reference in New Issue
	
	Block a user