From 79cc999fa35c79aedd0a82f81db460ec17dfbfff Mon Sep 17 00:00:00 2001
From: Simon Michael <simon@joyful.com>
Date: Tue, 9 Aug 2016 15:31:35 -0700
Subject: [PATCH] ui: d/u zooms report period down/up, t selects today

---
 hledger-lib/Hledger/Data/Period.hs      | 100 ++++++++++++++++++------
 hledger-ui/Hledger/UI/AccountsScreen.hs |   4 +-
 hledger-ui/Hledger/UI/RegisterScreen.hs |   4 +-
 hledger-ui/Hledger/UI/UIState.hs        |  38 ++++++---
 hledger-ui/Hledger/UI/UIUtils.hs        |   6 +-
 hledger-ui/doc/hledger-ui.1.m4.md       |  12 +--
 6 files changed, 118 insertions(+), 46 deletions(-)

diff --git a/hledger-lib/Hledger/Data/Period.hs b/hledger-lib/Hledger/Data/Period.hs
index 24ae998b2..c158f458e 100644
--- a/hledger-lib/Hledger/Data/Period.hs
+++ b/hledger-lib/Hledger/Data/Period.hs
@@ -1,8 +1,7 @@
 {-|
 
 Manipulate the time periods typically used for reports with Period,
-a richer abstraction that will probably replace DateSpan.
-See also Types and Dates.
+a richer abstraction than DateSpan. See also Types and Dates.
 
 -}
 
@@ -144,30 +143,6 @@ periodEnd p = me
   where
     DateSpan _ me = periodAsDateSpan p
 
--- | Enlarge a period to the next larger common duration, if there is one.
--- The new period will enclose the old one. A day becomes a week,
--- a week becomes a month (whichever month the week's middle day,
--- ie thursday, falls into), etc. A year is the largest duration
--- and growing that has no effect.
-periodGrow :: Period -> Period
-periodGrow (DayPeriod b) = WeekPeriod $ mondayBefore b
-periodGrow (WeekPeriod b) = MonthPeriod y m
-  where (y,m) = yearMonthContainingWeek b
-periodGrow (MonthPeriod y m) = QuarterPeriod y ((m-1) `div` 3 + 1)
-periodGrow (QuarterPeriod y _) = YearPeriod y
-periodGrow (YearPeriod _) = PeriodAll
-periodGrow p = p
-
-mondayBefore d = addDays (fromIntegral (1 - wd)) d
-  where
-    (_,_,wd) = toWeekDate d
-
-yearMonthContainingWeek weekstart = (y,m)
-  where
-    thu = addDays 3 weekstart
-    (y,yd) = toOrdinalDate thu
-    (m,_) = dayOfYearToMonthAndDay (isLeapYear y) yd
-
 -- | Move a period to the following period of same duration.
 periodNext :: Period -> Period
 periodNext (DayPeriod b) = DayPeriod (addDays 1 b)
@@ -190,3 +165,76 @@ periodPrevious (QuarterPeriod y q) = QuarterPeriod y (q-1)
 periodPrevious (YearPeriod y) = YearPeriod (y-1)
 periodPrevious p = p
 
+-- | Enlarge a standard period to the next larger enclosing standard period, if there is one.
+-- Eg, a day becomes the enclosing week.
+-- A week becomes whichever month the week's thursday falls into.
+-- A year becomes all (unlimited).
+-- Growing an unlimited period, or a non-standard period (arbitrary dates) has no effect.
+periodGrow :: Period -> Period
+periodGrow (DayPeriod b) = WeekPeriod $ mondayBefore b
+periodGrow (WeekPeriod b) = MonthPeriod y m
+  where (y,m) = yearMonthContainingWeekStarting b
+periodGrow (MonthPeriod y m) = QuarterPeriod y (quarterContainingMonth m)
+periodGrow (QuarterPeriod y _) = YearPeriod y
+periodGrow (YearPeriod _) = PeriodAll
+periodGrow p = p
+
+-- | Shrink a period to the next smaller standard period inside it,
+-- choosing the subperiod which contains today's date if possible,
+-- otherwise the first subperiod. It goes like this:
+-- unbounded periods and nonstandard periods (between two arbitrary dates) ->
+-- current year ->
+-- current quarter if it's in selected year, otherwise first quarter of selected year ->
+-- current month if it's in selected quarter, otherwise first month of selected quarter ->
+-- current week if it's in selected month, otherwise first week of selected month ->
+-- today if it's in selected week, otherwise first day of selected week,
+--  unless that's in previous month, in which case first day of month containing selected week.
+-- Shrinking a day has no effect.
+periodShrink :: Day -> Period -> Period
+periodShrink _     p@(DayPeriod _) = p
+periodShrink today (WeekPeriod b)
+  | today >= b && diffDays today b < 7 = DayPeriod today
+  | m /= weekmonth                     = DayPeriod $ fromGregorian weekyear weekmonth 1
+  | otherwise                          = DayPeriod b
+  where
+    (_,m,_) = toGregorian b
+    (weekyear,weekmonth) = yearMonthContainingWeekStarting b
+periodShrink today (MonthPeriod y m)
+  | (y',m') == (y,m) = WeekPeriod $ mondayBefore today
+  | otherwise        = WeekPeriod $ startOfFirstWeekInMonth y m
+  where (y',m',_) = toGregorian today
+periodShrink today (QuarterPeriod y q)
+  | quarterContainingMonth thismonth == q = MonthPeriod y thismonth
+  | otherwise                             = MonthPeriod y (firstMonthOfQuarter q)
+  where (_,thismonth,_) = toGregorian today
+periodShrink today (YearPeriod y)
+  | y == thisyear = QuarterPeriod y thisquarter
+  | otherwise     = QuarterPeriod y 1
+  where
+    (thisyear,thismonth,_) = toGregorian today
+    thisquarter = quarterContainingMonth thismonth
+periodShrink today _ = YearPeriod y
+  where (y,_,_) = toGregorian today
+
+mondayBefore d = addDays (fromIntegral (1 - wd)) d
+  where
+    (_,_,wd) = toWeekDate d
+
+yearMonthContainingWeekStarting weekstart = (y,m)
+  where
+    thu = addDays 3 weekstart
+    (y,yd) = toOrdinalDate thu
+    (m,_) = dayOfYearToMonthAndDay (isLeapYear y) yd
+
+quarterContainingMonth m = (m-1) `div` 3 + 1
+
+firstMonthOfQuarter q = (q-1)*3 + 1
+
+startOfFirstWeekInMonth y m
+  | monthstartday <= 4 = mon
+  | otherwise          = addDays 7 mon  -- month starts with a fri/sat/sun
+  where
+    monthstart = fromGregorian y m 1
+    mon = mondayBefore monthstart
+    (_,_,monthstartday) = toWeekDate monthstart
+
diff --git a/hledger-ui/Hledger/UI/AccountsScreen.hs b/hledger-ui/Hledger/UI/AccountsScreen.hs
index bdb821559..012a34be0 100644
--- a/hledger-ui/Hledger/UI/AccountsScreen.hs
+++ b/hledger-ui/Hledger/UI/AccountsScreen.hs
@@ -286,7 +286,9 @@ asHandle ui0@UIState{
         EvKey (KChar '-') [] -> continue $ regenerateScreens j d $ decDepth ui
         EvKey (KChar '_') [] -> continue $ regenerateScreens j d $ decDepth ui
         EvKey (KChar c)   [] | c `elem` ['+','='] -> continue $ regenerateScreens j d $ incDepth ui
-        EvKey (KChar 'd') [] -> continue $ regenerateScreens j d $ cycleReportDuration d ui
+        EvKey (KChar 'd') [] -> continue $ regenerateScreens j d $ cycleReportDurationDown d ui
+        EvKey (KChar 'u') [] -> continue $ regenerateScreens j d $ cycleReportDurationUp d ui
+        EvKey (KChar 't') [] -> continue $ regenerateScreens j d $ setReportPeriod (DayPeriod d) ui
         EvKey (KChar 'n') [] -> continue $ regenerateScreens j d $ nextReportPeriod ui
         EvKey (KChar 'p') [] -> continue $ regenerateScreens j d $ previousReportPeriod ui
         EvKey (KChar 'F') [] -> continue $ regenerateScreens j d $ toggleFlat ui
diff --git a/hledger-ui/Hledger/UI/RegisterScreen.hs b/hledger-ui/Hledger/UI/RegisterScreen.hs
index b9c703e84..79ffeaf9a 100644
--- a/hledger-ui/Hledger/UI/RegisterScreen.hs
+++ b/hledger-ui/Hledger/UI/RegisterScreen.hs
@@ -259,7 +259,9 @@ rsHandle ui@UIState{
         EvKey (KChar 'g') [] -> liftIO (uiReloadJournalIfChanged copts d j ui) >>= continue
         EvKey (KChar 'I') [] -> continue $ uiCheckBalanceAssertions d (toggleIgnoreBalanceAssertions ui)
         EvKey (KChar 'a') [] -> suspendAndResume $ clearScreen >> setCursorPosition 0 0 >> add copts j >> uiReloadJournalIfChanged copts d j ui
-        EvKey (KChar 'd') [] -> continue $ regenerateScreens j d $ cycleReportDuration d ui
+        EvKey (KChar 'd') [] -> continue $ regenerateScreens j d $ cycleReportDurationDown d ui
+        EvKey (KChar 'u') [] -> continue $ regenerateScreens j d $ cycleReportDurationUp d ui
+        EvKey (KChar 't') [] -> continue $ regenerateScreens j d $ setReportPeriod (DayPeriod d) ui
         EvKey (KChar 'n') [] -> continue $ regenerateScreens j d $ nextReportPeriod ui
         EvKey (KChar 'p') [] -> continue $ regenerateScreens j d $ previousReportPeriod ui
         EvKey (KChar 'E') [] -> suspendAndResume $ void (runEditor pos f) >> uiReloadJournalIfChanged copts d j ui
diff --git a/hledger-ui/Hledger/UI/UIState.hs b/hledger-ui/Hledger/UI/UIState.hs
index 3fee58302..4d4290c76 100644
--- a/hledger-ui/Hledger/UI/UIState.hs
+++ b/hledger-ui/Hledger/UI/UIState.hs
@@ -68,18 +68,20 @@ toggleIgnoreBalanceAssertions :: UIState -> UIState
 toggleIgnoreBalanceAssertions ui@UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{}}} =
   ui{aopts=uopts{cliopts_=copts{ignore_assertions_=not $ ignore_assertions_ copts}}}
 
--- | Cycle through increasingly larger report periods enclosing the current one.
-cycleReportDuration :: Day -> UIState -> UIState
-cycleReportDuration d ui@UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}} =
-  ui{aopts=uopts{cliopts_=copts{reportopts_=reportOptsCycleDuration d ropts}}}
+-- | Cycle through larger report periods.
+cycleReportDurationUp :: Day -> UIState -> UIState
+cycleReportDurationUp d ui@UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}} =
+  ui{aopts=uopts{cliopts_=copts{reportopts_=reportOptsCycleDurationUp d ropts}}}
 
--- | Cycle through increasingly larger report periods.
--- Simple periods (a specific day, monday-starting week, month, quarter, year)
--- become the next larger enclosing period.
--- Other periods (between two arbitrary dates, or unbounded on one or both ends)
--- become today.
-reportOptsCycleDuration :: Day -> ReportOpts -> ReportOpts
-reportOptsCycleDuration d ropts@ReportOpts{period_=p} = ropts{period_=p'}
+-- | Cycle through smaller report periods.
+cycleReportDurationDown :: Day -> UIState -> UIState
+cycleReportDurationDown d ui@UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}} =
+  ui{aopts=uopts{cliopts_=copts{reportopts_=reportOptsCycleDurationDown d ropts}}}
+
+-- | Cycle through increasingly large report periods using periodGrow,
+-- then start again at today.
+reportOptsCycleDurationUp :: Day -> ReportOpts -> ReportOpts
+reportOptsCycleDurationUp d ropts@ReportOpts{period_=p} = ropts{period_=p'}
   where
     p' = case p of
            PeriodAll         -> DayPeriod d
@@ -88,6 +90,15 @@ reportOptsCycleDuration d ropts@ReportOpts{period_=p} = ropts{period_=p'}
            PeriodBetween _ _ -> DayPeriod d
            _                 -> periodGrow p
 
+-- | Cycle through increasingly small report periods using periodShrink,
+-- then start again at unlimited.
+reportOptsCycleDurationDown :: Day -> ReportOpts -> ReportOpts
+reportOptsCycleDurationDown d ropts@ReportOpts{period_=p} = ropts{period_=p'}
+  where
+    p' = case p of
+           DayPeriod _ -> PeriodAll
+           _           -> periodShrink d p
+
 -- | Step the report start/end dates to the next period of same duration.
 nextReportPeriod :: UIState -> UIState
 nextReportPeriod ui@UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts@ReportOpts{period_=p}}}} =
@@ -98,6 +109,11 @@ previousReportPeriod :: UIState -> UIState
 previousReportPeriod ui@UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts@ReportOpts{period_=p}}}} =
   ui{aopts=uopts{cliopts_=copts{reportopts_=ropts{period_=periodPrevious p}}}}
 
+-- | Set the report period.
+setReportPeriod :: Period -> UIState -> UIState
+setReportPeriod p ui@UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}} =
+  ui{aopts=uopts{cliopts_=copts{reportopts_=ropts{period_=p}}}}
+
 -- | Apply a new filter query.
 setFilter :: String -> UIState -> UIState
 setFilter s ui@UIState{aopts=uopts@UIOpts{cliopts_=copts@CliOpts{reportopts_=ropts}}} =
diff --git a/hledger-ui/Hledger/UI/UIUtils.hs b/hledger-ui/Hledger/UI/UIUtils.hs
index 8a8982cbc..9a078d43c 100644
--- a/hledger-ui/Hledger/UI/UIUtils.hs
+++ b/hledger-ui/Hledger/UI/UIUtils.hs
@@ -71,9 +71,11 @@ helpDialog =
                   ,renderKey ("R", "toggle real filter")
                   ,renderKey ("Z", "toggle nonzero filter")
                   ,renderKey ("F", "toggle flat/exclusive mode")
-                  ,renderKey ("d", "change report period duration")
-                  ,str "when duration set:"
+                  ,str " "
+                  ,renderKey ("t", "  set report period to today")
+                  ,renderKey ("d/u", "decrease/increase report period")
                   ,renderKey ("n/p", "next/previous report period")
+                  ,str " "
                   ,str "accounts screen:"
                   ,renderKey ("-+0123456789", "set depth limit")
                   ,str " "
diff --git a/hledger-ui/doc/hledger-ui.1.m4.md b/hledger-ui/doc/hledger-ui.1.m4.md
index c450ea712..0d7e7d559 100644
--- a/hledger-ui/doc/hledger-ui.1.m4.md
+++ b/hledger-ui/doc/hledger-ui.1.m4.md
@@ -93,11 +93,13 @@ command-line edit keys
 ([CTRL-a/e/d/k, cursor keys etc.](http://hackage.haskell.org/package/brick-0.7/docs/Brick-Widgets-Edit.html#t:Editor)), 
 and `ENTER`to set the new filter or `ESCAPE`to cancel.
 
-`d` cycles through the common report period durations: 
-day, week, month, quarter, year, and unlimited (the default).
-When the report duration is limited in this way, `n` and `p`
-step to the next or previous day/week/month/etc.
-(To set arbitrary start/end dates, you can use `/` to set a [`date:` query](manual.html#queries).)
+`t` sets the report period to today,
+while `d` and `u` cycle downward and upward through standard report periods
+- day, week, month, quarter, year, and unlimited. 
+This is useful on the register screen, to limit the transaction history.
+When a standard report period is selected in this way, 
+`n` and `p` step to the next or previous period.
+(For non-standard periods, you can use `/` to set a [`date:` query](manual.html#queries).)
 
 `BACKSPACE` or `DELETE` clears any filters in effect.