dev: lens: Use TemplateHaskell for ReportOpts and ReportSpec.
Also rename overWithReport/setWithReport to overEither/setEither.
This commit is contained in:
Stephen Morgan
Simon Michael
parent
435ec992f9
commit
f3eacebc1d
@ -11,15 +11,17 @@ Options common to most hledger reports.
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Hledger.Reports.ReportOptions (
|
||||
ReportOpts(..),
|
||||
HasReportOptsNoUpdate(..),
|
||||
HasReportOpts(..),
|
||||
ReportSpec(..),
|
||||
HasReportSpec(..),
|
||||
overWithReport,
|
||||
setWithReport,
|
||||
overEither,
|
||||
setEither,
|
||||
BalanceCalculation(..),
|
||||
BalanceAccumulation(..),
|
||||
AccountListMode(..),
|
||||
@ -67,7 +69,6 @@ import Data.Maybe (fromMaybe, mapMaybe)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Calendar (Day, addDays)
|
||||
import Data.Default (Default(..))
|
||||
import Lens.Micro (Lens')
|
||||
import Safe (headMay, lastDef, lastMay, maximumMay)
|
||||
|
||||
import Text.Megaparsec.Custom
|
||||
@ -274,35 +275,6 @@ defreportspec = ReportSpec
|
||||
, _rsQueryOpts = []
|
||||
}
|
||||
|
||||
-- | Generate a ReportSpec from a set of ReportOpts on a given day.
|
||||
reportOptsToSpec :: Day -> ReportOpts -> Either String ReportSpec
|
||||
reportOptsToSpec day ropts = do
|
||||
(argsquery, queryopts) <- parseQueryList day $ querystring_ ropts
|
||||
return ReportSpec
|
||||
{ _rsReportOpts = ropts
|
||||
, _rsDay = day
|
||||
, _rsQuery = simplifyQuery $ And [queryFromFlags ropts, argsquery]
|
||||
, _rsQueryOpts = queryopts
|
||||
}
|
||||
|
||||
-- | Update the ReportOpts and the fields derived from it in a ReportSpec,
|
||||
-- or return an error message if there is a problem such as missing or
|
||||
-- unparseable options data. This is the safe way to change a ReportSpec,
|
||||
-- ensuring that all fields (_rsQuery, _rsReportOpts, querystring_, etc.) are in sync.
|
||||
updateReportSpec :: ReportOpts -> ReportSpec -> Either String ReportSpec
|
||||
updateReportSpec = setWithReport reportOpts
|
||||
|
||||
-- | Like updateReportSpec, but takes a ReportOpts-modifying function.
|
||||
updateReportSpecWith :: (ReportOpts -> ReportOpts) -> ReportSpec -> Either String ReportSpec
|
||||
updateReportSpecWith = overWithReport reportOpts
|
||||
|
||||
-- | Generate a ReportSpec from RawOpts and the current date.
|
||||
rawOptsToReportSpec :: RawOpts -> IO ReportSpec
|
||||
rawOptsToReportSpec rawopts = do
|
||||
d <- getCurrentDay
|
||||
let ropts = rawOptsToReportOpts d rawopts
|
||||
either fail return $ reportOptsToSpec d ropts
|
||||
|
||||
accountlistmodeopt :: RawOpts -> AccountListMode
|
||||
accountlistmodeopt =
|
||||
fromMaybe ALFlat . choiceopt parse where
|
||||
@ -709,237 +681,105 @@ instance (e ~ a) => Reportable (Either a) e where
|
||||
report _ = join
|
||||
|
||||
-- | Apply a function over a lens, but report on failure.
|
||||
overWithReport :: ((a -> Either e b) -> s -> Either e t) -> (a -> b) -> s -> Either e t
|
||||
overWithReport l f = l (pure . f)
|
||||
overEither :: ((a -> Either e b) -> s -> Either e t) -> (a -> b) -> s -> Either e t
|
||||
overEither l f = l (pure . f)
|
||||
|
||||
-- | Set a field using a lens, but report on failure.
|
||||
setWithReport :: ((a -> Either e b) -> s -> Either e t) -> b -> s -> Either e t
|
||||
setWithReport l = overWithReport l . const
|
||||
setEither :: ((a -> Either e b) -> s -> Either e t) -> b -> s -> Either e t
|
||||
setEither l = overEither l . const
|
||||
|
||||
type ReportableLens' s a = forall f. Reportable f String => (a -> f a) -> s -> f s
|
||||
|
||||
-- | Lenses for ReportOpts.
|
||||
-- Note that some of these are not true lenses, as they have a further restriction on
|
||||
|
||||
-- Implement HasReportOptsNoUpdate, the basic lenses for ReportOpts.
|
||||
makeHledgerClassyLenses ''ReportOpts
|
||||
makeHledgerClassyLenses ''ReportSpec
|
||||
|
||||
-- | Special lenses for ReportOpts which also update the Query and QueryOpts in ReportSpec.
|
||||
-- Note that these are not true lenses, as they have a further restriction on
|
||||
-- the functor. This will work as a normal lens for all common uses, but since they
|
||||
-- don't obey the lens laws for some fancy cases, they may fail in some exotic circumstances.
|
||||
-- The special type is so that updating querystring_, real_, depth_, date2_, period_, or
|
||||
-- statuses_ can automatically update the Query and QueryOpts in ReportSpec.
|
||||
class HasReportOpts a where
|
||||
--
|
||||
-- Note that setEither/overEither should only be necessary with
|
||||
-- querystring and reportOpts: the other lenses should never fail.
|
||||
--
|
||||
-- === Examples:
|
||||
-- >>> import Lens.Micro (set)
|
||||
-- >>> _rsQuery <$> setEither querystring ["assets"] defreportspec
|
||||
-- Right (Acct (RegexpCI "assets"))
|
||||
-- >>> _rsQuery <$> setEither querystring ["(assets"] defreportspec
|
||||
-- Left "this regular expression could not be compiled: (assets"
|
||||
-- >>> _rsQuery $ set querystring ["assets"] defreportspec
|
||||
-- Acct (RegexpCI "assets")
|
||||
-- >>> _rsQuery $ set querystring ["(assets"] defreportspec
|
||||
-- *** Exception: Updating ReportSpec failed: try using overEither instead of over or setEither instead of set
|
||||
-- >>> _rsQuery $ set period (MonthPeriod 2021 08) defreportspec
|
||||
-- Date DateSpan 2021-08
|
||||
class HasReportOptsNoUpdate a => HasReportOpts a where
|
||||
reportOpts :: ReportableLens' a ReportOpts
|
||||
reportOptsNoUpdate :: Lens' a ReportOpts
|
||||
reportOpts = reportOptsNoUpdate
|
||||
{-# INLINE reportOpts #-}
|
||||
|
||||
period :: ReportableLens' a Period
|
||||
period = reportOpts.period
|
||||
period = reportOpts.periodNoUpdate
|
||||
{-# INLINE period #-}
|
||||
|
||||
statuses :: ReportableLens' a [Status]
|
||||
statuses = reportOpts.statuses
|
||||
statuses = reportOpts.statusesNoUpdate
|
||||
{-# INLINE statuses #-}
|
||||
|
||||
depth :: ReportableLens' a (Maybe Int)
|
||||
depth = reportOpts.depth
|
||||
depth = reportOpts.depthNoUpdate
|
||||
{-# INLINE depth #-}
|
||||
|
||||
date2 :: ReportableLens' a Bool
|
||||
date2 = reportOpts.date2
|
||||
date2 = reportOpts.date2NoUpdate
|
||||
{-# INLINE date2 #-}
|
||||
|
||||
real :: ReportableLens' a Bool
|
||||
real = reportOpts.real
|
||||
real = reportOpts.realNoUpdate
|
||||
{-# INLINE real #-}
|
||||
|
||||
querystring :: ReportableLens' a [T.Text]
|
||||
querystring = reportOpts.querystring
|
||||
querystring = reportOpts.querystringNoUpdate
|
||||
{-# INLINE querystring #-}
|
||||
|
||||
interval :: Lens' a Interval
|
||||
interval = reportOptsNoUpdate.interval
|
||||
{-# INLINE interval #-}
|
||||
instance HasReportOpts ReportOpts
|
||||
|
||||
cost :: Lens' a Costing
|
||||
cost = reportOptsNoUpdate.cost
|
||||
{-# INLINE cost #-}
|
||||
|
||||
value :: Lens' a (Maybe ValuationType)
|
||||
value = reportOptsNoUpdate.value
|
||||
{-# INLINE value #-}
|
||||
|
||||
infer_value :: Lens' a Bool
|
||||
infer_value = reportOptsNoUpdate.infer_value
|
||||
{-# INLINE infer_value #-}
|
||||
|
||||
empty__ :: Lens' a Bool
|
||||
empty__ = reportOptsNoUpdate.empty__
|
||||
{-# INLINE empty__ #-}
|
||||
|
||||
no_elide :: Lens' a Bool
|
||||
no_elide = reportOptsNoUpdate.no_elide
|
||||
{-# INLINE no_elide #-}
|
||||
|
||||
format :: Lens' a StringFormat
|
||||
format = reportOptsNoUpdate.format
|
||||
{-# INLINE format #-}
|
||||
|
||||
average :: Lens' a Bool
|
||||
average = reportOptsNoUpdate.average
|
||||
{-# INLINE average #-}
|
||||
|
||||
related :: Lens' a Bool
|
||||
related = reportOptsNoUpdate.related
|
||||
{-# INLINE related #-}
|
||||
|
||||
txn_dates :: Lens' a Bool
|
||||
txn_dates = reportOptsNoUpdate.txn_dates
|
||||
{-# INLINE txn_dates #-}
|
||||
|
||||
balancecalc :: Lens' a BalanceCalculation
|
||||
balancecalc = reportOptsNoUpdate.balancecalc
|
||||
{-# INLINE balancecalc #-}
|
||||
|
||||
balanceaccum :: Lens' a BalanceAccumulation
|
||||
balanceaccum = reportOptsNoUpdate.balanceaccum
|
||||
{-# INLINE balanceaccum #-}
|
||||
|
||||
accountlistmode :: Lens' a AccountListMode
|
||||
accountlistmode = reportOptsNoUpdate.accountlistmode
|
||||
{-# INLINE accountlistmode #-}
|
||||
|
||||
drop__ :: Lens' a Int
|
||||
drop__ = reportOptsNoUpdate.drop__
|
||||
{-# INLINE drop__ #-}
|
||||
|
||||
row_total :: Lens' a Bool
|
||||
row_total = reportOptsNoUpdate.row_total
|
||||
{-# INLINE row_total #-}
|
||||
|
||||
no_total :: Lens' a Bool
|
||||
no_total = reportOptsNoUpdate.no_total
|
||||
{-# INLINE no_total #-}
|
||||
|
||||
show_costs :: Lens' a Bool
|
||||
show_costs = reportOptsNoUpdate.show_costs
|
||||
{-# INLINE show_costs #-}
|
||||
|
||||
pretty_tables :: Lens' a Bool
|
||||
pretty_tables = reportOptsNoUpdate.pretty_tables
|
||||
{-# INLINE pretty_tables #-}
|
||||
|
||||
sort_amount :: Lens' a Bool
|
||||
sort_amount = reportOptsNoUpdate.sort_amount
|
||||
{-# INLINE sort_amount #-}
|
||||
|
||||
percent :: Lens' a Bool
|
||||
percent = reportOptsNoUpdate.percent
|
||||
{-# INLINE percent #-}
|
||||
|
||||
invert :: Lens' a Bool
|
||||
invert = reportOptsNoUpdate.invert
|
||||
{-# INLINE invert #-}
|
||||
|
||||
normalbalance :: Lens' a (Maybe NormalSign)
|
||||
normalbalance = reportOptsNoUpdate.normalbalance
|
||||
{-# INLINE normalbalance #-}
|
||||
|
||||
color__ :: Lens' a Bool
|
||||
color__ = reportOptsNoUpdate.color__
|
||||
{-# INLINE color__ #-}
|
||||
|
||||
transpose__ :: Lens' a Bool
|
||||
transpose__ = reportOptsNoUpdate.transpose__
|
||||
{-# INLINE transpose__ #-}
|
||||
|
||||
instance HasReportOpts ReportOpts where
|
||||
reportOpts = id
|
||||
reportOptsNoUpdate = id
|
||||
period f ropts = (\x -> ropts{period_=x}) <$> f (period_ ropts)
|
||||
{-# INLINE period #-}
|
||||
interval f ropts = (\x -> ropts{interval_=x}) <$> f (interval_ ropts)
|
||||
{-# INLINE interval #-}
|
||||
statuses f ropts = (\x -> ropts{statuses_=x}) <$> f (statuses_ ropts)
|
||||
{-# INLINE statuses #-}
|
||||
cost f ropts = (\x -> ropts{cost_=x}) <$> f (cost_ ropts)
|
||||
{-# INLINE cost #-}
|
||||
value f ropts = (\x -> ropts{value_=x}) <$> f (value_ ropts)
|
||||
{-# INLINE value #-}
|
||||
infer_value f ropts = (\x -> ropts{infer_value_=x}) <$> f (infer_value_ ropts)
|
||||
{-# INLINE infer_value #-}
|
||||
depth f ropts = (\x -> ropts{depth_=x}) <$> f (depth_ ropts)
|
||||
{-# INLINE depth #-}
|
||||
date2 f ropts = (\x -> ropts{date2_=x}) <$> f (date2_ ropts)
|
||||
{-# INLINE date2 #-}
|
||||
empty__ f ropts = (\x -> ropts{empty_=x}) <$> f (empty_ ropts)
|
||||
{-# INLINE empty__ #-}
|
||||
no_elide f ropts = (\x -> ropts{no_elide_=x}) <$> f (no_elide_ ropts)
|
||||
{-# INLINE no_elide #-}
|
||||
real f ropts = (\x -> ropts{real_=x}) <$> f (real_ ropts)
|
||||
{-# INLINE real #-}
|
||||
format f ropts = (\x -> ropts{format_=x}) <$> f (format_ ropts)
|
||||
{-# INLINE format #-}
|
||||
querystring f ropts = (\x -> ropts{querystring_=x}) <$> f (querystring_ ropts)
|
||||
{-# INLINE querystring #-}
|
||||
average f ropts = (\x -> ropts{average_=x}) <$> f (average_ ropts)
|
||||
{-# INLINE average #-}
|
||||
related f ropts = (\x -> ropts{related_=x}) <$> f (related_ ropts)
|
||||
{-# INLINE related #-}
|
||||
txn_dates f ropts = (\x -> ropts{txn_dates_=x}) <$> f (txn_dates_ ropts)
|
||||
{-# INLINE txn_dates #-}
|
||||
balancecalc f ropts = (\x -> ropts{balancecalc_=x}) <$> f (balancecalc_ ropts)
|
||||
{-# INLINE balancecalc #-}
|
||||
balanceaccum f ropts = (\x -> ropts{balanceaccum_=x}) <$> f (balanceaccum_ ropts)
|
||||
{-# INLINE balanceaccum #-}
|
||||
accountlistmode f ropts = (\x -> ropts{accountlistmode_=x}) <$> f (accountlistmode_ ropts)
|
||||
{-# INLINE accountlistmode #-}
|
||||
drop__ f ropts = (\x -> ropts{drop_=x}) <$> f (drop_ ropts)
|
||||
{-# INLINE drop__ #-}
|
||||
row_total f ropts = (\x -> ropts{row_total_=x}) <$> f (row_total_ ropts)
|
||||
{-# INLINE row_total #-}
|
||||
no_total f ropts = (\x -> ropts{no_total_=x}) <$> f (no_total_ ropts)
|
||||
{-# INLINE no_total #-}
|
||||
show_costs f ropts = (\x -> ropts{show_costs_=x}) <$> f (show_costs_ ropts)
|
||||
{-# INLINE show_costs #-}
|
||||
pretty_tables f ropts = (\x -> ropts{pretty_tables_=x}) <$> f (pretty_tables_ ropts)
|
||||
{-# INLINE pretty_tables #-}
|
||||
sort_amount f ropts = (\x -> ropts{sort_amount_=x}) <$> f (sort_amount_ ropts)
|
||||
{-# INLINE sort_amount #-}
|
||||
percent f ropts = (\x -> ropts{percent_=x}) <$> f (percent_ ropts)
|
||||
{-# INLINE percent #-}
|
||||
invert f ropts = (\x -> ropts{invert_=x}) <$> f (invert_ ropts)
|
||||
{-# INLINE invert #-}
|
||||
normalbalance f ropts = (\x -> ropts{normalbalance_=x}) <$> f (normalbalance_ ropts)
|
||||
{-# INLINE normalbalance #-}
|
||||
color__ f ropts = (\x -> ropts{color_=x}) <$> f (color_ ropts)
|
||||
{-# INLINE color__ #-}
|
||||
transpose__ f ropts = (\x -> ropts{transpose_=x}) <$> f (transpose_ ropts)
|
||||
{-# INLINE transpose__ #-}
|
||||
|
||||
class HasReportSpec a where
|
||||
reportSpec :: Lens' a ReportSpec
|
||||
|
||||
rsDay :: Lens' a Day
|
||||
rsDay = reportSpec.rsDay
|
||||
{-# INLINE rsDay #-}
|
||||
|
||||
rsQuery :: Lens' a Query
|
||||
rsQuery = reportSpec.rsQuery
|
||||
{-# INLINE rsQuery #-}
|
||||
|
||||
rsQueryOpts :: Lens' a [QueryOpt]
|
||||
rsQueryOpts = reportSpec.rsQueryOpts
|
||||
{-# INLINE rsQueryOpts #-}
|
||||
|
||||
instance HasReportSpec ReportSpec where
|
||||
reportSpec = id
|
||||
rsDay f rspec = (\d -> either (error "Updating _rsDay should never fail") id . -- PARTIAL:
|
||||
reportOptsToSpec d $ _rsReportOpts rspec) <$> f (_rsDay rspec)
|
||||
{-# INLINE rsDay #-}
|
||||
rsQuery f rspec = (\x -> rspec{_rsQuery=x}) <$> f (_rsQuery rspec)
|
||||
{-# INLINE rsQuery #-}
|
||||
rsQueryOpts f rspec = (\x -> rspec{_rsQueryOpts=x}) <$> f (_rsQueryOpts rspec)
|
||||
{-# INLINE rsQueryOpts #-}
|
||||
instance HasReportOptsNoUpdate ReportSpec where
|
||||
reportOptsNoUpdate = rsReportOpts
|
||||
|
||||
instance HasReportOpts ReportSpec where
|
||||
reportOpts f rspec = report (error "Updating ReportSpec failed: try using overWithReport instead of over") $ -- PARTIAL:
|
||||
reportOpts f rspec = report (error' "Updating ReportSpec failed: try using overEither instead of over or setEither instead of set") $ -- PARTIAL:
|
||||
reportOptsToSpec (_rsDay rspec) <$> f (_rsReportOpts rspec)
|
||||
{-# INLINE reportOpts #-}
|
||||
reportOptsNoUpdate f rspec = (\x -> rspec{_rsReportOpts=x}) <$> f (_rsReportOpts rspec)
|
||||
{-# INLINE reportOptsNoUpdate #-}
|
||||
|
||||
-- | Generate a ReportSpec from a set of ReportOpts on a given day.
|
||||
reportOptsToSpec :: Day -> ReportOpts -> Either String ReportSpec
|
||||
reportOptsToSpec day ropts = do
|
||||
(argsquery, queryopts) <- parseQueryList day $ querystring_ ropts
|
||||
return ReportSpec
|
||||
{ _rsReportOpts = ropts
|
||||
, _rsDay = day
|
||||
, _rsQuery = simplifyQuery $ And [queryFromFlags ropts, argsquery]
|
||||
, _rsQueryOpts = queryopts
|
||||
}
|
||||
|
||||
-- | Update the ReportOpts and the fields derived from it in a ReportSpec,
|
||||
-- or return an error message if there is a problem such as missing or
|
||||
-- unparseable options data. This is the safe way to change a ReportSpec,
|
||||
-- ensuring that all fields (_rsQuery, _rsReportOpts, querystring_, etc.) are in sync.
|
||||
updateReportSpec :: ReportOpts -> ReportSpec -> Either String ReportSpec
|
||||
updateReportSpec = setEither reportOpts
|
||||
|
||||
-- | Like updateReportSpec, but takes a ReportOpts-modifying function.
|
||||
updateReportSpecWith :: (ReportOpts -> ReportOpts) -> ReportSpec -> Either String ReportSpec
|
||||
updateReportSpecWith = overEither reportOpts
|
||||
|
||||
-- | Generate a ReportSpec from RawOpts and the current date.
|
||||
rawOptsToReportSpec :: RawOpts -> IO ReportSpec
|
||||
rawOptsToReportSpec rawopts = do
|
||||
d <- getCurrentDay
|
||||
let ropts = rawOptsToReportOpts d rawopts
|
||||
either fail return $ reportOptsToSpec d ropts
|
||||
|
||||
@ -747,4 +747,3 @@ getDirectoryContentsSafe d =
|
||||
-- putStrLn $ "processed opts:\n" ++ show opts
|
||||
-- d <- getCurrentDay
|
||||
-- putStrLn $ "search query: " ++ (show $ queryFromOpts d $ reportopts_ opts)
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user