simonmichael/hledger
1
1
Fork 0
mirror of https://github.com/simonmichael/hledger.git synced 2024-12-25 03:13:25 +03:00
Code Issues Projects Releases Wiki Activity

;review, tag all error calls with an easier to find PARTIAL: comment (#1312)

Browse Source
This commit is contained in:
Simon Michael 2020-08-05 16:05:56 -07:00
parent c60ad79727
commit 3f55c23603
45 changed files with 96 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
hledger-lib/Hledger/Data/Amount.hs
View File

@ -466,6 +466,7 @@ instance Num MixedAmount where
fromInteger i = Mixed [fromInteger i] fromInteger i = Mixed [fromInteger i]
negate (Mixed as) = Mixed $ map negate as negate (Mixed as) = Mixed $ map negate as
(+) (Mixed as) (Mixed bs) = normaliseMixedAmount $ Mixed $ as ++ bs (+) (Mixed as) (Mixed bs) = normaliseMixedAmount $ Mixed $ as ++ bs
-- PARTIAL:
(*) = error' "error, mixed amounts do not support multiplication" (*) = error' "error, mixed amounts do not support multiplication"
abs = error' "error, mixed amounts do not support abs" abs = error' "error, mixed amounts do not support abs"
signum = error' "error, mixed amounts do not support signum" signum = error' "error, mixed amounts do not support signum"

2
hledger-lib/Hledger/Data/Commodity.hs
View File

@ -59,7 +59,7 @@ commoditysymbols =
-- | Look up one of the sample commodities' symbol by name. -- | Look up one of the sample commodities' symbol by name.
comm :: String -> CommoditySymbol comm :: String -> CommoditySymbol
comm name = snd $ fromMaybe comm name = snd $ fromMaybe
(error' "commodity lookup failed") (error' "commodity lookup failed") -- PARTIAL:
(find (\n -> fst n == name) commoditysymbols) (find (\n -> fst n == name) commoditysymbols)
-- | Find the conversion rate between two commodities. Currently returns 1. -- | Find the conversion rate between two commodities. Currently returns 1.

13
hledger-lib/Hledger/Data/Dates.hs
View File

@ -241,7 +241,7 @@ splitspan start next span@(DateSpan (Just s) (Just e))
| otherwise = DateSpan (Just subs) (Just sube) : splitspan' start next (DateSpan (Just sube) (Just e)) | otherwise = DateSpan (Just subs) (Just sube) : splitspan' start next (DateSpan (Just sube) (Just e))
where subs = start s where subs = start s
sube = next subs sube = next subs
splitspan' _ _ _ = error' "won't happen, avoids warnings" splitspan' _ _ _ = error' "won't happen, avoids warnings" -- PARTIAL:
-- | Count the days in a DateSpan, or if it is open-ended return Nothing. -- | Count the days in a DateSpan, or if it is open-ended return Nothing.
daysInSpan :: DateSpan -> Maybe Integer daysInSpan :: DateSpan -> Maybe Integer
@ -344,7 +344,7 @@ parsePeriodExpr refdate s = parsewith (periodexprp refdate <* eof) (T.toLower s)
-- | Like parsePeriodExpr, but call error' on failure. -- | Like parsePeriodExpr, but call error' on failure.
parsePeriodExpr' :: Day -> Text -> (Interval, DateSpan) parsePeriodExpr' :: Day -> Text -> (Interval, DateSpan)
parsePeriodExpr' refdate s = parsePeriodExpr' refdate s =
either (error' . ("failed to parse:" ++) . customErrorBundlePretty) id $ either (error' . ("failed to parse:" ++) . customErrorBundlePretty) id $ -- PARTIAL:
parsePeriodExpr refdate s parsePeriodExpr refdate s
maybePeriod :: Day -> Text -> Maybe (Interval,DateSpan) maybePeriod :: Day -> Text -> Maybe (Interval,DateSpan)
@ -385,6 +385,7 @@ spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e)
span (SmartRel This Year) = (thisyear refdate, nextyear refdate) span (SmartRel This Year) = (thisyear refdate, nextyear refdate)
span (SmartRel Last Year) = (prevyear refdate, thisyear refdate) span (SmartRel Last Year) = (prevyear refdate, thisyear refdate)
span (SmartRel Next Year) = (nextyear refdate, startofyear $ addGregorianYearsClip 2 refdate) span (SmartRel Next Year) = (nextyear refdate, startofyear $ addGregorianYearsClip 2 refdate)
-- PARTIAL:
span s@(SmartYMD Nothing Nothing Nothing) = error' $ "Ill-defined SmartDate " ++ show s span s@(SmartYMD Nothing Nothing Nothing) = error' $ "Ill-defined SmartDate " ++ show s
span s@(SmartYMD (Just _) Nothing (Just _)) = error' $ "Ill-defined SmartDate " ++ show s span s@(SmartYMD (Just _) Nothing (Just _)) = error' $ "Ill-defined SmartDate " ++ show s
span (SmartYMD y m (Just d)) = (day, nextday day) where day = fromGregorian (fromMaybe ry y) (fromMaybe rm m) d span (SmartYMD y m (Just d)) = (day, nextday day) where day = fromGregorian (fromMaybe ry y) (fromMaybe rm m) d
@ -398,7 +399,7 @@ spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e)
-- the provided reference date, or raise an error. -- the provided reference date, or raise an error.
fixSmartDateStr :: Day -> Text -> String fixSmartDateStr :: Day -> Text -> String
fixSmartDateStr d s = fixSmartDateStr d s =
either (error' . printf "could not parse date %s %s" (show s) . show) id $ either (error' . printf "could not parse date %s %s" (show s) . show) id $ -- PARTIAL:
(fixSmartDateStrEither d s :: Either (ParseErrorBundle Text CustomErr) String) (fixSmartDateStrEither d s :: Either (ParseErrorBundle Text CustomErr) String)
-- | A safe version of fixSmartDateStr. -- | A safe version of fixSmartDateStr.
@ -562,6 +563,7 @@ startofyear day = fromGregorian y 1 1 where (y,_,_) = toGregorian day
-- 2017-01-01 -- 2017-01-01
nthdayofyearcontaining :: Month -> MonthDay -> Day -> Day nthdayofyearcontaining :: Month -> MonthDay -> Day -> Day
nthdayofyearcontaining m md date nthdayofyearcontaining m md date
-- PARTIAL:
| not (validMonth m) = error' $ "nthdayofyearcontaining: invalid month "++show m | not (validMonth m) = error' $ "nthdayofyearcontaining: invalid month "++show m
| not (validDay md) = error' $ "nthdayofyearcontaining: invalid day " ++show md | not (validDay md) = error' $ "nthdayofyearcontaining: invalid day " ++show md
| mmddOfSameYear <= date = mmddOfSameYear | mmddOfSameYear <= date = mmddOfSameYear
@ -590,6 +592,7 @@ nthdayofyearcontaining m md date
-- 2017-10-30 -- 2017-10-30
nthdayofmonthcontaining :: MonthDay -> Day -> Day nthdayofmonthcontaining :: MonthDay -> Day -> Day
nthdayofmonthcontaining md date nthdayofmonthcontaining md date
-- PARTIAL:
| not (validDay md) = error' $ "nthdayofmonthcontaining: invalid day " ++show md | not (validDay md) = error' $ "nthdayofmonthcontaining: invalid day " ++show md
| nthOfSameMonth <= date = nthOfSameMonth | nthOfSameMonth <= date = nthOfSameMonth
| otherwise = nthOfPrevMonth | otherwise = nthOfPrevMonth
@ -645,8 +648,10 @@ nthweekdayofmonthcontaining n wd d | nthWeekdaySameMonth <= d = nthWeekdaySameM
nthWeekdayPrevMonth = advancetonthweekday n wd $ prevmonth d nthWeekdayPrevMonth = advancetonthweekday n wd $ prevmonth d
-- | Advance to nth weekday wd after given start day s -- | Advance to nth weekday wd after given start day s
-- Can call error.
advancetonthweekday :: Int -> WeekDay -> Day -> Day advancetonthweekday :: Int -> WeekDay -> Day -> Day
advancetonthweekday n wd s = advancetonthweekday n wd s =
-- PARTIAL:
maybe err (addWeeks (n-1)) $ firstMatch (>=s) $ iterate (addWeeks 1) $ firstweekday s maybe err (addWeeks (n-1)) $ firstMatch (>=s) $ iterate (addWeeks 1) $ firstweekday s
where where
err = error' "advancetonthweekday: should not happen" err = error' "advancetonthweekday: should not happen"
@ -694,7 +699,7 @@ parsedateM s = asum [
-- >>> parsedate "2008/02/03" -- >>> parsedate "2008/02/03"
-- 2008-02-03 -- 2008-02-03
parsedate :: String -> Day parsedate :: String -> Day
parsedate s = fromMaybe (error' $ "could not parse date \"" ++ s ++ "\"") parsedate s = fromMaybe (error' $ "could not parse date \"" ++ s ++ "\"") -- PARTIAL:
(parsedateM s) (parsedateM s)
-- doctests I haven't been able to make compatible with both GHC 7 and 8 -- doctests I haven't been able to make compatible with both GHC 7 and 8
-- -- >>> parsedate "2008/02/03/" -- -- >>> parsedate "2008/02/03/"

2
hledger-lib/Hledger/Data/Journal.hs
View File

@ -311,7 +311,7 @@ journalCashAccountQuery :: Journal -> Query
journalCashAccountQuery j = journalCashAccountQuery j =
case M.lookup Cash (jdeclaredaccounttypes j) of case M.lookup Cash (jdeclaredaccounttypes j) of
Just _ -> journalAccountTypeQuery [Cash] notused j Just _ -> journalAccountTypeQuery [Cash] notused j
where notused = error' "journalCashAccountQuery: this should not have happened!" -- XXX ugly where notused = error' "journalCashAccountQuery: this should not have happened!" -- PARTIAL:
Nothing -> And [journalAssetAccountQuery j Nothing -> And [journalAssetAccountQuery j
,Not $ Acct "(investment|receivable|:A/R|:fixed)" ,Not $ Acct "(investment|receivable|:A/R|:fixed)"
] ]

1
hledger-lib/Hledger/Data/Json.hs
View File

@ -242,6 +242,7 @@ writeJsonFile f = TL.writeFile f . toJsonText
readJsonFile :: FromJSON a => FilePath -> IO a readJsonFile :: FromJSON a => FilePath -> IO a
readJsonFile f = do readJsonFile f = do
bl <- BL.readFile f bl <- BL.readFile f
-- PARTIAL:
let v = fromMaybe (error $ "could not decode JSON in "++show f++" to target value") let v = fromMaybe (error $ "could not decode JSON in "++show f++" to target value")
(decode bl :: Maybe Value) (decode bl :: Maybe Value)
case fromJSON v :: FromJSON a => Result a of case fromJSON v :: FromJSON a => Result a of

4
hledger-lib/Hledger/Data/PeriodicTransaction.hs
View File

@ -38,7 +38,7 @@ _ptgen str = do
t = T.pack str t = T.pack str
(i,s) = parsePeriodExpr' nulldate t (i,s) = parsePeriodExpr' nulldate t
case checkPeriodicTransactionStartDate i s t of case checkPeriodicTransactionStartDate i s t of
Just e -> error' e Just e -> error' e -- PARTIAL:
Nothing -> Nothing ->
mapM_ (putStr . showTransaction) $ mapM_ (putStr . showTransaction) $
runPeriodicTransaction runPeriodicTransaction
@ -50,7 +50,7 @@ _ptgenspan str span = do
t = T.pack str t = T.pack str
(i,s) = parsePeriodExpr' nulldate t (i,s) = parsePeriodExpr' nulldate t
case checkPeriodicTransactionStartDate i s t of case checkPeriodicTransactionStartDate i s t of
Just e -> error' e Just e -> error' e -- PARTIAL:
Nothing -> Nothing ->
mapM_ (putStr . showTransaction) $ mapM_ (putStr . showTransaction) $
runPeriodicTransaction runPeriodicTransaction

2
hledger-lib/Hledger/Data/Timeclock.hs
View File

@ -94,7 +94,7 @@ entryFromTimeclockInOut :: TimeclockEntry -> TimeclockEntry -> Transaction
entryFromTimeclockInOut i o entryFromTimeclockInOut i o
| otime >= itime = t | otime >= itime = t
| otherwise = | otherwise =
error' $ "clock-out time less than clock-in time in:\n" ++ showTransaction t error' $ "clock-out time less than clock-in time in:\n" ++ showTransaction t -- PARTIAL:
where where
t = Transaction { t = Transaction {
tindex = 0, tindex = 0,

4
hledger-lib/Hledger/Data/Valuation.hs
View File

@ -167,7 +167,7 @@ amountApplyValuation priceoracle styles periodlast mreportlast today ismultiperi
case v of case v of
AtCost Nothing -> styleAmount styles $ amountCost a AtCost Nothing -> styleAmount styles $ amountCost a
AtCost mc -> amountValueAtDate priceoracle styles mc periodlast $ styleAmount styles $ amountCost a AtCost mc -> amountValueAtDate priceoracle styles mc periodlast $ styleAmount styles $ amountCost a
AtThen _mc -> error' unsupportedValueThenError -- TODO AtThen _mc -> error' unsupportedValueThenError -- PARTIAL:
-- amountValueAtDate priceoracle styles mc periodlast a -- posting date unknown, handle like AtEnd -- amountValueAtDate priceoracle styles mc periodlast a -- posting date unknown, handle like AtEnd
AtEnd mc -> amountValueAtDate priceoracle styles mc periodlast a AtEnd mc -> amountValueAtDate priceoracle styles mc periodlast a
AtNow mc -> amountValueAtDate priceoracle styles mc today a AtNow mc -> amountValueAtDate priceoracle styles mc today a
@ -402,7 +402,7 @@ node m = fst . fst . mkNode m
-- lowest-sorting label is used. -- lowest-sorting label is used.
pathEdgeLabels :: (Show b, Ord b) => Gr a b -> [Node] -> [b] pathEdgeLabels :: (Show b, Ord b) => Gr a b -> [Node] -> [b]
pathEdgeLabels g = map frommaybe . map (nodesEdgeLabel g) . pathEdges pathEdgeLabels g = map frommaybe . map (nodesEdgeLabel g) . pathEdges
where frommaybe = fromMaybe (error' "pathEdgeLabels: expected no Nothings here") where frommaybe = fromMaybe (error' "pathEdgeLabels: expected no Nothings here") -- PARTIAL:
-- | Convert a path to node pairs representing the path's edges. -- | Convert a path to node pairs representing the path's edges.
pathEdges :: [Node] -> [(Node,Node)] pathEdges :: [Node] -> [(Node,Node)]

2
hledger-lib/Hledger/Query.hs
View File

@ -282,7 +282,7 @@ parseQueryTerm _ (T.stripPrefix "status:" -> Just s) =
case parseStatus s of Left e -> Left $ "\"status:"++T.unpack s++"\" gave a parse error: " ++ e case parseStatus s of Left e -> Left $ "\"status:"++T.unpack s++"\" gave a parse error: " ++ e
Right st -> Right $ Left $ StatusQ st Right st -> Right $ Left $ StatusQ st
parseQueryTerm _ (T.stripPrefix "real:" -> Just s) = Right $ Left $ Real $ parseBool s || T.null s parseQueryTerm _ (T.stripPrefix "real:" -> Just s) = Right $ Left $ Real $ parseBool s || T.null s
parseQueryTerm _ (T.stripPrefix "amt:" -> Just s) = Right $ Left $ Amt ord q where (ord, q) = either error id $ parseAmountQueryTerm s parseQueryTerm _ (T.stripPrefix "amt:" -> Just s) = Right $ Left $ Amt ord q where (ord, q) = either error id $ parseAmountQueryTerm s -- PARTIAL:
parseQueryTerm _ (T.stripPrefix "empty:" -> Just s) = Right $ Left $ Empty $ parseBool s parseQueryTerm _ (T.stripPrefix "empty:" -> Just s) = Right $ Left $ Empty $ parseBool s
parseQueryTerm _ (T.stripPrefix "depth:" -> Just s) parseQueryTerm _ (T.stripPrefix "depth:" -> Just s)
| n >= 0 = Right $ Left $ Depth n | n >= 0 = Right $ Left $ Depth n

4
hledger-lib/Hledger/Read.hs
View File

@ -90,7 +90,7 @@ journalDefaultFilename = ".hledger.journal"
-- | Read a Journal from the given text, assuming journal format; or -- | Read a Journal from the given text, assuming journal format; or
-- throw an error. -- throw an error.
readJournal' :: Text -> IO Journal readJournal' :: Text -> IO Journal
readJournal' t = readJournal def Nothing t >>= either error' return readJournal' t = readJournal def Nothing t >>= either error' return -- PARTIAL:
-- | @readJournal iopts mfile txt@ -- | @readJournal iopts mfile txt@
-- --
@ -116,7 +116,7 @@ readJournal iopts mpath txt = do
-- | Read the default journal file specified by the environment, or raise an error. -- | Read the default journal file specified by the environment, or raise an error.
defaultJournal :: IO Journal defaultJournal :: IO Journal
defaultJournal = defaultJournalPath >>= readJournalFile def >>= either error' return defaultJournal = defaultJournalPath >>= readJournalFile def >>= either error' return -- PARTIAL:
-- | Get the default journal file path specified by the environment. -- | Get the default journal file path specified by the environment.
-- Like ledger, we look first for the LEDGER_FILE environment -- Like ledger, we look first for the LEDGER_FILE environment

2
hledger-lib/Hledger/Read/Common.hs
View File

@ -713,7 +713,7 @@ amountp' :: String -> Amount
amountp' s = amountp' s =
case runParser (evalStateT (amountp <* eof) nulljournal) "" (T.pack s) of case runParser (evalStateT (amountp <* eof) nulljournal) "" (T.pack s) of
Right amt -> amt Right amt -> amt
Left err -> error' $ show err -- XXX should throwError Left err -> error' $ show err -- PARTIAL: XXX should throwError
-- | Parse a mixed amount from a string, or get an error. -- | Parse a mixed amount from a string, or get an error.
mamountp' :: String -> MixedAmount mamountp' :: String -> MixedAmount

9
hledger-lib/Hledger/Read/CsvReader.hs
View File

@ -101,7 +101,7 @@ reader = Reader
{rFormat = "csv" {rFormat = "csv"
,rExtensions = ["csv","tsv","ssv"] ,rExtensions = ["csv","tsv","ssv"]
,rReadFn = parse ,rReadFn = parse
,rParser = error' "sorry, CSV files can't be included yet" ,rParser = error' "sorry, CSV files can't be included yet" -- PARTIAL:
} }
-- | Parse and post-process a "Journal" from CSV data, or give an error. -- | Parse and post-process a "Journal" from CSV data, or give an error.
@ -908,6 +908,7 @@ transactionFromCsvRecord sourcepos rules record = t
mdateformat = rule "date-format" mdateformat = rule "date-format"
date = fromMaybe "" $ fieldval "date" date = fromMaybe "" $ fieldval "date"
-- PARTIAL:
date' = fromMaybe (error' $ mkdateerror "date" date mdateformat) $ parsedate' date date' = fromMaybe (error' $ mkdateerror "date" date mdateformat) $ parsedate' date
mdate2 = fieldval "date2" mdate2 = fieldval "date2"
mdate2' = maybe Nothing (maybe (error' $ mkdateerror "date2" (fromMaybe "" mdate2) mdateformat) Just . parsedate') mdate2 mdate2' = maybe Nothing (maybe (error' $ mkdateerror "date2" (fromMaybe "" mdate2) mdateformat) Just . parsedate') mdate2
@ -1010,7 +1011,7 @@ getAmount rules record currency p1IsVirtual n =
[] -> Nothing [] -> Nothing
[(f,a)] | "-out" `isSuffixOf` f -> Just (-a) -- for -out fields, flip the sign [(f,a)] | "-out" `isSuffixOf` f -> Just (-a) -- for -out fields, flip the sign
[(_,a)] -> Just a [(_,a)] -> Just a
fs -> error' $ unlines $ [ fs -> error' $ unlines $ [ -- PARTIAL:
"multiple non-zero amounts or multiple zero amounts assigned," "multiple non-zero amounts or multiple zero amounts assigned,"
,"please ensure just one. (https://hledger.org/csv.html#amount)" ,"please ensure just one. (https://hledger.org/csv.html#amount)"
," " ++ showRecord record ," " ++ showRecord record
@ -1028,7 +1029,7 @@ getAmount rules record currency p1IsVirtual n =
-- The CSV rules and record are provided for the error message. -- The CSV rules and record are provided for the error message.
parseAmount :: CsvRules -> CsvRecord -> String -> String -> MixedAmount parseAmount :: CsvRules -> CsvRecord -> String -> String -> MixedAmount
parseAmount rules record currency amountstr = parseAmount rules record currency amountstr =
either mkerror (Mixed . (:[])) $ either mkerror (Mixed . (:[])) $ -- PARTIAL:
runParser (evalStateT (amountp <* eof) nulljournal) "" $ runParser (evalStateT (amountp <* eof) nulljournal) "" $
T.pack $ (currency++) $ simplifySign amountstr T.pack $ (currency++) $ simplifySign amountstr
where where
@ -1086,7 +1087,7 @@ mkBalanceAssertion rules record (amt, pos) = assrt{baamount=amt, baposition=pos}
Just "==" -> nullassertion{batotal=True} Just "==" -> nullassertion{batotal=True}
Just "=*" -> nullassertion{bainclusive=True} Just "=*" -> nullassertion{bainclusive=True}
Just "==*" -> nullassertion{batotal=True, bainclusive=True} Just "==*" -> nullassertion{batotal=True, bainclusive=True}
Just x -> error' $ unlines Just x -> error' $ unlines -- PARTIAL:
[ "balance-type \"" ++ x ++"\" is invalid. Use =, ==, =* or ==*." [ "balance-type \"" ++ x ++"\" is invalid. Use =, ==, =* or ==*."
, showRecord record , showRecord record
, showRules rules record , showRules rules record

3
hledger-lib/Hledger/Reports/AccountTransactionsReport.hs
View File

@ -110,13 +110,14 @@ accountTransactionsReport ropts j reportq thisacctq = (label, items)
filter (matchesTransaction thisacctq . filterTransactionPostings (And [realq, statusq])) ts2 filter (matchesTransaction thisacctq . filterTransactionPostings (And [realq, statusq])) ts2
-- maybe convert these transactions to cost or value -- maybe convert these transactions to cost or value
-- PARTIAL:
prices = journalPriceOracle (infer_value_ ropts) j prices = journalPriceOracle (infer_value_ ropts) j
styles = journalCommodityStyles j styles = journalCommodityStyles j
periodlast = periodlast =
fromMaybe (error' "journalApplyValuation: expected a non-empty journal") $ -- XXX shouldn't happen fromMaybe (error' "journalApplyValuation: expected a non-empty journal") $ -- XXX shouldn't happen
reportPeriodOrJournalLastDay ropts j reportPeriodOrJournalLastDay ropts j
mreportlast = reportPeriodLastDay ropts mreportlast = reportPeriodLastDay ropts
today = fromMaybe (error' "journalApplyValuation: could not pick a valuation date, ReportOpts today_ is unset") $ today_ ropts today = fromMaybe (error' "journalApplyValuation: could not pick a valuation date, ReportOpts today_ is unset") $ today_ ropts -- XXX shouldn't happen
multiperiod = interval_ ropts /= NoInterval multiperiod = interval_ ropts /= NoInterval
tval = case value_ ropts of tval = case value_ ropts of
Just v -> \t -> transactionApplyValuation prices styles periodlast mreportlast today multiperiod t v Just v -> \t -> transactionApplyValuation prices styles periodlast mreportlast today multiperiod t v

4
hledger-lib/Hledger/Reports/BudgetReport.hs
View File

@ -101,7 +101,7 @@ budgetReport ropts' assrt reportspan d j = dbg1 "sortedbudgetreport" budgetrepor
-- their purpose is to set goal amounts (of change) per account and period. -- their purpose is to set goal amounts (of change) per account and period.
budgetJournal :: Bool -> ReportOpts -> DateSpan -> Journal -> Journal budgetJournal :: Bool -> ReportOpts -> DateSpan -> Journal -> Journal
budgetJournal assrt _ropts reportspan j = budgetJournal assrt _ropts reportspan j =
either error' id $ journalBalanceTransactions assrt j{ jtxns = budgetts } either error' id $ journalBalanceTransactions assrt j{ jtxns = budgetts } -- PARTIAL:
where where
budgetspan = dbg2 "budgetspan" $ reportspan budgetspan = dbg2 "budgetspan" $ reportspan
budgetts = budgetts =
@ -218,7 +218,7 @@ budgetReportAsText ropts@ReportOpts{..} budgetr =
(showDateSpan $ periodicReportSpan budgetr) (showDateSpan $ periodicReportSpan budgetr)
(case value_ of (case value_ of
Just (AtCost _mc) -> ", valued at cost" Just (AtCost _mc) -> ", valued at cost"
Just (AtThen _mc) -> error' unsupportedValueThenError -- TODO Just (AtThen _mc) -> error' unsupportedValueThenError -- PARTIAL:
Just (AtEnd _mc) -> ", valued at period ends" Just (AtEnd _mc) -> ", valued at period ends"
Just (AtNow _mc) -> ", current value" Just (AtNow _mc) -> ", current value"
-- XXX duplicates the above -- XXX duplicates the above

2
hledger-lib/Hledger/Reports/EntriesReport.hs
View File

@ -45,7 +45,7 @@ entriesReport ropts@ReportOpts{..} q j@Journal{..} =
where where
periodlast = fromMaybe today $ reportPeriodOrJournalLastDay ropts j periodlast = fromMaybe today $ reportPeriodOrJournalLastDay ropts j
mreportlast = reportPeriodLastDay ropts mreportlast = reportPeriodLastDay ropts
today = fromMaybe (error' "erValue: could not pick a valuation date, ReportOpts today_ is unset") today_ -- should not happen today = fromMaybe (error' "erValue: could not pick a valuation date, ReportOpts today_ is unset") today_ -- PARTIAL: should not happen
tests_EntriesReport = tests "EntriesReport" [ tests_EntriesReport = tests "EntriesReport" [
tests "entriesReport" [ tests "entriesReport" [

9
hledger-lib/Hledger/Reports/MultiBalanceReport.hs
View File

@ -318,7 +318,7 @@ accumValueAmounts :: ReportOpts -> Journal -> PriceOracle -> [DateSpan]
-> HashMap ClippedAccountName Account -> HashMap ClippedAccountName Account
-> HashMap ClippedAccountName (Map DateSpan Account) -> HashMap ClippedAccountName (Map DateSpan Account)
-> HashMap ClippedAccountName (Map DateSpan Account) -> HashMap ClippedAccountName (Map DateSpan Account)
accumValueAmounts ropts j priceoracle colspans startbals acctchanges = accumValueAmounts ropts j priceoracle colspans startbals acctchanges = -- PARTIAL:
HM.mapWithKey processRow $ acctchanges <> (mempty <$ startbals) HM.mapWithKey processRow $ acctchanges <> (mempty <$ startbals)
where where
-- Must accumulate before valuing, since valuation can change without any -- Must accumulate before valuing, since valuation can change without any
@ -565,10 +565,13 @@ subaccountTallies as = foldr incrementParent mempty allaccts
allaccts = expandAccountNames as allaccts = expandAccountNames as
incrementParent a = HM.insertWith (+) (parentAccountName a) 1 incrementParent a = HM.insertWith (+) (parentAccountName a) 1
-- | Helper to calculate the percentage from two mixed. Keeps the sign of the first argument. -- | A helper: what percentage is the second mixed amount of the first ?
-- Keeps the sign of the first amount.
-- Uses unifyMixedAmount to unify each argument and then divides them. -- Uses unifyMixedAmount to unify each argument and then divides them.
-- Both amounts should be in the same, single commodity.
-- This can call error if the arguments are not right.
perdivide :: MixedAmount -> MixedAmount -> MixedAmount perdivide :: MixedAmount -> MixedAmount -> MixedAmount
perdivide a b = fromMaybe (error' errmsg) $ do perdivide a b = fromMaybe (error' errmsg) $ do -- PARTIAL:
a' <- unifyMixedAmount a a' <- unifyMixedAmount a
b' <- unifyMixedAmount b b' <- unifyMixedAmount b
guard $ amountIsZero a' || amountIsZero b' || acommodity a' == acommodity b' guard $ amountIsZero a' || amountIsZero b' || acommodity a' == acommodity b'

6
hledger-lib/Hledger/Reports/PostingsReport.hs
View File

@ -76,7 +76,7 @@ postingsReport ropts@ReportOpts{..} q j =
styles = journalCommodityStyles j styles = journalCommodityStyles j
priceoracle = journalPriceOracle infer_value_ j priceoracle = journalPriceOracle infer_value_ j
multiperiod = interval_ /= NoInterval multiperiod = interval_ /= NoInterval
today = fromMaybe (error' "postingsReport: could not pick a valuation date, ReportOpts today_ is unset") today_ today = fromMaybe (error' "postingsReport: could not pick a valuation date, ReportOpts today_ is unset") today_ -- PARTIAL:
-- postings to be included in the report, and similarly-matched postings before the report start date -- postings to be included in the report, and similarly-matched postings before the report start date
(precedingps, reportps) = matchedPostingsBeforeAndDuring ropts q j reportspan (precedingps, reportps) = matchedPostingsBeforeAndDuring ropts q j reportspan
@ -95,7 +95,7 @@ postingsReport ropts@ReportOpts{..} q j =
where where
mreportlast = reportPeriodLastDay ropts mreportlast = reportPeriodLastDay ropts
reportorjournallast = reportorjournallast =
fromMaybe (error' "postingsReport: expected a non-empty journal") $ -- XXX shouldn't happen fromMaybe (error' "postingsReport: expected a non-empty journal") $ -- PARTIAL: shouldn't happen
reportPeriodOrJournalLastDay ropts j reportPeriodOrJournalLastDay ropts j
-- Posting report items ready for display. -- Posting report items ready for display.
@ -118,7 +118,7 @@ postingsReport ropts@ReportOpts{..} q j =
-- XXX constrain valuation type to AtDate daybeforereportstart here ? -- XXX constrain valuation type to AtDate daybeforereportstart here ?
where where
daybeforereportstart = daybeforereportstart =
maybe (error' "postingsReport: expected a non-empty journal") -- XXX shouldn't happen maybe (error' "postingsReport: expected a non-empty journal") -- PARTIAL: shouldn't happen
(addDays (-1)) (addDays (-1))
$ reportPeriodOrJournalStart ropts j $ reportPeriodOrJournalStart ropts j

6
hledger-lib/Hledger/Reports/ReportOptions.hs
View File

@ -327,7 +327,7 @@ intervalFromRawOpts = lastDef NoInterval . collectopts intervalfromrawopt
(\e -> usageError $ "could not parse period option: "++customErrorBundlePretty e) (\e -> usageError $ "could not parse period option: "++customErrorBundlePretty e)
extractIntervalOrNothing $ extractIntervalOrNothing $
parsePeriodExpr parsePeriodExpr
(error' "intervalFromRawOpts: did not expect to need today's date here") -- should not happen; we are just getting the interval, which does not use the reference date (error' "intervalFromRawOpts: did not expect to need today's date here") -- PARTIAL: should not happen; we are just getting the interval, which does not use the reference date
(stripquotes $ T.pack v) (stripquotes $ T.pack v)
| n == "daily" = Just $ Days 1 | n == "daily" = Just $ Days 1
| n == "weekly" = Just $ Weeks 1 | n == "weekly" = Just $ Weeks 1
@ -466,7 +466,7 @@ queryFromOpts :: Day -> ReportOpts -> Query
queryFromOpts d ropts = simplifyQuery . And $ [flagsq, argsq] queryFromOpts d ropts = simplifyQuery . And $ [flagsq, argsq]
where where
flagsq = queryFromOptsOnly d ropts flagsq = queryFromOptsOnly d ropts
argsq = fst $ either error' id $ parseQuery d (T.pack $ query_ ropts) -- TODO: argsq = fst $ either error' id $ parseQuery d (T.pack $ query_ ropts) -- PARTIAL:
-- | Convert report options to a query, ignoring any non-flag command line arguments. -- | Convert report options to a query, ignoring any non-flag command line arguments.
queryFromOptsOnly :: Day -> ReportOpts -> Query queryFromOptsOnly :: Day -> ReportOpts -> Query
@ -484,7 +484,7 @@ queryFromOptsOnly _d ReportOpts{..} = simplifyQuery $ And flagsq
-- | Convert report options and arguments to query options. -- | Convert report options and arguments to query options.
-- If there is a parsing problem, this function calls error. -- If there is a parsing problem, this function calls error.
queryOptsFromOpts :: Day -> ReportOpts -> [QueryOpt] queryOptsFromOpts :: Day -> ReportOpts -> [QueryOpt]
queryOptsFromOpts d = snd . either error' id . parseQuery d . T.pack . query_ queryOptsFromOpts d = snd . either error' id . parseQuery d . T.pack . query_ -- PARTIAL:
-- Report dates. -- Report dates.

3
hledger-lib/Hledger/Utils.hs
View File

@ -162,7 +162,8 @@ applyN n f | n < 1 = id
expandPath :: FilePath -> FilePath -> IO FilePath -- general type sig for use in reader parsers expandPath :: FilePath -> FilePath -> IO FilePath -- general type sig for use in reader parsers
expandPath _ "-" = return "-" expandPath _ "-" = return "-"
expandPath curdir p = (if isRelative p then (curdir </>) else id) `liftM` expandHomePath p expandPath curdir p = (if isRelative p then (curdir </>) else id) `liftM` expandHomePath p
-- PARTIAL:
-- | Expand user home path indicated by tilde prefix -- | Expand user home path indicated by tilde prefix
expandHomePath :: FilePath -> IO FilePath expandHomePath :: FilePath -> IO FilePath
expandHomePath = \case expandHomePath = \case

2
hledger-lib/Hledger/Utils/Parse.hs
View File

@ -108,7 +108,7 @@ fromparse
fromparse = either parseerror id fromparse = either parseerror id
parseerror :: (Show t, Show (Token t), Show e) => ParseErrorBundle t e -> a parseerror :: (Show t, Show (Token t), Show e) => ParseErrorBundle t e -> a
parseerror e = error' $ showParseError e parseerror e = error' $ showParseError e -- PARTIAL:
showParseError showParseError
:: (Show t, Show (Token t), Show e) :: (Show t, Show (Token t), Show e)

1
hledger-lib/Hledger/Utils/Regex.hs
View File

@ -130,6 +130,7 @@ replaceMatch replpat s matchgroups = pre ++ repl ++ post
replaceBackReference :: MatchText String -> String -> String replaceBackReference :: MatchText String -> String -> String
replaceBackReference grps ('\\':s@(_:_)) | all isDigit s = replaceBackReference grps ('\\':s@(_:_)) | all isDigit s =
case read s of n | n `elem` indices grps -> fst (grps ! n) case read s of n | n `elem` indices grps -> fst (grps ! n)
-- PARTIAL:D
_ -> error' $ "no match group exists for backreference \"\\"++s++"\"" _ -> error' $ "no match group exists for backreference \"\\"++s++"\""
replaceBackReference _ s = error' $ "replaceBackReference called on non-numeric-backreference \""++s++"\", shouldn't happen" replaceBackReference _ s = error' $ "replaceBackReference called on non-numeric-backreference \""++s++"\", shouldn't happen"

6
hledger-ui/Hledger/UI/AccountsScreen.hs
View File

@ -116,7 +116,7 @@ asInit d reset ui@UIState{
} }
asInit _ _ _ = error "init function called with wrong screen type, should not happen" asInit _ _ _ = error "init function called with wrong screen type, should not happen" -- PARTIAL:
asDraw :: UIState -> [Widget Name] asDraw :: UIState -> [Widget Name]
asDraw UIState{aopts=_uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}} asDraw UIState{aopts=_uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}
@ -222,7 +222,7 @@ asDraw UIState{aopts=_uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}
,("q", str "quit") ,("q", str "quit")
] ]
asDraw _ = error "draw function called with wrong screen type, should not happen" asDraw _ = error "draw function called with wrong screen type, should not happen" -- PARTIAL:
asDrawItem :: (Int,Int) -> Bool -> AccountsScreenItem -> Widget Name asDrawItem :: (Int,Int) -> Bool -> AccountsScreenItem -> Widget Name
asDrawItem (acctwidth, balwidth) selected AccountsScreenItem{..} = asDrawItem (acctwidth, balwidth) selected AccountsScreenItem{..} =
@ -393,7 +393,7 @@ asHandle ui0@UIState{
where where
journalspan = journalDateSpan False j journalspan = journalDateSpan False j
asHandle _ _ = error "event handler called with wrong screen type, should not happen" asHandle _ _ = error "event handler called with wrong screen type, should not happen" -- PARTIAL:
asSetSelectedAccount a s@AccountsScreen{} = s & asSelectedAccount .~ a asSetSelectedAccount a s@AccountsScreen{} = s & asSelectedAccount .~ a
asSetSelectedAccount _ s = s asSetSelectedAccount _ s = s

6
hledger-ui/Hledger/UI/ErrorScreen.hs
View File

@ -41,7 +41,7 @@ errorScreen = ErrorScreen{
esInit :: Day -> Bool -> UIState -> UIState esInit :: Day -> Bool -> UIState -> UIState
esInit _ _ ui@UIState{aScreen=ErrorScreen{}} = ui esInit _ _ ui@UIState{aScreen=ErrorScreen{}} = ui
esInit _ _ _ = error "init function called with wrong screen type, should not happen" esInit _ _ _ = error "init function called with wrong screen type, should not happen" -- PARTIAL:
esDraw :: UIState -> [Widget Name] esDraw :: UIState -> [Widget Name]
esDraw UIState{aopts=UIOpts{cliopts_=copts@CliOpts{}} esDraw UIState{aopts=UIOpts{cliopts_=copts@CliOpts{}}
@ -72,7 +72,7 @@ esDraw UIState{aopts=UIOpts{cliopts_=copts@CliOpts{}}
,("q", "quit") ,("q", "quit")
] ]
esDraw _ = error "draw function called with wrong screen type, should not happen" esDraw _ = error "draw function called with wrong screen type, should not happen" -- PARTIAL:
esHandle :: UIState -> BrickEvent Name AppEvent -> EventM Name (Next UIState) esHandle :: UIState -> BrickEvent Name AppEvent -> EventM Name (Next UIState)
esHandle ui@UIState{aScreen=ErrorScreen{..} esHandle ui@UIState{aScreen=ErrorScreen{..}
@ -111,7 +111,7 @@ esHandle ui@UIState{aScreen=ErrorScreen{..}
VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui
_ -> continue ui _ -> continue ui
esHandle _ _ = error "event handler called with wrong screen type, should not happen" esHandle _ _ = error "event handler called with wrong screen type, should not happen" -- PARTIAL:
-- | Parse the file name, line and column number from a hledger parse error message, if possible. -- | Parse the file name, line and column number from a hledger parse error message, if possible.
-- Temporary, we should keep the original parse error location. XXX -- Temporary, we should keep the original parse error location. XXX

4
hledger-ui/Hledger/UI/Main.hs
View File

@ -108,7 +108,7 @@ runBrickUi uopts@UIOpts{cliopts_=copts@CliOpts{inputopts_=_iopts,reportopts_=rop
where where
q = queryFromOpts d ropts q = queryFromOpts d ropts
datespanfromargs = queryDateSpan (date2_ ropts) $ fst $ datespanfromargs = queryDateSpan (date2_ ropts) $ fst $
either error' id $ parseQuery d (T.pack $ query_ ropts) either error' id $ parseQuery d (T.pack $ query_ ropts) -- PARTIAL:
periodfromoptsandargs = periodfromoptsandargs =
dateSpanAsPeriod $ spansIntersect [periodAsDateSpan $ period_ ropts, datespanfromargs] dateSpanAsPeriod $ spansIntersect [periodAsDateSpan $ period_ ropts, datespanfromargs]
filteredQueryArg = \case filteredQueryArg = \case
@ -130,7 +130,7 @@ runBrickUi uopts@UIOpts{cliopts_=copts@CliOpts{inputopts_=_iopts,reportopts_=rop
Just apat -> (rsSetAccount acct False registerScreen, [ascr']) Just apat -> (rsSetAccount acct False registerScreen, [ascr'])
where where
acct = headDef acct = headDef
(error' $ "--register "++apat++" did not match any account") (error' $ "--register "++apat++" did not match any account") -- PARTIAL:
$ filter (regexMatches apat . T.unpack) $ journalAccountNames j $ filter (regexMatches apat . T.unpack) $ journalAccountNames j
-- Initialising the accounts screen is awkward, requiring -- Initialising the accounts screen is awkward, requiring
-- another temporary UIState value.. -- another temporary UIState value..

6
hledger-ui/Hledger/UI/RegisterScreen.hs
View File

@ -135,7 +135,7 @@ rsInit d reset ui@UIState{aopts=_uopts@UIOpts{cliopts_=CliOpts{reportopts_=ropts
ts = map rsItemTransaction displayitems ts = map rsItemTransaction displayitems
endidx = length displayitems - 1 endidx = length displayitems - 1
rsInit _ _ _ = error "init function called with wrong screen type, should not happen" rsInit _ _ _ = error "init function called with wrong screen type, should not happen" -- PARTIAL:
rsDraw :: UIState -> [Widget Name] rsDraw :: UIState -> [Widget Name]
rsDraw UIState{aopts=_uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}} rsDraw UIState{aopts=_uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}
@ -248,7 +248,7 @@ rsDraw UIState{aopts=_uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}
-- ,("q", "quit") -- ,("q", "quit")
] ]
rsDraw _ = error "draw function called with wrong screen type, should not happen" rsDraw _ = error "draw function called with wrong screen type, should not happen" -- PARTIAL:
rsDrawItem :: (Int,Int,Int,Int,Int) -> Bool -> RegisterScreenItem -> Widget Name rsDrawItem :: (Int,Int,Int,Int,Int) -> Bool -> RegisterScreenItem -> Widget Name
rsDrawItem (datewidth,descwidth,acctswidth,changewidth,balwidth) selected RegisterScreenItem{..} = rsDrawItem (datewidth,descwidth,acctswidth,changewidth,balwidth) selected RegisterScreenItem{..} =
@ -396,7 +396,7 @@ rsHandle ui@UIState{
MouseDown _ _ _ _ -> continue ui MouseDown _ _ _ _ -> continue ui
MouseUp _ _ _ -> continue ui MouseUp _ _ _ -> continue ui
rsHandle _ _ = error "event handler called with wrong screen type, should not happen" rsHandle _ _ = error "event handler called with wrong screen type, should not happen" -- PARTIAL:
isBlankElement mel = ((rsItemDate . snd) <$> mel) == Just "" isBlankElement mel = ((rsItemDate . snd) <$> mel) == Just ""

10
hledger-ui/Hledger/UI/TransactionScreen.hs
View File

@ -55,7 +55,7 @@ tsInit _d _reset ui@UIState{aopts=UIOpts{cliopts_=CliOpts{reportopts_=_ropts}}
-- (acommodity$head$amounts$pamount$head$tpostings$snd$tsTransaction) -- (acommodity$head$amounts$pamount$head$tpostings$snd$tsTransaction)
-- `seq` -- `seq`
ui ui
tsInit _ _ _ = error "init function called with wrong screen type, should not happen" tsInit _ _ _ = error "init function called with wrong screen type, should not happen" -- PARTIAL:
tsDraw :: UIState -> [Widget Name] tsDraw :: UIState -> [Widget Name]
tsDraw UIState{aopts=UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}} tsDraw UIState{aopts=UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}
@ -76,10 +76,10 @@ tsDraw UIState{aopts=UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}
prices = journalPriceOracle (infer_value_ ropts) j prices = journalPriceOracle (infer_value_ ropts) j
styles = journalCommodityStyles j styles = journalCommodityStyles j
periodlast = periodlast =
fromMaybe (error' "TransactionScreen: expected a non-empty journal") $ -- XXX shouldn't happen fromMaybe (error' "TransactionScreen: expected a non-empty journal") $ -- PARTIAL: shouldn't happen
reportPeriodOrJournalLastDay ropts j reportPeriodOrJournalLastDay ropts j
mreportlast = reportPeriodLastDay ropts mreportlast = reportPeriodLastDay ropts
today = fromMaybe (error' "TransactionScreen: could not pick a valuation date, ReportOpts today_ is unset") $ today_ ropts today = fromMaybe (error' "TransactionScreen: could not pick a valuation date, ReportOpts today_ is unset") $ today_ ropts -- PARTIAL:
multiperiod = interval_ ropts /= NoInterval multiperiod = interval_ ropts /= NoInterval
render $ defaultLayout toplabel bottomlabel $ str $ render $ defaultLayout toplabel bottomlabel $ str $
@ -126,7 +126,7 @@ tsDraw UIState{aopts=UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}
,("q", "quit") ,("q", "quit")
] ]
tsDraw _ = error "draw function called with wrong screen type, should not happen" tsDraw _ = error "draw function called with wrong screen type, should not happen" -- PARTIAL:
tsHandle :: UIState -> BrickEvent Name AppEvent -> EventM Name (Next UIState) tsHandle :: UIState -> BrickEvent Name AppEvent -> EventM Name (Next UIState)
tsHandle ui@UIState{aScreen=s@TransactionScreen{tsTransaction=(i,t) tsHandle ui@UIState{aScreen=s@TransactionScreen{tsTransaction=(i,t)
@ -204,7 +204,7 @@ tsHandle ui@UIState{aScreen=s@TransactionScreen{tsTransaction=(i,t)
VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui VtyEvent (EvKey (KChar 'z') [MCtrl]) -> suspend ui
_ -> continue ui _ -> continue ui
tsHandle _ _ = error "event handler called with wrong screen type, should not happen" tsHandle _ _ = error "event handler called with wrong screen type, should not happen" -- PARTIAL:
-- Got to redo the register screen's transactions report, to get the latest transactions list for this screen. -- Got to redo the register screen's transactions report, to get the latest transactions list for this screen.
-- XXX Duplicates rsInit. Why do we have to do this as well as regenerateScreens ? -- XXX Duplicates rsInit. Why do we have to do this as well as regenerateScreens ?

2
hledger-web/Hledger/Web/Handler/RegisterR.hs
View File

@ -86,7 +86,7 @@ undecorateLinks xs0@(x:_) =
let (link, xs1) = span (isJust . fst) xs0 let (link, xs1) = span (isJust . fst) xs0
(comma, xs2) = span (isNothing . fst) xs1 (comma, xs2) = span (isNothing . fst) xs1
in (acct, (map snd link, map snd comma)) : undecorateLinks xs2 in (acct, (map snd link, map snd comma)) : undecorateLinks xs2
_ -> error "link name not decorated with account" _ -> error "link name not decorated with account" -- PARTIAL:
decorateLinks :: [(acct, ([char], [char]))] -> [(Maybe acct, char)] decorateLinks :: [(acct, ([char], [char]))] -> [(Maybe acct, char)]
decorateLinks = decorateLinks =

2
hledger-web/Hledger/Web/WebOptions.hs
View File

@ -134,7 +134,7 @@ rawOptsToWebOpts rawopts =
maybestringopt "base-url" rawopts maybestringopt "base-url" rawopts
caps' = join $ T.splitOn "," . T.pack <$> listofstringopt "capabilities" rawopts caps' = join $ T.splitOn "," . T.pack <$> listofstringopt "capabilities" rawopts
caps = case traverse capabilityFromText caps' of caps = case traverse capabilityFromText caps' of
Left e -> error' ("Unknown capability: " ++ T.unpack e) Left e -> error' ("Unknown capability: " ++ T.unpack e) -- PARTIAL:
Right [] -> [CapView, CapAdd] Right [] -> [CapView, CapAdd]
Right xs -> xs Right xs -> xs
sock = stripTrailingSlash <$> maybestringopt "socket" rawopts sock = stripTrailingSlash <$> maybestringopt "socket" rawopts

2
hledger-web/Hledger/Web/Widget/AddForm.hs
View File

@ -91,7 +91,7 @@ addForm j today = identifyForm "add" $ \extra -> do
listField = Field listField = Field
{ fieldParse = const . pure . Right . Just . dropWhileEnd T.null { fieldParse = const . pure . Right . Just . dropWhileEnd T.null
, fieldView = error "Don't render using this!" , fieldView = error "Don't render using this!" -- PARTIAL:
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }

2
hledger/Hledger/Cli/CliOptions.hs
View File

@ -323,7 +323,7 @@ hledgerCommandMode :: CommandDoc -> [Flag RawOpts] -> [(String, [Flag RawOpts])]
-> [Flag RawOpts] -> ([Arg RawOpts], Maybe (Arg RawOpts)) -> Mode RawOpts -> [Flag RawOpts] -> ([Arg RawOpts], Maybe (Arg RawOpts)) -> Mode RawOpts
hledgerCommandMode doc unnamedflaggroup namedflaggroups hiddenflaggroup argsdescr = hledgerCommandMode doc unnamedflaggroup namedflaggroups hiddenflaggroup argsdescr =
case parseCommandDoc doc of case parseCommandDoc doc of
Nothing -> error' $ "Could not parse command doc:\n"++doc++"\n" Nothing -> error' $ "Could not parse command doc:\n"++doc++"\n" -- PARTIAL:
Just (names, shorthelp, longhelplines) -> Just (names, shorthelp, longhelplines) ->
(defCommandMode names) { (defCommandMode names) {
modeHelp = shorthelp modeHelp = shorthelp

8
hledger/Hledger/Cli/Commands.hs
View File

@ -304,7 +304,7 @@ tests_Commands = tests "Commands" [
let let
ignoresourcepos j = j{jtxns=map (\t -> t{tsourcepos=nullsourcepos}) (jtxns j)} ignoresourcepos j = j{jtxns=map (\t -> t{tsourcepos=nullsourcepos}) (jtxns j)}
sameParse str1 str2 = do sameParse str1 str2 = do
j1 <- readJournal def Nothing str1 >>= either error' (return . ignoresourcepos) j1 <- readJournal def Nothing str1 >>= either error' (return . ignoresourcepos) -- PARTIAL:
j2 <- readJournal def Nothing str2 >>= either error' (return . ignoresourcepos) j2 <- readJournal def Nothing str2 >>= either error' (return . ignoresourcepos)
j1 @?= j2{jlastreadtime=jlastreadtime j1, jfiles=jfiles j1} --, jparsestate=jparsestate j1} j1 @?= j2{jlastreadtime=jlastreadtime j1, jfiles=jfiles j1} --, jparsestate=jparsestate j1}
sameParse sameParse
@ -322,19 +322,19 @@ tests_Commands = tests "Commands" [
) )
,test "preserves \"virtual\" posting type" $ do ,test "preserves \"virtual\" posting type" $ do
j <- readJournal def Nothing "apply account test\n2008/12/07 One\n (from) $-1\n (to) $1\n" >>= either error' return j <- readJournal def Nothing "apply account test\n2008/12/07 One\n (from) $-1\n (to) $1\n" >>= either error' return -- PARTIAL:
let p = head $ tpostings $ head $ jtxns j let p = head $ tpostings $ head $ jtxns j
paccount p @?= "test:from" paccount p @?= "test:from"
ptype p @?= VirtualPosting ptype p @?= VirtualPosting
] ]
,test "alias directive" $ do ,test "alias directive" $ do
j <- readJournal def Nothing "!alias expenses = equity:draw:personal\n1/1\n (expenses:food) 1\n" >>= either error' return j <- readJournal def Nothing "!alias expenses = equity:draw:personal\n1/1\n (expenses:food) 1\n" >>= either error' return -- PARTIAL:
let p = head $ tpostings $ head $ jtxns j let p = head $ tpostings $ head $ jtxns j
paccount p @?= "equity:draw:personal:food" paccount p @?= "equity:draw:personal:food"
,test "Y default year directive" $ do ,test "Y default year directive" $ do
j <- readJournal def Nothing defaultyear_journal_txt >>= either error' return j <- readJournal def Nothing defaultyear_journal_txt >>= either error' return -- PARTIAL:
tdate (head $ jtxns j) @?= fromGregorian 2009 1 1 tdate (head $ jtxns j) @?= fromGregorian 2009 1 1
,test "ledgerAccountNames" $ ,test "ledgerAccountNames" $

2
hledger/Hledger/Cli/Commands/Add.hs
View File

@ -121,7 +121,7 @@ getAndAddTransactions es@EntryState{..} = (do
let defaultPrevInput = PrevInput{prevDateAndCode=Nothing, prevDescAndCmnt=Nothing, prevAccount=[], prevAmountAndCmnt=[]} let defaultPrevInput = PrevInput{prevDateAndCode=Nothing, prevDescAndCmnt=Nothing, prevAccount=[], prevAmountAndCmnt=[]}
mt <- runInputT (setComplete noCompletion defaultSettings) (System.Console.Wizard.run $ haskeline $ confirmedTransactionWizard defaultPrevInput es []) mt <- runInputT (setComplete noCompletion defaultSettings) (System.Console.Wizard.run $ haskeline $ confirmedTransactionWizard defaultPrevInput es [])
case mt of case mt of
Nothing -> error "Could not interpret the input, restarting" -- caught below causing a restart, I believe Nothing -> error "Could not interpret the input, restarting" -- caught below causing a restart, I believe -- PARTIAL:
Just t -> do Just t -> do
j <- if debug_ esOpts > 0 j <- if debug_ esOpts > 0
then do hPrintf stderr "Skipping journal add due to debug mode.\n" then do hPrintf stderr "Skipping journal add due to debug mode.\n"

6
hledger/Hledger/Cli/Commands/Aregister.hs
View File

@ -74,10 +74,10 @@ aregister opts@CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do
d <- getCurrentDay d <- getCurrentDay
-- the first argument specifies the account, any remaining arguments are a filter query -- the first argument specifies the account, any remaining arguments are a filter query
let args' = listofstringopt "args" rawopts let args' = listofstringopt "args" rawopts
when (null args') $ error' "aregister needs an account, please provide an account name or pattern" when (null args') $ error' "aregister needs an account, please provide an account name or pattern" -- PARTIAL:
let let
(apat:queryargs) = args' (apat:queryargs) = args'
acct = headDef (error' $ show apat++" did not match any account") $ acct = headDef (error' $ show apat++" did not match any account") $ -- PARTIAL:
filter (regexMatches apat . T.unpack) $ journalAccountNames j filter (regexMatches apat . T.unpack) $ journalAccountNames j
-- gather report options -- gather report options
inclusive = True -- tree_ ropts inclusive = True -- tree_ ropts
@ -108,7 +108,7 @@ aregister opts@CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do
render | fmt=="json" = (++"\n") . T.unpack . TL.toStrict . encodeToLazyText . toJSON render | fmt=="json" = (++"\n") . T.unpack . TL.toStrict . encodeToLazyText . toJSON
| fmt=="csv" = (++"\n") . printCSV . accountTransactionsReportAsCsv reportq thisacctq | fmt=="csv" = (++"\n") . printCSV . accountTransactionsReportAsCsv reportq thisacctq
| fmt=="txt" = accountTransactionsReportAsText opts reportq thisacctq | fmt=="txt" = accountTransactionsReportAsText opts reportq thisacctq
| otherwise = const $ error' $ unsupportedOutputFormatError fmt | otherwise = const $ error' $ unsupportedOutputFormatError fmt -- PARTIAL:
where where
fmt = outputFormatFromOpts opts fmt = outputFormatFromOpts opts

5
hledger/Hledger/Cli/Commands/Balance.hs
View File

@ -304,6 +304,7 @@ balancemode = hledgerCommandMode
-- | The balance command, prints a balance report. -- | The balance command, prints a balance report.
balance :: CliOpts -> Journal -> IO () balance :: CliOpts -> Journal -> IO ()
balance opts@CliOpts{rawopts_=rawopts,reportopts_=ropts@ReportOpts{..}} j = do balance opts@CliOpts{rawopts_=rawopts,reportopts_=ropts@ReportOpts{..}} j = do
-- PARTIAL:
d <- getCurrentDay d <- getCurrentDay
case lineFormatFromOpts ropts of case lineFormatFromOpts ropts of
Left err -> error' $ unlines [err] Left err -> error' $ unlines [err]
@ -494,7 +495,7 @@ multiBalanceReportAsHtml ropts mbr =
multiBalanceReportHtmlRows :: ReportOpts -> MultiBalanceReport -> (Html (), [Html ()], Maybe (Html ())) multiBalanceReportHtmlRows :: ReportOpts -> MultiBalanceReport -> (Html (), [Html ()], Maybe (Html ()))
multiBalanceReportHtmlRows ropts mbr = multiBalanceReportHtmlRows ropts mbr =
let let
headingsrow:rest | transpose_ ropts = error' "Sorry, --transpose is not supported with HTML output yet" headingsrow:rest | transpose_ ropts = error' "Sorry, --transpose is not supported with HTML output yet" -- PARTIAL:
| otherwise = multiBalanceReportAsCsv ropts mbr | otherwise = multiBalanceReportAsCsv ropts mbr
(bodyrows, mtotalsrow) | no_total_ ropts = (rest, Nothing) (bodyrows, mtotalsrow) | no_total_ ropts = (rest, Nothing)
| otherwise = (init rest, Just $ last rest) | otherwise = (init rest, Just $ last rest)
@ -581,7 +582,7 @@ multiBalanceReportAsText ropts@ReportOpts{..} r =
(showDateSpan $ periodicReportSpan r) (showDateSpan $ periodicReportSpan r)
(case value_ of (case value_ of
Just (AtCost _mc) -> ", valued at cost" Just (AtCost _mc) -> ", valued at cost"
Just (AtThen _mc) -> error' unsupportedValueThenError -- TODO -- ", valued at period ends" -- handled like AtEnd for now Just (AtThen _mc) -> error' unsupportedValueThenError -- TODO -- ", valued at period ends" -- handled like AtEnd for now -- PARTIAL:
Just (AtEnd _mc) -> ", valued at period ends" Just (AtEnd _mc) -> ", valued at period ends"
Just (AtNow _mc) -> ", current value" Just (AtNow _mc) -> ", current value"
-- XXX duplicates the above -- XXX duplicates the above

2
hledger/Hledger/Cli/Commands/Diff.hs
View File

@ -87,7 +87,7 @@ matching ppl ppr = do
readJournalFile' :: FilePath -> IO Journal readJournalFile' :: FilePath -> IO Journal
readJournalFile' fn = readJournalFile' fn =
readJournalFile definputopts {ignore_assertions_ = True} fn >>= either error' return readJournalFile definputopts {ignore_assertions_ = True} fn >>= either error' return -- PARTIAL:
matchingPostings :: AccountName -> Journal -> [PostingWithPath] matchingPostings :: AccountName -> Journal -> [PostingWithPath]
matchingPostings acct j = filter ((== acct) . paccount . ppposting) $ allPostingsWithPath j matchingPostings acct j = filter ((== acct) . paccount . ppposting) $ allPostingsWithPath j

2
hledger/Hledger/Cli/Commands/Import.hs
View File

@ -34,7 +34,7 @@ importcmd opts@CliOpts{rawopts_=rawopts,inputopts_=iopts} j = do
dryrun = boolopt "dry-run" rawopts dryrun = boolopt "dry-run" rawopts
iopts' = iopts{new_=True, new_save_=not dryrun} iopts' = iopts{new_=True, new_save_=not dryrun}
case inputfiles of case inputfiles of
[] -> error' "please provide one or more input files as arguments" [] -> error' "please provide one or more input files as arguments" -- PARTIAL:
fs -> do fs -> do
enewj <- readJournalFiles iopts' fs enewj <- readJournalFiles iopts' fs
case enewj of case enewj of

2
hledger/Hledger/Cli/Commands/Print.hs
View File

@ -62,7 +62,7 @@ printEntries opts@CliOpts{reportopts_=ropts} j = do
"csv" -> (++"\n") . printCSV . entriesReportAsCsv "csv" -> (++"\n") . printCSV . entriesReportAsCsv
"json" -> (++"\n") . TL.unpack . toJsonText "json" -> (++"\n") . TL.unpack . toJsonText
"sql" -> entriesReportAsSql "sql" -> entriesReportAsSql
_ -> const $ error' $ unsupportedOutputFormatError fmt _ -> const $ error' $ unsupportedOutputFormatError fmt -- PARTIAL:
writeOutput opts $ render $ entriesReport ropts q j writeOutput opts $ render $ entriesReport ropts q j
entriesReportAsText :: CliOpts -> EntriesReport -> String entriesReportAsText :: CliOpts -> EntriesReport -> String

2
hledger/Hledger/Cli/Commands/Register.hs
View File

@ -64,7 +64,7 @@ register opts@CliOpts{reportopts_=ropts} j = do
render | fmt=="txt" = postingsReportAsText render | fmt=="txt" = postingsReportAsText
| fmt=="csv" = const ((++"\n") . printCSV . postingsReportAsCsv) | fmt=="csv" = const ((++"\n") . printCSV . postingsReportAsCsv)
| fmt=="json" = const ((++"\n") . TL.unpack . toJsonText) | fmt=="json" = const ((++"\n") . TL.unpack . toJsonText)
| otherwise = const $ error' $ unsupportedOutputFormatError fmt | otherwise = const $ error' $ unsupportedOutputFormatError fmt -- PARTIAL:
writeOutput opts $ render opts $ postingsReport ropts (queryFromOpts d ropts) j writeOutput opts $ render opts $ postingsReport ropts (queryFromOpts d ropts) j
postingsReportAsCsv :: PostingsReport -> CSV postingsReportAsCsv :: PostingsReport -> CSV

4
hledger/Hledger/Cli/Commands/Rewrite.hs
View File

@ -40,7 +40,7 @@ rewrite opts@CliOpts{rawopts_=rawopts,reportopts_=ropts} j@Journal{jtxns=ts} = d
-- rewrite matched transactions -- rewrite matched transactions
d <- getCurrentDay d <- getCurrentDay
let modifiers = transactionModifierFromOpts opts : jtxnmodifiers j let modifiers = transactionModifierFromOpts opts : jtxnmodifiers j
let j' = j{jtxns=either error' id $ modifyTransactions d modifiers ts} let j' = j{jtxns=either error' id $ modifyTransactions d modifiers ts} -- PARTIAL:
-- run the print command, showing all transactions, or show diffs -- run the print command, showing all transactions, or show diffs
printOrDiff rawopts opts{reportopts_=ropts{query_=""}} j j' printOrDiff rawopts opts{reportopts_=ropts{query_=""}} j j'
@ -52,7 +52,7 @@ transactionModifierFromOpts CliOpts{rawopts_=rawopts,reportopts_=ropts} =
where where
q = T.pack $ query_ ropts q = T.pack $ query_ ropts
ps = map (parseposting . T.pack) $ listofstringopt "add-posting" rawopts ps = map (parseposting . T.pack) $ listofstringopt "add-posting" rawopts
parseposting t = either (error' . errorBundlePretty) id ep parseposting t = either (error' . errorBundlePretty) id ep -- PARTIAL:
where where
ep = runIdentity (runJournalParser (postingp Nothing <* eof) t') ep = runIdentity (runJournalParser (postingp Nothing <* eof) t')
t' = " " <> t <> "\n" -- inject space and newline for proper parsing t' = " " <> t <> "\n" -- inject space and newline for proper parsing

4
hledger/Hledger/Cli/Commands/Roi.hs
View File

@ -214,7 +214,7 @@ internalRateOfReturn showCashFlow prettyTables (OneSpan spanBegin spanEnd valueB
#endif #endif
(0.000000000001,10000) (interestSum spanEnd totalCF) of (0.000000000001,10000) (interestSum spanEnd totalCF) of
Root rate -> return ((rate-1)*100) Root rate -> return ((rate-1)*100)
NotBracketed -> error' "Error: No solution -- not bracketed." NotBracketed -> error' "Error: No solution -- not bracketed." -- PARTIAL:
SearchFailed -> error' "Error: Failed to find solution." SearchFailed -> error' "Error: Failed to find solution."
type CashFlow = [(Day, Quantity)] type CashFlow = [(Day, Quantity)]
@ -236,5 +236,5 @@ unMix :: MixedAmount -> Quantity
unMix a = unMix a =
case (normaliseMixedAmount $ mixedAmountCost a) of case (normaliseMixedAmount $ mixedAmountCost a) of
(Mixed [a]) -> aquantity a (Mixed [a]) -> aquantity a
_ -> error' "MixedAmount failed to normalize" _ -> error' "MixedAmount failed to normalize" -- PARTIAL:

2
hledger/Hledger/Cli/Commands/Stats.hs
View File

@ -82,7 +82,7 @@ showLedgerStats l today span =
path = journalFilePath j path = journalFilePath j
ts = sortOn tdate $ filter (spanContainsDate span . tdate) $ jtxns j ts = sortOn tdate $ filter (spanContainsDate span . tdate) $ jtxns j
as = nub $ map paccount $ concatMap tpostings ts as = nub $ map paccount $ concatMap tpostings ts
cs = either error' Map.keys $ commodityStylesFromAmounts $ concatMap (amounts . pamount) $ concatMap tpostings ts cs = either error' Map.keys $ commodityStylesFromAmounts $ concatMap (amounts . pamount) $ concatMap tpostings ts -- PARTIAL:
lastdate | null ts = Nothing lastdate | null ts = Nothing
| otherwise = Just $ tdate $ last ts | otherwise = Just $ tdate $ last ts
lastelapsed = fmap (diffDays today) lastdate lastelapsed = fmap (diffDays today) lastdate

2
hledger/Hledger/Cli/Main.hs
View File

@ -140,7 +140,7 @@ main = do
hasVersion = ("--version" `elem`) hasVersion = ("--version" `elem`)
hasDetailedVersion = ("--version+" `elem`) hasDetailedVersion = ("--version+" `elem`)
printUsage = putStr $ showModeUsage $ mainmode addons printUsage = putStr $ showModeUsage $ mainmode addons
badCommandError = error' ("command "++rawcmd++" is not recognized, run with no command to see a list") >> exitFailure badCommandError = error' ("command "++rawcmd++" is not recognized, run with no command to see a list") >> exitFailure -- PARTIAL:
hasHelpFlag args = any (`elem` args) ["-h","--help"] hasHelpFlag args = any (`elem` args) ["-h","--help"]
f `orShowHelp` mode f `orShowHelp` mode
| hasHelpFlag args = putStr $ showModeUsage mode | hasHelpFlag args = putStr $ showModeUsage mode

6
hledger/Hledger/Cli/Utils.hs
View File

@ -73,7 +73,7 @@ withJournalDo opts cmd = do
journalpaths <- journalFilePathFromOpts opts journalpaths <- journalFilePathFromOpts opts
readJournalFiles (inputopts_ opts) journalpaths readJournalFiles (inputopts_ opts) journalpaths
>>= mapM (journalTransform opts) >>= mapM (journalTransform opts)
>>= either error' cmd >>= either error' cmd -- PARTIAL:
-- | Apply some extra post-parse transformations to the journal, if -- | Apply some extra post-parse transformations to the journal, if
-- specified by options. These happen after journal validation, but -- specified by options. These happen after journal validation, but
@ -139,7 +139,7 @@ journalAddForecast CliOpts{inputopts_=iopts, reportopts_=ropts} j = do
] ]
-- With --auto enabled, transaction modifiers are also applied to forecast txns -- With --auto enabled, transaction modifiers are also applied to forecast txns
forecasttxns' = forecasttxns' =
(if auto_ iopts then either error' id . modifyTransactions today (jtxnmodifiers j) else id) (if auto_ iopts then either error' id . modifyTransactions today (jtxnmodifiers j) else id) -- PARTIAL:
forecasttxns forecasttxns
return $ return $
@ -150,7 +150,7 @@ journalAddForecast CliOpts{inputopts_=iopts, reportopts_=ropts} j = do
journalBalanceTransactions' iopts j = journalBalanceTransactions' iopts j =
let assrt = not . ignore_assertions_ $ iopts let assrt = not . ignore_assertions_ $ iopts
in in
either error' id $ journalBalanceTransactions assrt j either error' id $ journalBalanceTransactions assrt j -- PARTIAL:
-- | Write some output to stdout or to a file selected by --output-file. -- | Write some output to stdout or to a file selected by --output-file.
-- If the file exists it will be overwritten. -- If the file exists it will be overwritten.

2
hledger/Hledger/Cli/Version.hs
View File

@ -63,5 +63,5 @@ binaryfilename progname = prettify $ splitAtElement '.' buildversion
prettify (major:minor:bugfix:[]) = prettify [major,minor,bugfix,"0"] prettify (major:minor:bugfix:[]) = prettify [major,minor,bugfix,"0"]
prettify (major:minor:[]) = prettify [major,minor,"0","0"] prettify (major:minor:[]) = prettify [major,minor,"0","0"]
prettify (major:[]) = prettify [major,"0","0","0"] prettify (major:[]) = prettify [major,"0","0","0"]
prettify [] = error' "VERSION is empty, please fix" prettify [] = error' "VERSION is empty, please fix" -- PARTIAL:
prettify _ = error' "VERSION has too many components, please fix" prettify _ = error' "VERSION has too many components, please fix"

6
hledger/bench/bench.hs
View File

@ -34,7 +34,7 @@ main = do
benchWithTimeit = do benchWithTimeit = do
getCurrentDirectory >>= printf "Benchmarking hledger in %s with timeit\n" getCurrentDirectory >>= printf "Benchmarking hledger in %s with timeit\n"
let opts = defcliopts{output_file_=Just outputfile} let opts = defcliopts{output_file_=Just outputfile}
(t0,j) <- timeit ("read "++inputfile) $ either error id <$> readJournalFile def inputfile (t0,j) <- timeit ("read "++inputfile) $ either error id <$> readJournalFile def inputfile -- PARTIAL:
(t1,_) <- timeit ("print") $ print' opts j (t1,_) <- timeit ("print") $ print' opts j
(t2,_) <- timeit ("register") $ register opts j (t2,_) <- timeit ("register") $ register opts j
(t3,_) <- timeit ("balance") $ balance opts j (t3,_) <- timeit ("balance") $ balance opts j
@ -50,9 +50,9 @@ timeit name action = do
benchWithCriterion = do benchWithCriterion = do
getCurrentDirectory >>= printf "Benchmarking hledger in %s with criterion\n" getCurrentDirectory >>= printf "Benchmarking hledger in %s with criterion\n"
let opts = defcliopts{output_file_=Just "/dev/null"} let opts = defcliopts{output_file_=Just "/dev/null"}
j <- either error id <$> readJournalFile def inputfile j <- either error id <$> readJournalFile def inputfile -- PARTIAL:
Criterion.Main.defaultMainWith defaultConfig $ [ Criterion.Main.defaultMainWith defaultConfig $ [
bench ("read "++inputfile) $ nfIO $ (either error const <$> readJournalFile def inputfile), bench ("read "++inputfile) $ nfIO $ (either error const <$> readJournalFile def inputfile), -- PARTIAL:
bench ("print") $ nfIO $ print' opts j, bench ("print") $ nfIO $ print' opts j,
bench ("register") $ nfIO $ register opts j, bench ("register") $ nfIO $ register opts j,
bench ("balance") $ nfIO $ balance opts j, bench ("balance") $ nfIO $ balance opts j,