Events

#!/usr/bin/env pinafore

let

std_window :: Ref +Text -> (Action a -> [MenuItem]) -> UI a -> 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 getsel = {basemenus ++ moremenus getsel};
    in openWindow title menus $ uiScrolled contents;

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

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

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

eventTimeDay :: EventTime -> Day;
eventTimeDay et = case et of
    EventTimeDay d -> d;
    EventTimeTime (LocalTime d _) -> d
    end;

setEventTimeDay :: Day -> EventTime -> Maybe EventTime;
setEventTimeDay d et = Just $ case et of
    EventTimeDay _ -> EventTimeDay d;
    EventTimeTime (LocalTime _ t) -> EventTimeTime (LocalTime d t)
    end;

ui_eventTime :: Ref EventTime -> UI None;
ui_eventTime r = uiCalendar $ lensMapRef eventTimeDay setEventTimeDay r;

# for ordering
eventTimeTime :: EventTime -> LocalTime;
eventTimeTime et = case et of
    EventTimeDay 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 None,UI None);
overviewPage = (uiLabel {"Overview"},uiLabel overviewRef);

tablePage :: (UI None,UI None);
tablePage = 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"},uiIgnore $ uiTable columns eventOrder events eventWindow);

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 Day;
getCurrentDay = do
    LocalTime d _ <- getLocalTime;
    return d;
    end;

eventsWindow :: Action Window;
eventsWindow = selection_window ("Event","Events") events eventWindow (\i -> do day <- getCurrentDay; eventTime !$ {i} := EventTimeDay day; end) $ \_ -> uiPages [overviewPage, tablePage];

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