diff options
Diffstat (limited to 'website/sandbox/shift-time/Main.hs')
-rw-r--r-- | website/sandbox/shift-time/Main.hs | 140 |
1 files changed, 0 insertions, 140 deletions
diff --git a/website/sandbox/shift-time/Main.hs b/website/sandbox/shift-time/Main.hs deleted file mode 100644 index f33ac54a115a..000000000000 --- a/website/sandbox/shift-time/Main.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# 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 |