let

### Useful UI stuff

# A window that comes with some menus.
stdWindow: WholeRef +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 -> # window title
    SetRef item -> # the set of items
    [(item -> Action ()) -> MenuItem] -> # Menu items for creating new items
    (item -> Action Any) -> # what to do when an item is activated
    (WholeRef item -> UI) ->
    Action Window;
selectionWindow wtitle iset createMenuItems iopen iui = do
    selection <- newMemWhole;
    let
        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" $ mapList (\mi -> mi $ \i -> selection := i) createMenuItems ++
                [
                    menuAction "View" Nothing {viewItem},
                    menuAction "Delete" Nothing {deleteItem}
                ]
            ];
        in stdWindow {wtitle} moremenus (iui selection);
    end;

# This is a two-pane window, the left has a "selector" of items (e.g. a table), and the right shows the selected item.
selectionPairWindow:
    Text -> # window title
    SetRef item -> # the set of items
    [(item -> Action ()) -> MenuItem] -> # Menu items for creating new items
    (item -> Action Any) -> # what to do when an item is activated
    (WholeRef item -> UI) -> # UI for the item selector
    (WholeRef +item -> UI) -> # UI for the selected item
    Action Window;
selectionPairWindow wtitle iset createMenuItems iopen getSelectorUI getSelectedUI =
    selectionWindow wtitle iset createMenuItems iopen $ \selection -> let
        sidebarUI: UI;
        sidebarUI = getSelectorUI selection;

        selectedUI: UI;
        selectedUI = getSelectedUI $ immutWhole selection;

        in uiHorizontal [(False,sidebarUI),(True,selectedUI)];

uiPage: WholeRef +Text -> UI -> (UI,UI);
uiPage n ui = (uiLabel n,ui);

uiLabelled: WholeRef +Text -> UI -> UI;
uiLabelled n ui = uiHorizontal [(False, uiLabel n),(True, ui)];

in export
    stdWindow
    selectionWindow
    selectionPairWindow
    uiPage
    uiLabelled

#!/usr/bin/pinafore

let

import UIStuff;

# something with a name
opentype Named;
name = property @Named @Text !"identify.name";

byName: FiniteSetRef {+a,+Named} -> WholeRef +[(a,Text)];
byName ref = members (mapRefOrder fst $ refOrderOn name alphabetical) $ (identity !** name) !$$ ref;

# something with a lifespan
opentype Lifespanned;
# birth and death dates
birthdate = property @Lifespanned @Date !"lifespan.start.date";
deathdate = property @Lifespanned @Date !"lifespan.end.date";

# physical locations, that have addresses
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";

locationUI: WholeRef +Location -> UI;
locationUI loc = uiVertical
[
    (True, uiLabelled {"Address: "} $ uiTextArea $ address !$% loc),
    (False, uiLabelled {"City: "} $ uiTextEntry $ city !$% loc),
    (False, uiLabelled {"Postcode/ZIP: "} $ uiTextEntry $ postcode !$% loc),
    (False, uiLabelled {"State/Province: "} $ uiTextEntry $ province !$% loc),
    (False, uiLabelled {"Country: "} $ uiTextEntry $ country !$% loc),
    (False, uiLabelled {"Phone: "} $ uiTextEntry $ locphone !$% loc)
];

# a person or organisation
dynamictype LegalEntity = Person | Organisation;
subtype LegalEntity <: Named;
subtype LegalEntity <: Lifespanned;
email = property @LegalEntity @Text !"contact.email";
phone = property @LegalEntity @Text !"contact.telephone";
home = property @LegalEntity @Location !"being.location";
legalentities: FiniteSetRef LegalEntity;
legalentities = property @LegalEntity @() !"type.legalentity" !@ {()};

# a person
dynamictype Person = !"type.person";
people: FiniteSetRef Person;
people = maybeMapFiniteSet (check @Person) legalentities;
# family relationships between people
mother = property @Person @Person !"relation.family.mother";
father = property @Person @Person !"relation.family.father";
children: WholeRef +Person -> FiniteSetRef Person;
children p = (mother !@% p) <:|:> (father !@% p);
married = property @Person @Boolean !"relation.family.spouse.exist";

familyUI: WholeRef +Person -> UI;
familyUI p = uiVertical
[
    (False, uiLabelled {"Birth: "} $ uiTextEntry $ interpretDateAsText $ birthdate !$% p),
    (False, uiLabelled {"Death: "} $ uiTextEntry $ interpretDateAsText $ deathdate !$% p),
    (False, uiCheckBox {"Married"} $ married !$% p),
    (False, uiLabelled {"Mother: "} $ uiPick (byName people) $ mother !$% p),
    (False, uiLabelled {"Father: "} $ uiPick (byName people) $ father !$% p),
    (False, uiLabel {"Children:"}),
    (True, namedTable (children p) contactWindow Nothing)
];

# employment relationship
employer = property @Person @LegalEntity !"relation.employer";
employees: WholeRef +LegalEntity -> FiniteSetRef Person;
employees p = employer !@% p;

# an organisation
dynamictype Organisation = !"type.organisation";
organisations: FiniteSetRef Organisation;
organisations = property @Organisation @() !"type.organisation" !@ {()};

### User Interface

namedTable: FiniteSetRef {a,+Named} -> (a -> Action Any) -> Maybe (WholeRef {a,+Named}) -> UI;
namedTable = uiListTable [({"Name"},\p -> name !$ {p})] (refOrderOn name alphabetical);

contactPages: WholeRef +LegalEntity -> [(UI, UI)];
contactPages er =
[
    uiPage {"Social"} $ uiVertical
    [
        (False, uiLabelled {"Email: "} $ uiTextEntry $ email !$% er),
        (False, uiLabelled {"Phone: "} $ uiTextEntry $ phone !$% er)
    ],
    uiPage {"Home"} $ locationUI $ home !$% er
];

personPages: WholeRef +Person -> [(UI, UI)];
personPages p =
[
    uiPage {"Work"} $ uiVertical
    [
        (False, uiLabelled {"Employer: "} $ uiPick (byName legalentities) $ employer !$% p)
    ],
    uiPage {"Family"} $ familyUI p
];

organisationPages: WholeRef +Organisation -> [(UI, UI)];
organisationPages subj =
[
    uiPage {"Employees"} $ namedTable (employees subj) contactWindow Nothing
];

contactUI: LegalEntity -> UI;
contactUI e = let
    pages: [(UI, UI)];
    pages = contactPages {e} ++ case e of
        (p: Person) -> personPages {p};
        (o: Organisation) -> organisationPages {o};
        end;
    in uiVertical
    [
        (False, uiLabelled {"Name: "} $ uiTextEntry $ name !$% {e}),
        (True, uiPages pages)
    ];

contactRefUI: WholeRef +LegalEntity -> UI;
contactRefUI ref = uiDynamic $ coMapWhole contactUI ref;

contactWindow: LegalEntity -> Action Window;
contactWindow e = stdWindow (name !$ {e}) [] $ contactUI e;

newPersonMenuItem: (LegalEntity -> Action ()) -> MenuItem;
newPersonMenuItem setsel = menuAction ("New Person") (Just "Ctrl+K")
    {do
    item <- newDynamicEntity @Person;
    legalentities += item;
    setsel item;
    end};

newOrganisationMenuItem: (LegalEntity -> Action ()) -> MenuItem;
newOrganisationMenuItem setsel = menuAction ("New Organisation") (Just "Ctrl+K")
    {do
    item <- newDynamicEntity @Organisation;
    legalentities += item;
    setsel item;
    end};

contactsSelector: WholeRef LegalEntity -> UI;
contactsSelector selection = namedTable legalentities contactWindow (Just selection);

# main window
contactsWindow: Action Window;
contactsWindow = selectionPairWindow "Contacts" legalentities [newPersonMenuItem,newOrganisationMenuItem] contactWindow
    contactsSelector contactRefUI;

in contactsWindow