datepicker

  1{-# LANGUAGE PatternSynonyms #-}
  2
  3module DatePicker.CmdLine
  4  ( Opts (..),
  5    CmdTime,
  6    getTime,
  7    optsPeriod,
  8    getCmdArgs,
  9  )
 10where
 11
 12import Control.Applicative ((<|>))
 13import Data.Time.Calendar qualified as Cal
 14import Data.Time.Calendar.Month (Month, addMonths, pattern YearMonth)
 15import Data.Time.Calendar.OrdinalDate (Day, toOrdinalDate)
 16import Data.Time.Format qualified as Fmt
 17import Data.Time.LocalTime (LocalTime (LocalTime))
 18import DatePicker.Util (locale, periodAllMonths)
 19import Options.Applicative qualified as OPT
 20
 21data CmdTime = CmdTime String (Maybe String)
 22
 23firstDayInMY :: Cal.Year -> Cal.MonthOfYear -> Day
 24firstDayInMY y my = Cal.periodFirstDay $ YearMonth y my
 25
 26parseMonth :: String -> IO Month
 27parseMonth input =
 28  Fmt.parseTimeM False locale "%B" input
 29    <|> Fmt.parseTimeM False locale "%b" input
 30    <|> Fmt.parseTimeM False locale "%m" input
 31
 32getTime :: LocalTime -> CmdTime -> IO Day
 33getTime _ (CmdTime month (Just year)) = do
 34  (YearMonth _ my) <- parseMonth month
 35  pure (firstDayInMY (read year) my)
 36getTime (LocalTime cd _) (CmdTime month Nothing) = do
 37  (YearMonth _ my) <- parseMonth month
 38  pure (firstDayInMY (fst $ toOrdinalDate cd) my)
 39
 40------------------------------------------------------------------------
 41
 42data Duration = OneMonth | ThreeMonths | TwelveMonths | OneYear
 43
 44data Opts = Opts
 45  { optNoTime :: Bool,
 46    optLogical :: Bool,
 47    optFormat :: String,
 48    optSelect :: Maybe String,
 49    optMonday :: Bool,
 50    optDuration :: Duration,
 51    optTime :: Maybe CmdTime
 52  }
 53
 54durationParser :: OPT.Parser Duration
 55durationParser =
 56  OPT.flag
 57    OneMonth
 58    OneMonth
 59    ( OPT.long "one"
 60        <> OPT.short '1'
 61        <> OPT.help "Display a single month"
 62    )
 63    OPT.<|> OPT.flag'
 64      ThreeMonths
 65      ( OPT.long "three"
 66          <> OPT.short '3'
 67          <> OPT.help "Display next/previous month for current month"
 68      )
 69    OPT.<|> OPT.flag'
 70      TwelveMonths
 71      ( OPT.long "twelve"
 72          <> OPT.short 'Y'
 73          <> OPT.help "Display the next twelve months"
 74      )
 75    OPT.<|> OPT.flag'
 76      OneYear
 77      ( OPT.long "year"
 78          <> OPT.short 'y'
 79          <> OPT.help "Display the entire year"
 80      )
 81
 82timeParser :: OPT.Parser CmdTime
 83timeParser =
 84  CmdTime
 85    <$> OPT.argument OPT.str (OPT.metavar "month")
 86    <*> OPT.optional
 87      (OPT.argument OPT.str (OPT.metavar "year"))
 88
 89optsParser :: OPT.Parser Opts
 90optsParser =
 91  Opts
 92    <$> OPT.switch
 93      ( OPT.long "date-only"
 94          <> OPT.short 'd'
 95          <> OPT.help "Only require date selection, omitting time"
 96      )
 97    <*> OPT.switch
 98      ( OPT.long "logical-move"
 99          <> OPT.short 'l'
100          <> OPT.help "Always move cursor logically by week/date"
101      )
102    <*> OPT.strOption
103      ( OPT.long "format"
104          <> OPT.short 'f'
105          -- RFC 1123 format as per Go's time package
106          <> OPT.value "%a, %d %b %Y %T %Z"
107          <> OPT.metavar "FORMAT"
108          <> OPT.help "Format in which the date should be output"
109      )
110    <*> OPT.optional
111      ( OPT.strOption $
112          OPT.long "select"
113            <> OPT.short 's'
114            <> OPT.metavar "TIME"
115            <> OPT.help "Preselect date/time, in the -f format"
116      )
117    <*> OPT.switch
118      ( OPT.long "monday"
119          <> OPT.short 'm'
120          <> OPT.help "Treat monday as the first day of the week"
121      )
122    <*> durationParser
123    <*> OPT.optional timeParser
124
125------------------------------------------------------------------------
126
127optsPeriod :: Duration -> Cal.Day -> [Month]
128optsPeriod OneMonth day = [Cal.dayPeriod day]
129optsPeriod ThreeMonths day =
130  let month = Cal.dayPeriod day
131   in [addMonths (-1) month, month, addMonths 1 month]
132optsPeriod TwelveMonths day =
133  let month = Cal.dayPeriod day
134   in map (`addMonths` month) [0 .. 11]
135optsPeriod OneYear day = periodAllMonths (fst $ toOrdinalDate day)
136
137cmdOpts :: OPT.ParserInfo Opts
138cmdOpts =
139  OPT.info
140    (optsParser OPT.<**> OPT.helper)
141    ( OPT.fullDesc
142        <> OPT.progDesc "Interactively select a date to be printed to stdout"
143        <> OPT.header "datepicker - a utility for interactive date selection"
144    )
145
146getCmdArgs :: IO Opts
147getCmdArgs = OPT.execParser cmdOpts