datepicker

  1{-# LANGUAGE CPP #-}
  2
  3module Main where
  4
  5import Control.Exception (throwIO)
  6import Data.Time.Calendar qualified as Cal
  7import Data.Time.LocalTime
  8  ( LocalTime (LocalTime),
  9    ZonedTime (ZonedTime),
 10    getCurrentTimeZone,
 11    getZonedTime,
 12    localDay,
 13    zonedTimeToLocalTime,
 14  )
 15import DatePicker.CmdLine
 16  ( getCmdArgs,
 17    getTime,
 18    optDuration,
 19    optFormat,
 20    optLogical,
 21    optMonday,
 22    optNoTime,
 23    optSelect,
 24    optTime,
 25    optsPeriod,
 26  )
 27import DatePicker.UI qualified as UI
 28import DatePicker.UI.Month qualified as M
 29import DatePicker.UI.Time qualified as T
 30import DatePicker.Util (format, parseTime)
 31import Graphics.Vty qualified as V
 32import Graphics.Vty.Input.Events qualified as E
 33import Graphics.Vty.Platform.Unix (mkVtyWithSettings)
 34import Graphics.Vty.Platform.Unix.Settings qualified as VU
 35import System.Posix.IO (OpenMode (ReadWrite), defaultFileFlags, openFd)
 36
 37isTerm :: E.Event -> Bool
 38isTerm (E.EvKey key _) =
 39  key == E.KEsc || key == E.KChar 'q'
 40isTerm _ = False
 41
 42-- Make sure we read and write to /dev/tty instead of relying on stdin/stdout.
 43-- This allows using datepicker within pipes where stdin/stdout is redirected.
 44unixSettings :: IO VU.UnixSettings
 45unixSettings = do
 46#if MIN_VERSION_unix(2,8,0)
 47  ttyFd <- openFd "/dev/tty" ReadWrite defaultFileFlags
 48#else
 49  ttyFd <- openFd "/dev/tty" ReadWrite Nothing defaultFileFlags
 50#endif
 51
 52  -- Can't build upon defaultSettings here as it flushes standard input and
 53  -- if standard input is a pipe it may not necessarily be flushable.
 54  mb <- VU.currentTerminalName
 55  case mb of
 56    Nothing -> throwIO VU.MissingTermEnvVar
 57    Just t -> do
 58      return $
 59        VU.UnixSettings
 60          { VU.settingVmin = 1,
 61            VU.settingVtime = 100,
 62            VU.settingInputFd = ttyFd,
 63            VU.settingOutputFd = ttyFd,
 64            VU.settingTermName = t
 65          }
 66
 67main :: IO ()
 68main = do
 69  args <- getCmdArgs
 70  let dateFmt = optFormat args
 71
 72  localTime <- zonedTimeToLocalTime <$> getZonedTime
 73  today <- case optTime args of
 74    Nothing -> pure $ localDay localTime
 75    Just it -> getTime localTime it
 76  selected <- case optSelect args of
 77    Nothing -> pure today
 78    Just sd -> parseTime False dateFmt sd
 79
 80  let range = optsPeriod (optDuration args) today
 81      mview =
 82        M.mkMonthView
 83          range
 84          selected
 85          (if optMonday args then Cal.Monday else Cal.Sunday)
 86          (optLogical args)
 87  view <- case mview of
 88    Nothing -> fail "specified date is not in displayed range"
 89    Just x -> pure x
 90
 91  vty <- unixSettings >>= mkVtyWithSettings V.defaultConfig
 92  lt@(LocalTime date _) <- UI.showView view isTerm vty
 93
 94  timeZone <- getCurrentTimeZone
 95  let mkZonedTime local = ZonedTime local timeZone
 96
 97  if optNoTime args
 98    then V.shutdown vty >> putStrLn (format dateFmt $ mkZonedTime lt)
 99    else do
100      (LocalTime _ nowTime) <- zonedTimeToLocalTime <$> getZonedTime
101      (LocalTime _ time) <- UI.showView (T.mkTimeView nowTime lt) isTerm vty
102
103      let res = LocalTime date time
104      V.shutdown vty >> putStrLn (format dateFmt $ mkZonedTime res)