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