1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
|
{-# LANGUAGE DeriveAnyClass #-}
--------------------------------------------------------------------------------
module Main where
--------------------------------------------------------------------------------
import RIO
import RIO.Text
import RIO.Time
import Data.String.Conversions (cs)
import Data.Time.Clock.POSIX
import Prelude (putStrLn, putStr, print, getLine, read)
import Text.ParserCombinators.ReadP
--------------------------------------------------------------------------------
data ShiftTimeRequest = ShiftTimeRequest
{ shiftSeconds :: Int
, shiftMinutes :: Int
, shiftHours :: Int
, shiftDays :: Int
, shiftWeeks :: Int
, shiftMonths :: Int
, shiftQuarters :: Int
, shiftYears :: Int
} deriving (Eq, Show)
instance Semigroup ShiftTimeRequest where
(ShiftTimeRequest as am ah ad aw amonths aq ay) <> (ShiftTimeRequest bs bm bh bd bw bmonths bq by) =
ShiftTimeRequest
{ shiftSeconds = as + bs
, shiftMinutes = am + bm
, shiftHours = ah + bh
, shiftDays = ad + bd
, shiftWeeks = aw + bw
, shiftMonths = amonths + bmonths
, shiftQuarters = aq + bq
, shiftYears = ay + by
}
instance Monoid ShiftTimeRequest where
mempty = defaultShiftTimeRequest
defaultShiftTimeRequest :: ShiftTimeRequest
defaultShiftTimeRequest = ShiftTimeRequest
{ shiftSeconds = 0
, shiftMinutes = 0
, shiftHours = 0
, shiftDays = 0
, shiftWeeks = 0
, shiftMonths = 0
, shiftQuarters = 0
, shiftYears = 0
}
-- This basically broken because it doesn't account for:
-- Exhales... time stuff
-- - Leap seconds, leap days, leap years...
-- - Months like February having 28 days and others having 31
-- - other things that I'm probably not considering
toSeconds :: ShiftTimeRequest -> NominalDiffTime
toSeconds ShiftTimeRequest{..} = do
let minutes = 60
hours = minutes * 60
days = hours * 24
weeks = days * 7
months = weeks * 4
quarters = months * 3
years = days * 365
fromIntegral $ shiftSeconds +
shiftMinutes * minutes +
shiftHours * hours +
shiftDays * days +
shiftWeeks * weeks +
shiftMonths * months +
shiftQuarters * quarters +
shiftYears * years
shiftTime :: ShiftTimeRequest -> IO UTCTime
shiftTime req = do
t <- getPOSIXTime
let t' = t + toSeconds req
pure $ posixSecondsToUTCTime t'
data Unit = Second
| Minute
| Hour
| Day
| Week
| Month
| Quarter
| Year
deriving (Eq, Show)
digit :: ReadP Char
digit =
satisfy (\c -> c >= '0' && c <= '9')
unit :: ReadP Unit
unit = do
c <- get
case c of
's' -> pure Second
'm' -> pure Minute
'h' -> pure Hour
'd' -> pure Day
'w' -> pure Week
'M' -> pure Month
'q' -> pure Quarter
'y' -> pure Year
_ -> fail $ "We don't support this unit: " ++ show c
request :: ReadP ShiftTimeRequest
request = do
negative <- option Nothing $ fmap Just (satisfy (== '-'))
n <- read <$> many1 digit
u <- unit
let amt = if isJust negative then -1 * n else n
case u of
Second -> pure $ defaultShiftTimeRequest { shiftSeconds = amt }
Minute -> pure $ defaultShiftTimeRequest { shiftMinutes = amt }
Hour -> pure $ defaultShiftTimeRequest { shiftHours = amt }
Day -> pure $ defaultShiftTimeRequest { shiftDays = amt }
Week -> pure $ defaultShiftTimeRequest { shiftWeeks = amt }
Month -> pure $ defaultShiftTimeRequest { shiftMonths = amt }
Quarter -> pure $ defaultShiftTimeRequest { shiftQuarters = amt }
Year -> pure $ defaultShiftTimeRequest { shiftYears = amt }
parseInput :: Text -> Maybe ShiftTimeRequest
parseInput x =
case readP_to_S (manyTill request eof) (unpack x) of
[(xs, "")] -> Just $ mconcat xs
_ -> Nothing
main :: IO ()
main = do
putStr "Enter an offset (e.g. -10d-30s): "
x <- getLine
case parseInput (cs x) of
Nothing -> putStrLn "Try again!" >> main
Just req -> do
t <- shiftTime req
putStrLn $ show t
|
