initial commitHEAD1.0.0master

2 files changed, 1081 insertions, 0 deletions

diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
index 0000000..24f645c
--- /dev/null
+++ b/app/Main.hs
@@ -0,0 +1,1042 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main (main) where
+
+import Control.Monad (forM, forM_)
+import Data.ByteString qualified as BS
+import Data.ByteString.Char8 qualified as BSC
+import Data.ByteString.Lazy qualified as BL
+import Data.ByteString.Lazy.Char8 qualified as BLC
+import Data.Char (toLower)
+import Data.Default.Class (def)
+import Data.Foldable (toList)
+import Data.List (intercalate, sort, sortOn)
+import Data.Maybe (catMaybes, isJust, listToMaybe, mapMaybe)
+import Data.Set (Set)
+import Data.Set qualified as Set
+import Data.Text qualified as T
+import Data.Text.IO qualified as TIO
+import Data.Text.Lazy qualified as TL
+import Data.Time
+import Data.Time qualified as DT
+import Data.Time.Calendar.WeekDate (toWeekDate)
+import System.Directory
+    ( doesDirectoryExist
+    , listDirectory
+    )
+import System.FilePath
+    ( (</>)
+    , takeExtension
+    )
+import System.Environment (getArgs)
+import Text.ICalendar
+import Text.ICalendar qualified as ICal
+import Text.Printf (printf)
+
+
+--------------------------------------------------------------------------------
+-- Types
+--------------------------------------------------------------------------------
+
+data Event = Event
+    { eventStart       :: LocalTime
+    , eventEnd         :: Maybe LocalTime
+    , eventSummary     :: T.Text
+    , eventDescription :: Maybe T.Text
+    , eventLocation    :: Maybe T.Text
+    , eventUrl         :: Maybe T.Text
+    , eventRecurrence  :: Maybe Recur
+    , eventExDates     :: Set Day
+    }
+    deriving (Show)
+
+
+data EventOccurrence = EventOccurrence
+    { occurrenceDate  :: Day
+    , occurrenceEvent :: Event
+    }
+
+
+--------------------------------------------------------------------------------
+-- Main
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = do
+    args <- getArgs
+
+    case args of
+        []     -> run Nothing
+        [path] -> run (Just path)
+        _      -> usage
+
+
+run :: Maybe FilePath -> IO ()
+run mPath = do
+    today <- localDay . zonedTimeToLocalTime <$> getZonedTime
+
+    events <- case mPath of
+        Nothing   -> pure []
+        Just path -> loadEvents path
+
+    let viewStart =
+            firstDayOfMonth (addMonths (-1) today)
+
+        viewEnd =
+            firstDayOfMonth (addMonths 2 today)
+
+        occurrences =
+            concatMap
+                (expandEvent viewStart viewEnd)
+                events
+
+    putStr (renderThreeMonths today occurrences)
+
+    -- TODO flags to show cal and/or agenda
+    --renderAgenda today events
+
+
+usage :: IO ()
+usage =
+    putStrLn "usage: hascal [FILE.ics]"
+
+
+--------------------------------------------------------------------------------
+-- Loading iCalendar files
+--------------------------------------------------------------------------------
+
+loadEvents :: FilePath -> IO [Event]
+loadEvents path = do
+    isDir <- doesDirectoryExist path
+
+    if isDir
+    then do
+        paths <- findICSFiles path
+        events <- concat <$> mapM loadICSFile paths
+        pure (sortOn eventStart events)
+    else
+        loadICSFile path
+
+
+findICSFiles :: FilePath -> IO [FilePath]
+findICSFiles dir = do
+    entries <- listDirectory dir
+
+    fmap concat $
+        forM entries $ \entry -> do
+            let path = dir </> entry
+            isDir <- doesDirectoryExist path
+
+            if isDir
+            then findICSFiles path
+            else
+                pure
+                    [ path
+                    | map toLower (takeExtension path) == ".ics"
+                    ]
+
+
+loadICSFile :: FilePath -> IO [Event]
+loadICSFile path = do
+    source <- BL.readFile path
+    let cleaned = stripValarms source
+
+    case parseICalendar def path cleaned of
+        Left err -> do
+            putStrLn ("hascal: " <> path <> ": " <> err)
+            pure []
+
+        Right (calendars, warnings) -> do
+            mapM_
+                (\warning ->
+                    putStrLn
+                        ("hascal: warning: " <> path <> ": " <> warning))
+                warnings
+
+            pure (concatMap calendarEvents calendars)
+
+
+loadEventDirectory :: FilePath -> IO [Event]
+loadEventDirectory directory = do
+    names <- listDirectory directory
+
+    let files =
+            [ directory </> name
+            | name <- names
+            , map toLower (takeExtension name) == ".ics"
+            ]
+
+    events <- concat <$> mapM loadEventFile files
+
+    pure (sortOn eventStart events)
+
+
+loadEventFile :: FilePath -> IO [Event]
+loadEventFile path = do
+    contents <- BL.readFile path
+    let cleaned = stripValarms contents
+
+    case parseICalendar def path cleaned of
+        Left err -> do
+            putStrLn ("hascal: " <> path <> ": " <> err)
+            pure []
+
+        Right (calendars, warnings) -> do
+            mapM_
+                (putStrLn . ("hascal: warning: " <>))
+                warnings
+
+            pure (concatMap calendarEvents calendars)
+
+
+stripValarms :: BL.ByteString -> BL.ByteString
+stripValarms =
+    BLC.unlines . go . map normalize . BLC.lines
+  where
+    go [] =
+        []
+
+    go (line : rest)
+        | line == "BEGIN:VALARM" =
+            go (dropAlarm rest)
+
+        | otherwise =
+            line : go rest
+
+    dropAlarm [] =
+        []
+
+    dropAlarm (line : rest)
+        | line == "END:VALARM" =
+            rest
+
+        | otherwise =
+            dropAlarm rest
+
+    normalize =
+        BL.dropWhileEnd (== 13)  -- '\r'
+
+
+calendarEvents :: VCalendar -> [Event]
+calendarEvents =
+    catMaybes . map toEvent . toList . vcEvents
+
+
+mapMaybeVEvent :: [VEvent] -> [Event]
+mapMaybeVEvent =
+    catMaybes . map toEvent
+
+
+toEvent :: VEvent -> Maybe Event
+toEvent event = do
+    start <- extractStart (veDTStart event)
+
+    pure Event
+        { eventStart       = start
+        , eventEnd         = extractEnd (veDTEndDuration event)
+        , eventSummary     = maybe "" (TL.toStrict . summaryValue) (veSummary event)
+        , eventDescription = fmap (TL.toStrict . descriptionValue) (veDescription event)
+        , eventLocation    = fmap (TL.toStrict . locationValue) (veLocation event)
+        , eventUrl         = fmap (T.pack . show . urlValue) (veUrl event)
+        , eventRecurrence  = rRuleValue <$> listToMaybe (toList (veRRule event))
+        , eventExDates     = extractExDates (veExDate event)
+        }
+
+
+--------------------------------------------------------------------------------
+-- iCalendar value extraction
+--------------------------------------------------------------------------------
+
+dateTimeToLocal :: DateTime -> LocalTime
+dateTimeToLocal (FloatingDateTime t) =
+    t
+
+dateTimeToLocal (UTCDateTime t) =
+    utcToLocalTime utc t
+
+dateTimeToLocal (ZonedDateTime t _) =
+    t
+
+
+extractStart :: Maybe DTStart -> Maybe LocalTime
+extractStart Nothing =
+    Nothing
+
+extractStart (Just (DTStartDateTime dt _)) =
+    Just (dateTimeToLocal dt)
+
+extractStart (Just (DTStartDate date _)) =
+    Just (LocalTime (dateValue date) midnight)
+
+
+extractEnd :: Maybe (Either DTEnd DurationProp) -> Maybe LocalTime
+extractEnd (Just (Left dtEnd)) =
+    Just (extractDTEnd dtEnd)
+
+extractEnd _ =
+    Nothing
+
+
+extractDTEnd :: DTEnd -> LocalTime
+extractDTEnd (DTEndDateTime dt _) =
+    dateTimeToLocal dt
+
+extractDTEnd (DTEndDate date _) =
+    LocalTime (dateValue date) midnight
+
+
+extractExDates :: Set ExDate -> Set Day
+extractExDates =
+    Set.fromList . concatMap extract . toList
+  where
+    extract (ExDates dates _) =
+        map dateValue (Set.toList dates)
+
+    extract (ExDateTimes dateTimes _) =
+        map dateTimeDay (Set.toList dateTimes)
+
+
+dateTimeDay :: DateTime -> Day
+dateTimeDay (FloatingDateTime t) =
+    localDay t
+
+dateTimeDay (UTCDateTime t) =
+    localDay (utcToLocalTime utc t)
+
+dateTimeDay (ZonedDateTime t _) =
+    localDay t
+
+
+extractSummary :: Maybe Summary -> T.Text
+extractSummary =
+    maybe "" (TL.toStrict . summaryValue)
+
+
+extractDescription :: Maybe Description -> Maybe T.Text
+extractDescription =
+    fmap (TL.toStrict . descriptionValue)
+
+
+extractLocation :: Maybe Location -> Maybe T.Text
+extractLocation =
+    fmap (TL.toStrict . locationValue)
+
+
+extractUrl :: Maybe URL -> Maybe T.Text
+extractUrl =
+    fmap (T.pack . show . urlValue)
+
+
+--------------------------------------------------------------------------------
+-- Recurrence expansion
+--------------------------------------------------------------------------------
+
+expandEvent :: Day -> Day -> Event -> [EventOccurrence]
+expandEvent from to event =
+    case eventRecurrence event of
+        Nothing ->
+            singleOccurrence
+
+        Just recur ->
+            map makeOccurrence $
+                filter (not . excluded) $
+                takeWhile (< to) $
+                dropWhile (< from) $
+                recurrenceDatesLimited recur (eventStartDay event)
+
+  where
+    singleOccurrence =
+        [ EventOccurrence (eventStartDay event) event
+        | eventStartDay event >= from
+        , eventStartDay event < to
+        ]
+
+    makeOccurrence day =
+        EventOccurrence day event
+
+    excluded day =
+        day `Set.member` eventExDates event
+
+    eventStartDay =
+        localDay . eventStart
+
+
+recurrenceDates :: Recur -> Day -> [Day]
+recurrenceDates recur start =
+    case recurFreq recur of
+        Daily   -> daily
+        Weekly  -> weekly
+        Monthly -> monthly
+        Yearly  -> yearly
+
+  where
+    interval =
+        max 1 (recurInterval recur)
+
+    daily =
+        [ addDays (fromIntegral (n * interval)) start
+        | n <- [0 ..]
+        ]
+
+    weekly =
+        weeklyOccurrences recur start interval
+
+    monthly =
+        monthlyOccurrences recur start interval
+
+    yearly =
+        yearlyOccurrences recur start interval
+
+
+recurrenceDatesLimited :: Recur -> Day -> [Day]
+recurrenceDatesLimited recur start =
+    takeUntil $
+        maybe dates (`take` dates) (recurCount recur)
+  where
+    dates =
+        dropWhile (< start) $
+            recurrenceDates recur start
+
+    takeUntil =
+        case recurUntil recur of
+            Nothing ->
+                id
+
+            Just untilDay ->
+                takeWhile (<= untilDay)
+
+
+recurCount :: Recur -> Maybe Int
+recurCount recur =
+    case recurUntilCount recur of
+        Just (Right count) -> Just count
+        _                  -> Nothing
+
+
+recurUntil :: Recur -> Maybe Day
+recurUntil recur =
+    case recurUntilCount recur of
+        Just (Left (Left date)) ->
+            Just (dateValue date)
+
+        Just (Left (Right dateTime)) ->
+            Just (dateTimeDay dateTime)
+
+        _ ->
+            Nothing
+
+
+--------------------------------------------------------------------------------
+-- Daily / weekly recurrence
+--------------------------------------------------------------------------------
+
+weeklyOccurrences :: Recur -> Day -> Int -> [Day]
+weeklyOccurrences recur start interval =
+    concatMap occurrencesInWeek [0 ..]
+
+  where
+    weekStart =
+        startOfWeek (recurWkSt recur) start
+
+    weekdays =
+        if null (recurByDay recur)
+        then
+            [toICalWeekday (dayOfWeek start)]
+        else
+            map weekdayOf (recurByDay recur)
+
+    occurrencesInWeek n =
+        let base =
+                addDays
+                    (fromIntegral (n * 7 * interval))
+                    weekStart
+        in sort
+            [ addDays
+                (fromIntegral (weekdayOffsetFrom (recurWkSt recur) wd))
+                base
+            | wd <- weekdays
+            ]
+
+
+weekdayOf :: Either (Int, ICal.Weekday) ICal.Weekday -> ICal.Weekday
+weekdayOf value =
+    case value of
+        Left (_, wd) -> wd
+        Right wd     -> wd
+
+
+--------------------------------------------------------------------------------
+-- Monthly recurrence
+--------------------------------------------------------------------------------
+
+monthlyOccurrences :: Recur -> Day -> Int -> [Day]
+monthlyOccurrences recur start interval =
+    concatMap occurrencesInMonth [0 ..]
+
+  where
+    occurrencesInMonth n =
+        let month =
+                addMonths (n * interval) start
+        in monthlyDates recur month start
+
+
+monthlyDates :: Recur -> Day -> Day -> [Day]
+monthlyDates recur monthStart originalStart
+    | not (null (recurByMonthDay recur)) =
+        mapMaybe (makeDay monthStart) (recurByMonthDay recur)
+
+    | not (null (recurByDay recur)) =
+        monthlyByDay recur monthStart
+
+    | otherwise =
+        let (_, _, d) =
+                toGregorian originalStart
+        in maybeToList (makeDay monthStart d)
+
+
+monthlyByDay :: Recur -> Day -> [Day]
+monthlyByDay recur monthStart =
+    sort . catMaybes $
+        map (monthlyWeekday monthStart) (recurByDay recur)
+
+
+monthlyWeekday :: Day -> Either (Int, ICal.Weekday) ICal.Weekday -> Maybe Day
+monthlyWeekday monthStart spec =
+    case spec of
+        Right wd ->
+            nthWeekday monthStart wd 1
+
+        Left (n, wd) ->
+            nthWeekday monthStart wd n
+
+
+nthWeekday :: Day -> ICal.Weekday -> Int -> Maybe Day
+nthWeekday monthStart wd n
+    | n > 0 =
+        let first =
+                fromGregorian y m 1
+
+            offset =
+                weekdayOffsetFrom
+                    (toICalWeekday (dayOfWeek first))
+                    wd
+
+            day =
+                1 + offset + 7 * (n - 1)
+
+        in makeDay monthStart day
+
+    | n < 0 =
+        let last =
+                fromGregorian
+                    y
+                    m
+                    (gregorianMonthLength y m)
+
+            offset =
+                weekdayOffsetFrom
+                    wd
+                    (toICalWeekday (dayOfWeek last))
+
+            day =
+                gregorianMonthLength y m
+                    - offset
+                    + 7 * (n + 1)
+
+        in makeDay monthStart day
+
+    | otherwise =
+        Nothing
+
+  where
+    (y, m, _) =
+        toGregorian monthStart
+
+
+allWeekdays :: Day -> ICal.Weekday -> [Day]
+allWeekdays monthStart wd =
+    takeWhile sameMonth $
+        iterate (addDays 7) first
+  where
+    (year, month, _) =
+        toGregorian monthStart
+
+    first =
+        addDays
+            (fromIntegral
+                (weekdayOffsetFrom
+                    (toICalWeekday (dayOfWeek monthStart))
+                    wd))
+            monthStart
+
+    sameMonth day =
+        let (y, m, _) = toGregorian day
+        in y == year && m == month
+
+
+--------------------------------------------------------------------------------
+-- Yearly recurrence
+--------------------------------------------------------------------------------
+
+yearlyOccurrences :: Recur -> Day -> Int -> [Day]
+yearlyOccurrences recur start interval =
+    concatMap occurrencesInYear [0 ..]
+
+  where
+    (startYear, startMonth, startDay) =
+        toGregorian start
+
+    occurrencesInYear n =
+        let year =
+                startYear + fromIntegral (n * interval)
+        in yearlyDates
+            recur
+            year
+            startMonth
+            startDay
+
+
+yearlyDates :: Recur -> Integer -> MonthOfYear -> Int -> [Day]
+yearlyDates recur year originalMonth originalDay
+    | not (null (recurByMonth recur)) =
+        concatMap datesForMonth (recurByMonth recur)
+
+    | otherwise =
+        maybeToList $
+            makeYearDay
+                year
+                originalMonth
+                originalDay
+
+  where
+    datesForMonth month =
+        if null (recurByMonthDay recur)
+        then
+            if null (recurByDay recur)
+            then
+                maybeToList
+                    (makeYearDay year month originalDay)
+            else
+                yearlyByDay
+                    year
+                    month
+                    (recurByDay recur)
+        else
+            catMaybes
+                [ makeDay
+                    (fromGregorian year month 1)
+                    d
+                | d <- recurByMonthDay recur
+                ]
+
+
+makeYearDay :: Integer -> MonthOfYear -> Int -> Maybe Day
+makeYearDay year month day =
+    makeDay
+        (fromGregorian year month 1)
+        day
+
+
+yearlyByDay
+    :: Integer
+    -> MonthOfYear
+    -> [Either (Int, ICal.Weekday) ICal.Weekday]
+    -> [Day]
+yearlyByDay year month specs =
+    sort $
+        concatMap expand specs
+  where
+    monthStart =
+        fromGregorian year month 1
+
+    expand (Left (n, wd)) =
+        maybeToList $
+            nthWeekday monthStart wd n
+
+    expand (Right wd) =
+        allWeekdays monthStart wd
+
+
+--------------------------------------------------------------------------------
+-- Calendar calculations
+--------------------------------------------------------------------------------
+
+addMonths :: Int -> Day -> Day
+addMonths n day =
+    let (y, m, d) =
+            toGregorian day
+
+        total =
+            y * 12
+                + fromIntegral m
+                - 1
+                + fromIntegral n
+
+        y' =
+            total `div` 12
+
+        m' =
+            fromIntegral (total `mod` 12) + 1
+
+        d' =
+            min d (gregorianMonthLength y' m')
+
+    in fromGregorian y' m' d'
+
+
+firstDayOfMonth :: Day -> Day
+firstDayOfMonth day =
+    let (y, m, _) = toGregorian day
+    in fromGregorian y m 1
+
+
+dayOfMonth :: Day -> Int
+dayOfMonth day =
+    let (_, _, d) =
+            toGregorian day
+    in d
+
+
+monthOf :: Day -> Int
+monthOf day =
+    let (_, m, _) =
+            toGregorian day
+    in m
+
+
+isoWeekNumber :: Day -> Int
+isoWeekNumber day =
+    let (_, week, _) =
+            toWeekDate day
+    in week
+
+
+startOfWeek :: ICal.Weekday -> Day -> Day
+startOfWeek first day =
+    addDays
+        (negate (fromIntegral offset))
+        day
+  where
+    offset =
+        weekdayOffsetFrom
+            first
+            (toICalWeekday (dayOfWeek day))
+
+
+weekdayOffsetFrom :: ICal.Weekday -> ICal.Weekday -> Int
+weekdayOffsetFrom first target =
+    (fromEnum target - fromEnum first) `mod` 7
+
+
+makeDay :: Day -> Int -> Maybe Day
+makeDay monthStart d =
+    let (y, m, _) =
+            toGregorian monthStart
+
+        maxDay =
+            gregorianMonthLength y m
+
+    in if d >= 1 && d <= maxDay
+       then Just (fromGregorian y m d)
+       else Nothing
+
+
+maybeToList :: Maybe a -> [a]
+maybeToList Nothing  = []
+maybeToList (Just x) = [x]
+
+
+toICalWeekday :: DayOfWeek -> Weekday
+toICalWeekday dow =
+    case dow of
+        Data.Time.Monday ->
+            Text.ICalendar.Monday
+
+        Data.Time.Tuesday ->
+            Text.ICalendar.Tuesday
+
+        Data.Time.Wednesday ->
+            Text.ICalendar.Wednesday
+
+        Data.Time.Thursday ->
+            Text.ICalendar.Thursday
+
+        Data.Time.Friday ->
+            Text.ICalendar.Friday
+
+        Data.Time.Saturday ->
+            Text.ICalendar.Saturday
+
+        Data.Time.Sunday ->
+            Text.ICalendar.Sunday
+
+
+--------------------------------------------------------------------------------
+-- Calendar rendering
+--------------------------------------------------------------------------------
+
+
+eventOnDay :: Day -> [EventOccurrence] -> Bool
+eventOnDay date =
+    any ((== date) . occurrenceDate)
+
+
+renderThreeMonths :: Day -> [EventOccurrence] -> String
+renderThreeMonths today occurrences =
+    monthColor <> -- XXX this is a hack, we really want to colorize in renderMonth instead
+    unlines
+        [ intercalate " "
+            [ padMonth month row
+            | month <- monthLines
+            ]
+        | row <- [0 .. 7]
+        ]
+
+  where
+    firstMonth =
+        firstDayOfMonth today
+
+    months =
+        [ addMonths (-1) firstMonth
+        , firstMonth
+        , addMonths 1 firstMonth
+        ]
+
+    monthLines =
+        map
+            (renderMonth today occurrences)
+            months
+
+
+renderMonth :: Day -> [EventOccurrence] -> Day -> [String]
+renderMonth today occurrences month =
+    -- TODO colors interfer with padMonth
+    -- TODO [ monthColor <> center 24 (formatMonth month) <> resetColor
+    [ center 24 (formatMonth month)
+    , "   " <> dayOfWeekColor <> "Mo Tu We Th Fr Sa Su" <> resetColor <> " "
+    ]
+    <> map
+        (renderWeek today occurrences month)
+        [0 .. 5]
+
+
+renderWeek :: Day -> [EventOccurrence] -> Day -> Int -> String
+renderWeek today occurrences monthDay week =
+    weekNumber <> concatMap renderCell [0 .. 6]
+
+  where
+    first =
+        firstDayOfMonth monthDay
+
+    offset =
+        weekdayOffsetFrom
+            ICal.Monday
+            (toICalWeekday (dayOfWeek first))
+
+    firstDay =
+        addDays
+            (fromIntegral (week * 7 - offset))
+            first
+
+    dates =
+        map
+            (\weekday ->
+                dayForPosition
+                    first
+                    offset
+                    week
+                    weekday)
+            [0 .. 6]
+
+    hasDays =
+        any isJust dates
+
+    weekNumber
+        | hasDays =
+            weekNumberColor
+            <> printf "%02d" (isoWeekNumber firstActualDay)
+            <> resetColor
+            <> " "
+        | otherwise =
+            "   "
+
+    firstActualDay =
+        head (catMaybes dates)
+
+    renderCell weekday =
+        case dates !! weekday of
+            Nothing ->
+                "   "
+
+            Just date ->
+                colorize
+                    today
+                    occurrences
+                    date
+                    (printf "%2d" (dayOfMonth date))
+                    <> " "
+
+
+dayForPosition
+    :: Day
+    -> Int
+    -> Int
+    -> Int
+    -> Maybe Day
+dayForPosition first offset week weekday =
+    let dayNumber =
+            week * 7
+                + weekday
+                - offset
+                + 1
+
+        candidate =
+            addDays
+                (fromIntegral (dayNumber - 1))
+                first
+
+        (_, month, _) =
+            toGregorian first
+
+    in if dayNumber < 1
+       || monthOf candidate /= month
+       then Nothing
+       else Just candidate
+
+
+formatMonth :: Day -> String
+formatMonth day =
+    formatTime
+        defaultTimeLocale
+        "%B %Y"
+        day
+
+
+center :: Int -> String -> String
+center width str =
+    let padding =
+            max 0 (width - length str)
+
+        left =
+            padding `div` 2
+
+    in replicate left ' ' <> str
+
+
+padRight :: Int -> String -> String
+padRight width str =
+    str
+        <> replicate
+            (max 0 (width - length str))
+            ' '
+
+
+padMonth :: [String] -> Int -> String
+padMonth lines' row =
+    case drop row lines' of
+        (line : _) ->
+            padRight 24 line
+
+        [] ->
+            replicate 24 ' '
+
+
+--------------------------------------------------------------------------------
+-- Colors
+--------------------------------------------------------------------------------
+
+todayColor :: String
+todayColor =
+    --"\ESC[1;39;4m"
+    "\ESC[38;5;203;1m"
+
+
+eventColor :: String
+eventColor =
+    "\ESC[1;36m"
+
+
+pastColor :: String
+pastColor =
+    "\ESC[2m"
+
+
+weekNumberColor :: String
+weekNumberColor =
+    "\ESC[38;5;241m"
+
+
+dayOfWeekColor :: String
+dayOfWeekColor =
+    "\ESC[38;5;241m"
+
+
+monthColor :: String
+monthColor =
+    "\ESC[38;5;241m"
+
+
+resetColor :: String
+resetColor =
+    "\ESC[m"
+
+
+colorize :: Day -> [EventOccurrence] -> Day -> String -> String
+colorize today occurrences date text
+    | date == today =
+        todayColor <> text <> resetColor
+
+    | eventOnDay date occurrences =
+        eventColor <> text <> resetColor
+
+    | date < today =
+        pastColor <> text <> resetColor
+
+    | otherwise =
+        text
+
+
+--------------------------------------------------------------------------------
+-- Agenda
+--------------------------------------------------------------------------------
+
+renderAgenda :: Day -> [Event] -> IO ()
+renderAgenda today events = do
+    let viewStart =
+            firstDayOfMonth (addMonths (-1) today)
+
+        viewEnd =
+            firstDayOfMonth (addMonths 2 today)
+
+        relevant =
+            filter
+                (\e ->
+                    let d =
+                            localDay (eventStart e)
+                    in d >= viewStart
+                       && d < viewEnd)
+                events
+
+    forM_ relevant $ \event -> do
+        let time =
+                formatTime
+                    defaultTimeLocale
+                    "%a %d %H:%M"
+                    (eventStart event)
+
+        TIO.putStrLn
+            (T.pack time
+                <> "  "
+                <> eventSummary event)
+
+        forM_ (eventDescription event) $ \description ->
+            TIO.putStrLn
+                ("          " <> description)
+
+        forM_ (eventLocation event) $ \location ->
+            TIO.putStrLn
+                ("          @ " <> location)
+
+        forM_ (eventUrl event) $ \url ->
+            TIO.putStrLn
+                ("          " <> url)
diff --git a/neohascal.cabal b/neohascal.cabal
new file mode 100644
index 0000000..abfae54
--- /dev/null
+++ b/neohascal.cabal
@@ -0,0 +1,39 @@
+cabal-version: 3.0
+name:          neohascal
+version:       0.1.0.0
+synopsis:      A simple terminal calendar with iCalendar support
+description:   A cal-like terminal calendar with iCalendar agenda support.
+license:       BSD-3-Clause
+author:        tv
+build-type:    Simple
+extra-source-files:
+    README.md
+
+executable neohascal
+    main-is:          Main.hs
+    hs-source-dirs:   app
+    default-language: GHC2024
+
+    ghc-options:
+        -Wall
+        -Wcompat
+        -Widentities
+        -Wincomplete-uni-patterns
+        -Wincomplete-record-updates
+        -Wmissing-export-lists
+        -Wmissing-home-modules
+        -Wpartial-fields
+        -Wredundant-constraints
+        -O2
+
+    build-depends:
+        base >= 4.17 && < 5,
+        iCalendar >= 0.4.1.1 && < 0.5,
+        time >= 1.12 && < 2,
+        text >= 2.0 && < 3,
+        directory >= 1.3 && < 2,
+        filepath >= 1.4 && < 2
+      , bytestring
+      , data-default-class
+      , containers
+