Numeric float widgets

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

@@ -76,6 +76,7 @@ library
                        IHaskell.Display.Widgets.Float.BoundedFloat.BoundedFloatText
                        IHaskell.Display.Widgets.Float.BoundedFloat.FloatProgress
                        IHaskell.Display.Widgets.Float.BoundedFloat.FloatSlider
+                       IHaskell.Display.Widgets.Float.BoundedFloat.FloatLogSlider
                        IHaskell.Display.Widgets.Float.BoundedFloatRange.FloatRangeSlider
                        IHaskell.Display.Widgets.Image
                        IHaskell.Display.Widgets.Output

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

@@ -20,6 +20,7 @@ import           IHaskell.Display.Widgets.Float.FloatText as X
 import           IHaskell.Display.Widgets.Float.BoundedFloat.BoundedFloatText as X
 import           IHaskell.Display.Widgets.Float.BoundedFloat.FloatProgress as X
 import           IHaskell.Display.Widgets.Float.BoundedFloat.FloatSlider as X
+import           IHaskell.Display.Widgets.Float.BoundedFloat.FloatLogSlider as X
 import           IHaskell.Display.Widgets.Float.BoundedFloatRange.FloatRangeSlider as X
 
 import           IHaskell.Display.Widgets.Image as X

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

@@ -82,6 +82,7 @@ pattern FloatPairValue = S.SFloatPairValue
 pattern LowerFloat = S.SLowerFloat
 pattern UpperFloat = S.SUpperFloat
 pattern Orientation = S.SOrientation
+pattern BaseFloat = S.SBaseFloat
 pattern ShowRange = S.SShowRange
 pattern ReadOut = S.SReadOut
 pattern SliderColor = S.SSliderColor

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Float/BoundedFloat/BoundedFloatText.hs

@@ -36,7 +36,7 @@ mkBoundedFloatText = do
   -- Default properties, with a random uuid
   wid <- U.random
 
-  let widgetState = WidgetState $ defaultBoundedFloatWidget "FloatTextView" "FloatTextModel"
+  let widgetState = WidgetState $ defaultBoundedFloatWidget "FloatTextView" "BoundedFloatTextModel"
 
   stateIO <- newIORef widgetState
 

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Float/BoundedFloat/FloatLogSlider.hs

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans  #-}
+
+module IHaskell.Display.Widgets.Float.BoundedFloat.FloatLogSlider
+  ( -- * The FloatSlider Widget
+    FloatLogSlider
+    -- * Constructor
+  , mkFloatLogSlider
+  ) 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
+
+-- | 'FloatLogSlider' represents an FloatLogSlider widget from IPython.html.widgets.
+type FloatLogSlider = IPythonWidget 'FloatLogSliderType
+
+-- | Create a new widget
+mkFloatLogSlider :: IO FloatLogSlider
+mkFloatLogSlider = do
+  -- Default properties, with a random uuid
+  wid <- U.random
+
+  let boundedFloatAttrs = defaultBoundedFloatWidget "FloatLogSliderView" "FloatLogSliderModel"
+      sliderAttrs = (Orientation =:: HorizontalOrientation)
+                    :& (ShowRange =:: False)
+                    :& (ReadOut =:: True)
+                    :& (SliderColor =:: "")
+                    :& (BaseFloat =:: 10.0)
+                    :& RNil
+      widgetState = WidgetState $ boundedFloatAttrs <+> sliderAttrs
+
+  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 widget
+  return widget
+
+instance IHaskellWidget FloatLogSlider where
+  getCommUUID = uuid
+  comm widget val _ =
+    case nestedObjectLookup val ["state", "value"] of
+      Just (Number value) -> do
+        void $ setField' widget FloatValue (Sci.toRealFloat value)
+        triggerChange widget
+      _ -> pure ()

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Float/BoundedFloat/FloatProgress.hs

@@ -35,7 +35,7 @@ mkFloatProgress = do
   -- Default properties, with a random uuid
   wid <- U.random
 
-  let boundedFloatAttrs = defaultBoundedFloatWidget "ProgressView" "ProgressModel"
+  let boundedFloatAttrs = defaultBoundedFloatWidget "ProgressView" "FloatProgressModel"
       progressAttrs = (Orientation =:: HorizontalOrientation)
                       :& (BarStyle =:: DefaultBar)
                       :& RNil

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Float/BoundedFloatRange/FloatRangeSlider.hs

@@ -38,7 +38,7 @@ mkFloatRangeSlider = do
   -- Default properties, with a random uuid
   wid <- U.random
 
-  let boundedFloatAttrs = defaultBoundedFloatRangeWidget "FloatSliderView" "FloatSliderModel"
+  let boundedFloatAttrs = defaultBoundedFloatRangeWidget "FloatRangeSliderView" "FloatRangeSliderModel"
       sliderAttrs = (Orientation =:: HorizontalOrientation)
                     :& (ShowRange =:: True)
                     :& (ReadOut =:: True)

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Int/BoundedInt/BoundedIntText.hs

@@ -36,7 +36,7 @@ mkBoundedIntText = do
   -- Default properties, with a random uuid
   wid <- U.random
 
-  let widgetState = WidgetState $ defaultBoundedIntWidget "IntTextView" "IntTextModel"
+  let widgetState = WidgetState $ defaultBoundedIntWidget "IntTextView" "BoundedIntTextModel"
 
   stateIO <- newIORef widgetState
 

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

@@ -88,6 +88,7 @@ singletons
              | LowerFloat
              | UpperFloat
              | Orientation
+             | BaseFloat
              | ShowRange
              | ReadOut
              | SliderColor

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

@@ -215,6 +215,7 @@ type family FieldType (f :: Field) :: * where
         FieldType 'S.UpperInt = Integer
         FieldType 'S.IntPairValue = (Integer, Integer)
         FieldType 'S.Orientation = OrientationValue
+        FieldType 'S.BaseFloat = Double
         FieldType 'S.ShowRange = Bool
         FieldType 'S.ReadOut = Bool
         FieldType 'S.SliderColor = Text
@@ -289,6 +290,7 @@ data WidgetType = ButtonType
                 | FloatTextType
                 | BoundedFloatTextType
                 | FloatSliderType
+                | FloatLogSliderType
                 | FloatProgressType
                 | FloatRangeSliderType
                 | BoxType
@@ -341,6 +343,9 @@ type family WidgetFields (w :: WidgetType) :: [Field] where
   WidgetFields 'FloatSliderType =
                   BoundedFloatClass :++
                     ['S.Orientation, 'S.ShowRange, 'S.ReadOut, 'S.SliderColor]
+  WidgetFields 'FloatLogSliderType =
+                  BoundedFloatClass :++ 
+                    ['S.Orientation, 'S.ShowRange, 'S.ReadOut, 'S.SliderColor, 'S.BaseFloat]
   WidgetFields 'FloatProgressType =
                   BoundedFloatClass :++ ['S.Orientation, 'S.BarStyle]
   WidgetFields 'FloatRangeSliderType =
@@ -557,6 +562,9 @@ instance ToPairs (Attr 'S.UpperFloat) where
 instance ToPairs (Attr 'S.Orientation) where
   toPairs x = ["orientation" .= toJSON x]
 
+instance ToPairs (Attr 'S.BaseFloat) where
+  toPairs x = ["base" .= toJSON x]
+
 instance ToPairs (Attr 'S.ShowRange) where
   toPairs x = ["_range" .= toJSON x]