Events

A list of upcoming events.

events

#!/usr/bin/pinafore
import "pinafore-gnome", "UILib" in
with GTK., UILib. in
run.Context $ fn context =>
let

    Mk.UI.Named = mk.UI.Named context;

    ### EventTime

    # An event can either be at a particular time, or a whole-day event.
    datatype storable EventTime of
        MkDate Date !"Date"; # all-day event
        MkTime LocalTime !"Time"; # event at a time
    end;

    namespace EventTime of

        subtype EventTime <: Showable =
        match
            MkDate d => Mk.Showable $ encode (unixAsText.Date "%F") d;
            MkTime t => Mk.Showable $ encode (unixAsText.LocalTime "%F %R") t;
        end;

        dateOf: Lens EventTime Date =
        let
            getDate: EventTime -> Date =
            match
                MkDate d => d;
                MkTime (DateAndTime d _) => d
            end;

            setDate: EventTime -> Date -> EventTime =
            match
                MkTime (DateAndTime _ t) => fn d => MkTime (DateAndTime d t);
                _ => MkDate;
            end;
        in
        Mk.Lens getDate setDate;

        timeOfDayModel: WholeModel EventTime -> WholeModel TimeOfDay =
        let
            getTimeOfDay: Maybe EventTime -> Maybe TimeOfDay =
            match
                Just (MkTime (DateAndTime _ tod)) => Just tod;
                _ => Nothing;
            end;

            setTimeOfDay: Maybe TimeOfDay -> Maybe EventTime -> Maybe (Maybe EventTime) =
            fn mtod, met =>
            Just $ met >-
            match
                Nothing => Nothing;
                Just et =>
                    Just $ mtod >-
                    match
                        Nothing => MkDate $ fetch dateOf et;
                        Just tod => MkTime $ DateAndTime (fetch dateOf et) tod;
                    end;
            end;
        in maybeLensMap.WholeModel getTimeOfDay setTimeOfDay;

        # for ordering
        getTime: EventTime -> LocalTime =
        match
            MkDate d => DateAndTime d midnight;
            MkTime t => t
        end;

        order: ModelOrder EventTime =
        map.ModelOrder getTime order.LocalTime;

    end;

    ### Event

    opentype Event;
    subtype Event <: Named;

    namespace Event of

        eventSet: FiniteSetModel Event =
        property @Event @Unit !"type.event" store !@ {()};

        timeOf = property @Event @EventTime !"event.time" store;

        notesOf = property @Event @Text !"item.description" store;

        order: ModelOrder Event =
        on.ModelOrder timeOf order.EventTime;

        forDayModel: WholeModel +Date -> WholeModel +(List (EventTime *: Text)) =
        let

            eventData: FiniteSetModel (EventTime *: Text) =
            (timeOf.Event **.Property nameOf) !$$ eventSet;

            eventDataOrder: ModelOrder (EventTime *: Text) =
            map.ModelOrder fst order.EventTime;

            orderedEventsModel: WholeModel +(List (EventTime *: Text)) =
            toList.FiniteSetModel eventDataOrder eventData;

        in
        fn todaymodel =>
        {
            let

                today: Date = %todaymodel;

                pickCurrent: EventTime *: Text -> Boolean =
                fn (t,_) =>
                ge $ order.Date (fetch dateOf.EventTime t) today;

                todayEvent: EventTime *: Text =
                (MkDate.EventTime today,"Today");

                futureEvents: List (EventTime *: Text) =
                filter pickCurrent %orderedEventsModel;

            in todayEvent :: futureEvents
        };

    end;


    ### GTK

    # Text for the overview tab.
    overviewModel: WholeModel +Date -> WholeModel +Text =
    fn todaymodel =>
    {
        concat.Text $
        map.List (fn (t,n) => show t <>.Text ": " <>.Text n <>.Text "\n") %(forDayModel.Event todaymodel)
    };

    # Overview tab GTK
    overviewPane: Pane =
    simple.Pane "Overview" $
    exec.Widget $
    do
        now <- newClock $ Seconds 60; # update every minute
        tz <- newTimeZoneModel.LocalTime now;
        pure $ label.Widget $ overviewModel {fromTime.LocalTime %tz %now >- match DateAndTime d _ => d end};
    end;

    calendarWindow: WholeModel +Event -> Action Window =
    fn evt =>
    mfix $
    fn window =>
    open.Window gtk (200,200) {"date of " <>.Text %(nameOf !$% evt)} $ vertical.Widget
    [
        calendar.Widget $ dateOf.EventTime !$ (timeOf.Event !$% evt),
        button.Widget {"Done: " <>.Text show %(dateOf.EventTime !$ timeOf.Event !$% evt)} {close.Window window}
    ];

    eventUI: Event -> Widget =
    fn evt =>
    vertical.Widget
    [
        textEntry.Widget $ nameOf !$% {evt},
        horizontal.Widget
        [
            button.Widget {"cal"} {calendarWindow {evt}},
            textEntry.Widget $ reverse.Prism asText.Date !$ (dateOf.EventTime !$ timeOf.Event !$% {evt}),
            textEntry.Widget $ reverse.Prism (unixAsText.TimeOfDay "%H:%M") !$ (timeOfDayModel.EventTime $ timeOf.Event !$% {evt})
        ],
        layoutGrow.Widget $ textArea.Widget (fromWhole.TextModel $ notesOf.Event !$% {evt})
    ];

    eventWindow: Event -> Action Window =
    fn evt =>
    paneWindow $ namedPane eventUI evt;

    newEvent: Action Event =
    do
        item <- new.OpenEntity @Event;
        day <- getNowLocal.Date;
        timeOf.Event !$ {item} := MkDate.EventTime day;
        nameOf !$ {item} := "";
        pure item;
    end;

    eventsTableUI: SetWidget Event =
    Mk.SetWidget $
    fn mSelectionModel =>
    let
        columns: List (WholeModel +Text *: (Event -> WholeModel Text)) =
        let
            timeColumn: WholeModel +Text *: (Event -> WholeModel Text)
            = ({"When"},fn e => {show $ %(timeOf.Event !$ {e})});
            nameColumn: WholeModel +Text *: (Event -> WholeModel Text)
            = ({"What"},fn e => nameOf !$ {e});
        in
        [timeColumn,nameColumn];
    in
    exec.Widget $
    do
        lm <- getList.FiniteSetModel order.Event eventSet.Event;
        pure $ listTable.Widget columns lm eventWindow mSelectionModel;
    end;

    eventsPresentation: SetPresentation Event =
    Mk.SetPresentation of
        setName = "Events";
        itemSet = eventSet.Event;
        newItems =
        [
            Mk.NewItem of
                name = "New Event";
                mkey = Just "Ctrl+K";
                newItem = newEvent;
            end
        ];
        itemPane = namedPane eventUI;
        setWidget = eventsTableUI;
    end;

in
do
    eventsPane <- presentSetWithItem eventsPresentation;
    p <- notebook.Pane {"Events"} [overviewPane,eventsPane];
    paneWindow p
end