thu_syllabus2ical.hs

thu_syllabus2ical.hs

{-# LANGUAGE NoMonomorphismRestriction #-}
import Control.Applicative hiding ((<|>), many)
import Control.Monad
import Data.List
import Data.List.Split (splitOn)
import Data.Maybe
import Data.Time.Format
import Data.Time.Calendar
import Data.Time.Calendar.WeekDate
import Data.Time.Clock
import Data.Time.LocalTime
import Text.ParserCombinators.Parsec
import Text.Printf
import System.Environment (getArgs)
import System.Exit (exitFailure)
import System.Locale (defaultTimeLocale)
import System.IO

type CourseTime = (Int, Int, Int)

csv :: CharParser st [[String]]
csv = (record `sepEndBy` newline) <* eof
  where
    record = (quoted <|> many (noneOf ",\"\n")) `sepBy` char ','
    quoted = between (char '"') (char '"') . many $ noneOf "\"" <|> try ('"' <$ string "\"\"")

hmHm :: CharParser st (TimeOfDay, TimeOfDay)
hmHm = liftM3 (const . (,)) hm (char '-') hm
  where
    hm = many1 digit >>= \hh -> char ':' >> many1 digit >>= \mm -> return . fromJust $ makeTimeOfDayValid (read hh) (read mm) 0

course s = (name, desc, location, time)
  where
    name = reverse . drop 1 . dropWhile (/='(') . reverse $ s
    desc = reverse . takeWhile (/='(') . drop 1 . reverse $ s
    items = splitOn "；" desc
    time = (listToMaybe . mapMaybe (stripPrefix "时间") $ items) >>= either (const Nothing) Just . parse hmHm ""
    location = fromMaybe "unknown" . find isLocation $ reverse items
    isLocation s = any (`isInfixOf` s) ["楼", "阶", "教", "中心", "馆", "院", "厅", "房", "堂", "基地", "操场"]

timeIntervals :: [(TimeOfDay, TimeOfDay)]
timeIntervals = map (\((a,b),(c,d)) -> (f a b, f c d))
    [((8,  00), (9,  35))
    ,((9,  50), (12, 15))
    ,((13, 30), (15, 05))
    ,((15, 20), (16, 55))
    ,((17, 10), (18, 45))
    ,((19, 20), (21, 45))
    ]
  where
    f h m = fromJust $ makeTimeOfDayValid h m 0

schedule s
  | Right ws <- parse (char '第' *> ((read <$> many1 digit) `sepBy` char ',') <* char '周') "" s = [(w-1,1,1) | w <- ws]
  | Just t <- lookup s rules = [t]
  | otherwise = []
  where
    rules = [("全周", (0, 1, 16))
            ,("前八周", (0, 1, 8))
            ,("后八周", (8, 1, 8))
            ,("单周", (0, 2, 8))
            ,("双周", (1, 2, 8))]

pprint :: Day -> TimeOfDay -> TimeOfDay -> String -> String -> String -> CourseTime -> IO ()
pprint day timeStart timeEnd name desc location (start,interval,count) = do
    let f = formatTime defaultTimeLocale
    putStrLn "BEGIN:VEVENT"
    current <- formatTime defaultTimeLocale "%Y%m%dT%H%M%S" <$> getCurrentTime

    printf "CREATED;TZID=UTC:%s\n" current
    printf "DTSTAMP;TZID=UTC:%s\n" current
    printf "LAST-MODIFIED;TZID=UTC:%s\n" current

    printf "DESCRIPTION:%s(%s)\n" name desc
    printf "LOCATION:%s\n" location
    printf "DTSTART;TZID=Asia/Shanghai:%sT%s\n" (f "%Y%m%d" day) (f "%H%M%S" timeStart)
    printf "DTEND;TZID=Asia/Shanghai:%sT%s\n" (f "%Y%m%d" day) (f "%H%M%S" timeEnd)
    printf "RRULE:FREQ=WEEKLY;COUNT=%d;INTERVAL=%d\n" interval count
    putStrLn "TRANSP:opaque"
    printf "SUMMARY:%s\n" name
    printf "UID:%s-%s@ray-thu-syllabus.hs\n" name (show day++"T"++show timeStart)
    putStrLn "END:VEVENT"

process openDay table = do
    putStrLn "BEGIN:VCALENDAR"
    putStrLn "PRODID:-//thu syllabus to iCal//by sfr"
    putStrLn "VERSION:2.0"
    sequence_ [ pprint (addDays (fromIntegral $ col-1+week*7) openDay) start end name desc location t
        | col <- [1..7], row <- [2..7]
        , let (name, desc, location, time) = course $ table!!row!!col
        , let (start, end) = fromMaybe (timeIntervals!!(row-2)) time
        , not $ null name
        , t@(week,_,_) <- concatMap schedule $ splitOn "；" desc
        ]
    putStrLn "END:VCALENDAR"

main :: IO ()
main = do
    args <- getArgs
    when (length args /= 3) $ hPutStrLn stderr "usage: thu_syllabus2ical YYYY MM DD\nYYYYMMDD is the first Monday after school opens" >> exitFailure
    case fromGregorianValid (read $ head args) (read $ args!!1) (read $ args!!2) of
        Nothing -> hPutStrLn stderr "invalid date"
        Just day -> let (_,_,w) = toWeekDate day in
            case w of
                1 -> do
                    con <- getContents
                    case parse csv "" con of
                        Left err -> print err
                        Right c -> process day c
                _ -> hPutStrLn stderr "open day must be Monday" >> exitFailure