datepicker

  1{-# LANGUAGE CPP #-}
  2
  3module Util
  4  ( Week,
  5    monthWeeks,
  6    weekOfMonth,
  7    nthWeekOfMonth,
  8    addWeeks,
  9    horizPad,
 10    horizCenter,
 11    vertCenter,
 12    format,
 13    addSep,
 14    locale,
 15    makePad,
 16    periodAllMonths,
 17    splitEvery,
 18  )
 19where
 20
 21import Data.List (findIndex, intersperse)
 22import Data.List.NonEmpty qualified as NE
 23import Data.Maybe (fromJust)
 24import Data.Time.Calendar qualified as Cal
 25import Data.Time.Calendar.Month (Month, addMonths, diffMonths)
 26import Data.Time.Format qualified as Fmt
 27import Graphics.Vty.Attributes qualified as Attr
 28import Graphics.Vty.Image qualified as I
 29
 30infixl 9 !?
 31
 32{- ORMOLU_DISABLE -}
 33-- From https://github.com/ghc/ghc/commit/d53f6f4d98aabd6f5b28fb110db1da0f6db70a06
 34(!?) :: NE.NonEmpty a -> Int -> Maybe a
 35xs !? n
 36  | n < 0     = Nothing
 37  | otherwise = foldr (\x r k -> case k of
 38                                   0 -> Just x
 39                                   _ -> r (k-1)) (const Nothing) xs n
 40{- ORMOLU_ENABLE -}
 41
 42splitEvery :: Int -> [a] -> [[a]]
 43splitEvery _ [] = []
 44splitEvery n list = first : splitEvery n rest
 45  where
 46    (first, rest) = splitAt n list
 47
 48------------------------------------------------------------------------
 49
 50type Week = NE.NonEmpty Cal.Day
 51
 52monthWeeks :: Month -> NE.NonEmpty Week
 53monthWeeks m = NE.fromList $ map NE.fromList (monthWeeks' $ Cal.periodFirstDay m)
 54  where
 55    weekOfDay :: Cal.Day -> [Cal.Day]
 56    weekOfDay = Cal.weekAllDays Cal.Sunday
 57
 58    monthWeeks' :: Cal.Day -> [[Cal.Day]]
 59    monthWeeks' d
 60      | Cal.dayPeriod d /= m = []
 61      | otherwise =
 62          let days = weekOfDay d
 63              nday = Cal.addDays 1 $ last days
 64           in filter ((==) m . Cal.dayPeriod) days : monthWeeks' nday
 65
 66weekOfMonth :: Cal.Day -> Int
 67weekOfMonth d =
 68  let weeks = monthWeeks (Cal.dayPeriod d)
 69   in fromJust $ findIndex (any ((==) d)) (NE.toList weeks)
 70
 71nthWeekOfMonth :: Month -> Int -> Maybe (NE.NonEmpty Cal.Day)
 72nthWeekOfMonth m n = monthWeeks m !? n
 73
 74periodAllMonths :: (Cal.DayPeriod p) => p -> [Month]
 75periodAllMonths p =
 76  let (fd, ld) = (Cal.periodFirstDay p, Cal.periodLastDay p)
 77      (fm, lm) = (Cal.dayPeriod fd :: Month, Cal.dayPeriod ld :: Month)
 78   in map (`addMonths` fm) [0 .. lm `diffMonths` fm]
 79
 80addWeeks :: Integer -> Cal.Day -> Cal.Day
 81addWeeks n = Cal.addDays (n * 7)
 82
 83------------------------------------------------------------------------
 84
 85-- TODO: Make this configurable
 86locale :: Fmt.TimeLocale
 87locale = Fmt.defaultTimeLocale
 88
 89format :: (Fmt.FormatTime t) => String -> t -> String
 90format = Fmt.formatTime locale
 91
 92addSep :: [I.Image] -> [I.Image]
 93addSep = intersperse (I.char Attr.defAttr ' ')
 94
 95makePad :: Int -> Int -> I.Image
 96makePad = I.charFill Attr.defAttr ' '
 97
 98horizPad :: Int -> Bool -> I.Image -> I.Image
 99horizPad w padLeft i =
100  let diff = w - I.imageWidth i
101      comb = if padLeft then I.horizJoin else flip I.horizJoin
102   in if diff > 0
103        then makePad diff 1 `comb` i
104        else i
105
106horizCenter :: Int -> I.Image -> I.Image
107horizCenter w img =
108  let diff = fromIntegral (w - I.imageWidth img) :: Double
109      ldiff = floor (diff / 2)
110      rdiff = ceiling (diff / 2)
111   in if diff > 0
112        then makePad ldiff 1 I.<|> img I.<|> makePad rdiff 1
113        else img
114
115vertCenter :: Int -> I.Image -> I.Image
116vertCenter w img =
117  let diff = fromIntegral (w - I.imageHeight img) :: Double
118      tdiff = floor (diff / 2)
119      bdiff = ceiling (diff / 2)
120   in if diff > 0
121        then makePad 1 tdiff I.<-> img I.<-> makePad 1 bdiff
122        else img