Select widgets

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Common.hs

@@ -62,13 +62,11 @@ pattern B64Value = S.SB64Value
 pattern ImageFormat = S.SImageFormat
 pattern BoolValue = S.SBoolValue
 pattern Options = S.SOptions
-pattern SelectedLabel = S.SSelectedLabel
-pattern SelectedValue = S.SSelectedValue
+pattern Index = S.SIndex
 pattern SelectionHandler = S.SSelectionHandler
 pattern Tooltips = S.STooltips
 pattern Icons = S.SIcons
-pattern SelectedLabels = S.SSelectedLabels
-pattern SelectedValues = S.SSelectedValues
+pattern Indices = S.SIndices
 pattern IntValue = S.SIntValue
 pattern StepInt = S.SStepInt
 pattern MaxInt = S.SMaxInt

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Selection/Dropdown.hs

@@ -18,6 +18,7 @@ import           Prelude
 import           Control.Monad (void)
 import           Data.Aeson
 import           Data.IORef (newIORef)
+import qualified Data.Scientific as Sci
 import           Data.Vinyl (Rec(..), (<+>))
 
 import           IHaskell.Display
@@ -52,18 +53,8 @@ mkDropdown = do
 instance IHaskellWidget Dropdown where
   getCommUUID = uuid
   comm widget val _ =
-    case nestedObjectLookup val ["sync_data", "selected_label"] of
-      Just (String label) -> do
-        opts <- getField widget Options
-        case opts of
-          OptionLabels _ -> do
-            void $ setField' widget SelectedLabel label
-            void $ setField' widget SelectedValue label
-          OptionDict ps ->
-            case lookup label ps of
-              Nothing -> return ()
-              Just value -> do
-                void $ setField' widget SelectedLabel label
-                void $ setField' widget SelectedValue value
+    case nestedObjectLookup val ["state", "index"] of
+      Just (Number index) -> do
+        void $ setField' widget Index (Sci.coefficient index)
         triggerSelection widget
       _ -> pure ()

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Selection/RadioButtons.hs

@@ -18,6 +18,7 @@ import           Prelude
 import           Control.Monad (void)
 import           Data.Aeson
 import           Data.IORef (newIORef)
+import qualified Data.Scientific as Sci
 
 import           IHaskell.Display
 import           IHaskell.Eval.Widgets
@@ -49,18 +50,8 @@ mkRadioButtons = do
 instance IHaskellWidget RadioButtons where
   getCommUUID = uuid
   comm widget val _ =
-    case nestedObjectLookup val ["sync_data", "selected_label"] of
-      Just (String label) -> do
-        opts <- getField widget Options
-        case opts of
-          OptionLabels _ -> do
-            void $ setField' widget SelectedLabel label
-            void $ setField' widget SelectedValue label
-          OptionDict ps ->
-            case lookup label ps of
-              Nothing -> pure ()
-              Just value -> do
-                void $ setField' widget SelectedLabel label
-                void $ setField' widget SelectedValue value
+    case nestedObjectLookup val ["state", "index"] of
+      Just (Number index) -> do
+        void $ setField' widget Index (Sci.coefficient index)
         triggerSelection widget
       _ -> pure ()

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Selection/Select.hs

@@ -18,6 +18,7 @@ import           Prelude
 import           Control.Monad (void)
 import           Data.Aeson
 import           Data.IORef (newIORef)
+import qualified Data.Scientific as Sci
 
 import           IHaskell.Display
 import           IHaskell.Eval.Widgets
@@ -49,18 +50,8 @@ mkSelect = do
 instance IHaskellWidget Select where
   getCommUUID = uuid
   comm widget val _ =
-    case nestedObjectLookup val ["sync_data", "selected_label"] of
-      Just (String label) -> do
-        opts <- getField widget Options
-        case opts of
-          OptionLabels _ -> do
-            void $ setField' widget SelectedLabel label
-            void $ setField' widget SelectedValue label
-          OptionDict ps ->
-            case lookup label ps of
-              Nothing -> pure ()
-              Just value -> do
-                void $ setField' widget SelectedLabel label
-                void $ setField' widget SelectedValue value
+    case nestedObjectLookup val ["state", "index"] of
+      Just (Number index) -> do
+        void $ setField' widget Index (Sci.coefficient index)
         triggerSelection widget
       _ -> pure ()

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Selection/SelectMultiple.hs

@@ -18,6 +18,7 @@ import           Prelude
 import           Control.Monad (void)
 import           Data.Aeson
 import           Data.IORef (newIORef)
+import qualified Data.Scientific as Sci
 import qualified Data.Vector as V
 
 import           IHaskell.Display
@@ -50,19 +51,9 @@ mkSelectMultiple = do
 instance IHaskellWidget SelectMultiple where
   getCommUUID = uuid
   comm widget val _ =
-    case nestedObjectLookup val ["sync_data", "selected_labels"] of
-      Just (Array labels) -> do
-        let labelList = map (\(String x) -> x) $ V.toList labels
-        opts <- getField widget Options
-        case opts of
-          OptionLabels _ -> do
-            void $ setField' widget SelectedLabels labelList
-            void $ setField' widget SelectedValues labelList
-          OptionDict ps ->
-            case mapM (`lookup` ps) labelList of
-              Nothing -> pure ()
-              Just valueList -> do
-                void $ setField' widget SelectedLabels labelList
-                void $ setField' widget SelectedValues valueList
+    case nestedObjectLookup val ["state", "index"] of
+      Just (Array indices) -> do
+        let indicesList = map (\(Number x) -> Sci.coefficient x) $ V.toList indices
+        void $ setField' widget Indices indicesList
         triggerSelection widget
       _ -> pure ()

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Selection/ToggleButtons.hs

@@ -18,6 +18,7 @@ import           Prelude
 import           Control.Monad (void)
 import           Data.Aeson
 import           Data.IORef (newIORef)
+import qualified Data.Scientific as Sci
 import           Data.Vinyl (Rec(..), (<+>))
 
 import           IHaskell.Display
@@ -55,18 +56,8 @@ mkToggleButtons = do
 instance IHaskellWidget ToggleButtons where
   getCommUUID = uuid
   comm widget val _ =
-    case nestedObjectLookup val ["sync_data", "selected_label"]  of
-      Just (String label) -> do
-        opts <- getField widget Options
-        case opts of
-          OptionLabels _ -> void $ do
-            void $ setField' widget SelectedLabel label
-            void $ setField' widget SelectedValue label
-          OptionDict ps ->
-            case lookup label ps of
-              Nothing -> pure ()
-              Just value -> do
-                void $ setField' widget SelectedLabel label
-                void $ setField' widget SelectedValue value
+    case nestedObjectLookup val ["state", "index"] of
+      Just (Number index) -> do
+        void $ setField' widget Index (Sci.coefficient index)
         triggerSelection widget
       _ -> pure ()

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Singletons.hs

@@ -68,13 +68,11 @@ singletons
              | ImageFormat
              | BoolValue
              | Options
-             | SelectedLabel
-             | SelectedValue
+             | Index
              | SelectionHandler
              | Tooltips
              | Icons
-             | SelectedLabels
-             | SelectedValues
+             | Indices
              | IntValue
              | StepInt
              | MaxInt

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Types.hs

@@ -136,10 +136,10 @@ type StringClass = DOMWidgetClass :++ ['S.StringValue, 'S.Disabled, 'S.Descripti
 
 type BoolClass = DOMWidgetClass :++ ['S.BoolValue, 'S.Disabled, 'S.Description, 'S.ChangeHandler]
 
-type SelectionClass = DOMWidgetClass :++ ['S.Options, 'S.SelectedValue, 'S.SelectedLabel, 'S.Disabled,
+type SelectionClass = DOMWidgetClass :++ ['S.Options, 'S.Index, 'S.Disabled,
   'S.Description, 'S.SelectionHandler]
 
-type MultipleSelectionClass = DOMWidgetClass :++ ['S.Options, 'S.SelectedValues, 'S.SelectedLabels, 'S.Disabled,
+type MultipleSelectionClass = DOMWidgetClass :++ ['S.Options, 'S.Indices, 'S.Disabled,
   'S.Description, 'S.SelectionHandler]
 
 type IntClass = DOMWidgetClass :++ ['S.IntValue, 'S.Disabled, 'S.Description, 'S.ChangeHandler]
@@ -202,13 +202,11 @@ type family FieldType (f :: Field) :: * where
         FieldType 'S.ImageFormat = ImageFormatValue
         FieldType 'S.BoolValue = Bool
         FieldType 'S.Options = SelectionOptions
-        FieldType 'S.SelectedLabel = Text
-        FieldType 'S.SelectedValue = Text
+        FieldType 'S.Index = Integer
         FieldType 'S.SelectionHandler = IO ()
         FieldType 'S.Tooltips = [Text]
         FieldType 'S.Icons = [Text]
-        FieldType 'S.SelectedLabels = [Text]
-        FieldType 'S.SelectedValues = [Text]
+        FieldType 'S.Indices = [Integer]
         FieldType 'S.IntValue = Integer
         FieldType 'S.StepInt = Integer
         FieldType 'S.MinInt = Integer
@@ -490,11 +488,8 @@ instance ToPairs (Attr 'S.ImageFormat) where
 instance ToPairs (Attr 'S.BoolValue) where
   toPairs x = ["value" .= toJSON x]
 
-instance ToPairs (Attr 'S.SelectedLabel) where
-  toPairs x = ["selected_label" .= toJSON x]
-
-instance ToPairs (Attr 'S.SelectedValue) where
-  toPairs x = ["value" .= toJSON x]
+instance ToPairs (Attr 'S.Index) where
+  toPairs x = ["index" .= toJSON x]
 
 instance ToPairs (Attr 'S.Options) where
   toPairs x =
@@ -514,11 +509,8 @@ instance ToPairs (Attr 'S.Tooltips) where
 instance ToPairs (Attr 'S.Icons) where
   toPairs x = ["icons" .= toJSON x]
 
-instance ToPairs (Attr 'S.SelectedLabels) where
-  toPairs x = ["selected_labels" .= toJSON x]
-
-instance ToPairs (Attr 'S.SelectedValues) where
-  toPairs x = ["values" .= toJSON x]
+instance ToPairs (Attr 'S.Indices) where
+  toPairs x = ["index" .= toJSON x]
 
 instance ToPairs (Attr 'S.IntValue) where
   toPairs x = ["value" .= toJSON x]
@@ -710,8 +702,7 @@ defaultSelectionWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec
 defaultSelectionWidget viewName modelName = defaultDOMWidget viewName modelName <+> selectionAttrs
   where
     selectionAttrs = (Options =:: OptionLabels [])
-                     :& (SelectedValue =:: "")
-                     :& (SelectedLabel =:: "")
+                     :& (Index =:: 0)
                      :& (Disabled =:: False)
                      :& (Description =:: "")
                      :& (SelectionHandler =:: return ())
@@ -722,8 +713,7 @@ defaultMultipleSelectionWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelNam
 defaultMultipleSelectionWidget viewName modelName = defaultDOMWidget viewName modelName <+> mulSelAttrs
   where
     mulSelAttrs = (Options =:: OptionLabels [])
-                  :& (SelectedValues =:: [])
-                  :& (SelectedLabels =:: [])
+                  :& (Indices =:: [])
                   :& (Disabled =:: False)
                   :& (Description =:: "")
                   :& (SelectionHandler =:: return ())

src/IHaskell/Types.hs

@@ -43,7 +43,7 @@ module IHaskell.Types (
 import           IHaskellPrelude
 
 import qualified Data.HashMap.Strict as HashMap
-import           Data.Aeson (ToJSON (..), Value, (.=), object, Object, Value(String))
+import           Data.Aeson (ToJSON (..), Value, (.=), object, Value(String))
 import           Data.Function (on)
 import           Data.Text (pack)
 import           Data.Serialize