Minor additions to widget properties

- Add ChangeHandler to widgets that might want it.
- Refactor out trigger<event> functions.

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

@@ -61,4 +61,5 @@ instance IHaskellWidget CheckBox where
         key2 = "value" :: Text
         Just (Object dict2) = HM.lookup key1 dict1
         Just (Bool value) = HM.lookup key2 dict2
-    void $ setField' widget SBoolValue value
+    setField' widget SBoolValue value
+    triggerChange widget

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

@@ -66,4 +66,5 @@ instance IHaskellWidget ToggleButton where
         key2 = "value" :: Text
         Just (Object dict2) = HM.lookup key1 dict1
         Just (Bool value) = HM.lookup key2 dict2
-    void $ setField' widget SBoolValue value
+    setField' widget SBoolValue value
+    triggerChange widget

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

@@ -59,10 +59,6 @@ mkButton = do
   -- Return the button widget
   return button
 
--- | Artificially trigger a button click
-triggerClick :: Button -> IO ()
-triggerClick button = join $ getField button SClickHandler
-
 instance IHaskellDisplay Button where
   display b = do
     widgetSendView b

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

@@ -79,6 +79,7 @@ singletons [d|
              | ReadOut
              | SliderColor
              | BarStyle
+             | ChangeHandler
              deriving (Eq, Ord, Show)
              |]
 

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

@@ -12,7 +12,6 @@ module IHaskell.Display.Widgets.Float.BoundedFloat.BoundedFloatText (
 -- To keep `cabal repl` happy when running from the ihaskell repo
 import           Prelude
 
-import           Control.Exception (throw, ArithException (LossOfPrecision))
 import           Control.Monad (when, join, void)
 import           Data.Aeson
 import qualified Data.HashMap.Strict as HM
@@ -65,7 +64,5 @@ instance IHaskellWidget BoundedFloatText where
         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
-    void $ setField' widget SFloatValue newValue
+    setField' widget SFloatValue (Sci.toRealFloat value)
+    triggerChange widget

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

@@ -12,7 +12,6 @@ module IHaskell.Display.Widgets.Float.BoundedFloat.FloatSlider (
 -- To keep `cabal repl` happy when running from the ihaskell repo
 import           Prelude
 
-import           Control.Exception (throw, ArithException (LossOfPrecision))
 import           Control.Monad (when, join, void)
 import           Data.Aeson
 import qualified Data.HashMap.Strict as HM
@@ -71,7 +70,5 @@ instance IHaskellWidget FloatSlider where
         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
-    void $ setField' widget SFloatValue newValue
+    setField' widget SFloatValue (Sci.toRealFloat value)
+    triggerChange widget

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

@@ -73,4 +73,5 @@ instance IHaskellWidget FloatRangeSlider where
         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
-    void $ setField' widget SFloatPairValue (x, y)
+    setField' widget SFloatPairValue (x, y)
+    triggerChange widget

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

@@ -12,7 +12,6 @@ module IHaskell.Display.Widgets.Float.FloatText (
 -- To keep `cabal repl` happy when running from the ihaskell repo
 import           Prelude
 
-import           Control.Exception (throw, ArithException (LossOfPrecision))
 import           Control.Monad (when, join, void)
 import           Data.Aeson
 import qualified Data.HashMap.Strict as HM
@@ -62,7 +61,5 @@ instance IHaskellWidget FloatText where
         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
-    void $ setField' widget SFloatValue newValue
+    setField' widget SFloatValue (Sci.toRealFloat value)
+    triggerChange widget

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

@@ -12,7 +12,6 @@ module IHaskell.Display.Widgets.Int.BoundedInt.BoundedIntText (
 -- To keep `cabal repl` happy when running from the ihaskell repo
 import           Prelude
 
-import           Control.Exception (throw, ArithException (LossOfPrecision))
 import           Control.Monad (when, join, void)
 import           Data.Aeson
 import qualified Data.HashMap.Strict as HM
@@ -65,7 +64,5 @@ instance IHaskellWidget BoundedIntText where
         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.coefficient value)
-                  else throw LossOfPrecision
-    void $ setField' widget SIntValue newValue
+    setField' widget SIntValue (Sci.coefficient value)
+    triggerChange widget

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

@@ -12,7 +12,6 @@ module IHaskell.Display.Widgets.Int.BoundedInt.IntSlider (
 -- To keep `cabal repl` happy when running from the ihaskell repo
 import           Prelude
 
-import           Control.Exception (throw, ArithException (LossOfPrecision))
 import           Control.Monad (when, join, void)
 import           Data.Aeson
 import qualified Data.HashMap.Strict as HM
@@ -71,7 +70,5 @@ instance IHaskellWidget IntSlider where
         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.coefficient value)
-                  else throw LossOfPrecision
-    void $ setField' widget SIntValue newValue
+    setField' widget SIntValue (Sci.coefficient value)
+    triggerChange widget

ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Int/BoundedIntRange/IntRangeSlider.hs

@@ -12,7 +12,6 @@ module IHaskell.Display.Widgets.Int.BoundedIntRange.IntRangeSlider (
 -- To keep `cabal repl` happy when running from the ihaskell repo
 import           Prelude
 
-import           Control.Exception (throw, ArithException (LossOfPrecision))
 import           Control.Monad (when, join, void)
 import           Data.Aeson
 import qualified Data.HashMap.Strict as HM
@@ -73,4 +72,5 @@ instance IHaskellWidget IntRangeSlider where
         Just (Object dict2) = HM.lookup key1 dict1
         Just (Array values) = HM.lookup key2 dict2
         [x, y] = map (\(Number x) -> Sci.coefficient x) $ V.toList values
-    void $ setField' widget SIntPairValue (x, y)
+    setField' widget SIntPairValue (x, y)
+    triggerChange widget

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

@@ -12,7 +12,6 @@ module IHaskell.Display.Widgets.Int.IntText (
 -- To keep `cabal repl` happy when running from the ihaskell repo
 import           Prelude
 
-import           Control.Exception (throw, ArithException (LossOfPrecision))
 import           Control.Monad (when, join, void)
 import           Data.Aeson
 import qualified Data.HashMap.Strict as HM
@@ -62,7 +61,5 @@ instance IHaskellWidget IntText where
         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.coefficient value)
-                  else throw LossOfPrecision
-    void $ setField' widget SIntValue newValue
+    setField' widget SIntValue (Sci.coefficient value)
+    triggerChange widget

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

@@ -50,10 +50,6 @@ mkDropdown = do
   -- Return the widget
   return widget
 
--- | Artificially trigger a selection
-triggerSelection :: Dropdown -> IO ()
-triggerSelection widget = join $ getField widget SSelectionHandler
-
 instance IHaskellDisplay Dropdown where
   display b = do
     widgetSendView b

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

@@ -48,10 +48,6 @@ mkRadioButtons = do
   -- 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

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

@@ -47,10 +47,6 @@ mkSelect = do
   -- Return the widget
   return widget
 
--- | Artificially trigger a selection
-triggerSelection :: Select -> IO ()
-triggerSelection widget = join $ getField widget SSelectionHandler
-
 instance IHaskellDisplay Select where
   display b = do
     widgetSendView b

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

@@ -51,10 +51,6 @@ mkSelectMultiple = do
   -- Return the widget
   return widget
 
--- | Artificially trigger a selection
-triggerSelection :: SelectMultiple -> IO ()
-triggerSelection widget = join $ getField widget SSelectionHandler
-
 instance IHaskellDisplay SelectMultiple where
   display b = do
     widgetSendView b

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

@@ -55,10 +55,6 @@ mkToggleButtons = do
   -- 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

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

@@ -4,12 +4,11 @@
 {-# LANGUAGE TypeSynonymInstances #-}
 
 module IHaskell.Display.Widgets.String.Text (
--- * The Text Widget
-TextWidget,
+  -- * The Text Widget
+  TextWidget,
   -- * Constructor
   mkTextWidget,
-                          -- * Submit handling
-                          triggerSubmit) where
+  ) where
 
 -- To keep `cabal repl` happy when running from the ihaskell repo
 import           Prelude
@@ -37,7 +36,7 @@ mkTextWidget = do
   -- Default properties, with a random uuid
   uuid <- U.random
   let strWidget = defaultStringWidget "TextView"
-      txtWidget = (SSubmitHandler =:: return ()) :& RNil
+      txtWidget = (SSubmitHandler =:: return ()) :& (SChangeHandler =:: return ()) :& RNil
       widgetState = WidgetState $ strWidget <+> txtWidget
 
   stateIO <- newIORef widgetState
@@ -51,9 +50,6 @@ mkTextWidget = do
   -- Return the widget
   return widget
 
-triggerSubmit :: TextWidget -> IO ()
-triggerSubmit tw = join $ getField tw SSubmitHandler
-
 instance IHaskellDisplay TextWidget where
   display b = do
     widgetSendView b
@@ -66,7 +62,7 @@ instance IHaskellWidget TextWidget where
     case Map.lookup "sync_data" dict1 of
       Just (Object dict2) ->
         case Map.lookup "value" dict2 of
-          Just (String val) -> setField' tw SStringValue val >> return ()
+          Just (String val) -> setField' tw SStringValue val >> triggerChange tw
           Nothing           -> return ()
       Nothing ->
         case Map.lookup "content" dict1 of

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

@@ -14,6 +14,7 @@ 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(..), (<+>))
@@ -23,6 +24,7 @@ import           IHaskell.Eval.Widgets
 import           IHaskell.IPython.Message.UUID as U
 
 import           IHaskell.Display.Widgets.Types
+import           IHaskell.Display.Widgets.Common
 
 -- | A 'TextArea' represents a Textarea widget from IPython.html.widgets.
 type TextArea = IPythonWidget TextAreaType
@@ -32,7 +34,9 @@ mkTextArea :: IO TextArea
 mkTextArea = do
   -- Default properties, with a random uuid
   uuid <- U.random
-  let widgetState = WidgetState $ defaultStringWidget "TextareaView"
+  let strAttrs = defaultStringWidget "TextareaView"
+      wgtAttrs = (SChangeHandler =:: return ()) :& RNil
+      widgetState = WidgetState $ strAttrs <+> wgtAttrs
 
   stateIO <- newIORef widgetState
 
@@ -53,3 +57,10 @@ instance IHaskellDisplay TextArea where
 
 instance IHaskellWidget TextArea where
   getCommUUID = uuid
+  comm widget (Object dict1) _ = do
+    let key1 = "sync_data" :: Text
+        key2 = "value" :: Text
+        Just (Object dict2) = HM.lookup key1 dict1
+        Just (String value) = HM.lookup key2 dict2
+    setField' widget SStringValue value
+    triggerChange widget

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

@@ -48,7 +48,7 @@ module IHaskell.Display.Widgets.Types where
 -- To know more about the IPython messaging specification (as implemented in this package) take a look
 -- at the supplied MsgSpec.md.
 
-import Control.Monad (unless)
+import Control.Monad (unless, join)
 import Control.Applicative ((<$>))
 import qualified Control.Exception as Ex
 
@@ -79,16 +79,16 @@ type DOMWidgetClass = WidgetClass :++
     , FontWeight, FontSize, FontFamily
     ]
 type StringClass = DOMWidgetClass :++ '[StringValue, Disabled, Description, Placeholder]
-type BoolClass = DOMWidgetClass :++ '[BoolValue, Disabled, Description]
+type BoolClass = DOMWidgetClass :++ '[BoolValue, Disabled, Description, ChangeHandler]
 type SelectionClass = DOMWidgetClass :++
    '[Options, SelectedValue, SelectedLabel, Disabled, Description, SelectionHandler]
 type MultipleSelectionClass = DOMWidgetClass :++
    '[Options, SelectedLabels, SelectedValues, Disabled, Description, SelectionHandler]
-type IntClass = DOMWidgetClass :++ '[IntValue, Disabled, Description]
+type IntClass = DOMWidgetClass :++ '[IntValue, Disabled, Description, ChangeHandler]
 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 FloatClass = DOMWidgetClass :++ '[FloatValue, Disabled, Description, ChangeHandler]
 type BoundedFloatClass = FloatClass :++ '[StepFloat, MinFloat, MaxFloat]
 type FloatRangeClass = FloatClass :++ '[FloatPairValue, LowerFloat, UpperFloat]
 type BoundedFloatRangeClass = FloatRangeClass :++ '[StepFloat, MinFloat, MaxFloat]
@@ -158,6 +158,7 @@ type family FieldType (f :: Field) :: * where
   FieldType LowerFloat = Double
   FieldType UpperFloat = Double
   FieldType FloatPairValue = (Double, Double)
+  FieldType ChangeHandler = IO ()
 
 -- Will use a custom class rather than a newtype wrapper with an orphan instance. The main issue is
 -- the need of a Bounded instance for Float / Double.
@@ -211,8 +212,8 @@ type family WidgetFields (w :: WidgetType) :: [Field] where
   WidgetFields OutputType = DOMWidgetClass
   WidgetFields HTMLType = StringClass
   WidgetFields LatexType = StringClass
-  WidgetFields TextType = StringClass :++ '[SubmitHandler]
-  WidgetFields TextAreaType = StringClass
+  WidgetFields TextType = StringClass :++ '[SubmitHandler, ChangeHandler]
+  WidgetFields TextAreaType = StringClass :++ '[ChangeHandler]
   WidgetFields CheckBoxType = BoolClass
   WidgetFields ToggleButtonType = BoolClass :++ '[Tooltip, Icon, ButtonStyle]
   WidgetFields DropdownType = SelectionClass :++ '[ButtonStyle]
@@ -323,6 +324,7 @@ instance ToPairs (Attr ShowRange) where toPairs x = ["_range" .= toJSON x]
 instance ToPairs (Attr ReadOut) where toPairs x = ["readout" .= toJSON x]
 instance ToPairs (Attr SliderColor) where toPairs x = ["slider_color" .= toJSON x]
 instance ToPairs (Attr BarStyle) where toPairs x = ["bar_style" .= toJSON x]
+instance ToPairs (Attr ChangeHandler) where toPairs _ = [] -- Not sent to the frontend
 
 -- | Store the value for a field, as an object parametrized by the Field. No verification is done
 -- for these values.
@@ -401,6 +403,7 @@ defaultBoolWidget viewName = defaultDOMWidget viewName <+> boolAttrs
   where boolAttrs = (SBoolValue =:: False)
                  :& (SDisabled =:: False)
                  :& (SDescription =:: "")
+                 :& (SChangeHandler =:: return ())
                  :& RNil
 
 -- | A record representing a widget of the _Selection class from IPython
@@ -431,6 +434,7 @@ defaultIntWidget viewName = defaultDOMWidget viewName <+> intAttrs
   where intAttrs = (SIntValue =:: 0)
                 :& (SDisabled =:: False)
                 :& (SDescription =:: "")
+                :& (SChangeHandler =:: return ())
                 :& RNil
 
 -- | A record representing a widget of the _BoundedInt class from IPython
@@ -463,6 +467,7 @@ defaultFloatWidget viewName = defaultDOMWidget viewName <+> intAttrs
   where intAttrs = (SFloatValue =:: 0)
                 :& (SDisabled =:: False)
                 :& (SDescription =:: "")
+                :& (SChangeHandler =:: return ())
                 :& RNil
 
 -- | A record representing a widget of the _BoundedFloat class from IPython
@@ -538,3 +543,16 @@ properties widget = do
   let convert :: Attr f -> Const Field f
       convert attr = Const { getConst = _field attr }
   return $ recordToList . rmap convert . _getState $ st
+
+-- Trigger events
+triggerChange :: (ChangeHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
+triggerChange w = join $ getField w SChangeHandler
+
+triggerClick :: (ClickHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
+triggerClick w = join $ getField w SClickHandler
+
+triggerSelection :: (SelectionHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
+triggerSelection w = join $ getField w SSelectionHandler
+
+triggerSubmit :: (SubmitHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()
+triggerSubmit w = join $ getField w SSubmitHandler