Support parsing and shifting time
TL;DR: - Adds string-conversions library - Adds tests for remaining units and repeating requests - Adds a REPL in main
This commit is contained in:
parent
5fd79ce0ff
commit
3fdfa14355
4 changed files with 130 additions and 20 deletions
|
@ -1,3 +1,4 @@
|
|||
:set prompt "> "
|
||||
:set -Wall
|
||||
:set -XOverloadedStrings
|
||||
:set -XRecordWildCards
|
||||
|
|
|
@ -1,18 +1,16 @@
|
|||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
--------------------------------------------------------------------------------
|
||||
module Main where
|
||||
--------------------------------------------------------------------------------
|
||||
import RIO
|
||||
import RIO.Text
|
||||
import Prelude (putStrLn, read)
|
||||
import RIO.Time
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Time.Clock.POSIX
|
||||
import Prelude (putStrLn, putStr, print, getLine, read)
|
||||
import Text.ParserCombinators.ReadP
|
||||
|
||||
import qualified Data.Time.Clock as Clock
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- type Api = "run"
|
||||
-- :> ReqBody '[JSON] Request
|
||||
-- :> Post '[JSON] Response
|
||||
|
||||
data ShiftTimeRequest = ShiftTimeRequest
|
||||
{ shiftSeconds :: Int
|
||||
, shiftMinutes :: Int
|
||||
|
@ -24,6 +22,22 @@ data ShiftTimeRequest = ShiftTimeRequest
|
|||
, 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
|
||||
|
@ -36,10 +50,44 @@ defaultShiftTimeRequest = ShiftTimeRequest
|
|||
, shiftYears = 0
|
||||
}
|
||||
|
||||
-- shiftTime :: Maybe Request -> IO Clock.UTCTime
|
||||
-- shiftTime = Clock.getCurrentTime
|
||||
-- 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 =
|
||||
|
@ -47,23 +95,46 @@ digit =
|
|||
|
||||
unit :: ReadP Unit
|
||||
unit = do
|
||||
_ <- char 's'
|
||||
pure Second
|
||||
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
|
||||
_ <- unit
|
||||
case negative of
|
||||
Nothing -> pure $ defaultShiftTimeRequest { shiftSeconds = n }
|
||||
Just _ -> pure $ defaultShiftTimeRequest { shiftSeconds = -1 * n }
|
||||
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 }
|
||||
|
||||
parseTime :: Text -> Maybe ShiftTimeRequest
|
||||
parseTime x =
|
||||
case readP_to_S request (unpack x) of
|
||||
[(res, "")] -> Just res
|
||||
parseInput :: Text -> Maybe ShiftTimeRequest
|
||||
parseInput x =
|
||||
case readP_to_S (manyTill request eof) (unpack x) of
|
||||
[(xs, "")] -> Just $ mconcat xs
|
||||
_ -> Nothing
|
||||
|
||||
main :: IO ()
|
||||
main = putStrLn "Working!"
|
||||
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
|
||||
|
|
|
@ -15,3 +15,40 @@ main = hspec $ do
|
|||
it "handles seconds" $ do
|
||||
property $ \x -> parseTime (Text.concat [x & show & Text.pack, "s"]) ==
|
||||
(Just defaultShiftTimeRequest { shiftSeconds = x })
|
||||
|
||||
it "handles minutes" $ do
|
||||
property $ \x -> parseTime (Text.concat [x & show & Text.pack, "m"]) ==
|
||||
(Just defaultShiftTimeRequest { shiftMinutes = x })
|
||||
|
||||
it "handles hours" $ do
|
||||
property $ \x -> parseTime (Text.concat [x & show & Text.pack, "h"]) ==
|
||||
(Just defaultShiftTimeRequest { shiftHours = x })
|
||||
|
||||
it "handles days" $ do
|
||||
property $ \x -> parseTime (Text.concat [x & show & Text.pack, "d"]) ==
|
||||
(Just defaultShiftTimeRequest { shiftDays = x })
|
||||
|
||||
it "handles weeks" $ do
|
||||
property $ \x -> parseTime (Text.concat [x & show & Text.pack, "w"]) ==
|
||||
(Just defaultShiftTimeRequest { shiftWeeks = x })
|
||||
|
||||
it "handles months" $ do
|
||||
property $ \x -> parseTime (Text.concat [x & show & Text.pack, "M"]) ==
|
||||
(Just defaultShiftTimeRequest { shiftMonths = x })
|
||||
|
||||
it "handles quarters" $ do
|
||||
property $ \x -> parseTime (Text.concat [x & show & Text.pack, "q"]) ==
|
||||
(Just defaultShiftTimeRequest { shiftQuarters = x })
|
||||
|
||||
it "handles multiple shifts" $ do
|
||||
parseTime "1s-20m5h0d-4w100M-3y2q" ==
|
||||
(Just $ ShiftTimeRequest
|
||||
{ shiftSeconds = 1
|
||||
, shiftMinutes = -20
|
||||
, shiftHours = 5
|
||||
, shiftDays = 0
|
||||
, shiftWeeks = -4
|
||||
, shiftMonths = 100
|
||||
, shiftQuarters = 2
|
||||
, shiftYears = -3
|
||||
})
|
||||
|
|
|
@ -4,5 +4,6 @@ in briefcase.buildHaskell.shell {
|
|||
deps = hpkgs: with hpkgs; [
|
||||
hspec
|
||||
rio
|
||||
string-conversions
|
||||
];
|
||||
}
|
||||
|
|
Loading…
Reference in a new issue