#!/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