Add float widgets

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

@@ -62,6 +62,11 @@ library
                        IHaskell.Display.Widgets.Int.BoundedInt.IntProgress
                        IHaskell.Display.Widgets.Int.BoundedInt.IntSlider
                        IHaskell.Display.Widgets.Int.BoundedIntRange.IntRangeSlider
+                       IHaskell.Display.Widgets.Float.FloatText
+                       IHaskell.Display.Widgets.Float.BoundedFloat.BoundedFloatText
+                       IHaskell.Display.Widgets.Float.BoundedFloat.FloatProgress
+                       IHaskell.Display.Widgets.Float.BoundedFloat.FloatSlider
+                       IHaskell.Display.Widgets.Float.BoundedFloatRange.FloatRangeSlider
                        IHaskell.Display.Widgets.Image
                        IHaskell.Display.Widgets.Output
                        IHaskell.Display.Widgets.Selection.Dropdown

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

@@ -11,6 +11,12 @@ import           IHaskell.Display.Widgets.Int.BoundedInt.IntProgress as X
 import           IHaskell.Display.Widgets.Int.BoundedInt.IntSlider as X
 import           IHaskell.Display.Widgets.Int.BoundedIntRange.IntRangeSlider as X
 
+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.BoundedFloatRange.FloatRangeSlider as X
+
 import           IHaskell.Display.Widgets.Image as X
 
 import           IHaskell.Display.Widgets.Output as X

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

@@ -66,6 +66,13 @@ singletons [d|
              | IntPairValue
              | LowerInt
              | UpperInt
+             | FloatValue
+             | StepFloat
+             | MaxFloat
+             | MinFloat
+             | FloatPairValue
+             | LowerFloat
+             | UpperFloat
              | Orientation
              | ShowRange
              | ReadOut

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module IHaskell.Display.Widgets.Float.BoundedFloat.BoundedFloatText (
+  -- * The BoundedFloatText Widget
+  BoundedFloatTextWidget,
+  -- * Constructor
+  mkBoundedFloatTextWidget) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Control.Exception (throw, ArithException (LossOfPrecision))
+import           Control.Monad (when, join)
+import           Data.Aeson
+import qualified Data.HashMap.Strict as HM
+import           Data.IORef (newIORef)
+import qualified Data.Scientific as Sci
+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
+
+-- | 'BoundedFloatTextWidget' represents an BoundedFloatText widget from IPython.html.widgets.
+type BoundedFloatTextWidget = IPythonWidget BoundedFloatTextType
+
+-- | Create a new widget
+mkBoundedFloatTextWidget :: IO BoundedFloatTextWidget
+mkBoundedFloatTextWidget = do
+  -- Default properties, with a random uuid
+  uuid <- U.random
+
+  let widgetState = WidgetState $ defaultBoundedFloatWidget "FloatTextView"
+
+  stateIO <- newIORef widgetState
+
+  let widget = IPythonWidget uuid stateIO
+      initData = object
+                   [ "model_name" .= str "WidgetModel"
+                   , "widget_class" .= str "IPython.BoundedFloatText"
+                   ]
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen widget initData $ toJSON widgetState
+
+  -- Return the widget
+  return widget
+
+instance IHaskellDisplay BoundedFloatTextWidget where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget BoundedFloatTextWidget where
+  getCommUUID = uuid
+  comm widget (Object dict1) _ = do
+    let key1 = "sync_data" :: Text
+        key2 = "value" :: Text
+        Just (Object dict2) = HM.lookup key1 dict1
+        Just (Number value) = HM.lookup key2 dict2
+    newValue <- if abs value < 10 ^ 16
+                  then return (Sci.toRealFloat value)
+                  else throw LossOfPrecision
+    setField' widget SFloatValue newValue

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module IHaskell.Display.Widgets.Float.BoundedFloat.FloatProgress (
+  -- * The FloatProgress Widget
+  FloatProgressWidget,
+  -- * Constructor
+  mkFloatProgressWidget) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Control.Exception (throw, ArithException (LossOfPrecision))
+import           Control.Monad (when, join)
+import           Data.Aeson
+import qualified Data.HashMap.Strict as HM
+import           Data.IORef (newIORef)
+import qualified Data.Scientific as Sci
+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
+
+-- | 'FloatProgressWidget' represents an FloatProgress widget from IPython.html.widgets.
+type FloatProgressWidget = IPythonWidget FloatProgressType
+
+-- | Create a new widget
+mkFloatProgressWidget :: IO FloatProgressWidget
+mkFloatProgressWidget = do
+  -- Default properties, with a random uuid
+  uuid <- U.random
+
+  let boundedFloatAttrs = defaultBoundedFloatWidget "ProgressView"
+      progressAttrs = (SBarStyle =:: DefaultBar) :& RNil
+      widgetState = WidgetState $ boundedFloatAttrs <+> progressAttrs
+
+  stateIO <- newIORef widgetState
+
+  let widget = IPythonWidget uuid stateIO
+      initData = object
+                   [ "model_name" .= str "WidgetModel"
+                   , "widget_class" .= str "IPython.FloatProgress"
+                   ]
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen widget initData $ toJSON widgetState
+
+  -- Return the widget
+  return widget
+
+instance IHaskellDisplay FloatProgressWidget where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget FloatProgressWidget where
+  getCommUUID = uuid

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module IHaskell.Display.Widgets.Float.BoundedFloat.FloatSlider (
+  -- * The FloatSlider Widget
+  FloatSliderWidget,
+  -- * Constructor
+  mkFloatSliderWidget) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Control.Exception (throw, ArithException (LossOfPrecision))
+import           Control.Monad (when, join)
+import           Data.Aeson
+import qualified Data.HashMap.Strict as HM
+import           Data.IORef (newIORef)
+import qualified Data.Scientific as Sci
+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
+
+-- | 'FloatSliderWidget' represents an FloatSlider widget from IPython.html.widgets.
+type FloatSliderWidget = IPythonWidget FloatSliderType
+
+-- | Create a new widget
+mkFloatSliderWidget :: IO FloatSliderWidget
+mkFloatSliderWidget = do
+  -- Default properties, with a random uuid
+  uuid <- U.random
+
+  let boundedFloatAttrs = defaultBoundedFloatWidget "FloatSliderView"
+      sliderAttrs = (SOrientation =:: HorizontalOrientation)
+                 :& (SShowRange =:: False)
+                 :& (SReadOut =:: True)
+                 :& (SSliderColor =:: "")
+                 :& RNil
+      widgetState = WidgetState $ boundedFloatAttrs <+> sliderAttrs
+
+  stateIO <- newIORef widgetState
+
+  let widget = IPythonWidget uuid stateIO
+      initData = object
+                   [ "model_name" .= str "WidgetModel"
+                   , "widget_class" .= str "IPython.FloatSlider"
+                   ]
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen widget initData $ toJSON widgetState
+
+  -- Return the widget
+  return widget
+
+instance IHaskellDisplay FloatSliderWidget where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget FloatSliderWidget where
+  getCommUUID = uuid
+  comm widget (Object dict1) _ = do
+    let key1 = "sync_data" :: Text
+        key2 = "value" :: Text
+        Just (Object dict2) = HM.lookup key1 dict1
+        Just (Number value) = HM.lookup key2 dict2
+    newValue <- if abs value < 10 ^ 16
+                  then return (Sci.toRealFloat value)
+                  else throw LossOfPrecision
+    setField' widget SFloatValue newValue

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module IHaskell.Display.Widgets.Float.BoundedFloatRange.FloatRangeSlider (
+  -- * The FloatRangeSlider Widget
+  FloatRangeSliderWidget,
+  -- * Constructor
+  mkFloatRangeSliderWidget) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Control.Exception (throw, ArithException (LossOfPrecision))
+import           Control.Monad (when, join)
+import           Data.Aeson
+import qualified Data.HashMap.Strict as HM
+import           Data.IORef (newIORef)
+import qualified Data.Scientific as Sci
+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
+
+-- | 'FloatRangeSliderWidget' represents an FloatRangeSlider widget from IPython.html.widgets.
+type FloatRangeSliderWidget = IPythonWidget FloatRangeSliderType
+
+-- | Create a new widget
+mkFloatRangeSliderWidget :: IO FloatRangeSliderWidget
+mkFloatRangeSliderWidget = do
+  -- Default properties, with a random uuid
+  uuid <- U.random
+
+  let boundedFloatAttrs = defaultBoundedFloatRangeWidget "FloatSliderView"
+      sliderAttrs = (SOrientation =:: HorizontalOrientation)
+                 :& (SShowRange =:: True)
+                 :& (SReadOut =:: True)
+                 :& (SSliderColor =:: "")
+                 :& RNil
+      widgetState = WidgetState $ boundedFloatAttrs <+> sliderAttrs
+
+  stateIO <- newIORef widgetState
+
+  let widget = IPythonWidget uuid stateIO
+      initData = object
+                   [ "model_name" .= str "WidgetModel"
+                   , "widget_class" .= str "IPython.FloatRangeSlider"
+                   ]
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen widget initData $ toJSON widgetState
+
+  -- Return the widget
+  return widget
+
+instance IHaskellDisplay FloatRangeSliderWidget where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget FloatRangeSliderWidget where
+  getCommUUID = uuid
+  comm widget (Object dict1) _ = do
+    let key1 = "sync_data" :: Text
+        key2 = "value" :: Text
+        Just (Object dict2) = HM.lookup key1 dict1
+        Just (Array values) = HM.lookup key2 dict2
+        [x, y] = map (\(Number x) -> Sci.toRealFloat x) $ V.toList values
+    setField' widget SFloatPairValue (x, y)

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module IHaskell.Display.Widgets.Float.FloatText (
+  -- * The FloatText Widget
+  FloatTextWidget,
+  -- * Constructor
+  mkFloatTextWidget) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Control.Exception (throw, ArithException (LossOfPrecision))
+import           Control.Monad (when, join)
+import           Data.Aeson
+import qualified Data.HashMap.Strict as HM
+import           Data.IORef (newIORef)
+import qualified Data.Scientific as Sci
+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
+
+-- | 'FloatTextWidget' represents an FloatText widget from IPython.html.widgets.
+type FloatTextWidget = IPythonWidget FloatTextType
+
+-- | Create a new widget
+mkFloatTextWidget :: IO FloatTextWidget
+mkFloatTextWidget = do
+  -- Default properties, with a random uuid
+  uuid <- U.random
+
+  let widgetState = WidgetState $ defaultFloatWidget "FloatTextView"
+
+  stateIO <- newIORef widgetState
+
+  let widget = IPythonWidget uuid stateIO
+      initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.FloatText"]
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen widget initData $ toJSON widgetState
+
+  -- Return the widget
+  return widget
+
+instance IHaskellDisplay FloatTextWidget where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget FloatTextWidget where
+  getCommUUID = uuid
+  comm widget (Object dict1) _ = do
+    let key1 = "sync_data" :: Text
+        key2 = "value" :: Text
+        Just (Object dict2) = HM.lookup key1 dict1
+        Just (Number value) = HM.lookup key2 dict2
+    newValue <- if abs value < 10 ^ 16
+                  then return (Sci.toRealFloat value)
+                  else throw LossOfPrecision
+    setField' widget SFloatValue newValue

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

@@ -83,6 +83,10 @@ type IntClass = DOMWidgetClass :++ '[IntValue, Disabled, Description]
 type BoundedIntClass = IntClass :++ '[StepInt, MinInt, MaxInt]
 type IntRangeClass = IntClass :++ '[IntPairValue, LowerInt, UpperInt]
 type BoundedIntRangeClass = IntRangeClass :++ '[StepInt, MinInt, MaxInt]
+type FloatClass = DOMWidgetClass :++ '[FloatValue, Disabled, Description]
+type BoundedFloatClass = FloatClass :++ '[StepFloat, MinFloat, MaxFloat]
+type FloatRangeClass = FloatClass :++ '[FloatPairValue, LowerFloat, UpperFloat]
+type BoundedFloatRangeClass = FloatRangeClass :++ '[StepFloat, MinFloat, MaxFloat]
 
 -- Types associated with Fields.
 type family FieldType (f :: Field) :: * where
@@ -142,6 +146,13 @@ type family FieldType (f :: Field) :: * where
   FieldType ReadOut = Bool
   FieldType SliderColor = Text
   FieldType BarStyle = BarStyleValue
+  FieldType FloatValue = Double
+  FieldType StepFloat = Double
+  FieldType MinFloat = Double
+  FieldType MaxFloat = Double
+  FieldType LowerFloat = Double
+  FieldType UpperFloat = Double
+  FieldType FloatPairValue = (Double, Double)
 
 -- Different types of widgets. Every widget in IPython has a corresponding WidgetType
 data WidgetType = ButtonType
@@ -163,6 +174,11 @@ data WidgetType = ButtonType
                 | IntSliderType
                 | IntProgressType
                 | IntRangeSliderType
+                | FloatTextType
+                | BoundedFloatTextType
+                | FloatSliderType
+                | FloatProgressType
+                | FloatRangeSliderType
 
 -- Fields associated with a widget
 type family WidgetFields (w :: WidgetType) :: [Field] where
@@ -185,6 +201,11 @@ type family WidgetFields (w :: WidgetType) :: [Field] where
   WidgetFields IntSliderType = BoundedIntClass :++ '[Orientation, ShowRange, ReadOut, SliderColor]
   WidgetFields IntProgressType = BoundedIntClass :++ '[BarStyle]
   WidgetFields IntRangeSliderType = BoundedIntRangeClass :++ '[Orientation, ShowRange, ReadOut, SliderColor]
+  WidgetFields FloatTextType = FloatClass
+  WidgetFields BoundedFloatTextType = BoundedFloatClass
+  WidgetFields FloatSliderType = BoundedFloatClass :++ '[Orientation, ShowRange, ReadOut, SliderColor]
+  WidgetFields FloatProgressType = BoundedFloatClass :++ '[BarStyle]
+  WidgetFields FloatRangeSliderType = BoundedFloatRangeClass :++ '[Orientation, ShowRange, ReadOut, SliderColor]
 
 -- Wrapper around a field
 newtype Attr (f :: Field) = Attr { _unAttr :: FieldType f }
@@ -249,6 +270,13 @@ instance ToPairs (Attr MaxInt) where toPairs (Attr x) = ["max" .= toJSON x]
 instance ToPairs (Attr IntPairValue) where toPairs (Attr x) = ["value" .= toJSON x]
 instance ToPairs (Attr LowerInt) where toPairs (Attr x) = ["min" .= toJSON x]
 instance ToPairs (Attr UpperInt) where toPairs (Attr x) = ["max" .= toJSON x]
+instance ToPairs (Attr FloatValue) where toPairs (Attr x) = ["value" .= toJSON x]
+instance ToPairs (Attr StepFloat) where toPairs (Attr x) = ["step" .= toJSON x]
+instance ToPairs (Attr MinFloat) where toPairs (Attr x) = ["min" .= toJSON x]
+instance ToPairs (Attr MaxFloat) where toPairs (Attr x) = ["max" .= toJSON x]
+instance ToPairs (Attr FloatPairValue) where toPairs (Attr x) = ["value" .= toJSON x]
+instance ToPairs (Attr LowerFloat) where toPairs (Attr x) = ["min" .= toJSON x]
+instance ToPairs (Attr UpperFloat) where toPairs (Attr x) = ["max" .= toJSON x]
 instance ToPairs (Attr Orientation) where toPairs (Attr x) = ["orientation" .= toJSON x]
 instance ToPairs (Attr ShowRange) where toPairs (Attr x) = ["_range" .= toJSON x]
 instance ToPairs (Attr ReadOut) where toPairs (Attr x) = ["readout" .= toJSON x]
@@ -363,6 +391,38 @@ defaultBoundedIntRangeWidget viewName = defaultIntRangeWidget viewName <+> bound
                             :& (SMaxInt =:: 100)
                             :& RNil
 
+-- | A record representing a widget of the _Float class from IPython
+defaultFloatWidget :: FieldType ViewName -> Rec Attr FloatClass
+defaultFloatWidget viewName = defaultDOMWidget viewName <+> intAttrs
+  where intAttrs = (SFloatValue =:: 0)
+                :& (SDisabled =:: False)
+                :& (SDescription =:: "")
+                :& RNil
+
+-- | A record representing a widget of the _BoundedFloat class from IPython
+defaultBoundedFloatWidget :: FieldType ViewName -> Rec Attr BoundedFloatClass
+defaultBoundedFloatWidget viewName = defaultFloatWidget viewName <+> boundedFloatAttrs
+  where boundedFloatAttrs = (SStepFloat =:: 1)
+                       :& (SMinFloat =:: 0)
+                       :& (SMaxFloat =:: 100)
+                       :& RNil
+
+-- | A record representing a widget of the _BoundedFloat class from IPython
+defaultFloatRangeWidget :: FieldType ViewName -> Rec Attr FloatRangeClass
+defaultFloatRangeWidget viewName = defaultFloatWidget viewName <+> rangeAttrs
+  where rangeAttrs = (SFloatPairValue =:: (25, 75))
+                  :& (SLowerFloat =:: 0)
+                  :& (SUpperFloat =:: 100)
+                  :& RNil
+
+-- | A record representing a widget of the _BoundedFloatRange class from IPython
+defaultBoundedFloatRangeWidget :: FieldType ViewName -> Rec Attr BoundedFloatRangeClass
+defaultBoundedFloatRangeWidget viewName = defaultFloatRangeWidget viewName <+> boundedFloatRangeAttrs
+  where boundedFloatRangeAttrs = (SStepFloat =:: 1)
+                            :& (SMinFloat =:: 0)
+                            :& (SMaxFloat =:: 100)
+                            :& 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.