datepicker

 1{-# LANGUAGE CPP #-}
 2
 3module DatePicker.Util
 4  ( Week,
 5    monthWeeks,
 6    addWeeks,
 7    horizPad,
 8    horizCenter,
 9    vertCenter,
10    locale,
11    format,
12    addSep,
13    makePad,
14    periodAllMonths,
15    splitEvery,
16  )
17where
18
19import Data.List (intersperse)
20import Data.List.NonEmpty qualified as NE
21import Data.Time.Calendar qualified as Cal
22import Data.Time.Calendar.Month (Month, addMonths, diffMonths)
23import Data.Time.Format qualified as Fmt
24import Graphics.Vty.Attributes qualified as Attr
25import Graphics.Vty.Image qualified as I
26
27splitEvery :: Int -> [a] -> [[a]]
28splitEvery _ [] = []
29splitEvery n list = first : splitEvery n rest
30  where
31    (first, rest) = splitAt n list
32
33------------------------------------------------------------------------
34
35type Week = NE.NonEmpty Cal.Day
36
37monthWeeks :: Month -> Cal.DayOfWeek -> NE.NonEmpty Week
38monthWeeks m dw = NE.fromList $ map NE.fromList (monthWeeks' $ Cal.periodFirstDay m)
39  where
40    weekOfDay :: Cal.Day -> [Cal.Day]
41    weekOfDay = Cal.weekAllDays dw
42
43    monthWeeks' :: Cal.Day -> [[Cal.Day]]
44    monthWeeks' d
45      | Cal.dayPeriod d /= m = []
46      | otherwise =
47          let days = weekOfDay d
48              nday = Cal.addDays 1 $ last days
49           in filter ((==) m . Cal.dayPeriod) days : monthWeeks' nday
50
51periodAllMonths :: (Cal.DayPeriod p) => p -> [Month]
52periodAllMonths p =
53  let (fd, ld) = (Cal.periodFirstDay p, Cal.periodLastDay p)
54      (fm, lm) = (Cal.dayPeriod fd :: Month, Cal.dayPeriod ld :: Month)
55   in map (`addMonths` fm) [0 .. lm `diffMonths` fm]
56
57addWeeks :: Integer -> Cal.Day -> Cal.Day
58addWeeks n = Cal.addDays (n * 7)
59
60------------------------------------------------------------------------
61
62-- TODO: Make the default locale configurable
63locale :: Fmt.TimeLocale
64locale = Fmt.defaultTimeLocale
65
66format :: (Fmt.FormatTime t) => String -> t -> String
67format = Fmt.formatTime locale
68
69addSep :: [I.Image] -> [I.Image]
70addSep = intersperse (I.char Attr.defAttr ' ')
71
72makePad :: Int -> Int -> I.Image
73makePad = I.charFill Attr.defAttr ' '
74
75horizPad :: Int -> Bool -> I.Image -> I.Image
76horizPad w padLeft i =
77  let diff = w - I.imageWidth i
78      comb = if padLeft then I.horizJoin else flip I.horizJoin
79   in if diff > 0
80        then makePad diff 1 `comb` i
81        else i
82
83horizCenter :: Int -> I.Image -> I.Image
84horizCenter w img =
85  let diff = fromIntegral (w - I.imageWidth img) :: Double
86      ldiff = floor (diff / 2)
87      rdiff = ceiling (diff / 2)
88   in if diff > 0
89        then makePad ldiff 1 I.<|> img I.<|> makePad rdiff 1
90        else img
91
92vertCenter :: Int -> I.Image -> I.Image
93vertCenter w img =
94  let diff = fromIntegral (w - I.imageHeight img) :: Double
95      tdiff = floor (diff / 2)
96      bdiff = ceiling (diff / 2)
97   in if diff > 0
98        then makePad 1 tdiff I.<-> img I.<-> makePad 1 bdiff
99        else img