From 20a5c81708ee9b91c18ac61b5307b9dcc55a95f7 Mon Sep 17 00:00:00 2001 From: Martin Date: Wed, 8 May 2024 16:53:23 +0200 Subject: [PATCH] [Primitives] Rework dropdown This commit reworks the dropdown implementation. The old implementation did not allow users to define an explicit order of the values (amap only). Also the custom TriggerDropdown, DropdownConfig, and DropdownMode types were unwieldy. The new API provides a few variants with simple parameters. --- .../Aardvark.UI.Primitives.fsproj | 1 + .../Primitives/SimplePrimitives.fs | 455 ++++++++++-------- .../Primitives/UI.Primitives.Simple.fs | 28 +- .../resources/dropdown.js | 40 ++ src/Aardvark.UI/Core.fs | 248 +++++----- src/Examples (dotnetcore)/23 - Inputs/App.fs | 13 +- .../28 - Notifications/App.fs | 29 +- src/Scratch/02 - DrawRects/App.fs | 2 +- src/Scratch/27 - NavigationDemoNew/App.fs | 4 +- src/Scratch/27 - NavigationDemoNew/Program.fs | 1 + 10 files changed, 444 insertions(+), 377 deletions(-) create mode 100644 src/Aardvark.UI.Primitives/resources/dropdown.js diff --git a/src/Aardvark.UI.Primitives/Aardvark.UI.Primitives.fsproj b/src/Aardvark.UI.Primitives/Aardvark.UI.Primitives.fsproj index 6c928747..d1f294b7 100644 --- a/src/Aardvark.UI.Primitives/Aardvark.UI.Primitives.fsproj +++ b/src/Aardvark.UI.Primitives/Aardvark.UI.Primitives.fsproj @@ -87,6 +87,7 @@ + diff --git a/src/Aardvark.UI.Primitives/Primitives/SimplePrimitives.fs b/src/Aardvark.UI.Primitives/Primitives/SimplePrimitives.fs index 0d544958..569d417c 100644 --- a/src/Aardvark.UI.Primitives/Primitives/SimplePrimitives.fs +++ b/src/Aardvark.UI.Primitives/Primitives/SimplePrimitives.fs @@ -5,6 +5,8 @@ open Aardvark.UI open FSharp.Data.Adaptive open Aardvark.UI.Generic +#nowarn "44" // TODO: Remove old dropdown stuff + [] module SimplePrimitives = open System @@ -167,6 +169,223 @@ module SimplePrimitives = module TextConfig = let empty = { regex = None; maxLength = None } + // TODO: Add [] + module Dropdown = + + [] + type DropdownValues<'T, 'msg> = + | List of alist<'T * DomNode<'msg>> + | Map of amap<'T, DomNode<'msg>> + + module DropdownInternals = + + [] + type DropdownValueConverter() = + static member inline ToDropdownValues (values: DropdownValues<'T, 'msg>) = values + static member inline ToDropdownValues (values: alist<'T * DomNode<'msg>>) = DropdownValues.List values + static member inline ToDropdownValues (values: amap<'T, DomNode<'msg>>) = DropdownValues.Map values + static member inline ToDropdownValues (values: seq<'T * DomNode<'msg>>) = DropdownValues.List <| AList.ofSeq values + static member inline ToDropdownValues (values: array<'T * DomNode<'msg>>) = DropdownValues.List <| AList.ofArray values + static member inline ToDropdownValues (values: list<'T * DomNode<'msg>>) = DropdownValues.List <| AList.ofList values + + let inline private toDropdownValuesAux (_: ^Converter) (values: ^Values) = + ((^Converter or ^Values) : (static member ToDropdownValues : ^Values -> DropdownValues<'T, 'msg>) (values)) + + let inline toDropdownValues (values: ^Values) : DropdownValues<'T, 'msg> = + toDropdownValuesAux Unchecked.defaultof values + + let inline getEnumValues<'T, 'U, 'msg when 'T : enum<'U>> (toNode: Option<'T -> DomNode<'msg>>) : array<'T * DomNode<'msg>> = + let values = Enum.GetValues typeof<'T> |> unbox<'T[]> + let nodes = + match toNode with + | Some f -> values |> Array.map f + | _ -> Enum.GetNames typeof<'T> |> Array.map text + + Array.zip values nodes + + let private pickler = MBrace.FsPickler.FsPickler.CreateBinarySerializer() + + let private dropdownImpl (update: 'T list -> 'msg) (activateOnHover: bool) (placeholder: string option) (multiSelect: bool) (icon: string option) + (selected: alist<'T>) (attributes: AttributeMap<'msg>) (values: DropdownValues<'T, 'msg>) = + let dependencies = + Html.semui @ [ { name = "dropdown"; url = "resources/dropdown.js"; kind = Script }] + + let valuesWithKeys = + let sortedValues = + match values with + | DropdownValues.List list -> list + | DropdownValues.Map map -> + let cmp = + if typeof.IsAssignableFrom typeof<'T> then Unchecked.compare<'T> + else fun _ _ -> -1 + + map |> AMap.toASet |> ASet.sortWith (fun (a, _) (b, _) -> cmp a b) + + sortedValues + |> AList.map (fun (key, node) -> + let hash = pickler.ComputeHash(key).Hash |> Convert.ToBase64String + key, hash, node + ) + + let lookup = + valuesWithKeys + |> AList.toAVal + |> AVal.map (fun values -> + let forward = values |> IndexList.map (fun (key, hash, _) -> struct (key, hash)) |> HashMap.ofSeqV + let backward = values |> IndexList.map (fun (key, hash, _) -> struct (hash, key)) |> HashMap.ofSeqV + forward, backward + ) + + let update (args : string list) = + try + let data : string = Pickler.unpickleOfJson args.Head + let _fw, bw = AVal.force lookup + + let values = + data + |> String.split "," + |> Array.toList + |> List.choose (fun k -> HashMap.tryFind k bw) + + Seq.singleton (update values) + + with exn -> + Log.warn "[Dropdown] callback failed: %s" exn.Message + Seq.empty + + let selection = + adaptive { + let! selected = selected |> AList.toAVal + let! fw, _bw = lookup + + return selected + |> IndexList.choose (fun v -> HashMap.tryFind v fw) + |> IndexList.toList + } + + let attributes = + let disableClazz clazz disabled = + if disabled then AttributeMap.removeClass clazz + else id + + let toggleClazz clazz enabled = + if enabled then AttributeMap.addClass clazz + else AttributeMap.removeClass clazz + + let attributes = + attributes + |> toggleClazz "multiple" multiSelect + |> toggleClazz "selection" icon.IsNone + |> disableClazz "clearable" placeholder.IsNone + + AttributeMap.ofList [ + clazz "ui dropdown" + onEvent' "data-event" [] update + ] + |> AttributeMap.union attributes + + let boot = + let trigger = if activateOnHover then "'hover'" else "'click'" + + String.concat "" [ + "const $self = $('#__ID__');" + $"aardvark.dropdown($self, {trigger}, channelSelection);" + ] + + require dependencies ( + onBoot' ["channelSelection", AVal.channel selection] boot ( + Incremental.div attributes <| AList.ofList [ + input [ attribute "type" "hidden" ] + + match icon with + | Some icon -> + i [ clazz (sprintf "%s icon" icon)] [] + | _ -> + i [ clazz "dropdown icon" ] [] + div [ clazz "default text"] (placeholder |> Option.defaultValue "") + + Incremental.div (AttributeMap.ofList [clazz "menu"]) <| alist { + for (_, hash, node) in valuesWithKeys do + yield div [ clazz "ui item"; attribute "data-value" hash] [node] + } + ] + ) + ) + + let private dropdownOptionImpl (update: 'T option -> 'msg) (activateOnHover: bool) (icon: string option) (placeholder: string) + (selected: aval<'T option>) (attributes: AttributeMap<'msg>) (values: DropdownValues<'T, 'msg>) = + let selected = selected |> AVal.map Option.toList |> AList.ofAVal + let update = List.tryHead >> update + dropdownImpl update activateOnHover (Some placeholder) false icon selected attributes values + + let private dropdownSingleImpl (update: 'T -> 'msg) (activateOnHover: bool) (icon: string option) + (selected: aval<'T>) (attributes: AttributeMap<'msg>) (values: DropdownValues<'T, 'msg>) = + let selected = selected |> AVal.map List.singleton |> AList.ofAVal + let update = List.head >> update + dropdownImpl update activateOnHover None false icon selected attributes values + + /// Dropdown menu for a collection of values. Multiple items can be selected at a time. + let dropdownMultiSelect (update: 'T list -> 'msg) (activateOnHover: bool) (placeholder: string) + (selected: alist<'T>) (attributes: AttributeMap<'msg>) (values: DropdownValues<'T, 'msg>) = + dropdownImpl update activateOnHover (Some placeholder) true None selected attributes values + + /// Dropdown menu for a collection of values. At most a single item can be selected at a time. + let dropdownOption (update: 'T option -> 'msg) (activateOnHover: bool) (icon: string option) (placeholder: string) + (selected: aval<'T option>) (attributes: AttributeMap<'msg>) (values: DropdownValues<'T, 'msg>) = + dropdownOptionImpl update activateOnHover icon placeholder selected attributes values + + /// Dropdown menu for a collection of values. + let dropdown (update: 'T -> 'msg) (activateOnHover: bool) (icon: string option) + (selected: aval<'T>) (attributes: AttributeMap<'msg>) (values: DropdownValues<'T, 'msg>) = + dropdownSingleImpl update activateOnHover icon selected attributes values + + + /// Dropdown menu for a collection of values. Multiple items can be selected at a time. + /// The attributes can be provided as AttributeMap, amap, alist, or sequence of (conditional) attributes. + /// The values can be provided as alist, amap, or sequence of keys with DOM nodes. + let inline dropdownMultiSelect (update: 'T list -> 'msg) (activateOnHover: bool) (placeholder: string) + (selected: alist<'T>) attributes values = + let values: DropdownValues<'T, 'msg> = DropdownInternals.toDropdownValues values + DropdownInternals.dropdownMultiSelect update activateOnHover placeholder selected (att attributes) values + + /// Dropdown menu for an enumeration type. Multiple items can be selected at a time. + /// The attributes can be provided as AttributeMap, amap, alist, or sequence of (conditional) attributes. + /// The displayed values are derived from the enumeration value names, if the values argument is None. + let inline dropdownEnumMultiSelect (update: 'T list -> 'msg) (activateOnHover: bool) (placeholder: string) + (selected: alist<'T>) attributes values = + let values = DropdownInternals.getEnumValues<'T, _, 'msg> values |> DropdownInternals.toDropdownValues + dropdownMultiSelect update activateOnHover placeholder selected attributes values + + /// Dropdown menu for a collection of values. At most a single item can be selected at a time. + /// The attributes can be provided as AttributeMap, amap, alist, or sequence of (conditional) attributes. + /// The values can be provided as alist, amap, or sequence of keys with DOM nodes. + let inline dropdownOption (update: 'T option -> 'msg) (activateOnHover: bool) (icon: string option) (placeholder: string) + (selected: aval<'T option>) attributes values = + let values: DropdownValues<'T, 'msg> = DropdownInternals.toDropdownValues values + DropdownInternals.dropdownOption update activateOnHover icon placeholder selected (att attributes) values + + /// Dropdown menu for an enumeration type. At most a single item can be selected at a time. + /// The attributes can be provided as AttributeMap, amap, alist, or sequence of (conditional) attributes. + /// The displayed values are derived from the enumeration value names, if the values argument is None. + let inline dropdownEnumOption (update: 'T option -> 'msg) (activateOnHover: bool) (icon: string option) (placeholder: string) + (selected: aval<'T option>) attributes values = + let values = DropdownInternals.getEnumValues<'T, _, 'msg> values + dropdownOption update activateOnHover icon placeholder selected attributes values + + /// Dropdown menu for a collection of values. + /// The attributes can be provided as AttributeMap, amap, alist, or sequence of (conditional) attributes. + /// The values can be provided as alist, amap, or sequence of keys with DOM nodes. + let inline dropdown (update: 'T -> 'msg) (activateOnHover: bool) (icon: string option) (selected: aval<'T>) attributes values = + let values: DropdownValues<'T, 'msg> = DropdownInternals.toDropdownValues values + DropdownInternals.dropdown update activateOnHover icon selected (att attributes) values + + /// Dropdown menu for a an enumeration type. + /// The attributes can be provided as AttributeMap, amap, alist, or sequence of (conditional) attributes. + /// The displayed values are derived from the enumeration value names, if the values argument is None. + let inline dropdownEnum (update: 'T -> 'msg) (activateOnHover: bool) (icon: string option) (selected: aval<'T>) attributes values = + let values = DropdownInternals.getEnumValues<'T, _, 'msg> values + dropdown update activateOnHover icon selected attributes values + module Incremental = [] @@ -354,7 +573,7 @@ module SimplePrimitives = ) ) ) - + let textarea (cfg : TextAreaConfig) (atts : AttributeMap<'msg>) (value : aval) (update : string -> 'msg) = let value = if value.IsConstant then AVal.custom (fun t -> value.GetValue t) else value let update v = @@ -381,7 +600,7 @@ module SimplePrimitives = alist { yield textarea (att [ - match cfg.placeholder with + match cfg.placeholder with | Some ph when ph<>"" -> yield attribute "placeholder" ph | _ -> () yield attribute "type" "text" @@ -391,221 +610,39 @@ module SimplePrimitives = ) ) - let private pickler = MBrace.FsPickler.FsPickler.CreateBinarySerializer() - + [] let dropdown (cfg : DropdownConfig) (atts : AttributeMap<'msg>) (values : amap<'a, DomNode<'msg>>) (selected : aval>) (update : Option<'a> -> 'msg) = + let activateOnHover = cfg.onTrigger = TriggerDropdown.Hover - let selected = if selected.IsConstant then AVal.custom (fun t -> selected.GetValue t) else selected + match cfg.mode with + | DropdownMode.Icon icon -> + Dropdown.dropdownOption update activateOnHover (Some icon) "" selected atts values - let compare = - if typeof.IsAssignableFrom typeof<'a> then Some Unchecked.compare<'a> - else None - - let valuesWithKeys = - values - |> AMap.map (fun k v -> - let hash = pickler.ComputeHash(k).Hash |> System.Convert.ToBase64String - //let hash = System.Threading.Interlocked.Increment(&id) |> string - hash, v - ) - - let m = - valuesWithKeys - |> AMap.toAVal - |> AVal.map (HashMap.map (fun k (v,_) -> v)) - |> AVal.map (fun m -> m, HashMap.ofSeq (Seq.map (fun (a,b) -> b,a) m)) - - let update (k : string) = - let _fw, bw = AVal.force m - selected.MarkOutdated() - try - match HashMap.tryFind k bw with - | Some v -> update (Some v) |> Seq.singleton - | None -> update None |> Seq.singleton - with _ -> - Seq.empty + | DropdownMode.Text (Some placeholder) -> + let atts = AttributeMap.union atts (AttributeMap.ofList [clazz "clearable"]) + Dropdown.dropdownOption update activateOnHover None placeholder selected atts values - let selection = - selected |> AVal.bind (function Some v -> m |> AVal.map (fun (fw,_) -> HashMap.tryFind v fw) | None -> AVal.constant None) - - let myAtts = - AttributeMap.ofList [ - clazz "ui dropdown" - onEvent' "data-event" [] (function (str :: _) -> Seq.delay (fun () -> update (Pickler.unpickleOfJson str)) | _ -> Seq.empty) - ] - - let initial = - match selection.GetValue() with - | Some v -> sprintf ".dropdown('set selected', '%s', '', true);" v - | None -> ".dropdown('clear');" - - let boot = - let trigger = - match cfg.onTrigger with - | TriggerDropdown.Click -> "'click'" // default - | TriggerDropdown.Hover -> "'hover'" - - let clearable = - match cfg.mode with - | DropdownMode.Text (Some _) -> "true" - | _ -> "false" - - String.concat ";" [ - "var $self = $('#__ID__');" - "$self.dropdown({ on: " + trigger + ", clearable: " + clearable + ", onChange: function(value) { aardvark.processEvent('__ID__', 'data-event', value); }, onHide : function() { var v = $self.dropdown('get value'); if(!v || v.length == 0) { $self.dropdown('clear'); } } })" + initial - "selectedCh.onmessage = function(value) { if(value.value) { $self.dropdown('set selected', value.value.Some, '', true); } else { $self.dropdown('clear'); } }; " - ] - - require Html.semui ( - onBoot' ["selectedCh", AVal.channel (AVal.map thing selection)] boot ( - Incremental.div (AttributeMap.union atts myAtts) ( - alist { - yield input [ attribute "type" "hidden" ] - match cfg.mode with - | DropdownMode.Text ph -> - let ph = ph |> Option.defaultValue "" - yield i [ clazz "dropdown icon" ] [] - yield div [ clazz "default text"] ph - | DropdownMode.Icon iconName -> - yield i [ clazz (sprintf "%s icon" iconName)] [] - yield - Incremental.div (AttributeMap.ofList [clazz "ui menu"]) ( - alist { - match compare with - | Some cmp -> - for (_, (value, node)) in valuesWithKeys |> AMap.toASet |> ASet.sortWith (fun (a,_) (b,_) -> cmp a b) do - yield div [ clazz "ui item"; attribute "data-value" value] [node] - | None -> - for (_, (value, node)) in valuesWithKeys |> AMap.toASet |> ASet.sortBy (snd >> fst) do - yield div [ clazz "ui item"; attribute "data-value" value] [node] - } - ) - } - ) - ) - ) + | DropdownMode.Text None -> + Dropdown.dropdownOption update activateOnHover None "" selected atts values + [] let dropdownUnclearable (atts : AttributeMap<'msg>) (values : amap<'a, DomNode<'msg>>) (selected : aval<'a>) (update : 'a -> 'msg) = - dropdown DropdownConfig.unclearable atts values (AVal.map Some selected) (Option.get >> update) + Dropdown.dropdown update false None selected atts values - [] + [] let dropdownUnClearable (atts : AttributeMap<'msg>) (values : amap<'a, DomNode<'msg>>) (selected : aval<'a>) (update : 'a -> 'msg) = - dropdown DropdownConfig.unclearable atts values (AVal.map Some selected) (Option.get >> update) + Dropdown.dropdown update false None selected atts values + [] let dropdownMultiSelect (attributes : AttributeMap<'msg>) (compare : Option<'T -> 'T -> int>) (defaultText : string) (values : amap<'T, DomNode<'msg>>) (selected : alist<'T>) (update : 'T list -> 'msg) = - let valuesWithKeys = - values - |> AMap.map (fun k v -> - let hash = pickler.ComputeHash(k).Hash |> Convert.ToBase64String - hash, v - ) - - let lookup = - valuesWithKeys - |> AMap.toAVal - |> AVal.map (HashMap.map (fun k (v,_) -> v)) - |> AVal.map (fun m -> m, HashMap.ofSeq (Seq.map (fun (a,b) -> b,a) m)) - - let items = - let set = valuesWithKeys |> AMap.toASet - - let compare = - compare |> Option.orElse ( - if typeof.IsAssignableFrom typeof<'T> then - Some Unchecked.compare<'T> - else - None - ) - - match compare with - | Some cmp -> - set |> ASet.sortWith (fun (a,_) (b,_) -> cmp a b) - | _ -> - set |> ASet.sortBy (snd >> fst) - - let update (args : string list) = - try - let data : string = Pickler.unpickleOfJson args.Head - let _fw, bw = AVal.force lookup - - let values = - data - |> String.split "," - |> Array.toList - |> List.choose (fun k -> HashMap.tryFind k bw) - - Seq.singleton (update values) - - with exn -> - Log.warn "[dropdownMultiSelect] callback failed: %s" exn.Message - Seq.empty - - let selection = - adaptive { - let! selected = selected |> AList.toAVal - let! (fw, _) = lookup - - return selected - |> IndexList.choose (fun v -> HashMap.tryFind v fw) - |> IndexList.toList - } - - let attributes = - AttributeMap.ofList [ - clazz "ui dropdown multiple selection" - onEvent' "data-event" [] update - ] - |> AttributeMap.union attributes - - let boot = - String.concat "" [ - "const $self = $('#__ID__');" - - "$self.dropdown({" - " onChange: function(value) { aardvark.processEvent('__ID__', 'data-event', value); }," - "});" - - // God I hate JS... - // https://stackoverflow.com/questions/7837456/how-to-compare-arrays-in-javascript/7837725#7837725 - "function arraysIdentical(a, b) {" - " var i = a.length;" - " if (i != b.length) return false;" - " while (i--) {" - " if (a[i] !== b[i]) return false;" - " }" - " return true;" - "};" - - "selectedCh.onmessage = function(values) {" - " const curr = $self.dropdown('get values');" - - // Prevent resetting the same values (leads to flickering) - " if (arraysIdentical(curr, values)) {" - " return;" - " }" - - " $self.dropdown('clear', true);" - " $self.dropdown('set selected', values, true);" // set exactly bugged? clear seems to trigger event - "};" - ] - - require Html.semui ( - onBoot' ["selectedCh", AVal.channel selection] boot ( - Incremental.div attributes <| AList.ofList [ - input [ attribute "type" "hidden" ] - - i [ clazz "dropdown icon" ] [] - div [ clazz "default text"] defaultText - - Incremental.div (AttributeMap.ofList [clazz "ui menu"]) <| alist { - for (_, (value, node)) in items do - yield div [ clazz "ui item"; attribute "data-value" value] [node] - } - ] - ) - ) + match compare with + | Some cmp -> + let values = values |> AMap.toASet |> ASet.sortWith (fun (a, _) (b, _) -> cmp a b) + Dropdown.dropdownMultiSelect update false defaultText selected attributes values + | _ -> + Dropdown.dropdownMultiSelect update false defaultText selected attributes values [] type private AccordionInput<'msg> = @@ -943,6 +980,7 @@ module SimplePrimitives = member inline x.Run((a,v : aval<_>,cfg,msg)) = Incremental.textbox cfg a v msg + [] type DropdownBuilder() = member inline x.Yield(()) = @@ -973,6 +1011,8 @@ module SimplePrimitives = let simplenumeric<'a> = NumericBuilder<'a>() let simplenumeric'<'T> = NumericBuilder2<'T>() let simpletextbox = TextBuilder() + + [] let simpledropdown = DropdownBuilder() @@ -991,16 +1031,19 @@ module SimplePrimitives = let inline textarea (cfg : TextAreaConfig) atts (state : aval) (update : string -> 'msg) = Incremental.textarea cfg (att atts) state update + [] let inline dropdown (cfg : DropdownConfig) atts (values : amap<'a, DomNode<'msg>>) (selected : aval>) (update : Option<'a> -> 'msg) = Incremental.dropdown cfg (att atts) values selected update + [] let inline dropdownUnclearable atts (values : amap<'a, DomNode<'msg>>) (selected : aval<'a>) (update : 'a -> 'msg) = Incremental.dropdownUnclearable (att atts) values selected update - [] + [] let inline dropdownUnClearable atts (values : amap<'a, DomNode<'msg>>) (selected : aval<'a>) (update : 'a -> 'msg) = Incremental.dropdownUnclearable (att atts) values selected update + [] let inline dropdownMultiSelect (attributes : AttributeMap<'msg>) (compare : Option<'T -> 'T -> int>) (defaultText : string) (values : amap<'T, DomNode<'msg>>) (selected : alist<'T>) (update : 'T list -> 'msg) = diff --git a/src/Aardvark.UI.Primitives/Primitives/UI.Primitives.Simple.fs b/src/Aardvark.UI.Primitives/Primitives/UI.Primitives.Simple.fs index 8f7c85b0..e77adb87 100644 --- a/src/Aardvark.UI.Primitives/Primitives/UI.Primitives.Simple.fs +++ b/src/Aardvark.UI.Primitives/Primitives/UI.Primitives.Simple.fs @@ -215,31 +215,11 @@ module Simple = let largeTextArea (changed : string -> 'msg) (value : aval) = largeTextArea' changed value AttributeMap.empty + [] let dropDown<'a, 'msg when 'a : comparison and 'a : equality> (att : list>) (current : aval<'a>) (update : 'a -> 'msg) (names : Map<'a, string>) : DomNode<'msg> = - - let mutable back = Map.empty - let forth = - names |> Map.map (fun a s -> - let id = System.Guid.NewGuid() - back <- Map.add id a back - id - ) - - let selectedValue = current |> AVal.map (fun c -> Map.find c forth) - - let boot = - String.concat "\r\n" [ - sprintf "$('#__ID__').dropdown().dropdown('set selected', '%s');" (string (AVal.force selectedValue)) - "current.onmessage = function(v) { $('#__ID__').dropdown('set selected', v); };" - ] - - onBoot' ["current", AVal.channel selectedValue] boot ( - select ((onChange (fun str -> Map.find (str |> System.Guid.Parse) back |> update))::att) [ - for (value, name) in Map.toSeq names do - let v = Map.find value forth - yield option [attribute "value" (string v)] [ text name ] - ] - ) + let values: seq<'a * DomNode<'msg>> = names |> Seq.map (fun (KeyValue(value, str)) -> value, text str) + Dropdown.dropdown update false None current att values + [] let allValues<'a when 'a : comparison> = FSharpType.GetUnionCases(typeof<'a>,true) |> Array.map (fun c -> unbox<'a>(FSharpValue.MakeUnion(c, [||], true)), c.Name) |> Map.ofArray \ No newline at end of file diff --git a/src/Aardvark.UI.Primitives/resources/dropdown.js b/src/Aardvark.UI.Primitives/resources/dropdown.js new file mode 100644 index 00000000..f37eefd5 --- /dev/null +++ b/src/Aardvark.UI.Primitives/resources/dropdown.js @@ -0,0 +1,40 @@ +if (!aardvark.dropdown) { + /** + * @param {*} x + * @param {*} y + */ + function arraysIdentical(x, y) { + const a = Array.isArray(x) ? x : [x]; + const b = Array.isArray(y) ? y : [y]; + let i = a.length; + if (i != b.length) return false; + while (i--) { + if (a[i] !== b[i]) return false; + } + return true; + }; + + /** + * @param {HTMLElement[]} $self + * @param {string} trigger + * @param {{onmessage: function}} channel + */ + aardvark.dropdown = function ($self, trigger, channel) { + $self.dropdown({ + on: trigger, + onChange: function (value) { aardvark.processEvent($self[0].id, 'data-event', value); } + }); + + channel.onmessage = function(values) { + const curr = $self.dropdown('get values'); + + // Prevent resetting the same values (leads to flickering) + if (arraysIdentical(curr, values)) { + return; + } + + $self.dropdown('clear', true); + $self.dropdown('set selected', values, true); // set exactly bugged? clear seems to trigger event + }; + }; +} \ No newline at end of file diff --git a/src/Aardvark.UI/Core.fs b/src/Aardvark.UI/Core.fs index 2ed82f02..35b015ad 100644 --- a/src/Aardvark.UI/Core.fs +++ b/src/Aardvark.UI/Core.fs @@ -16,36 +16,36 @@ open FSharp.Data.Traceable type RenderControlConfig = { - adjustAspect : V2i -> Frustum -> Frustum + adjustAspect : V2i -> Frustum -> Frustum } module RenderControlConfig = - + /// Fills height, depending in aspect ratio - let standard = + let standard = { - adjustAspect = fun (size : V2i) -> Frustum.withAspect (float size.X / float size.Y) + adjustAspect = fun (size : V2i) -> Frustum.withAspect (float size.X / float size.Y) } /// Fills height, depending in aspect ratio - let fillHeight = standard + let fillHeight = standard /// Fills width, depending in aspect ratio let fillWidth = let aspect { left = l; right = r; top = t; bottom = b } = (t - b) / (r - l) - let withAspectFlipped (newAspect : float) ( { left = l; right = r; top = t; bottom = b } as f) = - let factor = 1.0 - (newAspect / aspect f) + let withAspectFlipped (newAspect : float) ( { left = l; right = r; top = t; bottom = b } as f) = + let factor = 1.0 - (newAspect / aspect f) { f with bottom = factor * t + b; top = factor * b + t } { - adjustAspect = fun (size : V2i) -> withAspectFlipped (float size.X / float size.Y) + adjustAspect = fun (size : V2i) -> withAspectFlipped (float size.X / float size.Y) } let noScaling = { adjustAspect = fun (size : V2i) (frustum : Frustum) -> frustum } - + [] @@ -72,7 +72,7 @@ module Event = let private processEvent (name : string) (id : string) (args : list) = let args = sprintf "'%s'" id :: sprintf "'%s'" name :: args sprintf "aardvark.processEvent(%s);" (String.concat ", " args) - + let toString (id : string) (name : string) (evt : Event<'msg>) = let send = processEvent name evt.clientSide send id @@ -98,16 +98,16 @@ module Event = let create1 (a : string) (reaction : 'a -> 'msg) = { clientSide = fun send id -> send id [a] - serverSide = fun session id args -> + serverSide = fun session id args -> match args with | [a] -> - try + try Seq.delay (fun () -> Seq.singleton (reaction (Pickler.json.UnPickleOfString a))) with e -> Log.warn "[UI] expected args (%s) but got (%A)" typename<'a> a Seq.empty - | _ -> + | _ -> Log.warn "[UI] expected args (%s) but got %A" typename<'a> args Seq.empty } @@ -115,16 +115,16 @@ module Event = let create2 (a : string) (b : string) (reaction : 'a -> 'b -> 'msg) = { clientSide = fun send id -> send id [a; b] - serverSide = fun session id args -> + serverSide = fun session id args -> match args with | [a; b] -> - try + try Seq.delay (fun () -> Seq.singleton (reaction (Pickler.json.UnPickleOfString a) (Pickler.json.UnPickleOfString b) )) with e -> Log.warn "[UI] expected args (%s, %s) but got (%A, %A)" typename<'a> typename<'b> a b Seq.empty - | _ -> + | _ -> Log.warn "[UI] expected args (%s, %s) but got %A" typename<'a> typename<'b> args Seq.empty } @@ -132,16 +132,16 @@ module Event = let create3 (a : string) (b : string) (c : string) (reaction : 'a -> 'b -> 'c -> 'msg) = { clientSide = fun send id -> send id [a; b; c] - serverSide = fun session id args -> + serverSide = fun session id args -> match args with | [a; b; c] -> - try + try Seq.delay (fun () -> Seq.singleton (reaction (Pickler.json.UnPickleOfString a) (Pickler.json.UnPickleOfString b) (Pickler.json.UnPickleOfString c))) with e -> Log.warn "[UI] expected args (%s, %s, %s) but got (%A, %A, %A)" typename<'a> typename<'b> typename<'c> a b c Seq.empty - | _ -> + | _ -> Log.warn "[UI] expected args (%s, %s, %s) but got %A" typename<'a> typename<'b> typename<'c> args Seq.empty } @@ -156,10 +156,10 @@ module Event = match args with | "0" :: args -> l.serverSide session id args | "1" :: args -> r.serverSide session id args - | _ -> + | _ -> Log.warn "[UI] expected args ((1|2)::args) but got %A" args Seq.empty - + } let combineMany (events : seq>) = @@ -168,10 +168,10 @@ module Event = match events.Length with | 0 -> empty | 1 -> events.[0] - | _ -> + | _ -> { clientSide = fun send id -> - let clientScripts = + let clientScripts = events |> Seq.mapi (fun i e -> e.clientSide (fun id args -> send id (string i :: args)) id ) @@ -190,15 +190,15 @@ module Event = | [] -> Log.warn "[UI] expected at least one arg for dispatcher" Seq.empty - - - + + + } - let map (f : 'a -> 'b) (e : Event<'a>) = + let map (f : 'a -> 'b) (e : Event<'a>) = { - clientSide = e.clientSide; - serverSide = fun session id args -> Seq.map f (e.serverSide session id args) + clientSide = e.clientSide; + serverSide = fun session id args -> Seq.map f (e.serverSide session id args) } @@ -211,33 +211,33 @@ type AttributeValue<'msg> = [] module AttributeValue = - + let combine (name : string) (l : AttributeValue<'msg>) (r : AttributeValue<'msg>) = match name, l, r with - | _, AttributeValue.Event l, AttributeValue.Event r -> + | _, AttributeValue.Event l, AttributeValue.Event r -> AttributeValue.Event (Event.combine l r) //| _, AttributeValue.RenderControlEvent l, AttributeValue.RenderControlEvent r -> // AttributeValue.RenderControlEvent (fun a -> l a @ r a) - | "class", AttributeValue.String l, AttributeValue.String r -> + | "class", AttributeValue.String l, AttributeValue.String r -> AttributeValue.String (l + " " + r) - | "style", AttributeValue.String l, AttributeValue.String r -> + | "style", AttributeValue.String l, AttributeValue.String r -> AttributeValue.String (l + "; " + r) - | _, AttributeValue.RenderEvent l, AttributeValue.RenderEvent r -> - AttributeValue.RenderEvent (fun clientInfo -> + | _, AttributeValue.RenderEvent l, AttributeValue.RenderEvent r -> + AttributeValue.RenderEvent (fun clientInfo -> seq { yield! l clientInfo yield! r clientInfo } ) - | _ -> + | _ -> r - let map (f : 'a -> 'b) (v : AttributeValue<'a>) = + let map (f : 'a -> 'b) (v : AttributeValue<'a>) = match v with | AttributeValue.Event e -> AttributeValue.Event (Event.map f e) | AttributeValue.String s -> AttributeValue.String s @@ -279,7 +279,7 @@ module AttributeMap = match ovs with | Some ovs -> let vs = ovs |> MapExt.remove index - if MapExt.isEmpty vs then + if MapExt.isEmpty vs then deltas <- HashMap.add ok Remove deltas None else @@ -292,7 +292,7 @@ module AttributeMap = () | Set(k, v) -> store <- store |> HashMap.alter k (fun ovs -> - let ovs = + let ovs = match ovs with | None -> MapExt.empty | Some ovs -> ovs @@ -304,7 +304,7 @@ module AttributeMap = deltas |> HashMap.choose (fun k vs -> match vs with - | Set vs -> + | Set vs -> (None, vs) ||> MapExt.fold (fun s _ v -> match s with | None -> Some v @@ -317,7 +317,7 @@ module AttributeMap = /// the empty attributes map let empty<'msg> = AttributeMap<'msg>.Empty - + /// creates an attribute-map with one single entry let single (name : string) (value : AttributeValue<'msg>) = AttributeMap(AMap.ofList [name, value]) @@ -376,7 +376,7 @@ module AttributeMap = | None -> [value] ) - let unique = + let unique = groups |> HashMap.map (fun key values -> match values with | [v] -> v @@ -409,7 +409,7 @@ module AttributeMap = let map (mapping : string -> AttributeValue<'a> -> AttributeValue<'b>) (map : AttributeMap<'a>) = AttributeMap(AMap.map mapping map.AMap) - + let mapAttributes (mapping : AttributeValue<'a> -> AttributeValue<'b>) (map : AttributeMap<'a>) = AttributeMap(AMap.map (fun _ v -> mapping v) map.AMap) @@ -419,10 +419,26 @@ module AttributeMap = let filter (predicate : string -> AttributeValue<'a> -> bool) (map : AttributeMap<'a>) = AttributeMap(AMap.filter predicate map.AMap) + /// Adds the given class to the attribute map. + let addClass (clazz: string) (attributes: AttributeMap<'msg>) = + union attributes <| ofList ["class", AttributeValue.String clazz] + + /// Removes the given class from the attribute map. + let removeClass (clazz: string) (attributes: AttributeMap<'msg>) = + attributes |> map (fun name attr -> + match name, attr with + | "class", AttributeValue.String str -> + String.split " " str + |> Array.filter (String.trim >> (<>) clazz) + |> String.concat " " + |> AttributeValue.String + + | _, value -> value + ) type ReferenceKind = - | Script + | Script | Stylesheet type Reference = { kind : ReferenceKind; name : string; url : string } @@ -444,7 +460,7 @@ type SceneEventProcessor<'msg>() = [] module SceneEventProcessor = - + [] module Implementation = type UnionProcessor<'msg>(inner : list>) = @@ -456,7 +472,7 @@ module SceneEventProcessor = ) override x.NeededEvents = needed.Value - override x.Process(sender, e) = + override x.Process(sender, e) = seq { for p in inner do yield! p.Process(sender, e) @@ -501,7 +517,7 @@ type Channel() = abstract member GetReader : unit -> ChannelReader [] -module ChannelThings = +module ChannelThings = type private ModChannelReader<'a>(m : aval<'a>) = inherit ChannelReader() @@ -530,15 +546,15 @@ module ChannelThings = override x.ComputeMessages t = let ops = reader.GetChanges t ops |> HashSetDelta.toList |> List.map Pickler.json.PickleToString - + type private AValChannel<'a>(m : aval<'a>) = inherit Channel() override x.GetReader() = new ModChannelReader<_>(m) :> ChannelReader - + type private ASetChannel<'a>(m : aset<'a>) = inherit Channel() override x.GetReader() = new ASetChannelReader<_>(m) :> ChannelReader - + type IAdaptiveValue<'a> with member x.Channel = AValChannel(x) :> Channel @@ -569,7 +585,7 @@ type RenderCommand<'msg> = | None, Some d, None -> values.runtime.CompileClearDepth(values.signature, d) | Some c, None, None -> values.runtime.CompileClear(values.signature, c) | None, None, None -> RenderTask.empty - | RenderCommand.SceneGraph sg -> + | RenderCommand.SceneGraph sg -> let sg = sg |> Sg.viewTrafo values.viewTrafo @@ -581,7 +597,7 @@ type IApp<'model, 'msg, 'outer> = abstract member ToOuter : 'model * 'msg -> seq<'outer> abstract member ToInner : 'model * 'outer -> seq<'msg> abstract member Start : unit -> MutableApp<'model, 'msg> - + and MutableApp<'model, 'msg> = { lock : obj @@ -593,14 +609,14 @@ and MutableApp<'model, 'msg> = shutdown : unit -> unit } - + and [] DomNode<'msg>() = let mutable required : list = [] let mutable boot : Option string> = None let mutable shutdown : Option string> = None let mutable callbacks : Map -> 'msg)> = Map.empty let mutable channels : Map = Map.empty - + member x.Required with get() = required and set v = required <- v @@ -658,7 +674,7 @@ and [] DomNode<'msg>() = member x.SubApp n = DomNode.SubApp(n.App).WithAttributesFrom n member x.Map n = DomNode.Map(n.Mapping, n.Node).WithAttributesFrom n } - + member x.WithRequired r = let res = x.Clone() res.Required <- r @@ -685,11 +701,11 @@ and [] DomNode<'msg>() = res member x.AddRequired r = x.WithRequired (x.Required @ r) - member x.AddBoot r = + member x.AddBoot r = match x.Boot with | None -> x.WithBoot (Some r) | Some b -> x.WithBoot (Some (fun self -> b self + ";" + r self)) - member x.AddShutdown r = + member x.AddShutdown r = match x.Shutdown with | None -> x.WithShutdown (Some r) | Some b -> x.WithShutdown (Some (fun self -> b self + ";" + r self)) @@ -755,7 +771,7 @@ and MapNode<'inner, 'outer>(mapping : 'inner -> 'outer, node : DomNode<'inner>) member x.Node : DomNode<'inner> = node override x.Visit v = v.Map x override x.NodeTag = node.NodeTag - + and DomNodeVisitor<'msg, 'r> = abstract member Empty : EmptyNode<'msg> -> 'r abstract member Inner : InnerNode<'msg> -> 'r @@ -790,7 +806,7 @@ and DomNode private() = | 3 -> MouseButtons.Right | _ -> MouseButtons.None - static member Empty<'msg>() : DomNode<'msg> = + static member Empty<'msg>() : DomNode<'msg> = EmptyNode<'msg>() :> DomNode<'msg> static member Element<'msg>(tag : string, ns : Option, attributes : AttributeMap<'msg>, children : alist>) : DomNode<'msg> = @@ -798,7 +814,7 @@ and DomNode private() = static member Element<'msg>(tag : string, ns : Option, attributes : AttributeMap<'msg>) : DomNode<'msg> = VoidNode(tag, ns, attributes) :> DomNode<_> - + static member Scene<'msg>(attributes : AttributeMap<'msg>, scene : Aardvark.Service.Scene, getClientState : Aardvark.Service.ClientInfo -> Aardvark.Service.ClientState) : DomNode<'msg> = SceneNode(attributes, scene, getClientState) :> DomNode<_> @@ -813,40 +829,40 @@ and DomNode private() = static member SubApp<'model, 'inner, 'outer>(app : IApp<'model, 'inner, 'outer>) : DomNode<'outer> = SubAppNode<'model, 'inner, 'outer>(app) :> DomNode<_> - - static member Text(content : aval) = + + static member Text(content : aval) = DomNode.Text("span", None, AttributeMap.empty, content) - - static member SvgText(content : aval) = + + static member SvgText(content : aval) = DomNode.Text("tspan", Some "http://www.w3.org/2000/svg", AttributeMap.empty, content) static member Void(tag : string, attributes : AttributeMap<'msg>) = - DomNode.Element(tag, None, attributes) + DomNode.Element(tag, None, attributes) static member Node(tag : string, attributes : AttributeMap<'msg>, content : alist>) = DomNode.Element(tag, None, attributes, content) static member Void(tag : string, ns : string, attributes : AttributeMap<'msg>) = - DomNode.Element(tag, Some ns, attributes) + DomNode.Element(tag, Some ns, attributes) static member Node(tag : string, ns : string, attributes : AttributeMap<'msg>, content : alist>) = DomNode.Element(tag, Some ns, attributes, content) - static member RenderControl(attributes : AttributeMap<'msg>, processor : SceneEventProcessor<'msg>, getState : Aardvark.Service.ClientInfo -> Aardvark.Service.ClientState, + static member RenderControl(attributes : AttributeMap<'msg>, processor : SceneEventProcessor<'msg>, getState : Aardvark.Service.ClientInfo -> Aardvark.Service.ClientState, scene : Aardvark.Service.Scene, htmlChildren : Option>) = let perform (sourceSession : Guid, sourceId : string, kind : SceneEventKind, buttons : MouseButtons, alt: bool, shift: bool, ctrl: bool, pos : V2i) : seq<'msg> = match scene.TryGetClientInfo(sourceSession, sourceId) with - | Some (info, state) -> + | Some (info, state) -> let pp = PixelPosition(pos.X, pos.Y, info.size.X, info.size.Y) let ray = state |> ClientState.pickRay pp |> FastRay3d |> RayPart - let evt = + let evt = { evtKind = kind evtPixel = pos - evtRay = ray + evtRay = ray evtButtons = buttons evtAlt = alt evtShift = shift @@ -865,7 +881,7 @@ and DomNode private() = // | Some cb -> // cb.s // cb evt @ procRes - // | None -> + // | None -> // procRes | None -> @@ -890,7 +906,7 @@ and DomNode private() = let ctrl = Boolean.Parse ctrl perform(session, id, kind, button, alt, shift, ctrl, V2i(x,y)) - | x :: y :: alt :: shift :: ctrl :: _ -> + | x :: y :: alt :: shift :: ctrl :: _ -> let vx = round (float x) |> int let vy = round (float y) |> int let alt = Boolean.Parse alt @@ -900,18 +916,18 @@ and DomNode private() = | _ -> Seq.empty - + } let events = - processor.NeededEvents - |> ASet.map (fun k -> - let kind = + processor.NeededEvents + |> ASet.map (fun k -> + let kind = match k with | SceneEventKind.Enter | SceneEventKind.Leave -> SceneEventKind.Move | _ -> k - + let button = needsButton kind eventNames.[kind], AttributeValue.Event(rayEvent button kind) ) @@ -921,7 +937,7 @@ and DomNode private() = | [] -> AttributeValue.Event Event.empty | h :: rest -> rest |> List.fold (AttributeValue.combine "urdar") h - + ) |> AttributeMap.ofAMap @@ -937,18 +953,18 @@ and DomNode private() = match htmlChildren with - | Some htmlChildren -> + | Some htmlChildren -> printfn "not implemented" DomNode.Scene(ownAttributes, scene, getState).WithBoot(Some boot) - | None -> + | None -> DomNode.Scene(ownAttributes, scene, getState).WithBoot(Some boot) - static member RenderControl(attributes : AttributeMap<'msg>, getState : Aardvark.Service.ClientInfo -> Aardvark.Service.ClientState, + static member RenderControl(attributes : AttributeMap<'msg>, getState : Aardvark.Service.ClientInfo -> Aardvark.Service.ClientState, scene : Aardvark.Service.Scene, htmlChildren : Option>) = DomNode.RenderControl(attributes, SceneEventProcessor.empty, getState, scene, htmlChildren) - + static member RenderControl(attributes : AttributeMap<'msg>, camera : aval, scene : Aardvark.Service.Scene, htmlChildren : Option>) = let getState(c : Aardvark.Service.ClientInfo) = let cam = camera.GetValue(c.token) @@ -960,10 +976,10 @@ and DomNode private() = } DomNode.RenderControl(attributes, SceneEventProcessor.empty, getState, scene, htmlChildren) - - - + + + static member RenderControl(attributes : AttributeMap<'msg>, camera : aval, sg : ClientValues -> ISg<'msg>, config: RenderControlConfig, htmlChildren : Option>) = @@ -978,7 +994,7 @@ and DomNode private() = let tree = AVal.init <| PickTree.ofSg (Sg.ofList []) let globalPicks = AVal.init AMap.empty - + let scene = Scene.custom (fun values -> let sg = @@ -988,35 +1004,35 @@ and DomNode private() = |> Sg.uniform "ViewportSize" values.size transact ( fun _ -> tree.Value <- PickTree.ofSg sg ) - - transact ( fun _ -> globalPicks.Value <- sg.GlobalPicks(Ag.Scope.Root) ) - + + transact ( fun _ -> globalPicks.Value <- sg.GlobalPicks(Ag.Scope.Root) ) + values.runtime.CompileRender(values.signature, sg) ) let proc = { new SceneEventProcessor<'msg>() with - member x.NeededEvents = + member x.NeededEvents = aset { let! tree = tree let! globalPicks = globalPicks yield! ASet.union (AMap.keys globalPicks) tree.Needed } - member x.Process (source : Guid, evt : SceneEvent) = + member x.Process (source : Guid, evt : SceneEvent) = seq { let consumed, msgs = tree.GetValue().Perform(evt) yield! msgs let m = globalPicks.GetValue().Content |> AVal.force match m |> HashMap.tryFind evt.kind with - | Some cb -> + | Some cb -> yield! cb evt - | None -> + | None -> () } } - + DomNode.RenderControl(attributes, proc, getState, scene, htmlChildren) static member RenderControl(attributes : AttributeMap<'msg>, camera : aval, sg : ISg<'msg>, config: RenderControlConfig, htmlChildren : Option>) = @@ -1047,14 +1063,14 @@ and DomNode private() = let sgs = sgs values - let t = + let t = sgs |> AList.choose (function RenderCommand.Clear _ -> None | SceneGraph sg -> PickTree.ofSg sg |> Some) - let g = + let g = sgs |> AList.toASet |> ASet.choose (function RenderCommand.Clear _ -> None | SceneGraph sg -> sg.GlobalPicks(Ag.Scope.Root) |> Some) transact (fun _ -> trees.Value <- t; globalPicks.Value <- g) - let mutable reader : IOpReader, IndexListDelta> = + let mutable reader : IOpReader, IndexListDelta> = let mutable state = IndexList.empty let input = sgs.GetReader() { new AbstractReader, IndexListDelta>(IndexList.trace) with @@ -1070,7 +1086,7 @@ and DomNode private() = | Remove -> match x.State.TryGet index with - | Some o -> + | Some o -> o.Dispose() Some Remove | None -> None @@ -1085,14 +1101,14 @@ and DomNode private() = () { new AbstractRenderTask() with - override x.PerformUpdate(t,rt) = + override x.PerformUpdate(t,rt) = update t - override x.Perform(t,rt,o) = + override x.Perform(t,rt,o) = update t for task in reader.State do task.Run(t,rt,o) - override x.Release() = - for task in reader.State do + override x.Release() = + for task in reader.State do task.Dispose() reader <- Unchecked.defaultof<_> @@ -1109,7 +1125,7 @@ and DomNode private() = let rec pickTrees (trees : list>) (evt) = match trees with | [] -> false, Seq.empty - | x::xs -> + | x::xs -> let consumed,msgs = pickTrees xs evt if consumed then true,msgs else @@ -1119,7 +1135,7 @@ and DomNode private() = let proc = { new SceneEventProcessor<'msg>() with member x.NeededEvents = needed - member x.Process (source : Guid, evt : SceneEvent) = + member x.Process (source : Guid, evt : SceneEvent) = let trees = trees |> AVal.force let trees = trees.Content |> AVal.force |> IndexList.toList let globalPicks = globalPicks |> AVal.force @@ -1128,9 +1144,9 @@ and DomNode private() = for perScene in globalPicks.Content |> AVal.force do let picks = perScene.Content |> AVal.force match picks |> HashMap.tryFind evt.kind with - | Some cb -> + | Some cb -> yield! cb evt - | None -> + | None -> () } } @@ -1150,7 +1166,7 @@ and DomNode private() = let scene = Scene.custom (fun values -> - let mutable reader : IOpReader, IndexListDelta> = + let mutable reader : IOpReader, IndexListDelta> = let mutable state = IndexList.empty let input = sgs.GetReader() { new AbstractReader, IndexListDelta>(IndexList.trace) with @@ -1166,7 +1182,7 @@ and DomNode private() = | Remove -> match x.State.TryGet index with - | Some o -> + | Some o -> o.Dispose() Some Remove | None -> None @@ -1179,14 +1195,14 @@ and DomNode private() = () { new AbstractRenderTask() with - override x.PerformUpdate(t,rt) = + override x.PerformUpdate(t,rt) = update t - override x.Perform(t,rt,o) = + override x.Perform(t,rt,o) = update t for task in reader.State do task.Run(t,rt,o) - override x.Release() = - for t in reader.State do + override x.Release() = + for t in reader.State do t.Dispose() reader <- Unchecked.defaultof<_> @@ -1209,7 +1225,7 @@ and DomNode private() = let rec pickTrees (trees : list>) (evt) = match trees with | [] -> false, Seq.empty - | x::xs -> + | x::xs -> let consumed,msgs = pickTrees xs evt if consumed then true,msgs else @@ -1219,7 +1235,7 @@ and DomNode private() = let proc = { new SceneEventProcessor<'msg>() with member x.NeededEvents = needed - member x.Process (source : Guid, evt : SceneEvent) = + member x.Process (source : Guid, evt : SceneEvent) = let trees = trees.Content |> AVal.force |> IndexList.toList seq { let consumed, msgs = pickTrees trees evt @@ -1228,9 +1244,9 @@ and DomNode private() = for perScene in globalPicks.Content |> AVal.force do let picks = perScene.Content |> AVal.force match picks |> HashMap.tryFind evt.kind with - | Some cb -> + | Some cb -> yield! cb evt - | None -> + | None -> () } } diff --git a/src/Examples (dotnetcore)/23 - Inputs/App.fs b/src/Examples (dotnetcore)/23 - Inputs/App.fs index d50953d5..635d4f72 100644 --- a/src/Examples (dotnetcore)/23 - Inputs/App.fs +++ b/src/Examples (dotnetcore)/23 - Inputs/App.fs @@ -66,11 +66,6 @@ let update (model : Model) (msg : Message) = let view (model : AdaptiveModel) = let alternatives = model.options |> AMap.map (fun _ v -> text v) - let enumValues : amap> = - Enum.GetValues() - |> Array.map (fun e -> e, text (string e)) - |> AMap.ofArray - let description (str : string) = div [ style "margin-bottom: 10px" ] [ text str ] @@ -183,23 +178,23 @@ let view (model : AdaptiveModel) = text "Dropdown menus", div [ clazz "menu" ] [ div [ clazz "item" ] [ description "Non-clearable" - dropdownUnclearable [ clazz "inverted selection" ] enumValues model.enumValue SetEnumValue + Dropdown.dropdownEnum SetEnumValue false None model.enumValue [ clazz "inverted" ] None ] div [ clazz "item" ] [ description "Clearable" - dropdown { mode = DropdownMode.Text <| Some "blub"; onTrigger = TriggerDropdown.Hover } [ clazz "inverted selection" ] alternatives model.alt SetAlternative + Dropdown.dropdownOption SetAlternative true None "Select..." model.alt [ clazz "inverted clearable" ] alternatives ] div [ clazz "item" ] [ description "Icon mode" - dropdown { mode = DropdownMode.Icon "sidebar"; onTrigger = TriggerDropdown.Hover } [ clazz "inverted icon top left pointing dropdown circular button" ] alternatives model.alt SetAlternative + Dropdown.dropdownOption SetAlternative true (Some "sidebar") "" model.alt [ clazz "inverted icon top left pointing dropdown circular button" ] alternatives ] div [ clazz "item" ] [ description "Multi select" let atts = AttributeMap.ofList [clazz "inverted clearable search"] - dropdownMultiSelect atts None "Search..." alternatives model.alts SetAlternatives + Dropdown.dropdownMultiSelect SetAlternatives false "Search..." model.alts atts alternatives ] ] diff --git a/src/Examples (dotnetcore)/28 - Notifications/App.fs b/src/Examples (dotnetcore)/28 - Notifications/App.fs index 91b1c939..a9e0faec 100644 --- a/src/Examples (dotnetcore)/28 - Notifications/App.fs +++ b/src/Examples (dotnetcore)/28 - Notifications/App.fs @@ -133,24 +133,17 @@ let view (model : AdaptiveModel) = text "Remove" ] - let values = - Enum.GetValues() - |> Array.map (fun p -> - let n = - match p with - | Position.TopRight -> text "Top Right" - | Position.TopLeft -> text "Top Left" - | Position.TopCenter -> text "Top Center" - | Position.TopAttached -> text "Top Attached" - | Position.BottomRight -> text "Bottom Right" - | Position.BottomLeft -> text "Bottom Left" - | Position.BottomCenter -> text "Bottom Center" - | _ -> text "Bottom Attached" - p, n - ) - |> AMap.ofArray - - dropdownUnclearable [clazz "selection"; style "margin: 10px"] values model.position SetPosition + let values = Some <| function + | Position.TopRight -> text "Top Right" + | Position.TopLeft -> text "Top Left" + | Position.TopCenter -> text "Top Center" + | Position.TopAttached -> text "Top Attached" + | Position.BottomRight -> text "Bottom Right" + | Position.BottomLeft -> text "Bottom Left" + | Position.BottomCenter -> text "Bottom Center" + | _ -> text "Bottom Attached" + + Dropdown.dropdownEnum SetPosition false None model.position [clazz "selection"; style "margin: 10px"] values ] ] diff --git a/src/Scratch/02 - DrawRects/App.fs b/src/Scratch/02 - DrawRects/App.fs index fb44b197..cb6089b0 100644 --- a/src/Scratch/02 - DrawRects/App.fs +++ b/src/Scratch/02 - DrawRects/App.fs @@ -273,7 +273,7 @@ module ClientApp = yield br [] yield text "Color Mode: " yield div [] [ - dropDown [] colorMode (changeMode >> SetColorMode) (Map.ofList [ "Constant", "Constant"; "Vertical Gradient", "Vertical Gradient";"Horizontal Gradient", "Horizontal Gradient";"Points", "Points"]) + Dropdown.dropdown (changeMode >> SetColorMode) false None colorMode AttributeMap.empty [ "Constant", text "Constant"; "Vertical Gradient", text "Vertical Gradient";"Horizontal Gradient", text "Horizontal Gradient";"Points", text "Points"] ] yield button [style "ui small red button"; onClick (fun _ -> Delete id)] [text "Delete"] ] diff --git a/src/Scratch/27 - NavigationDemoNew/App.fs b/src/Scratch/27 - NavigationDemoNew/App.fs index 9a52b648..13a76be2 100644 --- a/src/Scratch/27 - NavigationDemoNew/App.fs +++ b/src/Scratch/27 - NavigationDemoNew/App.fs @@ -180,9 +180,7 @@ let view (model : AdaptiveModel) = br [] br [] - //Html.SemUi.dropDown model.mode SetMode - let enumValues = AMap.ofArray((System.Enum.GetValues typeof :?> (CameraMode [])) |> Array.map (fun c -> (c, text (System.Enum.GetName(typeof, c)) ))) - dropdownUnclearable [ clazz "ui inverted selection dropdown" ] enumValues model.mode SetMode + Dropdown.dropdownEnum SetMode false None model.mode [ clazz "ui inverted selection dropdown" ] None br [] br [] ] diff --git a/src/Scratch/27 - NavigationDemoNew/Program.fs b/src/Scratch/27 - NavigationDemoNew/Program.fs index 65ec9969..4111c583 100644 --- a/src/Scratch/27 - NavigationDemoNew/Program.fs +++ b/src/Scratch/27 - NavigationDemoNew/Program.fs @@ -27,6 +27,7 @@ let main argv = // the non localhost variant runs in 127.0.0.1 which enables remote acces (e.g. via your mobile phone) WebPart.startServerLocalhost 4321 [ MutableApp.toWebPart' app.Runtime false instance + Reflection.assemblyWebPart typeof.Assembly Suave.Files.browseHome ] |> ignore