Add selection widgets

- Selection Widgets
  - Dropdown
  - ToggleButtons
  - RadioButtons
  - Select
  - SelectMultiple
- Small fix to MsgSpec.md

ihaskell-display/ihaskell-widgets/MsgSpec.md

@@ -22,7 +22,7 @@ The initial state update message looks like this:
 }
 ```
 
-Any property initialized with the empty string is provided the default value by the frontend.
+Any *numeric* property initialized with the empty string is provided the default value by the frontend.
 
 The initial state update must *at least* have the following fields:
 

ihaskell-display/ihaskell-widgets/ihaskell-widgets.cabal

@@ -55,15 +55,19 @@ library
   
   -- Modules included in this library but not exported.
   other-modules:       IHaskell.Display.Widgets.Button
-                       IHaskell.Display.Widgets.Image
                        IHaskell.Display.Widgets.Bool.CheckBox
                        IHaskell.Display.Widgets.Bool.ToggleButton
-                       -- IHaskell.Display.Widgets.Dropdown
+                       IHaskell.Display.Widgets.Image
+                       IHaskell.Display.Widgets.Output
+                       IHaskell.Display.Widgets.Selection.Dropdown
+                       IHaskell.Display.Widgets.Selection.RadioButtons
+                       IHaskell.Display.Widgets.Selection.Select
+                       IHaskell.Display.Widgets.Selection.ToggleButtons
+                       IHaskell.Display.Widgets.Selection.SelectMultiple
                        IHaskell.Display.Widgets.String.HTML
                        IHaskell.Display.Widgets.String.Latex
                        IHaskell.Display.Widgets.String.Text
                        IHaskell.Display.Widgets.String.TextArea
-                       IHaskell.Display.Widgets.Output
 
                        IHaskell.Display.Widgets.Types
                        IHaskell.Display.Widgets.Common
@@ -80,6 +84,7 @@ library
                      , unordered-containers -any
                      , nats -any
                      , vinyl >= 0.5
+                     , vector -any
                      , singletons >= 0.9.0
 
                        -- Waiting for the next release

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

@@ -5,16 +5,20 @@ import           IHaskell.Display.Widgets.Button as X
 import           IHaskell.Display.Widgets.Bool.CheckBox as X
 import           IHaskell.Display.Widgets.Bool.ToggleButton as X
 
--- import           IHaskell.Display.Widgets.Dropdown as X
-
 import           IHaskell.Display.Widgets.Image as X
 
+import           IHaskell.Display.Widgets.Output as X
+
+import           IHaskell.Display.Widgets.Selection.Dropdown as X
+import           IHaskell.Display.Widgets.Selection.RadioButtons as X
+import           IHaskell.Display.Widgets.Selection.Select as X
+import           IHaskell.Display.Widgets.Selection.ToggleButtons as X
+import           IHaskell.Display.Widgets.Selection.SelectMultiple as X
+
 import           IHaskell.Display.Widgets.String.HTML as X
 import           IHaskell.Display.Widgets.String.Latex as X
 import           IHaskell.Display.Widgets.String.Text as X
 import           IHaskell.Display.Widgets.String.TextArea as X
 
-import           IHaskell.Display.Widgets.Output as X
-
 import           IHaskell.Display.Widgets.Common as X
 import           IHaskell.Display.Widgets.Types as X (setField, getField)

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

@@ -51,9 +51,18 @@ singletons [d|
              | B64Value
              | ImageFormat
              | BoolValue
+             | Options
+             | SelectedLabel
+             | SelectedValue
+             | SelectionHandler
+             | Tooltips
+             | Icons
+             | SelectedLabels
+             | SelectedValues
              deriving (Eq, Ord, Show)
              |]
 
+-- | Pre-defined border styles
 data BorderStyleValue = NoBorder
                       | HiddenBorder
                       | DottedBorder
@@ -83,6 +92,7 @@ instance ToJSON BorderStyleValue where
   toJSON InheritBorder = "inherit"
   toJSON DefaultBorder = ""
 
+-- | Font style values
 data FontStyleValue = NormalFont
                     | ItalicFont
                     | ObliqueFont
@@ -98,6 +108,7 @@ instance ToJSON FontStyleValue where
   toJSON InheritFont = "inherit"
   toJSON DefaultFont = ""
 
+-- | Font weight values
 data FontWeightValue = NormalWeight
                      | BoldWeight
                      | BolderWeight
@@ -115,6 +126,7 @@ instance ToJSON FontWeightValue where
   toJSON InitialWeight = "initial"
   toJSON DefaultWeight = ""
 
+-- | Pre-defined button styles
 data ButtonStyleValue = PrimaryButton
                       | SuccessButton
                       | InfoButton
@@ -143,3 +155,6 @@ instance Show ImageFormatValue where
 
 instance ToJSON ImageFormatValue where
   toJSON = toJSON . pack . show
+
+-- | Options for selection widgets.
+data SelectionOptions = OptionLabels [Text] | OptionDict [(Text, Text)]

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

 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 
-module IHaskell.Display.Widgets.Dropdown (
-    -- * The dropdown widget
-    DropdownWidget,
+module IHaskell.Display.Widgets.Selection.Dropdown (
+    -- * The Dropdown Widget
+    Dropdown,
     -- * Constructor
-    mkDropdownWidget,
-    -- * Set properties
-    setDropdownText,
-    setDropdownStatus,
-    setDropdownOptions,
-    setDropdownSelected,
-    -- * Get properties
-    getDropdownText,
-    getDropdownStatus,
-    getDropdownOptions,
-    getDropdownSelected,
-    -- * Handle changes
-    setSelectionHandler,
-    getSelectionHandler,
-    triggerSelection,
+    mkDropdown,
     ) where
 
 -- To keep `cabal repl` happy when running from the ihaskell repo
 import           Prelude
 
-import           Control.Monad (when)
-import           Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
-import           Data.Aeson.Types (Pair)
-import           Data.HashMap.Strict as Map
-import           Data.IORef
+import           Control.Monad (when, join)
+import           Data.Aeson
+import qualified Data.HashMap.Strict as HM
+import           Data.IORef (newIORef)
 import           Data.Text (Text)
-import           System.IO.Unsafe (unsafePerformIO)
+import           Data.Vinyl (Rec (..), (<+>))
 
 import           IHaskell.Display
 import           IHaskell.Eval.Widgets
-import qualified IHaskell.IPython.Message.UUID as U
+import           IHaskell.IPython.Message.UUID as U
 
+import           IHaskell.Display.Widgets.Types
 import           IHaskell.Display.Widgets.Common
 
 -- | A 'Dropdown' represents a Dropdown widget from IPython.html.widgets.
-data DropdownWidget =
-       DropdownWidget
-         { uuid :: U.UUID       -- ^ The UUID for the comm
-         , description :: IORef Text -- ^ The label displayed beside the dropdown
-         , disabled :: IORef Bool    -- ^ Whether the dropdown is disabled
-         , selectedLabel :: IORef Text -- ^ The label which is currently selected
-         , labelOptions :: IORef [Text] -- ^ The possible label options
-         , selectionHandler :: IORef (DropdownWidget -> IO ())
-         }
+type Dropdown = IPythonWidget DropdownType
 
--- | Create a new dropdown
-mkDropdownWidget :: IO DropdownWidget
-mkDropdownWidget = do
+-- | Create a new Dropdown widget
+mkDropdown :: IO Dropdown
+mkDropdown = do
   -- Default properties, with a random uuid
-  commUUID <- U.random
-  desc <- newIORef ""
-  dis <- newIORef False
-  sel <- newIORef ""
-  opts <- newIORef []
-  handler <- newIORef $ const $ return ()
+  uuid <- U.random
+  let selectionAttrs = defaultSelectionWidget "DropdownView"
+      dropdownAttrs = (SButtonStyle =:: DefaultButton) :& RNil
+      widgetState = WidgetState $ selectionAttrs <+> dropdownAttrs
 
-  let b = DropdownWidget
-        { uuid = commUUID
-        , description = desc
-        , disabled = dis
-        , selectedLabel = sel
-        , labelOptions = opts
-        , selectionHandler = handler
-        }
+  stateIO <- newIORef widgetState
 
-  let initData = object
-                   ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Dropdown"]
+  let widget = IPythonWidget uuid stateIO
+      initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Dropdown"]
 
   -- Open a comm for this widget, and store it in the kernel state
-  widgetSendOpen b initData $ toJSON b
+  widgetSendOpen widget initData $ toJSON widgetState
 
-  -- Return the dropdown widget
-  return b
-
-setDropdownText :: DropdownWidget -> Text -> IO ()
-setDropdownText widget text = do
-  modify widget description text
-  update widget ["description" .= text]
-
-setDropdownStatus :: DropdownWidget -> Bool -> IO ()
-setDropdownStatus widget stat = do
-  let newStat = not stat
-  modify widget disabled newStat
-  update widget ["disabled" .= newStat]
-
-setDropdownOptions :: DropdownWidget -> [Text] -> IO ()
-setDropdownOptions widget opts = do
-  modify widget labelOptions opts
-  update widget ["_options_labels" .= opts]
-
-setDropdownSelected :: DropdownWidget -> Text -> IO ()
-setDropdownSelected widget opt = do
-  possibleOpts <- getDropdownOptions widget
-  when (opt `elem` possibleOpts) $ do
-    modify widget selectedLabel opt
-    update widget ["selected_label" .= opt]
-  triggerSelection widget
-
-toggleDropdownStatus :: DropdownWidget -> IO ()
-toggleDropdownStatus widget = modifyIORef (disabled widget) not
-
-getDropdownText :: DropdownWidget -> IO Text
-getDropdownText = readIORef . description
-
-getDropdownStatus :: DropdownWidget -> IO Bool
-getDropdownStatus = fmap not . readIORef . disabled
-
-getDropdownOptions :: DropdownWidget -> IO [Text]
-getDropdownOptions = readIORef . labelOptions
-
-getDropdownSelected :: DropdownWidget -> IO Text
-getDropdownSelected = readIORef . selectedLabel
-
--- | Set a function to be activated on selection
-setSelectionHandler :: DropdownWidget -> (DropdownWidget -> IO ()) -> IO ()
-setSelectionHandler = writeIORef . selectionHandler
-
--- | Get the selection handler for a dropdown
-getSelectionHandler :: DropdownWidget -> IO (DropdownWidget -> IO ())
-getSelectionHandler = readIORef . selectionHandler
+  -- Return the widget
+  return widget
 
 -- | Artificially trigger a selection
-triggerSelection :: DropdownWidget -> IO ()
-triggerSelection widget = do
-  handler <- getSelectionHandler widget
-  handler widget
-
-instance ToJSON DropdownWidget where
-  toJSON b = object
-               [ "_view_name" .= str "DropdownView"
-               , "visible" .= True
-               , "_css" .= object []
-               , "msg_throttle" .= (3 :: Int)
-               , "disabled" .= get disabled b
-               , "description" .= get description b
-               , "_options_labels" .= get labelOptions b
-               , "selected_label" .= get selectedLabel b
-               , "button_style" .= str ""
-               ]
-    where
-      get x y = unsafePerformIO . readIORef . x $ y
+triggerSelection :: Dropdown -> IO ()
+triggerSelection widget = join $ getField widget SSelectionHandler
 
-instance IHaskellDisplay DropdownWidget where
+instance IHaskellDisplay Dropdown where
   display b = do
     widgetSendView b
     return $ Display []
 
-instance IHaskellWidget DropdownWidget where
+instance IHaskellWidget Dropdown where
   getCommUUID = uuid
   comm widget (Object dict1) _ = do
     let key1 = "sync_data" :: Text
         key2 = "selected_label" :: Text
-        Just (Object dict2) = Map.lookup key1 dict1
-        Just (String label) = Map.lookup key2 dict2
-    modify widget selectedLabel label
+        Just (Object dict2) = HM.lookup key1 dict1
+        Just (String label) = HM.lookup key2 dict2
+    opts <- getField widget SOptions
+    case opts of
+      OptionLabels _ -> do
+        setField' widget SSelectedLabel label
+        setField' widget SSelectedValue label
+      OptionDict ps -> case lookup label ps of
+        Nothing -> return ()
+        Just value -> do
+          setField' widget SSelectedLabel label
+          setField' widget SSelectedValue value
     triggerSelection widget

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module IHaskell.Display.Widgets.Selection.RadioButtons (
+    -- * The RadioButtons Widget
+    RadioButtons,
+    -- * Constructor
+    mkRadioButtons,
+    ) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Control.Monad (when, join)
+import           Data.Aeson
+import qualified Data.HashMap.Strict as HM
+import           Data.IORef (newIORef)
+import           Data.Text (Text)
+import           Data.Vinyl (Rec (..), (<+>))
+
+import           IHaskell.Display
+import           IHaskell.Eval.Widgets
+import           IHaskell.IPython.Message.UUID as U
+
+import           IHaskell.Display.Widgets.Types
+import           IHaskell.Display.Widgets.Common
+
+-- | A 'RadioButtons' represents a RadioButtons widget from IPython.html.widgets.
+type RadioButtons = IPythonWidget RadioButtonsType
+
+-- | Create a new RadioButtons widget
+mkRadioButtons :: IO RadioButtons
+mkRadioButtons = do
+  -- Default properties, with a random uuid
+  uuid <- U.random
+  let widgetState = WidgetState $ defaultSelectionWidget "RadioButtonsView"
+
+  stateIO <- newIORef widgetState
+
+  let widget = IPythonWidget uuid stateIO
+      initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.RadioButtons"]
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen widget initData $ toJSON widgetState
+
+  -- Return the widget
+  return widget
+
+-- | Artificially trigger a selection
+triggerSelection :: RadioButtons -> IO ()
+triggerSelection widget = join $ getField widget SSelectionHandler
+
+instance IHaskellDisplay RadioButtons where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget RadioButtons where
+  getCommUUID = uuid
+  comm widget (Object dict1) _ = do
+    let key1 = "sync_data" :: Text
+        key2 = "selected_label" :: Text
+        Just (Object dict2) = HM.lookup key1 dict1
+        Just (String label) = HM.lookup key2 dict2
+    opts <- getField widget SOptions
+    case opts of
+      OptionLabels _ -> do
+        setField' widget SSelectedLabel label
+        setField' widget SSelectedValue label
+      OptionDict ps -> case lookup label ps of
+        Nothing -> return ()
+        Just value -> do
+          setField' widget SSelectedLabel label
+          setField' widget SSelectedValue value
+    triggerSelection widget

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module IHaskell.Display.Widgets.Selection.Select (
+    -- * The Select Widget
+    SelectWidget,
+    -- * Constructor
+    mkSelectWidget,
+    ) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Control.Monad (when, join)
+import           Data.Aeson
+import qualified Data.HashMap.Strict as HM
+import           Data.IORef (newIORef)
+import           Data.Text (Text)
+import           Data.Vinyl (Rec (..), (<+>))
+
+import           IHaskell.Display
+import           IHaskell.Eval.Widgets
+import           IHaskell.IPython.Message.UUID as U
+
+import           IHaskell.Display.Widgets.Types
+import           IHaskell.Display.Widgets.Common
+
+-- | A 'SelectWidget' represents a Select widget from IPython.html.widgets.
+type SelectWidget = IPythonWidget SelectType
+
+-- | Create a new Select widget
+mkSelectWidget :: IO SelectWidget
+mkSelectWidget = do
+  -- Default properties, with a random uuid
+  uuid <- U.random
+  let widgetState = WidgetState $ defaultSelectionWidget "SelectView"
+
+  stateIO <- newIORef widgetState
+
+  let widget = IPythonWidget uuid stateIO
+      initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Select"]
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen widget initData $ toJSON widgetState
+
+  -- Return the widget
+  return widget
+
+-- | Artificially trigger a selection
+triggerSelection :: SelectWidget -> IO ()
+triggerSelection widget = join $ getField widget SSelectionHandler
+
+instance IHaskellDisplay SelectWidget where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget SelectWidget where
+  getCommUUID = uuid
+  comm widget (Object dict1) _ = do
+    let key1 = "sync_data" :: Text
+        key2 = "selected_label" :: Text
+        Just (Object dict2) = HM.lookup key1 dict1
+        Just (String label) = HM.lookup key2 dict2
+    opts <- getField widget SOptions
+    case opts of
+      OptionLabels _ -> do
+        setField' widget SSelectedLabel label
+        setField' widget SSelectedValue label
+      OptionDict ps -> case lookup label ps of
+        Nothing -> return ()
+        Just value -> do
+          setField' widget SSelectedLabel label
+          setField' widget SSelectedValue value
+    triggerSelection widget

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module IHaskell.Display.Widgets.Selection.SelectMultiple (
+    -- * The SelectMultiple Widget
+    SelectMultipleWidget,
+    -- * Constructor
+    mkSelectMultipleWidget,
+    ) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Control.Monad (fmap, join, sequence)
+import           Data.Aeson
+import qualified Data.HashMap.Strict as HM
+import           Data.IORef (newIORef)
+import           Data.Text (Text)
+import qualified Data.Vector as V
+import           Data.Vinyl (Rec (..), (<+>))
+
+import           IHaskell.Display
+import           IHaskell.Eval.Widgets
+import           IHaskell.IPython.Message.UUID as U
+
+import           IHaskell.Display.Widgets.Types
+import           IHaskell.Display.Widgets.Common
+
+-- | A 'SelectMultipleWidget' represents a SelectMultiple widget from IPython.html.widgets.
+type SelectMultipleWidget = IPythonWidget SelectMultipleType
+
+-- | Create a new SelectMultiple widget
+mkSelectMultipleWidget :: IO SelectMultipleWidget
+mkSelectMultipleWidget = do
+  -- Default properties, with a random uuid
+  uuid <- U.random
+  let widgetState = WidgetState $ defaultMultipleSelectionWidget "SelectMultipleView"
+
+  stateIO <- newIORef widgetState
+
+  let widget = IPythonWidget uuid stateIO
+      initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.SelectMultiple"]
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen widget initData $ toJSON widgetState
+
+  -- Return the widget
+  return widget
+
+-- | Artificially trigger a selection
+triggerSelection :: SelectMultipleWidget -> IO ()
+triggerSelection widget = join $ getField widget SSelectionHandler
+
+instance IHaskellDisplay SelectMultipleWidget where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget SelectMultipleWidget where
+  getCommUUID = uuid
+  comm widget (Object dict1) _ = do
+    let key1 = "sync_data" :: Text
+        key2 = "selected_labels" :: Text
+        Just (Object dict2) = HM.lookup key1 dict1
+        Just (Array labels) = HM.lookup key2 dict2
+        labelList = map (\(String x) -> x) $ V.toList labels
+    opts <- getField widget SOptions
+    case opts of
+      OptionLabels _ -> do
+        setField' widget SSelectedLabels labelList
+        setField' widget SSelectedValues labelList
+      OptionDict ps -> case sequence $ map (`lookup` ps) labelList of
+        Nothing -> return ()
+        Just valueList -> do
+          setField' widget SSelectedLabels labelList
+          setField' widget SSelectedValues valueList
+    triggerSelection widget

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module IHaskell.Display.Widgets.Selection.ToggleButtons (
+    -- * The ToggleButtons Widget
+    ToggleButtons,
+    -- * Constructor
+    mkToggleButtons,
+    ) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Control.Monad (when, join)
+import           Data.Aeson
+import qualified Data.HashMap.Strict as HM
+import           Data.IORef (newIORef)
+import           Data.Text (Text)
+import           Data.Vinyl (Rec (..), (<+>))
+
+import           IHaskell.Display
+import           IHaskell.Eval.Widgets
+import           IHaskell.IPython.Message.UUID as U
+
+import           IHaskell.Display.Widgets.Types
+import           IHaskell.Display.Widgets.Common
+
+-- | A 'ToggleButtons' represents a ToggleButtons widget from IPython.html.widgets.
+type ToggleButtons = IPythonWidget ToggleButtonsType
+
+-- | Create a new ToggleButtons widget
+mkToggleButtons :: IO ToggleButtons
+mkToggleButtons = do
+  -- Default properties, with a random uuid
+  uuid <- U.random
+  let selectionAttrs = defaultSelectionWidget "ToggleButtonsView"
+      toggleButtonsAttrs = (STooltips =:: [])
+                        :& (SIcons =:: [])
+                        :& (SButtonStyle =:: DefaultButton)
+                        :& RNil
+      widgetState = WidgetState $ selectionAttrs <+> toggleButtonsAttrs
+
+  stateIO <- newIORef widgetState
+
+  let widget = IPythonWidget uuid stateIO
+      initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.ToggleButtons"]
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen widget initData $ toJSON widgetState
+
+  -- Return the widget
+  return widget
+
+-- | Artificially trigger a selection
+triggerSelection :: ToggleButtons -> IO ()
+triggerSelection widget = join $ getField widget SSelectionHandler
+
+instance IHaskellDisplay ToggleButtons where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget ToggleButtons where
+  getCommUUID = uuid
+  comm widget (Object dict1) _ = do
+    let key1 = "sync_data" :: Text
+        key2 = "selected_label" :: Text
+        Just (Object dict2) = HM.lookup key1 dict1
+        Just (String label) = HM.lookup key2 dict2
+    opts <- getField widget SOptions
+    case opts of
+      OptionLabels _ -> do
+        setField' widget SSelectedLabel label
+        setField' widget SSelectedValue label
+      OptionDict ps -> case lookup label ps of
+        Nothing -> return ()
+        Just value -> do
+          setField' widget SSelectedLabel label
+          setField' widget SSelectedValue value
+    triggerSelection widget

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

@@ -37,7 +37,7 @@ module IHaskell.Display.Widgets.Types where
 -- properties wrapped together with the corresponding promoted Field type. See ('=::') for more.
 --
 -- The IPython widgets expect state updates of the form {"property": value}, where an empty string for
--- value is ignored by the frontend and the default value is used instead.
+-- numeric values is ignored by the frontend and the default value is used instead.
 --
 -- To know more about the IPython messaging specification (as implemented in this package) take a look
 -- at the supplied MsgSpec.md.
@@ -75,6 +75,10 @@ type DOMWidgetClass = WidgetClass :++
     ]
 type StringClass = DOMWidgetClass :++ '[StringValue, Disabled, Description, Placeholder]
 type BoolClass = DOMWidgetClass :++ '[BoolValue, Disabled, Description]
+type SelectionClass = DOMWidgetClass :++
+   '[Options, SelectedValue, SelectedLabel, Disabled, Description, SelectionHandler]
+type MultipleSelectionClass = DOMWidgetClass :++
+   '[Options, SelectedLabels, SelectedValues, Disabled, Description, SelectionHandler]
 
 -- Types associated with Fields.
 type family FieldType (f :: Field) :: * where
@@ -114,6 +118,14 @@ type family FieldType (f :: Field) :: * where
   FieldType B64Value = Base64
   FieldType ImageFormat = ImageFormatValue
   FieldType BoolValue = Bool
+  FieldType Options = SelectionOptions
+  FieldType SelectedLabel = Text
+  FieldType SelectedValue = Text
+  FieldType SelectionHandler = IO ()
+  FieldType Tooltips = [Text]
+  FieldType Icons = [Text]
+  FieldType SelectedLabels = [Text]
+  FieldType SelectedValues = [Text]
 
 -- Different types of widgets. Every widget in IPython has a corresponding WidgetType
 data WidgetType = ButtonType
@@ -125,6 +137,11 @@ data WidgetType = ButtonType
                 | TextAreaType
                 | CheckBoxType
                 | ToggleButtonType
+                | DropdownType
+                | RadioButtonsType
+                | SelectType
+                | ToggleButtonsType
+                | SelectMultipleType
 
 -- Fields associated with a widget
 type family WidgetFields (w :: WidgetType) :: [Field] where
@@ -137,6 +154,11 @@ type family WidgetFields (w :: WidgetType) :: [Field] where
   WidgetFields TextAreaType = StringClass
   WidgetFields CheckBoxType = BoolClass
   WidgetFields ToggleButtonType = BoolClass :++ '[Tooltip, Icon, ButtonStyle]
+  WidgetFields DropdownType = SelectionClass :++ '[ButtonStyle]
+  WidgetFields RadioButtonsType = SelectionClass
+  WidgetFields SelectType = SelectionClass
+  WidgetFields ToggleButtonsType = SelectionClass :++ '[Tooltips, Icons, ButtonStyle]
+  WidgetFields SelectMultipleType = MultipleSelectionClass
 
 -- Wrapper around a field
 newtype Attr (f :: Field) = Attr { _unAttr :: FieldType f }
@@ -152,7 +174,7 @@ instance ToPairs (Attr ViewModule) where toPairs (Attr x) = ["_view_module" .= t
 instance ToPairs (Attr ViewName) where toPairs (Attr x) = ["_view_name" .= toJSON x]
 instance ToPairs (Attr MsgThrottle) where toPairs (Attr x) = ["msg_throttle" .= toJSON x]
 instance ToPairs (Attr Version) where toPairs (Attr x) = ["version" .= toJSON x]
-instance ToPairs (Attr OnDisplayed) where toPairs (Attr x) = [] -- Not sent to the frontend
+instance ToPairs (Attr OnDisplayed) where toPairs _ = [] -- Not sent to the frontend
 instance ToPairs (Attr Visible) where toPairs (Attr x) = ["visible" .= toJSON x]
 instance ToPairs (Attr CSS) where toPairs (Attr x) = ["_css" .= toJSON x]
 instance ToPairs (Attr DOMClasses) where toPairs (Attr x) = ["_dom_classes" .= toJSON x]
@@ -171,8 +193,8 @@ instance ToPairs (Attr FontWeight) where toPairs (Attr x) = ["font_weight" .= to
 instance ToPairs (Attr FontSize) where toPairs (Attr x) = ["font_size" .= toJSON x]
 instance ToPairs (Attr FontFamily) where toPairs (Attr x) = ["font_family" .= toJSON x]
 instance ToPairs (Attr Description) where toPairs (Attr x) = ["description" .= toJSON x]
-instance ToPairs (Attr ClickHandler) where toPairs (Attr x) = [] -- Not sent to the frontend
-instance ToPairs (Attr SubmitHandler) where toPairs (Attr x) = [] -- Not sent to the frontend
+instance ToPairs (Attr ClickHandler) where toPairs _ = [] -- Not sent to the frontend
+instance ToPairs (Attr SubmitHandler) where toPairs _ = [] -- Not sent to the frontend
 instance ToPairs (Attr Disabled) where toPairs (Attr x) = ["disabled" .= toJSON x]
 instance ToPairs (Attr StringValue) where toPairs (Attr x) = ["value" .= toJSON x]
 instance ToPairs (Attr Placeholder) where toPairs (Attr x) = ["placeholder" .= toJSON x]
@@ -182,6 +204,18 @@ instance ToPairs (Attr ButtonStyle) where toPairs (Attr x) = ["button_style" .=
 instance ToPairs (Attr B64Value) where toPairs (Attr x) = ["_b64value" .= toJSON x]
 instance ToPairs (Attr ImageFormat) where toPairs (Attr x) = ["format" .= toJSON x]
 instance ToPairs (Attr BoolValue) where toPairs (Attr x) = ["value" .= toJSON x]
+instance ToPairs (Attr SelectedLabel) where toPairs (Attr x) = ["selected_label" .= toJSON x]
+instance ToPairs (Attr SelectedValue) where toPairs (Attr x) = ["value" .= toJSON x]
+instance ToPairs (Attr Options) where
+  toPairs (Attr x) = case x of
+    OptionLabels xs -> labels xs
+    OptionDict xps -> labels $ map fst xps
+    where labels xs = ["_options_labels" .= xs]
+instance ToPairs (Attr SelectionHandler) where toPairs _ = [] -- Not sent to the frontend
+instance ToPairs (Attr Tooltips) where toPairs (Attr x) = ["tooltips" .= toJSON x]
+instance ToPairs (Attr Icons) where toPairs (Attr x) = ["icons" .= toJSON x]
+instance ToPairs (Attr SelectedLabels) where toPairs (Attr x) = ["selected_labels" .= toJSON x]
+instance ToPairs (Attr SelectedValues) where toPairs (Attr x) = ["values" .= toJSON x]
 
 -- | Store the value for a field, as an object parametrized by the Field
 (=::) :: sing f -> FieldType f -> Attr f
@@ -237,6 +271,28 @@ defaultBoolWidget viewName = defaultDOMWidget viewName <+> boolAttrs
                  :& (SDescription =:: "")
                  :& RNil
 
+-- | A record representing a widget of the _Selection class from IPython
+defaultSelectionWidget :: FieldType ViewName -> Rec Attr SelectionClass
+defaultSelectionWidget viewName = defaultDOMWidget viewName <+> selectionAttrs
+  where selectionAttrs = (SOptions =:: OptionLabels [])
+                      :& (SSelectedValue =:: "")
+                      :& (SSelectedLabel =:: "")
+                      :& (SDisabled =:: False)
+                      :& (SDescription =:: "")
+                      :& (SSelectionHandler =:: return ())
+                      :& RNil
+
+-- | A record representing a widget of the _MultipleSelection class from IPython
+defaultMultipleSelectionWidget :: FieldType ViewName -> Rec Attr MultipleSelectionClass
+defaultMultipleSelectionWidget viewName = defaultDOMWidget viewName <+> mulSelAttrs
+  where mulSelAttrs = (SOptions =:: OptionLabels [])
+                   :& (SSelectedLabels =:: [])
+                   :& (SSelectedValues =:: [])
+                   :& (SDisabled =:: False)
+                   :& (SDescription =:: "")
+                   :& (SSelectionHandler =:: return ())
+                   :& RNil
+
 newtype WidgetState w = WidgetState { _getState :: Rec Attr (WidgetFields w) }
 
 -- All records with ToPair instances for their Attrs will automatically have a toJSON instance now.