Commit ef90bebe authored by Christopher League's avatar Christopher League
Browse files

Prefix ics events w/CS101

Also TeX usage
parent 82ba1334
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
......@@ -9,6 +10,7 @@
module App.Schedule
( getScheduleR,
texSchedule,
)
where
......@@ -16,16 +18,19 @@ import App.ByteStoreWorkDir
import App.Foundation
import App.Prelude
import App.YamlStore
import Control.Monad.Trans.Resource
import Data.Aeson as Js
import Data.Function (on)
import Data.List (elem, zipWith3)
import qualified Data.Map as Map
import Data.Maybe (catMaybes)
import qualified Data.Set as Set
import Data.String (IsString)
import qualified Data.Text as Text
import Data.Time.Calendar (Day (..), fromGregorian)
import Data.Time.Calendar (Day (..), fromGregorian, toGregorian)
import Data.Time.Calendar.OrdinalDate (mondayStartWeek)
import Data.Time.Clock (UTCTime (..))
import Data.Time.Format
import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..))
import GHC.Generics
import Text.ICalendar
......@@ -45,7 +50,8 @@ data Meeting
= Meeting
{ meetUnit :: Maybe Text,
meetTopic :: Maybe Text,
meetRead :: Maybe Text
meetRead :: Maybe Text,
meetExam :: Maybe Text
}
deriving (Show, Generic)
......@@ -59,18 +65,30 @@ numberUnits i (m : ms) =
m {meetUnit = Just ("Unit " <> show i <> ": " <> u)} : numberUnits (i + 1) ms
meetingTitle :: Int -> LazyText
meetingTitle i = "Meeting " <> show i
meetingTitle i = "CS101 Meeting " <> show i
meetingDescr :: Meeting -> LazyText
meetingDescr Meeting {..} =
convertString . Text.intercalate ". " $
catMaybes [meetUnit, meetTopic, (("Read " <>) <$> meetRead)]
catMaybes
[ meetUnit,
meetExam,
meetTopic,
(("Read " <>) <$> meetRead)
]
-- meetingSummaryDescr index Meeting{..} =
-- ( "Meeting " <> show index,
-- ev &
-- veSummaryL ?~ Summary ("Meeting " <> show index) def def def
meetingTex :: Meeting -> Text
meetingTex Meeting {..} =
convertString . Text.intercalate ". " $
catMaybes
[ emph <$> meetUnit,
bf <$> meetExam,
meetTopic,
meetRead
]
where
emph s = "\\emph{" <> s <> "}"
bf s = "\\textbf{" <> s <> "}"
meetJsonOpts :: Js.Options
meetJsonOpts =
......@@ -165,23 +183,81 @@ eventMap :: Ord a => [VEvent] -> Map (LazyText, Maybe a) VEvent
eventMap =
Map.fromList . map (\e -> ((uidValue (veUID e), Nothing), e))
data DateKey
= KeyDay {keyDay :: Day}
| KeyInterval {keyDay, keyEnd :: Day}
deriving (Eq, Show)
instance Ord DateKey where
compare = compare `on` keyDay
flattenDateKey :: DateKey -> Set Day
flattenDateKey (KeyDay d) = Set.singleton d
flattenDateKey (KeyInterval d1 d2) = Set.fromList [d1 .. d2]
dateKeyFromDT :: DateTime -> DateKey
dateKeyFromDT = KeyDay . localDay . dateTimeFloating
keyToTex :: DateKey -> Text
keyToTex (KeyDay d) =
convertString $ formatTime defaultTimeLocale "%a %b %e" d
keyToTex (KeyInterval d1 d2) =
-- This assumes range doesn't span a month or year!
convertString $ formatTime defaultTimeLocale "%b %e–" d1 <> show x2
where
(_, _, x2) = toGregorian d2
holidaysS20 :: Map DateKey Text
holidaysS20 =
Map.fromList
[ ( KeyDay (fromGregorian 2020 2 17),
noClass "Presidents' Day"
),
( KeyInterval (fromGregorian 2020 3 9) (fromGregorian 2020 3 15),
noClass "Spring Break"
)
]
where
noClass s = "\\textbf{No class — " <> s <> "}"
finalsWeek :: Map DateKey Text
finalsWeek =
Map.fromList
[ (KeyInterval (fromGregorian 2020 5 6) (fromGregorian 2020 5 12), "Finals Week")
]
monWedS20 :: [DateTime]
monWedS20 =
map (\d -> ZonedDateTime (LocalTime d classStart) classTZ) (Set.toList days)
where
sem = Set.fromList [fromGregorian 2020 1 22 .. fromGregorian 2020 5 5]
sprBrk = Set.fromList [fromGregorian 2020 3 9 .. fromGregorian 2020 3 15]
prezDay = Set.singleton (fromGregorian 2020 2 17)
holidays = sprBrk `Set.union` prezDay
holidays = Set.unions $ map flattenDateKey $ Map.keys holidaysS20
isClassDay d =
d == fromGregorian 2020 2 18
|| mondayStartWeek d ^. _2 `elem` [1, 3]
days = Set.filter isClassDay $ sem `Set.difference` holidays
fetchSchedule :: ByteStoreRO m => m [Meeting]
fetchSchedule =
numberUnits 1 <$> loadY ScheduleKey
getScheduleR :: Handler TypedContent
getScheduleR = do
now <- getCurrentTime
descrs <- map meetingDescr . numberUnits 1 <$> runRo (loadY ScheduleKey)
descrs <- map meetingDescr <$> runRo fetchSchedule
let titles = map meetingTitle [1 ..]
evts = zipWith3 (mkClassMeeting now) monWedS20 titles descrs
return $ toTypedContent def {vcEvents = eventMap evts, vcOther = calProps}
texSchedule :: IO ()
texSchedule = do
meetings <- runResourceT $ runStoreRO @WorkDirT @FilePath "data" fetchSchedule
let meetingMap =
Map.fromList $
zip (map dateKeyFromDT monWedS20) (map meetingTex meetings)
entryMap = Map.unions [meetingMap, holidaysS20, finalsWeek]
putStrLn @Text "\\section{Schedule}"
putStrLn @Text "\\begin{description}"
forM_ (Map.toList entryMap) \(key, txt) ->
putStrLn $ "\\item[" <> keyToTex key <> "] " <> txt
putStrLn @Text "\\end{description}"
......@@ -4,6 +4,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
......@@ -47,7 +48,7 @@ import App.YamlStore
import Conduit
import Control.Lens (Lens')
import Control.Lens (makeLenses)
import Crypto.Hash
import "cryptohash" Crypto.Hash
import Data.Aeson as Js
import Data.CaseInsensitive (foldCase)
import Data.Char (isDigit, isLower)
......
import App.Schedule
main :: IO ()
main = texSchedule
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment