* 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