Added Selection Sliders widgets

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

@@ -83,6 +83,8 @@ library
                        IHaskell.Display.Widgets.Selection.Dropdown
                        IHaskell.Display.Widgets.Selection.RadioButtons
                        IHaskell.Display.Widgets.Selection.Select
+                       IHaskell.Display.Widgets.Selection.SelectionSlider
+                       IHaskell.Display.Widgets.Selection.SelectionRangeSlider
                        IHaskell.Display.Widgets.Selection.ToggleButtons
                        IHaskell.Display.Widgets.Selection.SelectMultiple
                        IHaskell.Display.Widgets.String.HTML

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

@@ -30,6 +30,8 @@ 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.SelectionSlider as X
+import           IHaskell.Display.Widgets.Selection.SelectionRangeSlider as X
 import           IHaskell.Display.Widgets.Selection.ToggleButtons as X
 import           IHaskell.Display.Widgets.Selection.SelectMultiple as X
 

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module IHaskell.Display.Widgets.Selection.SelectionRangeSlider
+  ( -- * The SelectionRangeSlider Widget
+    SelectionRangeSlider
+    -- * Constructor
+  , mkSelectionRangeSlider
+  ) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+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           Data.Vinyl (Rec(..), (<+>), rput)
+
+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 'SelectionRangeSlider' represents a SelectionSlider widget from IPyhon.widgets
+type SelectionRangeSlider = IPythonWidget 'SelectionRangeSliderType
+
+-- | Create a new SelectionRangeSlider widget
+mkSelectionRangeSlider :: IO SelectionRangeSlider
+mkSelectionRangeSlider = do
+  wid <- U.random
+  let selectionAttrs = defaultMultipleSelectionWidget "SelectionRangeSliderView" "SelectionRangeSliderModel"
+      widgetState = WidgetState $ rput (Indices =:: [0,0]) $ selectionAttrs <+>
+        (Orientation =:: HorizontalOrientation)
+        :& RNil
+
+  stateIO <- newIORef widgetState
+
+  let widget = IPythonWidget wid stateIO
+
+  -- Open a comm for this widget and store it in the kernel state
+  widgetSendOpen widget $ toJSON widgetState
+
+  -- Return the created widget
+  return widget
+
+instance IHaskellWidget SelectionRangeSlider where
+  getCommUUID = uuid
+  comm widget val _ =
+    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 ()
\ No newline at end of file

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module IHaskell.Display.Widgets.Selection.SelectionSlider
+  ( -- * The SelectionSlider Widget
+    SelectionSlider
+    -- * Constructor
+  , mkSelectionSlider
+  ) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+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
+import           IHaskell.Eval.Widgets
+import           IHaskell.IPython.Message.UUID as U
+
+import           IHaskell.Display.Widgets.Types
+import           IHaskell.Display.Widgets.Common
+
+-- | A 'SelectionSlider' represents a SelectionSlider widget from IPyhon.widgets
+type SelectionSlider = IPythonWidget 'SelectionSliderType
+
+-- | Create a new SelectionSLider widget
+mkSelectionSlider :: IO SelectionSlider
+mkSelectionSlider = do
+  wid <- U.random
+  let selectionAttrs = defaultSelectionWidget "SelectionSliderView" "SelectionSliderModel"
+      widgetState = WidgetState $ selectionAttrs <+>
+        (Orientation =:: HorizontalOrientation)
+        :& RNil
+
+  stateIO <- newIORef widgetState
+
+  let widget = IPythonWidget wid stateIO
+
+  -- Open a comm for this widget and store it in the kernel state
+  widgetSendOpen widget $ toJSON widgetState
+
+  -- Return the created widget
+  return widget
+
+instance IHaskellWidget SelectionSlider where
+  getCommUUID = uuid
+  comm widget val _ =
+    case nestedObjectLookup val ["state", "index"] of
+      Just (Number index) -> do
+        void $ setField' widget Index (Sci.coefficient index)
+        triggerSelection widget
+      _ -> pure ()
\ No newline at end of file

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

@@ -6,7 +6,7 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module IHaskell.Display.Widgets.String.HTMLMath
-  ( -- * The HTML Widget
+  ( -- * The HTMLMath Widget
     HTMLMathWidget
     -- * Constructor
   , mkHTMLMathWidget

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

@@ -281,6 +281,8 @@ data WidgetType = ButtonType
                 | DropdownType
                 | RadioButtonsType
                 | SelectType
+                | SelectionSliderType
+                | SelectionRangeSliderType
                 | ToggleButtonsType
                 | SelectMultipleType
                 | IntTextType
@@ -327,6 +329,8 @@ type family WidgetFields (w :: WidgetType) :: [Field] where
   WidgetFields 'DropdownType = SelectionClass :++ '[ 'S.ButtonStyle]
   WidgetFields 'RadioButtonsType = SelectionClass
   WidgetFields 'SelectType = SelectionClass
+  WidgetFields 'SelectionSliderType = SelectionClass :++ '[ 'S.Orientation ]
+  WidgetFields 'SelectionRangeSliderType = MultipleSelectionClass :++ '[ 'S.Orientation ]
   WidgetFields 'ToggleButtonsType =
                   SelectionClass :++ ['S.Tooltips, 'S.Icons, 'S.ButtonStyle]
   WidgetFields 'SelectMultipleType = MultipleSelectionClass