dev: lib, cli, bin: enable/fix name shadowing warnings
And a few other cleanups.
This commit is contained in:
		
							parent
							
								
									96db4fe9cc
								
							
						
					
					
						commit
						c80c72d7cd
					
				
							
								
								
									
										3
									
								
								Makefile
									
									
									
									
									
								
							
							
						
						
									
										3
									
								
								Makefile
									
									
									
									
									
								
							| @ -206,7 +206,6 @@ WARNINGS:=\ | |||||||
| 	-Wall \
 | 	-Wall \
 | ||||||
|   -Wno-incomplete-uni-patterns \
 |   -Wno-incomplete-uni-patterns \
 | ||||||
| 	-Wno-missing-signatures \
 | 	-Wno-missing-signatures \
 | ||||||
| 	-Wno-name-shadowing \
 |  | ||||||
| 	-Wno-orphans \
 | 	-Wno-orphans \
 | ||||||
| 	-Wno-type-defaults \
 | 	-Wno-type-defaults \
 | ||||||
| 	-Wno-unused-do-bind \
 | 	-Wno-unused-do-bind \
 | ||||||
| @ -418,7 +417,7 @@ ghci-web-test: webdirs $(call def-help,ghci-web-test, start ghci REPL on hledger | |||||||
| # better than stack exec ?
 | # better than stack exec ?
 | ||||||
| # XXX does not see changes to files
 | # XXX does not see changes to files
 | ||||||
| ghci-unit-test: $(call def-help,ghci-unit-test, start ghci REPL on hledger-lib + unit test suite) | ghci-unit-test: $(call def-help,ghci-unit-test, start ghci REPL on hledger-lib + unit test suite) | ||||||
| 	$(STACKGHCI) ghci --ghc-options='-rtsopts -Wall -Wno-incomplete-uni-patterns -Wno-missing-signatures -Wno-name-shadowing -Wno-orphans -Wno-type-defaults -Wno-unused-do-bind  -ihledger-lib  -DDEVELOPMENT -DVERSION="\"1.26.99\""' hledger-lib/test/unittest.hs | 	$(STACKGHCI) ghci --ghc-options='-rtsopts $(WARNINGS) -ihledger-lib  -DDEVELOPMENT -DVERSION="\"1.26.99\""' hledger-lib/test/unittest.hs | ||||||
| 
 | 
 | ||||||
| # ghci-all: $(call def-help,ghci-all, start ghci REPL on all the hledger)
 | # ghci-all: $(call def-help,ghci-all, start ghci REPL on all the hledger)
 | ||||||
| # 	$(STACK) exec -- $(GHCI) $(BUILDFLAGS) \
 | # 	$(STACK) exec -- $(GHCI) $(BUILDFLAGS) \
 | ||||||
|  | |||||||
| @ -3,7 +3,7 @@ | |||||||
| -- Run from inside the hledger source tree, or compile with compile.sh. | -- Run from inside the hledger source tree, or compile with compile.sh. | ||||||
| -- See hledger-check-fancyassertions.hs. | -- See hledger-check-fancyassertions.hs. | ||||||
| 
 | 
 | ||||||
| -- {-# OPTIONS_GHC -Wno-missing-signatures -Wno-name-shadowing #-} | -- {-# OPTIONS_GHC -Wno-missing-signatures #-} | ||||||
| 
 | 
 | ||||||
| {-| Construct two balance reports for two different time periods and use one of the as "budget" for | {-| Construct two balance reports for two different time periods and use one of the as "budget" for | ||||||
|     the other, thus comparing them |     the other, thus comparing them | ||||||
|  | |||||||
| @ -5,7 +5,7 @@ | |||||||
| 
 | 
 | ||||||
| {- Construct two balance reports for two different time periods and render them side by side -} | {- Construct two balance reports for two different time periods and render them side by side -} | ||||||
| 
 | 
 | ||||||
| {-# OPTIONS_GHC -Wno-missing-signatures -Wno-name-shadowing #-} | {-# OPTIONS_GHC -Wno-missing-signatures #-} | ||||||
| 
 | 
 | ||||||
| import System.Environment (getArgs) | import System.Environment (getArgs) | ||||||
| import Hledger.Cli | import Hledger.Cli | ||||||
|  | |||||||
| @ -15,7 +15,7 @@ | |||||||
| {-# LANGUAGE QuasiQuotes #-} | {-# LANGUAGE QuasiQuotes #-} | ||||||
| {-# LANGUAGE OverloadedStrings #-} | {-# LANGUAGE OverloadedStrings #-} | ||||||
| {-# LANGUAGE NamedFieldPuns #-} | {-# LANGUAGE NamedFieldPuns #-} | ||||||
| {-# OPTIONS_GHC -Wall -Wno-missing-signatures -Wno-name-shadowing #-} | {-# OPTIONS_GHC -Wall -Wno-missing-signatures #-} | ||||||
| 
 | 
 | ||||||
| import Data.List | import Data.List | ||||||
| import Data.Maybe | import Data.Maybe | ||||||
|  | |||||||
| @ -3,7 +3,7 @@ | |||||||
| -- Run from inside the hledger source tree, or compile with compile.sh. | -- Run from inside the hledger source tree, or compile with compile.sh. | ||||||
| -- See hledger-check-fancyassertions.hs. | -- See hledger-check-fancyassertions.hs. | ||||||
| 
 | 
 | ||||||
| {-# OPTIONS_GHC -Wno-missing-signatures -Wno-name-shadowing #-} | {-# OPTIONS_GHC -Wno-missing-signatures #-} | ||||||
| {-# LANGUAGE NamedFieldPuns #-} | {-# LANGUAGE NamedFieldPuns #-} | ||||||
| {-# LANGUAGE QuasiQuotes #-} | {-# LANGUAGE QuasiQuotes #-} | ||||||
| {-# LANGUAGE RecordWildCards #-} | {-# LANGUAGE RecordWildCards #-} | ||||||
|  | |||||||
| @ -104,10 +104,10 @@ accountTree :: AccountName -> [AccountName] -> Account | |||||||
| accountTree rootname as = nullacct{aname=rootname, asubs=map (uncurry accountTree') $ M.assocs m } | accountTree rootname as = nullacct{aname=rootname, asubs=map (uncurry accountTree') $ M.assocs m } | ||||||
|   where |   where | ||||||
|     T m = treeFromPaths $ map expandAccountName as :: FastTree AccountName |     T m = treeFromPaths $ map expandAccountName as :: FastTree AccountName | ||||||
|     accountTree' a (T m) = |     accountTree' a (T m') = | ||||||
|       nullacct{ |       nullacct{ | ||||||
|         aname=a |         aname=a | ||||||
|        ,asubs=map (uncurry accountTree') $ M.assocs m |        ,asubs=map (uncurry accountTree') $ M.assocs m' | ||||||
|        } |        } | ||||||
| 
 | 
 | ||||||
| -- | An efficient-to-build tree suggested by Cale Gibbard, probably | -- | An efficient-to-build tree suggested by Cale Gibbard, probably | ||||||
| @ -223,7 +223,7 @@ pruneAccounts p = headMay . prune | |||||||
| -- tree's structure remains intact and can still be used. It's a tree/list! | -- tree's structure remains intact and can still be used. It's a tree/list! | ||||||
| flattenAccounts :: Account -> [Account] | flattenAccounts :: Account -> [Account] | ||||||
| flattenAccounts a = squish a [] | flattenAccounts a = squish a [] | ||||||
|   where squish a as = a : Prelude.foldr squish as (asubs a) |   where squish a' as = a' : Prelude.foldr squish as (asubs a') | ||||||
| 
 | 
 | ||||||
| -- | Filter an account tree (to a list). | -- | Filter an account tree (to a list). | ||||||
| filterAccounts :: (Account -> Bool) -> Account -> [Account] | filterAccounts :: (Account -> Bool) -> Account -> [Account] | ||||||
|  | |||||||
| @ -177,12 +177,12 @@ concatAccountNames as = accountNameWithPostingType t $ T.intercalate ":" $ map a | |||||||
| -- Or, return any error arising from a bad regular expression in the aliases. | -- Or, return any error arising from a bad regular expression in the aliases. | ||||||
| accountNameApplyAliases :: [AccountAlias] -> AccountName -> Either RegexError AccountName | accountNameApplyAliases :: [AccountAlias] -> AccountName -> Either RegexError AccountName | ||||||
| accountNameApplyAliases aliases a = | accountNameApplyAliases aliases a = | ||||||
|   let (aname,atype) = (accountNameWithoutPostingType a, accountNamePostingType a) |   let (name,typ) = (accountNameWithoutPostingType a, accountNamePostingType a) | ||||||
|   in foldM |   in foldM | ||||||
|      (\acct alias -> dbg6 "result" $ aliasReplace (dbg6 "alias" alias) (dbg6 "account" acct)) |      (\acct alias -> dbg6 "result" $ aliasReplace (dbg6 "alias" alias) (dbg6 "account" acct)) | ||||||
|      aname |      name | ||||||
|      aliases |      aliases | ||||||
|      >>= Right . accountNameWithPostingType atype |      >>= Right . accountNameWithPostingType typ | ||||||
| 
 | 
 | ||||||
| -- | Memoising version of accountNameApplyAliases, maybe overkill. | -- | Memoising version of accountNameApplyAliases, maybe overkill. | ||||||
| accountNameApplyAliasesMemo :: [AccountAlias] -> AccountName -> Either RegexError AccountName | accountNameApplyAliasesMemo :: [AccountAlias] -> AccountName -> Either RegexError AccountName | ||||||
| @ -238,7 +238,7 @@ parentAccountNames :: AccountName -> [AccountName] | |||||||
| parentAccountNames a = parentAccountNames' $ parentAccountName a | parentAccountNames a = parentAccountNames' $ parentAccountName a | ||||||
|     where |     where | ||||||
|       parentAccountNames' "" = [] |       parentAccountNames' "" = [] | ||||||
|       parentAccountNames' a = a : parentAccountNames' (parentAccountName a) |       parentAccountNames' a2 = a2 : parentAccountNames' (parentAccountName a2) | ||||||
| 
 | 
 | ||||||
| -- | Is the first account a parent or other ancestor of (and not the same as) the second ? | -- | Is the first account a parent or other ancestor of (and not the same as) the second ? | ||||||
| isAccountNamePrefixOf :: AccountName -> AccountName -> Bool | isAccountNamePrefixOf :: AccountName -> AccountName -> Bool | ||||||
| @ -296,9 +296,9 @@ elideAccountName width s | |||||||
|     fitText Nothing (Just width) True False $ accountNameFromComponents $ elideparts width [] $ accountNameComponents s |     fitText Nothing (Just width) True False $ accountNameFromComponents $ elideparts width [] $ accountNameComponents s | ||||||
|       where |       where | ||||||
|         elideparts :: Int -> [Text] -> [Text] -> [Text] |         elideparts :: Int -> [Text] -> [Text] -> [Text] | ||||||
|         elideparts width done ss |         elideparts w done ss | ||||||
|           | realLength (accountNameFromComponents $ done++ss) <= width = done++ss |           | realLength (accountNameFromComponents $ done++ss) <= w = done++ss | ||||||
|           | length ss > 1 = elideparts width (done++[textTakeWidth 2 $ head ss]) (tail ss) |           | length ss > 1 = elideparts w (done++[textTakeWidth 2 $ head ss]) (tail ss) | ||||||
|           | otherwise = done++ss |           | otherwise = done++ss | ||||||
| 
 | 
 | ||||||
| -- | Keep only the first n components of an account name, where n | -- | Keep only the first n components of an account name, where n | ||||||
|  | |||||||
| @ -255,6 +255,7 @@ instance Num Amount where | |||||||
|     (-)                          = similarAmountsOp (-) |     (-)                          = similarAmountsOp (-) | ||||||
|     (*)                          = similarAmountsOp (*) |     (*)                          = similarAmountsOp (*) | ||||||
| 
 | 
 | ||||||
|  | -- TODO: amount, num are clashy | ||||||
| -- | The empty simple amount. | -- | The empty simple amount. | ||||||
| amount, nullamt :: Amount | amount, nullamt :: Amount | ||||||
| amount = Amount{acommodity="", aquantity=0, aprice=Nothing, astyle=amountstyle} | amount = Amount{acommodity="", aquantity=0, aprice=Nothing, astyle=amountstyle} | ||||||
| @ -314,8 +315,8 @@ amountCost a@Amount{aquantity=q, aprice=mp} = | |||||||
| transformAmount :: (Quantity -> Quantity) -> Amount -> Amount | transformAmount :: (Quantity -> Quantity) -> Amount -> Amount | ||||||
| transformAmount f a@Amount{aquantity=q,aprice=p} = a{aquantity=f q, aprice=f' <$> p} | transformAmount f a@Amount{aquantity=q,aprice=p} = a{aquantity=f q, aprice=f' <$> p} | ||||||
|   where |   where | ||||||
|     f' (TotalPrice a@Amount{aquantity=pq}) = TotalPrice a{aquantity = f pq} |     f' (TotalPrice a1@Amount{aquantity=pq}) = TotalPrice a1{aquantity = f pq} | ||||||
|     f' p = p |     f' p' = p' | ||||||
| 
 | 
 | ||||||
| -- | Divide an amount's quantity (and its total price, if it has one) by a constant. | -- | Divide an amount's quantity (and its total price, if it has one) by a constant. | ||||||
| divideAmount :: Quantity -> Amount -> Amount | divideAmount :: Quantity -> Amount -> Amount | ||||||
| @ -522,15 +523,15 @@ showamountquantity amt@Amount{astyle=AmountStyle{asdecimalpoint=mdec, asdigitgro | |||||||
| applyDigitGroupStyle :: Maybe DigitGroupStyle -> Int -> T.Text -> WideBuilder | applyDigitGroupStyle :: Maybe DigitGroupStyle -> Int -> T.Text -> WideBuilder | ||||||
| applyDigitGroupStyle Nothing                       l s = WideBuilder (TB.fromText s) l | applyDigitGroupStyle Nothing                       l s = WideBuilder (TB.fromText s) l | ||||||
| applyDigitGroupStyle (Just (DigitGroups _ []))     l s = WideBuilder (TB.fromText s) l | applyDigitGroupStyle (Just (DigitGroups _ []))     l s = WideBuilder (TB.fromText s) l | ||||||
| applyDigitGroupStyle (Just (DigitGroups c (g:gs))) l s = addseps (g:|gs) (toInteger l) s | applyDigitGroupStyle (Just (DigitGroups c (g0:gs0))) l0 s0 = addseps (g0:|gs0) (toInteger l0) s0 | ||||||
|   where |   where | ||||||
|     addseps (g:|gs) l s |     addseps (g1:|gs1) l1 s1 | ||||||
|         | l' > 0    = addseps gs' l' rest <> WideBuilder (TB.singleton c <> TB.fromText part) (fromIntegral g + 1) |         | l2 > 0    = addseps gs2 l2 rest <> WideBuilder (TB.singleton c <> TB.fromText part) (fromIntegral g1 + 1) | ||||||
|         | otherwise = WideBuilder (TB.fromText s) (fromInteger l) |         | otherwise = WideBuilder (TB.fromText s1) (fromInteger l1) | ||||||
|       where |       where | ||||||
|         (rest, part) = T.splitAt (fromInteger l') s |         (rest, part) = T.splitAt (fromInteger l2) s1 | ||||||
|         gs' = fromMaybe (g:|[]) $ nonEmpty gs |         gs2 = fromMaybe (g1:|[]) $ nonEmpty gs1 | ||||||
|         l' = l - toInteger g |         l2 = l1 - toInteger g1 | ||||||
| 
 | 
 | ||||||
| -- like journalCanonicaliseAmounts | -- like journalCanonicaliseAmounts | ||||||
| -- | Canonicalise an amount's display style using the provided commodity style map. | -- | Canonicalise an amount's display style using the provided commodity style map. | ||||||
| @ -702,10 +703,10 @@ maCommodities = S.fromList . fmap acommodity . amounts' | |||||||
| unifyMixedAmount :: MixedAmount -> Maybe Amount | unifyMixedAmount :: MixedAmount -> Maybe Amount | ||||||
| unifyMixedAmount = foldM combine 0 . amounts | unifyMixedAmount = foldM combine 0 . amounts | ||||||
|   where |   where | ||||||
|     combine amount result |     combine amt result | ||||||
|       | amountIsZero amount                    = Just result |       | amountIsZero amt                    = Just result | ||||||
|       | amountIsZero result                    = Just amount |       | amountIsZero result                 = Just amt | ||||||
|       | acommodity amount == acommodity result = Just $ amount + result |       | acommodity amt == acommodity result = Just $ amt + result | ||||||
|       | otherwise                           = Nothing |       | otherwise                           = Nothing | ||||||
| 
 | 
 | ||||||
| -- | Sum same-commodity amounts in a lossy way, applying the first | -- | Sum same-commodity amounts in a lossy way, applying the first | ||||||
| @ -839,10 +840,10 @@ showMixedAmountDebug m | m == missingmixedamt = "(missing)" | |||||||
| showMixedAmountB :: AmountDisplayOpts -> MixedAmount -> WideBuilder | showMixedAmountB :: AmountDisplayOpts -> MixedAmount -> WideBuilder | ||||||
| showMixedAmountB opts ma | showMixedAmountB opts ma | ||||||
|     | displayOneLine opts = showMixedAmountOneLineB opts ma |     | displayOneLine opts = showMixedAmountOneLineB opts ma | ||||||
|     | otherwise           = WideBuilder (wbBuilder . mconcat $ intersperse sep lines) width |     | otherwise           = WideBuilder (wbBuilder . mconcat $ intersperse sep ls) width | ||||||
|   where |   where | ||||||
|     lines = showMixedAmountLinesB opts ma |     ls = showMixedAmountLinesB opts ma | ||||||
|     width = headDef 0 $ map wbWidth lines |     width = headDef 0 $ map wbWidth ls | ||||||
|     sep = WideBuilder (TB.singleton '\n') 0 |     sep = WideBuilder (TB.singleton '\n') 0 | ||||||
| 
 | 
 | ||||||
| -- | Helper for showMixedAmountB to show a list of Amounts on multiple lines. This returns | -- | Helper for showMixedAmountB to show a list of Amounts on multiple lines. This returns | ||||||
| @ -900,7 +901,7 @@ showMixedAmountOneLineB opts@AmountDisplayOpts{displayMaxWidth=mmax,displayMinWi | |||||||
|     dropWhileRev p = foldr (\x xs -> if null xs && p x then [] else x:xs) [] |     dropWhileRev p = foldr (\x xs -> if null xs && p x then [] else x:xs) [] | ||||||
| 
 | 
 | ||||||
|     -- Add the elision strings (if any) to each amount |     -- Add the elision strings (if any) to each amount | ||||||
|     withElided = zipWith (\num amt -> (amt, elisionDisplay Nothing (wbWidth sep) num amt)) [n-1,n-2..0] |     withElided = zipWith (\n2 amt -> (amt, elisionDisplay Nothing (wbWidth sep) n2 amt)) [n-1,n-2..0] | ||||||
| 
 | 
 | ||||||
| orderedAmounts :: AmountDisplayOpts -> MixedAmount -> [Amount] | orderedAmounts :: AmountDisplayOpts -> MixedAmount -> [Amount] | ||||||
| orderedAmounts dopts = maybe id (mapM pad) (displayOrder dopts) . amounts | orderedAmounts dopts = maybe id (mapM pad) (displayOrder dopts) . amounts | ||||||
|  | |||||||
| @ -315,11 +315,11 @@ priceInferrerFor t pt = maybe id inferprice inferFromAndTo | |||||||
|     -- For each posting, if the posting type matches, there is only a single amount in the posting, |     -- For each posting, if the posting type matches, there is only a single amount in the posting, | ||||||
|     -- and the commodity of the amount matches the amount we're converting from, |     -- and the commodity of the amount matches the amount we're converting from, | ||||||
|     -- then set its price based on the ratio between fromamount and toamount. |     -- then set its price based on the ratio between fromamount and toamount. | ||||||
|     inferprice (fromamount, toamount) posting |     inferprice (fromamount, toamount) p | ||||||
|         | [a] <- amounts (pamount posting), ptype posting == pt, acommodity a == acommodity fromamount |         | [a] <- amounts (pamount p), ptype p == pt, acommodity a == acommodity fromamount | ||||||
|             = posting{ pamount   = mixedAmount a{aprice=Just conversionprice} |             = p{ pamount   = mixedAmount a{aprice=Just conversionprice} | ||||||
|                      , poriginal = Just $ originalPosting posting } |                      , poriginal = Just $ originalPosting p } | ||||||
|         | otherwise = posting |         | otherwise = p | ||||||
|       where |       where | ||||||
|         -- If only one Amount in the posting list matches fromamount we can use TotalPrice. |         -- If only one Amount in the posting list matches fromamount we can use TotalPrice. | ||||||
|         -- Otherwise divide the conversion equally among the Amounts by using a unit price. |         -- Otherwise divide the conversion equally among the Amounts by using a unit price. | ||||||
|  | |||||||
| @ -2,7 +2,6 @@ | |||||||
| {-# LANGUAGE NoMonoLocalBinds    #-} | {-# LANGUAGE NoMonoLocalBinds    #-} | ||||||
| {-# LANGUAGE OverloadedStrings   #-} | {-# LANGUAGE OverloadedStrings   #-} | ||||||
| {-# LANGUAGE ScopedTypeVariables #-} | {-# LANGUAGE ScopedTypeVariables #-} | ||||||
| {-# LANGUAGE TupleSections       #-} |  | ||||||
| {-# LANGUAGE TypeFamilies        #-} | {-# LANGUAGE TypeFamilies        #-} | ||||||
| {-| | {-| | ||||||
| 
 | 
 | ||||||
| @ -348,9 +347,9 @@ latestSpanContaining :: [DateSpan] -> Day -> Maybe DateSpan | |||||||
| latestSpanContaining datespans = go | latestSpanContaining datespans = go | ||||||
|   where |   where | ||||||
|     go day = do |     go day = do | ||||||
|         span <- Set.lookupLT supSpan spanSet |         spn <- Set.lookupLT supSpan spanSet | ||||||
|         guard $ spanContainsDate span day |         guard $ spanContainsDate spn day | ||||||
|         return span |         return spn | ||||||
|       where |       where | ||||||
|         -- The smallest DateSpan larger than any DateSpan containing day. |         -- The smallest DateSpan larger than any DateSpan containing day. | ||||||
|         supSpan = DateSpan (Just $ addDays 1 day) Nothing |         supSpan = DateSpan (Just $ addDays 1 day) Nothing | ||||||
| @ -387,18 +386,19 @@ spanFromSmartDate :: Day -> SmartDate -> DateSpan | |||||||
| spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e) | spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e) | ||||||
|     where |     where | ||||||
|       (ry,rm,_) = toGregorian refdate |       (ry,rm,_) = toGregorian refdate | ||||||
|       (b,e) = span sdate |       (b,e) = span' sdate | ||||||
|       span :: SmartDate -> (Day,Day) |         where | ||||||
|       span (SmartCompleteDate day)       = (day, nextday day) |           span' :: SmartDate -> (Day,Day) | ||||||
|       span (SmartAssumeStart y Nothing)  = (startofyear day, nextyear day) where day = fromGregorian y 1 1 |           span' (SmartCompleteDate day)       = (day, nextday day) | ||||||
|       span (SmartAssumeStart y (Just m)) = (startofmonth day, nextmonth day) where day = fromGregorian y m 1 |           span' (SmartAssumeStart y Nothing)  = (startofyear day, nextyear day) where day = fromGregorian y 1 1 | ||||||
|       span (SmartFromReference m d)      = (day, nextday day) where day = fromGregorian ry (fromMaybe rm m) d |           span' (SmartAssumeStart y (Just m)) = (startofmonth day, nextmonth day) where day = fromGregorian y m 1 | ||||||
|       span (SmartMonth m)                = (startofmonth day, nextmonth day) where day = fromGregorian ry m 1 |           span' (SmartFromReference m d)      = (day, nextday day) where day = fromGregorian ry (fromMaybe rm m) d | ||||||
|       span (SmartRelative n Day)         = (addDays n refdate, addDays (n+1) refdate) |           span' (SmartMonth m)                = (startofmonth day, nextmonth day) where day = fromGregorian ry m 1 | ||||||
|       span (SmartRelative n Week)        = (addDays (7*n) d, addDays (7*n+7) d) where d = thisweek refdate |           span' (SmartRelative n Day)         = (addDays n refdate, addDays (n+1) refdate) | ||||||
|       span (SmartRelative n Month)       = (addGregorianMonthsClip n d, addGregorianMonthsClip (n+1) d) where d = thismonth refdate |           span' (SmartRelative n Week)        = (addDays (7*n) d, addDays (7*n+7) d) where d = thisweek refdate | ||||||
|       span (SmartRelative n Quarter)     = (addGregorianMonthsClip (3*n) d, addGregorianMonthsClip (3*n+3) d) where d = thisquarter refdate |           span' (SmartRelative n Month)       = (addGregorianMonthsClip n d, addGregorianMonthsClip (n+1) d) where d = thismonth refdate | ||||||
|       span (SmartRelative n Year)        = (addGregorianYearsClip n d, addGregorianYearsClip (n+1) d) where d = thisyear refdate |           span' (SmartRelative n Quarter)     = (addGregorianMonthsClip (3*n) d, addGregorianMonthsClip (3*n+3) d) where d = thisquarter refdate | ||||||
|  |           span' (SmartRelative n Year)        = (addGregorianYearsClip n d, addGregorianYearsClip (n+1) d) where d = thisyear refdate | ||||||
| 
 | 
 | ||||||
| -- showDay :: Day -> String | -- showDay :: Day -> String | ||||||
| -- showDay day = printf "%04d/%02d/%02d" y m d where (y,m,d) = toGregorian day | -- showDay day = printf "%04d/%02d/%02d" y m d where (y,m,d) = toGregorian day | ||||||
| @ -541,7 +541,7 @@ thisquarter = startofquarter | |||||||
| startofquarter day = fromGregorian y (firstmonthofquarter m) 1 | startofquarter day = fromGregorian y (firstmonthofquarter m) 1 | ||||||
|     where |     where | ||||||
|       (y,m,_) = toGregorian day |       (y,m,_) = toGregorian day | ||||||
|       firstmonthofquarter m = ((m-1) `div` 3) * 3 + 1 |       firstmonthofquarter m2 = ((m2-1) `div` 3) * 3 + 1 | ||||||
| 
 | 
 | ||||||
| thisyear = startofyear | thisyear = startofyear | ||||||
| prevyear = startofyear . addGregorianYearsClip (-1) | prevyear = startofyear . addGregorianYearsClip (-1) | ||||||
| @ -577,14 +577,14 @@ intervalStartBefore int d = | |||||||
| -- >>> nthdayofyearcontaining 1 1 wed22nd | -- >>> nthdayofyearcontaining 1 1 wed22nd | ||||||
| -- 2017-01-01 | -- 2017-01-01 | ||||||
| nthdayofyearcontaining :: Month -> MonthDay -> Day -> Day | nthdayofyearcontaining :: Month -> MonthDay -> Day -> Day | ||||||
| nthdayofyearcontaining m md date | nthdayofyearcontaining m mdy date | ||||||
|   -- PARTIAL: |   -- PARTIAL: | ||||||
|   | not (validMonth m)  = error' $ "nthdayofyearcontaining: invalid month "++show m |   | not (validMonth m)  = error' $ "nthdayofyearcontaining: invalid month "++show m | ||||||
|   | not (validDay   md) = error' $ "nthdayofyearcontaining: invalid day "  ++show md |   | not (validDay   mdy) = error' $ "nthdayofyearcontaining: invalid day "  ++show mdy | ||||||
|   | mmddOfSameYear <= date = mmddOfSameYear |   | mmddOfSameYear <= date = mmddOfSameYear | ||||||
|   | otherwise = mmddOfPrevYear |   | otherwise = mmddOfPrevYear | ||||||
|   where mmddOfSameYear = addDays (toInteger md-1) $ applyN (m-1) nextmonth s |   where mmddOfSameYear = addDays (toInteger mdy-1) $ applyN (m-1) nextmonth s | ||||||
|         mmddOfPrevYear = addDays (toInteger md-1) $ applyN (m-1) nextmonth $ prevyear s |         mmddOfPrevYear = addDays (toInteger mdy-1) $ applyN (m-1) nextmonth $ prevyear s | ||||||
|         s = startofyear date |         s = startofyear date | ||||||
| 
 | 
 | ||||||
| -- | For given date d find month-long interval that starts on nth day of month | -- | For given date d find month-long interval that starts on nth day of month | ||||||
| @ -606,13 +606,13 @@ nthdayofyearcontaining m md date | |||||||
| -- >>> nthdayofmonthcontaining 30 wed22nd | -- >>> nthdayofmonthcontaining 30 wed22nd | ||||||
| -- 2017-10-30 | -- 2017-10-30 | ||||||
| nthdayofmonthcontaining :: MonthDay -> Day -> Day | nthdayofmonthcontaining :: MonthDay -> Day -> Day | ||||||
| nthdayofmonthcontaining md date | nthdayofmonthcontaining mdy date | ||||||
|   -- PARTIAL: |   -- PARTIAL: | ||||||
|   | not (validDay md) = error' $ "nthdayofmonthcontaining: invalid day "  ++show md |   | not (validDay mdy) = error' $ "nthdayofmonthcontaining: invalid day "  ++show mdy | ||||||
|   | nthOfSameMonth <= date = nthOfSameMonth |   | nthOfSameMonth <= date = nthOfSameMonth | ||||||
|   | otherwise = nthOfPrevMonth |   | otherwise = nthOfPrevMonth | ||||||
|   where nthOfSameMonth = nthdayofmonth md s |   where nthOfSameMonth = nthdayofmonth mdy s | ||||||
|         nthOfPrevMonth = nthdayofmonth md $ prevmonth s |         nthOfPrevMonth = nthdayofmonth mdy $ prevmonth s | ||||||
|         s = startofmonth date |         s = startofmonth date | ||||||
| 
 | 
 | ||||||
| -- | For given date d find week-long interval that starts on nth day of week | -- | For given date d find week-long interval that starts on nth day of week | ||||||
| @ -807,8 +807,8 @@ yyyymmdd :: TextParser m SmartDate | |||||||
| yyyymmdd = do | yyyymmdd = do | ||||||
|   y <- read <$> count 4 digitChar |   y <- read <$> count 4 digitChar | ||||||
|   m <- read <$> count 2 digitChar |   m <- read <$> count 2 digitChar | ||||||
|   md <- optional $ read <$> count 2 digitChar |   mdy <- optional $ read <$> count 2 digitChar | ||||||
|   case md of |   case mdy of | ||||||
|       Nothing -> failIfInvalidDate $ SmartAssumeStart y (Just m) |       Nothing -> failIfInvalidDate $ SmartAssumeStart y (Just m) | ||||||
|       Just d  -> maybe (Fail.fail $ showBadDate y m d) (return . SmartCompleteDate) $ |       Just d  -> maybe (Fail.fail $ showBadDate y m d) (return . SmartCompleteDate) $ | ||||||
|                    fromGregorianValid y m d |                    fromGregorianValid y m d | ||||||
| @ -1080,19 +1080,19 @@ tests_Dates = testGroup "Dates" | |||||||
|             ] |             ] | ||||||
| 
 | 
 | ||||||
|   , testCase "match dayOfWeek" $ do |   , testCase "match dayOfWeek" $ do | ||||||
|       let dayofweek n s = splitspan (nthdayofweekcontaining n) (\w -> (if w == 0 then id else applyN (n-1) nextday . applyN (fromInteger w) nextweek)) 1 s |       let dayofweek n = splitspan (nthdayofweekcontaining n) (\w -> (if w == 0 then id else applyN (n-1) nextday . applyN (fromInteger w) nextweek)) 1 | ||||||
|           match ds day = splitSpan (DaysOfWeek [day]) ds @?= dayofweek day ds |           matchdow ds day = splitSpan (DaysOfWeek [day]) ds @?= dayofweek day ds | ||||||
|           ys2021 = fromGregorian 2021 01 01 |           ys2021 = fromGregorian 2021 01 01 | ||||||
|           ye2021 = fromGregorian 2021 12 31 |           ye2021 = fromGregorian 2021 12 31 | ||||||
|           ys2022 = fromGregorian 2022 01 01 |           ys2022 = fromGregorian 2022 01 01 | ||||||
|       mapM_ (match (DateSpan (Just ys2021) (Just ye2021))) [1..7] |       mapM_ (matchdow (DateSpan (Just ys2021) (Just ye2021))) [1..7] | ||||||
|       mapM_ (match (DateSpan (Just ys2021) (Just ys2022))) [1..7] |       mapM_ (matchdow (DateSpan (Just ys2021) (Just ys2022))) [1..7] | ||||||
|       mapM_ (match (DateSpan (Just ye2021) (Just ys2022))) [1..7] |       mapM_ (matchdow (DateSpan (Just ye2021) (Just ys2022))) [1..7] | ||||||
| 
 | 
 | ||||||
|       mapM_ (match (DateSpan (Just ye2021) Nothing)) [1..7] |       mapM_ (matchdow (DateSpan (Just ye2021) Nothing)) [1..7] | ||||||
|       mapM_ (match (DateSpan (Just ys2022) Nothing)) [1..7] |       mapM_ (matchdow (DateSpan (Just ys2022) Nothing)) [1..7] | ||||||
| 
 | 
 | ||||||
|       mapM_ (match (DateSpan Nothing (Just ye2021))) [1..7] |       mapM_ (matchdow (DateSpan Nothing (Just ye2021))) [1..7] | ||||||
|       mapM_ (match (DateSpan Nothing (Just ys2022))) [1..7] |       mapM_ (matchdow (DateSpan Nothing (Just ys2022))) [1..7] | ||||||
| 
 | 
 | ||||||
|   ] |   ] | ||||||
|  | |||||||
| @ -111,24 +111,24 @@ makePostingAccountErrorExcerpt :: Posting -> (FilePath, Int, Maybe (Int, Maybe I | |||||||
| makePostingAccountErrorExcerpt p = makePostingErrorExcerpt p finderrcols | makePostingAccountErrorExcerpt p = makePostingErrorExcerpt p finderrcols | ||||||
|   where |   where | ||||||
|     -- Calculate columns suitable for highlighting the synthetic excerpt. |     -- Calculate columns suitable for highlighting the synthetic excerpt. | ||||||
|     finderrcols p _ _ = Just (col, Just col2) |     finderrcols p' _ _ = Just (col, Just col2) | ||||||
|       where |       where | ||||||
|         col = 5 + if isVirtual p then 1 else 0 |         col = 5 + if isVirtual p' then 1 else 0 | ||||||
|         col2 = col + T.length (paccount p) - 1 |         col2 = col + T.length (paccount p') - 1 | ||||||
| 
 | 
 | ||||||
| -- | From the given posting, make an error excerpt showing the transaction with | -- | From the given posting, make an error excerpt showing the transaction with | ||||||
| -- the balance assertion highlighted. | -- the balance assertion highlighted. | ||||||
| makeBalanceAssertionErrorExcerpt :: Posting -> (FilePath, Int, Maybe (Int, Maybe Int), Text) | makeBalanceAssertionErrorExcerpt :: Posting -> (FilePath, Int, Maybe (Int, Maybe Int), Text) | ||||||
| makeBalanceAssertionErrorExcerpt p = makePostingErrorExcerpt p finderrcols | makeBalanceAssertionErrorExcerpt p = makePostingErrorExcerpt p finderrcols | ||||||
|   where |   where | ||||||
|     finderrcols p t trendered = Just (col, Just col2) |     finderrcols p' t trendered = Just (col, Just col2) | ||||||
|       where |       where | ||||||
|         -- Analyse the rendering to find the columns to highlight. |         -- Analyse the rendering to find the columns to highlight. | ||||||
|         tlines = dbg5 "tlines" $ max 1 $ length $ T.lines $ tcomment t  -- transaction comment can generate extra lines |         tlines = dbg5 "tlines" $ max 1 $ length $ T.lines $ tcomment t  -- transaction comment can generate extra lines | ||||||
|         (col, col2) = |         (col, col2) = | ||||||
|           let def = (5, maximum (map T.length $ T.lines trendered))  -- fallback: underline whole posting. Shouldn't happen. |           let def = (5, maximum (map T.length $ T.lines trendered))  -- fallback: underline whole posting. Shouldn't happen. | ||||||
|           in |           in | ||||||
|             case transactionFindPostingIndex (==p) t of |             case transactionFindPostingIndex (==p') t of | ||||||
|               Nothing  -> def |               Nothing  -> def | ||||||
|               Just idx -> fromMaybe def $ do |               Just idx -> fromMaybe def $ do | ||||||
|                 let |                 let | ||||||
| @ -136,9 +136,9 @@ makeBalanceAssertionErrorExcerpt p = makePostingErrorExcerpt p finderrcols | |||||||
|                   beforepslines = dbg5 "beforepslines" $ sum $ map (max 1 . length . T.lines . pcomment) beforeps   -- posting comment can generate extra lines (assume only one commodity shown) |                   beforepslines = dbg5 "beforepslines" $ sum $ map (max 1 . length . T.lines . pcomment) beforeps   -- posting comment can generate extra lines (assume only one commodity shown) | ||||||
|                 assertionline <- dbg5 "assertionline" $ headMay $ drop (tlines + beforepslines) $ T.lines trendered |                 assertionline <- dbg5 "assertionline" $ headMay $ drop (tlines + beforepslines) $ T.lines trendered | ||||||
|                 let |                 let | ||||||
|                   col2 = T.length assertionline |                   col2' = T.length assertionline | ||||||
|                   l = dropWhile (/= '=') $ reverse $ T.unpack assertionline |                   l = dropWhile (/= '=') $ reverse $ T.unpack assertionline | ||||||
|                   l' = dropWhile (`elem` ['=','*']) l |                   l' = dropWhile (`elem` ['=','*']) l | ||||||
|                   col = length l' + 1 |                   col' = length l' + 1 | ||||||
|                 return (col, col2) |                 return (col', col2') | ||||||
| 
 | 
 | ||||||
|  | |||||||
| @ -252,14 +252,14 @@ dbgJournalAcctDeclOrder prefix | |||||||
|   where |   where | ||||||
|     showAcctDeclsSummary :: [(AccountName,AccountDeclarationInfo)] -> String |     showAcctDeclsSummary :: [(AccountName,AccountDeclarationInfo)] -> String | ||||||
|     showAcctDeclsSummary adis |     showAcctDeclsSummary adis | ||||||
|       | length adis < (2*num+2) = "[" <> showadis adis <> "]" |       | length adis < (2*n+2) = "[" <> showadis adis <> "]" | ||||||
|       | otherwise = |       | otherwise = | ||||||
|           "[" <> showadis (take num adis) <> " ... " <> showadis (takelast num adis) <> "]" |           "[" <> showadis (take n adis) <> " ... " <> showadis (takelast n adis) <> "]" | ||||||
|       where |       where | ||||||
|         num = 3 |         n = 3 | ||||||
|         showadis = intercalate ", " . map showadi |         showadis = intercalate ", " . map showadi | ||||||
|         showadi (a,adi) = "("<>show (adideclarationorder adi)<>","<>T.unpack a<>")" |         showadi (a,adi) = "("<>show (adideclarationorder adi)<>","<>T.unpack a<>")" | ||||||
|         takelast n = reverse . take n . reverse |         takelast n' = reverse . take n' . reverse | ||||||
| 
 | 
 | ||||||
| instance Default Journal where | instance Default Journal where | ||||||
|   def = nulljournal |   def = nulljournal | ||||||
| @ -405,7 +405,7 @@ journalAccountTags Journal{jdeclaredaccounttags} a = M.findWithDefault [] a jdec | |||||||
| -- | Which tags are in effect for this account, including tags inherited from parent accounts ? | -- | Which tags are in effect for this account, including tags inherited from parent accounts ? | ||||||
| journalInheritedAccountTags :: Journal -> AccountName -> [Tag] | journalInheritedAccountTags :: Journal -> AccountName -> [Tag] | ||||||
| journalInheritedAccountTags j a = | journalInheritedAccountTags j a = | ||||||
|   foldl' (\ts a -> ts `union` journalAccountTags j a) [] as |   foldl' (\ts a' -> ts `union` journalAccountTags j a') [] as | ||||||
|   where |   where | ||||||
|     as = a : parentAccountNames a |     as = a : parentAccountNames a | ||||||
| -- PERF: cache in journal ? | -- PERF: cache in journal ? | ||||||
|  | |||||||
| @ -116,15 +116,15 @@ journalCheckCommodities j = mapM_ checkcommodities (journalPostings j) | |||||||
|         --     assets      "C $" -1 @ $ 2 |         --     assets      "C $" -1 @ $ 2 | ||||||
|         --                 ^^^^^^^^^^^^^^ |         --                 ^^^^^^^^^^^^^^ | ||||||
|         -- XXX refine this region when it's easy |         -- XXX refine this region when it's easy | ||||||
|         finderrcols p t txntxt = |         finderrcols p' t txntxt = | ||||||
|           case transactionFindPostingIndex (==p) t of |           case transactionFindPostingIndex (==p') t of | ||||||
|             Nothing     -> Nothing |             Nothing     -> Nothing | ||||||
|             Just pindex -> Just (amtstart, Just amtend) |             Just pindex -> Just (amtstart, Just amtend) | ||||||
|               where |               where | ||||||
|                 tcommentlines = max 0 (length (T.lines $ tcomment t) - 1) |                 tcommentlines = max 0 (length (T.lines $ tcomment t) - 1) | ||||||
|                 errrelline = 1 + tcommentlines + pindex   -- XXX doesn't count posting coment lines |                 errrelline = 1 + tcommentlines + pindex   -- XXX doesn't count posting coment lines | ||||||
|                 errline = fromMaybe "" (T.lines txntxt `atMay` (errrelline-1)) |                 errline = fromMaybe "" (T.lines txntxt `atMay` (errrelline-1)) | ||||||
|                 acctend = 4 + T.length (paccount p) + if isVirtual p then 2 else 0 |                 acctend = 4 + T.length (paccount p') + if isVirtual p' then 2 else 0 | ||||||
|                 amtstart = acctend + (T.length $ T.takeWhile isSpace $ T.drop acctend errline) + 1 |                 amtstart = acctend + (T.length $ T.takeWhile isSpace $ T.drop acctend errline) + 1 | ||||||
|                 amtend = amtstart + (T.length $ T.stripEnd $ T.takeWhile (/=';') $ T.drop amtstart errline) |                 amtend = amtstart + (T.length $ T.stripEnd $ T.takeWhile (/=';') $ T.drop amtstart errline) | ||||||
| 
 | 
 | ||||||
| @ -151,10 +151,10 @@ journalCheckPayees j = mapM_ checkpayee (jtxns j) | |||||||
|         -- Calculate columns suitable for highlighting the excerpt. |         -- Calculate columns suitable for highlighting the excerpt. | ||||||
|         -- We won't show these in the main error line as they aren't |         -- We won't show these in the main error line as they aren't | ||||||
|         -- accurate for the actual data. |         -- accurate for the actual data. | ||||||
|         finderrcols t = Just (col, Just col2) |         finderrcols t' = Just (col, Just col2) | ||||||
|           where |           where | ||||||
|             col  = T.length (showTransactionLineFirstPart t) + 2 |             col  = T.length (showTransactionLineFirstPart t') + 2 | ||||||
|             col2 = col + T.length (transactionPayee t) - 1 |             col2 = col + T.length (transactionPayee t') - 1 | ||||||
| 
 | 
 | ||||||
| ---------- | ---------- | ||||||
| 
 | 
 | ||||||
|  | |||||||
| @ -20,10 +20,9 @@ journalCheckOrdereddates whichdate j = do | |||||||
|     -- note, relying on txns always being sorted by file here |     -- note, relying on txns always being sorted by file here | ||||||
|     txnsbyfile = groupBy (\t1 t2 -> transactionFile t1 == transactionFile t2) $ jtxns j |     txnsbyfile = groupBy (\t1 t2 -> transactionFile t1 == transactionFile t2) $ jtxns j | ||||||
|     getdate = transactionDateOrDate2 whichdate |     getdate = transactionDateOrDate2 whichdate | ||||||
|     compare a b = getdate a <= getdate b |     compare' a b = getdate a <= getdate b | ||||||
|   either Left (const $ Right ()) $  |   (const $ Right ()) =<< (forM txnsbyfile $ \ts -> | ||||||
|    forM txnsbyfile $ \ts -> |     case checkTransactions compare' ts of | ||||||
|     case checkTransactions compare ts of |  | ||||||
|       FoldAcc{fa_previous=Nothing} -> Right () |       FoldAcc{fa_previous=Nothing} -> Right () | ||||||
|       FoldAcc{fa_error=Nothing}    -> Right () |       FoldAcc{fa_error=Nothing}    -> Right () | ||||||
|       FoldAcc{fa_error=Just t, fa_previous=Just tprev} -> Left $ printf |       FoldAcc{fa_error=Just t, fa_previous=Just tprev} -> Left $ printf | ||||||
| @ -37,7 +36,7 @@ journalCheckOrdereddates whichdate j = do | |||||||
|           -- separate the two excerpts by a space-beginning line to help flycheck-hledger parse them |           -- separate the two excerpts by a space-beginning line to help flycheck-hledger parse them | ||||||
|           ex = T.unlines [textChomp ex1, T.pack " ", textChomp ex2] |           ex = T.unlines [textChomp ex1, T.pack " ", textChomp ex2] | ||||||
|           finderrcols _t = Just (1, Just 10) |           finderrcols _t = Just (1, Just 10) | ||||||
|           datenum   = if whichdate==SecondaryDate then "2" else "" |           datenum   = if whichdate==SecondaryDate then "2" else "") | ||||||
| 
 | 
 | ||||||
| data FoldAcc a b = FoldAcc | data FoldAcc a b = FoldAcc | ||||||
|  { fa_error    :: Maybe a |  { fa_error    :: Maybe a | ||||||
| @ -46,11 +45,11 @@ data FoldAcc a b = FoldAcc | |||||||
| 
 | 
 | ||||||
| checkTransactions :: (Transaction -> Transaction -> Bool) | checkTransactions :: (Transaction -> Transaction -> Bool) | ||||||
|   -> [Transaction] -> FoldAcc Transaction Transaction |   -> [Transaction] -> FoldAcc Transaction Transaction | ||||||
| checkTransactions compare = foldWhile f FoldAcc{fa_error=Nothing, fa_previous=Nothing} | checkTransactions compare' = foldWhile f FoldAcc{fa_error=Nothing, fa_previous=Nothing} | ||||||
|   where |   where | ||||||
|     f current acc@FoldAcc{fa_previous=Nothing} = acc{fa_previous=Just current} |     f current acc@FoldAcc{fa_previous=Nothing} = acc{fa_previous=Just current} | ||||||
|     f current acc@FoldAcc{fa_previous=Just previous} = |     f current acc@FoldAcc{fa_previous=Just previous} = | ||||||
|       if compare previous current |       if compare' previous current | ||||||
|       then acc{fa_previous=Just current} |       then acc{fa_previous=Just current} | ||||||
|       else acc{fa_error=Just current} |       else acc{fa_error=Just current} | ||||||
| 
 | 
 | ||||||
| @ -58,5 +57,5 @@ foldWhile :: (a -> FoldAcc a b -> FoldAcc a b) -> FoldAcc a b -> [a] -> FoldAcc | |||||||
| foldWhile _ acc [] = acc | foldWhile _ acc [] = acc | ||||||
| foldWhile fold acc (a:as) = | foldWhile fold acc (a:as) = | ||||||
|   case fold a acc of |   case fold a acc of | ||||||
|    acc@FoldAcc{fa_error=Just _} -> acc |    acc'@FoldAcc{fa_error=Just _} -> acc' | ||||||
|    acc -> foldWhile fold acc as |    acc' -> foldWhile fold acc' as | ||||||
|  | |||||||
| @ -1,4 +1,3 @@ | |||||||
| {-# LANGUAGE NamedFieldPuns    #-} |  | ||||||
| {-# LANGUAGE OverloadedStrings #-} | {-# LANGUAGE OverloadedStrings #-} | ||||||
| 
 | 
 | ||||||
| module Hledger.Data.JournalChecks.Uniqueleafnames ( | module Hledger.Data.JournalChecks.Uniqueleafnames ( | ||||||
| @ -43,12 +42,12 @@ journalCheckUniqueleafnames j = do | |||||||
|             (f,l,_,ex2) = makePostingErrorExcerpt p2 finderrcols |             (f,l,_,ex2) = makePostingErrorExcerpt p2 finderrcols | ||||||
|             -- separate the two excerpts by a space-beginning line to help flycheck-hledger parse them |             -- separate the two excerpts by a space-beginning line to help flycheck-hledger parse them | ||||||
|             ex = T.unlines [textChomp ex1, T.pack " ...", textChomp ex2] |             ex = T.unlines [textChomp ex1, T.pack " ...", textChomp ex2] | ||||||
|             finderrcols p _ _ = Just (col, Just col2) |             finderrcols p' _ _ = Just (col, Just col2) | ||||||
|               where |               where | ||||||
|                 a = paccount p |                 a = paccount p' | ||||||
|                 alen = T.length a |                 alen = T.length a | ||||||
|                 llen = T.length $ accountLeafName a |                 llen = T.length $ accountLeafName a | ||||||
|                 col = 5 + (if isVirtual p then 1 else 0) + alen - llen |                 col = 5 + (if isVirtual p' then 1 else 0) + alen - llen | ||||||
|                 col2 = col + llen - 1 |                 col2 = col + llen - 1 | ||||||
|             accts = T.unlines fulls |             accts = T.unlines fulls | ||||||
| 
 | 
 | ||||||
|  | |||||||
| @ -59,7 +59,7 @@ periodAsDateSpan (QuarterPeriod y q) = DateSpan (Just $ fromGregorian y m 1) (Ju | |||||||
|   where |   where | ||||||
|     (y', q') | q==4      = (y+1,1) |     (y', q') | q==4      = (y+1,1) | ||||||
|              | otherwise = (y,q+1) |              | otherwise = (y,q+1) | ||||||
|     quarterAsMonth q = (q-1) * 3 + 1 |     quarterAsMonth q2 = (q2-1) * 3 + 1 | ||||||
|     m  = quarterAsMonth q |     m  = quarterAsMonth q | ||||||
|     m' = quarterAsMonth q' |     m' = quarterAsMonth q' | ||||||
| periodAsDateSpan (YearPeriod y) = DateSpan (Just $ fromGregorian y 1 1) (Just $ fromGregorian (y+1) 1 1) | periodAsDateSpan (YearPeriod y) = DateSpan (Just $ fromGregorian y 1 1) (Just $ fromGregorian (y+1) 1 1) | ||||||
|  | |||||||
| @ -41,7 +41,7 @@ _ptgen str = do | |||||||
|           nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] } |           nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] } | ||||||
|           nulldatespan |           nulldatespan | ||||||
| 
 | 
 | ||||||
| _ptgenspan str span = do | _ptgenspan str spn = do | ||||||
|   let |   let | ||||||
|     t = T.pack str |     t = T.pack str | ||||||
|     (i,s) = parsePeriodExpr' nulldate t |     (i,s) = parsePeriodExpr' nulldate t | ||||||
| @ -51,7 +51,7 @@ _ptgenspan str span = do | |||||||
|       mapM_ (T.putStr . showTransaction) $ |       mapM_ (T.putStr . showTransaction) $ | ||||||
|         runPeriodicTransaction |         runPeriodicTransaction | ||||||
|           nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] } |           nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] } | ||||||
|           span |           spn | ||||||
| 
 | 
 | ||||||
| --deriving instance Show PeriodicTransaction | --deriving instance Show PeriodicTransaction | ||||||
| -- for better pretty-printing: | -- for better pretty-printing: | ||||||
|  | |||||||
| @ -86,7 +86,7 @@ import Data.Time.Calendar (Day) | |||||||
| import Safe (maximumBound) | import Safe (maximumBound) | ||||||
| import Text.DocLayout (realLength) | import Text.DocLayout (realLength) | ||||||
| 
 | 
 | ||||||
| import Text.Tabular.AsciiWide | import Text.Tabular.AsciiWide hiding (render) | ||||||
| 
 | 
 | ||||||
| import Hledger.Utils | import Hledger.Utils | ||||||
| import Hledger.Data.Types | import Hledger.Data.Types | ||||||
| @ -427,7 +427,7 @@ postingToCost styles ToCost         p | |||||||
|     | "_conversion-matched" `elem` map fst (ptags p) && noCost = Nothing |     | "_conversion-matched" `elem` map fst (ptags p) && noCost = Nothing | ||||||
|     | otherwise = Just $ postingTransformAmount (styleMixedAmount styles . mixedAmountCost) p |     | otherwise = Just $ postingTransformAmount (styleMixedAmount styles . mixedAmountCost) p | ||||||
|   where |   where | ||||||
|     noCost = null . filter (isJust . aprice) . amountsRaw $ pamount p |     noCost = (not . any (isJust . aprice) . amountsRaw) $ pamount p | ||||||
| 
 | 
 | ||||||
| -- | Generate inferred equity postings from a 'Posting' using transaction prices. | -- | Generate inferred equity postings from a 'Posting' using transaction prices. | ||||||
| -- Make sure not to generate equity postings when there are already matched | -- Make sure not to generate equity postings when there are already matched | ||||||
|  | |||||||
| @ -4,7 +4,6 @@ | |||||||
| 
 | 
 | ||||||
| {-# LANGUAGE FlexibleContexts  #-} | {-# LANGUAGE FlexibleContexts  #-} | ||||||
| {-# LANGUAGE OverloadedStrings #-} | {-# LANGUAGE OverloadedStrings #-} | ||||||
| {-# LANGUAGE PackageImports    #-} |  | ||||||
| {-# LANGUAGE TypeFamilies      #-} | {-# LANGUAGE TypeFamilies      #-} | ||||||
| 
 | 
 | ||||||
| module Hledger.Data.StringFormat ( | module Hledger.Data.StringFormat ( | ||||||
| @ -155,7 +154,7 @@ formatStringTester fs value expected = actual @?= expected | |||||||
|   where |   where | ||||||
|     actual = case fs of |     actual = case fs of | ||||||
|       FormatLiteral l                 -> formatText False Nothing Nothing l |       FormatLiteral l                 -> formatText False Nothing Nothing l | ||||||
|       FormatField leftJustify min max _ -> formatText leftJustify min max value |       FormatField leftJustify mn mx _ -> formatText leftJustify mn mx value | ||||||
| 
 | 
 | ||||||
| tests_StringFormat = testGroup "StringFormat" [ | tests_StringFormat = testGroup "StringFormat" [ | ||||||
| 
 | 
 | ||||||
|  | |||||||
| @ -139,8 +139,8 @@ entryFromTimeclockInOut i o | |||||||
|       -- since otherwise it will often have large recurring decimal parts which (since 1.21) |       -- since otherwise it will often have large recurring decimal parts which (since 1.21) | ||||||
|       -- print would display all 255 digits of. timeclock amounts have one second resolution, |       -- print would display all 255 digits of. timeclock amounts have one second resolution, | ||||||
|       -- so two decimal places is precise enough (#1527). |       -- so two decimal places is precise enough (#1527). | ||||||
|       amount   = mixedAmount $ setAmountInternalPrecision 2 $ hrs hours |       amt   = mixedAmount $ setAmountInternalPrecision 2 $ hrs hours | ||||||
|       ps       = [posting{paccount=acctname, pamount=amount, ptype=VirtualPosting, ptransaction=Just t}] |       ps       = [posting{paccount=acctname, pamount=amt, ptype=VirtualPosting, ptransaction=Just t}] | ||||||
| 
 | 
 | ||||||
| 
 | 
 | ||||||
| -- tests | -- tests | ||||||
|  | |||||||
| @ -10,7 +10,6 @@ tags. | |||||||
| {-# LANGUAGE MultiWayIf        #-} | {-# LANGUAGE MultiWayIf        #-} | ||||||
| {-# LANGUAGE NamedFieldPuns    #-} | {-# LANGUAGE NamedFieldPuns    #-} | ||||||
| {-# LANGUAGE OverloadedStrings #-} | {-# LANGUAGE OverloadedStrings #-} | ||||||
| {-# LANGUAGE TupleSections     #-} |  | ||||||
| 
 | 
 | ||||||
| module Hledger.Data.Transaction | module Hledger.Data.Transaction | ||||||
| ( -- * Transaction | ( -- * Transaction | ||||||
| @ -250,8 +249,8 @@ transactionAddPricesFromEquity acctTypes t = first (annotateErrorWithTransaction | |||||||
|       | isConversion p = Right ((cs, others),      Just np) |       | isConversion p = Right ((cs, others),      Just np) | ||||||
|       | hasPrice p     = Right ((cs, (np:ps, os)), Nothing) |       | hasPrice p     = Right ((cs, (np:ps, os)), Nothing) | ||||||
|       | otherwise      = Right ((cs, (ps, np:os)), Nothing) |       | otherwise      = Right ((cs, (ps, np:os)), Nothing) | ||||||
|     select np@(_, p) ((cs, others), Just last) |     select np@(_, p) ((cs, others), Just lst) | ||||||
|       | isConversion p = Right (((last, np):cs, others), Nothing) |       | isConversion p = Right (((lst, np):cs, others), Nothing) | ||||||
|       | otherwise      = Left "Conversion postings must occur in adjacent pairs" |       | otherwise      = Left "Conversion postings must occur in adjacent pairs" | ||||||
| 
 | 
 | ||||||
|     -- Given a pair of indexed conversion postings, and a state consisting of lists of |     -- Given a pair of indexed conversion postings, and a state consisting of lists of | ||||||
| @ -267,7 +266,7 @@ transactionAddPricesFromEquity acctTypes t = first (annotateErrorWithTransaction | |||||||
|         ca1 <- postingAmountNoPrice cp1 |         ca1 <- postingAmountNoPrice cp1 | ||||||
|         ca2 <- postingAmountNoPrice cp2 |         ca2 <- postingAmountNoPrice cp2 | ||||||
|         let -- The function to add transaction prices and tag postings in the indexed list of postings |         let -- The function to add transaction prices and tag postings in the indexed list of postings | ||||||
|             transformPostingF np pricep = \(n, p) -> |             transformPostingF np pricep (n,p) = | ||||||
|               (n, if | n == np            -> pricep `postingAddTags` [("_price-matched","")] |               (n, if | n == np            -> pricep `postingAddTags` [("_price-matched","")] | ||||||
|                      | n == n1 || n == n2 -> p      `postingAddTags` [("_conversion-matched","")] |                      | n == n1 || n == n2 -> p      `postingAddTags` [("_conversion-matched","")] | ||||||
|                      | otherwise          -> p) |                      | otherwise          -> p) | ||||||
|  | |||||||
| @ -67,7 +67,7 @@ module Hledger.Query ( | |||||||
|   matchesTags, |   matchesTags, | ||||||
|   matchesPriceDirective, |   matchesPriceDirective, | ||||||
|   words'', |   words'', | ||||||
|   prefixes, |   queryprefixes, | ||||||
|   -- * tests |   -- * tests | ||||||
|   tests_Query |   tests_Query | ||||||
| ) | ) | ||||||
| @ -167,7 +167,7 @@ data QueryOpt = QueryOptInAcctOnly AccountName  -- ^ show an account register fo | |||||||
| -- >>> parseQuery nulldate "\"expenses:dining out\"" | -- >>> parseQuery nulldate "\"expenses:dining out\"" | ||||||
| -- Right (Acct (RegexpCI "expenses:dining out"),[]) | -- Right (Acct (RegexpCI "expenses:dining out"),[]) | ||||||
| parseQuery :: Day -> T.Text -> Either String (Query,[QueryOpt]) | parseQuery :: Day -> T.Text -> Either String (Query,[QueryOpt]) | ||||||
| parseQuery d = parseQueryList d . words'' prefixes | parseQuery d = parseQueryList d . words'' queryprefixes | ||||||
| 
 | 
 | ||||||
| -- | Convert a list of query expression containing to a query and zero | -- | Convert a list of query expression containing to a query and zero | ||||||
| -- or more query options; or return an error message if query parsing fails. | -- or more query options; or return an error message if query parsing fails. | ||||||
| @ -234,8 +234,8 @@ words'' prefixes = fromparse . parsewith maybeprefixedquotedphrases -- XXX | |||||||
| 
 | 
 | ||||||
| -- XXX | -- XXX | ||||||
| -- keep synced with patterns below, excluding "not" | -- keep synced with patterns below, excluding "not" | ||||||
| prefixes :: [T.Text] | queryprefixes :: [T.Text] | ||||||
| prefixes = map (<>":") [ | queryprefixes = map (<>":") [ | ||||||
|      "inacctonly" |      "inacctonly" | ||||||
|     ,"inacct" |     ,"inacct" | ||||||
|     ,"amt" |     ,"amt" | ||||||
| @ -285,10 +285,10 @@ parseQueryTerm _ (T.stripPrefix "note:" -> Just s) = Left <$> noteTag (Just s) | |||||||
| parseQueryTerm _ (T.stripPrefix "acct:" -> Just s) = Left . Acct <$> toRegexCI s | parseQueryTerm _ (T.stripPrefix "acct:" -> Just s) = Left . Acct <$> toRegexCI s | ||||||
| parseQueryTerm d (T.stripPrefix "date2:" -> Just s) = | parseQueryTerm d (T.stripPrefix "date2:" -> Just s) = | ||||||
|         case parsePeriodExpr d s of Left e         -> Left $ "\"date2:"++T.unpack s++"\" gave a "++showDateParseError e |         case parsePeriodExpr d s of Left e         -> Left $ "\"date2:"++T.unpack s++"\" gave a "++showDateParseError e | ||||||
|                                     Right (_,span) -> Right $ Left $ Date2 span |                                     Right (_,spn) -> Right $ Left $ Date2 spn | ||||||
| parseQueryTerm d (T.stripPrefix "date:" -> Just s) = | parseQueryTerm d (T.stripPrefix "date:" -> Just s) = | ||||||
|         case parsePeriodExpr d s of Left e         -> Left $ "\"date:"++T.unpack s++"\" gave a "++showDateParseError e |         case parsePeriodExpr d s of Left e         -> Left $ "\"date:"++T.unpack s++"\" gave a "++showDateParseError e | ||||||
|                                     Right (_,span) -> Right $ Left $ Date span |                                     Right (_,spn) -> Right $ Left $ Date spn | ||||||
| parseQueryTerm _ (T.stripPrefix "status:" -> Just s) = | parseQueryTerm _ (T.stripPrefix "status:" -> Just s) = | ||||||
|         case parseStatus s of Left e   -> Left $ "\"status:"++T.unpack s++"\" gave a parse error: " ++ e |         case parseStatus s of Left e   -> Left $ "\"status:"++T.unpack s++"\" gave a parse error: " ++ e | ||||||
|                               Right st -> Right $ Left $ StatusQ st |                               Right st -> Right $ Left $ StatusQ st | ||||||
| @ -412,9 +412,9 @@ truestrings = ["1"] | |||||||
| -- * modifying | -- * modifying | ||||||
| 
 | 
 | ||||||
| simplifyQuery :: Query -> Query | simplifyQuery :: Query -> Query | ||||||
| simplifyQuery q = | simplifyQuery q0 = | ||||||
|   let q' = simplify q |   let q1 = simplify q0 | ||||||
|   in if q' == q then q else simplifyQuery q' |   in if q1 == q0 then q0 else simplifyQuery q1 | ||||||
|   where |   where | ||||||
|     simplify (And []) = Any |     simplify (And []) = Any | ||||||
|     simplify (And [q]) = simplify q |     simplify (And [q]) = simplify q | ||||||
| @ -455,7 +455,7 @@ filterQuery' p q = if p q then q else Any | |||||||
| -- (Since 1.24.1, might be merged into filterQuery in future.) | -- (Since 1.24.1, might be merged into filterQuery in future.) | ||||||
| -- XXX Semantics not completely clear. | -- XXX Semantics not completely clear. | ||||||
| filterQueryOrNotQuery :: (Query -> Bool) -> Query -> Query | filterQueryOrNotQuery :: (Query -> Bool) -> Query -> Query | ||||||
| filterQueryOrNotQuery p = simplifyQuery . filterQueryOrNotQuery' p | filterQueryOrNotQuery p0 = simplifyQuery . filterQueryOrNotQuery' p0 | ||||||
|   where |   where | ||||||
|     filterQueryOrNotQuery' :: (Query -> Bool) -> Query -> Query |     filterQueryOrNotQuery' :: (Query -> Bool) -> Query -> Query | ||||||
|     filterQueryOrNotQuery' p (And qs)      = And $ map (filterQueryOrNotQuery p) qs |     filterQueryOrNotQuery' p (And qs)      = And $ map (filterQueryOrNotQuery p) qs | ||||||
| @ -584,7 +584,7 @@ queryEndDate False (Date (DateSpan _ (Just d))) = Just d | |||||||
| queryEndDate True (Date2 (DateSpan _ (Just d))) = Just d | queryEndDate True (Date2 (DateSpan _ (Just d))) = Just d | ||||||
| queryEndDate _ _ = Nothing | queryEndDate _ _ = Nothing | ||||||
| 
 | 
 | ||||||
| queryTermDateSpan (Date span) = Just span | queryTermDateSpan (Date spn) = Just spn | ||||||
| queryTermDateSpan _ = Nothing | queryTermDateSpan _ = Nothing | ||||||
| 
 | 
 | ||||||
| -- | What date span (or with a true argument, what secondary date span) does this query specify ? | -- | What date span (or with a true argument, what secondary date span) does this query specify ? | ||||||
| @ -594,8 +594,8 @@ queryTermDateSpan _ = Nothing | |||||||
| queryDateSpan :: Bool -> Query -> DateSpan | queryDateSpan :: Bool -> Query -> DateSpan | ||||||
| queryDateSpan secondary (Or qs)  = spansUnion     $ map (queryDateSpan secondary) qs | queryDateSpan secondary (Or qs)  = spansUnion     $ map (queryDateSpan secondary) qs | ||||||
| queryDateSpan secondary (And qs) = spansIntersect $ map (queryDateSpan secondary) qs | queryDateSpan secondary (And qs) = spansIntersect $ map (queryDateSpan secondary) qs | ||||||
| queryDateSpan _     (Date span)  = span | queryDateSpan _     (Date spn)  = spn | ||||||
| queryDateSpan True (Date2 span)  = span | queryDateSpan True (Date2 spn)  = spn | ||||||
| queryDateSpan _ _                = nulldatespan | queryDateSpan _ _                = nulldatespan | ||||||
| 
 | 
 | ||||||
| -- | What date span does this query specify, treating primary and secondary dates as equivalent ? | -- | What date span does this query specify, treating primary and secondary dates as equivalent ? | ||||||
| @ -605,8 +605,8 @@ queryDateSpan _ _                = nulldatespan | |||||||
| queryDateSpan' :: Query -> DateSpan | queryDateSpan' :: Query -> DateSpan | ||||||
| queryDateSpan' (Or qs)      = spansUnion     $ map queryDateSpan' qs | queryDateSpan' (Or qs)      = spansUnion     $ map queryDateSpan' qs | ||||||
| queryDateSpan' (And qs)     = spansIntersect $ map queryDateSpan' qs | queryDateSpan' (And qs)     = spansIntersect $ map queryDateSpan' qs | ||||||
| queryDateSpan' (Date span)  = span | queryDateSpan' (Date spn)  = spn | ||||||
| queryDateSpan' (Date2 span) = span | queryDateSpan' (Date2 spn) = spn | ||||||
| queryDateSpan' _            = nulldatespan | queryDateSpan' _            = nulldatespan | ||||||
| 
 | 
 | ||||||
| -- | What is the earliest of these dates, where Nothing is earliest ? | -- | What is the earliest of these dates, where Nothing is earliest ? | ||||||
| @ -732,16 +732,16 @@ matchesPosting (And qs) p = all (`matchesPosting` p) qs | |||||||
| matchesPosting (Code r) p = maybe False (regexMatchText r . tcode) $ ptransaction p | matchesPosting (Code r) p = maybe False (regexMatchText r . tcode) $ ptransaction p | ||||||
| matchesPosting (Desc r) p = maybe False (regexMatchText r . tdescription) $ ptransaction p | matchesPosting (Desc r) p = maybe False (regexMatchText r . tdescription) $ ptransaction p | ||||||
| matchesPosting (Acct r) p = matches p || maybe False matches (poriginal p) where matches = regexMatchText r . paccount | matchesPosting (Acct r) p = matches p || maybe False matches (poriginal p) where matches = regexMatchText r . paccount | ||||||
| matchesPosting (Date span) p = span `spanContainsDate` postingDate p | matchesPosting (Date spn) p = spn `spanContainsDate` postingDate p | ||||||
| matchesPosting (Date2 span) p = span `spanContainsDate` postingDate2 p | matchesPosting (Date2 spn) p = spn `spanContainsDate` postingDate2 p | ||||||
| matchesPosting (StatusQ s) p = postingStatus p == s | matchesPosting (StatusQ s) p = postingStatus p == s | ||||||
| matchesPosting (Real v) p = v == isReal p | matchesPosting (Real v) p = v == isReal p | ||||||
| matchesPosting q@(Depth _) Posting{paccount=a} = q `matchesAccount` a | matchesPosting q@(Depth _) Posting{paccount=a} = q `matchesAccount` a | ||||||
| matchesPosting q@(Amt _ _) Posting{pamount=as} = q `matchesMixedAmount` as | matchesPosting q@(Amt _ _) Posting{pamount=as} = q `matchesMixedAmount` as | ||||||
| matchesPosting (Sym r) Posting{pamount=as} = any (matchesCommodity (Sym r) . acommodity) $ amountsRaw as | matchesPosting (Sym r) Posting{pamount=as} = any (matchesCommodity (Sym r) . acommodity) $ amountsRaw as | ||||||
| matchesPosting (Tag n v) p = case (reString n, v) of | matchesPosting (Tag n v) p = case (reString n, v) of | ||||||
|   ("payee", Just v) -> maybe False (regexMatchText v . transactionPayee) $ ptransaction p |   ("payee", Just v') -> maybe False (regexMatchText v' . transactionPayee) $ ptransaction p | ||||||
|   ("note", Just v) -> maybe False (regexMatchText v . transactionNote) $ ptransaction p |   ("note", Just v') -> maybe False (regexMatchText v' . transactionNote) $ ptransaction p | ||||||
|   (_, mv) -> matchesTags n mv $ postingAllTags p |   (_, mv) -> matchesTags n mv $ postingAllTags p | ||||||
| matchesPosting (Type _) _ = False | matchesPosting (Type _) _ = False | ||||||
| 
 | 
 | ||||||
| @ -765,17 +765,17 @@ matchesTransaction (And qs) t = all (`matchesTransaction` t) qs | |||||||
| matchesTransaction (Code r) t = regexMatchText r $ tcode t | matchesTransaction (Code r) t = regexMatchText r $ tcode t | ||||||
| matchesTransaction (Desc r) t = regexMatchText r $ tdescription t | matchesTransaction (Desc r) t = regexMatchText r $ tdescription t | ||||||
| matchesTransaction q@(Acct _) t = any (q `matchesPosting`) $ tpostings t | matchesTransaction q@(Acct _) t = any (q `matchesPosting`) $ tpostings t | ||||||
| matchesTransaction (Date span) t = spanContainsDate span $ tdate t | matchesTransaction (Date spn) t = spanContainsDate spn $ tdate t | ||||||
| matchesTransaction (Date2 span) t = spanContainsDate span $ transactionDate2 t | matchesTransaction (Date2 spn) t = spanContainsDate spn $ transactionDate2 t | ||||||
| matchesTransaction (StatusQ s) t = tstatus t == s | matchesTransaction (StatusQ s) t = tstatus t == s | ||||||
| matchesTransaction (Real v) t = v == hasRealPostings t | matchesTransaction (Real v) t = v == hasRealPostings t | ||||||
| matchesTransaction q@(Amt _ _) t = any (q `matchesPosting`) $ tpostings t | matchesTransaction q@(Amt _ _) t = any (q `matchesPosting`) $ tpostings t | ||||||
| matchesTransaction (Depth d) t = any (Depth d `matchesPosting`) $ tpostings t | matchesTransaction (Depth d) t = any (Depth d `matchesPosting`) $ tpostings t | ||||||
| matchesTransaction q@(Sym _) t = any (q `matchesPosting`) $ tpostings t | matchesTransaction q@(Sym _) t = any (q `matchesPosting`) $ tpostings t | ||||||
| matchesTransaction (Tag n v) t = case (reString n, v) of | matchesTransaction (Tag n v) t = case (reString n, v) of | ||||||
|   ("payee", Just v) -> regexMatchText v $ transactionPayee t |   ("payee", Just v') -> regexMatchText v' $ transactionPayee t | ||||||
|   ("note", Just v) -> regexMatchText v $ transactionNote t |   ("note", Just v') -> regexMatchText v' $ transactionNote t | ||||||
|   (_, v) -> matchesTags n v $ transactionAllTags t |   (_, v') -> matchesTags n v' $ transactionAllTags t | ||||||
| matchesTransaction (Type _) _ = False | matchesTransaction (Type _) _ = False | ||||||
| 
 | 
 | ||||||
| -- | Like matchesTransaction, but if the journal's account types are provided, | -- | Like matchesTransaction, but if the journal's account types are provided, | ||||||
| @ -821,7 +821,7 @@ matchesPriceDirective (Or qs) p     = any (`matchesPriceDirective` p) qs | |||||||
| matchesPriceDirective (And qs) p    = all (`matchesPriceDirective` p) qs | matchesPriceDirective (And qs) p    = all (`matchesPriceDirective` p) qs | ||||||
| matchesPriceDirective q@(Amt _ _) p = matchesAmount q (pdamount p) | matchesPriceDirective q@(Amt _ _) p = matchesAmount q (pdamount p) | ||||||
| matchesPriceDirective q@(Sym _) p   = matchesCommodity q (pdcommodity p) | matchesPriceDirective q@(Sym _) p   = matchesCommodity q (pdcommodity p) | ||||||
| matchesPriceDirective (Date span) p = spanContainsDate span (pddate p) | matchesPriceDirective (Date spn) p = spanContainsDate spn (pddate p) | ||||||
| matchesPriceDirective _ _           = True | matchesPriceDirective _ _           = True | ||||||
| 
 | 
 | ||||||
| 
 | 
 | ||||||
| @ -854,8 +854,8 @@ tests_Query = testGroup "Query" [ | |||||||
|       (words'' [] "not:'a b'")             @?= ["not:a b"] |       (words'' [] "not:'a b'")             @?= ["not:a b"] | ||||||
|       (words'' [] "'not:a b'")             @?= ["not:a b"] |       (words'' [] "'not:a b'")             @?= ["not:a b"] | ||||||
|       (words'' ["desc:"] "not:desc:'a b'") @?= ["not:desc:a b"] |       (words'' ["desc:"] "not:desc:'a b'") @?= ["not:desc:a b"] | ||||||
|       (words'' prefixes "\"acct:expenses:autres d\233penses\"") @?= ["acct:expenses:autres d\233penses"] |       (words'' queryprefixes "\"acct:expenses:autres d\233penses\"") @?= ["acct:expenses:autres d\233penses"] | ||||||
|       (words'' prefixes "\"")              @?= ["\""] |       (words'' queryprefixes "\"")              @?= ["\""] | ||||||
| 
 | 
 | ||||||
|   ,testCase "filterQuery" $ do |   ,testCase "filterQuery" $ do | ||||||
|      filterQuery queryIsDepth Any       @?= Any |      filterQuery queryIsDepth Any       @?= Any | ||||||
|  | |||||||
| @ -108,13 +108,13 @@ defaultJournal = defaultJournalPath >>= runExceptT . readJournalFile definputopt | |||||||
| defaultJournalPath :: IO String | defaultJournalPath :: IO String | ||||||
| defaultJournalPath = do | defaultJournalPath = do | ||||||
|   s <- envJournalPath |   s <- envJournalPath | ||||||
|   if null s then defaultJournalPath else return s |   if null s then defpath else return s | ||||||
|     where |     where | ||||||
|       envJournalPath = |       envJournalPath = | ||||||
|         getEnv journalEnvVar |         getEnv journalEnvVar | ||||||
|          `C.catch` (\(_::C.IOException) -> getEnv journalEnvVar2 |          `C.catch` (\(_::C.IOException) -> getEnv journalEnvVar2 | ||||||
|                                             `C.catch` (\(_::C.IOException) -> return "")) |                                             `C.catch` (\(_::C.IOException) -> return "")) | ||||||
|       defaultJournalPath = do |       defpath = do | ||||||
|         home <- getHomeDirectory `C.catch` (\(_::C.IOException) -> return "") |         home <- getHomeDirectory `C.catch` (\(_::C.IOException) -> return "") | ||||||
|         return $ home </> journalDefaultFilename |         return $ home </> journalDefaultFilename | ||||||
| 
 | 
 | ||||||
|  | |||||||
| @ -195,7 +195,7 @@ rawOptsToInputOpts day rawopts = | |||||||
|         argsquery = lefts . rights . map (parseQueryTerm day) $ querystring_ ropts |         argsquery = lefts . rights . map (parseQueryTerm day) $ querystring_ ropts | ||||||
|         datequery = simplifyQuery . filterQuery queryIsDate . And $ queryFromFlags ropts : argsquery |         datequery = simplifyQuery . filterQuery queryIsDate . And $ queryFromFlags ropts : argsquery | ||||||
| 
 | 
 | ||||||
|         commodity_styles = either err id $ commodityStyleFromRawOpts rawopts |         styles = either err id $ commodityStyleFromRawOpts rawopts | ||||||
|           where err e = error' $ "could not parse commodity-style: '" ++ e ++ "'"  -- PARTIAL: |           where err e = error' $ "could not parse commodity-style: '" ++ e ++ "'"  -- PARTIAL: | ||||||
| 
 | 
 | ||||||
|     in definputopts{ |     in definputopts{ | ||||||
| @ -215,7 +215,7 @@ rawOptsToInputOpts day rawopts = | |||||||
|       ,balancingopts_     = defbalancingopts{ |       ,balancingopts_     = defbalancingopts{ | ||||||
|                                  ignore_assertions_ = boolopt "ignore-assertions" rawopts |                                  ignore_assertions_ = boolopt "ignore-assertions" rawopts | ||||||
|                                , infer_transaction_prices_ = not noinferprice |                                , infer_transaction_prices_ = not noinferprice | ||||||
|                                , commodity_styles_  = Just commodity_styles |                                , commodity_styles_  = Just styles | ||||||
|                                } |                                } | ||||||
|       ,strict_            = boolopt "strict" rawopts |       ,strict_            = boolopt "strict" rawopts | ||||||
|       ,_ioDay             = day |       ,_ioDay             = day | ||||||
| @ -446,8 +446,8 @@ journalAddFile f j@Journal{jfiles=fs} = j{jfiles=fs++[f]} | |||||||
| -- A version of `match` that is strict in the returned text | -- A version of `match` that is strict in the returned text | ||||||
| match' :: TextParser m a -> TextParser m (Text, a) | match' :: TextParser m a -> TextParser m (Text, a) | ||||||
| match' p = do | match' p = do | ||||||
|   (!txt, p) <- match p |   (!txt, p') <- match p | ||||||
|   pure (txt, p) |   pure (txt, p') | ||||||
| 
 | 
 | ||||||
| --- ** parsers | --- ** parsers | ||||||
| --- *** transaction bits | --- *** transaction bits | ||||||
| @ -514,9 +514,9 @@ datep' mYear = do | |||||||
|         Just date -> pure $! date |         Just date -> pure $! date | ||||||
| 
 | 
 | ||||||
|     partialDate :: Int -> Maybe Year -> Month -> Char -> MonthDay -> TextParser m Day |     partialDate :: Int -> Maybe Year -> Month -> Char -> MonthDay -> TextParser m Day | ||||||
|     partialDate startOffset mYear month sep day = do |     partialDate startOffset myr month sep day = do | ||||||
|       endOffset <- getOffset |       endOffset <- getOffset | ||||||
|       case mYear of |       case myr of | ||||||
|         Just year -> |         Just year -> | ||||||
|           case fromGregorianValid year month day of |           case fromGregorianValid year month day of | ||||||
|             Nothing -> customFailure $ parseErrorAtRegion startOffset endOffset $ |             Nothing -> customFailure $ parseErrorAtRegion startOffset endOffset $ | ||||||
| @ -611,12 +611,12 @@ yearorintp = do | |||||||
| modifiedaccountnamep :: JournalParser m AccountName | modifiedaccountnamep :: JournalParser m AccountName | ||||||
| modifiedaccountnamep = do | modifiedaccountnamep = do | ||||||
|   parent  <- getParentAccount |   parent  <- getParentAccount | ||||||
|   aliases <- getAccountAliases |   als     <- getAccountAliases | ||||||
|   -- off1    <- getOffset |   -- off1    <- getOffset | ||||||
|   a       <- lift accountnamep |   a       <- lift accountnamep | ||||||
|   -- off2    <- getOffset |   -- off2    <- getOffset | ||||||
|   -- XXX or accountNameApplyAliasesMemo ? doesn't seem to make a difference (retest that function) |   -- XXX or accountNameApplyAliasesMemo ? doesn't seem to make a difference (retest that function) | ||||||
|   case accountNameApplyAliases aliases $ joinAccountNames parent a of |   case accountNameApplyAliases als $ joinAccountNames parent a of | ||||||
|     Right a' -> return $! a' |     Right a' -> return $! a' | ||||||
|     -- should not happen, regexaliasp will have displayed a better error already: |     -- should not happen, regexaliasp will have displayed a better error already: | ||||||
|     -- (XXX why does customFailure cause error to be displayed there, but not here ?) |     -- (XXX why does customFailure cause error to be displayed there, but not here ?) | ||||||
| @ -660,12 +660,12 @@ singlespacednoncommenttext1p = singlespacedtextsatisfying1p (not . isSameLineCom | |||||||
| -- | Parse non-empty, single-spaced text starting and ending with non-whitespace, | -- | Parse non-empty, single-spaced text starting and ending with non-whitespace, | ||||||
| -- where all characters satisfy the given predicate. | -- where all characters satisfy the given predicate. | ||||||
| singlespacedtextsatisfying1p :: (Char -> Bool) -> TextParser m T.Text | singlespacedtextsatisfying1p :: (Char -> Bool) -> TextParser m T.Text | ||||||
| singlespacedtextsatisfying1p pred = do | singlespacedtextsatisfying1p f = do | ||||||
|   firstPart <- partp |   firstPart <- partp | ||||||
|   otherParts <- many $ try $ singlespacep *> partp |   otherParts <- many $ try $ singlespacep *> partp | ||||||
|   pure $! T.unwords $ firstPart : otherParts |   pure $! T.unwords $ firstPart : otherParts | ||||||
|   where |   where | ||||||
|     partp = takeWhile1P Nothing (\c -> pred c && not (isSpace c)) |     partp = takeWhile1P Nothing (\c -> f c && not (isSpace c)) | ||||||
| 
 | 
 | ||||||
| -- | Parse one non-newline whitespace character that is not followed by another one. | -- | Parse one non-newline whitespace character that is not followed by another one. | ||||||
| singlespacep :: TextParser m () | singlespacep :: TextParser m () | ||||||
| @ -708,20 +708,20 @@ amountp = amountpwithmultiplier False | |||||||
| amountpwithmultiplier :: Bool -> JournalParser m Amount | amountpwithmultiplier :: Bool -> JournalParser m Amount | ||||||
| amountpwithmultiplier mult = label "amount" $ do | amountpwithmultiplier mult = label "amount" $ do | ||||||
|   let spaces = lift $ skipNonNewlineSpaces |   let spaces = lift $ skipNonNewlineSpaces | ||||||
|   amount <- amountwithoutpricep mult <* spaces |   amt <- amountwithoutpricep mult <* spaces | ||||||
|   (mprice, _elotprice, _elotdate) <- runPermutation $ |   (mprice, _elotprice, _elotdate) <- runPermutation $ | ||||||
|     (,,) <$> toPermutationWithDefault Nothing (Just <$> priceamountp amount <* spaces) |     (,,) <$> toPermutationWithDefault Nothing (Just <$> priceamountp amt <* spaces) | ||||||
|          <*> toPermutationWithDefault Nothing (Just <$> lotpricep <* spaces) |          <*> toPermutationWithDefault Nothing (Just <$> lotpricep <* spaces) | ||||||
|          <*> toPermutationWithDefault Nothing (Just <$> lotdatep <* spaces) |          <*> toPermutationWithDefault Nothing (Just <$> lotdatep <* spaces) | ||||||
|   pure $ amount { aprice = mprice } |   pure $ amt { aprice = mprice } | ||||||
| 
 | 
 | ||||||
| amountpnolotpricesp :: JournalParser m Amount | amountpnolotpricesp :: JournalParser m Amount | ||||||
| amountpnolotpricesp = label "amount" $ do | amountpnolotpricesp = label "amount" $ do | ||||||
|   let spaces = lift $ skipNonNewlineSpaces |   let spaces = lift $ skipNonNewlineSpaces | ||||||
|   amount <- amountwithoutpricep False |   amt <- amountwithoutpricep False | ||||||
|   spaces |   spaces | ||||||
|   mprice <- optional $ priceamountp amount <* spaces |   mprice <- optional $ priceamountp amt <* spaces | ||||||
|   pure $ amount { aprice = mprice } |   pure $ amt { aprice = mprice } | ||||||
| 
 | 
 | ||||||
| amountwithoutpricep :: Bool -> JournalParser m Amount | amountwithoutpricep :: Bool -> JournalParser m Amount | ||||||
| amountwithoutpricep mult = do | amountwithoutpricep mult = do | ||||||
| @ -1094,8 +1094,8 @@ data DigitGrp = DigitGrp { | |||||||
| 
 | 
 | ||||||
| -- | A custom show instance, showing digit groups as the parser saw them. | -- | A custom show instance, showing digit groups as the parser saw them. | ||||||
| instance Show DigitGrp where | instance Show DigitGrp where | ||||||
|   show (DigitGrp len num) = "\"" ++ padding ++ numStr ++ "\"" |   show (DigitGrp len n) = "\"" ++ padding ++ numStr ++ "\"" | ||||||
|     where numStr = show num |     where numStr = show n | ||||||
|           padding = genericReplicate (toInteger len - toInteger (length numStr)) '0' |           padding = genericReplicate (toInteger len - toInteger (length numStr)) '0' | ||||||
| 
 | 
 | ||||||
| instance Sem.Semigroup DigitGrp where | instance Sem.Semigroup DigitGrp where | ||||||
|  | |||||||
| @ -13,9 +13,7 @@ A reader for CSV data, using an extra rules file to help interpret the data. | |||||||
| --- ** language | --- ** language | ||||||
| {-# LANGUAGE FlexibleContexts     #-} | {-# LANGUAGE FlexibleContexts     #-} | ||||||
| {-# LANGUAGE FlexibleInstances    #-} | {-# LANGUAGE FlexibleInstances    #-} | ||||||
| {-# LANGUAGE MultiWayIf           #-} |  | ||||||
| {-# LANGUAGE OverloadedStrings    #-} | {-# LANGUAGE OverloadedStrings    #-} | ||||||
| {-# LANGUAGE PackageImports       #-} |  | ||||||
| {-# LANGUAGE RecordWildCards      #-} | {-# LANGUAGE RecordWildCards      #-} | ||||||
| {-# LANGUAGE ScopedTypeVariables  #-} | {-# LANGUAGE ScopedTypeVariables  #-} | ||||||
| {-# LANGUAGE TypeFamilies         #-} | {-# LANGUAGE TypeFamilies         #-} | ||||||
| @ -38,7 +36,7 @@ where | |||||||
| 
 | 
 | ||||||
| --- ** imports | --- ** imports | ||||||
| import Control.Applicative        (liftA2) | import Control.Applicative        (liftA2) | ||||||
| import Control.Monad              (unless, when) | import Control.Monad              (unless, when, void) | ||||||
| import Control.Monad.Except       (ExceptT(..), liftEither, throwError) | import Control.Monad.Except       (ExceptT(..), liftEither, throwError) | ||||||
| import qualified Control.Monad.Fail as Fail | import qualified Control.Monad.Fail as Fail | ||||||
| import Control.Monad.IO.Class     (MonadIO, liftIO) | import Control.Monad.IO.Class     (MonadIO, liftIO) | ||||||
| @ -104,13 +102,13 @@ parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal | |||||||
| parse iopts f t = do | parse iopts f t = do | ||||||
|   let rulesfile = mrules_file_ iopts |   let rulesfile = mrules_file_ iopts | ||||||
|   readJournalFromCsv rulesfile f t |   readJournalFromCsv rulesfile f t | ||||||
|  |   -- apply any command line account aliases. Can fail with a bad replacement pattern. | ||||||
|  |   >>= liftEither . journalApplyAliases (aliasesFromOpts iopts) | ||||||
|       -- journalFinalise assumes the journal's items are |       -- journalFinalise assumes the journal's items are | ||||||
|       -- reversed, as produced by JournalReader's parser. |       -- reversed, as produced by JournalReader's parser. | ||||||
|       -- But here they are already properly ordered. So we'd |       -- But here they are already properly ordered. So we'd | ||||||
|       -- better preemptively reverse them once more. XXX inefficient |       -- better preemptively reverse them once more. XXX inefficient | ||||||
|   <&> journalReverse |       . journalReverse | ||||||
|   -- apply any command line account aliases. Can fail with a bad replacement pattern. |  | ||||||
|   >>= liftEither . journalApplyAliases (aliasesFromOpts iopts) |  | ||||||
|   >>= journalFinalise iopts{balancingopts_=(balancingopts_ iopts){ignore_assertions_=True}} f t |   >>= journalFinalise iopts{balancingopts_=(balancingopts_ iopts){ignore_assertions_=True}} f t | ||||||
| 
 | 
 | ||||||
| --- ** reading rules files | --- ** reading rules files | ||||||
| @ -193,14 +191,14 @@ instance ShowErrorComponent String where | |||||||
| -- Included file paths may be relative to the directory of the provided file path. | -- Included file paths may be relative to the directory of the provided file path. | ||||||
| -- This is done as a pre-parse step to simplify the CSV rules parser. | -- This is done as a pre-parse step to simplify the CSV rules parser. | ||||||
| expandIncludes :: FilePath -> Text -> IO Text | expandIncludes :: FilePath -> Text -> IO Text | ||||||
| expandIncludes dir content = mapM (expandLine dir) (T.lines content) >>= return . T.unlines | expandIncludes dir0 content = mapM (expandLine dir0) (T.lines content) <&> T.unlines | ||||||
|   where |   where | ||||||
|     expandLine dir line = |     expandLine dir1 line = | ||||||
|       case line of |       case line of | ||||||
|         (T.stripPrefix "include " -> Just f) -> expandIncludes dir' =<< T.readFile f' |         (T.stripPrefix "include " -> Just f) -> expandIncludes dir2 =<< T.readFile f' | ||||||
|           where |           where | ||||||
|             f' = dir </> T.unpack (T.dropWhile isSpace f) |             f' = dir1 </> T.unpack (T.dropWhile isSpace f) | ||||||
|             dir' = takeDirectory f' |             dir2 = takeDirectory f' | ||||||
|         _ -> return line |         _ -> return line | ||||||
| 
 | 
 | ||||||
| -- | An error-throwing IO action that parses this text as CSV conversion rules | -- | An error-throwing IO action that parses this text as CSV conversion rules | ||||||
| @ -582,7 +580,7 @@ conditionaltablep = do | |||||||
|   newline |   newline | ||||||
|   body <- flip manyTill (lift eolof) $ do |   body <- flip manyTill (lift eolof) $ do | ||||||
|     off <- getOffset |     off <- getOffset | ||||||
|     m <- matcherp' (char sep >> return ()) |     m <- matcherp' $ void $ char sep | ||||||
|     vs <- T.split (==sep) . T.pack <$> lift restofline |     vs <- T.split (==sep) . T.pack <$> lift restofline | ||||||
|     if (length vs /= length fields) |     if (length vs /= length fields) | ||||||
|       then customFailure $ parseErrorAt off $ ((printf "line of conditional table should have %d values, but this one has only %d" (length fields) (length vs)) :: String) |       then customFailure $ parseErrorAt off $ ((printf "line of conditional table should have %d values, but this one has only %d" (length fields) (length vs)) :: String) | ||||||
| @ -757,7 +755,7 @@ readJournalFromCsv mrulesfile csvfile csvdata = do | |||||||
|       -- Second, sort by date. |       -- Second, sort by date. | ||||||
|       txns'' = dbg7 "date-sorted csv txns" $ sortBy (comparing tdate) txns' |       txns'' = dbg7 "date-sorted csv txns" $ sortBy (comparing tdate) txns' | ||||||
| 
 | 
 | ||||||
|     liftIO $ when (not rulesfileexists) $ do |     liftIO $ unless rulesfileexists $ do | ||||||
|       dbg1IO "creating conversion rules file" rulesfile |       dbg1IO "creating conversion rules file" rulesfile | ||||||
|       T.writeFile rulesfile rulestext |       T.writeFile rulesfile rulestext | ||||||
| 
 | 
 | ||||||
| @ -804,7 +802,7 @@ validateCsv :: CsvRules -> Int -> CSV -> Either String [CsvRecord] | |||||||
| validateCsv rules numhdrlines = validate . applyConditionalSkips . drop numhdrlines . filternulls | validateCsv rules numhdrlines = validate . applyConditionalSkips . drop numhdrlines . filternulls | ||||||
|   where |   where | ||||||
|     filternulls = filter (/=[""]) |     filternulls = filter (/=[""]) | ||||||
|     skipCount r = |     skipnum r = | ||||||
|       case (getEffectiveAssignment rules r "end", getEffectiveAssignment rules r "skip") of |       case (getEffectiveAssignment rules r "end", getEffectiveAssignment rules r "skip") of | ||||||
|         (Nothing, Nothing) -> Nothing |         (Nothing, Nothing) -> Nothing | ||||||
|         (Just _, _) -> Just maxBound |         (Just _, _) -> Just maxBound | ||||||
| @ -812,7 +810,7 @@ validateCsv rules numhdrlines = validate . applyConditionalSkips . drop numhdrli | |||||||
|         (Nothing, Just x) -> Just (read $ T.unpack x) |         (Nothing, Just x) -> Just (read $ T.unpack x) | ||||||
|     applyConditionalSkips [] = [] |     applyConditionalSkips [] = [] | ||||||
|     applyConditionalSkips (r:rest) = |     applyConditionalSkips (r:rest) = | ||||||
|       case skipCount r of |       case skipnum r of | ||||||
|         Nothing -> r:(applyConditionalSkips rest) |         Nothing -> r:(applyConditionalSkips rest) | ||||||
|         Just cnt -> applyConditionalSkips (drop (cnt-1) rest) |         Just cnt -> applyConditionalSkips (drop (cnt-1) rest) | ||||||
|     validate [] = Right [] |     validate [] = Right [] | ||||||
| @ -869,15 +867,15 @@ transactionFromCsvRecord sourcepos rules record = t | |||||||
|     field    = hledgerField      rules record :: HledgerFieldName -> Maybe FieldTemplate |     field    = hledgerField      rules record :: HledgerFieldName -> Maybe FieldTemplate | ||||||
|     fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text |     fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text | ||||||
|     parsedate = parseDateWithCustomOrDefaultFormats (rule "date-format") |     parsedate = parseDateWithCustomOrDefaultFormats (rule "date-format") | ||||||
|     mkdateerror datefield datevalue mdateformat = T.unpack $ T.unlines |     mkdateerror datefield datevalue mdateformat' = T.unpack $ T.unlines | ||||||
|       ["error: could not parse \""<>datevalue<>"\" as a date using date format " |       ["error: could not parse \""<>datevalue<>"\" as a date using date format " | ||||||
|         <>maybe "\"YYYY/M/D\", \"YYYY-M-D\" or \"YYYY.M.D\"" (T.pack . show) mdateformat |         <>maybe "\"YYYY/M/D\", \"YYYY-M-D\" or \"YYYY.M.D\"" (T.pack . show) mdateformat' | ||||||
|       ,showRecord record |       ,showRecord record | ||||||
|       ,"the "<>datefield<>" rule is:   "<>(fromMaybe "required, but missing" $ field datefield) |       ,"the "<>datefield<>" rule is:   "<>(fromMaybe "required, but missing" $ field datefield) | ||||||
|       ,"the date-format is: "<>fromMaybe "unspecified" mdateformat |       ,"the date-format is: "<>fromMaybe "unspecified" mdateformat' | ||||||
|       ,"you may need to " |       ,"you may need to " | ||||||
|         <>"change your "<>datefield<>" rule, " |         <>"change your "<>datefield<>" rule, " | ||||||
|         <>maybe "add a" (const "change your") mdateformat<>" date-format rule, " |         <>maybe "add a" (const "change your") mdateformat'<>" date-format rule, " | ||||||
|         <>"or "<>maybe "add a" (const "change your") mskip<>" skip rule" |         <>"or "<>maybe "add a" (const "change your") mskip<>" skip rule" | ||||||
|       ,"for m/d/y or d/m/y dates, use date-format %-m/%-d/%Y or date-format %-d/%-m/%Y" |       ,"for m/d/y or d/m/y dates, use date-format %-m/%-d/%Y or date-format %-d/%-m/%Y" | ||||||
|       ] |       ] | ||||||
| @ -894,7 +892,7 @@ transactionFromCsvRecord sourcepos rules record = t | |||||||
|     -- PARTIAL: |     -- PARTIAL: | ||||||
|     date'       = fromMaybe (error' $ mkdateerror "date" date mdateformat) $ parsedate date |     date'       = fromMaybe (error' $ mkdateerror "date" date mdateformat) $ parsedate date | ||||||
|     mdate2      = fieldval "date2" |     mdate2      = fieldval "date2" | ||||||
|     mdate2'     = maybe Nothing (maybe (error' $ mkdateerror "date2" (fromMaybe "" mdate2) mdateformat) Just . parsedate) mdate2 |     mdate2'     = (maybe (error' $ mkdateerror "date2" (fromMaybe "" mdate2) mdateformat) Just . parsedate) =<< mdate2 | ||||||
|     status      = |     status      = | ||||||
|       case fieldval "status" of |       case fieldval "status" of | ||||||
|         Nothing -> Unmarked |         Nothing -> Unmarked | ||||||
| @ -904,12 +902,12 @@ transactionFromCsvRecord sourcepos rules record = t | |||||||
|               ["error: could not parse \""<>s<>"\" as a cleared status (should be *, ! or empty)" |               ["error: could not parse \""<>s<>"\" as a cleared status (should be *, ! or empty)" | ||||||
|               ,"the parse error is:      "<>T.pack (customErrorBundlePretty err) |               ,"the parse error is:      "<>T.pack (customErrorBundlePretty err) | ||||||
|               ] |               ] | ||||||
|     code        = maybe "" singleline $ fieldval "code" |     code        = maybe "" singleline' $ fieldval "code" | ||||||
|     description = maybe "" singleline $ fieldval "description" |     description = maybe "" singleline' $ fieldval "description" | ||||||
|     comment     = maybe "" unescapeNewlines $ fieldval "comment" |     comment     = maybe "" unescapeNewlines $ fieldval "comment" | ||||||
|     precomment  = maybe "" unescapeNewlines $ fieldval "precomment" |     precomment  = maybe "" unescapeNewlines $ fieldval "precomment" | ||||||
| 
 | 
 | ||||||
|     singleline = T.unwords . filter (not . T.null) . map T.strip . T.lines |     singleline' = T.unwords . filter (not . T.null) . map T.strip . T.lines | ||||||
|     unescapeNewlines = T.intercalate "\n" . T.splitOn "\\n" |     unescapeNewlines = T.intercalate "\n" . T.splitOn "\\n" | ||||||
| 
 | 
 | ||||||
|     ---------------------------------------------------------------------- |     ---------------------------------------------------------------------- | ||||||
| @ -918,7 +916,7 @@ transactionFromCsvRecord sourcepos rules record = t | |||||||
| 
 | 
 | ||||||
|     p1IsVirtual = (accountNamePostingType <$> fieldval "account1") == Just VirtualPosting |     p1IsVirtual = (accountNamePostingType <$> fieldval "account1") == Just VirtualPosting | ||||||
|     ps = [p | n <- [1..maxpostings] |     ps = [p | n <- [1..maxpostings] | ||||||
|          ,let comment  = maybe "" unescapeNewlines $ fieldval ("comment"<> T.pack (show n)) |          ,let cmt  = maybe "" unescapeNewlines $ fieldval ("comment"<> T.pack (show n)) | ||||||
|          ,let currency = fromMaybe "" (fieldval ("currency"<> T.pack (show n)) <|> fieldval "currency") |          ,let currency = fromMaybe "" (fieldval ("currency"<> T.pack (show n)) <|> fieldval "currency") | ||||||
|          ,let mamount  = getAmount rules record currency p1IsVirtual n |          ,let mamount  = getAmount rules record currency p1IsVirtual n | ||||||
|          ,let mbalance = getBalance rules record currency n |          ,let mbalance = getBalance rules record currency n | ||||||
| @ -930,7 +928,7 @@ transactionFromCsvRecord sourcepos rules record = t | |||||||
|                              ,pamount           = fromMaybe missingmixedamt mamount |                              ,pamount           = fromMaybe missingmixedamt mamount | ||||||
|                              ,ptransaction      = Just t |                              ,ptransaction      = Just t | ||||||
|                              ,pbalanceassertion = mkBalanceAssertion rules record <$> mbalance |                              ,pbalanceassertion = mkBalanceAssertion rules record <$> mbalance | ||||||
|                              ,pcomment          = comment |                              ,pcomment          = cmt | ||||||
|                              ,ptype             = accountNamePostingType acct |                              ,ptype             = accountNamePostingType acct | ||||||
|                              } |                              } | ||||||
|          ] |          ] | ||||||
| @ -967,7 +965,7 @@ getAmount rules record currency p1IsVirtual n = | |||||||
|     unnumberedfieldnames = ["amount","amount-in","amount-out"] |     unnumberedfieldnames = ["amount","amount-in","amount-out"] | ||||||
| 
 | 
 | ||||||
|     -- amount field names which can affect this posting |     -- amount field names which can affect this posting | ||||||
|     fieldnames = map (("amount"<> T.pack(show n))<>) ["","-in","-out"] |     fieldnames = map (("amount"<> T.pack (show n))<>) ["","-in","-out"] | ||||||
|                  -- For posting 1, also recognise the old amount/amount-in/amount-out names. |                  -- For posting 1, also recognise the old amount/amount-in/amount-out names. | ||||||
|                  -- For posting 2, the same but only if posting 1 needs balancing. |                  -- For posting 2, the same but only if posting 1 needs balancing. | ||||||
|                  ++ if n==1 || n==2 && not p1IsVirtual then unnumberedfieldnames else [] |                  ++ if n==1 || n==2 && not p1IsVirtual then unnumberedfieldnames else [] | ||||||
| @ -1000,6 +998,37 @@ getAmount rules record currency p1IsVirtual n = | |||||||
|       []      -> Nothing |       []      -> Nothing | ||||||
|       [(f,a)] -> Just $ negateIfOut f a |       [(f,a)] -> Just $ negateIfOut f a | ||||||
|       fs      -> error' . T.unpack . textChomp . T.unlines $  -- PARTIAL: |       fs      -> error' . T.unpack . textChomp . T.unlines $  -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|  |           -- PARTIAL: | ||||||
|         ["in CSV rules:" |         ["in CSV rules:" | ||||||
|         ,"While processing " <> showRecord record |         ,"While processing " <> showRecord record | ||||||
|         ,"while calculating amount for posting " <> T.pack (show n) |         ,"while calculating amount for posting " <> T.pack (show n) | ||||||
| @ -1038,6 +1067,37 @@ getBalance rules record currency n = do | |||||||
| parseAmount :: CsvRules -> CsvRecord -> Text -> Text -> MixedAmount | parseAmount :: CsvRules -> CsvRecord -> Text -> Text -> MixedAmount | ||||||
| parseAmount rules record currency s = | parseAmount rules record currency s = | ||||||
|     either mkerror mixedAmount $  -- PARTIAL: |     either mkerror mixedAmount $  -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|  |       -- PARTIAL: | ||||||
|     runParser (evalStateT (amountp <* eof) journalparsestate) "" $ |     runParser (evalStateT (amountp <* eof) journalparsestate) "" $ | ||||||
|     currency <> simplifySign s |     currency <> simplifySign s | ||||||
|   where |   where | ||||||
| @ -1068,8 +1128,8 @@ parseBalanceAmount rules record currency n s = | |||||||
|                   -- the csv record's line number would be good |                   -- the csv record's line number would be good | ||||||
|   where |   where | ||||||
|     journalparsestate = nulljournal{jparsedecimalmark=parseDecimalMark rules} |     journalparsestate = nulljournal{jparsedecimalmark=parseDecimalMark rules} | ||||||
|     mkerror n s e = error' . T.unpack $ T.unlines |     mkerror n' s' e = error' . T.unpack $ T.unlines | ||||||
|       ["error: could not parse \"" <> s <> "\" as balance"<> T.pack (show n) <> " amount" |       ["error: could not parse \"" <> s' <> "\" as balance"<> T.pack (show n') <> " amount" | ||||||
|       ,showRecord record |       ,showRecord record | ||||||
|       ,showRules rules record |       ,showRules rules record | ||||||
|       -- ,"the default-currency is: "++fromMaybe "unspecified" mdefaultcurrency |       -- ,"the default-currency is: "++fromMaybe "unspecified" mdefaultcurrency | ||||||
| @ -1252,17 +1312,19 @@ replaceCsvFieldReference rules record s = case T.uncons s of | |||||||
| -- column number, ("date" or "1"), from the given CSV record, if such a field exists. | -- column number, ("date" or "1"), from the given CSV record, if such a field exists. | ||||||
| csvFieldValue :: CsvRules -> CsvRecord -> CsvFieldName -> Maybe Text | csvFieldValue :: CsvRules -> CsvRecord -> CsvFieldName -> Maybe Text | ||||||
| csvFieldValue rules record fieldname = do | csvFieldValue rules record fieldname = do | ||||||
|   fieldindex <- if | T.all isDigit fieldname -> readMay $ T.unpack fieldname |   fieldindex <- | ||||||
|                    | otherwise               -> lookup (T.toLower fieldname) $ rcsvfieldindexes rules |     if T.all isDigit fieldname  | ||||||
|  |     then readMay $ T.unpack fieldname | ||||||
|  |     else lookup (T.toLower fieldname) $ rcsvfieldindexes rules | ||||||
|   T.strip <$> atMay record (fieldindex-1) |   T.strip <$> atMay record (fieldindex-1) | ||||||
| 
 | 
 | ||||||
| -- | Parse the date string using the specified date-format, or if unspecified | -- | Parse the date string using the specified date-format, or if unspecified | ||||||
| -- the "simple date" formats (YYYY/MM/DD, YYYY-MM-DD, YYYY.MM.DD, leading | -- the "simple date" formats (YYYY/MM/DD, YYYY-MM-DD, YYYY.MM.DD, leading | ||||||
| -- zeroes optional). | -- zeroes optional). | ||||||
| parseDateWithCustomOrDefaultFormats :: Maybe DateFormat -> Text -> Maybe Day | parseDateWithCustomOrDefaultFormats :: Maybe DateFormat -> Text -> Maybe Day | ||||||
| parseDateWithCustomOrDefaultFormats mformat s = asum $ map parsewith formats | parseDateWithCustomOrDefaultFormats mformat s = asum $ map parsewith' formats | ||||||
|   where |   where | ||||||
|     parsewith = flip (parseTimeM True defaultTimeLocale) (T.unpack s) |     parsewith' = flip (parseTimeM True defaultTimeLocale) (T.unpack s) | ||||||
|     formats = map T.unpack $ maybe |     formats = map T.unpack $ maybe | ||||||
|                ["%Y/%-m/%-d" |                ["%Y/%-m/%-d" | ||||||
|                ,"%Y-%-m-%-d" |                ,"%Y-%-m-%-d" | ||||||
| @ -1299,6 +1361,37 @@ tests_CsvReader = testGroup "CsvReader" [ | |||||||
|    ] |    ] | ||||||
|   ,testGroup "conditionalblockp" [ |   ,testGroup "conditionalblockp" [ | ||||||
|     testCase "space after conditional" $ -- #1120 |     testCase "space after conditional" $ -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|  |        -- #1120 | ||||||
|       parseWithState' defrules conditionalblockp "if a\n account2 b\n \n" @?= |       parseWithState' defrules conditionalblockp "if a\n account2 b\n \n" @?= | ||||||
|         (Right $ CB{cbMatchers=[RecordMatcher None $ toRegexCI' "a"],cbAssignments=[("account2","b")]}) |         (Right $ CB{cbMatchers=[RecordMatcher None $ toRegexCI' "a"],cbAssignments=[("account2","b")]}) | ||||||
| 
 | 
 | ||||||
|  | |||||||
| @ -261,8 +261,8 @@ includedirectivep = do | |||||||
|   prefixedglob <- T.unpack <$> takeWhileP Nothing (/= '\n') -- don't consume newline yet |   prefixedglob <- T.unpack <$> takeWhileP Nothing (/= '\n') -- don't consume newline yet | ||||||
|   parentoff <- getOffset |   parentoff <- getOffset | ||||||
|   parentpos <- getSourcePos |   parentpos <- getSourcePos | ||||||
|   let (mprefix,glob) = splitReaderPrefix prefixedglob |   let (mprefix,glb) = splitReaderPrefix prefixedglob | ||||||
|   paths <- getFilePaths parentoff parentpos glob |   paths <- getFilePaths parentoff parentpos glb | ||||||
|   let prefixedpaths = case mprefix of |   let prefixedpaths = case mprefix of | ||||||
|         Nothing  -> paths |         Nothing  -> paths | ||||||
|         Just fmt -> map ((fmt++":")++) paths |         Just fmt -> map ((fmt++":")++) paths | ||||||
| @ -460,8 +460,8 @@ commoditydirectiveonelinep = do | |||||||
|     string "commodity" |     string "commodity" | ||||||
|     lift skipNonNewlineSpaces1 |     lift skipNonNewlineSpaces1 | ||||||
|     off <- getOffset |     off <- getOffset | ||||||
|     amount <- amountp |     amt <- amountp | ||||||
|     pure $ (off, amount) |     pure $ (off, amt) | ||||||
|   lift skipNonNewlineSpaces |   lift skipNonNewlineSpaces | ||||||
|   _ <- lift followingcommentp |   _ <- lift followingcommentp | ||||||
|   let comm = Commodity{csymbol=acommodity, cformat=Just $ dbg6 "style from commodity directive" astyle} |   let comm = Commodity{csymbol=acommodity, cformat=Just $ dbg6 "style from commodity directive" astyle} | ||||||
| @ -489,8 +489,8 @@ commoditydirectivemultilinep = do | |||||||
|   lift skipNonNewlineSpaces1 |   lift skipNonNewlineSpaces1 | ||||||
|   sym <- lift commoditysymbolp |   sym <- lift commoditysymbolp | ||||||
|   _ <- lift followingcommentp |   _ <- lift followingcommentp | ||||||
|   mformat <- lastMay <$> many (indented $ formatdirectivep sym) |   mfmt <- lastMay <$> many (indented $ formatdirectivep sym) | ||||||
|   let comm = Commodity{csymbol=sym, cformat=mformat} |   let comm = Commodity{csymbol=sym, cformat=mfmt} | ||||||
|   modify' (\j -> j{jcommodities=M.insert sym comm $ jcommodities j}) |   modify' (\j -> j{jcommodities=M.insert sym comm $ jcommodities j}) | ||||||
|   where |   where | ||||||
|     indented = (lift skipNonNewlineSpaces1 >>) |     indented = (lift skipNonNewlineSpaces1 >>) | ||||||
| @ -674,7 +674,7 @@ periodictransactionp = do | |||||||
|   -- first parsing with 'singlespacedtextp', then "re-parsing" with |   -- first parsing with 'singlespacedtextp', then "re-parsing" with | ||||||
|   -- 'periodexprp' saves 'periodexprp' from having to respect the single- |   -- 'periodexprp' saves 'periodexprp' from having to respect the single- | ||||||
|   -- and double-space parsing rules |   -- and double-space parsing rules | ||||||
|   (interval, span) <- lift $ reparseExcerpt periodExcerpt $ do |   (interval, spn) <- lift $ reparseExcerpt periodExcerpt $ do | ||||||
|     pexp <- periodexprp refdate |     pexp <- periodexprp refdate | ||||||
|     (<|>) eof $ do |     (<|>) eof $ do | ||||||
|       offset1 <- getOffset |       offset1 <- getOffset | ||||||
| @ -687,7 +687,7 @@ periodictransactionp = do | |||||||
|     pure pexp |     pure pexp | ||||||
| 
 | 
 | ||||||
|   -- In periodic transactions, the period expression has an additional constraint: |   -- In periodic transactions, the period expression has an additional constraint: | ||||||
|   case checkPeriodicTransactionStartDate interval span periodtxt of |   case checkPeriodicTransactionStartDate interval spn periodtxt of | ||||||
|     Just e -> customFailure $ parseErrorAt off e |     Just e -> customFailure $ parseErrorAt off e | ||||||
|     Nothing -> pure () |     Nothing -> pure () | ||||||
| 
 | 
 | ||||||
| @ -701,7 +701,7 @@ periodictransactionp = do | |||||||
|   return $ nullperiodictransaction{ |   return $ nullperiodictransaction{ | ||||||
|      ptperiodexpr=periodtxt |      ptperiodexpr=periodtxt | ||||||
|     ,ptinterval=interval |     ,ptinterval=interval | ||||||
|     ,ptspan=span |     ,ptspan=spn | ||||||
|     ,ptstatus=status |     ,ptstatus=status | ||||||
|     ,ptcode=code |     ,ptcode=code | ||||||
|     ,ptdescription=description |     ,ptdescription=description | ||||||
| @ -767,7 +767,7 @@ postingphelper isPostingRule mTransactionYear = do | |||||||
|     let (ptype, account') = (accountNamePostingType account, textUnbracket account) |     let (ptype, account') = (accountNamePostingType account, textUnbracket account) | ||||||
|     lift skipNonNewlineSpaces |     lift skipNonNewlineSpaces | ||||||
|     mult <- if isPostingRule then multiplierp else pure False |     mult <- if isPostingRule then multiplierp else pure False | ||||||
|     amount <- optional $ amountpwithmultiplier mult |     amt <- optional $ amountpwithmultiplier mult | ||||||
|     lift skipNonNewlineSpaces |     lift skipNonNewlineSpaces | ||||||
|     massertion <- optional balanceassertionp |     massertion <- optional balanceassertionp | ||||||
|     lift skipNonNewlineSpaces |     lift skipNonNewlineSpaces | ||||||
| @ -777,7 +777,7 @@ postingphelper isPostingRule mTransactionYear = do | |||||||
|             , pdate2=mdate2 |             , pdate2=mdate2 | ||||||
|             , pstatus=status |             , pstatus=status | ||||||
|             , paccount=account' |             , paccount=account' | ||||||
|             , pamount=maybe missingmixedamt mixedAmount amount |             , pamount=maybe missingmixedamt mixedAmount amt | ||||||
|             , pcomment=comment |             , pcomment=comment | ||||||
|             , ptype=ptype |             , ptype=ptype | ||||||
|             , ptags=tags |             , ptags=tags | ||||||
|  | |||||||
| @ -28,7 +28,6 @@ inc.client1   .... .... .. | |||||||
| 
 | 
 | ||||||
| --- ** language | --- ** language | ||||||
| {-# LANGUAGE OverloadedStrings #-} | {-# LANGUAGE OverloadedStrings #-} | ||||||
| {-# LANGUAGE PackageImports #-} |  | ||||||
| 
 | 
 | ||||||
| --- ** exports | --- ** exports | ||||||
| module Hledger.Read.TimedotReader ( | module Hledger.Read.TimedotReader ( | ||||||
| @ -173,7 +172,7 @@ entryp = do | |||||||
|   lift $ optional $ choice [orgheadingprefixp, skipNonNewlineSpaces1] |   lift $ optional $ choice [orgheadingprefixp, skipNonNewlineSpaces1] | ||||||
|   a <- modifiedaccountnamep |   a <- modifiedaccountnamep | ||||||
|   lift skipNonNewlineSpaces |   lift skipNonNewlineSpaces | ||||||
|   hrs <- |   hours <- | ||||||
|     try (lift followingcommentp >> return 0) |     try (lift followingcommentp >> return 0) | ||||||
|     <|> (lift durationp <* |     <|> (lift durationp <* | ||||||
|          (try (lift followingcommentp) <|> (newline >> return ""))) |          (try (lift followingcommentp) <|> (newline >> return ""))) | ||||||
| @ -187,7 +186,7 @@ entryp = do | |||||||
|           tstatus    = Cleared, |           tstatus    = Cleared, | ||||||
|           tpostings  = [ |           tpostings  = [ | ||||||
|             nullposting{paccount=a |             nullposting{paccount=a | ||||||
|                       ,pamount=mixedAmount $ nullamt{acommodity=c, aquantity=hrs, astyle=s} |                       ,pamount=mixedAmount $ nullamt{acommodity=c, aquantity=hours, astyle=s} | ||||||
|                       ,ptype=VirtualPosting |                       ,ptype=VirtualPosting | ||||||
|                       ,ptransaction=Just t |                       ,ptransaction=Just t | ||||||
|                       } |                       } | ||||||
|  | |||||||
| @ -245,8 +245,8 @@ accountTransactionsReportByCommodity tr = | |||||||
| -- balance amount) components that don't involve the specified | -- balance amount) components that don't involve the specified | ||||||
| -- commodity. Other item fields such as the transaction are left unchanged. | -- commodity. Other item fields such as the transaction are left unchanged. | ||||||
| filterAccountTransactionsReportByCommodity :: CommoditySymbol -> AccountTransactionsReport -> AccountTransactionsReport | filterAccountTransactionsReportByCommodity :: CommoditySymbol -> AccountTransactionsReport -> AccountTransactionsReport | ||||||
| filterAccountTransactionsReportByCommodity c = | filterAccountTransactionsReportByCommodity comm = | ||||||
|     fixTransactionsReportItemBalances . concatMap (filterTransactionsReportItemByCommodity c) |     fixTransactionsReportItemBalances . concatMap (filterTransactionsReportItemByCommodity comm) | ||||||
|   where |   where | ||||||
|     filterTransactionsReportItemByCommodity c (t,t2,s,o,a,bal) |     filterTransactionsReportItemByCommodity c (t,t2,s,o,a,bal) | ||||||
|       | c `elem` cs = [item'] |       | c `elem` cs = [item'] | ||||||
| @ -261,9 +261,9 @@ filterAccountTransactionsReportByCommodity c = | |||||||
|     fixTransactionsReportItemBalances items = reverse $ i:(go startbal is) |     fixTransactionsReportItemBalances items = reverse $ i:(go startbal is) | ||||||
|       where |       where | ||||||
|         i:is = reverse items |         i:is = reverse items | ||||||
|         startbal = filterMixedAmountByCommodity c $ triBalance i |         startbal = filterMixedAmountByCommodity comm $ triBalance i | ||||||
|         go _ [] = [] |         go _ [] = [] | ||||||
|         go bal ((t,t2,s,o,amt,_):is) = (t,t2,s,o,amt,bal'):go bal' is |         go bal ((t,t2,s,o,amt,_):is') = (t,t2,s,o,amt,bal'):go bal' is' | ||||||
|           where bal' = bal `maPlus` amt |           where bal' = bal `maPlus` amt | ||||||
| 
 | 
 | ||||||
| -- tests | -- tests | ||||||
|  | |||||||
| @ -133,17 +133,17 @@ journalAddBudgetGoalTransactions bopts ropts reportspan j = | |||||||
|             Just d  -> Just d' |             Just d  -> Just d' | ||||||
|               where |               where | ||||||
|                 -- the interval and any date span of the periodic transaction with longest period |                 -- the interval and any date span of the periodic transaction with longest period | ||||||
|                 (interval, span) = |                 (intervl, spn) = | ||||||
|                   case budgetpts of |                   case budgetpts of | ||||||
|                     []  -> (Days 1, nulldatespan) |                     []  -> (Days 1, nulldatespan) | ||||||
|                     pts -> (ptinterval pt, ptspan pt) |                     pts -> (ptinterval pt, ptspan pt) | ||||||
|                       where pt = maximumBy (comparing ptinterval) pts  -- PARTIAL: maximumBy won't fail |                       where pt = maximumBy (comparing ptinterval) pts  -- PARTIAL: maximumBy won't fail | ||||||
|                 -- the natural start of this interval on or before the journal/report start |                 -- the natural start of this interval on or before the journal/report start | ||||||
|                 intervalstart = intervalStartBefore interval d |                 intervalstart = intervalStartBefore intervl d | ||||||
|                 -- the natural interval start before the journal/report start, |                 -- the natural interval start before the journal/report start, | ||||||
|                 -- or the rule-specified start if later, |                 -- or the rule-specified start if later, | ||||||
|                 -- but no later than the journal/report start. |                 -- but no later than the journal/report start. | ||||||
|                 d' = min d $ maybe intervalstart (max intervalstart) $ spanStart span |                 d' = min d $ maybe intervalstart (max intervalstart) $ spanStart spn | ||||||
| 
 | 
 | ||||||
|     -- select periodic transactions matching a pattern |     -- select periodic transactions matching a pattern | ||||||
|     -- (the argument of the (final) --budget option). |     -- (the argument of the (final) --budget option). | ||||||
| @ -308,11 +308,11 @@ budgetReportAsTable | |||||||
|       | transpose_ = \(Tab.Table rh ch vals) -> Tab.Table ch rh (transpose vals) |       | transpose_ = \(Tab.Table rh ch vals) -> Tab.Table ch rh (transpose vals) | ||||||
|       | otherwise  = id |       | otherwise  = id | ||||||
| 
 | 
 | ||||||
|     (accts, rows, totalrows) = (accts, prependcs itemscs (padcells texts), prependcs trcs (padtr trtexts)) |     (accts, rows, totalrows) = (accts', prependcs itemscs (padcells texts), prependcs trcs (padtr trtexts)) | ||||||
|       where |       where | ||||||
|         shownitems :: [[(AccountName, WideBuilder, BudgetDisplayRow)]] |         shownitems :: [[(AccountName, WideBuilder, BudgetDisplayRow)]] | ||||||
|         shownitems = (fmap (\i -> fmap (\(cs, cvals) -> (renderacct i, cs, cvals)) . showrow $ rowToBudgetCells i) items) |         shownitems = (fmap (\i -> fmap (\(cs, cvals) -> (renderacct i, cs, cvals)) . showrow $ rowToBudgetCells i) items) | ||||||
|         (accts, itemscs, texts) = unzip3 $ concat shownitems |         (accts', itemscs, texts) = unzip3 $ concat shownitems | ||||||
| 
 | 
 | ||||||
|         showntr    :: [[(WideBuilder, BudgetDisplayRow)]] |         showntr    :: [[(WideBuilder, BudgetDisplayRow)]] | ||||||
|         showntr    = [showrow $ rowToBudgetCells tr] |         showntr    = [showrow $ rowToBudgetCells tr] | ||||||
| @ -381,10 +381,8 @@ budgetReportAsTable | |||||||
|       where |       where | ||||||
|         actual' = fromMaybe nullmixedamt actual |         actual' = fromMaybe nullmixedamt actual | ||||||
| 
 | 
 | ||||||
|         budgetAndPerc b = uncurry zip |         budgetAndPerc b =  | ||||||
|           ( showmixed b |           zip (showmixed b) (fmap (wbFromText . T.pack . show . roundTo 0) <$> percbudget actual' b) | ||||||
|           , fmap (wbFromText . T.pack . show . roundTo 0) <$> percbudget actual' b |  | ||||||
|           ) |  | ||||||
| 
 | 
 | ||||||
|         full |         full | ||||||
|           | Just b <- mbudget = Just <$> budgetAndPerc b |           | Just b <- mbudget = Just <$> budgetAndPerc b | ||||||
| @ -397,9 +395,9 @@ budgetReportAsTable | |||||||
|             (TB.fromText . flip T.replicate " " $ actualwidth - w) <> b |             (TB.fromText . flip T.replicate " " $ actualwidth - w) <> b | ||||||
| 
 | 
 | ||||||
|         (totalpercentwidth, totalbudgetwidth) = |         (totalpercentwidth, totalbudgetwidth) = | ||||||
|           let totalpercentwidth = if percentwidth == 0 then 0 else percentwidth + 5 |           let totalpercentwidth' = if percentwidth == 0 then 0 else percentwidth + 5 | ||||||
|            in ( totalpercentwidth |            in ( totalpercentwidth' | ||||||
|               , if budgetwidth == 0 then 0 else budgetwidth + totalpercentwidth + 3 |               , if budgetwidth == 0 then 0 else budgetwidth + totalpercentwidth' + 3 | ||||||
|               ) |               ) | ||||||
| 
 | 
 | ||||||
|         -- | Display a padded budget string |         -- | Display a padded budget string | ||||||
| @ -446,14 +444,20 @@ budgetReportAsCsv | |||||||
|   (PeriodicReport colspans items tr) |   (PeriodicReport colspans items tr) | ||||||
|   = (if transpose_ then transpose else id) $ |   = (if transpose_ then transpose else id) $ | ||||||
| 
 | 
 | ||||||
|  |   -- heading row | ||||||
|  |    | ||||||
|  | 
 | ||||||
|   -- heading row |   -- heading row | ||||||
|   ("Account" : |   ("Account" : | ||||||
|   ["Commodity" | layout_ == LayoutBare ] |   ["Commodity" | layout_ == LayoutBare ] | ||||||
|    ++ concatMap (\span -> [showDateSpan span, "budget"]) colspans |    ++ concatMap (\spn -> [showDateSpan spn, "budget"]) colspans | ||||||
|    ++ concat [["Total"  ,"budget"] | row_total_] |    ++ concat [["Total"  ,"budget"] | row_total_] | ||||||
|    ++ concat [["Average","budget"] | average_] |    ++ concat [["Average","budget"] | average_] | ||||||
|   ) : |   ) : | ||||||
| 
 | 
 | ||||||
|  |   -- account rows | ||||||
|  |    | ||||||
|  | 
 | ||||||
|   -- account rows |   -- account rows | ||||||
|   concatMap (rowAsTexts prrFullName) items |   concatMap (rowAsTexts prrFullName) items | ||||||
| 
 | 
 | ||||||
| @ -461,23 +465,23 @@ budgetReportAsCsv | |||||||
|   ++ concat [ rowAsTexts (const "Total:") tr | not no_total_ ] |   ++ concat [ rowAsTexts (const "Total:") tr | not no_total_ ] | ||||||
| 
 | 
 | ||||||
|   where |   where | ||||||
|     flattentuples abs = concat [[a,b] | (a,b) <- abs] |     flattentuples tups = concat [[a,b] | (a,b) <- tups] | ||||||
|     showNorm = maybe "" (wbToText . showMixedAmountB oneLine) |     showNorm = maybe "" (wbToText . showMixedAmountB oneLine) | ||||||
| 
 | 
 | ||||||
|     rowAsTexts :: (PeriodicReportRow a BudgetCell -> Text) |     rowAsTexts :: (PeriodicReportRow a BudgetCell -> Text) | ||||||
|                -> PeriodicReportRow a BudgetCell |                -> PeriodicReportRow a BudgetCell | ||||||
|                -> [[Text]] |                -> [[Text]] | ||||||
|     rowAsTexts render row@(PeriodicReportRow _ as (rowtot,budgettot) (rowavg, budgetavg)) |     rowAsTexts render row@(PeriodicReportRow _ as (rowtot,budgettot) (rowavg, budgetavg)) | ||||||
|       | layout_ /= LayoutBare = [render row : fmap showNorm all] |       | layout_ /= LayoutBare = [render row : fmap showNorm vals] | ||||||
|       | otherwise = |       | otherwise = | ||||||
|             joinNames . zipWith (:) cs  -- add symbols and names |             joinNames . zipWith (:) cs  -- add symbols and names | ||||||
|           . transpose                   -- each row becomes a list of Text quantities |           . transpose                   -- each row becomes a list of Text quantities | ||||||
|           . fmap (fmap wbToText . showMixedAmountLinesB oneLine{displayOrder=Just cs, displayMinWidth=Nothing} |           . fmap (fmap wbToText . showMixedAmountLinesB oneLine{displayOrder=Just cs, displayMinWidth=Nothing} | ||||||
|                  .fromMaybe nullmixedamt) |                  .fromMaybe nullmixedamt) | ||||||
|           $ all |           $ vals | ||||||
|       where |       where | ||||||
|         cs = S.toList . foldl' S.union mempty . fmap maCommodities $ catMaybes all |         cs = S.toList . foldl' S.union mempty . fmap maCommodities $ catMaybes vals | ||||||
|         all = flattentuples as |         vals = flattentuples as | ||||||
|             ++ concat [[rowtot, budgettot] | row_total_] |             ++ concat [[rowtot, budgettot] | row_total_] | ||||||
|             ++ concat [[rowavg, budgetavg] | average_] |             ++ concat [[rowavg, budgetavg] | average_] | ||||||
| 
 | 
 | ||||||
|  | |||||||
| @ -343,7 +343,7 @@ calculateReportMatrix rspec@ReportSpec{_rsReportOpts=ropts} j priceoracle startb | |||||||
|     avalue = acctApplyBoth . mixedAmountApplyValuationAfterSumFromOptsWith ropts j priceoracle |     avalue = acctApplyBoth . mixedAmountApplyValuationAfterSumFromOptsWith ropts j priceoracle | ||||||
|     acctApplyBoth f a = a{aibalance = f $ aibalance a, aebalance = f $ aebalance a} |     acctApplyBoth f a = a{aibalance = f $ aibalance a, aebalance = f $ aebalance a} | ||||||
|     historicalDate = minimumMay $ mapMaybe spanStart colspans |     historicalDate = minimumMay $ mapMaybe spanStart colspans | ||||||
|     zeros = M.fromList [(span, nullacct) | span <- colspans] |     zeros = M.fromList [(spn, nullacct) | spn <- colspans] | ||||||
|     colspans = map fst colps |     colspans = map fst colps | ||||||
| 
 | 
 | ||||||
| 
 | 
 | ||||||
| @ -406,11 +406,11 @@ displayedAccounts :: ReportSpec | |||||||
|                   -> HashMap AccountName (Map DateSpan Account) |                   -> HashMap AccountName (Map DateSpan Account) | ||||||
|                   -> HashMap AccountName DisplayName |                   -> HashMap AccountName DisplayName | ||||||
| displayedAccounts ReportSpec{_rsQuery=query,_rsReportOpts=ropts} unelidableaccts valuedaccts | displayedAccounts ReportSpec{_rsQuery=query,_rsReportOpts=ropts} unelidableaccts valuedaccts | ||||||
|     | depth == 0 = HM.singleton "..." $ DisplayName "..." "..." 1 |     | qdepth == 0 = HM.singleton "..." $ DisplayName "..." "..." 1 | ||||||
|     | otherwise  = HM.mapWithKey (\a _ -> displayedName a) displayedAccts |     | otherwise  = HM.mapWithKey (\a _ -> displayedName a) displayedAccts | ||||||
|   where |   where | ||||||
|     -- Accounts which are to be displayed |     -- Accounts which are to be displayed | ||||||
|     displayedAccts = (if depth == 0 then id else HM.filterWithKey keep) valuedaccts |     displayedAccts = (if qdepth == 0 then id else HM.filterWithKey keep) valuedaccts | ||||||
|       where |       where | ||||||
|         keep name amts = isInteresting name amts || name `HM.member` interestingParents |         keep name amts = isInteresting name amts || name `HM.member` interestingParents | ||||||
| 
 | 
 | ||||||
| @ -429,7 +429,7 @@ displayedAccounts ReportSpec{_rsQuery=query,_rsReportOpts=ropts} unelidableaccts | |||||||
| 
 | 
 | ||||||
|     -- Accounts interesting for their own sake |     -- Accounts interesting for their own sake | ||||||
|     isInteresting name amts = |     isInteresting name amts = | ||||||
|         d <= depth                                 -- Throw out anything too deep |         d <= qdepth                                  -- Throw out anything too deep | ||||||
|         && ( name `Set.member` unelidableaccts     -- Unelidable accounts should be kept unless too deep |         && ( name `Set.member` unelidableaccts     -- Unelidable accounts should be kept unless too deep | ||||||
|            ||(empty_ ropts && keepWhenEmpty amts)  -- Keep empty accounts when called with --empty |            ||(empty_ ropts && keepWhenEmpty amts)  -- Keep empty accounts when called with --empty | ||||||
|            || not (isZeroRow balance amts)         -- Keep everything with a non-zero balance in the row |            || not (isZeroRow balance amts)         -- Keep everything with a non-zero balance in the row | ||||||
| @ -440,7 +440,7 @@ displayedAccounts ReportSpec{_rsQuery=query,_rsReportOpts=ropts} unelidableaccts | |||||||
|             ALFlat -> const True          -- Keep all empty accounts in flat mode |             ALFlat -> const True          -- Keep all empty accounts in flat mode | ||||||
|             ALTree -> all (null . asubs)  -- Keep only empty leaves in tree mode |             ALTree -> all (null . asubs)  -- Keep only empty leaves in tree mode | ||||||
|         balance = maybeStripPrices . case accountlistmode_ ropts of |         balance = maybeStripPrices . case accountlistmode_ ropts of | ||||||
|             ALTree | d == depth -> aibalance |             ALTree | d == qdepth -> aibalance | ||||||
|             _                    -> aebalance |             _                    -> aebalance | ||||||
|           where maybeStripPrices = if conversionop_ ropts == Just NoConversionOp then id else mixedAmountStripPrices |           where maybeStripPrices = if conversionop_ ropts == Just NoConversionOp then id else mixedAmountStripPrices | ||||||
| 
 | 
 | ||||||
| @ -453,7 +453,7 @@ displayedAccounts ReportSpec{_rsQuery=query,_rsReportOpts=ropts} unelidableaccts | |||||||
|         minSubs = if no_elide_ ropts then 1 else 2 |         minSubs = if no_elide_ ropts then 1 else 2 | ||||||
| 
 | 
 | ||||||
|     isZeroRow balance = all (mixedAmountLooksZero . balance) |     isZeroRow balance = all (mixedAmountLooksZero . balance) | ||||||
|     depth = fromMaybe maxBound $  queryDepth query |     qdepth = fromMaybe maxBound $ queryDepth query | ||||||
|     numSubs = subaccountTallies . HM.keys $ HM.filterWithKey isInteresting valuedaccts |     numSubs = subaccountTallies . HM.keys $ HM.filterWithKey isInteresting valuedaccts | ||||||
| 
 | 
 | ||||||
| -- | Sort the rows by amount or by account declaration order. | -- | Sort the rows by amount or by account declaration order. | ||||||
| @ -534,10 +534,10 @@ transposeMap :: [(DateSpan, HashMap AccountName a)] | |||||||
|              -> HashMap AccountName (Map DateSpan a) |              -> HashMap AccountName (Map DateSpan a) | ||||||
| transposeMap = foldr (uncurry addSpan) mempty | transposeMap = foldr (uncurry addSpan) mempty | ||||||
|   where |   where | ||||||
|     addSpan span acctmap seen = HM.foldrWithKey (addAcctSpan span) seen acctmap |     addSpan spn acctmap seen = HM.foldrWithKey (addAcctSpan spn) seen acctmap | ||||||
| 
 | 
 | ||||||
|     addAcctSpan span acct a = HM.alter f acct |     addAcctSpan spn acct a = HM.alter f acct | ||||||
|       where f = Just . M.insert span a . fromMaybe mempty |       where f = Just . M.insert spn a . fromMaybe mempty | ||||||
| 
 | 
 | ||||||
| -- | A sorting helper: sort a list of things (eg report rows) keyed by account name | -- | A sorting helper: sort a list of things (eg report rows) keyed by account name | ||||||
| -- to match the provided ordering of those same account names. | -- to match the provided ordering of those same account names. | ||||||
|  | |||||||
| @ -73,8 +73,8 @@ postingsReport rspec@ReportSpec{_rsReportOpts=ropts@ReportOpts{..}} j = items | |||||||
| 
 | 
 | ||||||
|       -- Postings, or summary postings with their subperiod's end date, to be displayed. |       -- Postings, or summary postings with their subperiod's end date, to be displayed. | ||||||
|       displayps :: [(Posting, Maybe Period)] |       displayps :: [(Posting, Maybe Period)] | ||||||
|         | multiperiod = [(p, Just period) | (p, period) <- summariseps reportps] |         | multiperiod = [(p', Just period') | (p', period') <- summariseps reportps] | ||||||
|         | otherwise   = [(p, Nothing) | p <- reportps] |         | otherwise   = [(p', Nothing) | p' <- reportps] | ||||||
|         where |         where | ||||||
|           summariseps = summarisePostingsByInterval whichdate mdepth showempty colspans |           summariseps = summarisePostingsByInterval whichdate mdepth showempty colspans | ||||||
|           showempty = empty_ || average_ |           showempty = empty_ || average_ | ||||||
| @ -189,9 +189,9 @@ summarisePostingsByInterval wd mdepth showempty colspans = | |||||||
| -- with 0 amount. | -- with 0 amount. | ||||||
| -- | -- | ||||||
| summarisePostingsInDateSpan :: DateSpan -> WhichDate -> Maybe Int -> Bool -> [Posting] -> [SummaryPosting] | summarisePostingsInDateSpan :: DateSpan -> WhichDate -> Maybe Int -> Bool -> [Posting] -> [SummaryPosting] | ||||||
| summarisePostingsInDateSpan span@(DateSpan b e) wd mdepth showempty ps | summarisePostingsInDateSpan spn@(DateSpan b e) wd mdepth showempty ps | ||||||
|   | null ps && (isNothing b || isNothing e) = [] |   | null ps && (isNothing b || isNothing e) = [] | ||||||
|   | null ps && showempty = [(summaryp, dateSpanAsPeriod span)] |   | null ps && showempty = [(summaryp, dateSpanAsPeriod spn)] | ||||||
|   | otherwise = summarypes |   | otherwise = summarypes | ||||||
|   where |   where | ||||||
|     postingdate = if wd == PrimaryDate then postingDate else postingDate2 |     postingdate = if wd == PrimaryDate then postingDate else postingDate2 | ||||||
| @ -200,14 +200,14 @@ summarisePostingsInDateSpan span@(DateSpan b e) wd mdepth showempty ps | |||||||
|     clippedanames = nub $ map (clipAccountName mdepth) anames |     clippedanames = nub $ map (clipAccountName mdepth) anames | ||||||
|     summaryps | mdepth == Just 0 = [summaryp{paccount="...",pamount=sumPostings ps}] |     summaryps | mdepth == Just 0 = [summaryp{paccount="...",pamount=sumPostings ps}] | ||||||
|               | otherwise        = [summaryp{paccount=a,pamount=balance a} | a <- clippedanames] |               | otherwise        = [summaryp{paccount=a,pamount=balance a} | a <- clippedanames] | ||||||
|     summarypes = map (, dateSpanAsPeriod span) $ (if showempty then id else filter (not . mixedAmountLooksZero . pamount)) summaryps |     summarypes = map (, dateSpanAsPeriod spn) $ (if showempty then id else filter (not . mixedAmountLooksZero . pamount)) summaryps | ||||||
|     anames = nubSort $ map paccount ps |     anames = nubSort $ map paccount ps | ||||||
|     -- aggregate balances by account, like ledgerFromJournal, then do depth-clipping |     -- aggregate balances by account, like ledgerFromJournal, then do depth-clipping | ||||||
|     accts = accountsFromPostings ps |     accts = accountsFromPostings ps | ||||||
|     balance a = maybe nullmixedamt bal $ lookupAccount a accts |     balance a = maybe nullmixedamt bal $ lookupAccount a accts | ||||||
|       where |       where | ||||||
|         bal = if isclipped a then aibalance else aebalance |         bal = if isclipped a then aibalance else aebalance | ||||||
|         isclipped a = maybe False (accountNameLevel a >=) mdepth |         isclipped a' = maybe False (accountNameLevel a' >=) mdepth | ||||||
| 
 | 
 | ||||||
| negatePostingAmount :: Posting -> Posting | negatePostingAmount :: Posting -> Posting | ||||||
| negatePostingAmount = postingTransformAmount negate | negatePostingAmount = postingTransformAmount negate | ||||||
|  | |||||||
| @ -292,8 +292,8 @@ defreportspec = ReportSpec | |||||||
| 
 | 
 | ||||||
| -- | Set the default ConversionOp. | -- | Set the default ConversionOp. | ||||||
| setDefaultConversionOp :: ConversionOp -> ReportSpec -> ReportSpec | setDefaultConversionOp :: ConversionOp -> ReportSpec -> ReportSpec | ||||||
| setDefaultConversionOp def rspec@ReportSpec{_rsReportOpts=ropts} = | setDefaultConversionOp defop rspec@ReportSpec{_rsReportOpts=ropts} = | ||||||
|     rspec{_rsReportOpts=ropts{conversionop_=conversionop_ ropts <|> Just def}} |     rspec{_rsReportOpts=ropts{conversionop_=conversionop_ ropts <|> Just defop}} | ||||||
| 
 | 
 | ||||||
| accountlistmodeopt :: RawOpts -> AccountListMode | accountlistmodeopt :: RawOpts -> AccountListMode | ||||||
| accountlistmodeopt = | accountlistmodeopt = | ||||||
| @ -360,7 +360,7 @@ layoutopt rawopts = fromMaybe (LayoutWide Nothing) $ layout <|> column | |||||||
|         (s,n) = break (==',') $ map toLower opt |         (s,n) = break (==',') $ map toLower opt | ||||||
|         w = case drop 1 n of |         w = case drop 1 n of | ||||||
|               "" -> Nothing |               "" -> Nothing | ||||||
|               c | Just w <- readMay c -> Just w |               c | Just w' <- readMay c -> Just w' | ||||||
|               _ -> usageError "width in --layout=wide,WIDTH must be an integer" |               _ -> usageError "width in --layout=wide,WIDTH must be an integer" | ||||||
| 
 | 
 | ||||||
|         err = usageError "--layout's argument should be \"wide[,WIDTH]\", \"tall\", \"bare\", or \"tidy\"" |         err = usageError "--layout's argument should be \"wide[,WIDTH]\", \"tall\", \"bare\", or \"tidy\"" | ||||||
| @ -390,14 +390,14 @@ periodFromRawOpts d rawopts = | |||||||
| beginDatesFromRawOpts :: Day -> RawOpts -> [Day] | beginDatesFromRawOpts :: Day -> RawOpts -> [Day] | ||||||
| beginDatesFromRawOpts d = collectopts (begindatefromrawopt d) | beginDatesFromRawOpts d = collectopts (begindatefromrawopt d) | ||||||
|   where |   where | ||||||
|     begindatefromrawopt d (n,v) |     begindatefromrawopt d' (n,v) | ||||||
|       | n == "begin" = |       | n == "begin" = | ||||||
|           either (\e -> usageError $ "could not parse "++n++" date: "++customErrorBundlePretty e) Just $ |           either (\e -> usageError $ "could not parse "++n++" date: "++customErrorBundlePretty e) Just $ | ||||||
|           fixSmartDateStrEither' d (T.pack v) |           fixSmartDateStrEither' d' (T.pack v) | ||||||
|       | n == "period" = |       | n == "period" = | ||||||
|         case |         case | ||||||
|           either (\e -> usageError $ "could not parse period option: "++customErrorBundlePretty e) id $ |           either (\e -> usageError $ "could not parse period option: "++customErrorBundlePretty e) id $ | ||||||
|           parsePeriodExpr d (stripquotes $ T.pack v) |           parsePeriodExpr d' (stripquotes $ T.pack v) | ||||||
|         of |         of | ||||||
|           (_, DateSpan (Just b) _) -> Just b |           (_, DateSpan (Just b) _) -> Just b | ||||||
|           _                        -> Nothing |           _                        -> Nothing | ||||||
| @ -408,14 +408,14 @@ beginDatesFromRawOpts d = collectopts (begindatefromrawopt d) | |||||||
| endDatesFromRawOpts :: Day -> RawOpts -> [Day] | endDatesFromRawOpts :: Day -> RawOpts -> [Day] | ||||||
| endDatesFromRawOpts d = collectopts (enddatefromrawopt d) | endDatesFromRawOpts d = collectopts (enddatefromrawopt d) | ||||||
|   where |   where | ||||||
|     enddatefromrawopt d (n,v) |     enddatefromrawopt d' (n,v) | ||||||
|       | n == "end" = |       | n == "end" = | ||||||
|           either (\e -> usageError $ "could not parse "++n++" date: "++customErrorBundlePretty e) Just $ |           either (\e -> usageError $ "could not parse "++n++" date: "++customErrorBundlePretty e) Just $ | ||||||
|           fixSmartDateStrEither' d (T.pack v) |           fixSmartDateStrEither' d' (T.pack v) | ||||||
|       | n == "period" = |       | n == "period" = | ||||||
|         case |         case | ||||||
|           either (\e -> usageError $ "could not parse period option: "++customErrorBundlePretty e) id $ |           either (\e -> usageError $ "could not parse period option: "++customErrorBundlePretty e) id $ | ||||||
|           parsePeriodExpr d (stripquotes $ T.pack v) |           parsePeriodExpr d' (stripquotes $ T.pack v) | ||||||
|         of |         of | ||||||
|           (_, DateSpan _ (Just e)) -> Just e |           (_, DateSpan _ (Just e)) -> Just e | ||||||
|           _                        -> Nothing |           _                        -> Nothing | ||||||
| @ -589,12 +589,12 @@ journalApplyValuationFromOptsWith rspec@ReportSpec{_rsReportOpts=ropts} j priceo | |||||||
|       CalcGain -> journalMapPostings (\p -> postingTransformAmount (gain p) p) j |       CalcGain -> journalMapPostings (\p -> postingTransformAmount (gain p) p) j | ||||||
|       _        -> journalMapPostings (\p -> postingTransformAmount (valuation p) p) $ costing j |       _        -> journalMapPostings (\p -> postingTransformAmount (valuation p) p) $ costing j | ||||||
|   where |   where | ||||||
|     valuation p = maybe id (mixedAmountApplyValuation priceoracle styles (periodEnd p) (_rsDay rspec) (postingDate p)) (value_ ropts) |     valuation p = maybe id (mixedAmountApplyValuation priceoracle styles (postingperiodend p) (_rsDay rspec) (postingDate p)) (value_ ropts) | ||||||
|     gain      p = maybe id (mixedAmountApplyGain      priceoracle styles (periodEnd p) (_rsDay rspec) (postingDate p)) (value_ ropts) |     gain      p = maybe id (mixedAmountApplyGain      priceoracle styles (postingperiodend p) (_rsDay rspec) (postingDate p)) (value_ ropts) | ||||||
|     costing     = journalToCost (fromMaybe NoConversionOp $ conversionop_ ropts) |     costing     = journalToCost (fromMaybe NoConversionOp $ conversionop_ ropts) | ||||||
| 
 | 
 | ||||||
|     -- Find the end of the period containing this posting |     -- Find the end of the period containing this posting | ||||||
|     periodEnd  = addDays (-1) . fromMaybe err . mPeriodEnd . postingDateOrDate2 (whichDate ropts) |     postingperiodend  = addDays (-1) . fromMaybe err . mPeriodEnd . postingDateOrDate2 (whichDate ropts) | ||||||
|     mPeriodEnd = case interval_ ropts of |     mPeriodEnd = case interval_ ropts of | ||||||
|         NoInterval -> const . spanEnd . fst $ reportSpan j rspec |         NoInterval -> const . spanEnd . fst $ reportSpan j rspec | ||||||
|         _          -> spanEnd <=< latestSpanContaining (historical : spans) |         _          -> spanEnd <=< latestSpanContaining (historical : spans) | ||||||
| @ -611,11 +611,11 @@ mixedAmountApplyValuationAfterSumFromOptsWith ropts j priceoracle = | |||||||
|     case valuationAfterSum ropts of |     case valuationAfterSum ropts of | ||||||
|         Just mc -> case balancecalc_ ropts of |         Just mc -> case balancecalc_ ropts of | ||||||
|             CalcGain -> gain mc |             CalcGain -> gain mc | ||||||
|             _        -> \span -> valuation mc span . costing |             _        -> \spn -> valuation mc spn . costing | ||||||
|         Nothing      -> const id |         Nothing      -> const id | ||||||
|   where |   where | ||||||
|     valuation mc span = mixedAmountValueAtDate priceoracle styles mc (maybe err (addDays (-1)) $ spanEnd span) |     valuation mc spn = mixedAmountValueAtDate priceoracle styles mc (maybe err (addDays (-1)) $ spanEnd spn) | ||||||
|     gain mc span = mixedAmountGainAtDate priceoracle styles mc (maybe err (addDays (-1)) $ spanEnd span) |     gain mc spn = mixedAmountGainAtDate priceoracle styles mc (maybe err (addDays (-1)) $ spanEnd spn) | ||||||
|     costing = case fromMaybe NoConversionOp $ conversionop_ ropts of |     costing = case fromMaybe NoConversionOp $ conversionop_ ropts of | ||||||
|         NoConversionOp -> id |         NoConversionOp -> id | ||||||
|         ToCost         -> styleMixedAmount styles . mixedAmountCost |         ToCost         -> styleMixedAmount styles . mixedAmountCost | ||||||
| @ -809,6 +809,8 @@ class HasReportOptsNoUpdate a => HasReportOpts a where | |||||||
|     reportOpts = reportOptsNoUpdate |     reportOpts = reportOptsNoUpdate | ||||||
|     {-# INLINE reportOpts #-} |     {-# INLINE reportOpts #-} | ||||||
| 
 | 
 | ||||||
|  |     -- XXX these names are a bit clashy | ||||||
|  | 
 | ||||||
|     period :: ReportableLens' a Period |     period :: ReportableLens' a Period | ||||||
|     period = reportOpts.periodNoUpdate |     period = reportOpts.periodNoUpdate | ||||||
|     {-# INLINE period #-} |     {-# INLINE period #-} | ||||||
|  | |||||||
| @ -183,7 +183,7 @@ readFileOrStdinPortably f = openFileOrStdin f ReadMode >>= readHandlePortably | |||||||
|   where |   where | ||||||
|     openFileOrStdin :: String -> IOMode -> IO Handle |     openFileOrStdin :: String -> IOMode -> IO Handle | ||||||
|     openFileOrStdin "-" _ = return stdin |     openFileOrStdin "-" _ = return stdin | ||||||
|     openFileOrStdin f m   = openFile f m |     openFileOrStdin f' m   = openFile f' m | ||||||
| 
 | 
 | ||||||
| readHandlePortably :: Handle -> IO Text | readHandlePortably :: Handle -> IO Text | ||||||
| readHandlePortably h = do | readHandlePortably h = do | ||||||
| @ -225,9 +225,9 @@ sequence' ms = do | |||||||
|   return (h []) |   return (h []) | ||||||
|   where |   where | ||||||
|     go h [] = return h |     go h [] = return h | ||||||
|     go h (m:ms) = do |     go h (m:ms') = do | ||||||
|       x <- m |       x <- m | ||||||
|       go (h . (x :)) ms |       go (h . (x :)) ms' | ||||||
| 
 | 
 | ||||||
| -- | Like mapM but uses sequence'. | -- | Like mapM but uses sequence'. | ||||||
| {-# INLINABLE mapM' #-} | {-# INLINABLE mapM' #-} | ||||||
| @ -339,7 +339,7 @@ makeHledgerClassyLenses x = flip makeLensesWith x $ classyRules | |||||||
|     -- HasReportOpts class with some special behaviour. We therefore give the |     -- HasReportOpts class with some special behaviour. We therefore give the | ||||||
|     -- basic lenses a special NoUpdate name to avoid conflicts. |     -- basic lenses a special NoUpdate name to avoid conflicts. | ||||||
|     className "ReportOpts" = Just (mkName "HasReportOptsNoUpdate", mkName "reportOptsNoUpdate") |     className "ReportOpts" = Just (mkName "HasReportOptsNoUpdate", mkName "reportOptsNoUpdate") | ||||||
|     className (x:xs)       = Just (mkName ("Has" ++ x:xs), mkName (toLower x : xs)) |     className (x':xs)       = Just (mkName ("Has" ++ x':xs), mkName (toLower x' : xs)) | ||||||
|     className []           = Nothing |     className []           = Nothing | ||||||
| 
 | 
 | ||||||
|     -- Fields of ReportOpts which need to update the Query when they are updated. |     -- Fields of ReportOpts which need to update the Query when they are updated. | ||||||
|  | |||||||
| @ -99,11 +99,11 @@ instance Show Regexp where | |||||||
|                              RegexpCI _ _ -> showString "RegexpCI " |                              RegexpCI _ _ -> showString "RegexpCI " | ||||||
| 
 | 
 | ||||||
| instance Read Regexp where | instance Read Regexp where | ||||||
|   readsPrec d r =  readParen (d > app_prec) (\r -> [(toRegexCI' m,t) | |   readsPrec d r =  readParen (d > app_prec) (\r' -> [(toRegexCI' m,t) | | ||||||
|                                                     ("RegexCI",s) <- lex r, |                                                     ("RegexCI",s) <- lex r', | ||||||
|                                                     (m,t) <- readsPrec (app_prec+1) s]) r |                                                     (m,t) <- readsPrec (app_prec+1) s]) r | ||||||
|                 ++ readParen (d > app_prec) (\r -> [(toRegex' m, t) | |                 ++ readParen (d > app_prec) (\r' -> [(toRegex' m, t) | | ||||||
|                                                     ("Regex",s) <- lex r, |                                                     ("Regex",s) <- lex r', | ||||||
|                                                     (m,t) <- readsPrec (app_prec+1) s]) r |                                                     (m,t) <- readsPrec (app_prec+1) s]) r | ||||||
|     where app_prec = 10 |     where app_prec = 10 | ||||||
| 
 | 
 | ||||||
| @ -186,7 +186,7 @@ regexReplace re repl = memo $ regexReplaceUnmemo re repl | |||||||
| -- but there can still be a runtime error from the replacement | -- but there can still be a runtime error from the replacement | ||||||
| -- pattern, eg a backreference referring to a nonexistent match group.) | -- pattern, eg a backreference referring to a nonexistent match group.) | ||||||
| regexReplaceUnmemo :: Regexp -> Replacement -> String -> Either RegexError String | regexReplaceUnmemo :: Regexp -> Replacement -> String -> Either RegexError String | ||||||
| regexReplaceUnmemo re repl s = foldM (replaceMatch repl) s (reverse $ match (reCompiled re) s :: [MatchText String]) | regexReplaceUnmemo re repl str = foldM (replaceMatch repl) str (reverse $ match (reCompiled re) str :: [MatchText String]) | ||||||
|   where |   where | ||||||
|     -- Replace one match within the string with the replacement text |     -- Replace one match within the string with the replacement text | ||||||
|     -- appropriate for this match. Or return an error message. |     -- appropriate for this match. Or return an error message. | ||||||
| @ -195,22 +195,22 @@ regexReplaceUnmemo re repl s = foldM (replaceMatch repl) s (reverse $ match (reC | |||||||
|       case elems matchgroups of  |       case elems matchgroups of  | ||||||
|         [] -> Right s |         [] -> Right s | ||||||
|         ((_,(off,len)):_) ->   -- groups should have 0-based indexes, and there should always be at least one, since this is a match |         ((_,(off,len)):_) ->   -- groups should have 0-based indexes, and there should always be at least one, since this is a match | ||||||
|           erepl >>= \repl -> Right $ pre ++ repl ++ post |           erpl >>= \rpl -> Right $ pre ++ rpl ++ post | ||||||
|           where |           where | ||||||
|             (pre, post') = splitAt off s |             (pre, post') = splitAt off s | ||||||
|             post = drop len post' |             post = drop len post' | ||||||
|             -- The replacement text: the replacement pattern with all |             -- The replacement text: the replacement pattern with all | ||||||
|             -- numeric backreferences replaced by the appropriate groups |             -- numeric backreferences replaced by the appropriate groups | ||||||
|             -- from this match. Or an error message. |             -- from this match. Or an error message. | ||||||
|             erepl = regexReplaceAllByM backrefRegex (lookupMatchGroup matchgroups) replpat |             erpl = regexReplaceAllByM backrefRegex (lookupMatchGroup matchgroups) replpat | ||||||
|               where |               where | ||||||
|                 -- Given some match groups and a numeric backreference, |                 -- Given some match groups and a numeric backreference, | ||||||
|                 -- return the referenced group text, or an error message. |                 -- return the referenced group text, or an error message. | ||||||
|                 lookupMatchGroup :: MatchText String -> String -> Either RegexError String |                 lookupMatchGroup :: MatchText String -> String -> Either RegexError String | ||||||
|                 lookupMatchGroup grps ('\\':s@(_:_)) | all isDigit s = |                 lookupMatchGroup grps ('\\':s2@(_:_)) | all isDigit s2 = | ||||||
|                   case read s of n | n `elem` indices grps -> Right $ fst (grps ! n)  -- PARTIAL: should not fail, all digits |                   case read s2 of n | n `elem` indices grps -> Right $ fst (grps ! n)  -- PARTIAL: should not fail, all digits | ||||||
|                                   _                         -> Left $ "no match group exists for backreference \"\\"++s++"\"" |                                   _                         -> Left $ "no match group exists for backreference \"\\"++s++"\"" | ||||||
|                 lookupMatchGroup _ s = Left $ "lookupMatchGroup called on non-numeric-backreference \""++s++"\", shouldn't happen" |                 lookupMatchGroup _ s2 = Left $ "lookupMatchGroup called on non-numeric-backreference \""++s2++"\", shouldn't happen" | ||||||
|     backrefRegex = toRegex' "\\\\[0-9]+"  -- PARTIAL: should not fail |     backrefRegex = toRegex' "\\\\[0-9]+"  -- PARTIAL: should not fail | ||||||
| 
 | 
 | ||||||
| -- regexReplace' :: Regexp -> Replacement -> String -> String | -- regexReplace' :: Regexp -> Replacement -> String -> String | ||||||
| @ -249,8 +249,8 @@ regexReplaceAllBy re transform s = prependdone rest | |||||||
|         go :: (Int,String,String->String) -> (Int,Int) ->  (Int,String,String->String) |         go :: (Int,String,String->String) -> (Int,Int) ->  (Int,String,String->String) | ||||||
|         go (pos,todo,prepend) (off,len) = |         go (pos,todo,prepend) (off,len) = | ||||||
|           let (prematch, matchandrest) = splitAt (off - pos) todo |           let (prematch, matchandrest) = splitAt (off - pos) todo | ||||||
|               (matched, rest) = splitAt len matchandrest |               (matched, rest2) = splitAt len matchandrest | ||||||
|           in (off + len, rest, prepend . (prematch++) . (transform matched ++)) |           in (off + len, rest2, prepend . (prematch++) . (transform matched ++)) | ||||||
| 
 | 
 | ||||||
| -- Replace all occurrences of a regexp in a string, transforming each match | -- Replace all occurrences of a regexp in a string, transforming each match | ||||||
| -- with the given monadic function. Eg if the monad is Either, a Left result | -- with the given monadic function. Eg if the monad is Either, a Left result | ||||||
|  | |||||||
| @ -371,9 +371,9 @@ attachSource filePath sourceText finalParseError = case finalParseError of | |||||||
| 
 | 
 | ||||||
|   -- A parse error thrown directly with the 'FinalError' constructor |   -- A parse error thrown directly with the 'FinalError' constructor | ||||||
|   -- requires both source and filepath. |   -- requires both source and filepath. | ||||||
|   FinalError parseError -> |   FinalError err -> | ||||||
|     let bundle = ParseErrorBundle |     let bundle = ParseErrorBundle | ||||||
|           { bundleErrors = parseError NE.:| [] |           { bundleErrors = err NE.:| [] | ||||||
|           , bundlePosState = initialPosState filePath sourceText } |           , bundlePosState = initialPosState filePath sourceText } | ||||||
|     in  FinalParseErrorBundle' |     in  FinalParseErrorBundle' | ||||||
|           { finalErrorBundle = bundle |           { finalErrorBundle = bundle | ||||||
|  | |||||||
| @ -211,11 +211,11 @@ renderHLine _ _ _ _ _ NoLine = [] | |||||||
| renderHLine vpos borders pretty w h prop = [renderHLine' vpos borders pretty prop w h] | renderHLine vpos borders pretty w h prop = [renderHLine' vpos borders pretty prop w h] | ||||||
| 
 | 
 | ||||||
| renderHLine' :: VPos -> Bool -> Bool -> Properties -> [Int] -> Header a -> Builder | renderHLine' :: VPos -> Bool -> Bool -> Properties -> [Int] -> Header a -> Builder | ||||||
| renderHLine' vpos borders pretty prop is h = addBorders $ sep <> coreLine <> sep | renderHLine' vpos borders pretty prop is hdr = addBorders $ sep <> coreLine <> sep | ||||||
|  where |  where | ||||||
|   addBorders xs   = if borders then edge HL <> xs <> edge HR else xs |   addBorders xs   = if borders then edge HL <> xs <> edge HR else xs | ||||||
|   edge hpos       = boxchar vpos hpos SingleLine prop pretty |   edge hpos       = boxchar vpos hpos SingleLine prop pretty | ||||||
|   coreLine        = foldMap helper $ flattenHeader $ zipHeader 0 is h |   coreLine        = foldMap helper $ flattenHeader $ zipHeader 0 is hdr | ||||||
|   helper          = either vsep dashes |   helper          = either vsep dashes | ||||||
|   dashes (i,_)    = stimesMonoid i sep |   dashes (i,_)    = stimesMonoid i sep | ||||||
|   sep             = boxchar vpos HM NoLine prop pretty |   sep             = boxchar vpos HM NoLine prop pretty | ||||||
|  | |||||||
| @ -83,7 +83,6 @@ ghc-options: | |||||||
| - -Wall | - -Wall | ||||||
| - -Wno-incomplete-uni-patterns | - -Wno-incomplete-uni-patterns | ||||||
| - -Wno-missing-signatures | - -Wno-missing-signatures | ||||||
| - -Wno-name-shadowing |  | ||||||
| - -Wno-orphans | - -Wno-orphans | ||||||
| - -Wno-type-defaults | - -Wno-type-defaults | ||||||
| - -Wno-unused-do-bind | - -Wno-unused-do-bind | ||||||
|  | |||||||
| @ -210,7 +210,7 @@ updateReportPeriod updatePeriod = fromRight err . overEither period updatePeriod | |||||||
| 
 | 
 | ||||||
| -- | Apply a new filter query, or return the failing query. | -- | Apply a new filter query, or return the failing query. | ||||||
| setFilter :: String -> UIState -> Either String UIState | setFilter :: String -> UIState -> Either String UIState | ||||||
| setFilter s = first (const s) . setEither querystring (words'' prefixes $ T.pack s) | setFilter s = first (const s) . setEither querystring (words'' queryprefixes $ T.pack s) | ||||||
| 
 | 
 | ||||||
| -- | Reset some filters & toggles. | -- | Reset some filters & toggles. | ||||||
| resetFilter :: UIState -> UIState | resetFilter :: UIState -> UIState | ||||||
|  | |||||||
| @ -118,14 +118,14 @@ removeDates = | |||||||
|     map quoteIfSpaced . |     map quoteIfSpaced . | ||||||
|     filter (\term -> |     filter (\term -> | ||||||
|         not $ T.isPrefixOf "date:" term || T.isPrefixOf "date2:" term) . |         not $ T.isPrefixOf "date:" term || T.isPrefixOf "date2:" term) . | ||||||
|     Query.words'' Query.prefixes |     Query.words'' queryprefixes | ||||||
| 
 | 
 | ||||||
| removeInacct :: Text -> [Text] | removeInacct :: Text -> [Text] | ||||||
| removeInacct = | removeInacct = | ||||||
|     map quoteIfSpaced . |     map quoteIfSpaced . | ||||||
|     filter (\term -> |     filter (\term -> | ||||||
|         not $ T.isPrefixOf "inacct:" term || T.isPrefixOf "inacctonly:" term) . |         not $ T.isPrefixOf "inacct:" term || T.isPrefixOf "inacctonly:" term) . | ||||||
|     Query.words'' Query.prefixes |     Query.words'' queryprefixes | ||||||
| 
 | 
 | ||||||
| replaceInacct :: Text -> Text -> Text | replaceInacct :: Text -> Text -> Text | ||||||
| replaceInacct q acct = T.unwords $ acct : removeInacct q | replaceInacct q acct = T.unwords $ acct : removeInacct q | ||||||
|  | |||||||
| @ -323,7 +323,7 @@ defCommandMode names = defMode { | |||||||
| -- given name, providing hledger's common input/reporting/help flags. | -- given name, providing hledger's common input/reporting/help flags. | ||||||
| -- Just used when invoking addons. | -- Just used when invoking addons. | ||||||
| addonCommandMode :: Name -> Mode RawOpts | addonCommandMode :: Name -> Mode RawOpts | ||||||
| addonCommandMode name = (defCommandMode [name]) { | addonCommandMode nam = (defCommandMode [nam]) { | ||||||
|    modeHelp = "" |    modeHelp = "" | ||||||
|      -- XXX not needed ? |      -- XXX not needed ? | ||||||
|      -- fromMaybe "" $ lookup (stripAddonExtension name) [ |      -- fromMaybe "" $ lookup (stripAddonExtension name) [ | ||||||
| @ -539,10 +539,10 @@ rawOptsToCliOpts rawopts = do | |||||||
| -- add a space character to preserve them. | -- add a space character to preserve them. | ||||||
| -- | -- | ||||||
| getHledgerCliOpts' :: Mode RawOpts -> [String] -> IO CliOpts | getHledgerCliOpts' :: Mode RawOpts -> [String] -> IO CliOpts | ||||||
| getHledgerCliOpts' mode' args' = do | getHledgerCliOpts' mode' args0 = do | ||||||
|   let rawopts = either usageError id $ process mode' args' |   let rawopts = either usageError id $ process mode' args0 | ||||||
|   opts <- rawOptsToCliOpts rawopts |   opts <- rawOptsToCliOpts rawopts | ||||||
|   debugArgs args' opts |   debugArgs args0 opts | ||||||
|   when ("help" `inRawOpts` rawopts_ opts) $ putStr shorthelp >> exitSuccess |   when ("help" `inRawOpts` rawopts_ opts) $ putStr shorthelp >> exitSuccess | ||||||
|   -- when ("help" `inRawOpts` rawopts_ opts) $ putStr longhelp  >> exitSuccess |   -- when ("help" `inRawOpts` rawopts_ opts) $ putStr longhelp  >> exitSuccess | ||||||
|   return opts |   return opts | ||||||
| @ -557,11 +557,11 @@ getHledgerCliOpts' mode' args' = do | |||||||
|         ] |         ] | ||||||
|     -- | Print debug info about arguments and options if --debug is present. |     -- | Print debug info about arguments and options if --debug is present. | ||||||
|     debugArgs :: [String] -> CliOpts -> IO () |     debugArgs :: [String] -> CliOpts -> IO () | ||||||
|     debugArgs args' opts = |     debugArgs args1 opts = | ||||||
|       when ("--debug" `elem` args') $ do |       when ("--debug" `elem` args1) $ do | ||||||
|         progname' <- getProgName |         progname' <- getProgName | ||||||
|         putStrLn $ "running: " ++ progname' |         putStrLn $ "running: " ++ progname' | ||||||
|         putStrLn $ "raw args: " ++ show args' |         putStrLn $ "raw args: " ++ show args1 | ||||||
|         putStrLn $ "processed opts:\n" ++ show opts |         putStrLn $ "processed opts:\n" ++ show opts | ||||||
|         putStrLn $ "search query: " ++ show (_rsQuery $ reportspec_ opts) |         putStrLn $ "search query: " ++ show (_rsQuery $ reportspec_ opts) | ||||||
| 
 | 
 | ||||||
| @ -590,7 +590,7 @@ expandPathPreservingPrefix d prefixedf = do | |||||||
|   let (p,f) = splitReaderPrefix prefixedf |   let (p,f) = splitReaderPrefix prefixedf | ||||||
|   f' <- expandPath d f |   f' <- expandPath d f | ||||||
|   return $ case p of |   return $ case p of | ||||||
|     Just p  -> p ++ ":" ++ f' |     Just p'  -> p' ++ ":" ++ f' | ||||||
|     Nothing -> f' |     Nothing -> f' | ||||||
| 
 | 
 | ||||||
| -- | Get the expanded, absolute output file path specified by an | -- | Get the expanded, absolute output file path specified by an | ||||||
|  | |||||||
| @ -51,7 +51,7 @@ accounts CliOpts{rawopts_=rawopts, reportspec_=ReportSpec{_rsQuery=query,_rsRepo | |||||||
| 
 | 
 | ||||||
|   -- 1. identify the accounts we'll show |   -- 1. identify the accounts we'll show | ||||||
|   let tree     = tree_ ropts |   let tree     = tree_ ropts | ||||||
|       declared = boolopt "declared" rawopts |       decl = boolopt "declared" rawopts | ||||||
|       used = boolopt "used"     rawopts |       used = boolopt "used"     rawopts | ||||||
|       types = boolopt "types"    rawopts |       types = boolopt "types"    rawopts | ||||||
|       positions = boolopt "positions" rawopts |       positions = boolopt "positions" rawopts | ||||||
| @ -60,15 +60,15 @@ accounts CliOpts{rawopts_=rawopts, reportspec_=ReportSpec{_rsQuery=query,_rsRepo | |||||||
|       nodepthq = dbg4 "nodepthq" $ filterQuery (not . queryIsDepth) query |       nodepthq = dbg4 "nodepthq" $ filterQuery (not . queryIsDepth) query | ||||||
|       -- just the acct: part of the query will be reapplied later, after clipping |       -- just the acct: part of the query will be reapplied later, after clipping | ||||||
|       acctq = dbg4 "acctq" $ filterQuery queryIsAcct query |       acctq = dbg4 "acctq" $ filterQuery queryIsAcct query | ||||||
|       depth    = dbg4 "depth" $ queryDepth $ filterQuery queryIsDepth query |       dep = dbg4 "depth" $ queryDepth $ filterQuery queryIsDepth query | ||||||
|       matcheddeclaredaccts = |       matcheddeclaredaccts = | ||||||
|         dbg4 "matcheddeclaredaccts" $ |         dbg4 "matcheddeclaredaccts" $ | ||||||
|         filter (matchesAccountExtra (journalAccountType j) (journalInheritedAccountTags j) nodepthq) |         filter (matchesAccountExtra (journalAccountType j) (journalInheritedAccountTags j) nodepthq) | ||||||
|           $ map fst $ jdeclaredaccounts j |           $ map fst $ jdeclaredaccounts j | ||||||
|       matchedusedaccts = dbg5 "matchedusedaccts" $ map paccount $ journalPostings $ filterJournalPostings nodepthq j |       matchedusedaccts = dbg5 "matchedusedaccts" $ map paccount $ journalPostings $ filterJournalPostings nodepthq j | ||||||
|       accts = dbg5 "accts to show" $ |       accts = dbg5 "accts to show" $ | ||||||
|         if | declared     && not used -> matcheddeclaredaccts |         if | decl     && not used -> matcheddeclaredaccts | ||||||
|            | not declared && used     -> matchedusedaccts |            | not decl && used     -> matchedusedaccts | ||||||
|            | otherwise            -> matcheddeclaredaccts ++ matchedusedaccts |            | otherwise            -> matcheddeclaredaccts ++ matchedusedaccts | ||||||
| 
 | 
 | ||||||
|   -- 2. sort them by declaration order (then undeclared accounts alphabetically) |   -- 2. sort them by declaration order (then undeclared accounts alphabetically) | ||||||
| @ -81,7 +81,7 @@ accounts CliOpts{rawopts_=rawopts, reportspec_=ReportSpec{_rsQuery=query,_rsRepo | |||||||
|         filter (matchesAccount acctq) $  -- clipping can leave accounts that no longer match the query, remove such |         filter (matchesAccount acctq) $  -- clipping can leave accounts that no longer match the query, remove such | ||||||
|         nub $                            -- clipping can leave duplicates (adjacent, hopefully) |         nub $                            -- clipping can leave duplicates (adjacent, hopefully) | ||||||
|         filter (not . T.null) $          -- depth:0 can leave nulls |         filter (not . T.null) $          -- depth:0 can leave nulls | ||||||
|         map (clipAccountName depth) $  -- clip at depth if specified |         map (clipAccountName dep) $      -- clip at depth if specified | ||||||
|         sortedaccts |         sortedaccts | ||||||
| 
 | 
 | ||||||
|   -- 4. print what remains as a list or tree, maybe applying --drop in the former case. |   -- 4. print what remains as a list or tree, maybe applying --drop in the former case. | ||||||
|  | |||||||
| @ -189,7 +189,7 @@ confirmedTransactionWizard prevInput es@EntryState{..} stack@(currentStage : _) | |||||||
|     Nothing -> |     Nothing -> | ||||||
|       confirmedTransactionWizard prevInput es (drop 1 stack) |       confirmedTransactionWizard prevInput es (drop 1 stack) | ||||||
| 
 | 
 | ||||||
|   EnterNewPosting txnParams@TxnParams{..} posting -> case (esPostings, posting) of |   EnterNewPosting txnParams@TxnParams{..} p -> case (esPostings, p) of | ||||||
|     ([], Nothing) -> |     ([], Nothing) -> | ||||||
|       confirmedTransactionWizard prevInput es (EnterAccount txnParams : stack) |       confirmedTransactionWizard prevInput es (EnterAccount txnParams : stack) | ||||||
|     (_, Just _) -> |     (_, Just _) -> | ||||||
| @ -230,15 +230,15 @@ confirmedTransactionWizard prevInput es@EntryState{..} stack@(currentStage : _) | |||||||
|       confirmedTransactionWizard prevInput es{esPostings=init esPostings} (dropWhile notPrevAmountAndNotEnterDesc stack) |       confirmedTransactionWizard prevInput es{esPostings=init esPostings} (dropWhile notPrevAmountAndNotEnterDesc stack) | ||||||
| 
 | 
 | ||||||
|   EnterAmountAndComment txnParams account -> amountAndCommentWizard prevInput es >>= \case |   EnterAmountAndComment txnParams account -> amountAndCommentWizard prevInput es >>= \case | ||||||
|     Just (amount, comment) -> do |     Just (amt, comment) -> do | ||||||
|       let posting = nullposting{paccount=T.pack $ stripbrackets account |       let p = nullposting{paccount=T.pack $ stripbrackets account | ||||||
|                                ,pamount=mixedAmount amount |                           ,pamount=mixedAmount amt | ||||||
|                           ,pcomment=comment |                           ,pcomment=comment | ||||||
|                           ,ptype=accountNamePostingType $ T.pack account |                           ,ptype=accountNamePostingType $ T.pack account | ||||||
|                           } |                           } | ||||||
|           amountAndCommentString = showAmount amount ++ T.unpack (if T.null comment then "" else "  ;" <> comment) |           amountAndCommentString = showAmount amt ++ T.unpack (if T.null comment then "" else "  ;" <> comment) | ||||||
|           prevAmountAndCmnt' = replaceNthOrAppend (length esPostings) amountAndCommentString (prevAmountAndCmnt prevInput) |           prevAmountAndCmnt' = replaceNthOrAppend (length esPostings) amountAndCommentString (prevAmountAndCmnt prevInput) | ||||||
|           es' = es{esPostings=esPostings++[posting], esArgs=drop 2 esArgs} |           es' = es{esPostings=esPostings++[p], esArgs=drop 2 esArgs} | ||||||
|       confirmedTransactionWizard prevInput{prevAmountAndCmnt=prevAmountAndCmnt'} es' (EnterNewPosting txnParams (Just posting) : stack) |       confirmedTransactionWizard prevInput{prevAmountAndCmnt=prevAmountAndCmnt'} es' (EnterNewPosting txnParams (Just posting) : stack) | ||||||
|     Nothing -> confirmedTransactionWizard prevInput es (drop 1 stack) |     Nothing -> confirmedTransactionWizard prevInput es (drop 1 stack) | ||||||
| 
 | 
 | ||||||
| @ -310,18 +310,18 @@ accountWizard PrevInput{..} EntryState{..} = do | |||||||
|     where |     where | ||||||
|       canfinish = not (null esPostings) && postingsBalanced esPostings |       canfinish = not (null esPostings) && postingsBalanced esPostings | ||||||
|       parseAccountOrDotOrNull :: String -> Bool -> String -> Maybe (Maybe String) |       parseAccountOrDotOrNull :: String -> Bool -> String -> Maybe (Maybe String) | ||||||
|       parseAccountOrDotOrNull _  _ "<"       = dbg1 $ Just Nothing |       parseAccountOrDotOrNull _  _ "<"       = dbg' $ Just Nothing | ||||||
|       parseAccountOrDotOrNull _  _ "."       = dbg1 $ Just $ Just "." -- . always signals end of txn |       parseAccountOrDotOrNull _  _ "."       = dbg' $ Just $ Just "." -- . always signals end of txn | ||||||
|       parseAccountOrDotOrNull "" True ""     = dbg1 $ Just $ Just ""  -- when there's no default and txn is balanced, "" also signals end of txn |       parseAccountOrDotOrNull "" True ""     = dbg' $ Just $ Just ""  -- when there's no default and txn is balanced, "" also signals end of txn | ||||||
|       parseAccountOrDotOrNull def@(_:_) _ "" = dbg1 $ Just $ Just def -- when there's a default, "" means use that |       parseAccountOrDotOrNull def@(_:_) _ "" = dbg' $ Just $ Just def -- when there's a default, "" means use that | ||||||
|       parseAccountOrDotOrNull _ _ s          = dbg1 $ fmap (Just . T.unpack) $ |       parseAccountOrDotOrNull _ _ s          = dbg' $ fmap (Just . T.unpack) $ | ||||||
|         either (const Nothing) validateAccount $ |         either (const Nothing) validateAccount $ | ||||||
|           flip evalState esJournal $ runParserT (accountnamep <* eof) "" (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 && notElem t (journalAccountNamesDeclaredOrImplied esJournal) = Nothing |           validateAccount t | no_new_accounts_ esOpts && notElem t (journalAccountNamesDeclaredOrImplied esJournal) = Nothing | ||||||
|                             | otherwise = Just t |                             | otherwise = Just t | ||||||
|       dbg1 = id -- strace |       dbg' = id -- strace | ||||||
| 
 | 
 | ||||||
| amountAndCommentWizard PrevInput{..} EntryState{..} = do | amountAndCommentWizard PrevInput{..} EntryState{..} = do | ||||||
|   let pnum = length esPostings + 1 |   let pnum = length esPostings + 1 | ||||||
|  | |||||||
| @ -31,7 +31,7 @@ import Hledger | |||||||
| import Hledger.Read.CsvReader (CSV, CsvRecord, printCSV) | import Hledger.Read.CsvReader (CSV, CsvRecord, printCSV) | ||||||
| import Hledger.Cli.CliOptions | import Hledger.Cli.CliOptions | ||||||
| import Hledger.Cli.Utils | import Hledger.Cli.Utils | ||||||
| import Text.Tabular.AsciiWide | import Text.Tabular.AsciiWide hiding (render) | ||||||
| 
 | 
 | ||||||
| aregistermode = hledgerCommandMode | aregistermode = hledgerCommandMode | ||||||
|   $(embedFileRelative "Hledger/Cli/Commands/Aregister.txt") |   $(embedFileRelative "Hledger/Cli/Commands/Aregister.txt") | ||||||
| @ -71,7 +71,7 @@ aregister :: CliOpts -> Journal -> IO () | |||||||
| aregister opts@CliOpts{rawopts_=rawopts,reportspec_=rspec} j = do | aregister opts@CliOpts{rawopts_=rawopts,reportspec_=rspec} j = do | ||||||
|   -- the first argument specifies the account, any remaining arguments are a filter query |   -- the first argument specifies the account, any remaining arguments are a filter query | ||||||
|   let help = "aregister needs an ACCTPAT argument to select an account" |   let help = "aregister needs an ACCTPAT argument to select an account" | ||||||
|   (apat,querystring) <- case listofstringopt "args" rawopts of |   (apat,querystr) <- case listofstringopt "args" rawopts of | ||||||
|       []     -> error' $ help <> ".\nPlease provide an account name or a (case-insensitive, infix, regexp) pattern." |       []     -> error' $ help <> ".\nPlease provide an account name or a (case-insensitive, infix, regexp) pattern." | ||||||
|       (a:as) -> return (a, map T.pack as) |       (a:as) -> return (a, map T.pack as) | ||||||
|   let |   let | ||||||
| @ -88,7 +88,7 @@ aregister opts@CliOpts{rawopts_=rawopts,reportspec_=rspec} j = do | |||||||
|         depth_=Nothing |         depth_=Nothing | ||||||
|         -- always show historical balance |         -- always show historical balance | ||||||
|       , balanceaccum_= Historical |       , balanceaccum_= Historical | ||||||
|       , querystring_ = querystring |       , querystring_ = querystr | ||||||
|       } |       } | ||||||
|     wd = whichDate ropts' |     wd = whichDate ropts' | ||||||
|   -- and regenerate the ReportSpec, making sure to use the above |   -- and regenerate the ReportSpec, making sure to use the above | ||||||
| @ -184,8 +184,8 @@ accountTransactionsReportItemAsText | |||||||
|       ] |       ] | ||||||
|     spacerCell  = Cell BottomLeft [WideBuilder (TB.singleton ' ') 1] |     spacerCell  = Cell BottomLeft [WideBuilder (TB.singleton ' ') 1] | ||||||
|     spacerCell2 = Cell BottomLeft [WideBuilder (TB.fromString "  ") 2] |     spacerCell2 = Cell BottomLeft [WideBuilder (TB.fromString "  ") 2] | ||||||
|     pad fullwidth amt = WideBuilder (TB.fromText $ T.replicate w " ") w <> amt |     pad fullwidth amt1 = WideBuilder (TB.fromText $ T.replicate w " ") w <> amt1 | ||||||
|       where w = fullwidth - wbWidth amt |       where w = fullwidth - wbWidth amt1 | ||||||
|     -- calculate widths |     -- calculate widths | ||||||
|     (totalwidth,mdescwidth) = registerWidthsFromOpts copts |     (totalwidth,mdescwidth) = registerWidthsFromOpts copts | ||||||
|     (datewidth, date) = (10, showDate $ transactionRegisterDate wd reportq thisacctq t) |     (datewidth, date) = (10, showDate $ transactionRegisterDate wd reportq thisacctq t) | ||||||
|  | |||||||
| @ -267,7 +267,7 @@ import qualified Data.Text.Lazy as TL | |||||||
| import qualified Data.Text.Lazy.Builder as TB | import qualified Data.Text.Lazy.Builder as TB | ||||||
| import Data.Time (addDays, fromGregorian) | import Data.Time (addDays, fromGregorian) | ||||||
| import System.Console.CmdArgs.Explicit as C | import System.Console.CmdArgs.Explicit as C | ||||||
| import Lucid as L | import Lucid as L hiding (value_) | ||||||
| import Safe (headMay, maximumMay) | import Safe (headMay, maximumMay) | ||||||
| import Text.Tabular.AsciiWide | import Text.Tabular.AsciiWide | ||||||
|     (Align(..), Cell(..), Table(..), TableOpts(..), cellWidth, concatTables, |     (Align(..), Cell(..), Table(..), TableOpts(..), cellWidth, concatTables, | ||||||
| @ -340,8 +340,8 @@ balancemode = hledgerCommandMode | |||||||
| balance :: CliOpts -> Journal -> IO () | balance :: CliOpts -> Journal -> IO () | ||||||
| balance opts@CliOpts{reportspec_=rspec} j = case balancecalc_ of | balance opts@CliOpts{reportspec_=rspec} j = case balancecalc_ of | ||||||
|     CalcBudget -> do  -- single or multi period budget report |     CalcBudget -> do  -- single or multi period budget report | ||||||
|       let reportspan = fst $ reportSpan j rspec |       let rspan = fst $ reportSpan j rspec | ||||||
|           budgetreport = budgetReport rspec (balancingopts_ $ inputopts_ opts) reportspan j |           budgetreport = budgetReport rspec (balancingopts_ $ inputopts_ opts) rspan j | ||||||
|           render = case fmt of |           render = case fmt of | ||||||
|             "txt"  -> budgetReportAsText ropts |             "txt"  -> budgetReportAsText ropts | ||||||
|             "json" -> (<>"\n") . toJsonText |             "json" -> (<>"\n") . toJsonText | ||||||
| @ -362,8 +362,8 @@ balance opts@CliOpts{reportspec_=rspec} j = case balancecalc_ of | |||||||
|     _ -> do  -- single period simple balance report |     _ -> do  -- single period simple balance report | ||||||
|         let report = balanceReport rspec j -- simple Ledger-style balance report |         let report = balanceReport rspec j -- simple Ledger-style balance report | ||||||
|             render = case fmt of |             render = case fmt of | ||||||
|               "txt"  -> \ropts -> TB.toLazyText . balanceReportAsText ropts |               "txt"  -> \ropts1 -> TB.toLazyText . balanceReportAsText ropts1 | ||||||
|               "csv"  -> \ropts -> printCSV . balanceReportAsCsv ropts |               "csv"  -> \ropts1 -> printCSV . balanceReportAsCsv ropts1 | ||||||
|               -- "html" -> \ropts -> (<>"\n") . L.renderText . multiBalanceReportAsHtml ropts . balanceReportAsMultiBalanceReport ropts |               -- "html" -> \ropts -> (<>"\n") . L.renderText . multiBalanceReportAsHtml ropts . balanceReportAsMultiBalanceReport ropts | ||||||
|               "json" -> const $ (<>"\n") . toJsonText |               "json" -> const $ (<>"\n") . toJsonText | ||||||
|               _      -> error' $ unsupportedOutputFormatError fmt  -- PARTIAL: |               _      -> error' $ unsupportedOutputFormatError fmt  -- PARTIAL: | ||||||
| @ -430,9 +430,9 @@ balanceReportAsText :: ReportOpts -> BalanceReport -> TB.Builder | |||||||
| balanceReportAsText opts ((items, total)) = case layout_ opts of | balanceReportAsText opts ((items, total)) = case layout_ opts of | ||||||
|     LayoutBare | iscustom -> error' "Custom format not supported with commodity columns"  -- PARTIAL: |     LayoutBare | iscustom -> error' "Custom format not supported with commodity columns"  -- PARTIAL: | ||||||
|     LayoutBare -> balanceReportAsText' opts ((items, total)) |     LayoutBare -> balanceReportAsText' opts ((items, total)) | ||||||
|     _ -> unlinesB lines <> unlinesB (if no_total_ opts then [] else [overline, totalLines]) |     _ -> unlinesB ls <> unlinesB (if no_total_ opts then [] else [overline, totalLines]) | ||||||
|   where |   where | ||||||
|     (lines, sizes) = unzip $ map (balanceReportItemAsText opts) items |     (ls, sizes) = unzip $ map (balanceReportItemAsText opts) items | ||||||
|     -- abuse renderBalanceReportItem to render the total with similar format |     -- abuse renderBalanceReportItem to render the total with similar format | ||||||
|     (totalLines, _) = renderBalanceReportItem opts ("",0,total) |     (totalLines, _) = renderBalanceReportItem opts ("",0,total) | ||||||
|     -- with a custom format, extend the line to the full report width; |     -- with a custom format, extend the line to the full report width; | ||||||
| @ -449,20 +449,20 @@ balanceReportAsText opts ((items, total)) = case layout_ opts of | |||||||
| balanceReportAsText' :: ReportOpts -> BalanceReport -> TB.Builder | balanceReportAsText' :: ReportOpts -> BalanceReport -> TB.Builder | ||||||
| balanceReportAsText' opts ((items, total)) = | balanceReportAsText' opts ((items, total)) = | ||||||
|   unlinesB . fmap (renderColumns def{tableBorders=False} sizes .  Tab.Group Tab.NoLine . fmap Tab.Header) $ |   unlinesB . fmap (renderColumns def{tableBorders=False} sizes .  Tab.Group Tab.NoLine . fmap Tab.Header) $ | ||||||
|     lines ++ concat [[[overline], totalline] | not (no_total_ opts)] |     ls ++ concat [[[overline], totalline] | not (no_total_ opts)] | ||||||
|   where |   where | ||||||
|     render (_, acctname, depth, amt) = |     render (_, acctname, dep, amt) = | ||||||
|         [ Cell TopRight damts |         [ Cell TopRight damts | ||||||
|         , Cell TopLeft (fmap wbFromText cs) |         , Cell TopLeft (fmap wbFromText cs) | ||||||
|         , Cell TopLeft (replicate (length damts - 1) mempty ++ [wbFromText dispname]) ] |         , Cell TopLeft (replicate (length damts - 1) mempty ++ [wbFromText dispname]) ] | ||||||
|       where dopts = oneLine{displayColour=color_ opts, displayOrder=Just cs} |       where dopts = oneLine{displayColour=color_ opts, displayOrder=Just cs} | ||||||
|             cs    = if mixedAmountLooksZero amt then [""] else S.toList $ maCommodities amt |             cs    = if mixedAmountLooksZero amt then [""] else S.toList $ maCommodities amt | ||||||
|             dispname = T.replicate ((depth - 1) * 2) " " <> acctname |             dispname = T.replicate ((dep - 1) * 2) " " <> acctname | ||||||
|             damts = showMixedAmountLinesB dopts amt |             damts = showMixedAmountLinesB dopts amt | ||||||
|     lines = fmap render items |     ls = fmap render items | ||||||
|     totalline = render ("", "", 0, total) |     totalline = render ("", "", 0, total) | ||||||
|     sizes = fromMaybe 0 . maximumMay . map cellWidth <$> |     sizes = fromMaybe 0 . maximumMay . map cellWidth <$> | ||||||
|         transpose ([totalline | not (no_total_ opts)] ++ lines) |         transpose ([totalline | not (no_total_ opts)] ++ ls) | ||||||
|     overline = Cell TopLeft . pure . wbFromText . flip T.replicate "-" . fromMaybe 0 $ headMay sizes |     overline = Cell TopLeft . pure . wbFromText . flip T.replicate "-" . fromMaybe 0 $ headMay sizes | ||||||
| 
 | 
 | ||||||
| {- | {- | ||||||
| @ -481,12 +481,12 @@ This implementation turned out to be a bit convoluted but implements the followi | |||||||
| -- differently-priced quantities of the same commodity will appear merged. | -- differently-priced quantities of the same commodity will appear merged. | ||||||
| -- The output will be one or more lines depending on the format and number of commodities. | -- The output will be one or more lines depending on the format and number of commodities. | ||||||
| balanceReportItemAsText :: ReportOpts -> BalanceReportItem -> (TB.Builder, [Int]) | balanceReportItemAsText :: ReportOpts -> BalanceReportItem -> (TB.Builder, [Int]) | ||||||
| balanceReportItemAsText opts (_, accountName, depth, amt) = | balanceReportItemAsText opts (_, accountName, dep, amt) = | ||||||
|   renderBalanceReportItem opts (accountName, depth, amt) |   renderBalanceReportItem opts (accountName, dep, amt) | ||||||
| 
 | 
 | ||||||
| -- | Render a balance report item using the given StringFormat, generating one or more lines of text. | -- | Render a balance report item using the given StringFormat, generating one or more lines of text. | ||||||
| renderBalanceReportItem :: ReportOpts -> (AccountName, Int, MixedAmount) -> (TB.Builder, [Int]) | renderBalanceReportItem :: ReportOpts -> (AccountName, Int, MixedAmount) -> (TB.Builder, [Int]) | ||||||
| renderBalanceReportItem opts (acctname, depth, total) = | renderBalanceReportItem opts (acctname, dep, total) = | ||||||
|   case format_ opts of |   case format_ opts of | ||||||
|       OneLine       comps -> renderRow' $ render True  True  comps |       OneLine       comps -> renderRow' $ render True  True  comps | ||||||
|       TopAligned    comps -> renderRow' $ render True  False comps |       TopAligned    comps -> renderRow' $ render True  False comps | ||||||
| @ -496,14 +496,14 @@ renderBalanceReportItem opts (acctname, depth, total) = | |||||||
|                       . Tab.Group Tab.NoLine $ map Tab.Header is |                       . Tab.Group Tab.NoLine $ map Tab.Header is | ||||||
|                     , map cellWidth is ) |                     , map cellWidth is ) | ||||||
| 
 | 
 | ||||||
|     render topaligned oneline = map (renderComponent topaligned oneline opts (acctname, depth, total)) |     render topaligned oneline = map (renderComponent topaligned oneline opts (acctname, dep, total)) | ||||||
| 
 | 
 | ||||||
| -- | Render one StringFormat component for a balance report item. | -- | Render one StringFormat component for a balance report item. | ||||||
| renderComponent :: Bool -> Bool -> ReportOpts -> (AccountName, Int, MixedAmount) -> StringFormatComponent -> Cell | renderComponent :: Bool -> Bool -> ReportOpts -> (AccountName, Int, MixedAmount) -> StringFormatComponent -> Cell | ||||||
| renderComponent _ _ _ _ (FormatLiteral s) = textCell TopLeft s | renderComponent _ _ _ _ (FormatLiteral s) = textCell TopLeft s | ||||||
| renderComponent topaligned oneline opts (acctname, depth, total) (FormatField ljust mmin mmax field) = case field of | renderComponent topaligned oneline opts (acctname, dep, total) (FormatField ljust mmin mmax field) = case field of | ||||||
|     DepthSpacerField -> Cell align [WideBuilder (TB.fromText $ T.replicate d " ") d] |     DepthSpacerField -> Cell align [WideBuilder (TB.fromText $ T.replicate d " ") d] | ||||||
|                         where d = maybe id min mmax $ depth * fromMaybe 1 mmin |                         where d = maybe id min mmax $ dep * fromMaybe 1 mmin | ||||||
|     AccountField     -> textCell align $ formatText ljust mmin mmax acctname |     AccountField     -> textCell align $ formatText ljust mmin mmax acctname | ||||||
|     TotalField       -> Cell align . pure $ showMixedAmountB dopts total |     TotalField       -> Cell align . pure $ showMixedAmountB dopts total | ||||||
|     _                -> Cell align [mempty] |     _                -> Cell align [mempty] | ||||||
| @ -721,13 +721,13 @@ multiBalanceRowAsWbs bopts ReportOpts{..} colspans (PeriodicReportRow _ as rowto | |||||||
|     totalscolumn = row_total_ && balanceaccum_ `notElem` [Cumulative, Historical] |     totalscolumn = row_total_ && balanceaccum_ `notElem` [Cumulative, Historical] | ||||||
|     cs = if all mixedAmountLooksZero allamts then [""] else S.toList $ foldMap maCommodities allamts |     cs = if all mixedAmountLooksZero allamts then [""] else S.toList $ foldMap maCommodities allamts | ||||||
|     allamts = as ++ [rowtot | totalscolumn && not (null as)] ++ [rowavg | average_ && not (null as)] |     allamts = as ++ [rowtot | totalscolumn && not (null as)] ++ [rowavg | average_ && not (null as)] | ||||||
|     addDateColumns span@(DateSpan s e) = (wbFromText (showDateSpan span) :) |     addDateColumns spn@(DateSpan s e) = (wbFromText (showDateSpan spn) :) | ||||||
|                                        . (wbFromText (maybe "" showDate s) :) |                                        . (wbFromText (maybe "" showDate s) :) | ||||||
|                                        . (wbFromText (maybe "" (showDate . addDays (-1)) e) :) |                                        . (wbFromText (maybe "" (showDate . addDays (-1)) e) :) | ||||||
| 
 | 
 | ||||||
|     paddedTranspose :: a -> [[a]] -> [[a]] |     paddedTranspose :: a -> [[a]] -> [[a]] | ||||||
|     paddedTranspose _ [] = [[]] |     paddedTranspose _ [] = [[]] | ||||||
|     paddedTranspose n as = take (maximum . map length $ as) . trans $ as |     paddedTranspose n as1 = take (maximum . map length $ as1) . trans $ as1 | ||||||
|         where |         where | ||||||
|           trans ([] : xss)  = (n : map h xss) :  trans ([n] : map t xss) |           trans ([] : xss)  = (n : map h xss) :  trans ([n] : map t xss) | ||||||
|           trans ((x : xs) : xss) = (x : map h xss) : trans (m xs : map t xss) |           trans ((x : xs) : xss) = (x : map h xss) : trans (m xs : map t xss) | ||||||
|  | |||||||
| @ -96,10 +96,10 @@ parseCheckArgument s = | |||||||
| -- | Run the named error check, possibly with some arguments,  | -- | Run the named error check, possibly with some arguments,  | ||||||
| -- on this journal with these options. | -- on this journal with these options. | ||||||
| runCheck :: CliOpts -> Journal -> (Check,[String]) -> IO () | runCheck :: CliOpts -> Journal -> (Check,[String]) -> IO () | ||||||
| runCheck CliOpts{reportspec_=ReportSpec{_rsReportOpts=ropts}} j (check,_) = do | runCheck CliOpts{reportspec_=ReportSpec{_rsReportOpts=ropts}} j (chck,_) = do | ||||||
|   d <- getCurrentDay |   d <- getCurrentDay | ||||||
|   let |   let | ||||||
|     results = case check of |     results = case chck of | ||||||
|       Accounts        -> journalCheckAccounts j |       Accounts        -> journalCheckAccounts j | ||||||
|       Commodities     -> journalCheckCommodities j |       Commodities     -> journalCheckCommodities j | ||||||
|       Ordereddates    -> journalCheckOrdereddates (whichDate ropts) j |       Ordereddates    -> journalCheckOrdereddates (whichDate ropts) j | ||||||
|  | |||||||
| @ -135,11 +135,11 @@ close copts@CliOpts{rawopts_=rawopts, reportspec_=rspec'} j = do | |||||||
| 
 | 
 | ||||||
|         | -- get the balances for each commodity and transaction price |         | -- get the balances for each commodity and transaction price | ||||||
|           (a,mb) <- acctbals |           (a,mb) <- acctbals | ||||||
|         , let bs = amounts mb |         , let bs0 = amounts mb | ||||||
|           -- mark the last balance in each commodity with True |           -- mark the last balance in each commodity with True | ||||||
|         , let bs' = concat [reverse $ zip (reverse bs) (True : repeat False) |         , let bs2 = concat [reverse $ zip (reverse bs1) (True : repeat False) | ||||||
|                            | bs <- groupBy ((==) `on` acommodity) bs] |                            | bs1 <- groupBy ((==) `on` acommodity) bs0] | ||||||
|         , (b, islast) <- bs' |         , (b, islast) <- bs2 | ||||||
|         ] |         ] | ||||||
| 
 | 
 | ||||||
|       -- or a final multicommodity posting transferring all balances to equity |       -- or a final multicommodity posting transferring all balances to equity | ||||||
| @ -160,12 +160,12 @@ close copts@CliOpts{rawopts_=rawopts, reportspec_=rspec'} j = do | |||||||
|         : [posting{paccount=openingacct, pamount=mixedAmount . precise $ negate b} | interleaved] |         : [posting{paccount=openingacct, pamount=mixedAmount . precise $ negate b} | interleaved] | ||||||
| 
 | 
 | ||||||
|         | (a,mb) <- acctbals |         | (a,mb) <- acctbals | ||||||
|         , let bs = amounts mb |         , let bs0 = amounts mb | ||||||
|           -- mark the last balance in each commodity with the unpriced sum in that commodity (for a balance assertion) |           -- mark the last balance in each commodity with the unpriced sum in that commodity (for a balance assertion) | ||||||
|         , let bs' = concat [reverse $ zip (reverse bs) (Just commoditysum : repeat Nothing) |         , let bs2 = concat [reverse $ zip (reverse bs1) (Just commoditysum : repeat Nothing) | ||||||
|                            | bs <- groupBy ((==) `on` acommodity) bs |                            | bs1 <- groupBy ((==) `on` acommodity) bs0 | ||||||
|                            , let commoditysum = (sum bs)] |                            , let commoditysum = (sum bs1)] | ||||||
|         , (b, mcommoditysum) <- bs' |         , (b, mcommoditysum) <- bs2 | ||||||
|         ] |         ] | ||||||
|       ++ [posting{paccount=openingacct, pamount=if explicit then mixedAmountSetFullPrecision (maNegate totalamt) else missingmixedamt} | not interleaved] |       ++ [posting{paccount=openingacct, pamount=if explicit then mixedAmountSetFullPrecision (maNegate totalamt) else missingmixedamt} | not interleaved] | ||||||
| 
 | 
 | ||||||
|  | |||||||
| @ -34,6 +34,6 @@ codesmode = hledgerCommandMode | |||||||
| codes :: CliOpts -> Journal -> IO () | codes :: CliOpts -> Journal -> IO () | ||||||
| codes CliOpts{reportspec_=rspec} j = do | codes CliOpts{reportspec_=rspec} j = do | ||||||
|   let ts = entriesReport rspec j |   let ts = entriesReport rspec j | ||||||
|       codes = (if empty_ (_rsReportOpts rspec) then id else filter (not . T.null)) $ |       codes' = (if empty_ (_rsReportOpts rspec) then id else filter (not . T.null)) $ | ||||||
|               map tcode ts |               map tcode ts | ||||||
|   mapM_ T.putStrLn codes |   mapM_ T.putStrLn codes' | ||||||
|  | |||||||
| @ -33,6 +33,6 @@ descriptionsmode = hledgerCommandMode | |||||||
| descriptions :: CliOpts -> Journal -> IO () | descriptions :: CliOpts -> Journal -> IO () | ||||||
| descriptions CliOpts{reportspec_=rspec} j = do | descriptions CliOpts{reportspec_=rspec} j = do | ||||||
|   let ts = entriesReport rspec j |   let ts = entriesReport rspec j | ||||||
|       descriptions = nubSort $ map tdescription ts |       descs = nubSort $ map tdescription ts | ||||||
| 
 | 
 | ||||||
|   mapM_ T.putStrLn descriptions |   mapM_ T.putStrLn descs | ||||||
|  | |||||||
| @ -31,7 +31,7 @@ files :: CliOpts -> Journal -> IO () | |||||||
| files CliOpts{rawopts_=rawopts} j = do | files CliOpts{rawopts_=rawopts} j = do | ||||||
|   let args = listofstringopt "args" rawopts |   let args = listofstringopt "args" rawopts | ||||||
|   regex <- mapM (either fail pure . toRegex . T.pack) $ headMay args |   regex <- mapM (either fail pure . toRegex . T.pack) $ headMay args | ||||||
|   let files = maybe id (filter . regexMatch) regex |   let fs = maybe id (filter . regexMatch) regex | ||||||
|               $ map fst |               $ map fst | ||||||
|               $ jfiles j |               $ jfiles j | ||||||
|   mapM_ putStrLn files |   mapM_ putStrLn fs | ||||||
|  | |||||||
| @ -34,5 +34,5 @@ notesmode = hledgerCommandMode | |||||||
| notes :: CliOpts -> Journal -> IO () | notes :: CliOpts -> Journal -> IO () | ||||||
| notes CliOpts{reportspec_=rspec} j = do | notes CliOpts{reportspec_=rspec} j = do | ||||||
|   let ts = entriesReport rspec j |   let ts = entriesReport rspec j | ||||||
|       notes = nubSort $ map transactionNote ts |       notes' = nubSort $ map transactionNote ts | ||||||
|   mapM_ T.putStrLn notes |   mapM_ T.putStrLn notes' | ||||||
|  | |||||||
| @ -36,13 +36,13 @@ payeesmode = hledgerCommandMode | |||||||
| payees :: CliOpts -> Journal -> IO () | payees :: CliOpts -> Journal -> IO () | ||||||
| payees CliOpts{rawopts_=rawopts, reportspec_=ReportSpec{_rsQuery=query}} j = do | payees CliOpts{rawopts_=rawopts, reportspec_=ReportSpec{_rsQuery=query}} j = do | ||||||
|   let |   let | ||||||
|     declared = boolopt "declared" rawopts |     decl = boolopt "declared" rawopts | ||||||
|     used     = boolopt "used"     rawopts |     used     = boolopt "used"     rawopts | ||||||
|     -- XXX matchesPayee is currently an alias for matchesDescription, not sure if it matters |     -- XXX matchesPayee is currently an alias for matchesDescription, not sure if it matters | ||||||
|     matcheddeclaredpayees = S.fromList . filter (matchesPayeeWIP query) $ journalPayeesDeclared j |     matcheddeclaredpayees = S.fromList . filter (matchesPayeeWIP query) $ journalPayeesDeclared j | ||||||
|     matchedusedpayees     = S.fromList . map transactionPayee $ filter (matchesTransaction query) $ jtxns j |     matchedusedpayees     = S.fromList . map transactionPayee $ filter (matchesTransaction query) $ jtxns j | ||||||
|     payees = |     payees' = | ||||||
|       if | declared     && not used -> matcheddeclaredpayees |       if | decl     && not used -> matcheddeclaredpayees | ||||||
|          | not declared && used     -> matchedusedpayees |          | not decl && used     -> matchedusedpayees | ||||||
|          | otherwise            -> matcheddeclaredpayees <> matchedusedpayees |          | otherwise            -> matcheddeclaredpayees <> matchedusedpayees | ||||||
|   mapM_ T.putStrLn payees |   mapM_ T.putStrLn payees' | ||||||
|  | |||||||
| @ -168,13 +168,13 @@ entriesReportAsCsv txns = | |||||||
| -- The txnidx field (transaction index) allows postings to be grouped back into transactions. | -- The txnidx field (transaction index) allows postings to be grouped back into transactions. | ||||||
| transactionToCSV :: Transaction -> CSV | transactionToCSV :: Transaction -> CSV | ||||||
| transactionToCSV t = | transactionToCSV t = | ||||||
|   map (\p -> T.pack (show idx):date:date2:status:code:description:comment:p) |   map (\p -> T.pack (show idx):d:d2:status:code:description:comment:p) | ||||||
|    (concatMap postingToCSV $ tpostings t) |    (concatMap postingToCSV $ tpostings t) | ||||||
|   where |   where | ||||||
|     idx = tindex t |     idx = tindex t | ||||||
|     description = tdescription t |     description = tdescription t | ||||||
|     date = showDate (tdate t) |     d = showDate (tdate t) | ||||||
|     date2 = maybe "" showDate $ tdate2 t |     d2 = maybe "" showDate $ tdate2 t | ||||||
|     status = T.pack . show $ tstatus t |     status = T.pack . show $ tstatus t | ||||||
|     code = tcode t |     code = tcode t | ||||||
|     comment = T.strip $ tcomment t |     comment = T.strip $ tcomment t | ||||||
| @ -186,10 +186,10 @@ postingToCSV p = | |||||||
|     -- separators and prices |     -- separators and prices | ||||||
|     let a_ = amountStripPrices a{acommodity=""} in |     let a_ = amountStripPrices a{acommodity=""} in | ||||||
|     let showamt = wbToText . showAmountB csvDisplay in |     let showamt = wbToText . showAmountB csvDisplay in | ||||||
|     let amount = showamt a_ in |     let amt = showamt a_ in | ||||||
|     let credit = if q < 0 then showamt $ negate a_ else "" in |     let credit = if q < 0 then showamt $ negate a_ else "" in | ||||||
|     let debit  = if q >= 0 then showamt a_ else "" in |     let debit  = if q >= 0 then showamt a_ else "" in | ||||||
|     [account, amount, c, credit, debit, status, comment]) |     [account, amt, c, credit, debit, status, comment]) | ||||||
|     . amounts $ pamount p |     . amounts $ pamount p | ||||||
|   where |   where | ||||||
|     status = T.pack . show $ pstatus p |     status = T.pack . show $ pstatus p | ||||||
|  | |||||||
| @ -25,11 +25,11 @@ import qualified Data.Text.Lazy as TL | |||||||
| import qualified Data.Text.Lazy.Builder as TB | import qualified Data.Text.Lazy.Builder as TB | ||||||
| import System.Console.CmdArgs.Explicit (flagNone, flagReq) | import System.Console.CmdArgs.Explicit (flagNone, flagReq) | ||||||
| 
 | 
 | ||||||
| import Hledger | import Hledger hiding (per) | ||||||
| import Hledger.Read.CsvReader (CSV, CsvRecord, printCSV) | import Hledger.Read.CsvReader (CSV, CsvRecord, printCSV) | ||||||
| import Hledger.Cli.CliOptions | import Hledger.Cli.CliOptions | ||||||
| import Hledger.Cli.Utils | import Hledger.Cli.Utils | ||||||
| import Text.Tabular.AsciiWide | import Text.Tabular.AsciiWide hiding (render) | ||||||
| 
 | 
 | ||||||
| registermode = hledgerCommandMode | registermode = hledgerCommandMode | ||||||
|   $(embedFileRelative "Hledger/Cli/Commands/Register.txt") |   $(embedFileRelative "Hledger/Cli/Commands/Register.txt") | ||||||
| @ -144,13 +144,13 @@ postingsReportItemAsText opts preferredamtwidth preferredbalwidth ((mdate, mperi | |||||||
|       ] |       ] | ||||||
|     spacerCell  = Cell BottomLeft [WideBuilder (TB.singleton ' ') 1] |     spacerCell  = Cell BottomLeft [WideBuilder (TB.singleton ' ') 1] | ||||||
|     spacerCell2 = Cell BottomLeft [WideBuilder (TB.fromString "  ") 2] |     spacerCell2 = Cell BottomLeft [WideBuilder (TB.fromString "  ") 2] | ||||||
|     pad fullwidth amt = WideBuilder (TB.fromText $ T.replicate w " ") w <> amt |     pad fullwidth amt' = WideBuilder (TB.fromText $ T.replicate w " ") w <> amt' | ||||||
|       where w = fullwidth - wbWidth amt |       where w = fullwidth - wbWidth amt' | ||||||
|     -- calculate widths |     -- calculate widths | ||||||
|     (totalwidth,mdescwidth) = registerWidthsFromOpts opts |     (totalwidth,mdescwidth) = registerWidthsFromOpts opts | ||||||
|     datewidth = maybe 10 periodTextWidth mperiod |     datewidth = maybe 10 periodTextWidth mperiod | ||||||
|     date = case mperiod of |     date = case mperiod of | ||||||
|              Just period -> if isJust mdate then showPeriod period else "" |              Just per -> if isJust mdate then showPeriod per else "" | ||||||
|              Nothing  -> maybe "" showDate mdate |              Nothing  -> maybe "" showDate mdate | ||||||
|     (amtwidth, balwidth) |     (amtwidth, balwidth) | ||||||
|       | shortfall <= 0 = (preferredamtwidth, preferredbalwidth) |       | shortfall <= 0 = (preferredamtwidth, preferredbalwidth) | ||||||
|  | |||||||
| @ -20,7 +20,7 @@ import Hledger.Cli.CliOptions | |||||||
| import Hledger.Cli.Commands.Print | import Hledger.Cli.Commands.Print | ||||||
| import System.Console.CmdArgs.Explicit | import System.Console.CmdArgs.Explicit | ||||||
| import Text.Printf | import Text.Printf | ||||||
| import Text.Megaparsec | import Text.Megaparsec hiding (pos1) | ||||||
| import qualified Data.Algorithm.Diff as D | import qualified Data.Algorithm.Diff as D | ||||||
| 
 | 
 | ||||||
| rewritemode = hledgerCommandMode | rewritemode = hledgerCommandMode | ||||||
| @ -101,11 +101,11 @@ renderPatch = go Nothing . sortOn fst where | |||||||
|     go _ [] = "" |     go _ [] = "" | ||||||
|     go Nothing cs@((SourcePos fp _ _, _):_) = fileHeader fp <> go (Just (fp, 0)) cs |     go Nothing cs@((SourcePos fp _ _, _):_) = fileHeader fp <> go (Just (fp, 0)) cs | ||||||
|     go (Just (fp, _)) cs@((SourcePos fp' _ _, _):_) | fp /= fp' = go Nothing cs |     go (Just (fp, _)) cs@((SourcePos fp' _ _, _):_) | fp /= fp' = go Nothing cs | ||||||
|     go (Just (fp, offs)) ((SourcePos _ lineno _, diffs):cs) = chunkHeader <> chunk <> go (Just (fp, offs + adds - dels)) cs |     go (Just (fp, offs)) ((SourcePos _ lineno _, diffs):cs) = chunkHeader <> chnk <> go (Just (fp, offs + adds - dels)) cs | ||||||
|         where |         where | ||||||
|             chunkHeader = T.pack $ printf "@@ -%d,%d +%d,%d @@\n" (unPos lineno) dels (unPos lineno+offs) adds |             chunkHeader = T.pack $ printf "@@ -%d,%d +%d,%d @@\n" (unPos lineno) dels (unPos lineno+offs) adds | ||||||
|             (dels, adds) = foldl' countDiff (0, 0) diffs |             (dels, adds) = foldl' countDiff (0, 0) diffs | ||||||
|             chunk = foldMap renderLine diffs |             chnk = foldMap renderLine diffs | ||||||
|     fileHeader fp = "--- " <> T.pack fp <> "\n+++ " <> T.pack fp <> "\n" |     fileHeader fp = "--- " <> T.pack fp <> "\n+++ " <> T.pack fp <> "\n" | ||||||
| 
 | 
 | ||||||
|     countDiff (dels, adds) = \case |     countDiff (dels, adds) = \case | ||||||
|  | |||||||
| @ -92,45 +92,45 @@ roi CliOpts{rawopts_=rawopts, reportspec_=rspec@ReportSpec{_rsReportOpts=ReportO | |||||||
| 
 | 
 | ||||||
|   let priceDirectiveDates = dbg3 "priceDirectiveDates" $ map pddate $ jpricedirectives j |   let priceDirectiveDates = dbg3 "priceDirectiveDates" $ map pddate $ jpricedirectives j | ||||||
| 
 | 
 | ||||||
|   tableBody <- forM spans $ \span@(DateSpan (Just spanBegin) (Just spanEnd)) -> do |   tableBody <- forM spans $ \spn@(DateSpan (Just begin) (Just end)) -> do | ||||||
|     -- Spans are [spanBegin,spanEnd), and spanEnd is 1 day after then actual end date we are interested in |     -- Spans are [begin,end), and end is 1 day after the actual end date we are interested in | ||||||
|     let |     let | ||||||
|       cashFlowApplyCostValue = map (\(d,amt) -> (d,mixedAmountValue spanEnd d amt)) |       cashFlowApplyCostValue = map (\(d,amt) -> (d,mixedAmountValue end d amt)) | ||||||
| 
 | 
 | ||||||
|       valueBefore = |       valueBefore = | ||||||
|         mixedAmountValue spanEnd spanBegin $  |         mixedAmountValue end begin $  | ||||||
|         total trans (And [ investmentsQuery |         total trans (And [ investmentsQuery | ||||||
|                          , Date (DateSpan Nothing (Just spanBegin))]) |                          , Date (DateSpan Nothing (Just begin))]) | ||||||
| 
 | 
 | ||||||
|       valueAfter  = |       valueAfter  = | ||||||
|         mixedAmountValue spanEnd spanEnd $  |         mixedAmountValue end end $  | ||||||
|         total trans (And [investmentsQuery |         total trans (And [investmentsQuery | ||||||
|                          , Date (DateSpan Nothing (Just spanEnd))]) |                          , Date (DateSpan Nothing (Just end))]) | ||||||
| 
 | 
 | ||||||
|       priceDates = dbg3 "priceDates" $ nub $ filter (spanContainsDate span) priceDirectiveDates |       priceDates = dbg3 "priceDates" $ nub $ filter (spanContainsDate spn) priceDirectiveDates | ||||||
|       cashFlow = |       cashFlow = | ||||||
|         ((map (,nullmixedamt) priceDates)++) $ |         ((map (,nullmixedamt) priceDates)++) $ | ||||||
|         cashFlowApplyCostValue $ |         cashFlowApplyCostValue $ | ||||||
|         calculateCashFlow wd trans (And [ Not investmentsQuery |         calculateCashFlow wd trans (And [ Not investmentsQuery | ||||||
|                                         , Not pnlQuery |                                         , Not pnlQuery | ||||||
|                                         , Date span ] ) |                                         , Date spn ] ) | ||||||
| 
 | 
 | ||||||
| 
 | 
 | ||||||
|       pnl = |       pnl = | ||||||
|         cashFlowApplyCostValue $ |         cashFlowApplyCostValue $ | ||||||
|         calculateCashFlow wd trans (And [ Not investmentsQuery |         calculateCashFlow wd trans (And [ Not investmentsQuery | ||||||
|                                         , pnlQuery |                                         , pnlQuery | ||||||
|                                         , Date span ] ) |                                         , Date spn ] ) | ||||||
| 
 | 
 | ||||||
|       thisSpan = dbg3 "processing span" $ |       thisSpan = dbg3 "processing span" $ | ||||||
|                  OneSpan spanBegin spanEnd valueBefore valueAfter cashFlow pnl |                  OneSpan begin end valueBefore valueAfter cashFlow pnl | ||||||
| 
 | 
 | ||||||
|     irr <- internalRateOfReturn showCashFlow prettyTables thisSpan |     irr <- internalRateOfReturn showCashFlow prettyTables thisSpan | ||||||
|     twr <- timeWeightedReturn showCashFlow prettyTables investmentsQuery trans mixedAmountValue thisSpan |     twr <- timeWeightedReturn showCashFlow prettyTables investmentsQuery trans mixedAmountValue thisSpan | ||||||
|     let cashFlowAmt = maNegate . maSum $ map snd cashFlow |     let cashFlowAmt = maNegate . maSum $ map snd cashFlow | ||||||
|     let smallIsZero x = if abs x < 0.01 then 0.0 else x |     let smallIsZero x = if abs x < 0.01 then 0.0 else x | ||||||
|     return [ showDate spanBegin |     return [ showDate begin | ||||||
|            , showDate (addDays (-1) spanEnd) |            , showDate (addDays (-1) end) | ||||||
|            , T.pack $ showMixedAmount valueBefore |            , T.pack $ showMixedAmount valueBefore | ||||||
|            , T.pack $ showMixedAmount cashFlowAmt |            , T.pack $ showMixedAmount cashFlowAmt | ||||||
|            , T.pack $ showMixedAmount valueAfter |            , T.pack $ showMixedAmount valueAfter | ||||||
| @ -148,7 +148,7 @@ roi CliOpts{rawopts_=rawopts, reportspec_=rspec@ReportSpec{_rsReportOpts=ReportO | |||||||
| 
 | 
 | ||||||
|   TL.putStrLn $ Tab.render prettyTables id id id table |   TL.putStrLn $ Tab.render prettyTables id id id table | ||||||
| 
 | 
 | ||||||
| timeWeightedReturn showCashFlow prettyTables investmentsQuery trans mixedAmountValue (OneSpan spanBegin spanEnd valueBeforeAmt valueAfter cashFlow pnl) = do | timeWeightedReturn showCashFlow prettyTables investmentsQuery trans mixedAmountValue (OneSpan begin end valueBeforeAmt valueAfter cashFlow pnl) = do | ||||||
|   let valueBefore = unMix valueBeforeAmt |   let valueBefore = unMix valueBeforeAmt | ||||||
|   let initialUnitPrice = 100 :: Decimal |   let initialUnitPrice = 100 :: Decimal | ||||||
|   let initialUnits = valueBefore / initialUnitPrice |   let initialUnits = valueBefore / initialUnitPrice | ||||||
| @ -169,16 +169,16 @@ timeWeightedReturn showCashFlow prettyTables investmentsQuery trans mixedAmountV | |||||||
|         $ sort |         $ sort | ||||||
|         $ datedCashflows ++ datedPnls |         $ datedCashflows ++ datedPnls | ||||||
|         where |         where | ||||||
|           zeroUnitsNeedsCashflowAtTheFront changes = |           zeroUnitsNeedsCashflowAtTheFront changes1 = | ||||||
|             if initialUnits > 0 then changes |             if initialUnits > 0 then changes1 | ||||||
|             else  |             else  | ||||||
|               let (leadingEmptyCashFlows, rest) = span isEmptyCashflow changes |               let (leadingEmptyCashFlows, rest) = span isEmptyCashflow changes1 | ||||||
|                   (leadingPnls, rest') = span (isLeft . snd) rest |                   (leadingPnls, rest') = span (isLeft . snd) rest | ||||||
|                   (firstCashflow, rest'') = splitAt 1 rest' |                   (firstCashflow, rest'') = splitAt 1 rest' | ||||||
|               in leadingEmptyCashFlows ++ firstCashflow ++ leadingPnls ++ rest'' |               in leadingEmptyCashFlows ++ firstCashflow ++ leadingPnls ++ rest'' | ||||||
| 
 | 
 | ||||||
|           isEmptyCashflow (_date, amt) = case amt of |           isEmptyCashflow (_date, amt) = case amt of | ||||||
|             Right amt -> mixedAmountIsZero amt |             Right amt' -> mixedAmountIsZero amt' | ||||||
|             Left _     -> False |             Left _     -> False | ||||||
| 
 | 
 | ||||||
|           datedPnls = map (second Left) $ aggregateByDate pnl |           datedPnls = map (second Left) $ aggregateByDate pnl | ||||||
| @ -198,16 +198,16 @@ timeWeightedReturn showCashFlow prettyTables investmentsQuery trans mixedAmountV | |||||||
|         tail $ |         tail $ | ||||||
|         scanl |         scanl | ||||||
|           (\(_, _, unitPrice, unitBalance) (date, amt) -> |           (\(_, _, unitPrice, unitBalance) (date, amt) -> | ||||||
|              let valueOnDate = unMix $ mixedAmountValue spanEnd date $ total trans (And [investmentsQuery, Date (DateSpan Nothing (Just date))]) |              let valueOnDate = unMix $ mixedAmountValue end date $ total trans (And [investmentsQuery, Date (DateSpan Nothing (Just date))]) | ||||||
|              in |              in | ||||||
|              case amt of |              case amt of | ||||||
|                Right amt -> |                Right amt' -> | ||||||
|                  -- we are buying or selling |                  -- we are buying or selling | ||||||
|                  let unitsBoughtOrSold = unMix amt / unitPrice |                  let unitsBoughtOrSold = unMix amt' / unitPrice | ||||||
|                  in (valueOnDate, unitsBoughtOrSold, unitPrice, unitBalance + unitsBoughtOrSold) |                  in (valueOnDate, unitsBoughtOrSold, unitPrice, unitBalance + unitsBoughtOrSold) | ||||||
|                Left pnl -> |                Left pnl' -> | ||||||
|                  -- PnL change |                  -- PnL change | ||||||
|                  let valueAfterDate = valueOnDate + unMix pnl |                  let valueAfterDate = valueOnDate + unMix pnl' | ||||||
|                      unitPrice' = valueAfterDate/unitBalance |                      unitPrice' = valueAfterDate/unitBalance | ||||||
|                  in (valueOnDate, 0, unitPrice', unitBalance)) |                  in (valueOnDate, 0, unitPrice', unitBalance)) | ||||||
|           (0, 0, initialUnitPrice, initialUnits) |           (0, 0, initialUnitPrice, initialUnits) | ||||||
| @ -220,17 +220,17 @@ timeWeightedReturn showCashFlow prettyTables investmentsQuery trans mixedAmountV | |||||||
|                        else (unMix valueAfter) / finalUnitBalance |                        else (unMix valueAfter) / finalUnitBalance | ||||||
|       -- Technically, totalTWR should be (100*(finalUnitPrice - initialUnitPrice) / initialUnitPrice), but initalUnitPrice is 100, so 100/100 == 1 |       -- Technically, totalTWR should be (100*(finalUnitPrice - initialUnitPrice) / initialUnitPrice), but initalUnitPrice is 100, so 100/100 == 1 | ||||||
|       totalTWR = roundTo 2 $ (finalUnitPrice - initialUnitPrice) |       totalTWR = roundTo 2 $ (finalUnitPrice - initialUnitPrice) | ||||||
|       years = fromIntegral (diffDays spanEnd spanBegin) / 365 :: Double |       years = fromIntegral (diffDays end begin) / 365 :: Double | ||||||
|       annualizedTWR = 100*((1+(realToFrac totalTWR/100))**(1/years)-1) :: Double |       annualizedTWR = 100*((1+(realToFrac totalTWR/100))**(1/years)-1) :: Double | ||||||
| 
 | 
 | ||||||
|   when showCashFlow $ do |   when showCashFlow $ do | ||||||
|     printf "\nTWR cash flow for %s - %s\n" (showDate spanBegin) (showDate (addDays (-1) spanEnd)) |     printf "\nTWR cash flow for %s - %s\n" (showDate begin) (showDate (addDays (-1) end)) | ||||||
|     let (dates', amounts) = unzip changes |     let (dates', amts) = unzip changes | ||||||
|         cashflows' = map (fromRight nullmixedamt) amounts |         cashflows' = map (fromRight nullmixedamt) amts | ||||||
|         pnls = map (fromLeft nullmixedamt) amounts |         pnls = map (fromLeft nullmixedamt) amts | ||||||
|         (valuesOnDate,unitsBoughtOrSold', unitPrices', unitBalances') = unzip4 units |         (valuesOnDate,unitsBoughtOrSold', unitPrices', unitBalances') = unzip4 units | ||||||
|         add x lst = if valueBefore/=0 then x:lst else lst |         add x lst = if valueBefore/=0 then x:lst else lst | ||||||
|         dates = add spanBegin dates' |         dates = add begin dates' | ||||||
|         cashflows = add valueBeforeAmt cashflows' |         cashflows = add valueBeforeAmt cashflows' | ||||||
|         unitsBoughtOrSold = add initialUnits unitsBoughtOrSold' |         unitsBoughtOrSold = add initialUnits unitsBoughtOrSold' | ||||||
|         unitPrices = add initialUnitPrice unitPrices' |         unitPrices = add initialUnitPrice unitPrices' | ||||||
| @ -242,11 +242,11 @@ timeWeightedReturn showCashFlow prettyTables investmentsQuery trans mixedAmountV | |||||||
|        (Tab.Group DoubleLine [ Tab.Group Tab.SingleLine [Tab.Header "Portfolio value", Tab.Header "Unit balance"] |        (Tab.Group DoubleLine [ Tab.Group Tab.SingleLine [Tab.Header "Portfolio value", Tab.Header "Unit balance"] | ||||||
|                          , Tab.Group Tab.SingleLine [Tab.Header "Pnl", Tab.Header "Cashflow", Tab.Header "Unit price", Tab.Header "Units"] |                          , Tab.Group Tab.SingleLine [Tab.Header "Pnl", Tab.Header "Cashflow", Tab.Header "Unit price", Tab.Header "Units"] | ||||||
|                          , Tab.Group Tab.SingleLine [Tab.Header "New Unit Balance"]]) |                          , Tab.Group Tab.SingleLine [Tab.Header "New Unit Balance"]]) | ||||||
|        [ [value, oldBalance, pnl, cashflow, prc, udelta, balance] |        [ [val, oldBalance, pnl', cashflow, prc, udelta, balance] | ||||||
|        | value <- map showDecimal valuesOnDate |        | val <- map showDecimal valuesOnDate | ||||||
|        | oldBalance <- map showDecimal (0:unitBalances) |        | oldBalance <- map showDecimal (0:unitBalances) | ||||||
|        | balance <- map showDecimal unitBalances |        | balance <- map showDecimal unitBalances | ||||||
|        | pnl <- map showMixedAmount pnls |        | pnl' <- map showMixedAmount pnls | ||||||
|        | cashflow <- map showMixedAmount cashflows |        | cashflow <- map showMixedAmount cashflows | ||||||
|        | prc <- map showDecimal unitPrices |        | prc <- map showDecimal unitPrices | ||||||
|        | udelta <- map showDecimal unitsBoughtOrSold ]) |        | udelta <- map showDecimal unitsBoughtOrSold ]) | ||||||
| @ -256,28 +256,28 @@ timeWeightedReturn showCashFlow prettyTables investmentsQuery trans mixedAmountV | |||||||
| 
 | 
 | ||||||
|   return annualizedTWR |   return annualizedTWR | ||||||
| 
 | 
 | ||||||
| internalRateOfReturn showCashFlow prettyTables (OneSpan spanBegin spanEnd valueBefore valueAfter cashFlow _pnl) = do | internalRateOfReturn showCashFlow prettyTables (OneSpan begin end valueBefore valueAfter cashFlow _pnl) = do | ||||||
|   let prefix = (spanBegin, maNegate valueBefore) |   let prefix = (begin, maNegate valueBefore) | ||||||
| 
 | 
 | ||||||
|       postfix = (spanEnd, valueAfter) |       postfix = (end, valueAfter) | ||||||
| 
 | 
 | ||||||
|       totalCF = filter (maIsNonZero . snd) $ prefix : (sortOn fst cashFlow) ++ [postfix] |       totalCF = filter (maIsNonZero . snd) $ prefix : (sortOn fst cashFlow) ++ [postfix] | ||||||
| 
 | 
 | ||||||
|   when showCashFlow $ do |   when showCashFlow $ do | ||||||
|     printf "\nIRR cash flow for %s - %s\n" (showDate spanBegin) (showDate (addDays (-1) spanEnd)) |     printf "\nIRR cash flow for %s - %s\n" (showDate begin) (showDate (addDays (-1) end)) | ||||||
|     let (dates, amounts) = unzip totalCF |     let (dates, amts) = unzip totalCF | ||||||
|     TL.putStrLn $ Tab.render prettyTables id id id |     TL.putStrLn $ Tab.render prettyTables id id id | ||||||
|       (Table |       (Table | ||||||
|        (Tab.Group Tab.NoLine (map (Header . showDate) dates)) |        (Tab.Group Tab.NoLine (map (Header . showDate) dates)) | ||||||
|        (Tab.Group Tab.SingleLine [Header "Amount"]) |        (Tab.Group Tab.SingleLine [Header "Amount"]) | ||||||
|        (map ((:[]) . T.pack . showMixedAmount) amounts)) |        (map ((:[]) . T.pack . showMixedAmount) amts)) | ||||||
| 
 | 
 | ||||||
|   -- 0% is always a solution, so require at least something here |   -- 0% is always a solution, so require at least something here | ||||||
|   case totalCF of |   case totalCF of | ||||||
|     [] -> return 0 |     [] -> return 0 | ||||||
|     _ -> case ridders (RiddersParam 100 (AbsTol 0.00001)) |     _ -> case ridders (RiddersParam 100 (AbsTol 0.00001)) | ||||||
|                       (0.000000000001,10000) |                       (0.000000000001,10000) | ||||||
|                       (interestSum spanEnd totalCF) of |                       (interestSum end totalCF) of | ||||||
|         Root rate    -> return ((rate-1)*100) |         Root rate    -> return ((rate-1)*100) | ||||||
|         NotBracketed -> error' $ "Error (NotBracketed): No solution for Internal Rate of Return (IRR).\n" |         NotBracketed -> error' $ "Error (NotBracketed): No solution for Internal Rate of Return (IRR).\n" | ||||||
|                         ++       "  Possible causes: IRR is huge (>1000000%), balance of investment becomes negative at some point in time." |                         ++       "  Possible causes: IRR is huge (>1000000%), balance of investment becomes negative at some point in time." | ||||||
| @ -301,7 +301,7 @@ total trans query = sumPostings . filter (matchesPosting query) $ concatMap real | |||||||
| unMix :: MixedAmount -> Quantity | unMix :: MixedAmount -> Quantity | ||||||
| unMix a = | unMix a = | ||||||
|   case (unifyMixedAmount $ mixedAmountCost a) of |   case (unifyMixedAmount $ mixedAmountCost a) of | ||||||
|     Just a -> aquantity a |     Just a' -> aquantity a' | ||||||
|     Nothing -> error' $ "Amounts could not be converted to a single cost basis: " ++ show (map showAmount $ amounts a) ++ |     Nothing -> error' $ "Amounts could not be converted to a single cost basis: " ++ show (map showAmount $ amounts a) ++ | ||||||
|                "\nConsider using --value to force all costs to be in a single commodity." ++ |                "\nConsider using --value to force all costs to be in a single commodity." ++ | ||||||
|                "\nFor example, \"--cost --value=end,<commodity> --infer-market-prices\", where commodity is the one that was used to pay for the investment." |                "\nFor example, \"--cost --value=end,<commodity> --infer-market-prices\", where commodity is the one that was used to pay for the investment." | ||||||
|  | |||||||
| @ -60,17 +60,17 @@ stats opts@CliOpts{reportspec_=rspec, progstarttime_} j = do | |||||||
|     (realToFrac dt :: Float) (fromIntegral numtxns / realToFrac dt :: Float) |     (realToFrac dt :: Float) (fromIntegral numtxns / realToFrac dt :: Float) | ||||||
| 
 | 
 | ||||||
| showLedgerStats :: Ledger -> Day -> DateSpan -> (TB.Builder, Int) | showLedgerStats :: Ledger -> Day -> DateSpan -> (TB.Builder, Int) | ||||||
| showLedgerStats l today span = | showLedgerStats l today spn = | ||||||
|     (unlinesB $ map (renderRowB def{tableBorders=False, borderSpaces=False} . showRow) stats |     (unlinesB $ map (renderRowB def{tableBorders=False, borderSpaces=False} . showRow) stts | ||||||
|     ,tnum) |     ,tnum) | ||||||
|   where |   where | ||||||
|     showRow (label, value) = Group NoLine $ map (Header . textCell TopLeft) |     showRow (label, val) = Group NoLine $ map (Header . textCell TopLeft) | ||||||
|       [fitText (Just w1) (Just w1) False True label `T.append` ": ", T.pack value] |       [fitText (Just w1) (Just w1) False True label `T.append` ": ", T.pack val] | ||||||
|     w1 = maximum $ map (T.length . fst) stats |     w1 = maximum $ map (T.length . fst) stts | ||||||
|     (stats, tnum) = ([ |     (stts, tnum) = ([ | ||||||
|        ("Main file", path) -- ++ " (from " ++ source ++ ")") |        ("Main file", path) -- ++ " (from " ++ source ++ ")") | ||||||
|       ,("Included files", unlines $ drop 1 $ journalFilePaths j) |       ,("Included files", unlines $ drop 1 $ journalFilePaths j) | ||||||
|       ,("Transactions span", printf "%s to %s (%d days)" (start span) (end span) days) |       ,("Transactions span", printf "%s to %s (%d days)" (start spn) (end spn) days) | ||||||
|       ,("Last transaction", maybe "none" show lastdate ++ showelapsed lastelapsed) |       ,("Last transaction", maybe "none" show lastdate ++ showelapsed lastelapsed) | ||||||
|       ,("Transactions", printf "%d (%0.1f per day)" tnum txnrate) |       ,("Transactions", printf "%d (%0.1f per day)" tnum txnrate) | ||||||
|       ,("Transactions last 30 days", printf "%d (%0.1f per day)" tnum30 txnrate30) |       ,("Transactions last 30 days", printf "%d (%0.1f per day)" tnum30 txnrate30) | ||||||
| @ -84,29 +84,29 @@ showLedgerStats l today span = | |||||||
|     -- Days since reconciliation   : %(reconcileelapsed)s |     -- Days since reconciliation   : %(reconcileelapsed)s | ||||||
|     -- Days since last transaction : %(recentelapsed)s |     -- Days since last transaction : %(recentelapsed)s | ||||||
|      ]  |      ]  | ||||||
|      ,tnum) |      ,tnum1) | ||||||
|        where |        where | ||||||
|          j = ljournal l |          j = ljournal l | ||||||
|          path = journalFilePath j |          path = journalFilePath j | ||||||
|          ts = sortOn tdate $ filter (spanContainsDate span . tdate) $ jtxns j |          ts = sortOn tdate $ filter (spanContainsDate spn . tdate) $ jtxns j | ||||||
|          as = nub $ map paccount $ concatMap tpostings ts |          as = nub $ map paccount $ concatMap tpostings ts | ||||||
|          cs = either error' Map.keys $ commodityStylesFromAmounts $ concatMap (amountsRaw . pamount) $ concatMap tpostings ts  -- PARTIAL: |          cs = either error' Map.keys $ commodityStylesFromAmounts $ concatMap (amountsRaw . pamount) $ concatMap tpostings ts  -- PARTIAL: | ||||||
|          lastdate | null ts = Nothing |          lastdate | null ts = Nothing | ||||||
|                   | otherwise = Just $ tdate $ last ts |                   | otherwise = Just $ tdate $ last ts | ||||||
|          lastelapsed = fmap (diffDays today) lastdate |          lastelapsed = fmap (diffDays today) lastdate | ||||||
|          showelapsed Nothing = "" |          showelapsed Nothing = "" | ||||||
|          showelapsed (Just days) = printf " (%d %s)" days' direction |          showelapsed (Just dys) = printf " (%d %s)" dys' direction | ||||||
|                                    where days' = abs days |                                    where dys' = abs dys | ||||||
|                                          direction | days >= 0 = "days ago" :: String |                                          direction | dys >= 0 = "days ago" :: String | ||||||
|                                                    | otherwise = "days from now" |                                                    | otherwise = "days from now" | ||||||
|          tnum = length ts  -- Integer would be better |          tnum1 = length ts  -- Integer would be better | ||||||
|          start (DateSpan (Just d) _) = show d |          start (DateSpan (Just d) _) = show d | ||||||
|          start _ = "" |          start _ = "" | ||||||
|          end (DateSpan _ (Just d)) = show d |          end (DateSpan _ (Just d)) = show d | ||||||
|          end _ = "" |          end _ = "" | ||||||
|          days = fromMaybe 0 $ daysInSpan span |          days = fromMaybe 0 $ daysInSpan spn | ||||||
|          txnrate | days==0 = 0 |          txnrate | days==0 = 0 | ||||||
|                  | otherwise = fromIntegral tnum / fromIntegral days :: Double |                  | otherwise = fromIntegral tnum1 / fromIntegral days :: Double | ||||||
|          tnum30 = length $ filter withinlast30 ts |          tnum30 = length $ filter withinlast30 ts | ||||||
|          withinlast30 t = d >= addDays (-30) today && (d<=today) where d = tdate t |          withinlast30 t = d >= addDays (-30) today && (d<=today) where d = tdate t | ||||||
|          txnrate30 = fromIntegral tnum30 / 30 :: Double |          txnrate30 = fromIntegral tnum30 / 30 :: Double | ||||||
|  | |||||||
| @ -22,7 +22,7 @@ import Data.Time.Calendar (Day, addDays) | |||||||
| import System.Console.CmdArgs.Explicit as C | import System.Console.CmdArgs.Explicit as C | ||||||
| import Hledger.Read.CsvReader (CSV, printCSV) | import Hledger.Read.CsvReader (CSV, printCSV) | ||||||
| import Lucid as L hiding (value_) | import Lucid as L hiding (value_) | ||||||
| import Text.Tabular.AsciiWide as Tab | import Text.Tabular.AsciiWide as Tab hiding (render) | ||||||
| 
 | 
 | ||||||
| import Hledger | import Hledger | ||||||
| import Hledger.Cli.Commands.Balance | import Hledger.Cli.Commands.Balance | ||||||
| @ -232,12 +232,12 @@ compoundBalanceReportAsText ropts | |||||||
| 
 | 
 | ||||||
|     -- | Convert a named multi balance report to a table suitable for |     -- | Convert a named multi balance report to a table suitable for | ||||||
|     -- concatenating with others to make a compound balance report table. |     -- concatenating with others to make a compound balance report table. | ||||||
|     subreportAsTable ropts (title, r, _) = t |     subreportAsTable ropts1 (title1, r, _) = t | ||||||
|       where |       where | ||||||
|         -- convert to table |         -- convert to table | ||||||
|         Table lefthdrs tophdrs cells = balanceReportAsTable ropts r |         Table lefthdrs tophdrs cells = balanceReportAsTable ropts1 r | ||||||
|         -- tweak the layout |         -- tweak the layout | ||||||
|         t = Table (Tab.Group Tab.SingleLine [Tab.Header title, lefthdrs]) tophdrs ([]:cells) |         t = Table (Tab.Group Tab.SingleLine [Tab.Header title1, lefthdrs]) tophdrs ([]:cells) | ||||||
| 
 | 
 | ||||||
| -- | Render a compound balance report as CSV. | -- | Render a compound balance report as CSV. | ||||||
| -- Subreports' CSV is concatenated, with the headings rows replaced by a | -- Subreports' CSV is concatenated, with the headings rows replaced by a | ||||||
| @ -256,9 +256,9 @@ compoundBalanceReportAsCsv ropts (CompoundPeriodicReport title colspans subrepor | |||||||
|       : concatMap (subreportAsCsv ropts) subreports |       : concatMap (subreportAsCsv ropts) subreports | ||||||
|   where |   where | ||||||
|     -- | Add a subreport title row and drop the heading row. |     -- | Add a subreport title row and drop the heading row. | ||||||
|     subreportAsCsv ropts (subreporttitle, multibalreport, _) = |     subreportAsCsv ropts1 (subreporttitle, multibalreport, _) = | ||||||
|       padRow subreporttitle : |       padRow subreporttitle : | ||||||
|       tail (multiBalanceReportAsCsv ropts multibalreport) |       tail (multiBalanceReportAsCsv ropts1 multibalreport) | ||||||
|     padRow s = take numcols $ s : repeat "" |     padRow s = take numcols $ s : repeat "" | ||||||
|       where |       where | ||||||
|         numcols |         numcols | ||||||
|  | |||||||
| @ -97,7 +97,7 @@ mainmode addons = defMode { | |||||||
| -- | Let's go! | -- | Let's go! | ||||||
| main :: IO () | main :: IO () | ||||||
| main = do | main = do | ||||||
|   progstarttime <- getPOSIXTime |   starttime <- getPOSIXTime | ||||||
| 
 | 
 | ||||||
|   -- Choose and run the appropriate internal or external command based |   -- Choose and run the appropriate internal or external command based | ||||||
|   -- on the raw command-line arguments, cmdarg's interpretation of |   -- on the raw command-line arguments, cmdarg's interpretation of | ||||||
| @ -132,7 +132,7 @@ main = do | |||||||
| 
 | 
 | ||||||
|   -- parse arguments with cmdargs |   -- parse arguments with cmdargs | ||||||
|   opts' <- argsToCliOpts args addons |   opts' <- argsToCliOpts args addons | ||||||
|   let opts = opts'{progstarttime_=progstarttime} |   let opts = opts'{progstarttime_=starttime} | ||||||
| 
 | 
 | ||||||
|   -- select an action and run it. |   -- select an action and run it. | ||||||
|   let |   let | ||||||
| @ -143,13 +143,13 @@ main = do | |||||||
|     hasVersion           = ("--version" `elem`) |     hasVersion           = ("--version" `elem`) | ||||||
|     printUsage           = putStr $ showModeUsage $ mainmode addons |     printUsage           = putStr $ showModeUsage $ mainmode addons | ||||||
|     badCommandError      = error' ("command "++rawcmd++" is not recognized, run with no command to see a list") >> exitFailure  -- PARTIAL: |     badCommandError      = error' ("command "++rawcmd++" is not recognized, run with no command to see a list") >> exitFailure  -- PARTIAL: | ||||||
|     hasHelpFlag args     = any (`elem` args) ["-h","--help"] |     hasHelpFlag args1     = any (`elem` args1) ["-h","--help"] | ||||||
|     hasManFlag args      = (`elem` args) "--man" |     hasManFlag args1      = (`elem` args1) "--man" | ||||||
|     hasInfoFlag args     = (`elem` args) "--info" |     hasInfoFlag args1     = (`elem` args1) "--info" | ||||||
|     f `orShowHelp` mode |     f `orShowHelp` mode1 | ||||||
|       | hasHelpFlag args = putStr $ showModeUsage mode |       | hasHelpFlag args = putStr $ showModeUsage mode1 | ||||||
|       | hasInfoFlag args = runInfoForTopic "hledger" (headMay $ modeNames mode) |       | hasInfoFlag args = runInfoForTopic "hledger" (headMay $ modeNames mode1) | ||||||
|       | hasManFlag args  = runManForTopic "hledger" (headMay $ modeNames mode) |       | hasManFlag args  = runManForTopic "hledger" (headMay $ modeNames mode1) | ||||||
|       | otherwise        = f |       | otherwise        = f | ||||||
|       -- where |       -- where | ||||||
|       --   lastdocflag |       --   lastdocflag | ||||||
| @ -237,7 +237,7 @@ moveFlagsAfterCommand args = moveArgs $ ensureDebugHasArg args | |||||||
|        (bs,["--debug"])                                    -> bs++["--debug=1"] |        (bs,["--debug"])                                    -> bs++["--debug=1"] | ||||||
|        _                                                   -> as |        _                                                   -> as | ||||||
| 
 | 
 | ||||||
|     moveArgs args = insertFlagsAfterCommand $ moveArgs' (args, []) |     moveArgs args1 = insertFlagsAfterCommand $ moveArgs' (args1, []) | ||||||
|       where |       where | ||||||
|         -- -f FILE ..., --alias ALIAS ... |         -- -f FILE ..., --alias ALIAS ... | ||||||
|         moveArgs' ((f:v:a:as), flags) | isMovableReqArgFlag f, isValue v       = moveArgs' (a:as, flags ++ [f,v]) |         moveArgs' ((f:v:a:as), flags) | isMovableReqArgFlag f, isValue v       = moveArgs' (a:as, flags ++ [f,v]) | ||||||
| @ -251,7 +251,7 @@ moveFlagsAfterCommand args = moveArgs $ ensureDebugHasArg args | |||||||
|         moveArgs' (as, flags) = (as, flags) |         moveArgs' (as, flags) = (as, flags) | ||||||
| 
 | 
 | ||||||
|         insertFlagsAfterCommand ([],           flags) = flags |         insertFlagsAfterCommand ([],           flags) = flags | ||||||
|         insertFlagsAfterCommand (command:args, flags) = [command] ++ flags ++ args |         insertFlagsAfterCommand (command1:args2, flags) = [command1] ++ flags ++ args2 | ||||||
| 
 | 
 | ||||||
| isMovableNoArgFlag a  = "-" `isPrefixOf` a && dropWhile (=='-') a `elem` optargflagstomove ++ noargflagstomove | isMovableNoArgFlag a  = "-" `isPrefixOf` a && dropWhile (=='-') a `elem` optargflagstomove ++ noargflagstomove | ||||||
| 
 | 
 | ||||||
|  | |||||||
| @ -181,16 +181,16 @@ maybeFileModificationTime f = do | |||||||
| 
 | 
 | ||||||
| -- | Attempt to open a web browser on the given url, all platforms. | -- | Attempt to open a web browser on the given url, all platforms. | ||||||
| openBrowserOn :: String -> IO ExitCode | openBrowserOn :: String -> IO ExitCode | ||||||
| openBrowserOn u = trybrowsers browsers u | openBrowserOn = trybrowsers browsers | ||||||
|     where |     where | ||||||
|       trybrowsers (b:bs) u = do |       trybrowsers (b:bs) u1 = do | ||||||
|         (e,_,_) <- readProcessWithExitCode b [u] "" |         (e,_,_) <- readProcessWithExitCode b [u1] "" | ||||||
|         case e of |         case e of | ||||||
|           ExitSuccess -> return ExitSuccess |           ExitSuccess -> return ExitSuccess | ||||||
|           ExitFailure _ -> trybrowsers bs u |           ExitFailure _ -> trybrowsers bs u1 | ||||||
|       trybrowsers [] u = do |       trybrowsers [] u1 = do | ||||||
|         putStrLn $ printf "Could not start a web browser (tried: %s)" $ intercalate ", " browsers |         putStrLn $ printf "Could not start a web browser (tried: %s)" $ intercalate ", " browsers | ||||||
|         putStrLn $ printf "Please open your browser and visit %s" u |         putStrLn $ printf "Please open your browser and visit %s" u1 | ||||||
|         return $ ExitFailure 127 |         return $ ExitFailure 127 | ||||||
|       browsers | os=="darwin"  = ["open"] |       browsers | os=="darwin"  = ["open"] | ||||||
|                | os=="mingw32" = ["c:/Program Files/Mozilla Firefox/firefox.exe"] |                | os=="mingw32" = ["c:/Program Files/Mozilla Firefox/firefox.exe"] | ||||||
| @ -270,11 +270,11 @@ postingsOrTransactionsReportAsText alignAll opts itemAsText itemamt itembal repo | |||||||
|     minWidth  = 12 |     minWidth  = 12 | ||||||
|     chunkSize = 1000 |     chunkSize = 1000 | ||||||
| 
 | 
 | ||||||
|     renderItem (amtWidth, balWidth) item@(_, amt, bal) = ((amtWidth', balWidth'), itemBuilder) |     renderItem (amtWidth, balWidth) item@(_, amt1, bal1) = ((amtWidth', balWidth'), itemBuilder) | ||||||
|       where |       where | ||||||
|         itemBuilder = itemAsText amtWidth' balWidth' item |         itemBuilder = itemAsText amtWidth' balWidth' item | ||||||
|         amtWidth' = if alignAll then amtWidth else maximumStrict $ amtWidth : map wbWidth amt |         amtWidth' = if alignAll then amtWidth else maximumStrict $ amtWidth : map wbWidth amt1 | ||||||
|         balWidth' = if alignAll then balWidth else maximumStrict $ balWidth : map wbWidth bal |         balWidth' = if alignAll then balWidth else maximumStrict $ balWidth : map wbWidth bal1 | ||||||
| 
 | 
 | ||||||
|     startWidth f = maximum $ minWidth : map wbWidth (concatMap f startAlign) |     startWidth f = maximum $ minWidth : map wbWidth (concatMap f startAlign) | ||||||
|       where |       where | ||||||
|  | |||||||
| @ -57,19 +57,19 @@ progname = "hledger" | |||||||
| -- so that must not be overridden by a log.date git config variable. | -- so that must not be overridden by a log.date git config variable. | ||||||
| -- | -- | ||||||
| versionStringWith :: Either String GitInfo -> ProgramName -> PackageVersion -> VersionString | versionStringWith :: Either String GitInfo -> ProgramName -> PackageVersion -> VersionString | ||||||
| versionStringWith egitinfo progname packageversion = | versionStringWith egitinfo prognam packagever = | ||||||
|   concat [ progname , " " , version , ", " , os' , "-" , arch ] |   concat [ prognam , " " , version , ", " , os' , "-" , arch ] | ||||||
|   where |   where | ||||||
|     os' | os == "darwin"  = "mac" |     os' | os == "darwin"  = "mac" | ||||||
|         | os == "mingw32" = "windows" |         | os == "mingw32" = "windows" | ||||||
|         | otherwise       = os |         | otherwise       = os | ||||||
|     version = case egitinfo of |     version = case egitinfo of | ||||||
|       Left _err     -> packageversion |       Left _err     -> packagever | ||||||
|       Right gitinfo ->  |       Right gitinfo ->  | ||||||
|         case words $ giCommitDate gitinfo of |         case words $ giCommitDate gitinfo of | ||||||
|           -- git log's date format is normally --date=default ("similar to --date=rfc2822") |           -- git log's date format is normally --date=default ("similar to --date=rfc2822") | ||||||
|           _weekday:mon:day:_localtime:year:_offset:_ -> |           _weekday:mon:day:_localtime:year:_offset:_ -> | ||||||
|             intercalate "-" [packageversion , hash, date] |             intercalate "-" [packagever , hash, date] | ||||||
|               where |               where | ||||||
|                 hash = 'g' : take 9 (giHash gitinfo)  -- like git describe |                 hash = 'g' : take 9 (giHash gitinfo)  -- like git describe | ||||||
|                 date = concat [year,mm,dd] |                 date = concat [year,mm,dd] | ||||||
|  | |||||||
| @ -89,7 +89,6 @@ ghc-options: | |||||||
| - -Wall | - -Wall | ||||||
| - -Wno-incomplete-uni-patterns | - -Wno-incomplete-uni-patterns | ||||||
| - -Wno-missing-signatures | - -Wno-missing-signatures | ||||||
| - -Wno-name-shadowing |  | ||||||
| - -Wno-orphans | - -Wno-orphans | ||||||
| - -Wno-type-defaults | - -Wno-type-defaults | ||||||
| - -Wno-unused-do-bind | - -Wno-unused-do-bind | ||||||
|  | |||||||
		Loading…
	
		Reference in New Issue
	
	Block a user