People and Places

#!/usr/bin/pinafore

let

### Useful
ui_page n ui = (uiLabel n,ui);
ui_labelled n ui = uiHorizontal [(False, uiLabel n),(True, ui)];

stdWindow: Ref +Text -> [MenuItem] -> UI -> Action Window;
stdWindow title moremenus contents = fixAction $ \window -> let
    menus: [MenuItem];
    menus =
        [
            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}
            ]
        ] ++ moremenus;
    in openWindow title {menus} $ uiScrolled contents;

selectionWindow:
    (Text, Text) ->
    SetRef (item | NewEntity) ->
    ((item | NewEntity) -> Action Any) ->
    ((item | NewEntity) -> Action Any) ->
    (Ref {item,+NewEntity} -> UI) ->
    Action Window;
selectionWindow (inames,inamep) iset iopen inew iui = do
    selection <- newMemRef;
    let
        newItem: Action ();
        newItem = do
            item <- newEntity iset;
            inew item;
            iopen item;
            selection := item;
            end;

        viewItem: Action ();
        viewItem = do
            item <- get selection;
            iopen item;
            return ();
            end;

        deleteItem: Action ();
        deleteItem = do
            item <- get selection;
            iset -= item;
            end;

        moremenus: [MenuItem];
        moremenus =
            [
                menuSubmenu "Selection"
                [
                    menuAction ("New " <> inames) (Just "Ctrl+K") {newItem},
                    menuAction "View" Nothing {viewItem},
                    menuAction "Delete" Nothing {deleteItem}
                ]
            ];
        in stdWindow {inamep} moremenus (iui selection);
    end;

selectionPairWindow:
    (Text, Text) ->
    SetRef (item | NewEntity) ->
    ((item | NewEntity) -> Action Any) ->
    ((item | NewEntity) -> Action Any) ->
    (Ref {item,+NewEntity} -> UI) ->
    (Ref {+item,+NewEntity} -> UI) ->
    Action Window;
selectionPairWindow (inames,inamep) iset iopen inew getSelectorUI getSelectedUI = do
    selection <- newMemRef;
    let
        newItem: Action ();
        newItem = do
            item <- newEntity iset;
            inew item;
            iopen item;
            selection := item;
            end;

        viewItem: Action ();
        viewItem = do
            item <- get selection;
            iopen item;
            return ();
            end;

        deleteItem: Action ();
        deleteItem = do
            item <- get selection;
            iset -= item;
            end;

        moremenus: [MenuItem];
        moremenus =
            [
                menuSubmenu "Selection"
                [
                    menuAction ("New " <> inames) (Just "Ctrl+K") {newItem},
                    menuAction "View" Nothing {viewItem},
                    menuAction "Delete" Nothing {deleteItem}
                ]
            ];

        sidebarUI: UI;
        sidebarUI = getSelectorUI selection;

        selectedUI: UI;
        selectedUI = getSelectedUI $ immutRef selection;

        ui: UI;
        ui = uiHorizontal [(False,sidebarUI),(True,selectedUI)];
    in stdWindow {inamep} moremenus ui;
    end;

### People

# Ontology

opentype LegalEntity;
name = property @LegalEntity @Text !"identify.name";
email = property @LegalEntity @Text !"contact.email";
phone = property @LegalEntity @Text !"contact.telephone";

opentype Person;
people: FiniteSetRef Person;
people = property @Person @() !"type.person" !@ {()};
subtype Person <: LegalEntity;

birthdate = property @Person @Date !"lifespan.start.date";
deathdate = property @Person @Date !"lifespan.end.date";

mother = property @Person @Person !"relation.family.mother";
father = property @Person @Person !"relation.family.father";
children: Ref Person -> FiniteSetRef Person;
children p = (mother !@ p) <:|:> (father !@ p);
married = property @Person @Boolean !"relation.family.spouse.exist";

employer = property @Person @LegalEntity !"relation.employer";

opentype Location;
address = property @Location @Text !"location.address.withincity";
locphone = property @Location @Text !"location.telephone";
city = property @Location @Text !"location.address.city";
postcode = property @Location @Text !"location.address.postcode";
province = property @Location @Text !"location.address.province";
country = property @Location @Text !"location.address.country";

home = property @LegalEntity @Location !"being.location";

opentype Organisation;
organisations: FiniteSetRef Organisation;
organisations = property @Organisation @() !"type.organisation" !@ {()};
subtype Organisation <: LegalEntity;

legalentities: FiniteSetRef (Either Person Organisation);
legalentities = people <:+:> organisations;

# UI
table_entities: Ref (Either Person Organisation) -> UI;
table_entities selection = let
    nameColumn: (Ref +Text, Either Person Organisation -> Ref Text);
    nameColumn = ({"Name"},\i -> name !$ {either i});
    openItem: Either Person Organisation -> Action Window;
    openItem i = case i of
        Left p -> window_person p;
        Right o -> window_org o;
        end;
    in uiTable [nameColumn] (orderOn (name !++ name) alphabetical) legalentities openItem (Just selection);

table_people: FiniteSetRef Person -> Maybe (Ref Person) -> UI;
table_people pp mselection = uiTable [({"Name"},\p -> name !$ {p})] (orderOn name alphabetical) pp window_person mselection;

ui_people: FiniteSetRef Person -> UI;
ui_people pp = uiRun $ do
    (selection,sel) <- makeNotifier;
    return $ uiVertical
    [
        (False, uiButton {"New Person"} {newEntity pp >>= window_person}),
        (False, uiButton {"View Person"} {get sel >>= window_person}),
        (False, uiButton {"Remove Person"} {get sel >>= \p -> pp -= p}),
        (True, table_people pp selection)
    ];
    end;

peopleByName: Ref +[(Person,Text)];
peopleByName = members (mapOrder fst $ orderOn name alphabetical) $ (identity !** name) !$$ people;

ui_person: Ref {-LegalEntity,+Person} -> UI;
ui_person p = uiVertical
[
    (False, ui_labelled {"Name: "} $ uiTextEntry $ name !$ p),
    (True, uiPages
    [
        ui_page {"Social"} $ uiVertical
        [
            (False, ui_labelled {"Email: "} $ uiTextEntry $ email !$ p),
            (False, ui_labelled {"Phone: "} $ uiTextEntry $ phone !$ p)
        ],
        ui_page {"Home"} $ let homep = home !$ p in uiVertical
        [
            (True, ui_labelled {"Address: "} $ uiTextArea $ address !$ homep),
            (False, ui_labelled {"City: "} $ uiTextEntry $ city !$ homep),
            (False, ui_labelled {"Postcode/ZIP: "} $ uiTextEntry $ postcode !$ homep),
            (False, ui_labelled {"State/Province: "} $ uiTextEntry $ province !$ homep),
            (False, ui_labelled {"Country: "} $ uiTextEntry $ country !$ homep),
            (False, ui_labelled {"Phone: "} $ uiTextEntry $ locphone !$ homep)
        ],
        ui_page {"Work"} $ uiVertical
        [
            (False, ui_labelled {"Employer: "} $ uiTextEntry $ (name !. employer) !$ p)
        ],
        ui_page {"Family"} $ uiVertical
        [
            (False, ui_labelled {"Birth: "} $ uiTextEntry $ interpretDateAsText $ birthdate !$ p),
            (False, ui_labelled {"Death: "} $ uiTextEntry $ interpretDateAsText $ deathdate !$ p),
            (False, uiCheckBox {"Married"} $ married !$ p),
            (False, ui_labelled {"Mother: "} $ uiPick peopleByName $ mother !$ p),
            (False, ui_labelled {"Father: "} $ uiPick peopleByName $ father !$ p),
            (False, uiLabel {"Children:"}),
            (True, table_people (children p) Nothing)
        ]
    ])
];

window_person: Person -> Action Window;
window_person p = stdWindow (name !$ {p}) [] (ui_person {p});

window_org: Organisation -> Action Window;
window_org o = stdWindow (name !$ {o}) [] uiBlank;

window_people: Action Window;
window_people = selectionPairWindow ("Person","People") people window_person (\_ -> return ()) (\selection -> table_people people (Just selection)) ui_person;

in window_people