datepicker

  1module UI.Month (MonthView, mkMonthView) where
  2
  3import Data.Bool (bool)
  4import Data.List (find)
  5import Data.List.NonEmpty qualified as NE
  6import Data.Maybe (fromJust)
  7import Data.Time.Calendar qualified as Cal
  8import Data.Time.Calendar.Month (Month, addMonths)
  9import Data.Time.Format qualified as Fmt
 10import Data.Time.LocalTime (LocalTime (LocalTime), TimeOfDay (TimeOfDay))
 11import Graphics.Vty.Attributes qualified as Attr
 12import Graphics.Vty.Image qualified as I
 13import Graphics.Vty.Input.Events qualified as E
 14import UI (View (..))
 15import Util
 16
 17data MonthView = MonthView
 18  { months :: [Month],
 19    curDay :: Cal.Day,
 20    numCols :: Int,
 21    movType :: Movement
 22  }
 23
 24instance View MonthView where
 25  draw = drawView
 26  process = processEvent
 27
 28mkMonthView :: [Month] -> Cal.Day -> Bool -> MonthView
 29mkMonthView ms day logicMove =
 30  MonthView ms day 3 $ if logicMove then MLogical else MSpatial
 31
 32currentMonth :: MonthView -> Month
 33currentMonth MonthView {months = ms, curDay = d} =
 34  fromJust $ find (\m -> Cal.dayPeriod d == m) ms
 35
 36hasDay :: MonthView -> Cal.Day -> Bool
 37hasDay MonthView {months = ms} d =
 38  any (\m -> Cal.dayPeriod d == m) ms
 39
 40hasMonth :: MonthView -> Month -> Bool
 41hasMonth MonthView {months = ms} m =
 42  m `elem` ms
 43
 44-- TODO: Make this customizable to implement the cal(1) -m option.
 45firstDayOfWeek :: MonthView -> Bool
 46firstDayOfWeek mv@MonthView {curDay = d} =
 47  Cal.dayOfWeek d == Cal.Sunday
 48    || Cal.periodFirstDay (currentMonth mv) == d
 49
 50-- TODO: Make this customizable to implement the cal(1) -m option.
 51lastDayOfWeek :: MonthView -> Bool
 52lastDayOfWeek mv@MonthView {curDay = d} =
 53  Cal.dayOfWeek d == Cal.Saturday
 54    || Cal.periodLastDay (currentMonth mv) == d
 55
 56firstWeekDayOfMonth :: MonthView -> Bool
 57firstWeekDayOfMonth mv@MonthView {curDay = day} =
 58  firstWeekDay (currentMonth mv) (Cal.dayOfWeek day) == day
 59  where
 60    firstWeekDay :: Month -> Cal.DayOfWeek -> Cal.Day
 61    firstWeekDay m dw = Cal.firstDayOfWeekOnAfter dw (Cal.periodFirstDay m)
 62
 63lastWeekDayOfMonth :: MonthView -> Bool
 64lastWeekDayOfMonth mv@MonthView {curDay = day} =
 65  Just day == lastWeekDay (currentMonth mv) (Cal.dayOfWeek day)
 66  where
 67    lastWeekDay :: Month -> Cal.DayOfWeek -> Maybe Cal.Day
 68    lastWeekDay m dw = find ((==) dw . Cal.dayOfWeek) $ reverse (Cal.periodAllDays m)
 69
 70------------------------------------------------------------------------
 71
 72drawView :: MonthView -> I.Image
 73drawView MonthView {curDay = d, months = ms, numCols = cols} =
 74  I.vertCat (map I.horizCat $ splitEvery cols (map drawView' ms))
 75  where
 76    drawView' :: Month -> I.Image
 77    drawView' m =
 78      let img = drawMonth m d
 79       in img I.<|> makePad 2 (I.imageHeight img) I.<-> makePad weekWidth 1
 80
 81-- The return value specifies if the view has changed as a result
 82-- of processing the event, if so, 'drawView' needs to be invoked.
 83processEvent :: MonthView -> E.Event -> Either (Maybe MonthView) LocalTime
 84processEvent view@MonthView {curDay = day, movType = mov} (E.EvKey key _) =
 85  case key of
 86    E.KEnter -> Right $ LocalTime day (TimeOfDay 0 0 0)
 87    E.KUp -> Left $ moveCursor view mov PrevWeek
 88    E.KDown -> Left $ moveCursor view mov NextWeek
 89    E.KRight -> Left $ moveCursor view mov NextDay
 90    E.KLeft -> Left $ moveCursor view mov PrevDay
 91    _ -> Left Nothing
 92processEvent view (E.EvResize _ _) = Left $ Just view
 93processEvent _ _ = Left Nothing
 94
 95------------------------------------------------------------------------
 96
 97weekWidth :: Int
 98weekWidth = (2 * 7) + 6 -- +6 for spacing between weeks
 99
100drawDay :: Cal.Day -> Bool -> I.Image
101drawDay day curDay =
102  let attr = if curDay then high else Attr.defAttr
103   in I.string attr $ format "%_2e" day
104  where
105    high :: Attr.Attr
106    high =
107      Attr.defAttr
108        `Attr.withBackColor` Attr.white
109        `Attr.withForeColor` Attr.black
110
111drawWeeks :: Cal.Day -> NE.NonEmpty Week -> I.Image
112drawWeeks curDay weeks =
113  let w = NE.toList $ NE.map NE.toList weeks
114   in I.vertCat $ zipWith zipFunc [0 ..] (map drawWeek w)
115  where
116    zipFunc :: Int -> I.Image -> I.Image
117    zipFunc i = horizPad weekWidth (i == 0)
118
119    drawWeek :: [Cal.Day] -> I.Image
120    drawWeek days =
121      I.horizCat $
122        addSep (map (\day -> drawDay day $ day == curDay) days)
123
124-- XXX: Unfortunately, 'MonthYear' does not implement 'FormatTime'.
125drawMonthYear :: Month -> I.Image
126drawMonthYear m =
127  horizCenter weekWidth $
128    I.string Attr.defAttr (format "%B %Y" m)
129
130drawMonth :: Month -> Cal.Day -> I.Image
131drawMonth m curDay = drawMonthYear m I.<-> drawHeader locale I.<-> weeks
132  where
133    weeks :: I.Image
134    weeks = drawWeeks curDay (monthWeeks m)
135
136drawHeader :: Fmt.TimeLocale -> I.Image
137drawHeader Fmt.TimeLocale {Fmt.wDays = w} =
138  let wdays = map snd w
139      items = map (I.string Attr.defAttr . shortenWeekDay) wdays
140   in I.horizCat $ addSep items
141  where
142    shortenWeekDay :: String -> String
143    shortenWeekDay (f : s : _xs) = [f, s]
144    shortenWeekDay s = s
145
146------------------------------------------------------------------------
147
148data Direction = NextDay | PrevDay | NextWeek | PrevWeek
149  deriving (Eq, Show)
150
151data Movement = MLogical | MSpatial
152  deriving (Eq, Show)
153
154moveCursor :: MonthView -> Movement -> Direction -> Maybe MonthView
155moveCursor mv@MonthView {curDay = day, numCols = cols} mov dir
156  | mov == MSpatial && lastDayOfWeek mv && dir == NextDay =
157      moveSpatialHoriz mv 1 NE.head
158  | mov == MSpatial && firstDayOfWeek mv && dir == PrevDay =
159      moveSpatialHoriz mv (-1) NE.last
160  | mov == MSpatial && firstWeekDayOfMonth mv && dir == PrevWeek =
161      moveSpatialVert mv (cols * (-1)) NE.reverse
162  | mov == MSpatial && lastWeekDayOfMonth mv && dir == NextWeek =
163      moveSpatialVert mv cols id
164  | otherwise =
165      let newDay = moveLogical dir day
166       in bool Nothing (Just mv {curDay = newDay}) (hasDay mv newDay)
167
168moveLogical :: Direction -> Cal.Day -> Cal.Day
169moveLogical NextDay = Cal.addDays 1
170moveLogical PrevDay = Cal.addDays (-1)
171moveLogical NextWeek = addWeeks 1
172moveLogical PrevWeek = addWeeks (-1)
173
174moveSpatial ::
175  MonthView ->
176  Int ->
177  (Month -> Maybe Week) ->
178  (Week -> Maybe Cal.Day) ->
179  Maybe MonthView
180moveSpatial mv inc selectWeek selectDay =
181  let curMonth = currentMonth mv
182      newMonth = addMonths (fromIntegral inc) curMonth
183   in if hasMonth mv newMonth
184        then (\d -> mv {curDay = d}) <$> (selectWeek newMonth >>= selectDay)
185        else Nothing
186
187moveSpatialVert :: MonthView -> Int -> (Week -> Week) -> Maybe MonthView
188moveSpatialVert mv@MonthView {curDay = day} inc proc =
189  let dayOfWeek = Cal.dayOfWeek day
190   in moveSpatial
191        mv
192        inc
193        (Just . proc . NE.fromList . Cal.periodAllDays)
194        (find ((==) dayOfWeek . Cal.dayOfWeek))
195
196moveSpatialHoriz :: MonthView -> Int -> (Week -> Cal.Day) -> Maybe MonthView
197moveSpatialHoriz mv@MonthView {curDay = day} inc select =
198  moveSpatial mv inc (\m -> nthWeekOfMonth m (weekOfMonth day)) (Just . select)