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:
William Carroll 2020-08-13 22:05:39 +01:00
parent 5fd79ce0ff
commit 3fdfa14355
4 changed files with 130 additions and 20 deletions

View file

@ -1,3 +1,4 @@
:set prompt "> "
:set -Wall
:set -XOverloadedStrings
:set -XRecordWildCards

View file

@ -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

View file

@ -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
})

View file

@ -4,5 +4,6 @@ in briefcase.buildHaskell.shell {
deps = hpkgs: with hpkgs; [
hspec
rio
string-conversions
];
}