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