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