From 3642b95f8cb7b54b45ad7e4c1e41cb805ffc3bfa Mon Sep 17 00:00:00 2001 From: Eike Kettner Date: Sat, 8 Aug 2020 09:23:48 +0200 Subject: [PATCH] Add a better tag selection field --- modules/webapp/src/main/elm/Api.elm | 47 ++++- .../webapp/src/main/elm/Comp/SearchMenu.elm | 76 ++++---- .../webapp/src/main/elm/Comp/TagSelect.elm | 180 ++++++++++++++++++ 3 files changed, 251 insertions(+), 52 deletions(-) create mode 100644 modules/webapp/src/main/elm/Comp/TagSelect.elm diff --git a/modules/webapp/src/main/elm/Api.elm b/modules/webapp/src/main/elm/Api.elm index db1b3aae..317aa53c 100644 --- a/modules/webapp/src/main/elm/Api.elm +++ b/modules/webapp/src/main/elm/Api.elm @@ -51,6 +51,7 @@ module Api exposing , getScanMailbox , getSentMails , getSources + , getTagCloud , getTags , getUsers , itemDetail @@ -148,6 +149,7 @@ import Api.Model.SimpleMail exposing (SimpleMail) import Api.Model.Source exposing (Source) import Api.Model.SourceList exposing (SourceList) import Api.Model.Tag exposing (Tag) +import Api.Model.TagCloud exposing (TagCloud) import Api.Model.TagList exposing (TagList) import Api.Model.User exposing (User) import Api.Model.UserList exposing (UserList) @@ -689,6 +691,10 @@ uploadSingle flags sourceId meta track files receive = } + +--- Registration + + register : Flags -> Registration -> (Result Http.Error BasicResult -> msg) -> Cmd msg register flags reg receive = Http.post @@ -707,6 +713,10 @@ newInvite flags req receive = } + +--- Login + + login : Flags -> UserPass -> (Result Http.Error AuthResult -> msg) -> Cmd msg login flags up receive = Http.post @@ -736,14 +746,6 @@ loginSession flags receive = } -versionInfo : Flags -> (Result Http.Error VersionInfo -> msg) -> Cmd msg -versionInfo flags receive = - Http.get - { url = flags.config.baseUrl ++ "/api/info/version" - , expect = Http.expectJson receive Api.Model.VersionInfo.decoder - } - - refreshSession : Flags -> (Result Http.Error AuthResult -> msg) -> Cmd msg refreshSession flags receive = case flags.account of @@ -775,6 +777,31 @@ refreshSessionTask flags = } + +--- Version + + +versionInfo : Flags -> (Result Http.Error VersionInfo -> msg) -> Cmd msg +versionInfo flags receive = + Http.get + { url = flags.config.baseUrl ++ "/api/info/version" + , expect = Http.expectJson receive Api.Model.VersionInfo.decoder + } + + + +--- Collective + + +getTagCloud : Flags -> (Result Http.Error TagCloud -> msg) -> Cmd msg +getTagCloud flags receive = + Http2.authGet + { url = flags.config.baseUrl ++ "/api/v1/sec/collective/cloud" + , account = getAccount flags + , expect = Http.expectJson receive Api.Model.TagCloud.decoder + } + + getInsights : Flags -> (Result Http.Error ItemInsights -> msg) -> Cmd msg getInsights flags receive = Http2.authGet @@ -812,6 +839,10 @@ setCollectiveSettings flags settings receive = } + +--- Contacts + + getContacts : Flags -> Maybe ContactType diff --git a/modules/webapp/src/main/elm/Comp/SearchMenu.elm b/modules/webapp/src/main/elm/Comp/SearchMenu.elm index cc308830..5c28f62c 100644 --- a/modules/webapp/src/main/elm/Comp/SearchMenu.elm +++ b/modules/webapp/src/main/elm/Comp/SearchMenu.elm @@ -17,10 +17,11 @@ import Api.Model.IdName exposing (IdName) import Api.Model.ItemSearch exposing (ItemSearch) import Api.Model.ReferenceList exposing (ReferenceList) import Api.Model.Tag exposing (Tag) -import Api.Model.TagList exposing (TagList) +import Api.Model.TagCloud exposing (TagCloud) import Comp.DatePicker import Comp.Dropdown exposing (isDropdownChangeMsg) import Comp.FolderSelect +import Comp.TagSelect import Data.Direction exposing (Direction) import Data.Flags exposing (Flags) import Data.Icons as Icons @@ -41,8 +42,8 @@ import Util.Update type alias Model = - { tagInclModel : Comp.Dropdown.Model Tag - , tagExclModel : Comp.Dropdown.Model Tag + { tagSelectModel : Comp.TagSelect.Model + , tagSelection : Comp.TagSelect.Selection , tagCatInclModel : Comp.Dropdown.Model String , tagCatExclModel : Comp.Dropdown.Model String , directionModel : Comp.Dropdown.Model Direction @@ -71,8 +72,8 @@ type alias Model = init : Model init = - { tagInclModel = Util.Tag.makeDropdownModel - , tagExclModel = Util.Tag.makeDropdownModel + { tagSelectModel = Comp.TagSelect.init [] + , tagSelection = Comp.TagSelect.emptySelection , tagCatInclModel = Util.Tag.makeCatDropdownModel , tagCatExclModel = Util.Tag.makeCatDropdownModel , directionModel = @@ -134,8 +135,7 @@ init = type Msg = Init - | TagIncMsg (Comp.Dropdown.Msg Tag) - | TagExcMsg (Comp.Dropdown.Msg Tag) + | TagSelectMsg Comp.TagSelect.Msg | DirectionMsg (Comp.Dropdown.Msg Direction) | OrgMsg (Comp.Dropdown.Msg IdName) | CorrPersonMsg (Comp.Dropdown.Msg IdName) @@ -146,7 +146,7 @@ type Msg | FromDueDateMsg Comp.DatePicker.Msg | UntilDueDateMsg Comp.DatePicker.Msg | ToggleInbox - | GetTagsResp (Result Http.Error TagList) + | GetTagsResp (Result Http.Error TagCloud) | GetOrgResp (Result Http.Error ReferenceList) | GetEquipResp (Result Http.Error EquipmentList) | GetPersonResp (Result Http.Error ReferenceList) @@ -194,8 +194,8 @@ getItemSearch model = "*" ++ s ++ "*" in { e - | tagsInclude = Comp.Dropdown.getSelected model.tagInclModel |> List.map .id - , tagsExclude = Comp.Dropdown.getSelected model.tagExclModel |> List.map .id + | tagsInclude = model.tagSelection.include |> List.map .tag |> List.map .id + , tagsExclude = model.tagSelection.exclude |> List.map .tag |> List.map .id , corrPerson = Comp.Dropdown.getSelected model.corrPersonModel |> List.map .id |> List.head , corrOrg = Comp.Dropdown.getSelected model.orgModel |> List.map .id |> List.head , concPerson = Comp.Dropdown.getSelected model.concPersonModel |> List.map .id |> List.head @@ -268,7 +268,7 @@ update flags settings msg model = noChange ( mdp , Cmd.batch - [ Api.getTags flags "" GetTagsResp + [ Api.getTagCloud flags GetTagsResp , Api.getOrgLight flags GetOrgResp , Api.getEquipments flags "" GetEquipResp , Api.getPersonsLight flags GetPersonResp @@ -286,21 +286,24 @@ update flags settings msg model = GetTagsResp (Ok tags) -> let - tagList = - Comp.Dropdown.SetOptions tags.items - catList = - Util.Tag.getCategories tags.items + Util.Tag.getCategories (List.map .tag tags.items) |> Comp.Dropdown.SetOptions + + selectModel = + List.sortBy .count tags.items + |> List.reverse + |> Comp.TagSelect.init + + model_ = + { model | tagSelectModel = selectModel } in noChange <| Util.Update.andThen1 - [ update flags settings (TagIncMsg tagList) >> .modelCmd - , update flags settings (TagExcMsg tagList) >> .modelCmd - , update flags settings (TagCatIncMsg catList) >> .modelCmd + [ update flags settings (TagCatIncMsg catList) >> .modelCmd , update flags settings (TagCatExcMsg catList) >> .modelCmd ] - model + model_ GetTagsResp (Err _) -> noChange ( model, Cmd.none ) @@ -340,27 +343,19 @@ update flags settings msg model = GetPersonResp (Err _) -> noChange ( model, Cmd.none ) - TagIncMsg m -> + TagSelectMsg m -> let - ( m2, c2 ) = - Comp.Dropdown.update m model.tagInclModel + ( m_, sel ) = + Comp.TagSelect.update m model.tagSelectModel in NextState - ( { model | tagInclModel = m2 } - , Cmd.map TagIncMsg c2 + ( { model + | tagSelectModel = m_ + , tagSelection = sel + } + , Cmd.none ) - (isDropdownChangeMsg m) - - TagExcMsg m -> - let - ( m2, c2 ) = - Comp.Dropdown.update m model.tagExclModel - in - NextState - ( { model | tagExclModel = m2 } - , Cmd.map TagExcMsg c2 - ) - (isDropdownChangeMsg m) + (sel /= model.tagSelection) DirectionMsg m -> let @@ -639,14 +634,7 @@ view flags settings model = ] ] , formHeader (Icons.tagsIcon "") "Tags" - , div [ class "field" ] - [ label [] [ text "Include (and)" ] - , Html.map TagIncMsg (Comp.Dropdown.view settings model.tagInclModel) - ] - , div [ class "field" ] - [ label [] [ text "Exclude (or)" ] - , Html.map TagExcMsg (Comp.Dropdown.view settings model.tagExclModel) - ] + , Html.map TagSelectMsg (Comp.TagSelect.view settings model.tagSelectModel) , div [ class "field" ] [ label [] [ text "Category Include (and)" ] , Html.map TagCatIncMsg (Comp.Dropdown.view settings model.tagCatInclModel) diff --git a/modules/webapp/src/main/elm/Comp/TagSelect.elm b/modules/webapp/src/main/elm/Comp/TagSelect.elm new file mode 100644 index 00000000..2af7567b --- /dev/null +++ b/modules/webapp/src/main/elm/Comp/TagSelect.elm @@ -0,0 +1,180 @@ +module Comp.TagSelect exposing + ( Model + , Msg + , Selection + , emptySelection + , init + , update + , view + ) + +import Api.Model.TagCount exposing (TagCount) +import Data.Icons as I +import Data.UiSettings exposing (UiSettings) +import Dict exposing (Dict) +import Html exposing (..) +import Html.Attributes exposing (..) +import Html.Events exposing (onClick) + + +type alias Model = + { all : List TagCount + , selected : Dict String Bool + , expanded : Bool + } + + +init : List TagCount -> Model +init tags = + { all = tags + , selected = Dict.empty + , expanded = False + } + + + +--- Update + + +type Msg + = Toggle String + | ToggleExpand + + +type alias Selection = + { include : List TagCount + , exclude : List TagCount + } + + +emptySelection : Selection +emptySelection = + Selection [] [] + + +update : Msg -> Model -> ( Model, Selection ) +update msg model = + case msg of + Toggle id -> + let + current = + Dict.get id model.selected + + next = + case current of + Nothing -> + Dict.insert id True model.selected + + Just True -> + Dict.insert id False model.selected + + Just False -> + Dict.remove id model.selected + + model_ = + { model | selected = next } + in + ( model_, getSelection model_ ) + + ToggleExpand -> + ( { model | expanded = not model.expanded } + , getSelection model + ) + + +getSelection : Model -> Selection +getSelection model = + let + selectedOnly t = + Dict.member t.tag.id model.selected + + isIncluded t = + Dict.get t.tag.id model.selected + |> Maybe.withDefault False + + ( incl, excl ) = + List.filter selectedOnly model.all + |> List.partition isIncluded + in + Selection incl excl + + + +--- View + + +type SelState + = Include + | Exclude + | Deselect + + +selState : Model -> String -> SelState +selState model id = + case Dict.get id model.selected of + Just True -> + Include + + Just False -> + Exclude + + Nothing -> + Deselect + + +view : UiSettings -> Model -> Html Msg +view settings model = + div [ class "ui list" ] + [ div [ class "item" ] + [ I.tagIcon "" + , div [ class "content" ] + [ div [ class "header" ] + [ text "Tags" + ] + , div [ class "ui relaxed list" ] + (List.map (viewItem settings model) model.all) + ] + ] + ] + + +viewItem : UiSettings -> Model -> TagCount -> Html Msg +viewItem settings model tag = + let + state = + selState model tag.tag.id + + color = + Data.UiSettings.tagColorString tag.tag settings + + icon = + case state of + Include -> + i [ class ("check icon " ++ color) ] [] + + Exclude -> + i [ class ("minus icon " ++ color) ] [] + + Deselect -> + I.tagIcon color + in + a + [ class "item" + , href "#" + , onClick (Toggle tag.tag.id) + ] + [ icon + , div [ class "content" ] + [ div + [ classList + [ ( "header", state == Include ) + , ( "description", state /= Include ) + ] + ] + [ text tag.tag.name + , div [ class "ui right floated circular label" ] + [ text (String.fromInt tag.count) + ] + ] + ] + ]