datepicker

  1{-# LANGUAGE OverloadedLists #-}
  2
  3module DatePicker.UI.Time (TimeView, mkTimeView) where
  4
  5import Data.Char (digitToInt, isDigit)
  6import Data.List.NonEmpty qualified as NE
  7import Data.Time.Calendar qualified as Cal
  8import Data.Time.LocalTime (LocalTime (LocalTime), TimeOfDay (todHour, todMin), makeTimeOfDayValid)
  9import DatePicker.UI (View (..))
 10import DatePicker.Util (format, horizCenter, makePad)
 11import Graphics.Vty.Attributes qualified as Attr
 12import Graphics.Vty.Image qualified as I
 13import Graphics.Vty.Input.Events qualified as E
 14
 15data TimeView = TimeView
 16  { rawInput :: NE.NonEmpty Int,
 17    position :: Word,
 18    initTime :: LocalTime
 19  }
 20
 21instance View TimeView where
 22  draw = drawView
 23  process = processEvent
 24
 25type ClockGlyph = [[Int]]
 26
 27-- Shamelessly stolen from the tmux clock-mode.
 28--
 29-- See: https://github.com/tmux/tmux/blob/3.5a/window-clock.c#L53-L124
 30clockFont :: [ClockGlyph]
 31clockFont =
 32  [ [ [1, 1, 1, 1, 1], -- 0
 33      [1, 0, 0, 0, 1],
 34      [1, 0, 0, 0, 1],
 35      [1, 0, 0, 0, 1],
 36      [1, 1, 1, 1, 1]
 37    ],
 38    [ [0, 0, 0, 0, 1], -- 1
 39      [0, 0, 0, 0, 1],
 40      [0, 0, 0, 0, 1],
 41      [0, 0, 0, 0, 1],
 42      [0, 0, 0, 0, 1]
 43    ],
 44    [ [1, 1, 1, 1, 1], -- 2
 45      [0, 0, 0, 0, 1],
 46      [1, 1, 1, 1, 1],
 47      [1, 0, 0, 0, 0],
 48      [1, 1, 1, 1, 1]
 49    ],
 50    [ [1, 1, 1, 1, 1], -- 3
 51      [0, 0, 0, 0, 1],
 52      [1, 1, 1, 1, 1],
 53      [0, 0, 0, 0, 1],
 54      [1, 1, 1, 1, 1]
 55    ],
 56    [ [1, 0, 0, 0, 1], -- 4
 57      [1, 0, 0, 0, 1],
 58      [1, 1, 1, 1, 1],
 59      [0, 0, 0, 0, 1],
 60      [0, 0, 0, 0, 1]
 61    ],
 62    [ [1, 1, 1, 1, 1], -- 5
 63      [1, 0, 0, 0, 0],
 64      [1, 1, 1, 1, 1],
 65      [0, 0, 0, 0, 1],
 66      [1, 1, 1, 1, 1]
 67    ],
 68    [ [1, 1, 1, 1, 1], -- 6
 69      [1, 0, 0, 0, 0],
 70      [1, 1, 1, 1, 1],
 71      [1, 0, 0, 0, 1],
 72      [1, 1, 1, 1, 1]
 73    ],
 74    [ [1, 1, 1, 1, 1], -- 7
 75      [0, 0, 0, 0, 1],
 76      [0, 0, 0, 0, 1],
 77      [0, 0, 0, 0, 1],
 78      [0, 0, 0, 0, 1]
 79    ],
 80    [ [1, 1, 1, 1, 1], -- 8
 81      [1, 0, 0, 0, 1],
 82      [1, 1, 1, 1, 1],
 83      [1, 0, 0, 0, 1],
 84      [1, 1, 1, 1, 1]
 85    ],
 86    [ [1, 1, 1, 1, 1], -- 9
 87      [1, 0, 0, 0, 1],
 88      [1, 1, 1, 1, 1],
 89      [0, 0, 0, 0, 1],
 90      [1, 1, 1, 1, 1]
 91    ],
 92    [ [0, 0, 0, 0, 0], -- :
 93      [0, 0, 1, 0, 0],
 94      [0, 0, 0, 0, 0],
 95      [0, 0, 1, 0, 0],
 96      [0, 0, 0, 0, 0]
 97    ]
 98  ]
 99
100mkTimeView :: TimeOfDay -> LocalTime -> TimeView
101mkTimeView cur = TimeView (toInput cur) 0
102  where
103    toInput :: TimeOfDay -> NE.NonEmpty Int
104    toInput t = fromInt (todHour t) `NE.append` fromInt (todMin t)
105
106    fromInt :: Int -> NE.NonEmpty Int
107    fromInt n =
108      let t = map digitToInt $ show n
109       in if length t < 2 then 0 NE.:| t else NE.fromList t
110
111drawView :: TimeView -> I.Image
112drawView v@TimeView {initTime = t} =
113  let str = format "%-d %B, %Y" t
114      clk = drawClock v
115   in horizCenter (I.imageWidth clk) (I.string Attr.defAttr str)
116        I.<-> makePad (I.imageWidth clk) 1
117        I.<-> drawClock v
118
119processEvent :: TimeView -> E.Event -> Either (Maybe TimeView) LocalTime
120processEvent view (E.EvKey key _mods) =
121  case key of
122    E.KChar c -> Left $ processInput view c
123    E.KBS -> Left $ Just (moveCursor view (-1))
124    E.KLeft -> Left $ Just (moveCursor view (-1))
125    E.KRight -> Left $ Just (moveCursor view 1)
126    E.KEnter -> case getTimeOfDay view of
127      Nothing -> Left Nothing -- TODO: Provide visual feedback
128      Just t -> Right $ LocalTime (Cal.ModifiedJulianDay 0) t
129    _ -> Left Nothing
130processEvent view (E.EvResize _ _) = Left $ Just view
131processEvent _ _ = Left Nothing
132
133------------------------------------------------------------------------
134
135moveCursor :: TimeView -> Int -> TimeView
136moveCursor view@TimeView {rawInput = input, position = p} off =
137  let len = fromIntegral $ NE.length input
138   in view {position = (p + fromIntegral off) `mod` len}
139
140drawGlyph :: ClockGlyph -> Attr.Attr -> I.Image
141drawGlyph glyph attr =
142  let digits = map (`drawBlock` attr) glyph
143   in I.vertCat digits I.<|> makePad 1 (length digits)
144
145drawClock :: TimeView -> I.Image
146drawClock TimeView {position = curPos, rawInput = input} =
147  let (h, m) = NE.splitAt 2 $ NE.zipWith drawDigit [0 ..] input
148   in I.horizCat h I.<|> colonSep I.<|> I.horizCat m
149  where
150    defAttr :: Attr.Attr
151    defAttr = Attr.defAttr `Attr.withBackColor` Attr.cyan
152
153    drawDigit idx digit =
154      drawGlyph (clockFont !! digit) $
155        if idx == curPos
156          then defAttr `Attr.withBackColor` Attr.magenta
157          else defAttr
158
159    colonSep :: I.Image
160    colonSep = drawGlyph (last clockFont) defAttr
161
162drawBlock :: [Int] -> Attr.Attr -> I.Image
163drawBlock blk attr = I.horizCat $ map (\i -> I.char (a i) ' ') blk
164  where
165    a i = if i == 1 then attr else Attr.defAttr
166
167getTimeOfDay :: TimeView -> Maybe TimeOfDay
168getTimeOfDay TimeView {rawInput = input} =
169  let (h, m) = NE.splitAt 2 input
170   in makeTimeOfDayValid (toInt h) (toInt m) 0
171  where
172    toInt :: [Int] -> Int
173    toInt = read . concatMap show
174
175processInput :: TimeView -> Char -> Maybe TimeView
176processInput v c
177  | isDigit c = Just $ cycleDigits v (digitToInt c)
178  | otherwise = Nothing
179
180cycleDigits :: TimeView -> Int -> TimeView
181cycleDigits v@TimeView {position = p, rawInput = input} n =
182  let newView = moveCursor v 1
183   in newView {rawInput = newInput}
184  where
185    newInput :: NE.NonEmpty Int
186    newInput = NE.zipWith (\e i -> if i == p then n else e) input [0 ..]