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