module Main where

import Data.Maybe
import Data.Function (on)
import Text.ParserCombinators.ReadP hiding ((+++))

import Text.Html
import Network.HTTP
import Network.URI

type Slot = Maybe String

data Line = Junk
          | Dates Int Int -- Month, Day
          | Time Int Slot Slot Slot Slot Slot Slot Slot
            deriving (Read, Show)

isJunk Junk = True
isJunk _ = False

isDate (Dates _ _) = True
isDate _ = False

isTime (Time _ _ _ _ _ _ _ _) = True
isTime _ = False

isBlankTime (Time _ Nothing Nothing Nothing Nothing Nothing Nothing Nothing) = True
isBlankTime _ = False

slot :: ReadP Slot
slot = do
  separator
  sixChars <- count 6 get
  return $ case filter (/=' ') sixChars of
             "" -> Nothing
             keyholder -> Just keyholder

separator :: ReadP ()
separator = string "  " >> return ()

line :: ReadP Line
line = dateLine <++ timeLine <++ junk

junk = return Junk

dateLine = do
  dates <- count 7 (skipSpaces >> date)
  return $ head dates
    where 
      date = do
        month <- integer
        char '/'
        day <- integer
        return $ Dates month day

timeLine = do
  header <- time
  hours <- count 7 slot
  let [sun,mon,tue,wed,thu,fri,sat] = hours
  return $ Time header sun mon tue wed thu fri sat

time :: ReadP Int
time = do
  skipSpaces
  start <- timeSpec
  string " - "
  end <- timeSpec
  return start

timeSpec :: ReadP Int
timeSpec = noon <++ midnight <++ withAMPM <++ integer
  where
    noon = string "Noon" >> return 12
    midnight = string "Mid" >> return 0
    withAMPM = do
      n <- integer
      string " AM" <++ string " PM"
      return n

integer :: ReadP Int
integer = do
  chars <- munch1 (\c -> c `elem` "0123456789")
  return $ read chars

url = fromJust $ parseURI "http://web.mit.edu/mitsfs/www/schedule.txt"

getURL :: URI -> IO String
getURL uri = do
  Right response <- simpleHTTP request
  case rspCode response of
    (2,0,0) -> return $ rspBody response
    err -> fail $ "Error " ++ show err ++ " " ++ rspReason response
  where
    request = Request {rqURI = uri,
                       rqMethod = GET,
                       rqHeaders = [],
                       rqBody = ""}

parseLine = fst . head . readP_to_S line . extendWithSpace
  where
    extendWithSpace x = take 80 $ x ++ repeat ' '

schedule r =
  tail . reverse . snd . foldl collect ([],[]) . map parseLine $ lines r

collect (accum,result) j | isJunk j = (accum,result)
collect (accum,result) d | isDate d = ([d], (reverse accum):result)
collect (accum,result) t | isTime t = (t:accum, result)

pageHeader = header $ (thetitle . toHtml $ "MITSFS Schedule") 
                +++ (meta ! [name "viewport",
                             content "initial-scale = 1.0, user-scalable = no"])

htmlify :: [[Line]] -> Html
htmlify weeks = pageHeader +++ (body $ foldr1 (+++) $ map htmlifyWeek weeks)

htmlifyWeek :: [Line] -> Html
htmlifyWeek (d:ts) = table $ htmlifyDate d +++ (toHtml $ weekheader </> (aboves . map htmlifyTime $ dropBlanks ts))

weekheader = besides $ map (th . toHtml) 
               [" ", "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"]

dropBlanks = takeWhile (not . isBlankTime) . dropWhile isBlankTime

htmlifyDate :: Line -> Html
htmlifyDate (Dates m d) = caption . toHtml $ "Week of " ++ show m ++ "/" ++ show d

htmlifyTime :: Line -> HtmlTable
htmlifyTime (Time hour sun mon tue wed thu fri sat) =
          besides $ (th . toHtml $ show hour):map td  [htmlifySlot sun,
                                                  htmlifySlot mon,
                                                  htmlifySlot tue,
                                                  htmlifySlot wed,
                                                  htmlifySlot thu,
                                                  htmlifySlot fri,
                                                  htmlifySlot sat]                   

htmlifySlot :: Maybe String -> Html
htmlifySlot Nothing = noHtml
htmlifySlot (Just keyholder) = toHtml keyholder

main :: IO ()
main = do
  -- r <- getURL url
  r <- readFile "schedule.txt"
  putStr $ renderHtml $ htmlify $ schedule r