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

ics tweaks

parent 4304191b
......@@ -30,6 +30,7 @@ import Data.Maybe (catMaybes)
import qualified Data.Set as Set
import Data.String (IsString)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as LT
import Data.Time.Calendar (Day (..), fromGregorian, toGregorian)
import Data.Time.Calendar.OrdinalDate (mondayStartWeek)
import Data.Time.Clock (UTCTime (..))
......@@ -54,9 +55,11 @@ instance Key ScheduleKey where
data Schedule
= Schedule
{ schTitle :: Text,
{ schCourse :: LazyText,
schTitle :: Text,
schStart :: TimeOfDay,
schDays :: Text,
schLocation :: LazyText,
schMeetings :: [Meeting]
}
deriving (Show, Generic)
......@@ -76,11 +79,11 @@ instance FromJSON Schedule where
data Meeting
= Meeting
{ meetUnit :: Maybe Text,
meetTopic :: Maybe Text,
meetRead :: Maybe Text,
meetExam :: Maybe Text,
meetDue :: Maybe Text
{ meetUnit :: Maybe LazyText,
meetTopic :: Maybe LazyText,
meetRead :: Maybe LazyText,
meetExam :: Maybe LazyText,
meetDue :: Maybe LazyText
}
deriving (Show, Generic)
......@@ -93,34 +96,34 @@ numberUnits i (m : ms) =
Just u ->
m {meetUnit = Just ("Unit " <> show i <> ": " <> u)} : numberUnits (i + 1) ms
numberThingsDue :: Map Text Int -> [Meeting] -> [Meeting]
numberThingsDue :: Map LazyText Int -> [Meeting] -> [Meeting]
numberThingsDue _ [] = []
numberThingsDue nums (m : ms) =
case meetDue m of
Nothing ->
m : numberThingsDue nums ms
Just kind ->
m {meetDue = Just (Text.toTitle kind <> " " <> show i <> " due")}
m {meetDue = Just (LT.toTitle kind <> " " <> show i <> " due")}
: numberThingsDue new ms
where
i = fromMaybe 1 $ Map.lookup kind nums
new = Map.insert kind (i + 1) nums
icalTitleDescr :: Text -> Int -> Meeting -> (Text, Text)
icalTitleDescr course i Meeting {..} =
( course <> " Meeting " <> show i <> parens (dotSep [meetExam, meetDue]),
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 = Text.intercalate ". " . catMaybes
dotSep = LT.intercalate ". " . catMaybes
parens "" = ""
parens s = " (" <> s <> ")"
data TextFmt
= TextFmt
{ textit, textbf :: Text -> Text,
beginDescr, endDescr :: Text,
descrItem :: Text -> Text -> Text
{ textit, textbf :: LazyText -> LazyText,
beginDescr, endDescr :: LazyText,
descrItem :: LazyText -> LazyText -> LazyText
}
laTeX :: TextFmt
......@@ -143,12 +146,12 @@ orgMode =
descrItem = \k v -> "- " <> k <> " :: " <> stripNL v
}
stripNL :: Text -> Text
stripNL = Text.replace "\n" " "
stripNL :: LazyText -> LazyText
stripNL = LT.replace "\n" " "
meetingTex :: TextFmt -> Meeting -> Text
meetingTex :: TextFmt -> Meeting -> LazyText
meetingTex fmt Meeting {..} =
convertString . Text.intercalate ". " $
LT.intercalate ". " $
catMaybes
[ textit fmt <$> meetUnit,
textbf fmt <$> meetExam,
......@@ -222,15 +225,15 @@ classDuration =
classTZ :: IsString s => s
classTZ = "America/New_York"
mkClassMeeting :: UTCTime -> DateTime -> (Text, Text) -> VEvent
mkClassMeeting now start (title, descr) =
mkClassMeeting :: UTCTime -> Schedule -> DateTime -> (LazyText, LazyText) -> VEvent
mkClassMeeting now sch start (title, descr) =
def
{ veDTStamp = DTStamp now def,
veUID = UID ("cs101-mtg-" <> show (localDay (dateTimeFloating start))) def,
veLocation = Just (Location "Pratt 610" def def def),
veUID = UID (schCourse sch <> "-mtg-" <> show (localDay (dateTimeFloating start))) def,
veLocation = Just (Location (schLocation sch) def def def),
veDTStart = Just (DTStartDateTime start def),
veSummary = Just (Summary (convertString title) def def def),
veDescription = Just (Description (convertString descr) def def def),
veSummary = Just (Summary title def def def),
veDescription = Just (Description descr def def def),
veDTEndDuration = Just (Right classDuration)
}
......@@ -253,16 +256,16 @@ flattenDateKey (KeyInterval d1 d2) = Set.fromList [d1 .. d2]
dateKeyFromDT :: DateTime -> DateKey
dateKeyFromDT = KeyDay . localDay . dateTimeFloating
keyToTex :: DateKey -> Text
keyToTex :: DateKey -> String
keyToTex (KeyDay d) =
convertString $ formatTime defaultTimeLocale "%a %b %e" d
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
formatTime defaultTimeLocale "%b %e–" d1 <> show x2
where
(_, _, x2) = toGregorian d2
holidaysS20 :: Map DateKey Text
holidaysS20 :: Map DateKey LazyText
holidaysS20 =
Map.fromList
[ ( KeyDay (fromGregorian 2020 2 17),
......@@ -275,7 +278,7 @@ holidaysS20 =
where
noClass s = "No class — " <> s
finalsWeek :: Map DateKey Text
finalsWeek :: Map DateKey LazyText
finalsWeek =
Map.fromList
[ (KeyInterval (fromGregorian 2020 5 6) (fromGregorian 2020 5 12), "Finals Week")
......@@ -309,8 +312,8 @@ getScheduleR file = do
sched <- runRo (loadMaybeY (ScheduleKey tag)) >>= maybeReturn notFound
now <- getCurrentTime
let meets = numberUnits 1 $ numberThingsDue mempty $ schMeetings sched
blurbs = zipWith (icalTitleDescr tag) [1 ..] meets
evts = zipWith (mkClassMeeting now) (scheduledDays sched) blurbs
blurbs = zipWith (icalTitleDescr sched) [1 ..] meets
evts = zipWith (mkClassMeeting now sched) (scheduledDays sched) blurbs
calName = Text.toUpper tag <> " Spring 2020"
props =
Set.fromList
......@@ -336,5 +339,5 @@ texSchedule tag fmt = do
entryMap = Map.unions [meetMap, textbf fmt <$> holidaysS20, finalsWeek]
putStrLn $ beginDescr fmt
forM_ (Map.toList entryMap) \(key, txt) ->
putStrLn $ descrItem fmt (keyToTex key) txt
putStrLn $ descrItem fmt (convertString (keyToTex key)) txt
putStrLn $ endDescr fmt
......@@ -5,7 +5,6 @@
import App.Prelude
import App.Schedule
import Data.String.Conversions
import System.Environment
import System.Exit
......
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