Support parsing second shifts

Parse inputs like -10s into 10 second shifts back in time.

1 files changed, 69 insertions, 0 deletions

diff --git a/website/sandbox/shift-time/Main.hs b/website/sandbox/shift-time/Main.hs
new file mode 100644
index 000000000000..80663d797be7
--- /dev/null
+++ b/website/sandbox/shift-time/Main.hs
@@ -0,0 +1,69 @@
+--------------------------------------------------------------------------------
+module Main where
+--------------------------------------------------------------------------------
+import RIO
+import RIO.Text
+import Prelude (putStrLn, 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
+  , shiftHours :: Int
+  , shiftDays :: Int
+  , shiftWeeks :: Int
+  , shiftMonths :: Int
+  , shiftQuarters :: Int
+  , shiftYears :: Int
+  } deriving (Eq, Show)
+
+defaultShiftTimeRequest :: ShiftTimeRequest
+defaultShiftTimeRequest = ShiftTimeRequest
+  { shiftSeconds = 0
+  , shiftMinutes = 0
+  , shiftHours = 0
+  , shiftDays = 0
+  , shiftWeeks = 0
+  , shiftMonths = 0
+  , shiftQuarters = 0
+  , shiftYears = 0
+  }
+
+-- shiftTime :: Maybe Request -> IO Clock.UTCTime
+-- shiftTime = Clock.getCurrentTime
+
+data Unit = Second
+
+digit :: ReadP Char
+digit =
+  satisfy (\c -> c >= '0' && c <= '9')
+
+unit :: ReadP Unit
+unit = do
+  _ <- char 's'
+  pure Second
+
+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 }
+
+parseTime :: Text -> Maybe ShiftTimeRequest
+parseTime x =
+  case readP_to_S request (unpack x) of
+    [(res, "")] -> Just res
+    _ -> Nothing
+
+main :: IO ()
+main = putStrLn "Working!"