{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Hledger.Reports.ReportOptions (
ReportOpts(..),
BalanceType(..),
AccountListMode(..),
ValuationType(..),
FormatStr,
defreportopts,
rawOptsToReportOpts,
checkReportOpts,
flat_,
tree_,
reportOptsToggleStatus,
simplifyStatuses,
whichDateFromOpts,
journalSelectingAmountFromOpts,
intervalFromRawOpts,
forecastPeriodFromRawOpts,
queryFromOpts,
queryFromOptsOnly,
queryOptsFromOpts,
transactionDateFn,
postingDateFn,
reportSpan,
reportStartDate,
reportEndDate,
specifiedStartEndDates,
specifiedStartDate,
specifiedEndDate,
reportPeriodStart,
reportPeriodOrJournalStart,
reportPeriodLastDay,
reportPeriodOrJournalLastDay,
valuationTypeIsCost,
valuationTypeIsDefaultValue,
tests_ReportOptions
)
where
import Control.Applicative ((<|>))
import Data.List.Extra (nubSort)
import Data.Maybe (fromMaybe, isJust)
import qualified Data.Text as T
import Data.Time.Calendar (Day, addDays, fromGregorian)
import Data.Default (Default(..))
import Safe (lastDef, lastMay)
import System.Console.ANSI (hSupportsANSIColor)
import System.Environment (lookupEnv)
import System.IO (stdout)
import Text.Megaparsec.Custom
import Hledger.Data
import Hledger.Query
import Hledger.Utils
type FormatStr = String
data BalanceType = PeriodChange
| CumulativeChange
| HistoricalBalance
deriving (Eq,Show)
instance Default BalanceType where def = PeriodChange
data AccountListMode = ALFlat | ALTree deriving (Eq, Show)
instance Default AccountListMode where def = ALFlat
data ReportOpts = ReportOpts {
today_ :: Maybe Day
,period_ :: Period
,interval_ :: Interval
,statuses_ :: [Status]
,value_ :: Maybe ValuationType
,infer_value_ :: Bool
,depth_ :: Maybe Int
,date2_ :: Bool
,empty_ :: Bool
,no_elide_ :: Bool
,real_ :: Bool
,format_ :: Maybe FormatStr
,query_ :: String
,average_ :: Bool
,related_ :: Bool
,txn_dates_ :: Bool
,balancetype_ :: BalanceType
,accountlistmode_ :: AccountListMode
,drop_ :: Int
,row_total_ :: Bool
,no_total_ :: Bool
,pretty_tables_ :: Bool
,sort_amount_ :: Bool
,percent_ :: Bool
,invert_ :: Bool
,normalbalance_ :: Maybe NormalSign
,color_ :: Bool
,forecast_ :: Maybe DateSpan
,transpose_ :: Bool
} deriving (Show)
instance Default ReportOpts where def = defreportopts
defreportopts :: ReportOpts
defreportopts = ReportOpts
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
def
rawOptsToReportOpts :: RawOpts -> IO ReportOpts
rawOptsToReportOpts rawopts = checkReportOpts <$> do
let rawopts' = checkRawOpts rawopts
d <- getCurrentDay
no_color <- isJust <$> lookupEnv "NO_COLOR"
supports_color <- hSupportsANSIColor stdout
let colorflag = stringopt "color" rawopts
return defreportopts{
today_ = Just d
,period_ = periodFromRawOpts d rawopts'
,interval_ = intervalFromRawOpts rawopts'
,statuses_ = statusesFromRawOpts rawopts'
,value_ = valuationTypeFromRawOpts rawopts'
,infer_value_ = boolopt "infer-value" rawopts'
,depth_ = maybeposintopt "depth" rawopts'
,date2_ = boolopt "date2" rawopts'
,empty_ = boolopt "empty" rawopts'
,no_elide_ = boolopt "no-elide" rawopts'
,real_ = boolopt "real" rawopts'
,format_ = maybestringopt "format" rawopts'
,query_ = unwords . map quoteIfNeeded $ listofstringopt "args" rawopts'
,average_ = boolopt "average" rawopts'
,related_ = boolopt "related" rawopts'
,txn_dates_ = boolopt "txn-dates" rawopts'
,balancetype_ = balancetypeopt rawopts'
,accountlistmode_ = accountlistmodeopt rawopts'
,drop_ = posintopt "drop" rawopts'
,row_total_ = boolopt "row-total" rawopts'
,no_total_ = boolopt "no-total" rawopts'
,sort_amount_ = boolopt "sort-amount" rawopts'
,percent_ = boolopt "percent" rawopts'
,invert_ = boolopt "invert" rawopts'
,pretty_tables_ = boolopt "pretty-tables" rawopts'
,color_ = and [not no_color
,not $ colorflag `elem` ["never","no"]
,colorflag `elem` ["always","yes"] || supports_color
]
,forecast_ = forecastPeriodFromRawOpts d rawopts'
,transpose_ = boolopt "transpose" rawopts'
}
checkRawOpts :: RawOpts -> RawOpts
checkRawOpts rawopts
| otherwise = rawopts
checkReportOpts :: ReportOpts -> ReportOpts
checkReportOpts ropts@ReportOpts{..} =
either usageError (const ropts) $ do
case depth_ of
Just d | d < 0 -> Left "--depth should have a positive number"
_ -> Right ()
accountlistmodeopt :: RawOpts -> AccountListMode
accountlistmodeopt =
fromMaybe ALFlat . choiceopt parse where
parse = \case
"tree" -> Just ALTree
"flat" -> Just ALFlat
_ -> Nothing
balancetypeopt :: RawOpts -> BalanceType
balancetypeopt =
fromMaybe PeriodChange . choiceopt parse where
parse = \case
"historical" -> Just HistoricalBalance
"cumulative" -> Just CumulativeChange
_ -> Nothing
periodFromRawOpts :: Day -> RawOpts -> Period
periodFromRawOpts d rawopts =
case (mlastb, mlaste) of
(Nothing, Nothing) -> PeriodAll
(Just b, Nothing) -> PeriodFrom b
(Nothing, Just e) -> PeriodTo e
(Just b, Just e) -> simplifyPeriod $
PeriodBetween b e
where
mlastb = case beginDatesFromRawOpts d rawopts of
[] -> Nothing
bs -> Just $ last bs
mlaste = case endDatesFromRawOpts d rawopts of
[] -> Nothing
es -> Just $ last es
beginDatesFromRawOpts :: Day -> RawOpts -> [Day]
beginDatesFromRawOpts d = collectopts (begindatefromrawopt d)
where
begindatefromrawopt d (n,v)
| n == "begin" =
either (\e -> usageError $ "could not parse "++n++" date: "++customErrorBundlePretty e) Just $
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)
of
(_, DateSpan (Just b) _) -> Just b
_ -> Nothing
| otherwise = Nothing
endDatesFromRawOpts :: Day -> RawOpts -> [Day]
endDatesFromRawOpts d = collectopts (enddatefromrawopt d)
where
enddatefromrawopt d (n,v)
| n == "end" =
either (\e -> usageError $ "could not parse "++n++" date: "++customErrorBundlePretty e) Just $
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)
of
(_, DateSpan _ (Just e)) -> Just e
_ -> Nothing
| otherwise = Nothing
intervalFromRawOpts :: RawOpts -> Interval
intervalFromRawOpts = lastDef NoInterval . collectopts intervalfromrawopt
where
intervalfromrawopt (n,v)
| n == "period" =
either
(\e -> usageError $ "could not parse period option: "++customErrorBundlePretty e)
extractIntervalOrNothing $
parsePeriodExpr
(error' "intervalFromRawOpts: did not expect to need today's date here")
(stripquotes $ T.pack v)
| n == "daily" = Just $ Days 1
| n == "weekly" = Just $ Weeks 1
| n == "monthly" = Just $ Months 1
| n == "quarterly" = Just $ Quarters 1
| n == "yearly" = Just $ Years 1
| otherwise = Nothing
forecastPeriodFromRawOpts :: Day -> RawOpts -> Maybe DateSpan
forecastPeriodFromRawOpts d opts =
case maybestringopt "forecast" opts
of
Nothing -> Nothing
Just "" -> Just nulldatespan
Just str ->
either (\e -> usageError $ "could not parse forecast period : "++customErrorBundlePretty e) (Just . snd) $
parsePeriodExpr d $ stripquotes $ T.pack str
extractIntervalOrNothing :: (Interval, DateSpan) -> Maybe Interval
extractIntervalOrNothing (NoInterval, _) = Nothing
extractIntervalOrNothing (interval, _) = Just interval
statusesFromRawOpts :: RawOpts -> [Status]
statusesFromRawOpts = simplifyStatuses . collectopts statusfromrawopt
where
statusfromrawopt (n,_)
| n == "unmarked" = Just Unmarked
| n == "pending" = Just Pending
| n == "cleared" = Just Cleared
| otherwise = Nothing
simplifyStatuses l
| length l' >= numstatuses = []
| otherwise = l'
where
l' = nubSort l
numstatuses = length [minBound .. maxBound :: Status]
reportOptsToggleStatus s ropts@ReportOpts{statuses_=ss}
| s `elem` ss = ropts{statuses_=filter (/= s) ss}
| otherwise = ropts{statuses_=simplifyStatuses (s:ss)}
valuationTypeFromRawOpts :: RawOpts -> Maybe ValuationType
valuationTypeFromRawOpts = lastMay . collectopts valuationfromrawopt
where
valuationfromrawopt (n,v)
| n == "B" = Just $ AtCost Nothing
| n == "V" = Just $ AtDefault Nothing
| n == "X" = Just $ AtDefault (Just $ T.pack v)
| n == "value" = Just $ valuation v
| otherwise = Nothing
valuation v
| t `elem` ["cost","c"] = AtCost mc
| t `elem` ["then" ,"t"] = AtThen mc
| t `elem` ["end" ,"e"] = AtEnd mc
| t `elem` ["now" ,"n"] = AtNow mc
| otherwise =
case parsedateM t of
Just d -> AtDate d mc
Nothing -> usageError $ "could not parse \""++t++"\" as valuation type, should be: cost|then|end|now|c|t|e|n|YYYY-MM-DD"
where
(t,c') = break (==',') v
mc = case drop 1 c' of
"" -> Nothing
c -> Just $ T.pack c
valuationTypeIsCost :: ReportOpts -> Bool
valuationTypeIsCost ropts =
case value_ ropts of
Just (AtCost _) -> True
_ -> False
valuationTypeIsDefaultValue :: ReportOpts -> Bool
valuationTypeIsDefaultValue ropts =
case value_ ropts of
Just (AtDefault _) -> True
_ -> False
transactionDateFn :: ReportOpts -> (Transaction -> Day)
transactionDateFn ReportOpts{..} = if date2_ then transactionDate2 else tdate
postingDateFn :: ReportOpts -> (Posting -> Day)
postingDateFn ReportOpts{..} = if date2_ then postingDate2 else postingDate
whichDateFromOpts :: ReportOpts -> WhichDate
whichDateFromOpts ReportOpts{..} = if date2_ then SecondaryDate else PrimaryDate
tree_ :: ReportOpts -> Bool
tree_ ReportOpts{accountlistmode_ = ALTree} = True
tree_ ReportOpts{accountlistmode_ = ALFlat} = False
flat_ :: ReportOpts -> Bool
flat_ = not . tree_
journalSelectingAmountFromOpts :: ReportOpts -> Journal -> Journal
journalSelectingAmountFromOpts opts =
case value_ opts of
Just (AtCost _) -> journalToCost
_ -> id
queryFromOpts :: Day -> ReportOpts -> Query
queryFromOpts d ropts = simplifyQuery . And $ [flagsq, argsq]
where
flagsq = queryFromOptsOnly d ropts
argsq = fst $ either error' id $ parseQuery d (T.pack $ query_ ropts)
queryFromOptsOnly :: Day -> ReportOpts -> Query
queryFromOptsOnly _d ReportOpts{..} = simplifyQuery $ And flagsq
where
flagsq = consIf Real real_
. consIf Empty empty_
. consJust Depth depth_
$ [ (if date2_ then Date2 else Date) $ periodAsDateSpan period_
, Or $ map StatusQ statuses_
]
consIf f b = if b then (f True:) else id
consJust f = maybe id ((:) . f)
queryOptsFromOpts :: Day -> ReportOpts -> [QueryOpt]
queryOptsFromOpts d = snd . either error' id . parseQuery d . T.pack . query_
reportSpan :: Journal -> ReportOpts -> IO DateSpan
reportSpan j ropts = do
(mspecifiedstartdate, mspecifiedenddate) <-
dbg3 "specifieddates" <$> specifiedStartEndDates ropts
let
DateSpan mjournalstartdate mjournalenddate =
dbg3 "journalspan" $ journalDateSpan False j
mstartdate = mspecifiedstartdate <|> mjournalstartdate
menddate = mspecifiedenddate <|> mjournalenddate
return $ dbg3 "reportspan" $ DateSpan mstartdate menddate
reportStartDate :: Journal -> ReportOpts -> IO (Maybe Day)
reportStartDate j ropts = spanStart <$> reportSpan j ropts
reportEndDate :: Journal -> ReportOpts -> IO (Maybe Day)
reportEndDate j ropts = spanEnd <$> reportSpan j ropts
specifiedStartEndDates :: ReportOpts -> IO (Maybe Day, Maybe Day)
specifiedStartEndDates ropts = do
today <- getCurrentDay
let
q = queryFromOpts today ropts
mspecifiedstartdate = queryStartDate False q
mspecifiedenddate = queryEndDate False q
return (mspecifiedstartdate, mspecifiedenddate)
specifiedStartDate :: ReportOpts -> IO (Maybe Day)
specifiedStartDate ropts = fst <$> specifiedStartEndDates ropts
specifiedEndDate :: ReportOpts -> IO (Maybe Day)
specifiedEndDate ropts = snd <$> specifiedStartEndDates ropts
reportPeriodStart :: ReportOpts -> Maybe Day
reportPeriodStart ropts@ReportOpts{..} = do
t <- today_
queryStartDate False $ queryFromOpts t ropts
reportPeriodOrJournalStart :: ReportOpts -> Journal -> Maybe Day
reportPeriodOrJournalStart ropts j =
reportPeriodStart ropts <|> journalStartDate False j
reportPeriodLastDay :: ReportOpts -> Maybe Day
reportPeriodLastDay ropts@ReportOpts{..} = do
t <- today_
let q = queryFromOpts t ropts
qend <- queryEndDate False q
return $ addDays (-1) qend
reportPeriodOrJournalLastDay :: ReportOpts -> Journal -> Maybe Day
reportPeriodOrJournalLastDay ropts j =
reportPeriodLastDay ropts <|> journalEndDate False j
tests_ReportOptions = tests "ReportOptions" [
test "queryFromOpts" $ do
queryFromOpts nulldate defreportopts @?= Any
queryFromOpts nulldate defreportopts{query_="a"} @?= Acct (toRegexCI' "a")
queryFromOpts nulldate defreportopts{query_="desc:'a a'"} @?= Desc (toRegexCI' "a a")
queryFromOpts nulldate defreportopts{period_=PeriodFrom (fromGregorian 2012 01 01),query_="date:'to 2013'" }
@?= (Date $ DateSpan (Just $ fromGregorian 2012 01 01) (Just $ fromGregorian 2013 01 01))
queryFromOpts nulldate defreportopts{query_="date2:'in 2012'"} @?= (Date2 $ DateSpan (Just $ fromGregorian 2012 01 01) (Just $ fromGregorian 2013 01 01))
queryFromOpts nulldate defreportopts{query_="'a a' 'b"} @?= Or [Acct $ toRegexCI' "a a", Acct $ toRegexCI' "'b"]
,test "queryOptsFromOpts" $ do
queryOptsFromOpts nulldate defreportopts @?= []
queryOptsFromOpts nulldate defreportopts{query_="a"} @?= []
queryOptsFromOpts nulldate defreportopts{period_=PeriodFrom (fromGregorian 2012 01 01)
,query_="date:'to 2013'"} @?= []
]