diff options
| -rw-r--r-- | website/sandbox/shift-time/.ghci | 1 | ||||
| -rw-r--r-- | website/sandbox/shift-time/Main.hs | 111 | ||||
| -rw-r--r-- | website/sandbox/shift-time/Spec.hs | 37 | ||||
| -rw-r--r-- | website/sandbox/shift-time/shell.nix | 1 |
4 files changed, 130 insertions, 20 deletions
diff --git a/website/sandbox/shift-time/.ghci b/website/sandbox/shift-time/.ghci index d899113e92d2..19a1e8f5ec3f 100644 --- a/website/sandbox/shift-time/.ghci +++ b/website/sandbox/shift-time/.ghci @@ -1,3 +1,4 @@ :set prompt "> " :set -Wall :set -XOverloadedStrings +:set -XRecordWildCards diff --git a/website/sandbox/shift-time/Main.hs b/website/sandbox/shift-time/Main.hs index 80663d797be7..f33ac54a115a 100644 --- a/website/sandbox/shift-time/Main.hs +++ b/website/sandbox/shift-time/Main.hs @@ -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 diff --git a/website/sandbox/shift-time/Spec.hs b/website/sandbox/shift-time/Spec.hs index dcb28248b380..ba3f71d7c754 100644 --- a/website/sandbox/shift-time/Spec.hs +++ b/website/sandbox/shift-time/Spec.hs @@ -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 + }) diff --git a/website/sandbox/shift-time/shell.nix b/website/sandbox/shift-time/shell.nix index fb5021a6b722..dab0be4ba267 100644 --- a/website/sandbox/shift-time/shell.nix +++ b/website/sandbox/shift-time/shell.nix @@ -4,5 +4,6 @@ in briefcase.buildHaskell.shell { deps = hpkgs: with hpkgs; [ hspec rio + string-conversions ]; } |