Can Santa Save Christmas? - Haskell

import Text.ParserCombinators.ReadP

class (Num a) => Time a where
    toSeconds :: a -> Second
    toDays :: a -> Day
    addTimes :: a -> a -> Second
    addTimes x y = toSeconds x + toSeconds y

data Day = Day Double
    deriving Show

data Hour = Hour Integer
    deriving Show

data Minute = Minute Integer
    deriving Show

data Second = Second Integer
    deriving Show

data CompleteTime = CompleteTime Hour Minute Second
    deriving Show

data AllCompleteTimes = AllCompleteTimes [CompleteTime]

data CanSantaSaveChristmas = CanSantaSaveChristmas AllCompleteTimes

instance Show CanSantaSaveChristmas where
    show (CanSantaSaveChristmas (AllCompleteTimes timeList)) | toDays (foldr (\elem acc -> elem + acc) (CompleteTime (Hour 0) (Minute 0) (Second 0)) timeList) > 1 = "false"
                                                             | otherwise = "true"

instance Num Day where
    (Day x) + (Day y) = Day (x + y)
    (Day x) * (Day y) = Day (x * y)
    abs (Day x) = Day (abs x)
    signum (Day x) = Day (signum x)
    fromInteger x = Day (fromInteger x)
    negate (Day x) = Day (negate x)

instance Eq Day where
    x == y = case (toSeconds x) of
        Second xs -> case (toSeconds y) of
            Second ys -> xs == ys

instance Ord Day where
    x <= y = case (toSeconds x) of
        Second xs -> case (toSeconds y) of
            Second ys -> xs <= ys

instance Num Hour where
    (Hour x) + (Hour y) = Hour (x + y)
    (Hour x) * (Hour y) = Hour (x * y)
    abs (Hour x) = Hour (abs x)
    signum (Hour x) = Hour (signum x)
    fromInteger x = Hour (fromInteger x)
    negate (Hour x) = Hour (negate x)

instance Num Minute where
    (Minute x) + (Minute y) = Minute (x + y)
    (Minute x) * (Minute y) = Minute (x * y)
    abs (Minute x) = Minute (abs x)
    signum (Minute x) = Minute (signum x)
    fromInteger x = Minute (fromInteger x)
    negate (Minute x) = Minute (negate x)

instance Num Second where
    (Second x) + (Second y) = Second (x + y)
    (Second x) * (Second y) = Second (x * y)
    abs (Second x) = Second (abs x)
    signum (Second x) = Second (signum x)
    fromInteger x = Second (fromInteger x)
    negate (Second x) = Second (negate x)

addSeconds :: Second -> Second -> (Maybe Minute, Second)
addSeconds x y = case (x + y) of
    Second t | t < 60 -> (Nothing, Second t)
             | otherwise -> (Just (Minute (t `div` 60)), Second (t `mod` 60))

addMinutes :: Minute -> Minute -> (Maybe Hour, Minute)
addMinutes x y = case (x + y) of
    Minute t | t < 60 -> (Nothing, Minute t)
             | otherwise -> (Just (Hour (t `div` 60)), Minute (t `mod` 60))

instance Num CompleteTime where
    (CompleteTime hrs1 mins1 ss1) + (CompleteTime hrs2 mins2 ss2) = case (addSeconds ss1 ss2) of
        (Nothing, sSum) -> case (addMinutes mins1 mins2) of
            (Nothing, minSum) -> CompleteTime (hrs1 + hrs2) minSum (ss1 + ss2)
            (Just newHours, minSum) -> CompleteTime (hrs1 + hrs2 + newHours) minSum (ss1 + ss2)
        (Just newMins, sSum) -> case (addMinutes mins1 (mins2 + newMins)) of
            (Nothing, minSum) -> CompleteTime (hrs1 + hrs2) minSum sSum
            (Just newHours, minSum) -> CompleteTime (hrs1 + hrs2 + newHours) minSum sSum
-- I CAN'T BE BOTHERED TO IMPLEMENT THE REST OF NUM'S MISSING METHODS FOR COMPLETETIME AAAAAAAA

instance Time Day where
    toSeconds (Day x) = Second . round $ 86400 * x
    toDays x = x

instance Time Hour where
    toSeconds (Hour x) = Second (3600 * x)
    toDays (Hour x) = Day ((fromIntegral x) / 24.0)

instance Time Minute where
    toSeconds (Minute x) = Second (60 * x)
    toDays (Minute x) = Day ((fromIntegral x) / 1440.0)

instance Time Second where
    toSeconds x = x
    toDays (Second x) = Day ((fromIntegral x) / 86400.0)

instance Time CompleteTime where
    toSeconds (CompleteTime hrs mins ss) = toSeconds hrs + toSeconds mins + toSeconds ss
    toDays (CompleteTime hrs mins ss) = toDays hrs + toDays mins + toDays ss

satisfyIsNumber :: Char -> Bool
satisfyIsNumber x = (x >= '0') && (x <= '9')

satisfyLessThanSix :: Char -> Bool
satisfyLessThanSix x = (x >= '0' && x < '6')

parseSeconds :: ReadP Second
parseSeconds = do
    digit1 <- satisfy satisfyLessThanSix
    digit2 <- satisfy satisfyIsNumber
    return . Second . read $ [digit1, digit2]

parseMinutes :: ReadP Minute
parseMinutes = do
    digit1 <- satisfy satisfyLessThanSix
    digit2 <- satisfy satisfyIsNumber
    return . Minute . read $ [digit1, digit2]

parseHours2Digit :: ReadP Hour
parseHours2Digit = do
    digit1 <- satisfy satisfyIsNumber
    digit2 <- satisfy satisfyIsNumber
    return . Hour . read $ [digit1, digit2]

parseHours1Digit :: ReadP Hour
parseHours1Digit = do
    digit1 <- satisfy satisfyIsNumber
    return . Hour . read $ [digit1]

-- want to parse 2 digits if possible, or else 1 digit
parseHours :: ReadP Hour
parseHours = parseHours2Digit <++ parseHours1Digit

parseCompleteTime :: ReadP CompleteTime
parseCompleteTime = do
    hrs <- parseHours
    char ':'
    mins <- parseMinutes
    char ':'
    ss <- parseSeconds
    return (CompleteTime hrs mins ss)

getAllCompleteTimes :: [String] -> AllCompleteTimes
getAllCompleteTimes strs = AllCompleteTimes (map (\completeTime -> fst . head $ (readP_to_S parseCompleteTime completeTime)) strs)

-- pointfree!!!!
can_santa_save_christmas :: [String] -> CanSantaSaveChristmas
can_santa_save_christmas = CanSantaSaveChristmas . getAllCompleteTimes

main :: IO ()
main = do
    putStrLn . show $ can_santa_save_christmas ["01:30:00", "02:15:00", "05:00:00"]
    putStrLn . show $ can_santa_save_christmas ["12:00:00", "10:00:00", "2:00:00"]
    putStrLn . show $ can_santa_save_christmas ["12:00:00", "10:00:00", "2:00:00", "00:10:00"]