AddTimeInterval.hs

module Main where

import Control.Monad (when)
import Data.Char (toLower)
import System.Environment (getArgs)
import Text.Read (readMaybe)

data Day
  = Sunday
  | Monday
  | Tuesday
  | Wednesday
  | Thursday
  | Friday
  | Saturday
  deriving (Eq, Show, Enum)

parseDay :: String -> Either String Day
parseDay str =
  case map toLower str of
    "sunday" -> Right Sunday
    "monday" -> Right Monday
    "tuesday" -> Right Tuesday
    "wednesday" -> Right Wednesday
    "thursday" -> Right Thursday
    "friday" -> Right Friday
    "saturday" -> Right Saturday
    _ -> Left $ "Invalid day: " ++ str

addDays :: Int -> Day -> Day
addDays n d = toEnum $ mod (fromEnum d + n) 7

data Time = Time
  { timeHours :: Int
  , timeMinutes :: Int
  , timeDay :: Maybe Day
  }
  deriving (Eq, Show)

data TimeInterval = TimeInterval
  { timeIntervalHours :: Int
  , timeIntervalMinutes :: Int
  }
  deriving (Show)

parsePositiveInt :: [Char] -> String -> Either [Char] Int
parsePositiveInt name str =
  case readMaybe str of
    Nothing -> Left $ name ++ " is not a number: " ++ str
    Just i
      | i < 0 -> Left $ name ++ " contains a negative number: " ++ str
      | otherwise -> Right i

parseTimePair :: String -> Either String (Int, Int)
parseTimePair str =
  case span (/= ':') str of
    (hStr, ':' : mStr) -> do
      h <- parsePositiveInt "Hours" hStr
      m <- parsePositiveInt "Minutes" mStr
      when (m >= 60) $ Left $ "Expected 60 minute format, but got: " ++ mStr
      Right (h, m)
    _ -> Left $ "Invalid time format: " ++ str

parseTimeSep :: String -> String -> Maybe String -> Either String Time
parseTimeSep strHM ampm mStrDay = do
  (h, m) <- parseTimePair strHM
  h24 <- case map toLower ampm of
    "pm" -> Right $ mod h 12 + 12
    "am" -> Right $ mod h 12
    _ -> Left $ "Expected 'AM' or 'PM', but got: " ++ ampm
  mDay <- mapM parseDay mStrDay
  pure (Time h24 m mDay)

parseTime :: String -> Either String Time
parseTime str =
  case words str of
    [hm, ampm] -> parseTimeSep hm ampm Nothing
    [hm, ampm, d] -> parseTimeSep hm ampm (Just d)
    _ -> Left $ "Invalid time format: " ++ str

parseTimeInterval :: String -> Either String TimeInterval
parseTimeInterval strTimeInterval = do
  (h, m) <- parseTimePair strTimeInterval
  pure (TimeInterval h m)

addTimeInterval :: Time -> TimeInterval -> (Time, Int)
addTimeInterval t ti = (newTime, extraDays)
  where
    (extraHour, newMinutes) = divMod (timeMinutes t + timeIntervalMinutes ti) 60
    (extraDays, newHours) = divMod (extraHour + timeHours t + timeIntervalHours ti) 24
    newTime =
      Time
        { timeHours = newHours
        , timeMinutes = newMinutes
        , timeDay = addDays extraDays <$> timeDay t
        }

formatTime :: Time -> String
formatTime t = show h ++ ":" ++ m ++ " " ++ ampm ++ d
  where
    m
      | timeMinutes t >= 10 = show (timeMinutes t)
      | otherwise = '0' : show (timeMinutes t)
    d = maybe "" (\x -> " " ++ show x) (timeDay t)
    (h, ampm)
      | timeHours t == 0 = (12, "am")
      | timeHours t == 12 = (12, "pm")
      | timeHours t < 12 = (timeHours t, "am")
      | otherwise = (timeHours t - 12, "pm")

main :: IO ()
main = do
  args <- getArgs
  case args of
    [tStr, iStr] ->
      either error print $ do
        t <- parseTime tStr
        i <- parseTimeInterval iStr
        let (newTime, extraDays) = addTimeInterval t i
            extraDaysStr
              | extraDays == 0 = ""
              | extraDays == 1 = " (next day)"
              | otherwise = " (" ++ show extraDays ++ " days)"
        pure $ formatTime newTime ++ extraDaysStr
    _ -> error $ "Unexpected arguments: " ++ show args

testParser :: IO ()
testParser =
  mapM_
    testTimeParse
    [Time h m d | h <- [0 .. 23], m <- [0 .. 59], d <- Nothing : fmap Just [Sunday .. Saturday]]
  where
    testTimeParse t =
      case parseTime (formatTime t) of
        Left err -> putStrLn $ "Parsing of " ++ show t ++ " failed with: " ++ err
        Right t' ->
          if t == t'
            then pure ()
            else
              putStrLn $ "Formatted time: " ++ show t ++ " does not parse to the same time " ++ show t'