Contacts

Organise people and organisations. Makes use of dynamic types.

contacts

#!/usr/bin/pinafore
import "pinafore-gnome", "UILib" in
with GTK., UILib. in
run.Context $ fn context =>
let

    Mk.UI.Named = mk.UI.Named context;

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

    # physical locations, that have addresses
    opentype Location;

    namespace Location of
        addressOf = property @Location @Text !"location.address.withincity" store;
        phoneOf = property @Location @Text !"location.telephone" store;
        cityOf = property @Location @Text !"location.address.city" store;
        postcodeOf = property @Location @Text !"location.address.postcode" store;
        provinceOf = property @Location @Text !"location.address.province" store;
        countryOf = property @Location @Text !"location.address.country" store;
    end;

    locationUI: WholeModel +Location -> Widget =
    fn loc =>
    vertical.Widget
    [
        layoutGrow.Widget $ labelled.Widget {"Address: "} $ textArea.Widget (fromWhole.TextModel $ addressOf.Location !$% loc),
        labelled.Widget {"City: "} $ textEntry.Widget $ cityOf.Location !$% loc,
        labelled.Widget {"Postcode/ZIP: "} $ textEntry.Widget $ postcodeOf.Location !$% loc,
        labelled.Widget {"State/Province: "} $ textEntry.Widget $ provinceOf.Location !$% loc,
        labelled.Widget {"Country: "} $ textEntry.Widget $ countryOf.Location !$% loc,
        labelled.Widget {"Phone: "} $ textEntry.Widget $ phoneOf.Location !$% loc
    ];

    let
        # a person or organisation
        dynamictype Contact;
        subtype Contact <: Named;
        subtype Contact <: Lifespanned;

        emailOf = property @Contact @Text !"contact.email" store;
        phoneOf = property @Contact @Text !"contact.telephone" store;
        homeOf = property @Contact @Location !"being.location" store;

        contactSet: FiniteSetModel Contact =
        property @Contact @Unit !"type.legalentity" store !@ {()};

        # a person
        dynamictype Person = !"type.person";
        subtype Person <: Contact;

        peopleSet: FiniteSetModel Person =
        maybeMap.FiniteSetModel (check @Person) contactSet;

        # family relationships between people
        motherOf = property @Person @Person !"relation.family.mother" store;
        fatherOf = property @Person @Person !"relation.family.father" store;
        childrenSet: WholeModel +Person -> FiniteSetModel Person =
        fn p => (motherOf !@% p) <:|:> (fatherOf !@% p);
        marriedOf = property @Person @Boolean !"relation.family.spouse.exist" store;

        # employment relationship
        employerOf = property @Person @Contact !"relation.employer" store;
        employeeSet: WholeModel +Contact -> FiniteSetModel Person =
        fn p => employerOf !@% p;

        # an organisation
        dynamictype Organisation = !"type.organisation";
        subtype Organisation <: Contact;
        organisationSet: FiniteSetModel Organisation =
        property @Organisation @Unit !"type.organisation" store !@ {()};
    end;

    ### User Interface

    let rec

        contactPages: WholeModel +Contact -> List (Widget *: Widget) =
        fn er =>
        [
            page.Widget {"Social"} $ vertical.Widget
            [
                labelled.Widget {"Email: "} $ textEntry.Widget $ emailOf !$% er,
                labelled.Widget {"Phone: "} $ textEntry.Widget $ phoneOf !$% er
            ],
            page.Widget {"Home"} $ locationUI $ homeOf !$% er
        ];

        personPages: WholeModel +Person -> List (Widget *: Widget) =
        fn p =>
        [
            page.Widget {"Work"} $ vertical.Widget
            [
                labelled.Widget {"Employer: "} $ pick.Widget (byName contactSet) $ employerOf !$% p
            ],
            page.Widget {"Family"} $ familyUI p
        ];

        familyUI: WholeModel +Person -> Widget =
        fn p =>
        vertical.Widget
        [
            labelled.Widget {"Birth: "} $ textEntry.Widget $ reverse.Prism asText.Date !$ birthDateOf !$% p,
            labelled.Widget {"Death: "} $ textEntry.Widget $ reverse.Prism asText.Date !$ deathDateOf !$% p,
            checkBox.Widget {"Married"} $ marriedOf !$% p,
            labelled.Widget {"Mother: "} $ pick.Widget (byName peopleSet) $ motherOf !$% p,
            labelled.Widget {"Father: "} $ pick.Widget (byName peopleSet) $ fatherOf !$% p,
            label.Widget {"Children:"},
            layoutGrow.Widget $ toWidget.SetWidget $ namedTable (childrenSet p) contactUI
        ];

        organisationPages: WholeModel +Organisation -> List (Widget *: Widget) =
        fn subj =>
        [
            page.Widget {"Employees"} $ toWidget.SetWidget $ namedTable (employeeSet subj) contactUI
        ];

        contactUI: Contact -> Widget =
        fn c =>
        let
            pages: List (Widget *: Widget) =
            contactPages {c} <>.List (c >- match
                p:? Person => personPages {p};
                o:? Organisation => organisationPages {o};
                end);
        in
        vertical.Widget
        [
            labelled.Widget {"Name: "} $ textEntry.Widget $ nameOf !$% {c},
            layoutGrow.Widget $ notebook.Widget unknown pages
        ];
    end;

    contactsPresentation: SetPresentation Contact =
    Mk.SetPresentation of
        setName = "Contacts";
        itemSet = contactSet;
        newItems =
        [
            Mk.NewItem of name = "New Person"; mkey = Just "Ctrl+K"; newItem = new.DynamicEntity @Person end,
            Mk.NewItem of name = "New Organisation"; newItem = new.DynamicEntity @Organisation end
        ];
        itemPane = namedPane contactUI;
        setWidget = namedTable contactSet contactUI;
    end;

    contactsWindow: Action Window =
    do
        p <- presentSetWithItem contactsPresentation;
        paneWindow p;
    end;

in contactsWindow