diff options
author | William Carroll <wpcarro@gmail.com> | 2020-08-13T21·22+0100 |
---|---|---|
committer | William Carroll <wpcarro@gmail.com> | 2020-08-20T10·26+0100 |
commit | f895cb417a7a397e9ddac7d2be7683e57e3cb1fb (patch) | |
tree | 7b1b5e6f68174bb86d6192e04348c92550ad334d /website | |
parent | 3fdfa14355088af602877153b49a85a5941fe879 (diff) |
Move shift-time into top-level //zoo
I'm still unsure whether or not this is a good idea, but experimenting is a good way to find out!
Diffstat (limited to 'website')
-rw-r--r-- | website/sandbox/shift-time/.ghci | 4 | ||||
-rw-r--r-- | website/sandbox/shift-time/Main.hs | 140 | ||||
-rw-r--r-- | website/sandbox/shift-time/Spec.hs | 54 | ||||
-rw-r--r-- | website/sandbox/shift-time/default.nix | 28 | ||||
-rw-r--r-- | website/sandbox/shift-time/shell.nix | 9 |
5 files changed, 0 insertions, 235 deletions
diff --git a/website/sandbox/shift-time/.ghci b/website/sandbox/shift-time/.ghci deleted file mode 100644 index 19a1e8f5ec3f..000000000000 --- a/website/sandbox/shift-time/.ghci +++ /dev/null @@ -1,4 +0,0 @@ -:set prompt "> " -:set -Wall -:set -XOverloadedStrings -:set -XRecordWildCards 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 diff --git a/website/sandbox/shift-time/Spec.hs b/website/sandbox/shift-time/Spec.hs deleted file mode 100644 index ba3f71d7c754..000000000000 --- a/website/sandbox/shift-time/Spec.hs +++ /dev/null @@ -1,54 +0,0 @@ --------------------------------------------------------------------------------- -module Spec where --------------------------------------------------------------------------------- -import RIO -import Test.Hspec -import Test.QuickCheck -import Main hiding (main) - -import qualified RIO.Text as Text --------------------------------------------------------------------------------- - -main :: IO () -main = hspec $ do - describe "Main" $ 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/default.nix b/website/sandbox/shift-time/default.nix deleted file mode 100644 index 356c250c7134..000000000000 --- a/website/sandbox/shift-time/default.nix +++ /dev/null @@ -1,28 +0,0 @@ -let - briefcase = import /home/wpcarro/briefcase {}; -in briefcase.buildHaskell.program { - name = "shift-time"; - srcs = builtins.path { - path = ./.; - name = "shift-time-src"; - }; - ghcExtensions = [ - "OverloadedStrings" - "NoImplicitPrelude" - "RecordWildCards" - "TypeApplications" - ]; - deps = hpkgs: with hpkgs; [ - servant-server - aeson - wai-cors - warp - jwt - unordered-containers - base64 - http-conduit - rio - envy - req - ]; -} diff --git a/website/sandbox/shift-time/shell.nix b/website/sandbox/shift-time/shell.nix deleted file mode 100644 index dab0be4ba267..000000000000 --- a/website/sandbox/shift-time/shell.nix +++ /dev/null @@ -1,9 +0,0 @@ -let - briefcase = import /home/wpcarro/briefcase {}; -in briefcase.buildHaskell.shell { - deps = hpkgs: with hpkgs; [ - hspec - rio - string-conversions - ]; -} |