1 files changed, 91 insertions, 20 deletions

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