datepicker

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