Include tag categories into the new tag selection field

modules/webapp/src/main/elm/Comp/FolderSelect.elm

@@ -80,7 +80,7 @@ view constr model =
             [ i [ class "folder open icon" ] []
             , div [ class "content" ]
                 [ div [ class "header" ]
-                    [ text "All"
+                    [ text "Folders"
                     ]
                 , div [ class "ui relaxed list" ]
                     (renderItems constr model)

modules/webapp/src/main/elm/Comp/SearchMenu.elm

@@ -16,7 +16,6 @@ import Api.Model.FolderList exposing (FolderList)
 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.TagCloud exposing (TagCloud)
 import Comp.DatePicker
 import Comp.Dropdown exposing (isDropdownChangeMsg)
@@ -33,7 +32,6 @@ import Html.Events exposing (onCheck, onClick, onInput)
 import Http
 import Util.Html exposing (KeyCode(..))
 import Util.Maybe
-import Util.Tag
 import Util.Update
 
 
@@ -44,8 +42,6 @@ import Util.Update
 type alias Model =
     { tagSelectModel : Comp.TagSelect.Model
     , tagSelection : Comp.TagSelect.Selection
-    , tagCatInclModel : Comp.Dropdown.Model String
-    , tagCatExclModel : Comp.Dropdown.Model String
     , directionModel : Comp.Dropdown.Model Direction
     , orgModel : Comp.Dropdown.Model IdName
     , corrPersonModel : Comp.Dropdown.Model IdName
@@ -74,8 +70,6 @@ init : Model
 init =
     { tagSelectModel = Comp.TagSelect.init []
     , tagSelection = Comp.TagSelect.emptySelection
-    , tagCatInclModel = Util.Tag.makeCatDropdownModel
-    , tagCatExclModel = Util.Tag.makeCatDropdownModel
     , directionModel =
         Comp.Dropdown.makeSingleList
             { makeOption =
@@ -158,8 +152,6 @@ type Msg
     | ToggleNameHelp
     | FolderSelectMsg Comp.FolderSelect.Msg
     | GetFolderResp (Result Http.Error FolderList)
-    | TagCatIncMsg (Comp.Dropdown.Msg String)
-    | TagCatExcMsg (Comp.Dropdown.Msg String)
 
 
 getDirection : Model -> Maybe Direction
@@ -194,8 +186,8 @@ getItemSearch model =
                 "*" ++ s ++ "*"
     in
     { e
-        | tagsInclude = model.tagSelection.include |> List.map .tag |> List.map .id
+        | tagsInclude = model.tagSelection.includeTags |> List.map .tag |> List.map .id
-        , tagsExclude = model.tagSelection.exclude |> List.map .tag |> List.map .id
+        , tagsExclude = model.tagSelection.excludeTags |> 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
@@ -217,8 +209,8 @@ getItemSearch model =
             model.allNameModel
                 |> Maybe.map amendWildcards
         , fullText = model.fulltextModel
-        , tagCategoriesInclude = Comp.Dropdown.getSelected model.tagCatInclModel
+        , tagCategoriesInclude = model.tagSelection.includeCats |> List.map .name
-        , tagCategoriesExclude = Comp.Dropdown.getSelected model.tagCatExclModel
+        , tagCategoriesExclude = model.tagSelection.excludeCats |> List.map .name
     }
 
 
@@ -286,10 +278,6 @@ update flags settings msg model =
 
         GetTagsResp (Ok tags) ->
             let
-                catList =
-                    Util.Tag.getCategories (List.map .tag tags.items)
-                        |> Comp.Dropdown.SetOptions
-
                 selectModel =
                     List.sortBy .count tags.items
                         |> List.reverse
@@ -298,12 +286,7 @@ update flags settings msg model =
                 model_ =
                     { model | tagSelectModel = selectModel }
             in
-            noChange <|
+            noChange ( model_, Cmd.none )
-                Util.Update.andThen1
-                    [ update flags settings (TagCatIncMsg catList) >> .modelCmd
-                    , update flags settings (TagCatExcMsg catList) >> .modelCmd
-                    ]
-                    model_
 
         GetTagsResp (Err _) ->
             noChange ( model, Cmd.none )
@@ -563,28 +546,6 @@ update flags settings msg model =
                 )
                 (model.selectedFolder /= sel)
 
-        TagCatIncMsg m ->
-            let
-                ( m2, c2 ) =
-                    Comp.Dropdown.update m model.tagCatInclModel
-            in
-            NextState
-                ( { model | tagCatInclModel = m2 }
-                , Cmd.map TagCatIncMsg c2
-                )
-                (isDropdownChangeMsg m)
-
-        TagCatExcMsg m ->
-            let
-                ( m2, c2 ) =
-                    Comp.Dropdown.update m model.tagCatExclModel
-            in
-            NextState
-                ( { model | tagCatExclModel = m2 }
-                , Cmd.map TagCatExcMsg c2
-                )
-                (isDropdownChangeMsg m)
-
 
 
 -- View
@@ -633,17 +594,7 @@ view flags settings model =
                     ]
                 ]
             ]
-        , formHeader (Icons.tagsIcon "") "Tags"
         , 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)
-            ]
-        , div [ class "field" ]
-            [ label [] [ text "Category Exclude (or)" ]
-            , Html.map TagCatExcMsg (Comp.Dropdown.view settings model.tagCatExclModel)
-            ]
-        , formHeader (Icons.folderIcon "") "Folder"
         , Html.map FolderSelectMsg
             (Comp.FolderSelect.view settings.searchMenuFolders model.folderList)
         , formHeaderHelp nameIcon "Names" ToggleNameHelp

modules/webapp/src/main/elm/Comp/TagSelect.elm

@@ -1,5 +1,6 @@
 module Comp.TagSelect exposing
-    ( Model
+    ( Category
+    , Model
     , Msg
     , Selection
     , emptySelection
@@ -19,84 +20,154 @@ import Html.Events exposing (onClick)
 
 type alias Model =
     { all : List TagCount
-    , selected : Dict String Bool
+    , categories : List Category
-    , expanded : Bool
+    , selectedTags : Dict String Bool
+    , selectedCats : Dict String Bool
+    , expandedTags : Bool
+    , expandedCats : Bool
+    }
+
+
+type alias Category =
+    { name : String
+    , count : Int
     }
 
 
 init : List TagCount -> Model
 init tags =
     { all = tags
-    , selected = Dict.empty
+    , categories = sumCategories tags
-    , expanded = False
+    , selectedTags = Dict.empty
+    , selectedCats = Dict.empty
+    , expandedTags = False
+    , expandedCats = False
     }
 
 
+sumCategories : List TagCount -> List Category
+sumCategories tags =
+    let
+        filterCat tc =
+            Maybe.map (\cat -> Category cat tc.count) tc.tag.category
+
+        withCats =
+            List.filterMap filterCat tags
+
+        sum cat mc =
+            Maybe.map ((+) cat.count) mc
+                |> Maybe.withDefault cat.count
+                |> Just
+
+        sumCounts cat dict =
+            Dict.update cat.name (sum cat) dict
+
+        cats =
+            List.foldl sumCounts Dict.empty withCats
+    in
+    Dict.toList cats
+        |> List.map (\( n, c ) -> Category n c)
+
+
 
 --- Update
 
 
 type Msg
-    = Toggle String
+    = ToggleTag String
-    | ToggleExpand
+    | ToggleCat String
+    | ToggleExpandTags
+    | ToggleExpandCats
 
 
 type alias Selection =
-    { include : List TagCount
+    { includeTags : List TagCount
-    , exclude : List TagCount
+    , excludeTags : List TagCount
+    , includeCats : List Category
+    , excludeCats : List Category
     }
 
 
 emptySelection : Selection
 emptySelection =
-    Selection [] []
+    Selection [] [] [] []
 
 
 update : Msg -> Model -> ( Model, Selection )
 update msg model =
     case msg of
-        Toggle id ->
+        ToggleTag id ->
             let
-                current =
-                    Dict.get id model.selected
-
                 next =
-                    case current of
+                    updateSelection id model.selectedTags
-                        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 }
+                    { model | selectedTags = next }
             in
             ( model_, getSelection model_ )
 
-        ToggleExpand ->
+        ToggleCat name ->
-            ( { model | expanded = not model.expanded }
+            let
+                next =
+                    updateSelection name model.selectedCats
+
+                model_ =
+                    { model | selectedCats = next }
+            in
+            ( model_, getSelection model_ )
+
+        ToggleExpandTags ->
+            ( { model | expandedTags = not model.expandedTags }
             , getSelection model
             )
 
+        ToggleExpandCats ->
+            ( { model | expandedCats = not model.expandedCats }
+            , getSelection model
+            )
+
+
+updateSelection : String -> Dict String Bool -> Dict String Bool
+updateSelection id selected =
+    let
+        current =
+            Dict.get id selected
+    in
+    case current of
+        Nothing ->
+            Dict.insert id True selected
+
+        Just True ->
+            Dict.insert id False selected
+
+        Just False ->
+            Dict.remove id selected
+
 
 getSelection : Model -> Selection
 getSelection model =
+    let
+        ( inclTags, exclTags ) =
+            getSelection1 (\t -> t.tag.id) model.selectedTags model.all
+
+        ( inclCats, exclCats ) =
+            getSelection1 (\c -> c.name) model.selectedCats model.categories
+    in
+    Selection inclTags exclTags inclCats exclCats
+
+
+getSelection1 : (a -> String) -> Dict String Bool -> List a -> ( List a, List a )
+getSelection1 mkId selected items =
     let
         selectedOnly t =
-            Dict.member t.tag.id model.selected
+            Dict.member (mkId t) selected
 
         isIncluded t =
-            Dict.get t.tag.id model.selected
+            Dict.get (mkId t) selected
                 |> Maybe.withDefault False
-
-        ( incl, excl ) =
-            List.filter selectedOnly model.all
-                |> List.partition isIncluded
     in
-    Selection incl excl
+    List.filter selectedOnly items
+        |> List.partition isIncluded
 
 
 
@@ -109,9 +180,22 @@ type SelState
     | Deselect
 
 
-selState : Model -> String -> SelState
+tagState : Model -> String -> SelState
-selState model id =
+tagState model id =
-    case Dict.get id model.selected of
+    case Dict.get id model.selectedTags of
+        Just True ->
+            Include
+
+        Just False ->
+            Exclude
+
+        Nothing ->
+            Deselect
+
+
+catState : Model -> String -> SelState
+catState model name =
+    case Dict.get name model.selectedCats of
         Just True ->
             Include
 
@@ -132,36 +216,72 @@ view settings model =
                     [ text "Tags"
                     ]
                 , div [ class "ui relaxed list" ]
-                    (List.map (viewItem settings model) model.all)
+                    (List.map (viewTagItem settings model) model.all)
+                ]
+            ]
+        , div [ class "item" ]
+            [ I.tagsIcon ""
+            , div [ class "content" ]
+                [ div [ class "header" ]
+                    [ text "Categories"
+                    ]
+                , div [ class "ui relaxed list" ]
+                    (List.map (viewCategoryItem settings model) model.categories)
                 ]
             ]
         ]
 
 
-viewItem : UiSettings -> Model -> TagCount -> Html Msg
+viewCategoryItem : UiSettings -> Model -> Category -> Html Msg
-viewItem settings model tag =
+viewCategoryItem settings model cat =
     let
         state =
-            selState model tag.tag.id
+            catState model cat.name
+
+        color =
+            Data.UiSettings.catColorString settings cat.name
+
+        icon =
+            getIcon state color I.tagsIcon
+    in
+    a
+        [ class "item"
+        , href "#"
+        , onClick (ToggleCat cat.name)
+        ]
+        [ icon
+        , div [ class "content" ]
+            [ div
+                [ classList
+                    [ ( "header", state == Include )
+                    , ( "description", state /= Include )
+                    ]
+                ]
+                [ text cat.name
+                , div [ class "ui right floated circular label" ]
+                    [ text (String.fromInt cat.count)
+                    ]
+                ]
+            ]
+        ]
+
+
+viewTagItem : UiSettings -> Model -> TagCount -> Html Msg
+viewTagItem settings model tag =
+    let
+        state =
+            tagState model tag.tag.id
 
         color =
             Data.UiSettings.tagColorString tag.tag settings
 
         icon =
-            case state of
+            getIcon state color I.tagIcon
-                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)
+        , onClick (ToggleTag tag.tag.id)
         ]
         [ icon
         , div [ class "content" ]
@@ -178,3 +298,16 @@ viewItem settings model tag =
                 ]
             ]
         ]
+
+
+getIcon : SelState -> String -> (String -> Html msg) -> Html msg
+getIcon state color default =
+    case state of
+        Include ->
+            i [ class ("check icon " ++ color) ] []
+
+        Exclude ->
+            i [ class ("minus icon " ++ color) ] []
+
+        Deselect ->
+            default color

modules/webapp/src/main/elm/Data/UiSettings.elm

@@ -2,6 +2,8 @@ module Data.UiSettings exposing
     ( Pos(..)
     , StoredUiSettings
     , UiSettings
+    , catColor
+    , catColorString
     , defaults
     , merge
     , mergeDefaults
@@ -133,13 +135,21 @@ toStoredUiSettings settings =
     }
 
 
+catColor : UiSettings -> String -> Maybe Color
+catColor settings c =
+    Dict.get c settings.tagCategoryColors
+
+
 tagColor : Tag -> UiSettings -> Maybe Color
 tagColor tag settings =
-    let
+    Maybe.andThen (catColor settings) tag.category
-        readColor c =
+
-            Dict.get c settings.tagCategoryColors
+
-    in
+catColorString : UiSettings -> String -> String
-    Maybe.andThen readColor tag.category
+catColorString settings name =
+    catColor settings name
+        |> Maybe.map Data.Color.toString
+        |> Maybe.withDefault ""
 
 
 tagColorString : Tag -> UiSettings -> String