Finished reimplementing class hierarchy

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

@@ -48,6 +48,7 @@ pattern B64Value = S.SB64Value
 pattern ImageFormat = S.SImageFormat
 pattern BoolValue = S.SBoolValue
 pattern Options = S.SOptions
+pattern OptionalIndex = S.SOptionalIndex
 pattern Index = S.SIndex
 pattern SelectionHandler = S.SSelectionHandler
 pattern Tooltips = S.STooltips

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

@@ -36,9 +36,7 @@ mkDropdown :: IO Dropdown
 mkDropdown = do
   -- Default properties, with a random uuid
   wid <- U.random
-  let selectionAttrs = defaultSelectionWidget "DropdownView" "DropdownModel"
-      dropdownAttrs = (ButtonStyle =:: DefaultButton) :& RNil
-      widgetState = WidgetState $ selectionAttrs <+> dropdownAttrs
+  let widgetState = WidgetState $ defaultSelectionWidget "DropdownView" "DropdownModel"
 
   stateIO <- newIORef widgetState
 
@@ -55,6 +53,6 @@ instance IHaskellWidget Dropdown where
   comm widget val _ =
     case nestedObjectLookup val ["state", "index"] of
       Just (Number index) -> do
-        void $ setField' widget Index (Sci.coefficient index)
+        void $ setField' widget OptionalIndex (Just $ Sci.coefficient index)
         triggerSelection widget
       _ -> pure ()

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

@@ -52,6 +52,6 @@ instance IHaskellWidget RadioButtons where
   comm widget val _ =
     case nestedObjectLookup val ["state", "index"] of
       Just (Number index) -> do
-        void $ setField' widget Index (Sci.coefficient index)
+        void $ setField' widget OptionalIndex (Just $ Sci.coefficient index)
         triggerSelection widget
       _ -> pure ()

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

@@ -19,6 +19,7 @@ import           Control.Monad (void)
 import           Data.Aeson
 import           Data.IORef (newIORef)
 import qualified Data.Scientific as Sci
+import           Data.Vinyl (Rec(..), (<+>))
 
 import           IHaskell.Display
 import           IHaskell.Eval.Widgets
@@ -35,7 +36,10 @@ mkSelect :: IO Select
 mkSelect = do
   -- Default properties, with a random uuid
   wid <- U.random
-  let widgetState = WidgetState $ defaultSelectionWidget "SelectView" "SelectModel"
+  let selectionAttrs = defaultSelectionWidget "SelectView" "SelectModel"
+      selectAttrs = (Rows =:: Just 5)
+                    :& RNil
+      widgetState = WidgetState $ selectionAttrs <+> selectAttrs
 
   stateIO <- newIORef widgetState
 
@@ -52,6 +56,6 @@ instance IHaskellWidget Select where
   comm widget val _ =
     case nestedObjectLookup val ["state", "index"] of
       Just (Number index) -> do
-        void $ setField' widget Index (Sci.coefficient index)
+        void $ setField' widget OptionalIndex (Just $ Sci.coefficient index)
         triggerSelection widget
       _ -> pure ()

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

@@ -20,6 +20,7 @@ import           Data.Aeson
 import           Data.IORef (newIORef)
 import qualified Data.Scientific as Sci
 import qualified Data.Vector as V
+import           Data.Vinyl (Rec(..), (<+>))
 
 import           IHaskell.Display
 import           IHaskell.Eval.Widgets
@@ -36,7 +37,10 @@ mkSelectMultiple :: IO SelectMultiple
 mkSelectMultiple = do
   -- Default properties, with a random uuid
   wid <- U.random
-  let widgetState = WidgetState $ defaultMultipleSelectionWidget "SelectMultipleView" "SelectMultipleModel"
+  let multipleSelectionAttrs = defaultMultipleSelectionWidget "SelectMultipleView" "SelectMultipleModel"
+      selectMultipleAttrs = (Rows =:: Just 5)
+                            :& RNil
+      widgetState = WidgetState $ multipleSelectionAttrs <+> selectMultipleAttrs
 
   stateIO <- newIORef widgetState
 

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

@@ -37,9 +37,11 @@ mkSelectionRangeSlider :: IO SelectionRangeSlider
 mkSelectionRangeSlider = do
   wid <- U.random
   let selectionAttrs = defaultMultipleSelectionWidget "SelectionRangeSliderView" "SelectionRangeSliderModel"
-      widgetState = WidgetState $ rput (Indices =:: [0,0]) $ selectionAttrs <+>
-        (Orientation =:: HorizontalOrientation)
-        :& RNil
+      selectionRangeSliderAttrs = (Orientation =:: HorizontalOrientation)
+                                  :& (ReadOut =:: True)
+                                  :& (ContinuousUpdate =:: True)
+                                  :& RNil
+      widgetState = WidgetState $ rput (Indices =:: [0,0]) $ selectionAttrs <+> selectionRangeSliderAttrs
 
   stateIO <- newIORef widgetState
 

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

@@ -35,10 +35,12 @@ type SelectionSlider = IPythonWidget 'SelectionSliderType
 mkSelectionSlider :: IO SelectionSlider
 mkSelectionSlider = do
   wid <- U.random
-  let selectionAttrs = defaultSelectionWidget "SelectionSliderView" "SelectionSliderModel"
-      widgetState = WidgetState $ selectionAttrs <+>
-        (Orientation =:: HorizontalOrientation)
-        :& RNil
+  let selectionAttrs = defaultSelectionNonemptyWidget "SelectionSliderView" "SelectionSliderModel"
+      selectionSliderAttrs = (Orientation =:: HorizontalOrientation)
+                             :& (ReadOut =:: True)
+                             :& (ContinuousUpdate =:: True)
+                             :& RNil
+      widgetState = WidgetState $ selectionAttrs <+> selectionSliderAttrs
 
   stateIO <- newIORef widgetState
 

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

@@ -58,6 +58,6 @@ instance IHaskellWidget ToggleButtons where
   comm widget val _ =
     case nestedObjectLookup val ["state", "index"] of
       Just (Number index) -> do
-        void $ setField' widget Index (Sci.coefficient index)
+        void $ setField' widget OptionalIndex (Just $ Sci.coefficient index)
         triggerSelection widget
       _ -> pure ()

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

@@ -55,6 +55,7 @@ singletons
              | BoolValue
              | Options
              | Index
+             | OptionalIndex
              | SelectionHandler
              | Tooltips
              | Icons

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

@@ -134,11 +134,11 @@ type StringClass = DescriptionWidgetClass :++ ['S.StringValue, 'S.Placeholder]
 
 type BoolClass = DescriptionWidgetClass :++ ['S.BoolValue, 'S.Disabled, 'S.ChangeHandler]
 
-type SelectionClass = DOMWidgetClass :++ ['S.Options, 'S.Index, 'S.Disabled,
-  'S.Description, 'S.SelectionHandler]
+type SelectionClass = DescriptionWidgetClass :++ ['S.Options, 'S.OptionalIndex, 'S.Disabled, 'S.SelectionHandler]
 
-type MultipleSelectionClass = DOMWidgetClass :++ ['S.Options, 'S.Indices, 'S.Disabled,
-  'S.Description, 'S.SelectionHandler]
+type SelectionNonemptyClass = DescriptionWidgetClass :++ ['S.Options, 'S.Index, 'S.Disabled, 'S.SelectionHandler]
+
+type MultipleSelectionClass = DescriptionWidgetClass :++ ['S.Options, 'S.Indices, 'S.Disabled, 'S.SelectionHandler]
 
 type IntClass = DescriptionWidgetClass :++ [ 'S.IntValue, 'S.ChangeHandler ]
 
@@ -189,6 +189,7 @@ type family FieldType (f :: Field) :: * where
         FieldType 'S.BoolValue = Bool
         FieldType 'S.Options = SelectionOptions
         FieldType 'S.Index = Integer
+        FieldType 'S.OptionalIndex = Maybe Integer
         FieldType 'S.SelectionHandler = IO ()
         FieldType 'S.Tooltips = [Text]
         FieldType 'S.Icons = [Text]
@@ -315,14 +316,14 @@ type family WidgetFields (w :: WidgetType) :: [Field] where
   WidgetFields 'CheckBoxType = BoolClass :++ '[ 'S.Indent ]
   WidgetFields 'ToggleButtonType = BoolClass :++ ['S.Icon, 'S.ButtonStyle]
   WidgetFields 'ValidType = BoolClass :++ '[ 'S.ReadOutMsg ]
-  WidgetFields 'DropdownType = SelectionClass :++ '[ 'S.ButtonStyle]
+  WidgetFields 'DropdownType = SelectionClass
   WidgetFields 'RadioButtonsType = SelectionClass
-  WidgetFields 'SelectType = SelectionClass
-  WidgetFields 'SelectionSliderType = SelectionClass :++ '[ 'S.Orientation ]
-  WidgetFields 'SelectionRangeSliderType = MultipleSelectionClass :++ '[ 'S.Orientation ]
+  WidgetFields 'SelectType = SelectionClass :++ '[ 'S.Rows ]
+  WidgetFields 'SelectionSliderType = SelectionNonemptyClass :++ '[ 'S.Orientation, 'S.ReadOut, 'S.ContinuousUpdate ]
+  WidgetFields 'SelectionRangeSliderType = MultipleSelectionClass :++ '[ 'S.Orientation, 'S.ReadOut, 'S.ContinuousUpdate ]
   WidgetFields 'ToggleButtonsType =
                   SelectionClass :++ ['S.Tooltips, 'S.Icons, 'S.ButtonStyle]
-  WidgetFields 'SelectMultipleType = MultipleSelectionClass
+  WidgetFields 'SelectMultipleType = MultipleSelectionClass ++ '[ S.Rows ]
   WidgetFields 'IntTextType = IntClass :++ [ 'S.Disabled, 'S.ContinuousUpdate, 'S.StepInt ]
   WidgetFields 'BoundedIntTextType = BoundedIntClass :++ [ 'S.Disabled, 'S.ContinuousUpdate, 'S.StepInt ]
   WidgetFields 'IntSliderType =
@@ -449,6 +450,9 @@ instance ToPairs (Attr 'S.BoolValue) where
 instance ToPairs (Attr 'S.Index) where
   toPairs x = ["index" .= toJSON x]
 
+instance ToPairs (Attr 'S.OptionalIndex) where
+  toPairs x = ["index" .= toJSON x]
+
 instance ToPairs (Attr 'S.Options) where
   toPairs x =
     case _value x of
@@ -657,23 +661,31 @@ defaultBoolWidget viewName modelName = defaultDescriptionWidget viewName modelNa
 
 -- | A record representing a widget of the _Selection class from IPython
 defaultSelectionWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr SelectionClass
-defaultSelectionWidget viewName modelName = defaultDOMWidget viewName modelName <+> selectionAttrs
+defaultSelectionWidget viewName modelName = defaultDescriptionWidget viewName modelName <+> selectionAttrs
+  where
+    selectionAttrs = (Options =:: OptionLabels [])
+                     :& (OptionalIndex =:: Nothing)
+                     :& (Disabled =:: False)
+                     :& (SelectionHandler =:: return ())
+                     :& RNil
+
+-- | A record representing a widget of the _SelectionNonempty class from IPython
+defaultSelectionNonemptyWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr SelectionNonemptyClass
+defaultSelectionNonemptyWidget viewName modelName = defaultDescriptionWidget viewName modelName <+> selectionAttrs
   where
     selectionAttrs = (Options =:: OptionLabels [])
                      :& (Index =:: 0)
                      :& (Disabled =:: False)
-                     :& (Description =:: "")
                      :& (SelectionHandler =:: return ())
                      :& RNil
 
 -- | A record representing a widget of the _MultipleSelection class from IPython
 defaultMultipleSelectionWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr MultipleSelectionClass
-defaultMultipleSelectionWidget viewName modelName = defaultDOMWidget viewName modelName <+> mulSelAttrs
+defaultMultipleSelectionWidget viewName modelName = defaultDescriptionWidget viewName modelName <+> mulSelAttrs
   where
     mulSelAttrs = (Options =:: OptionLabels [])
                   :& (Indices =:: [])
                   :& (Disabled =:: False)
-                  :& (Description =:: "")
                   :& (SelectionHandler =:: return ())
                   :& RNil