From 5012c4e28497636590e8e5175b82f648403042e4 Mon Sep 17 00:00:00 2001 From: Matthias Date: Thu, 18 Jan 2024 09:44:22 +0100 Subject: [PATCH 1/6] improved hovercard in use --- elm.json.base | 6 +- src/Css/Browser.elm | 1 - src/Css/Graph.elm | 1 - src/Css/Header.elm | 3 +- src/Init.elm | 2 +- src/Init/Graph.elm | 1 + src/Init/Graph/Search.elm | 34 ++++++---- src/Init/Graph/Tag.elm | 43 ++++++++---- src/Model.elm | 5 +- src/Model/Graph.elm | 2 + src/Model/Graph/Search.elm | 3 +- src/Model/Graph/Tag.elm | 3 +- src/Msg/Graph.elm | 6 +- src/Sub.elm | 4 ++ src/Sub/Graph.elm | 7 ++ src/Update.elm | 58 +++++++++++----- src/Update/Graph.elm | 131 ++++++++++++++++++++----------------- src/Util/Css.elm | 7 +- src/Util/Graph/History.elm | 15 ++--- src/Util/View.elm | 10 +-- src/View.elm | 16 ++--- src/View/Graph.elm | 4 +- 22 files changed, 222 insertions(+), 140 deletions(-) diff --git a/elm.json.base b/elm.json.base index 9d95262a..14ac0491 100644 --- a/elm.json.base +++ b/elm.json.base @@ -7,7 +7,8 @@ "openapi/src", "themes", "config", - "lib/elm-autocomplete/src" + "lib/elm-autocomplete/src", + "lib/elm-hovercard/src" ], "elm-version": "0.19.1", "dependencies": { @@ -27,6 +28,7 @@ "elm/http": "2.0.0", "elm/json": "1.1.3", "elm/regex": "1.0.0", + "elm/svg": "1.0.1", "elm/time": "1.0.0", "elm/url": "1.0.0", "elm-community/basics-extra": "4.1.0", @@ -41,7 +43,6 @@ "jschomay/elm-bounded-number": "2.1.2", "krisajenkins/remotedata": "6.0.1", "lukewestby/elm-string-interpolate": "1.0.4", - "myrho/elm-hovercard": "3.0.0", "myrho/numeral-elm": "1.0.1", "myrho/yaml": "1.0.0", "noahzgordon/elm-color-extra": "1.0.2", @@ -55,7 +56,6 @@ "elm/bytes": "1.0.8", "elm/parser": "1.1.0", "elm/random": "1.0.0", - "elm/svg": "1.0.1", "elm/virtual-dom": "1.0.3", "elm-explorations/test": "1.2.2", "fredcy/elm-parseint": "2.0.1", diff --git a/src/Css/Browser.elm b/src/Css/Browser.elm index 48bc79d9..91ecab69 100644 --- a/src/Css/Browser.elm +++ b/src/Css/Browser.elm @@ -8,7 +8,6 @@ root : Config -> Float -> List Style root vc width = position absolute :: height (px 0) - :: (zIndex <| int 50) :: (maxWidth <| px width) :: vc.theme.browser.root diff --git a/src/Css/Graph.elm b/src/Css/Graph.elm index 1b9492fb..cc0fa441 100644 --- a/src/Css/Graph.elm +++ b/src/Css/Graph.elm @@ -215,7 +215,6 @@ searchTextarea vc = toolbox : Config -> Bool -> List Style toolbox vc visible = position absolute - :: Util.Css.zIndexMain :: vc.theme.graph.toolbox vc.lightmode visible diff --git a/src/Css/Header.elm b/src/Css/Header.elm index d96a1b92..06eed74a 100644 --- a/src/Css/Header.elm +++ b/src/Css/Header.elm @@ -2,6 +2,7 @@ module Css.Header exposing (..) import Config.View exposing (Config) import Css exposing (..) +import Util.Css header : Config -> List Style @@ -9,7 +10,7 @@ header vc = [ displayFlex , flexDirection row , justifyContent spaceBetween - , zIndex <| int 51 + , zIndex <| int <| Util.Css.zIndexMainValue + 1 ] ++ vc.theme.header vc.lightmode diff --git a/src/Init.elm b/src/Init.elm index 6c52d050..89e899c5 100644 --- a/src/Init.elm +++ b/src/Init.elm @@ -45,7 +45,7 @@ init plugins flags url key = , user = { apiKey = "" , auth = Unknown - , hovercardElement = Nothing + , hovercard = Nothing } , stats = NotAsked , width = flags.width diff --git a/src/Init/Graph.elm b/src/Init/Graph.elm index 06ae022d..733e0a7b 100644 --- a/src/Init/Graph.elm +++ b/src/Init/Graph.elm @@ -36,4 +36,5 @@ init us now = , history = History.init , highlights = Highlighter.init , selectIfLoaded = Nothing + , hovercard = Nothing } diff --git a/src/Init/Graph/Search.elm b/src/Init/Graph/Search.elm index a34b49cf..e41af16d 100644 --- a/src/Init/Graph/Search.elm +++ b/src/Init/Graph/Search.elm @@ -1,21 +1,31 @@ module Init.Graph.Search exposing (..) import Api.Data -import Browser.Dom as Dom -import Model.Graph.Id exposing (EntityId) +import Hovercard +import Model.Graph.Id exposing (EntityId, entityIdToString) import Model.Graph.Search exposing (..) +import Msg.Graph exposing (Msg(..)) +import Tuple exposing (mapSecond) -init : List Api.Data.Concept -> Dom.Element -> EntityId -> Model -init categories element entityId = - { direction = Outgoing - , criterion = initCriterion categories - , id = entityId - , element = element - , depth = "2" - , breadth = "20" - , maxAddresses = "100" - } +init : List Api.Data.Concept -> EntityId -> ( Model, Cmd Msg ) +init categories entityId = + let + ( hovercard, cmd ) = + entityIdToString entityId + |> Hovercard.init + |> mapSecond (Cmd.map SearchHovercardMsg) + in + ( { direction = Outgoing + , criterion = initCriterion categories + , id = entityId + , hovercard = hovercard + , depth = "2" + , breadth = "20" + , maxAddresses = "100" + } + , cmd + ) initCriterion : List Api.Data.Concept -> Criterion diff --git a/src/Init/Graph/Tag.elm b/src/Init/Graph/Tag.elm index 6ff2ec41..ab735b84 100644 --- a/src/Init/Graph/Tag.elm +++ b/src/Init/Graph/Tag.elm @@ -1,27 +1,46 @@ module Init.Graph.Tag exposing (..) import Browser.Dom as Dom +import Hovercard import Init.Search as Search import Model.Graph.Id exposing (..) import Model.Graph.Tag exposing (..) import Model.Node exposing (Node(..)) import Model.Search as Search +import Msg.Graph exposing (Msg(..)) +import Tuple exposing (mapSecond) -initAddressTag : AddressId -> Dom.Element -> Maybe UserTag -> Model -initAddressTag id element existing = - { input = initInput (Address id) existing - , existing = existing - , hovercardElement = element - } +initAddressTag : AddressId -> Maybe UserTag -> ( Model, Cmd Msg ) +initAddressTag id existing = + let + ( hovercard, cmd ) = + addressIdToString id + |> Hovercard.init + |> mapSecond (Cmd.map TagHovercardMsg) + in + ( { input = initInput (Address id) existing + , existing = existing + , hovercard = hovercard + } + , cmd + ) -initEntityTag : EntityId -> Dom.Element -> Maybe UserTag -> Model -initEntityTag id element existing = - { input = initInput (Entity id) existing - , existing = existing - , hovercardElement = element - } +initEntityTag : EntityId -> Maybe UserTag -> ( Model, Cmd Msg ) +initEntityTag id existing = + let + ( hovercard, cmd ) = + entityIdToString id + |> Hovercard.init + |> mapSecond (Cmd.map TagHovercardMsg) + in + ( { input = initInput (Entity id) existing + , existing = existing + , hovercard = hovercard + } + , cmd + ) initInput : Node AddressId EntityId -> Maybe UserTag -> Input diff --git a/src/Model.elm b/src/Model.elm index d32ee68c..2de1a0fa 100644 --- a/src/Model.elm +++ b/src/Model.elm @@ -10,6 +10,7 @@ import Effect.Api import Effect.Graph import Effect.Locale import Effect.Search +import Hovercard import Http import Json.Encode import Model.Dialog @@ -23,6 +24,7 @@ import Msg.Search import Plugin.Model as Plugin import Plugin.Msg as Plugin import RemoteData exposing (WebData) +import Theme.Hovercard exposing (Hovercard) import Time import Url exposing (Url) @@ -96,6 +98,7 @@ type Msg | GraphMsg Msg.Graph.Msg | PluginMsg Plugin.Msg | UserClickedExampleSearch String + | UserHovercardMsg Hovercard.Msg type RequestLimit @@ -111,7 +114,7 @@ showResetCounterAtRemaining = type alias UserModel = { auth : Auth , apiKey : String - , hovercardElement : Maybe Browser.Dom.Element + , hovercard : Maybe Hovercard.Model } diff --git a/src/Model/Graph.elm b/src/Model/Graph.elm index be8c444f..84d171ec 100644 --- a/src/Model/Graph.elm +++ b/src/Model/Graph.elm @@ -5,6 +5,7 @@ import Browser.Dom as Dom import Color import Config.Graph exposing (Config) import Dict exposing (Dict) +import Hovercard import IntDict exposing (IntDict) import Model.Address as A import Model.Entity as E @@ -41,6 +42,7 @@ type alias Model = , history : History.Model , highlights : Highlighter.Model , selectIfLoaded : Maybe SelectIfLoaded + , hovercard : Maybe Hovercard.Model } diff --git a/src/Model/Graph/Search.elm b/src/Model/Graph/Search.elm index e5d5f054..71b76d35 100644 --- a/src/Model/Graph/Search.elm +++ b/src/Model/Graph/Search.elm @@ -2,6 +2,7 @@ module Model.Graph.Search exposing (..) import Api.Data import Browser.Dom as Dom +import Hovercard import Model.Graph.Id exposing (EntityId) @@ -9,7 +10,7 @@ type alias Model = { direction : Direction , criterion : Criterion , id : EntityId - , element : Dom.Element + , hovercard : Hovercard.Model , depth : String , breadth : String , maxAddresses : String diff --git a/src/Model/Graph/Tag.elm b/src/Model/Graph/Tag.elm index 96f3a29a..c409d06d 100644 --- a/src/Model/Graph/Tag.elm +++ b/src/Model/Graph/Tag.elm @@ -2,6 +2,7 @@ module Model.Graph.Tag exposing (..) import Api.Data import Browser.Dom as Dom +import Hovercard import Model.Graph.Id exposing (AddressId, EntityId) import Model.Node exposing (Node) import Model.Search as Search @@ -10,7 +11,7 @@ import Model.Search as Search type alias Model = { input : Input , existing : Maybe UserTag - , hovercardElement : Dom.Element + , hovercard : Hovercard.Model } diff --git a/src/Msg/Graph.elm b/src/Msg/Graph.elm index 0fb3c482..4f727fd0 100644 --- a/src/Msg/Graph.elm +++ b/src/Msg/Graph.elm @@ -4,6 +4,7 @@ import Api.Data import Browser.Dom import Color import File +import Hovercard import Json.Encode import Model.Actor as Act import Model.Address as A @@ -105,8 +106,6 @@ type Msg | InternalGraphSelectedAddress AddressId | UserScrolledTable Browser.ScrollPos | TagSearchMsg Search.Msg - | BrowserGotAddressElementForAnnotate AddressId (Result Browser.Dom.Error Browser.Dom.Element) - | BrowserGotEntityElementForAnnotate EntityId (Result Browser.Dom.Error Browser.Dom.Element) | UserInputsTagSource String | UserInputsTagCategory String | UserInputsTagAbuse String @@ -127,7 +126,6 @@ type Msg | UserChangesAddressLabelType String | UserChangesTxLabelType String | UserClickedSearch EntityId - | BrowserGotEntityElementForSearch EntityId (Result Browser.Dom.Error Browser.Dom.Element) | UserSelectsDirection String | UserSelectsCriterion String | UserSelectsSearchCategory String @@ -176,3 +174,5 @@ type Msg | UserClickedToggleShowZeroTransactions | AnimationFrameDeltaForTransform Float | RuntimeDebouncedAddingEntities + | SearchHovercardMsg Hovercard.Msg + | TagHovercardMsg Hovercard.Msg diff --git a/src/Sub.elm b/src/Sub.elm index 7fdcc0b1..e03ab996 100644 --- a/src/Sub.elm +++ b/src/Sub.elm @@ -2,6 +2,7 @@ module Sub exposing (subscriptions) import Browser.Events import Browser.Navigation as Nav +import Hovercard import Model exposing (Model, Msg(..)) import Plugin.Sub as Plugin import Ports @@ -33,6 +34,9 @@ subscriptions model = _ -> Sub.none + , model.user.hovercard + |> Maybe.map (Hovercard.subscriptions >> Sub.map UserHovercardMsg) + |> Maybe.withDefault Sub.none , Plugin.subscriptions Ports.pluginsIn model.plugins |> Sub.map PluginMsg ] diff --git a/src/Sub/Graph.elm b/src/Sub/Graph.elm index daa86c96..22a8284e 100644 --- a/src/Sub/Graph.elm +++ b/src/Sub/Graph.elm @@ -1,6 +1,7 @@ module Sub.Graph exposing (subscriptions) import Browser.Events +import Hovercard import Json.Decode import Model.Graph exposing (Dragging(..), Model) import Msg.Graph exposing (Msg(..)) @@ -32,5 +33,11 @@ subscriptions model = ) ) , Transform.subscriptions model.transform + , model.tag + |> Maybe.map (.hovercard >> Hovercard.subscriptions >> Sub.map TagHovercardMsg) + |> Maybe.withDefault Sub.none + , model.search + |> Maybe.map (.hovercard >> Hovercard.subscriptions >> Sub.map SearchHovercardMsg) + |> Maybe.withDefault Sub.none ] |> Sub.batch diff --git a/src/Update.elm b/src/Update.elm index 8543dc0e..11251cc1 100644 --- a/src/Update.elm +++ b/src/Update.elm @@ -13,6 +13,7 @@ import Effect.Api import Effect.Graph as Graph import Effect.Locale as Locale import File.Download +import Hovercard import Http exposing (Error(..)) import Init.Graph import Init.Search as Search @@ -187,14 +188,40 @@ update plugins uc msg model = n model UserHoversUserIcon id -> - ( model - , GetElementEffect - { id = id - , msg = BrowserGotElement - } + let + ( hovercard, cmd ) = + Hovercard.init id + in + ( { model + | user = + model.user + |> s_hovercard (Just hovercard) + } + , Cmd.map UserHovercardMsg cmd + |> CmdEffect |> List.singleton ) + UserHovercardMsg hm -> + model.user.hovercard + |> Maybe.map + (\hovercard -> + let + ( hovercard_, cmd ) = + Hovercard.update hm hovercard + in + ( { model + | user = + model.user + |> s_hovercard (Just hovercard_) + } + , Cmd.map UserHovercardMsg cmd + |> CmdEffect + |> List.singleton + ) + ) + |> Maybe.withDefault (n model) + UserLeftUserHovercard -> { model | user = @@ -203,7 +230,7 @@ update plugins uc msg model = model.user _ -> - model.user |> s_hovercardElement Nothing + model.user |> s_hovercard Nothing } |> n @@ -275,12 +302,12 @@ update plugins uc msg model = else Unauthorized True [] ) - |> s_hovercardElement + |> s_hovercard (if List.isEmpty effs then Nothing else - model.user.hovercardElement + model.user.hovercard ) , plugins = new } @@ -289,14 +316,6 @@ update plugins uc msg model = ) |> updateByPluginOutMsg plugins outMsg - BrowserGotElement result -> - { model - | user = - model.user - |> s_hovercardElement (Result.toMaybe result) - } - |> n - BrowserGotContentsElement result -> result |> Result.map @@ -336,7 +355,7 @@ update plugins uc msg model = { model | user = model.user - |> s_hovercardElement Nothing + |> s_hovercard Nothing } TimeUpdateReset _ -> @@ -844,6 +863,9 @@ update plugins uc msg model = PluginMsg msgValue -> updatePlugins plugins msgValue model + BrowserGotElement _ -> + Debug.todo "branch 'BrowserGotElement _' not implemented" + updateByPluginOutMsg : Plugins -> List Plugin.OutMsg -> ( Model key, List Effect ) -> ( Model key, List Effect ) updateByPluginOutMsg plugins outMsgs ( mo, effects ) = @@ -1115,7 +1137,7 @@ handleResponse plugins uc result model = { model | user = updateRequestLimit headers model.user - |> s_hovercardElement Nothing + |> s_hovercard Nothing } Err ( BadStatus 401, eff ) -> diff --git a/src/Update/Graph.elm b/src/Update/Graph.elm index f97ef319..59d1afb2 100644 --- a/src/Update/Graph.elm +++ b/src/Update/Graph.elm @@ -19,6 +19,7 @@ import Effect.Graph exposing (Effect(..)) import Encode.Graph as Encode import File import File.Select +import Hovercard import Init.Graph.ContextMenu as ContextMenu import Init.Graph.Highlighter as Highlighter import Init.Graph.History as History @@ -1235,55 +1236,37 @@ updateByMsg plugins uc msg model = hideContextmenu model UserClickedAnnotateAddress id -> - ( model - , Id.addressIdToString id - |> Dom.getElement - |> Task.attempt (BrowserGotAddressElementForAnnotate id) - |> CmdEffect - |> List.singleton + let + ( tag, cmd ) = + model.layers + |> Layer.getAddress id + |> Maybe.andThen .userTag + |> Tag.initAddressTag id + in + ( { model + | tag = + tag + |> Just + } + , CmdEffect cmd |> List.singleton ) - BrowserGotAddressElementForAnnotate id element -> - element - |> Result.map - (\el -> - { model - | tag = - model.layers - |> Layer.getAddress id - |> Maybe.andThen .userTag - |> Tag.initAddressTag id el - |> Just - } - ) - |> Result.withDefault model - |> n - UserClickedAnnotateEntity id -> - ( model - , Id.entityIdToString id - |> Dom.getElement - |> Task.attempt (BrowserGotEntityElementForAnnotate id) - |> CmdEffect - |> List.singleton + let + ( tag, cmd ) = + model.layers + |> Layer.getEntity id + |> Maybe.andThen .userTag + |> Tag.initEntityTag id + in + ( { model + | tag = + tag + |> Just + } + , CmdEffect cmd |> List.singleton ) - BrowserGotEntityElementForAnnotate id element -> - element - |> Result.map - (\el -> - { model - | tag = - model.layers - |> Layer.getEntity id - |> Maybe.andThen .userTag - |> Tag.initEntityTag id el - |> Just - } - ) - |> Result.withDefault model - |> n - UserInputsTagSource input -> model.tag |> Maybe.map @@ -1712,25 +1695,17 @@ updateByMsg plugins uc msg model = |> n UserClickedSearch id -> - ( model - , Id.entityIdToString id - |> Dom.getElement - |> Task.attempt (BrowserGotEntityElementForSearch id) - |> CmdEffect + let + ( search, cmd ) = + Search.init model.config.entityConcepts id + in + ( { model + | search = search |> Just + } + , CmdEffect cmd |> List.singleton ) - BrowserGotEntityElementForSearch id result -> - result - |> Result.map - (\element -> - { model - | search = Search.init model.config.entityConcepts element id |> Just - } - ) - |> Result.withDefault model - |> n - UserSelectsDirection direction -> updateSearch (Search.selectDirection direction) model @@ -2236,6 +2211,42 @@ updateByMsg plugins uc msg model = } |> n + SearchHovercardMsg hm -> + model.search + |> Maybe.map + (\s -> + let + ( search, cmd ) = + Hovercard.update hm s.hovercard + in + ( { model + | search = s |> s_hovercard search |> Just + } + , Cmd.map SearchHovercardMsg cmd + |> CmdEffect + |> List.singleton + ) + ) + |> Maybe.withDefault (n model) + + TagHovercardMsg hm -> + model.tag + |> Maybe.map + (\s -> + let + ( tag, cmd ) = + Hovercard.update hm s.hovercard + in + ( { model + | tag = s |> s_hovercard tag |> Just + } + , Cmd.map TagHovercardMsg cmd + |> CmdEffect + |> List.singleton + ) + ) + |> Maybe.withDefault (n model) + NoOp -> n model diff --git a/src/Util/Css.elm b/src/Util/Css.elm index 4858d983..936f824b 100644 --- a/src/Util/Css.elm +++ b/src/Util/Css.elm @@ -5,4 +5,9 @@ import Css exposing (Style, int, zIndex) zIndexMain : Style zIndexMain = - zIndex <| int 50 + zIndex <| int zIndexMainValue + + +zIndexMainValue : Int +zIndexMainValue = + 50 diff --git a/src/Util/Graph/History.elm b/src/Util/Graph/History.elm index 84407ae6..2f8a66f5 100644 --- a/src/Util/Graph/History.elm +++ b/src/Util/Graph/History.elm @@ -242,12 +242,6 @@ shallPushHistory msg model = TagSearchMsg _ -> False - BrowserGotAddressElementForAnnotate _ _ -> - False - - BrowserGotEntityElementForAnnotate _ _ -> - False - UserInputsTagSource _ -> False @@ -305,9 +299,6 @@ shallPushHistory msg model = UserClickedSearch _ -> False - BrowserGotEntityElementForSearch _ _ -> - False - UserSelectsDirection _ -> False @@ -448,3 +439,9 @@ shallPushHistory msg model = RuntimeDebouncedAddingEntities -> False + + SearchHovercardMsg _ -> + False + + TagHovercardMsg _ -> + False diff --git a/src/Util/View.elm b/src/Util/View.elm index 59076f6e..f1d486ca 100644 --- a/src/Util/View.elm +++ b/src/Util/View.elm @@ -17,6 +17,7 @@ import Html.Styled.Attributes exposing (classList, css, src, title, value) import Html.Styled.Events exposing (onClick, stopPropagationOn) import Json.Decode import Switch +import Util.Css import View.Locale as Locale @@ -95,16 +96,15 @@ setAlpha alpha = >> Color.fromRgba -hovercard : View.Config -> Dom.Element -> List (Html.Html msg) -> List (Html.Styled.Html msg) +hovercard : View.Config -> Hovercard.Model -> List (Html.Html msg) -> List (Html.Styled.Html msg) hovercard vc element = Hovercard.hovercard - { maxWidth = 300 - , maxHeight = 500 - , tickLength = 0 + { tickLength = 16 + , zIndex = Util.Css.zIndexMainValue + 1 , borderColor = (vc.theme.hovercard vc.lightmode).borderColor , backgroundColor = (vc.theme.hovercard vc.lightmode).backgroundColor , borderWidth = (vc.theme.hovercard vc.lightmode).borderWidth - , overflow = "visible" + , viewport = vc.size } element (Css.hovercard vc diff --git a/src/View.elm b/src/View.elm index fdf74f09..55333dbb 100644 --- a/src/View.elm +++ b/src/View.elm @@ -15,6 +15,7 @@ import Model.Dialog as Dialog import Plugin.View as Plugin exposing (Plugins) import Route import Route.Graph +import Util.Css import Util.View exposing (hovercard) import View.Dialog as Dialog import View.Header as Header @@ -137,12 +138,12 @@ sidebar plugins vc model = hovercards : Plugins -> Config -> Model key -> List (Html Msg) hovercards plugins vc model = - model.user.hovercardElement + model.user.hovercard |> Maybe.map - (\element -> + (\hc -> User.hovercard plugins vc model model.user |> List.map Html.Styled.toUnstyled - |> hovercard vc element + |> hovercard { vc | size = Nothing } hc ) |> Maybe.withDefault [] @@ -160,17 +161,16 @@ overlay plugins vc model = in case model.user.auth of Unauthorized _ _ -> - model.user.hovercardElement + model.user.hovercard |> Maybe.map (\element -> Hovercard.hovercard - { maxWidth = 300 - , maxHeight = 500 - , tickLength = 0 + { tickLength = 0 + , zIndex = Util.Css.zIndexMainValue + 1 , borderColor = (vc.theme.hovercard vc.lightmode).borderColor , backgroundColor = (vc.theme.hovercard vc.lightmode).backgroundColor , borderWidth = (vc.theme.hovercard vc.lightmode).borderWidth - , overflow = "visible" + , viewport = Nothing } element (Css.View.hovercard vc diff --git a/src/View/Graph.elm b/src/View/Graph.elm index 10f3490d..e248741b 100644 --- a/src/View/Graph.elm +++ b/src/View/Graph.elm @@ -466,7 +466,7 @@ hovercards plugins states vc model = |> Html.Styled.toUnstyled |> List.singleton ) - |> hovercard vc tag.hovercardElement + |> hovercard vc tag.hovercard ) |> Maybe.withDefault [] ) @@ -477,7 +477,7 @@ hovercards plugins states vc model = |> Html.Styled.toUnstyled |> List.singleton ) - |> hovercard vc search.element + |> hovercard vc search.hovercard ) |> Maybe.withDefault [] ) From 73d8b1a057f197ce370ec46d8c43f4f8e7ccd929 Mon Sep 17 00:00:00 2001 From: Matthias Date: Thu, 18 Jan 2024 09:48:56 +0100 Subject: [PATCH 2/6] open user profile on click only --- src/Css/View.elm | 3 ++- src/Model.elm | 2 +- src/Update.elm | 34 +++++++++++++++++++--------------- src/View/User.elm | 13 +++---------- 4 files changed, 25 insertions(+), 27 deletions(-) diff --git a/src/Css/View.elm b/src/Css/View.elm index 9daf7654..922dacfe 100644 --- a/src/Css/View.elm +++ b/src/Css/View.elm @@ -89,7 +89,8 @@ contents vc = tool : Config -> List Style tool vc = - vc.theme.tool + cursor pointer + :: vc.theme.tool hovercard : Config -> List ( String, String ) diff --git a/src/Model.elm b/src/Model.elm index 2de1a0fa..24cde592 100644 --- a/src/Model.elm +++ b/src/Model.elm @@ -75,7 +75,7 @@ type Msg | UserSwitchesLocale String | UserSubmitsApiKeyForm | UserInputsApiKeyForm String - | UserHoversUserIcon String + | UserClickedUserIcon String | UserLeftUserHovercard | UserClickedLayout | UserClickedConfirm Msg diff --git a/src/Update.elm b/src/Update.elm index 11251cc1..08a134b3 100644 --- a/src/Update.elm +++ b/src/Update.elm @@ -187,20 +187,24 @@ update plugins uc msg model = _ -> n model - UserHoversUserIcon id -> - let - ( hovercard, cmd ) = - Hovercard.init id - in - ( { model - | user = - model.user - |> s_hovercard (Just hovercard) - } - , Cmd.map UserHovercardMsg cmd - |> CmdEffect - |> List.singleton - ) + UserClickedUserIcon id -> + if model.user.hovercard == Nothing then + let + ( hovercard, cmd ) = + Hovercard.init id + in + ( { model + | user = + model.user + |> s_hovercard (Just hovercard) + } + , Cmd.map UserHovercardMsg cmd + |> CmdEffect + |> List.singleton + ) + + else + n { model | user = model.user |> s_hovercard Nothing } UserHovercardMsg hm -> model.user.hovercard @@ -1155,7 +1159,7 @@ handleResponse plugins uc result model = } , "userTool" |> Task.succeed - |> Task.perform UserHoversUserIcon + |> Task.perform UserClickedUserIcon |> CmdEffect |> List.singleton ) diff --git a/src/View/User.elm b/src/View/User.elm index ae14a8ed..979986c8 100644 --- a/src/View/User.elm +++ b/src/View/User.elm @@ -23,13 +23,13 @@ user : Config -> UserModel -> Html Msg user vc model = div [ Css.root vc |> css + , Events.stopPropagationOn "click" (Json.Decode.succeed ( NoOp, True )) ] [ Button.tool vc { icon = FontAwesome.user } [ id "userTool" - , Events.onMouseOver (UserHoversUserIcon "userTool") - , Events.onClick (UserHoversUserIcon "userTool") + , Events.onClick (UserClickedUserIcon "userTool") ] ] @@ -90,14 +90,7 @@ hovercard plugins vc appModel model = [] ) |> div - [ Events.on "mouseleave" - (Json.Decode.oneOf - [ Json.Decode.at [ "relatedTarget" ] (Json.Decode.null False) - |> Json.Decode.map (\_ -> NoOp) - , Json.Decode.succeed UserLeftUserHovercard - ] - ) - , Events.stopPropagationOn "click" (Json.Decode.succeed ( NoOp, True )) + [ Events.stopPropagationOn "click" (Json.Decode.succeed ( NoOp, True )) , Css.hovercardRoot vc |> css ] |> List.singleton From 7acfc91aed5d53e5d0c20bbbe366b8ae37355235 Mon Sep 17 00:00:00 2001 From: Matthias Date: Thu, 18 Jan 2024 10:42:35 +0100 Subject: [PATCH 3/6] automatically reposition hovercard on drag/move/zoom --- src/Update/Graph.elm | 42 +++++++++++++++++++++++++++++++----------- 1 file changed, 31 insertions(+), 11 deletions(-) diff --git a/src/Update/Graph.elm b/src/Update/Graph.elm index 59d1afb2..29ad65c1 100644 --- a/src/Update/Graph.elm +++ b/src/Update/Graph.elm @@ -495,15 +495,16 @@ updateByMsg plugins uc msg model = |> n UserMovesMouseOnGraph coords -> - (case model.dragging of + case model.dragging of NoDragging -> - model + n model Dragging transform start _ -> { model | transform = Transform.update start coords transform , dragging = Dragging transform start coords } + |> repositionHovercards DraggingNode id start _ -> let @@ -516,26 +517,25 @@ updateByMsg plugins uc msg model = , dragging = DraggingNode id start coords } |> syncLinks (Set.singleton id) - ) - |> n + |> repositionHovercards UserReleasesMouseButton -> - (case model.dragging of + case model.dragging of NoDragging -> - model + n model - Dragging _ _ _ -> + Dragging _ start coords -> { model | dragging = NoDragging } + |> repositionHovercards - DraggingNode id _ _ -> + DraggingNode id start coords -> { model | layers = Layer.releaseEntity id model.layers , dragging = NoDragging } - ) - |> n + |> repositionHovercards UserPressesEscape -> deselectHighlighter model |> n @@ -2209,7 +2209,7 @@ updateByMsg plugins uc msg model = { model | transform = Transform.transition delta model.transform } - |> n + |> repositionHovercards SearchHovercardMsg hm -> model.search @@ -4127,3 +4127,23 @@ undoRedo fun model = ) |> Maybe.withDefault model |> n + + +repositionHovercards : Model -> ( Model, List Effect ) +repositionHovercards model = + [ repositionHovercardCmd model .tag TagHovercardMsg + , repositionHovercardCmd model .search SearchHovercardMsg + ] + |> List.map CmdEffect + |> pair model + + +repositionHovercardCmd : Model -> (Model -> Maybe { a | hovercard : Hovercard.Model }) -> (Hovercard.Msg -> Msg) -> Cmd Msg +repositionHovercardCmd model field toMsg = + field model + |> Maybe.map + (.hovercard + >> Hovercard.getElement + >> Cmd.map toMsg + ) + |> Maybe.withDefault Cmd.none From d16cfa9364319d7459b5ec56b6387d6f47b0a2bc Mon Sep 17 00:00:00 2001 From: Matthias Date: Thu, 18 Jan 2024 10:48:44 +0100 Subject: [PATCH 4/6] fix zIndex on hovercards --- src/Css/Graph.elm | 1 + src/Util/View.elm | 6 +++--- src/View.elm | 2 +- src/View/Graph.elm | 9 +++++++-- 4 files changed, 12 insertions(+), 6 deletions(-) diff --git a/src/Css/Graph.elm b/src/Css/Graph.elm index cc0fa441..41405864 100644 --- a/src/Css/Graph.elm +++ b/src/Css/Graph.elm @@ -53,6 +53,7 @@ svgRoot : Config -> List Style svgRoot vc = [ pct 100 |> width , property "color" "black" + , property "user-select" "none" ] ++ vc.theme.graph.svgRoot vc.lightmode diff --git a/src/Util/View.elm b/src/Util/View.elm index f1d486ca..1e9bd763 100644 --- a/src/Util/View.elm +++ b/src/Util/View.elm @@ -96,11 +96,11 @@ setAlpha alpha = >> Color.fromRgba -hovercard : View.Config -> Hovercard.Model -> List (Html.Html msg) -> List (Html.Styled.Html msg) -hovercard vc element = +hovercard : View.Config -> Hovercard.Model -> Int -> List (Html.Html msg) -> List (Html.Styled.Html msg) +hovercard vc element zIndex = Hovercard.hovercard { tickLength = 16 - , zIndex = Util.Css.zIndexMainValue + 1 + , zIndex = zIndex , borderColor = (vc.theme.hovercard vc.lightmode).borderColor , backgroundColor = (vc.theme.hovercard vc.lightmode).backgroundColor , borderWidth = (vc.theme.hovercard vc.lightmode).borderWidth diff --git a/src/View.elm b/src/View.elm index 55333dbb..0f824c43 100644 --- a/src/View.elm +++ b/src/View.elm @@ -143,7 +143,7 @@ hovercards plugins vc model = (\hc -> User.hovercard plugins vc model model.user |> List.map Html.Styled.toUnstyled - |> hovercard { vc | size = Nothing } hc + |> hovercard { vc | size = Nothing } hc (Util.Css.zIndexMainValue + 1) ) |> Maybe.withDefault [] diff --git a/src/View/Graph.elm b/src/View/Graph.elm index e248741b..cda10886 100644 --- a/src/View/Graph.elm +++ b/src/View/Graph.elm @@ -29,6 +29,7 @@ import Svg.Styled.Events as Svg exposing (..) import Svg.Styled.Keyed as Keyed import Svg.Styled.Lazy as Svg import Tuple exposing (..) +import Util.Css import Util.ExternalLinks exposing (getBlockExplorerLinks, getBlockExplorerTransactionLinks) import Util.Graph as Util import Util.View exposing (contextMenuRule, hovercard, none) @@ -454,6 +455,10 @@ contextMenu plugins states vc model cm = hovercards : Plugins -> ModelState -> Config -> Model -> List (Html Msg) hovercards plugins states vc model = + let + zIndex = + Util.Css.zIndexMainValue - 1 + in (model.tag |> Maybe.map (\tag -> @@ -466,7 +471,7 @@ hovercards plugins states vc model = |> Html.Styled.toUnstyled |> List.singleton ) - |> hovercard vc tag.hovercard + |> hovercard vc tag.hovercard zIndex ) |> Maybe.withDefault [] ) @@ -477,7 +482,7 @@ hovercards plugins states vc model = |> Html.Styled.toUnstyled |> List.singleton ) - |> hovercard vc search.hovercard + |> hovercard vc search.hovercard zIndex ) |> Maybe.withDefault [] ) From 54b9e844ca1d5393e95abd8bff9e13afe48498de Mon Sep 17 00:00:00 2001 From: Matthias Date: Thu, 18 Jan 2024 11:43:35 +0100 Subject: [PATCH 5/6] add elm-hovercard lib --- elm.json.base | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/elm.json.base b/elm.json.base index 14ac0491..875327cd 100644 --- a/elm.json.base +++ b/elm.json.base @@ -7,8 +7,7 @@ "openapi/src", "themes", "config", - "lib/elm-autocomplete/src", - "lib/elm-hovercard/src" + "lib/elm-autocomplete/src" ], "elm-version": "0.19.1", "dependencies": { @@ -43,6 +42,7 @@ "jschomay/elm-bounded-number": "2.1.2", "krisajenkins/remotedata": "6.0.1", "lukewestby/elm-string-interpolate": "1.0.4", + "myrho/elm-hovercard": "4.0.0", "myrho/numeral-elm": "1.0.1", "myrho/yaml": "1.0.0", "noahzgordon/elm-color-extra": "1.0.2", From 4825a09d75f1a0e1cfdf9d8553b1ff058c980af3 Mon Sep 17 00:00:00 2001 From: Matthias Date: Thu, 18 Jan 2024 11:49:06 +0100 Subject: [PATCH 6/6] adaption to lib, simplifications --- src/Util/View.elm | 5 ++--- src/View.elm | 20 +++++--------------- src/View/Graph.elm | 2 ++ 3 files changed, 9 insertions(+), 18 deletions(-) diff --git a/src/Util/View.elm b/src/Util/View.elm index 1e9bd763..7cf24c35 100644 --- a/src/Util/View.elm +++ b/src/Util/View.elm @@ -96,9 +96,9 @@ setAlpha alpha = >> Color.fromRgba -hovercard : View.Config -> Hovercard.Model -> Int -> List (Html.Html msg) -> List (Html.Styled.Html msg) +hovercard : View.Config -> Hovercard.Model -> Int -> List (Html.Html msg) -> Html.Styled.Html msg hovercard vc element zIndex = - Hovercard.hovercard + Hovercard.view { tickLength = 16 , zIndex = zIndex , borderColor = (vc.theme.hovercard vc.lightmode).borderColor @@ -111,7 +111,6 @@ hovercard vc element zIndex = |> List.map (\( k, v ) -> Html.Attributes.style k v) ) >> Html.Styled.fromUnstyled - >> List.singleton switch : View.Config -> List (Attribute msg) -> String -> Html msg diff --git a/src/View.elm b/src/View.elm index 0f824c43..b62d1100 100644 --- a/src/View.elm +++ b/src/View.elm @@ -144,6 +144,7 @@ hovercards plugins vc model = User.hovercard plugins vc model model.user |> List.map Html.Styled.toUnstyled |> hovercard { vc | size = Nothing } hc (Util.Css.zIndexMainValue + 1) + |> List.singleton ) |> Maybe.withDefault [] @@ -163,21 +164,10 @@ overlay plugins vc model = Unauthorized _ _ -> model.user.hovercard |> Maybe.map - (\element -> - Hovercard.hovercard - { tickLength = 0 - , zIndex = Util.Css.zIndexMainValue + 1 - , borderColor = (vc.theme.hovercard vc.lightmode).borderColor - , backgroundColor = (vc.theme.hovercard vc.lightmode).backgroundColor - , borderWidth = (vc.theme.hovercard vc.lightmode).borderWidth - , viewport = Nothing - } - element - (Css.View.hovercard vc - |> List.map (\( k, v ) -> Html.Attributes.style k v) - ) - (User.hovercard plugins vc model model.user |> List.map Html.Styled.toUnstyled) - |> Html.Styled.fromUnstyled + (\hc -> + User.hovercard plugins vc model model.user + |> List.map Html.Styled.toUnstyled + |> hovercard { vc | size = Nothing } hc (Util.Css.zIndexMainValue + 1) ) |> Maybe.map (ov NoOp) |> Maybe.withDefault [] diff --git a/src/View/Graph.elm b/src/View/Graph.elm index cda10886..1699316c 100644 --- a/src/View/Graph.elm +++ b/src/View/Graph.elm @@ -472,6 +472,7 @@ hovercards plugins states vc model = |> List.singleton ) |> hovercard vc tag.hovercard zIndex + |> List.singleton ) |> Maybe.withDefault [] ) @@ -483,6 +484,7 @@ hovercards plugins states vc model = |> List.singleton ) |> hovercard vc search.hovercard zIndex + |> List.singleton ) |> Maybe.withDefault [] )