Events

#!/usr/bin/env pinafore

let

std_window :: Ref +Text -> [MenuItem] -> UI -> Action Window;
std_window title moremenus contents = fixAction $ \window -> let
    basemenus :: [MenuItem];
    basemenus =
        [
            menuSubmenu "File"
            [
                menuAction "Close" (Just "Ctrl+W") {closeWindow window},
                menuSeparator,
                menuAction "Exit" (Just "Ctrl+Q") {exitUI}
            ],
            menuSubmenu "Edit"
            [
                menuAction "Undo" (Just "Ctrl+Z") {queueUndo},
                menuAction "Redo" (Just "Ctrl+Y") {queueRedo}
            ]
        ];
    menus = {basemenus ++ moremenus};
    in openWindow title menus $ uiScrolled contents;

selection_window :: (Text, Text) -> (set & FiniteSetRef {-item,-NewEntity}) -> ((item | NewEntity) -> Action Any) -> ((item | NewEntity) -> Action Any) -> (set -> Notifier item -> UI) -> Action Window;
selection_window (inames,inamep) iset iopen inew iui = do
    (notifier,getsel) <- makeNotifier;
    let
    moremenus =
        [
            menuSubmenu "Selection"
            [
                menuAction ("New " <> inames) (Just "Ctrl+K") {newEntity iset >>= iopen},
                menuAction "View" Nothing {getsel >>= iopen},
                menuAction "Delete" Nothing {getsel >>= \p -> iset -= p}
            ]
        ];
    in std_window {inamep} moremenus (iui iset notifier);
    end;

closedtype EventTime
    = EventTimeDate Date !"EventTimeDate" # all-day event
    | EventTimeTime LocalTime !"EventTimeTime"; # event at a time

showEventTime :: EventTime -> Text;
showEventTime et = case et of
    EventTimeDate d -> toText d;
    EventTimeTime t -> toText t;
    end;

eventTimeDate :: EventTime -> Date;
eventTimeDate et = case et of
    EventTimeDate d -> d;
    EventTimeTime (LocalTime d _) -> d
    end;

setEventTimeDate :: Date -> Maybe EventTime -> Maybe EventTime;
setEventTimeDate d et = Just $ case et of
    Just (EventTimeTime (LocalTime _ t)) -> EventTimeTime (LocalTime d t);
    _ -> EventTimeDate d;
    end;

ui_eventTime :: Ref EventTime -> UI;
ui_eventTime r = uiCalendar $ lensMapRef eventTimeDate setEventTimeDate r;

# for ordering
eventTimeTime :: EventTime -> LocalTime;
eventTimeTime et = case et of
    EventTimeDate d -> LocalTime d midnight;
    EventTimeTime t -> t
    end;

eventTimeOrder :: Order EventTime;
eventTimeOrder = mapOrder eventTimeTime localChronological;

opentype Event;
events :: FiniteSetRef Event;
events = property @Event @() !"Events" !@ {()};

eventName = property @Event @Text !"eventName";
eventTime = property @Event @EventTime !"eventTime";

eventOrder :: Order Event;
eventOrder = orderOn eventTime eventTimeOrder;

eventData :: FiniteSetRef (EventTime,Text);
eventData = (eventTime !** eventName) !$$ events;

eventDataOrder :: Order (EventTime,Text);
eventDataOrder = mapOrder fst eventTimeOrder;

eventList :: Ref +[(EventTime,Text)];
eventList = members eventDataOrder eventData;

overviewRef :: Ref +Text;
overviewRef = {textConcat $ mapList (\(t,n) -> showEventTime t <> ": " <> n <> "\n") %eventList};

overviewPage :: (UI,UI);
overviewPage = (uiLabel {"Overview"},uiLabel overviewRef);

tablePage :: Notifier Event -> (UI,UI);
tablePage notifier = let
    columns :: [(Ref +Text, Event -> Ref Text)];
    columns = let
        timeColumn :: (Ref +Text, Event -> Ref Text);
        timeColumn = ({"Time"},\e -> {showEventTime $ %(eventTime !$ {e})});
        nameColumn :: (Ref +Text, Event -> Ref Text);
        nameColumn = ({"Name"},\e -> eventName !$ {e});
        in [timeColumn,nameColumn];
    in (uiLabel {"Events"}, uiTable columns eventOrder events eventWindow notifier);

eventWindow :: Event -> Action Window;
eventWindow evt = std_window (eventName !$ {evt}) [] $ uiVertical
    [
        (ui_eventTime $ eventTime !$ {evt},False),
        (uiTextEntry $ eventName !$ {evt},True)
    ];

getLocalTime :: Action LocalTime;
getLocalTime = do
    t <- get now;
    tz <- getTimeZone t;
    return $ timeToLocal tz t;
    end;

getCurrentDay :: Action Date;
getCurrentDay = do
    LocalTime d _ <- getLocalTime;
    return d;
    end;

eventsWindow :: Action Window;
eventsWindow = let
    inew i = do
        day <- getCurrentDay;
        eventTime !$ {i} := EventTimeDate day;
        end;
    iui _ notifier = uiPages [overviewPage, tablePage notifier];
    in selection_window ("Event","Events") events eventWindow inew iui;

in do
    _ <- eventsWindow;
    return ();
    end