Add a better tag selection field

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

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
+    { tagSelectModel : Comp.TagSelect.Model
-    , tagExclModel : Comp.Dropdown.Model Tag
+    , 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
+    { tagSelectModel = Comp.TagSelect.init []
-    , tagExclModel = Util.Tag.makeDropdownModel
+    , 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)
+    | TagSelectMsg Comp.TagSelect.Msg
-    | TagExcMsg (Comp.Dropdown.Msg Tag)
     | 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
+        | tagsInclude = model.tagSelection.include |> List.map .tag |> List.map .id
-        , tagsExclude = Comp.Dropdown.getSelected model.tagExclModel |> 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 (TagCatIncMsg catList) >> .modelCmd
-                    , update flags settings (TagExcMsg tagList) >> .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 ) =
+                ( m_, sel ) =
-                    Comp.Dropdown.update m model.tagInclModel
+                    Comp.TagSelect.update m model.tagSelectModel
             in
             NextState
-                ( { model | tagInclModel = m2 }
+                ( { model
-                , Cmd.map TagIncMsg c2
+                    | tagSelectModel = m_
+                    , tagSelection = sel
+                  }
+                , Cmd.none
                 )
-                (isDropdownChangeMsg m)
+                (sel /= model.tagSelection)
-
-        TagExcMsg m ->
-            let
-                ( m2, c2 ) =
-                    Comp.Dropdown.update m model.tagExclModel
-            in
-            NextState
-                ( { model | tagExclModel = m2 }
-                , Cmd.map TagExcMsg c2
-                )
-                (isDropdownChangeMsg m)
 
         DirectionMsg m ->
             let
@@ -639,14 +634,7 @@ view flags settings model =
                 ]
             ]
         , formHeader (Icons.tagsIcon "") "Tags"
-        , div [ class "field" ]
+        , Html.map TagSelectMsg (Comp.TagSelect.view settings model.tagSelectModel)
-            [ 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)
-            ]
         , div [ class "field" ]
             [ label [] [ text "Category Include (and)" ]
             , Html.map TagCatIncMsg (Comp.Dropdown.view settings model.tagCatInclModel)

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)
+                    ]
+                ]
+            ]
+        ]