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

Some adaptations for blended cs697

parent e1f30435
......@@ -24,7 +24,8 @@ import App.YamlStore
import Control.Monad.Trans.Resource
import Data.Aeson as Js
import Data.Function (on)
import Data.List (elem, zipWith)
import Data.List (elem, any, zipWith)
import Control.Monad (mzero)
import qualified Data.Map as Map
import Data.Maybe (catMaybes)
import qualified Data.Set as Set
......@@ -58,6 +59,7 @@ data Schedule
{ schCourse :: LazyText,
schTitle :: Text,
schStart :: TimeOfDay,
schDuration :: TimeOfDay,
schDays :: Text,
schLocation :: LazyText,
schMeetings :: [Meeting]
......@@ -77,16 +79,43 @@ instance ToJSON Schedule where
instance FromJSON Schedule where
parseJSON = genericParseJSON schJsonOpts
data MeetFormat
= Meet_f2f
| Meet_online
| Meet_async
deriving (Eq, Show, Read)
notF2F :: MeetFormat -> Bool
notF2F Meet_f2f = False
notF2F _ = True
isBlended :: Schedule -> Bool
isBlended = any notF2F . map meetFormatDef . schMeetings
instance Default MeetFormat where
def = Meet_f2f
instance ToJSON MeetFormat where
toJSON = String . Text.drop 5 . show
instance FromJSON MeetFormat where
parseJSON (String s) = maybeReturn mzero $ readMaybe ("Meet_" <> s)
parseJSON _ = mzero
data Meeting
= Meeting
{ meetUnit :: Maybe LazyText,
meetTopic :: Maybe LazyText,
meetRead :: Maybe LazyText,
meetExam :: Maybe LazyText,
meetDue :: Maybe LazyText
meetDue :: Maybe LazyText,
meetFormat :: Maybe MeetFormat
}
deriving (Show, Generic)
meetFormatDef :: Meeting -> MeetFormat
meetFormatDef = fromMaybe def . meetFormat
numberUnits :: Int -> [Meeting] -> [Meeting]
numberUnits _ [] = []
numberUnits i (m : ms) =
......@@ -109,16 +138,6 @@ numberThingsDue nums (m : ms) =
i = fromMaybe 1 $ Map.lookup kind nums
new = Map.insert kind (i + 1) nums
icalTitleDescr :: Schedule -> Int -> Meeting -> (LazyText, LazyText)
icalTitleDescr sch i Meeting {..} =
( schCourse sch <> " Meeting " <> show i <> parens (dotSep [meetExam, meetDue]),
dotSep [meetUnit, meetTopic, ("Read " <>) <$> meetRead]
)
where
dotSep = LT.intercalate ". " . catMaybes
parens "" = ""
parens s = " (" <> s <> ")"
data TextFmt
= TextFmt
{ textit, textbf :: LazyText -> LazyText,
......@@ -149,8 +168,8 @@ orgMode =
stripNL :: LazyText -> LazyText
stripNL = LT.replace "\n" " "
meetingTex :: TextFmt -> Meeting -> LazyText
meetingTex fmt Meeting {..} =
meetingTex :: Bool -> TextFmt -> Meeting -> LazyText
meetingTex blend fmt Meeting {..} =
LT.intercalate ". " $
catMaybes
[ textit fmt <$> meetUnit,
......@@ -218,24 +237,46 @@ instance Default VEvent where
veOther = mempty
}
classDuration :: DurationProp
classDuration =
DurationProp (DurationTime def 1 50 0) def
durationFromTime :: TimeOfDay -> DurationProp
durationFromTime TimeOfDay{..} =
DurationProp (DurationTime def todHour todMin 0) def
classTZ :: IsString s => s
classTZ = "America/New_York"
mkClassMeeting :: UTCTime -> Schedule -> DateTime -> (LazyText, LazyText) -> VEvent
mkClassMeeting now sch start (title, descr) =
mkClassMeeting :: UTCTime -> Schedule -> DateTime -> Meeting -> VEvent
mkClassMeeting now sch start m@Meeting{..} =
def
{ veDTStamp = DTStamp now def,
veUID = UID (schCourse sch <> "-mtg-" <> show (localDay (dateTimeFloating start))) def,
veLocation = Just (Location (schLocation sch) def def def),
veDTStart = Just (DTStartDateTime start def),
veUID = UID (schCourse sch <> "-mtg-" <> show day) def,
veLocation =
case meetFormatDef m of
Meet_f2f -> Just (Location (schLocation sch) def def def)
Meet_online -> Just (Location "Online" def def def)
Meet_async -> Nothing,
veDTStart =
case meetFormatDef m of
Meet_async -> Just (DTStartDate (Date day) def)
_ -> Just (DTStartDateTime start def),
veSummary = Just (Summary title def def def),
veDescription = Just (Description descr def def def),
veDTEndDuration = Just (Right classDuration)
veDTEndDuration =
case meetFormatDef m of
Meet_async -> Nothing
_ -> Just (Right (durationFromTime (schDuration sch)))
}
where
day = localDay (dateTimeFloating start)
title = schCourse sch <> meetTitle <> parens (dotSep [meetExam, meetDue])
meetTitle =
case meetFormatDef m of
Meet_f2f -> " Meeting"
Meet_online -> " Online meeting"
Meet_async -> " No meeting"
descr = dotSep [meetUnit, meetTopic, ("Read " <>) <$> meetRead]
dotSep = LT.intercalate ". " . catMaybes
parens "" = ""
parens s = " (" <> s <> ")"
eventMap :: Ord a => [VEvent] -> Map (LazyText, Maybe a) VEvent
eventMap =
......@@ -293,7 +334,7 @@ classDays :: TimeOfDay -> [Int] -> [DateTime]
classDays startTime daysOfWeek =
map (\d -> ZonedDateTime (LocalTime d startTime) classTZ) (Set.toList days)
where
sem = Set.fromList [fromGregorian 2020 1 22 .. fromGregorian 2020 5 5]
sem = Set.fromList [fromGregorian 2020 1 22 .. fromGregorian 2020 5 12]
holidays = Set.unions $ map flattenDateKey $ Map.keys holidaysS20
isClassDay d = weekDayOf d `elem` daysOfWeek
days = Set.filter isClassDay $ sem `Set.difference` holidays
......@@ -303,6 +344,7 @@ scheduledDays sch =
classDays (schStart sch) $
case schDays sch of
"MW" -> [1, 3]
"M" -> [1]
_ -> []
-- Path is, e.g., /ics/cs164.ics
......@@ -312,8 +354,7 @@ getScheduleR file = do
sched <- runRo (loadMaybeY (ScheduleKey tag)) >>= maybeReturn notFound
now <- getCurrentTime
let meets = numberUnits 1 $ numberThingsDue mempty $ schMeetings sched
blurbs = zipWith (icalTitleDescr sched) [1 ..] meets
evts = zipWith (mkClassMeeting now sched) (scheduledDays sched) blurbs
evts = zipWith (mkClassMeeting now sched) (scheduledDays sched) meets
calName = Text.toUpper tag <> " Spring 2020"
props =
Set.fromList
......@@ -335,7 +376,7 @@ texSchedule tag fmt = do
let meets = numberUnits 1 $ numberThingsDue mempty $ schMeetings sched
meetMap =
Map.fromList $
zip (map dateKeyFromDT (scheduledDays sched)) (map (meetingTex fmt) meets)
zip (map dateKeyFromDT (scheduledDays sched)) (map (meetingTex (isBlended sched) fmt) meets)
entryMap = Map.unions [meetMap, textbf fmt <$> holidaysS20, finalsWeek]
putStrLn $ beginDescr fmt
forM_ (Map.toList entryMap) \(key, txt) ->
......
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