Merge pull request #519 from sumitsahrawat/refactor

Refactoring Widgets + Boolean Widgets

build.sh

@@ -48,7 +48,7 @@ if [ $# -gt 0 ]; then
   if [ $1 = "display" ] || [ $1 = "all" ]; then
         # Install all the display libraries
         cd ihaskell-display
-        for dir in `ls`
+        for dir in `ls | grep -v ihaskell-widgets`
         do
             INSTALLS="$INSTALLS ihaskell-display/$dir"
         done
@@ -71,6 +71,10 @@ INSTALL_DIRS=`echo $INSTALLS | tr ' ' '\n' | sed 's#^#./#' | tr ' ' '\n'`
 echo CMD: cabal install --constraint "arithmoi -llvm" -j $INSTALL_DIRS --force-reinstalls --max-backjumps=-1 --reorder-goals
 cabal install --constraint "arithmoi -llvm" -j $INSTALL_DIRS --force-reinstalls --max-backjumps=-1 --reorder-goals
 
+if [ $1 = "display" ] || [ $1 = "all" ]; then
+    cabal install ihaskell-display/ihaskell-widgets
+fi
+
 if hash ihaskell 2>/dev/null; then
     ihaskell install 2>/dev/null || echo "The command \"ihaskell install\" failed. Please check your 'ipython --version'. 3.0 or up is required but it is $(ipython --version)!"
 else

ihaskell-display/ihaskell-widgets/MsgSpec.md

+# IPython widget messaging specification
+
+> Largely based on: https://github.com/ipython/ipython/wiki/IPEP-23:-Backbone.js-Widgets
+
+> The messaging specification as detailed is riddled with the assumptions IHaskell's widget
+> implementation makes. It works for us, so it should work for everyone.
+
+## Creating widgets
+
+Let's say the user types in some code, and the only effect of that code is the creation of a widget.
+The kernel will open a comm for the widget, and store a reference to that comm inside it. Then, to
+notify the frontend about the creation of a widget, an initial state update is sent on the widget's comm.
+
+> The comm should be opened with a `target_name` of `"ipython.widget"`.
+
+The initial state update message looks like this:
+
+```json
+{
+    "method": "update",
+    "state": { "<some/all widget properties>" }
+}
+```
+
+Any *numeric* property initialized with the empty string is provided the default value by the frontend.
+
+The initial state update must *at least* have the following fields:
+
+  - `msg_throttle` (default 3): To prevent the kernel from flooding with messages, the messages from
+    the widget to the kernel are throttled. If `msg_throttle` messages were sent, and all are still
+    processing, the widget will not send anymore state messages.
+
+  - `_view_name` (depends on the widget): The frontend uses a generic model to represent
+    widgets. This field determines how a set of widget properties gets rendered into a
+    widget. Has the form `IPython.<widgetname>`, e.g `IPython.Button`.
+
+  - `_css` (default value = empty list): A list of 3-tuples, (selector, key, value).
+
+  - `visible` (default = True): Whether the widget is visible or not.
+
+  - Rest of the properties as required initially.
+
+This state update is also used with fragments of the overall state to sync changes between the
+frontend and the kernel.
+
+## Displaying widgets
+
+The creation of a widget does not display it. To display a widget, the kernel sends a display
+message to the frontend on the widget's comm.
+
+```json
+{
+    "method": "display"
+}
+```
+
+## Custom messages
+
+* Widgets can also send a custom message, having the form:
+
+```json
+{
+    "method": "custom",
+    "content": { "<message content>" }
+}
+```
+
+This message is used by widgets for ad-hoc syncronization, event handling and other stuff. An example
+is mentioned in the next section.
+
+## Handling changes to widget in the frontend
+
+Changes to widgets in the frontend lead to messages being sent to the backend. These messages have
+two possible formats:
+
+1. Backbone.js initiated sync:
+
+  ```json
+  {
+      "method": "backbone",
+      "sync_data": { "<changes to sync with the backend>" }
+  }
+  ```
+
+  These messages are sent by the Backbone.js library when some change is made to a widget. For
+  example, whenever a change is made to the text inside a `TextWidget`, the complete contents are sent
+  to the kernel so that the kernel stays up-to-date about the widget's contents.
+
+2. Custom message:
+
+  ```json
+  {
+      "method": "custom",
+      "content": { "<custom message data>" }
+  }
+  ```
+
+  This form is generally used to notify the kernel about events. For example, the `TextWidget` sends a
+  custom message when the text is submitted by hitting the 'Enter' key.
+
+---
+
+*NOTE*: It's important that the messages sent on the comm are in response to an execution message
+ from the front-end or another widget's comm message. This is required so the widget framework knows
+ what cell triggered the message and can display the widget in the correct location.
+
+---

ihaskell-display/ihaskell-widgets/README.md

+# IHaskell-Widgets
+
+This package implements the [ipython widgets](https://github.com/ipython/ipywidgets) in
+IHaskell. The frontend (javascript) is provided by the jupyter/ipython notebook environment, whereas
+the backend is implemented in haskell.
+
+To know more about the widget messaging protocol, see [MsgSpec.md](MsgSpec.md).

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

@@ -44,7 +44,7 @@ build-type:          Simple
 
 -- Extra files to be distributed with the package, such as examples or a 
 -- README.
--- extra-source-files:  
+extra-source-files:  README.md, MsgSpec.md
 
 -- Constraint on the version of Cabal needed to build this package.
 cabal-version:       >=1.10
@@ -55,25 +55,37 @@ library
   
   -- Modules included in this library but not exported.
   other-modules:       IHaskell.Display.Widgets.Button
+                       IHaskell.Display.Widgets.Bool.CheckBox
+                       IHaskell.Display.Widgets.Bool.ToggleButton
                        IHaskell.Display.Widgets.Image
-                       IHaskell.Display.Widgets.Dropdown
+                       IHaskell.Display.Widgets.Output
+                       IHaskell.Display.Widgets.Selection.Dropdown
+                       IHaskell.Display.Widgets.Selection.RadioButtons
+                       IHaskell.Display.Widgets.Selection.Select
+                       IHaskell.Display.Widgets.Selection.ToggleButtons
+                       IHaskell.Display.Widgets.Selection.SelectMultiple
                        IHaskell.Display.Widgets.String.HTML
                        IHaskell.Display.Widgets.String.Latex
                        IHaskell.Display.Widgets.String.Text
                        IHaskell.Display.Widgets.String.TextArea
-                       IHaskell.Display.Widgets.Output
 
+                       IHaskell.Display.Widgets.Types
                        IHaskell.Display.Widgets.Common
 
   -- LANGUAGE extensions used by modules in this package.
   -- other-extensions:    
   
   -- Other library packages from which modules are imported.
-  build-depends:       aeson >= 0.8.1.0
+  build-depends:       aeson >=0.7 && < 0.9
                      , base >=4.7 && <4.9
-                     , ipython-kernel >= 0.6.1.0
-                     , text >= 1.2.1.0
-                     , unordered-containers >= 0.2.5.1
+                     , containers >= 0.5
+                     , ipython-kernel >= 0.6.1
+                     , text >= 0.11
+                     , unordered-containers -any
+                     , nats -any
+                     , vinyl >= 0.5
+                     , vector -any
+                     , singletons >= 0.9.0
 
                        -- Waiting for the next release
                      , ihaskell -any
@@ -84,3 +96,10 @@ library
   -- Base language which the package is written in.
   default-language:    Haskell2010
   
+  -- Deal with small -fcontext-stack on ghc-7.8.
+  -- Default values:
+  --   ghc-7.6.*  = 200
+  --   ghc-7.8.*  = 20   -- Too small for vinyl & singletons
+  --   ghc-7.10.* = 100
+  if impl(ghc == 7.8.*)
+    ghc-options:       -fcontext-stack=100

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

@@ -2,15 +2,23 @@ module IHaskell.Display.Widgets (module X) where
 
 import           IHaskell.Display.Widgets.Button as X
 
-import           IHaskell.Display.Widgets.Dropdown as X
+import           IHaskell.Display.Widgets.Bool.CheckBox as X
+import           IHaskell.Display.Widgets.Bool.ToggleButton as X
 
 import           IHaskell.Display.Widgets.Image as X
 
+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.ToggleButtons as X
+import           IHaskell.Display.Widgets.Selection.SelectMultiple as X
+
 import           IHaskell.Display.Widgets.String.HTML as X
 import           IHaskell.Display.Widgets.String.Latex as X
 import           IHaskell.Display.Widgets.String.Text as X
 import           IHaskell.Display.Widgets.String.TextArea as X
 
-import           IHaskell.Display.Widgets.Output as X
-
-import           IHaskell.Display.Widgets.Common as X (ButtonStyle(..), ImageFormat(..))
+import           IHaskell.Display.Widgets.Common as X
+import           IHaskell.Display.Widgets.Types as X (setField, getField)

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module IHaskell.Display.Widgets.Bool.CheckBox (
+-- * The CheckBox Widget
+CheckBoxWidget, 
+                -- * Constructor
+                mkCheckBoxWidget) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Control.Monad (when, join)
+import           Data.Aeson
+import           Data.HashMap.Strict as HM
+import           Data.IORef (newIORef)
+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
+
+-- | A 'CheckBoxWidget' represents a Checkbox widget from IPython.html.widgets.
+type CheckBoxWidget = IPythonWidget CheckBoxType
+
+-- | Create a new output widget
+mkCheckBoxWidget :: IO CheckBoxWidget
+mkCheckBoxWidget = do
+  -- Default properties, with a random uuid
+  uuid <- U.random
+
+  let widgetState = WidgetState $ defaultBoolWidget "CheckboxView"
+
+  stateIO <- newIORef widgetState
+
+  let widget = IPythonWidget uuid stateIO
+      initData = object
+                   ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Checkbox"]
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen widget initData $ toJSON widgetState
+
+  -- Return the image widget
+  return widget
+
+instance IHaskellDisplay CheckBoxWidget where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget CheckBoxWidget where
+  getCommUUID = uuid
+  comm widget (Object dict1) _ = do
+    let key1 = "sync_data" :: Text
+        key2 = "value" :: Text
+        Just (Object dict2) = HM.lookup key1 dict1
+        Just (Bool value) = HM.lookup key2 dict2
+    setField' widget SBoolValue value

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module IHaskell.Display.Widgets.Bool.ToggleButton (
+-- * The ToggleButton Widget
+ToggleButton, 
+              -- * Constructor
+              mkToggleButton) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Control.Monad (when, join)
+import           Data.Aeson
+import           Data.HashMap.Strict as HM
+import           Data.IORef (newIORef)
+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
+
+-- | A 'ToggleButton' represents a ToggleButton widget from IPython.html.widgets.
+type ToggleButton = IPythonWidget ToggleButtonType
+
+-- | Create a new output widget
+mkToggleButton :: IO ToggleButton
+mkToggleButton = do
+  -- Default properties, with a random uuid
+  uuid <- U.random
+
+  let boolState = defaultBoolWidget "ToggleButtonView"
+      toggleState = (STooltip =:: "")
+                    :& (SIcon =:: "")
+                    :& (SButtonStyle =:: DefaultButton)
+                    :& RNil
+      widgetState = WidgetState (boolState <+> toggleState)
+
+  stateIO <- newIORef widgetState
+
+  let widget = IPythonWidget uuid stateIO
+      initData = object
+                   ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.ToggleButton"]
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen widget initData $ toJSON widgetState
+
+  -- Return the image widget
+  return widget
+
+instance IHaskellDisplay ToggleButton where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget ToggleButton where
+  getCommUUID = uuid
+  comm widget (Object dict1) _ = do
+    let key1 = "sync_data" :: Text
+        key2 = "value" :: Text
+        Just (Object dict2) = HM.lookup key1 dict1
+        Just (Bool value) = HM.lookup key2 dict2
+    setField' widget SBoolValue value

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

 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 
 module IHaskell.Display.Widgets.Button (
-    -- * The Button Widget
-    Button,
-    -- * Create a new button
-    mkButton,
-    -- * Set button properties
-    setButtonStyle,
-    setButtonLabel,
-    setButtonTooltip,
-    setButtonStatus,
-    toggleButtonStatus,
-    -- * Get button properties
-    getButtonStyle,
-    getButtonLabel,
-    getButtonTooltip,
-    getButtonStatus,
-    -- * Click handlers
-    setClickHandler,
-    getClickHandler,
-    triggerClick,
-    ) where
+-- * The Button Widget
+Button, 
+        -- * Create a new button
+        mkButton, 
+                  -- * Click manipulation
+                  triggerClick) where
 
 -- To keep `cabal repl` happy when running from the ihaskell repo
 import           Prelude
 
-import           Control.Monad (when)
-import           Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
-import           Data.Aeson.Types (Pair)
-import           Data.HashMap.Strict as Map
-import           Data.IORef
+import           Control.Monad (when, join)
+import           Data.Aeson
+import           Data.HashMap.Strict as HM
+import           Data.IORef (newIORef)
 import           Data.Text (Text)
-import qualified Data.Text as T
-import           System.IO.Unsafe (unsafePerformIO)
+import           Data.Vinyl (Rec(..), (<+>))
 
 import           IHaskell.Display
 import           IHaskell.Eval.Widgets
-import qualified IHaskell.IPython.Message.UUID as U
-import           IHaskell.Types (WidgetMethod(..))
+import           IHaskell.IPython.Message.UUID as U
 
+import           IHaskell.Display.Widgets.Types
 import           IHaskell.Display.Widgets.Common
 
 -- | A 'Button' represents a Button from IPython.html.widgets.
-data Button =
-       Button
-         { uuid :: U.UUID       -- ^ The UUID for the comm
-         , description :: IORef Text -- ^ The label displayed on the button
-         , tooltip :: IORef Text     -- ^ The tooltip shown on mouseover
-         , disabled :: IORef Bool    -- ^ Whether the button is disabled
-         , buttonStyle :: IORef ButtonStyle -- ^ The button_style
-         , clickHandler :: IORef (Button -> IO ()) -- ^ Function executed when button is clicked
-         }
+type Button = IPythonWidget ButtonType
 
 -- | Create a new button
 mkButton :: IO Button
 mkButton = do
   -- Default properties, with a random uuid
-  commUUID <- U.random
-  desc <- newIORef "label"      -- Non-empty to get a display
-  ttip <- newIORef ""
-  dis <- newIORef False
-  sty <- newIORef None
-  fun <- newIORef $ const $ return ()
-
-  let b = Button
-        { uuid = commUUID
-        , description = desc
-        , tooltip = ttip
-        , disabled = dis
-        , buttonStyle = sty
-        , clickHandler = fun
-        }
+  uuid <- U.random
+
+  let dom = defaultDOMWidget "ButtonView"
+      but = (SDescription =:: "")
+            :& (STooltip =:: "")
+            :& (SDisabled =:: False)
+            :& (SIcon =:: "")
+            :& (SButtonStyle =:: DefaultButton)
+            :& (SClickHandler =:: return ())
+            :& RNil
+      buttonState = WidgetState (dom <+> but)
+
+  stateIO <- newIORef buttonState
+
+  let button = IPythonWidget uuid stateIO
+
+  let initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Button"]
 
   -- Open a comm for this widget, and store it in the kernel state
-  widgetSendOpen b (toJSON ButtonInitData) (toJSON b)
+  widgetSendOpen button initData $ toJSON buttonState
 
   -- Return the button widget
-  return b
-
--- | Set the button style
-setButtonStyle :: Button -> ButtonStyle -> IO ()
-setButtonStyle b bst = do
-  modify b buttonStyle bst
-  update b ["button_style" .= bst]
-
--- | Set the button label
-setButtonLabel :: Button -> Text -> IO ()
-setButtonLabel b txt = do
-  modify b description txt
-  update b ["description" .= txt]
-
--- | Set the button tooltip
-setButtonTooltip :: Button -> Text -> IO ()
-setButtonTooltip b txt = do
-  modify b tooltip txt
-  update b ["tooltip" .= txt]
-
--- | Set buttton status. True: Enabled, False: Disabled
-setButtonStatus :: Button -> Bool -> IO ()
-setButtonStatus b stat = do
-  let newStatus = not stat
-  modify b disabled newStatus
-  update b ["disabled" .= newStatus]
-
--- | Toggle the button
-toggleButtonStatus :: Button -> IO ()
-toggleButtonStatus b = do
-  oldVal <- getButtonStatus b
-  let newVal = not oldVal
-  modify b disabled newVal
-  update b ["disabled" .= newVal]
-
--- | Get the button style
-getButtonStyle :: Button -> IO ButtonStyle
-getButtonStyle = readIORef . buttonStyle
-
--- | Get the button label
-getButtonLabel :: Button -> IO Text
-getButtonLabel = readIORef . description
-
--- | Get the button tooltip
-getButtonTooltip :: Button -> IO Text
-getButtonTooltip = readIORef . tooltip
-
--- | Check whether the button is enabled / disabled
-getButtonStatus :: Button -> IO Bool
-getButtonStatus = fmap not . readIORef . disabled
-
--- | Set a function to be activated on click
-setClickHandler :: Button -> (Button -> IO ()) -> IO ()
-setClickHandler = writeIORef . clickHandler
-
--- | Get the click handler for a button
-getClickHandler :: Button -> IO (Button -> IO ())
-getClickHandler = readIORef . clickHandler
+  return button
 
 -- | Artificially trigger a button click
 triggerClick :: Button -> IO ()
-triggerClick button = do
-  handler <- getClickHandler button
-  handler button
-
-data ViewName = ButtonWidget
-
-instance ToJSON ViewName where
-  toJSON ButtonWidget = "ButtonView"
-
-data InitData = ButtonInitData
-
-instance ToJSON InitData where
-  toJSON ButtonInitData = object
-                            [ "model_name" .= str "WidgetModel"
-                            , "widget_class" .= str "IPython.Button"
-                            ]
-
-instance ToJSON Button where
-  toJSON b = object
-               [ "_view_name" .= toJSON ButtonWidget
-               , "visible" .= True
-               , "_css" .= object []
-               , "msg_throttle" .= (3 :: Int)
-               , "disabled" .= get disabled b
-               , "description" .= get description b
-               , "tooltip" .= get tooltip b
-               , "button_style" .= get buttonStyle b
-               ]
-    where
-      get x y = unsafePerformIO . readIORef . x $ y
+triggerClick button = join $ getField button SClickHandler
 
 instance IHaskellDisplay Button where
   display b = do
@@ -179,6 +73,6 @@ instance IHaskellWidget Button where
   comm widget (Object dict1) _ = do
     let key1 = "content" :: Text
         key2 = "event" :: Text
-        Just (Object dict2) = Map.lookup key1 dict1
-        Just (String event) = Map.lookup key2 dict2
+        Just (Object dict2) = HM.lookup key1 dict1
+        Just (String event) = HM.lookup key2 dict2
     when (event == "click") $ triggerClick widget

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

 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+module IHaskell.Display.Widgets.Common where
 
-module IHaskell.Display.Widgets.Common (
-    -- * Convenience types
-    ButtonStyle(..),
-    ImageFormat(..),
-    PosInt(..),
-    -- * Convenience functions (for internal use)
-    update,
-    modify,
-    str,
-    ) where
-
-import           Data.Aeson hiding (Success)
-import           Data.Aeson.Types (Pair)
-import qualified Data.Text as T
-import           Data.IORef
-
-import           IHaskell.Display
-import           IHaskell.Eval.Widgets
-
--- | Pre-defined button-styles
-data ButtonStyle = Primary
-                 | Success
-                 | Info
-                 | Warning
-                 | Danger
-                 | None
-  deriving (Eq, Show)
-
-instance ToJSON ButtonStyle where
-  toJSON Primary = "primary"
-  toJSON Success = "success"
-  toJSON Info = "info"
-  toJSON Warning = "warning"
-  toJSON Danger = "danger"
-  toJSON None = ""
-
--- | A wrapper around Int. 'toJSON' gives the no. for positive numbers, and empty string otherwise
-newtype PosInt = PosInt { unwrap :: Int }
-
-instance ToJSON PosInt where
-  toJSON (PosInt n)
-    | n > 0 = toJSON $ str $ show n
-    | otherwise = toJSON $ str $ ""
+import Data.Aeson
+import Data.Text (pack, Text)
+
+import Data.Singletons.TH
+
+-- Widget properties
+singletons [d|
+  data Field = ModelModule
+             | ModelName
+             | ViewModule
+             | ViewName
+             | MsgThrottle
+             | Version
+             | OnDisplayed
+             | Visible
+             | CSS
+             | DOMClasses
+             | Width
+             | Height
+             | Padding
+             | Margin
+             | Color
+             | BackgroundColor
+             | BorderColor
+             | BorderWidth
+             | BorderRadius
+             | BorderStyle
+             | FontStyle
+             | FontWeight
+             | FontSize
+             | FontFamily
+             | Description
+             | ClickHandler
+             | SubmitHandler
+             | Disabled
+             | StringValue
+             | Placeholder
+             | Tooltip
+             | Icon
+             | ButtonStyle
+             | B64Value
+             | ImageFormat
+             | BoolValue
+             | Options
+             | SelectedLabel
+             | SelectedValue
+             | SelectionHandler
+             | Tooltips
+             | Icons
+             | SelectedLabels
+             | SelectedValues
+             deriving (Eq, Ord, Show)
+             |]
+
+-- | Pre-defined border styles
+data BorderStyleValue = NoBorder
+                      | HiddenBorder
+                      | DottedBorder
+                      | DashedBorder
+                      | SolidBorder
+                      | DoubleBorder
+                      | GrooveBorder
+                      | RidgeBorder
+                      | InsetBorder
+                      | OutsetBorder
+                      | InitialBorder
+                      | InheritBorder
+                      | DefaultBorder
+
+instance ToJSON BorderStyleValue where
+  toJSON NoBorder = "none"
+  toJSON HiddenBorder = "hidden"
+  toJSON DottedBorder = "dotted"
+  toJSON DashedBorder = "dashed"
+  toJSON SolidBorder = "solid"
+  toJSON DoubleBorder = "double"
+  toJSON GrooveBorder = "groove"
+  toJSON RidgeBorder = "ridge"
+  toJSON InsetBorder = "inset"
+  toJSON OutsetBorder = "outset"
+  toJSON InitialBorder = "initial"
+  toJSON InheritBorder = "inherit"
+  toJSON DefaultBorder = ""
+
+-- | Font style values
+data FontStyleValue = NormalFont
+                    | ItalicFont
+                    | ObliqueFont
+                    | InitialFont
+                    | InheritFont
+                    | DefaultFont
+
+instance ToJSON FontStyleValue where
+  toJSON NormalFont = "normal"
+  toJSON ItalicFont = "italic"
+  toJSON ObliqueFont = "oblique"
+  toJSON InitialFont = "initial"
+  toJSON InheritFont = "inherit"
+  toJSON DefaultFont = ""
+
+-- | Font weight values
+data FontWeightValue = NormalWeight
+                     | BoldWeight
+                     | BolderWeight
+                     | LighterWeight
+                     | InheritWeight
+                     | InitialWeight
+                     | DefaultWeight
+
+instance ToJSON FontWeightValue where
+  toJSON NormalWeight = "normal"
+  toJSON BoldWeight = "bold"
+  toJSON BolderWeight = "bolder"
+  toJSON LighterWeight = "lighter"
+  toJSON InheritWeight = "inherit"
+  toJSON InitialWeight = "initial"
+  toJSON DefaultWeight = ""
+
+-- | Pre-defined button styles
+data ButtonStyleValue = PrimaryButton
+                      | SuccessButton
+                      | InfoButton
+                      | WarningButton
+                      | DangerButton
+                      | DefaultButton
+
+instance ToJSON ButtonStyleValue where
+  toJSON PrimaryButton = "primary"
+  toJSON SuccessButton = "success"
+  toJSON InfoButton = "info"
+  toJSON WarningButton = "warning"
+  toJSON DangerButton = "danger"
+  toJSON DefaultButton = ""
 
 -- | Image formats for ImageWidget
-data ImageFormat = PNG
-                 | SVG
-                 | JPG
+data ImageFormatValue = PNG
+                      | SVG
+                      | JPG
   deriving Eq
 
-instance Show ImageFormat where
+instance Show ImageFormatValue where
   show PNG = "png"
   show SVG = "svg"
   show JPG = "jpg"
 
-instance ToJSON ImageFormat where
-  toJSON = toJSON . T.pack . show
+instance ToJSON ImageFormatValue where
+  toJSON = toJSON . pack . show
+
+-- | Options for selection widgets.
+data SelectionOptions = OptionLabels [Text] | OptionDict [(Text, Text)]
 
--- | Send an update msg for a widget, with custom json. Make it easy to update fragments of the
--- state, by accepting a Pair instead of a Value.
-update :: IHaskellWidget a => a -> [Pair] -> IO ()
-update widget = widgetSendUpdate widget . toJSON . object
 
--- | Modify attributes of a widget, stored inside it as IORefs
-modify :: IHaskellWidget a => a -> (a -> IORef b) -> b -> IO ()
-modify widget attr newval = writeIORef (attr widget) newval
 
--- | Useful with toJSON
-str :: String -> String
-str = id

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

-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module IHaskell.Display.Widgets.Dropdown (
-    -- * The dropdown widget
-    DropdownWidget,
-    -- * Constructor
-    mkDropdownWidget,
-    -- * Set properties
-    setDropdownText,
-    setDropdownStatus,
-    setDropdownOptions,
-    setDropdownSelected,
-    -- * Get properties
-    getDropdownText,
-    getDropdownStatus,
-    getDropdownOptions,
-    getDropdownSelected,
-    -- * Handle changes
-    setSelectionHandler,
-    getSelectionHandler,
-    triggerSelection,
-    ) where
-
--- To keep `cabal repl` happy when running from the ihaskell repo
-import           Prelude
-
-import           Control.Monad (when)
-import           Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
-import           Data.Aeson.Types (Pair)
-import           Data.HashMap.Strict as Map
-import           Data.IORef
-import           Data.Text (Text)
-import           System.IO.Unsafe (unsafePerformIO)
-
-import           IHaskell.Display
-import           IHaskell.Eval.Widgets
-import qualified IHaskell.IPython.Message.UUID as U
-
-import           IHaskell.Display.Widgets.Common
-
--- | A 'Dropdown' represents a Dropdown widget from IPython.html.widgets.
-data DropdownWidget =
-       DropdownWidget
-         { uuid :: U.UUID       -- ^ The UUID for the comm
-         , description :: IORef Text -- ^ The label displayed beside the dropdown
-         , disabled :: IORef Bool    -- ^ Whether the dropdown is disabled
-         , selectedLabel :: IORef Text -- ^ The label which is currently selected
-         , labelOptions :: IORef [Text] -- ^ The possible label options
-         , selectionHandler :: IORef (DropdownWidget -> IO ())
-         }
-
--- | Create a new dropdown
-mkDropdownWidget :: IO DropdownWidget
-mkDropdownWidget = do
-  -- Default properties, with a random uuid
-  commUUID <- U.random
-  desc <- newIORef ""
-  dis <- newIORef False
-  sel <- newIORef ""
-  opts <- newIORef []
-  handler <- newIORef $ const $ return ()
-
-  let b = DropdownWidget
-        { uuid = commUUID
-        , description = desc
-        , disabled = dis
-        , selectedLabel = sel
-        , labelOptions = opts
-        , selectionHandler = handler
-        }
-
-  let initData = object
-                   ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Dropdown"]
-
-  -- Open a comm for this widget, and store it in the kernel state
-  widgetSendOpen b initData $ toJSON b
-
-  -- Return the dropdown widget
-  return b
-
-setDropdownText :: DropdownWidget -> Text -> IO ()
-setDropdownText widget text = do
-  modify widget description text
-  update widget ["description" .= text]
-
-setDropdownStatus :: DropdownWidget -> Bool -> IO ()
-setDropdownStatus widget stat = do
-  let newStat = not stat
-  modify widget disabled newStat
-  update widget ["disabled" .= newStat]
-
-setDropdownOptions :: DropdownWidget -> [Text] -> IO ()
-setDropdownOptions widget opts = do
-  modify widget labelOptions opts
-  update widget ["_options_labels" .= opts]
-
-setDropdownSelected :: DropdownWidget -> Text -> IO ()
-setDropdownSelected widget opt = do
-  possibleOpts <- getDropdownOptions widget
-  when (opt `elem` possibleOpts) $ do
-    modify widget selectedLabel opt
-    update widget ["selected_label" .= opt]
-  triggerSelection widget
-
-toggleDropdownStatus :: DropdownWidget -> IO ()
-toggleDropdownStatus widget = modifyIORef (disabled widget) not
-
-getDropdownText :: DropdownWidget -> IO Text
-getDropdownText = readIORef . description
-
-getDropdownStatus :: DropdownWidget -> IO Bool
-getDropdownStatus = fmap not . readIORef . disabled
-
-getDropdownOptions :: DropdownWidget -> IO [Text]
-getDropdownOptions = readIORef . labelOptions
-
-getDropdownSelected :: DropdownWidget -> IO Text
-getDropdownSelected = readIORef . selectedLabel
-
--- | Set a function to be activated on selection
-setSelectionHandler :: DropdownWidget -> (DropdownWidget -> IO ()) -> IO ()
-setSelectionHandler = writeIORef . selectionHandler
-
--- | Get the selection handler for a dropdown
-getSelectionHandler :: DropdownWidget -> IO (DropdownWidget -> IO ())
-getSelectionHandler = readIORef . selectionHandler
-
--- | Artificially trigger a selection
-triggerSelection :: DropdownWidget -> IO ()
-triggerSelection widget = do
-  handler <- getSelectionHandler widget
-  handler widget
-
-instance ToJSON DropdownWidget where
-  toJSON b = object
-               [ "_view_name" .= str "DropdownView"
-               , "visible" .= True
-               , "_css" .= object []
-               , "msg_throttle" .= (3 :: Int)
-               , "disabled" .= get disabled b
-               , "description" .= get description b
-               , "_options_labels" .= get labelOptions b
-               , "selected_label" .= get selectedLabel b
-               , "button_style" .= str ""
-               ]
-    where
-      get x y = unsafePerformIO . readIORef . x $ y
-
-instance IHaskellDisplay DropdownWidget where
-  display b = do
-    widgetSendView b
-    return $ Display []
-
-instance IHaskellWidget DropdownWidget where
-  getCommUUID = uuid
-  comm widget (Object dict1) _ = do
-    let key1 = "sync_data" :: Text
-        key2 = "selected_label" :: Text
-        Just (Object dict2) = Map.lookup key1 dict1
-        Just (String label) = Map.lookup key2 dict2
-    modify widget selectedLabel label
-    triggerSelection widget

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

 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 
 module IHaskell.Display.Widgets.Image (
-    -- * The Image Widget
-    ImageWidget,
-    -- * Create a new image widget
-    mkImageWidget,
-    -- * Set image properties
-    setImageFormat,
-    setImageB64Value,
-    setImageWidth,
-    setImageHeight,
-    -- * Get image properties
-    getImageFormat,
-    getImageB64Value,
-    getImageWidth,
-    getImageHeight,
-    ) where
+-- * The Image Widget
+ImageWidget, 
+             -- * Constructor
+             mkImageWidget) where
 
 -- To keep `cabal repl` happy when running from the ihaskell repo
 import           Prelude
 
-import           Control.Monad (when)
-import           Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
-import           Data.Aeson.Types (Pair)
-import           Data.HashMap.Strict as Map
-import           Data.IORef
+import           Control.Monad (when, join)
+import           Data.Aeson
+import           Data.HashMap.Strict as HM
+import           Data.IORef (newIORef)
+import           Data.Monoid (mempty)
 import           Data.Text (Text)
-import qualified Data.Text as T
-import           System.IO.Unsafe (unsafePerformIO)
+import           Data.Vinyl (Rec(..), (<+>))
 
 import           IHaskell.Display
 import           IHaskell.Eval.Widgets
-import qualified IHaskell.IPython.Message.UUID as U
-import           IHaskell.Types (WidgetMethod(..))
+import           IHaskell.IPython.Message.UUID as U
 
+import           IHaskell.Display.Widgets.Types
 import           IHaskell.Display.Widgets.Common
 
--- | A 'Image' represents a Image from IPython.html.widgets.
-data ImageWidget =
-       ImageWidget
-         { uuid :: U.UUID
-         , format :: IORef ImageFormat
-         , height :: IORef PosInt
-         , width :: IORef PosInt
-         , b64value :: IORef Base64
-         }
+-- | An 'ImageWidget' represents a Image widget from IPython.html.widgets.
+type ImageWidget = IPythonWidget ImageType
 
 -- | Create a new image widget
 mkImageWidget :: IO ImageWidget
 mkImageWidget = do
   -- Default properties, with a random uuid
-  commUUID <- U.random
-  fmt <- newIORef PNG
-  hgt <- newIORef (PosInt 0)
-  wdt <- newIORef (PosInt 0)
-  val <- newIORef ""
+  uuid <- U.random
 
-  let initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Image"]
-      b = ImageWidget { uuid = commUUID, format = fmt, height = hgt, width = wdt, b64value = val }
-
-  -- Open a comm for this widget, and store it in the kernel state
-  widgetSendOpen b initData (toJSON b)
-
-  -- Return the image widget
-  return b
-
--- | Set the image style
-setImageFormat :: ImageWidget -> ImageFormat -> IO ()
-setImageFormat b fmt = do
-  modify b format fmt
-  update b ["format" .= fmt]
+  let dom = defaultDOMWidget "ImageView"
+      img = (SImageFormat =:: PNG)
+            :& (SB64Value =:: mempty)
+            :& RNil
+      widgetState = WidgetState (dom <+> img)
 
--- | Set the image value (encoded in base64)
-setImageB64Value :: ImageWidget -> Base64 -> IO ()
-setImageB64Value b val = do
-  modify b b64value val
-  update b ["_b64value" .= val]
+  stateIO <- newIORef widgetState
 
--- | Set the image width
-setImageWidth :: ImageWidget -> Int -> IO ()
-setImageWidth b wdt = do
-  let w = PosInt wdt
-  modify b width w
-  update b ["width" .= w]
+  let widget = IPythonWidget uuid stateIO
 
--- | Set the image height
-setImageHeight :: ImageWidget -> Int -> IO ()
-setImageHeight b hgt = do
-  let h = PosInt hgt
-  modify b height h
-  update b ["height" .= h]
-
--- | Get the image format
-getImageFormat :: ImageWidget -> IO ImageFormat
-getImageFormat = readIORef . format
-
--- | Get the image value (encoded in base64)
-getImageB64Value :: ImageWidget -> IO Base64
-getImageB64Value = readIORef . b64value
-
--- | Get the image width
-getImageWidth :: ImageWidget -> IO Int
-getImageWidth = fmap unwrap . readIORef . width
+  let initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Image"]
 
--- | Get the image height
-getImageHeight :: ImageWidget -> IO Int
-getImageHeight = fmap unwrap . readIORef . height
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen widget initData $ toJSON widgetState
 
-instance ToJSON ImageWidget where
-  toJSON b = object
-               [ "_view_module" .= str ""
-               , "background_color" .= str ""
-               , "border_width" .= str ""
-               , "border_color" .= str ""
-               , "width" .= get width b
-               , "_dom_classes" .= object []
-               , "margin" .= str ""
-               , "font_style" .= str ""
-               , "font_weight" .= str ""
-               , "height" .= get height b
-               , "font_size" .= str ""
-               , "border_style" .= str ""
-               , "padding" .= str ""
-               , "border_radius" .= str ""
-               , "version" .= (0 :: Int)
-               , "font_family" .= str ""
-               , "color" .= str ""
-               , "_view_name" .= str "ImageView"
-               , "visible" .= True
-               , "_css" .= object []
-               , "msg_throttle" .= (3 :: Int)
-               , "format" .= get format b
-               , "_b64value" .= get b64value b
-               ]
-    where
-      get x y = unsafePerformIO . readIORef . x $ y
+  -- Return the image widget
+  return widget
 
 instance IHaskellDisplay ImageWidget where
   display b = do

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

 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 
 module IHaskell.Display.Widgets.Output (
-    -- * The Output  Widget
+    -- * The Output Widget
     OutputWidget,
     -- * Constructor
     mkOutputWidget,
-    -- * Get/Set/Modify width
-    getOutputWidth,
-    setOutputWidth,
-    modifyOutputWidth,
-    modifyOutputWidth_,
-    -- * Output to widget
+    -- * Using the output widget
     appendOutput,
     clearOutput,
     clearOutput_,
@@ -21,62 +18,40 @@ module IHaskell.Display.Widgets.Output (
 -- To keep `cabal repl` happy when running from the ihaskell repo
 import           Prelude
 
-import           Control.Monad (when, void)
-import           Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
-import           Data.Aeson.Types (Pair, Array)
-import qualified Data.HashMap.Strict as Map
-import           Data.IORef
+import           Control.Monad (when, join)
+import           Data.Aeson
+import           Data.HashMap.Strict as HM
+import           Data.IORef (newIORef)
 import           Data.Text (Text)
-import qualified Data.Text as T
-import           System.IO.Unsafe (unsafePerformIO)
+import           Data.Vinyl (Rec(..), (<+>))
 
 import           IHaskell.Display
 import           IHaskell.Eval.Widgets
-import qualified IHaskell.IPython.Message.UUID as U
-import           IHaskell.Types (WidgetMethod(..))
+import           IHaskell.IPython.Message.UUID as U
 
-import           IHaskell.Display.Widgets.Common
+import           IHaskell.Display.Widgets.Types
 
-data OutputWidget = OutputWidget { uuid :: U.UUID, width :: IORef PosInt }
+-- | An 'OutputWidget' represents a Output widget from IPython.html.widgets.
+type OutputWidget = IPythonWidget OutputType
 
+-- | Create a new output widget
 mkOutputWidget :: IO OutputWidget
 mkOutputWidget = do
   -- Default properties, with a random uuid
-  commUUID <- U.random
-  wdt <- newIORef $ PosInt 400
-  dis <- newIORef False
+  uuid <- U.random
 
-  let b = OutputWidget { uuid = commUUID, width = wdt }
+  let widgetState = WidgetState $ defaultDOMWidget "OutputView"
 
-  let initData = object ["model_name" .= str "WidgetModel"]
+  stateIO <- newIORef widgetState
 
-  -- Open a comm for this widget, and store it in the kernel state
-  widgetSendOpen b initData (toJSON b)
-
-  -- Return the widget
-  return b
-
--- | Get the output widget width
-getOutputWidth :: OutputWidget -> IO Int
-getOutputWidth = fmap unwrap . readIORef . width
+  let widget = IPythonWidget uuid stateIO
+      initData = object ["model_name" .= str "WidgetModel"]
 
--- | Set the output widget width
-setOutputWidth :: OutputWidget -> Int -> IO ()
-setOutputWidth widget widthInt = do
-  let w = PosInt widthInt
-  modify widget width w
-  update widget ["width" .= w]
-
--- | Modify the output widget width (with IO)
-modifyOutputWidth :: OutputWidget -> (Int -> IO Int) -> IO ()
-modifyOutputWidth widget modifier = getOutputWidth widget >>= modifier >>= setOutputWidth widget
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen widget initData $ toJSON widgetState
 
--- | Modify the output widget width (with pure modifier)
-modifyOutputWidth_ :: OutputWidget -> (Int -> Int) -> IO ()
-modifyOutputWidth_ widget modifier = do
-  w <- getOutputWidth widget
-  let newWidth = modifier w
-  setOutputWidth widget newWidth
+  -- Return the image widget
+  return widget
 
 -- | Append to the output widget
 appendOutput :: IHaskellDisplay a => OutputWidget -> a -> IO ()
@@ -98,33 +73,6 @@ replaceOutput widget d = do
   clearOutput_ widget
   appendOutput widget d
 
-instance ToJSON OutputWidget where
-  toJSON b = object
-               [ "_view_module" .= str ""
-               , "background_color" .= str ""
-               , "border_width" .= str ""
-               , "border_color" .= str ""
-               , "width" .= get width b
-               , "_dom_classes" .= object []
-               , "margin" .= str ""
-               , "font_style" .= str ""
-               , "font_weight" .= str ""
-               , "height" .= str ""
-               , "font_size" .= str ""
-               , "border_style" .= str ""
-               , "padding" .= str ""
-               , "border_radius" .= str ""
-               , "version" .= (0 :: Int)
-               , "font_family" .= str ""
-               , "color" .= str ""
-               , "_view_name" .= str "OutputView"
-               , "visible" .= True
-               , "_css" .= object []
-               , "msg_throttle" .= (3 :: Int)
-               ]
-    where
-      get x = unsafePerformIO . readIORef . x
-
 instance IHaskellDisplay OutputWidget where
   display b = do
     widgetSendView b

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module IHaskell.Display.Widgets.Selection.Dropdown (
+-- * The Dropdown Widget
+Dropdown, 
+          -- * Constructor
+          mkDropdown) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+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(..), (<+>))
+
+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 'Dropdown' represents a Dropdown widget from IPython.html.widgets.
+type Dropdown = IPythonWidget DropdownType
+
+-- | Create a new Dropdown widget
+mkDropdown :: IO Dropdown
+mkDropdown = do
+  -- Default properties, with a random uuid
+  uuid <- U.random
+  let selectionAttrs = defaultSelectionWidget "DropdownView"
+      dropdownAttrs = (SButtonStyle =:: DefaultButton) :& RNil
+      widgetState = WidgetState $ selectionAttrs <+> dropdownAttrs
+
+  stateIO <- newIORef widgetState
+
+  let widget = IPythonWidget uuid stateIO
+      initData = object
+                   ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Dropdown"]
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen widget initData $ toJSON widgetState
+
+  -- 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
+    return $ Display []
+
+instance IHaskellWidget Dropdown where
+  getCommUUID = uuid
+  comm widget (Object dict1) _ = do
+    let key1 = "sync_data" :: Text
+        key2 = "selected_label" :: Text
+        Just (Object dict2) = HM.lookup key1 dict1
+        Just (String label) = HM.lookup key2 dict2
+    opts <- getField widget SOptions
+    case opts of
+      OptionLabels _ -> do
+        setField' widget SSelectedLabel label
+        setField' widget SSelectedValue label
+      OptionDict ps ->
+        case lookup label ps of
+          Nothing -> return ()
+          Just value -> do
+            setField' widget SSelectedLabel label
+            setField' widget SSelectedValue value
+    triggerSelection widget

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module IHaskell.Display.Widgets.Selection.RadioButtons (
+-- * The RadioButtons Widget
+RadioButtons, 
+              -- * Constructor
+              mkRadioButtons) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+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(..), (<+>))
+
+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 'RadioButtons' represents a RadioButtons widget from IPython.html.widgets.
+type RadioButtons = IPythonWidget RadioButtonsType
+
+-- | Create a new RadioButtons widget
+mkRadioButtons :: IO RadioButtons
+mkRadioButtons = do
+  -- Default properties, with a random uuid
+  uuid <- U.random
+  let widgetState = WidgetState $ defaultSelectionWidget "RadioButtonsView"
+
+  stateIO <- newIORef widgetState
+
+  let widget = IPythonWidget uuid stateIO
+      initData = object
+                   ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.RadioButtons"]
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen widget initData $ toJSON widgetState
+
+  -- 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
+    return $ Display []
+
+instance IHaskellWidget RadioButtons where
+  getCommUUID = uuid
+  comm widget (Object dict1) _ = do
+    let key1 = "sync_data" :: Text
+        key2 = "selected_label" :: Text
+        Just (Object dict2) = HM.lookup key1 dict1
+        Just (String label) = HM.lookup key2 dict2
+    opts <- getField widget SOptions
+    case opts of
+      OptionLabels _ -> do
+        setField' widget SSelectedLabel label
+        setField' widget SSelectedValue label
+      OptionDict ps ->
+        case lookup label ps of
+          Nothing -> return ()
+          Just value -> do
+            setField' widget SSelectedLabel label
+            setField' widget SSelectedValue value
+    triggerSelection widget

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module IHaskell.Display.Widgets.Selection.Select (
+-- * The Select Widget
+SelectWidget, 
+              -- * Constructor
+              mkSelectWidget) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+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(..), (<+>))
+
+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 'SelectWidget' represents a Select widget from IPython.html.widgets.
+type SelectWidget = IPythonWidget SelectType
+
+-- | Create a new Select widget
+mkSelectWidget :: IO SelectWidget
+mkSelectWidget = do
+  -- Default properties, with a random uuid
+  uuid <- U.random
+  let widgetState = WidgetState $ defaultSelectionWidget "SelectView"
+
+  stateIO <- newIORef widgetState
+
+  let widget = IPythonWidget uuid stateIO
+      initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Select"]
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen widget initData $ toJSON widgetState
+
+  -- Return the widget
+  return widget
+
+-- | Artificially trigger a selection
+triggerSelection :: SelectWidget -> IO ()
+triggerSelection widget = join $ getField widget SSelectionHandler
+
+instance IHaskellDisplay SelectWidget where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget SelectWidget where
+  getCommUUID = uuid
+  comm widget (Object dict1) _ = do
+    let key1 = "sync_data" :: Text
+        key2 = "selected_label" :: Text
+        Just (Object dict2) = HM.lookup key1 dict1
+        Just (String label) = HM.lookup key2 dict2
+    opts <- getField widget SOptions
+    case opts of
+      OptionLabels _ -> do
+        setField' widget SSelectedLabel label
+        setField' widget SSelectedValue label
+      OptionDict ps ->
+        case lookup label ps of
+          Nothing -> return ()
+          Just value -> do
+            setField' widget SSelectedLabel label
+            setField' widget SSelectedValue value
+    triggerSelection widget

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module IHaskell.Display.Widgets.Selection.SelectMultiple (
+-- * The SelectMultiple Widget
+SelectMultipleWidget, 
+                      -- * Constructor
+                      mkSelectMultipleWidget) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Control.Monad (fmap, join, sequence)
+import           Data.Aeson
+import qualified Data.HashMap.Strict as HM
+import           Data.IORef (newIORef)
+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
+
+-- | A 'SelectMultipleWidget' represents a SelectMultiple widget from IPython.html.widgets.
+type SelectMultipleWidget = IPythonWidget SelectMultipleType
+
+-- | Create a new SelectMultiple widget
+mkSelectMultipleWidget :: IO SelectMultipleWidget
+mkSelectMultipleWidget = do
+  -- Default properties, with a random uuid
+  uuid <- U.random
+  let widgetState = WidgetState $ defaultMultipleSelectionWidget "SelectMultipleView"
+
+  stateIO <- newIORef widgetState
+
+  let widget = IPythonWidget uuid stateIO
+      initData = object
+                   [ "model_name" .= str "WidgetModel"
+                   , "widget_class" .= str "IPython.SelectMultiple"
+                   ]
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen widget initData $ toJSON widgetState
+
+  -- Return the widget
+  return widget
+
+-- | Artificially trigger a selection
+triggerSelection :: SelectMultipleWidget -> IO ()
+triggerSelection widget = join $ getField widget SSelectionHandler
+
+instance IHaskellDisplay SelectMultipleWidget where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget SelectMultipleWidget where
+  getCommUUID = uuid
+  comm widget (Object dict1) _ = do
+    let key1 = "sync_data" :: Text
+        key2 = "selected_labels" :: Text
+        Just (Object dict2) = HM.lookup key1 dict1
+        Just (Array labels) = HM.lookup key2 dict2
+        labelList = map (\(String x) -> x) $ V.toList labels
+    opts <- getField widget SOptions
+    case opts of
+      OptionLabels _ -> do
+        setField' widget SSelectedLabels labelList
+        setField' widget SSelectedValues labelList
+      OptionDict ps ->
+        case sequence $ map (`lookup` ps) labelList of
+          Nothing -> return ()
+          Just valueList -> do
+            setField' widget SSelectedLabels labelList
+            setField' widget SSelectedValues valueList
+    triggerSelection widget

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module IHaskell.Display.Widgets.Selection.ToggleButtons (
+-- * The ToggleButtons Widget
+ToggleButtons, 
+               -- * Constructor
+               mkToggleButtons) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+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(..), (<+>))
+
+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 'ToggleButtons' represents a ToggleButtons widget from IPython.html.widgets.
+type ToggleButtons = IPythonWidget ToggleButtonsType
+
+-- | Create a new ToggleButtons widget
+mkToggleButtons :: IO ToggleButtons
+mkToggleButtons = do
+  -- Default properties, with a random uuid
+  uuid <- U.random
+  let selectionAttrs = defaultSelectionWidget "ToggleButtonsView"
+      toggleButtonsAttrs = (STooltips =:: [])
+                           :& (SIcons =:: [])
+                           :& (SButtonStyle =:: DefaultButton)
+                           :& RNil
+      widgetState = WidgetState $ selectionAttrs <+> toggleButtonsAttrs
+
+  stateIO <- newIORef widgetState
+
+  let widget = IPythonWidget uuid stateIO
+      initData = object
+                   [ "model_name" .= str "WidgetModel"
+                   , "widget_class" .= str "IPython.ToggleButtons"
+                   ]
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen widget initData $ toJSON widgetState
+
+  -- 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
+    return $ Display []
+
+instance IHaskellWidget ToggleButtons where
+  getCommUUID = uuid
+  comm widget (Object dict1) _ = do
+    let key1 = "sync_data" :: Text
+        key2 = "selected_label" :: Text
+        Just (Object dict2) = HM.lookup key1 dict1
+        Just (String label) = HM.lookup key2 dict2
+    opts <- getField widget SOptions
+    case opts of
+      OptionLabels _ -> do
+        setField' widget SSelectedLabel label
+        setField' widget SSelectedValue label
+      OptionDict ps ->
+        case lookup label ps of
+          Nothing -> return ()
+          Just value -> do
+            setField' widget SSelectedLabel label
+            setField' widget SSelectedValue value
+    triggerSelection widget

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

+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 
 module IHaskell.Display.Widgets.String.HTML (
-    -- * The HTML Widget
-    HTMLWidget,
-    -- * Constructor
-    mkHTMLWidget,
-    -- * Set properties
-    setHTMLValue,
-    setHTMLDescription,
-    setHTMLPlaceholder,
-    -- * Get properties
-    getHTMLValue,
-    getHTMLDescription,
-    getHTMLPlaceholder,
-    ) where
+-- * The HTML Widget
+HTMLWidget, 
+            -- * Constructor
+            mkHTMLWidget) where
 
 -- To keep `cabal repl` happy when running from the ihaskell repo
 import           Prelude
 
-import           Control.Monad (when)
-import           Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
-import           Data.Aeson.Types (Pair)
-import           Data.HashMap.Strict as Map
-import           Data.IORef
+import           Control.Monad (when, join)
+import           Data.Aeson
+import           Data.IORef (newIORef)
 import           Data.Text (Text)
-import qualified Data.Text as T
-import           System.IO.Unsafe (unsafePerformIO)
+import           Data.Vinyl (Rec(..), (<+>))
 
 import           IHaskell.Display
 import           IHaskell.Eval.Widgets
-import qualified IHaskell.IPython.Message.UUID as U
+import           IHaskell.IPython.Message.UUID as U
 
-import           IHaskell.Display.Widgets.Common
+import           IHaskell.Display.Widgets.Types
 
-data HTMLWidget =
-       HTMLWidget
-         { uuid :: U.UUID
-         , value :: IORef Text
-         , description :: IORef Text
-         , placeholder :: IORef Text
-         }
+-- | A 'HTMLWidget' represents a HTML widget from IPython.html.widgets.
+type HTMLWidget = IPythonWidget HTMLType
 
 -- | Create a new HTML widget
 mkHTMLWidget :: IO HTMLWidget
 mkHTMLWidget = do
   -- Default properties, with a random uuid
-  commUUID <- U.random
-  val <- newIORef ""
-  des <- newIORef ""
-  plc <- newIORef ""
+  uuid <- U.random
+  let widgetState = WidgetState $ defaultStringWidget "HTMLView"
 
-  let b = HTMLWidget { uuid = commUUID, value = val, description = des, placeholder = plc }
+  stateIO <- newIORef widgetState
 
-  let initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.HTML"]
+  let widget = IPythonWidget uuid stateIO
+      initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.HTML"]
 
   -- Open a comm for this widget, and store it in the kernel state
-  widgetSendOpen b initData (toJSON b)
+  widgetSendOpen widget initData $ toJSON widgetState
 
-  -- Return the string widget
-  return b
-
--- | Set the HTML string value.
-setHTMLValue :: HTMLWidget -> Text -> IO ()
-setHTMLValue b txt = do
-  modify b value txt
-  update b ["value" .= txt]
-
--- | Set the HTML description
-setHTMLDescription :: HTMLWidget -> Text -> IO ()
-setHTMLDescription b txt = do
-  modify b description txt
-  update b ["description" .= txt]
-
--- | Set the HTML placeholder, i.e. text displayed in empty widget
-setHTMLPlaceholder :: HTMLWidget -> Text -> IO ()
-setHTMLPlaceholder b txt = do
-  modify b placeholder txt
-  update b ["placeholder" .= txt]
-
--- | Get the HTML string value.
-getHTMLValue :: HTMLWidget -> IO Text
-getHTMLValue = readIORef . value
-
--- | Get the HTML description value.
-getHTMLDescription :: HTMLWidget -> IO Text
-getHTMLDescription = readIORef . description
-
--- | Get the HTML placeholder value.
-getHTMLPlaceholder :: HTMLWidget -> IO Text
-getHTMLPlaceholder = readIORef . placeholder
-
-instance ToJSON HTMLWidget where
-  toJSON b = object
-               [ "_view_name" .= str "HTMLView"
-               , "visible" .= True
-               , "_css" .= object []
-               , "msg_throttle" .= (3 :: Int)
-               , "value" .= get value b
-               ]
-    where
-      get x y = unsafePerformIO . readIORef . x $ y
+  -- Return the widget
+  return widget
 
 instance IHaskellDisplay HTMLWidget where
   display b = do

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

+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 
 module IHaskell.Display.Widgets.String.Latex (
-    -- * The Latex Widget
-    LatexWidget,
-    -- * Constructor
-    mkLatexWidget,
-    -- * Set properties
-    setLatexValue,
-    setLatexPlaceholder,
-    setLatexDescription,
-    setLatexWidth,
-    -- * Get properties
-    getLatexValue,
-    getLatexPlaceholder,
-    getLatexDescription,
-    getLatexWidth,
-    ) where
+-- * The Latex Widget
+LatexWidget, 
+             -- * Constructor
+             mkLatexWidget) where
 
 -- To keep `cabal repl` happy when running from the ihaskell repo
 import           Prelude
 
-import           Control.Monad (when)
-import           Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
-import           Data.Aeson.Types (Pair)
-import           Data.HashMap.Strict as Map
-import           Data.IORef
+import           Control.Monad (when, join)
+import           Data.Aeson
+import           Data.IORef (newIORef)
 import           Data.Text (Text)
-import qualified Data.Text as T
-import           System.IO.Unsafe (unsafePerformIO)
+import           Data.Vinyl (Rec(..), (<+>))
 
 import           IHaskell.Display
 import           IHaskell.Eval.Widgets
-import qualified IHaskell.IPython.Message.UUID as U
+import           IHaskell.IPython.Message.UUID as U
 
-import           IHaskell.Display.Widgets.Common
+import           IHaskell.Display.Widgets.Types
 
-data LatexWidget =
-       LatexWidget
-         { uuid :: U.UUID
-         , value :: IORef Text
-         , description :: IORef Text
-         , placeholder :: IORef Text
-         , width :: IORef Int
-         }
+-- | A 'LatexWidget' represents a Latex widget from IPython.html.widgets.
+type LatexWidget = IPythonWidget LatexType
 
 -- | Create a new Latex widget
 mkLatexWidget :: IO LatexWidget
 mkLatexWidget = do
   -- Default properties, with a random uuid
-  commUUID <- U.random
-  val <- newIORef ""
-  des <- newIORef ""
-  plc <- newIORef ""
-  width <- newIORef 400
+  uuid <- U.random
+  let widgetState = WidgetState $ defaultStringWidget "LatexView"
 
-  let b = LatexWidget
-        { uuid = commUUID
-        , value = val
-        , description = des
-        , placeholder = plc
-        , width = width
-        }
+  stateIO <- newIORef widgetState
 
-  let initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Latex"]
+  let widget = IPythonWidget uuid stateIO
+      initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Latex"]
 
   -- Open a comm for this widget, and store it in the kernel state
-  widgetSendOpen b initData (toJSON b)
+  widgetSendOpen widget initData $ toJSON widgetState
 
-  -- Return the string widget
-  return b
-
--- | Set the Latex string value.
-setLatexValue :: LatexWidget -> Text -> IO ()
-setLatexValue b txt = do
-  modify b value txt
-  update b ["value" .= txt]
-
--- | Set the Latex description
-setLatexDescription :: LatexWidget -> Text -> IO ()
-setLatexDescription b txt = do
-  modify b description txt
-  update b ["description" .= txt]
-
--- | Set the Latex placeholder, i.e. text displayed in empty widget
-setLatexPlaceholder :: LatexWidget -> Text -> IO ()
-setLatexPlaceholder b txt = do
-  modify b placeholder txt
-  update b ["placeholder" .= txt]
-
--- | Set the Latex widget width.
-setLatexWidth :: LatexWidget -> Int -> IO ()
-setLatexWidth b wid = do
-  modify b width wid
-  update b ["width" .= wid]
-
--- | Get the Latex string value.
-getLatexValue :: LatexWidget -> IO Text
-getLatexValue = readIORef . value
-
--- | Get the Latex description value.
-getLatexDescription :: LatexWidget -> IO Text
-getLatexDescription = readIORef . description
-
--- | Get the Latex placeholder value.
-getLatexPlaceholder :: LatexWidget -> IO Text
-getLatexPlaceholder = readIORef . placeholder
-
--- | Get the Latex widget width.
-getLatexWidth :: LatexWidget -> IO Int
-getLatexWidth = readIORef . width
-
-instance ToJSON LatexWidget where
-  toJSON b = object
-               [ "_view_name" .= str "LatexView"
-               , "visible" .= True
-               , "_css" .= object []
-               , "msg_throttle" .= (3 :: Int)
-               , "value" .= get value b
-               ]
-    where
-      get x y = unsafePerformIO . readIORef . x $ y
+  -- Return the widget
+  return widget
 
 instance IHaskellDisplay LatexWidget where
   display b = do

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

+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 
 module IHaskell.Display.Widgets.String.Text (
-    -- * The Text Widget
-    TextWidget,
-    -- * Constructor
-    mkTextWidget,
-    -- * Set properties
-    setTextValue,
-    setTextDescription,
-    setTextPlaceholder,
-    -- * Get properties
-    getTextValue,
-    getTextDescription,
-    getTextPlaceholder,
-    -- * Submit handling
-    setSubmitHandler,
-    getSubmitHandler,
-    triggerSubmit,
-    ) where
+-- * The Text Widget
+TextWidget, 
+            -- * Constructor
+            mkTextWidget, 
+                          -- * Submit handling
+                          triggerSubmit) where
 
 -- To keep `cabal repl` happy when running from the ihaskell repo
 import           Prelude
 
-import           Control.Monad (when, void)
-import           Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
-import           Data.Aeson.Types (Pair)
-import           Data.HashMap.Strict as Map
-import           Data.IORef
+import           Control.Monad (when, join)
+import           Data.Aeson
+import qualified Data.HashMap.Strict as Map
+import           Data.IORef (newIORef)
 import           Data.Text (Text)
-import qualified Data.Text as T
-import           System.IO.Unsafe (unsafePerformIO)
+import           Data.Vinyl (Rec(..), (<+>))
 
 import           IHaskell.Display
 import           IHaskell.Eval.Widgets
-import qualified IHaskell.IPython.Message.UUID as U
+import           IHaskell.IPython.Message.UUID as U
 
+import           IHaskell.Display.Widgets.Types
 import           IHaskell.Display.Widgets.Common
 
-data TextWidget =
-       TextWidget
-         { uuid :: U.UUID
-         , value :: IORef Text
-         , description :: IORef Text
-         , placeholder :: IORef Text
-         , submitHandler :: IORef (TextWidget -> IO ())
-         }
+-- | A 'TextWidget' represents a Text widget from IPython.html.widgets.
+type TextWidget = IPythonWidget TextType
 
 -- | Create a new Text widget
 mkTextWidget :: IO TextWidget
 mkTextWidget = do
   -- Default properties, with a random uuid
-  commUUID <- U.random
-  val <- newIORef ""
-  des <- newIORef ""
-  plc <- newIORef ""
-  sh <- newIORef $ const $ return ()
+  uuid <- U.random
+  let strWidget = defaultStringWidget "TextView"
+      txtWidget = (SSubmitHandler =:: return ()) :& RNil
+      widgetState = WidgetState $ strWidget <+> txtWidget
 
-  let b = TextWidget
-        { uuid = commUUID
-        , value = val
-        , description = des
-        , placeholder = plc
-        , submitHandler = sh
-        }
+  stateIO <- newIORef widgetState
 
-  let initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Text"]
+  let widget = IPythonWidget uuid stateIO
+      initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Text"]
 
   -- Open a comm for this widget, and store it in the kernel state
-  widgetSendOpen b initData (toJSON b)
+  widgetSendOpen widget initData $ toJSON widgetState
 
-  -- Return the string widget
-  return b
+  -- Return the widget
+  return widget
 
--- | Set the Text string value.
-setTextValue :: TextWidget -> Text -> IO ()
-setTextValue b txt = do
-  modify b value txt
-  update b ["value" .= txt]
-
--- | Set the text widget "description"
-setTextDescription :: TextWidget -> Text -> IO ()
-setTextDescription b txt = do
-  modify b description txt
-  update b ["description" .= txt]
-
--- | Set the text widget "placeholder", i.e. text displayed in empty text widget
-setTextPlaceholder :: TextWidget -> Text -> IO ()
-setTextPlaceholder b txt = do
-  modify b placeholder txt
-  update b ["placeholder" .= txt]
-
--- | Get the Text string value.
-getTextValue :: TextWidget -> IO Text
-getTextValue = readIORef . value
-
--- | Get the Text widget "description" value.
-getTextDescription :: TextWidget -> IO Text
-getTextDescription = readIORef . description
-
--- | Get the Text widget placeholder value.
-getTextPlaceholder :: TextWidget -> IO Text
-getTextPlaceholder = readIORef . placeholder
-
--- | Set a function to be activated on click
-setSubmitHandler :: TextWidget -> (TextWidget -> IO ()) -> IO ()
-setSubmitHandler = writeIORef . submitHandler
-
--- | Get the submit handler for a TextWidget
-getSubmitHandler :: TextWidget -> IO (TextWidget -> IO ())
-getSubmitHandler = readIORef . submitHandler
-
--- | Artificially trigger a TextWidget submit
 triggerSubmit :: TextWidget -> IO ()
-triggerSubmit tw = do
-  handler <- getSubmitHandler tw
-  handler tw
-
-instance ToJSON TextWidget where
-  toJSON b = object
-               [ "_view_name" .= str "TextView"
-               , "visible" .= True
-               , "_css" .= object []
-               , "msg_throttle" .= (3 :: Int)
-               , "value" .= get value b
-               , "description" .= get description b
-               , "placeholder" .= get placeholder b
-               ]
-    where
-      get x y = unsafePerformIO . readIORef . x $ y
+triggerSubmit tw = join $ getField tw SSubmitHandler
 
 instance IHaskellDisplay TextWidget where
   display b = do
@@ -141,7 +66,7 @@ instance IHaskellWidget TextWidget where
     case Map.lookup "sync_data" dict1 of
       Just (Object dict2) ->
         case Map.lookup "value" dict2 of
-          Just (String val) -> setTextValue tw val
+          Just (String val) -> setField' tw SStringValue val
           Nothing           -> return ()
       Nothing ->
         case Map.lookup "content" dict1 of

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

+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 
 module IHaskell.Display.Widgets.String.TextArea (
-    -- * The TextArea Widget
-    TextAreaWidget,
-    -- * Constructor
-    mkTextAreaWidget,
-    -- * Set properties
-    setTextAreaValue,
-    setTextAreaDescription,
-    setTextAreaPlaceholder,
-    -- * Get properties
-    getTextAreaValue,
-    getTextAreaDescription,
-    getTextAreaPlaceholder,
-    ) where
+-- * The TextArea Widget
+TextAreaWidget, 
+                -- * Constructor
+                mkTextAreaWidget) where
 
 -- To keep `cabal repl` happy when running from the ihaskell repo
 import           Prelude
 
-import           Control.Monad (when)
-import           Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
-import           Data.Aeson.Types (Pair)
-import           Data.HashMap.Strict as Map
-import           Data.IORef
+import           Control.Monad (when, join)
+import           Data.Aeson
+import           Data.IORef (newIORef)
 import           Data.Text (Text)
-import qualified Data.Text as T
-import           System.IO.Unsafe (unsafePerformIO)
+import           Data.Vinyl (Rec(..), (<+>))
 
 import           IHaskell.Display
 import           IHaskell.Eval.Widgets
-import qualified IHaskell.IPython.Message.UUID as U
+import           IHaskell.IPython.Message.UUID as U
 
-import           IHaskell.Display.Widgets.Common
+import           IHaskell.Display.Widgets.Types
 
-data TextAreaWidget =
-       TextAreaWidget
-         { uuid :: U.UUID
-         , value :: IORef Text
-         , description :: IORef Text
-         , placeholder :: IORef Text
-         }
+-- | A 'TextAreaWidget' represents a Textarea widget from IPython.html.widgets.
+type TextAreaWidget = IPythonWidget TextAreaType
 
 -- | Create a new TextArea widget
 mkTextAreaWidget :: IO TextAreaWidget
 mkTextAreaWidget = do
   -- Default properties, with a random uuid
-  commUUID <- U.random
-  val <- newIORef ""
-  des <- newIORef ""
-  plc <- newIORef ""
+  uuid <- U.random
+  let widgetState = WidgetState $ defaultStringWidget "TextareaView"
 
-  let b = TextAreaWidget { uuid = commUUID, value = val, description = des, placeholder = plc }
+  stateIO <- newIORef widgetState
 
-  let initData = object
+  let widget = IPythonWidget uuid stateIO
+      initData = object
                    ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Textarea"]
 
   -- Open a comm for this widget, and store it in the kernel state
-  widgetSendOpen b initData (toJSON b)
+  widgetSendOpen widget initData $ toJSON widgetState
 
-  -- Return the string widget
-  return b
-
--- | Set the TextArea string value.
-setTextAreaValue :: TextAreaWidget -> Text -> IO ()
-setTextAreaValue b txt = do
-  modify b value txt
-  update b ["value" .= txt]
-
--- | Set the TextArea widget "description"
-setTextAreaDescription :: TextAreaWidget -> Text -> IO ()
-setTextAreaDescription b txt = do
-  modify b description txt
-  update b ["description" .= txt]
-
--- | Set the TextArea widget "placeholder", i.e. text displayed in empty widget
-setTextAreaPlaceholder :: TextAreaWidget -> Text -> IO ()
-setTextAreaPlaceholder b txt = do
-  modify b placeholder txt
-  update b ["placeholder" .= txt]
-
--- | Get the TextArea string value.
-getTextAreaValue :: TextAreaWidget -> IO Text
-getTextAreaValue = readIORef . value
-
--- | Get the TextArea widget "description" value.
-getTextAreaDescription :: TextAreaWidget -> IO Text
-getTextAreaDescription = readIORef . description
-
--- | Get the TextArea widget placeholder value.
-getTextAreaPlaceholder :: TextAreaWidget -> IO Text
-getTextAreaPlaceholder = readIORef . placeholder
-
-instance ToJSON TextAreaWidget where
-  toJSON b = object
-               [ "_view_name" .= str "TextareaView"
-               , "visible" .= True
-               , "_css" .= object []
-               , "msg_throttle" .= (3 :: Int)
-               , "value" .= get value b
-               , "description" .= get description b
-               , "placeholder" .= get placeholder b
-               ]
-    where
-      get x y = unsafePerformIO . readIORef . x $ y
+  -- Return the widget
+  return widget
 
 instance IHaskellDisplay TextAreaWidget where
   display b = do

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

+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ConstraintKinds #-}
+module IHaskell.Display.Widgets.Types where
+
+-- | This module houses all the type-trickery needed to make widgets happen.
+--
+-- All widgets have a corresponding 'WidgetType', and some fields/attributes/properties as defined by
+-- the 'WidgetFields' type-family.
+--
+-- Each widget field corresponds to a concrete haskell type, as given by the 'FieldType' type-family.
+--
+-- Vinyl records are used to wrap together widget fields into a single 'WidgetState'.
+--
+-- Singletons are used as a way to represent the promoted types of kind Field. For example:
+--
+-- @
+-- SViewName :: SField ViewName
+-- @
+--
+-- This allows the user to pass the type 'ViewName' without using Data.Proxy. In essence, a singleton
+-- is the only inhabitant (other than bottom) of a promoted type. Single element set/type == singleton.
+--
+-- It also allows the record to wrap values of properties with information about their Field type. A
+-- vinyl record is represented as @Rec f ts@, which means that a record is a list of @f x@, where @x@
+-- is a type present in the type-level list @ts@. Thus a 'WidgetState' is essentially a list of field
+-- properties wrapped together with the corresponding promoted Field type. See ('=::') for more.
+--
+-- The IPython widgets expect state updates of the form {"property": value}, where an empty string for
+-- numeric values is ignored by the frontend and the default value is used instead.
+--
+-- To know more about the IPython messaging specification (as implemented in this package) take a look
+-- at the supplied MsgSpec.md.
+
+import Control.Monad (when)
+import Control.Applicative ((<$>))
+
+import Data.Aeson
+import Data.Aeson.Types (emptyObject, Pair)
+import Data.Text (pack, Text)
+import Data.IORef (IORef, readIORef, modifyIORef)
+
+import Data.Vinyl (Rec (..), (<+>), recordToList, reifyConstraint, rmap, Dict (..))
+import Data.Vinyl.Functor (Compose (..), Const (..))
+import Data.Vinyl.Lens (rget, rput, type (∈))
+import Data.Vinyl.TypeLevel (RecAll (..))
+
+import Data.Singletons.Prelude ((:++))
+import Data.Singletons.TH
+
+import Numeric.Natural
+
+import IHaskell.Eval.Widgets (widgetSendUpdate)
+import IHaskell.Display (Base64, IHaskellWidget (..))
+import IHaskell.IPython.Message.UUID
+
+import IHaskell.Display.Widgets.Common
+
+-- Classes from IPython's widget hierarchy. Defined as such to reduce code duplication.
+type WidgetClass = '[ModelModule, ModelName, ViewModule, ViewName, MsgThrottle, Version, OnDisplayed]
+type DOMWidgetClass = WidgetClass :++
+   '[ Visible, CSS, DOMClasses, Width, Height, Padding, Margin, Color
+    , BackgroundColor, BorderColor, BorderWidth, BorderRadius, BorderStyle, FontStyle
+    , FontWeight, FontSize, FontFamily
+    ]
+type StringClass = DOMWidgetClass :++ '[StringValue, Disabled, Description, Placeholder]
+type BoolClass = DOMWidgetClass :++ '[BoolValue, Disabled, Description]
+type SelectionClass = DOMWidgetClass :++
+   '[Options, SelectedValue, SelectedLabel, Disabled, Description, SelectionHandler]
+type MultipleSelectionClass = DOMWidgetClass :++
+   '[Options, SelectedLabels, SelectedValues, Disabled, Description, SelectionHandler]
+
+-- Types associated with Fields.
+type family FieldType (f :: Field) :: * where
+  FieldType ModelModule = Text
+  FieldType ModelName = Text
+  FieldType ViewModule = Text
+  FieldType ViewName = Text
+  FieldType MsgThrottle = Natural
+  FieldType Version = Natural
+  FieldType OnDisplayed = IO ()
+  FieldType Visible = Bool
+  FieldType CSS = [(Text, Text, Text)]
+  FieldType DOMClasses = [Text]
+  FieldType Width = Natural
+  FieldType Height = Natural
+  FieldType Padding = Natural
+  FieldType Margin = Natural
+  FieldType Color = Text
+  FieldType BackgroundColor = Text
+  FieldType BorderColor = Text
+  FieldType BorderWidth = Natural
+  FieldType BorderRadius = Natural
+  FieldType BorderStyle = BorderStyleValue
+  FieldType FontStyle = FontStyleValue
+  FieldType FontWeight = FontWeightValue
+  FieldType FontSize = Natural
+  FieldType FontFamily = Text
+  FieldType Description = Text
+  FieldType ClickHandler = IO ()
+  FieldType SubmitHandler = IO ()
+  FieldType Disabled = Bool
+  FieldType StringValue = Text
+  FieldType Placeholder = Text
+  FieldType Tooltip = Text
+  FieldType Icon = Text
+  FieldType ButtonStyle = ButtonStyleValue
+  FieldType B64Value = Base64
+  FieldType ImageFormat = ImageFormatValue
+  FieldType BoolValue = Bool
+  FieldType Options = SelectionOptions
+  FieldType SelectedLabel = Text
+  FieldType SelectedValue = Text
+  FieldType SelectionHandler = IO ()
+  FieldType Tooltips = [Text]
+  FieldType Icons = [Text]
+  FieldType SelectedLabels = [Text]
+  FieldType SelectedValues = [Text]
+
+-- Different types of widgets. Every widget in IPython has a corresponding WidgetType
+data WidgetType = ButtonType
+                | ImageType
+                | OutputType
+                | HTMLType
+                | LatexType
+                | TextType
+                | TextAreaType
+                | CheckBoxType
+                | ToggleButtonType
+                | DropdownType
+                | RadioButtonsType
+                | SelectType
+                | ToggleButtonsType
+                | SelectMultipleType
+
+-- Fields associated with a widget
+type family WidgetFields (w :: WidgetType) :: [Field] where
+  WidgetFields ButtonType = DOMWidgetClass :++ '[Description, Tooltip, Disabled, Icon, ButtonStyle, ClickHandler]
+  WidgetFields ImageType = DOMWidgetClass :++ '[ImageFormat, B64Value]
+  WidgetFields OutputType = DOMWidgetClass
+  WidgetFields HTMLType = StringClass
+  WidgetFields LatexType = StringClass
+  WidgetFields TextType = StringClass :++ '[SubmitHandler]
+  WidgetFields TextAreaType = StringClass
+  WidgetFields CheckBoxType = BoolClass
+  WidgetFields ToggleButtonType = BoolClass :++ '[Tooltip, Icon, ButtonStyle]
+  WidgetFields DropdownType = SelectionClass :++ '[ButtonStyle]
+  WidgetFields RadioButtonsType = SelectionClass
+  WidgetFields SelectType = SelectionClass
+  WidgetFields ToggleButtonsType = SelectionClass :++ '[Tooltips, Icons, ButtonStyle]
+  WidgetFields SelectMultipleType = MultipleSelectionClass
+
+-- Wrapper around a field
+newtype Attr (f :: Field) = Attr { _unAttr :: FieldType f }
+
+-- Types that can be converted to Aeson Pairs.
+class ToPairs a where
+  toPairs :: a -> [Pair]
+
+-- Attributes that aren't synced with the frontend give [] on toPairs
+instance ToPairs (Attr ModelModule) where toPairs (Attr x) = ["_model_module" .= toJSON x]
+instance ToPairs (Attr ModelName) where toPairs (Attr x) = ["_model_name" .= toJSON x]
+instance ToPairs (Attr ViewModule) where toPairs (Attr x) = ["_view_module" .= toJSON x]
+instance ToPairs (Attr ViewName) where toPairs (Attr x) = ["_view_name" .= toJSON x]
+instance ToPairs (Attr MsgThrottle) where toPairs (Attr x) = ["msg_throttle" .= toJSON x]
+instance ToPairs (Attr Version) where toPairs (Attr x) = ["version" .= toJSON x]
+instance ToPairs (Attr OnDisplayed) where toPairs _ = [] -- Not sent to the frontend
+instance ToPairs (Attr Visible) where toPairs (Attr x) = ["visible" .= toJSON x]
+instance ToPairs (Attr CSS) where toPairs (Attr x) = ["_css" .= toJSON x]
+instance ToPairs (Attr DOMClasses) where toPairs (Attr x) = ["_dom_classes" .= toJSON x]
+instance ToPairs (Attr Width) where toPairs (Attr x) = ["width" .= toJSON x]
+instance ToPairs (Attr Height) where toPairs (Attr x) = ["height" .= toJSON x]
+instance ToPairs (Attr Padding) where toPairs (Attr x) = ["padding" .= toJSON x]
+instance ToPairs (Attr Margin) where toPairs (Attr x) = ["margin" .= toJSON x]
+instance ToPairs (Attr Color) where toPairs (Attr x) = ["color" .= toJSON x]
+instance ToPairs (Attr BackgroundColor) where toPairs (Attr x) = ["background_color" .= toJSON x]
+instance ToPairs (Attr BorderColor) where toPairs (Attr x) = ["border_color" .= toJSON x]
+instance ToPairs (Attr BorderWidth) where toPairs (Attr x) = ["border_width" .= toJSON x]
+instance ToPairs (Attr BorderRadius) where toPairs (Attr x) = ["border_radius" .= toJSON x]
+instance ToPairs (Attr BorderStyle) where toPairs (Attr x) = ["border_style" .= toJSON x]
+instance ToPairs (Attr FontStyle) where toPairs (Attr x) = ["font_style" .= toJSON x]
+instance ToPairs (Attr FontWeight) where toPairs (Attr x) = ["font_weight" .= toJSON x]
+instance ToPairs (Attr FontSize) where toPairs (Attr x) = ["font_size" .= toJSON x]
+instance ToPairs (Attr FontFamily) where toPairs (Attr x) = ["font_family" .= toJSON x]
+instance ToPairs (Attr Description) where toPairs (Attr x) = ["description" .= toJSON x]
+instance ToPairs (Attr ClickHandler) where toPairs _ = [] -- Not sent to the frontend
+instance ToPairs (Attr SubmitHandler) where toPairs _ = [] -- Not sent to the frontend
+instance ToPairs (Attr Disabled) where toPairs (Attr x) = ["disabled" .= toJSON x]
+instance ToPairs (Attr StringValue) where toPairs (Attr x) = ["value" .= toJSON x]
+instance ToPairs (Attr Placeholder) where toPairs (Attr x) = ["placeholder" .= toJSON x]
+instance ToPairs (Attr Tooltip) where toPairs (Attr x) = ["tooltip" .= toJSON x]
+instance ToPairs (Attr Icon) where toPairs (Attr x) = ["icon" .= toJSON x]
+instance ToPairs (Attr ButtonStyle) where toPairs (Attr x) = ["button_style" .= toJSON x]
+instance ToPairs (Attr B64Value) where toPairs (Attr x) = ["_b64value" .= toJSON x]
+instance ToPairs (Attr ImageFormat) where toPairs (Attr x) = ["format" .= toJSON x]
+instance ToPairs (Attr BoolValue) where toPairs (Attr x) = ["value" .= toJSON x]
+instance ToPairs (Attr SelectedLabel) where toPairs (Attr x) = ["selected_label" .= toJSON x]
+instance ToPairs (Attr SelectedValue) where toPairs (Attr x) = ["value" .= toJSON x]
+instance ToPairs (Attr Options) where
+  toPairs (Attr x) = case x of
+    OptionLabels xs -> labels xs
+    OptionDict xps -> labels $ map fst xps
+    where labels xs = ["_options_labels" .= xs]
+instance ToPairs (Attr SelectionHandler) where toPairs _ = [] -- Not sent to the frontend
+instance ToPairs (Attr Tooltips) where toPairs (Attr x) = ["tooltips" .= toJSON x]
+instance ToPairs (Attr Icons) where toPairs (Attr x) = ["icons" .= toJSON x]
+instance ToPairs (Attr SelectedLabels) where toPairs (Attr x) = ["selected_labels" .= toJSON x]
+instance ToPairs (Attr SelectedValues) where toPairs (Attr x) = ["values" .= toJSON x]
+
+-- | Store the value for a field, as an object parametrized by the Field
+(=::) :: sing f -> FieldType f -> Attr f
+_ =:: x = Attr x
+
+-- | A record representing an object of the Widget class from IPython
+defaultWidget :: FieldType ViewName -> Rec Attr WidgetClass
+defaultWidget viewName = (SModelModule =:: "")
+                      :& (SModelName =:: "WidgetModel")
+                      :& (SViewModule =:: "")
+                      :& (SViewName =:: viewName)
+                      :& (SMsgThrottle =:: 3)
+                      :& (SVersion =:: 0)
+                      :& (SOnDisplayed =:: return ())
+                      :& RNil
+
+-- | A record representing an object of the DOMWidget class from IPython
+defaultDOMWidget :: FieldType ViewName -> Rec Attr DOMWidgetClass
+defaultDOMWidget viewName = defaultWidget viewName <+> domAttrs
+  where domAttrs = (SVisible =:: True)
+                :& (SCSS =:: [])
+                :& (SDOMClasses =:: [])
+                :& (SWidth =:: 0)
+                :& (SHeight =:: 0)
+                :& (SPadding =:: 0)
+                :& (SMargin =:: 0)
+                :& (SColor =:: "")
+                :& (SBackgroundColor =:: "")
+                :& (SBorderColor =:: "")
+                :& (SBorderWidth =:: 0)
+                :& (SBorderRadius =:: 0)
+                :& (SBorderStyle =:: DefaultBorder)
+                :& (SFontStyle =:: DefaultFont)
+                :& (SFontWeight =:: DefaultWeight)
+                :& (SFontSize =:: 0)
+                :& (SFontFamily =:: "")
+                :& RNil
+
+-- | A record representing a widget of the _String class from IPython
+defaultStringWidget :: FieldType ViewName -> Rec Attr StringClass
+defaultStringWidget viewName = defaultDOMWidget viewName <+> strAttrs
+  where strAttrs = (SStringValue =:: "")
+                :& (SDisabled =:: False)
+                :& (SDescription =:: "")
+                :& (SPlaceholder =:: "")
+                :& RNil
+
+-- | A record representing a widget of the _Bool class from IPython
+defaultBoolWidget :: FieldType ViewName -> Rec Attr BoolClass
+defaultBoolWidget viewName = defaultDOMWidget viewName <+> boolAttrs
+  where boolAttrs = (SBoolValue =:: False)
+                 :& (SDisabled =:: False)
+                 :& (SDescription =:: "")
+                 :& RNil
+
+-- | A record representing a widget of the _Selection class from IPython
+defaultSelectionWidget :: FieldType ViewName -> Rec Attr SelectionClass
+defaultSelectionWidget viewName = defaultDOMWidget viewName <+> selectionAttrs
+  where selectionAttrs = (SOptions =:: OptionLabels [])
+                      :& (SSelectedValue =:: "")
+                      :& (SSelectedLabel =:: "")
+                      :& (SDisabled =:: False)
+                      :& (SDescription =:: "")
+                      :& (SSelectionHandler =:: return ())
+                      :& RNil
+
+-- | A record representing a widget of the _MultipleSelection class from IPython
+defaultMultipleSelectionWidget :: FieldType ViewName -> Rec Attr MultipleSelectionClass
+defaultMultipleSelectionWidget viewName = defaultDOMWidget viewName <+> mulSelAttrs
+  where mulSelAttrs = (SOptions =:: OptionLabels [])
+                   :& (SSelectedLabels =:: [])
+                   :& (SSelectedValues =:: [])
+                   :& (SDisabled =:: False)
+                   :& (SDescription =:: "")
+                   :& (SSelectionHandler =:: return ())
+                   :& 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.
+instance RecAll Attr (WidgetFields w) ToPairs => ToJSON (WidgetState w) where
+  toJSON record =
+    object
+    . concat
+    . recordToList
+    . rmap (\(Compose (Dict x)) -> Const $ toPairs x)
+    $ reifyConstraint (Proxy :: Proxy ToPairs) $ _getState record
+
+data IPythonWidget (w :: WidgetType) = IPythonWidget { uuid :: UUID, state :: IORef (WidgetState w) }
+
+-- | Change the value for a field, and notify the frontend about it.
+setField :: (f ∈ WidgetFields w, IHaskellWidget (IPythonWidget w), ToPairs (Attr f)) => IPythonWidget w -> SField f -> FieldType f -> IO ()
+setField widget (sfield :: SField f) fval = do
+  setField' widget sfield fval
+  let pairs = toPairs (Attr fval :: Attr f)
+  when (not . null $ pairs) $ widgetSendUpdate widget (object pairs)
+
+-- | Change the value of a field, without notifying the frontend. For internal use. Uses BangPattern.
+setField' :: (f ∈ WidgetFields w, IHaskellWidget (IPythonWidget w)) => IPythonWidget w -> SField f -> FieldType f -> IO ()
+setField' widget sfield !fval = modifyIORef (state widget) (WidgetState . rput (sfield =:: fval) . _getState)
+
+-- | Get the value of a field.
+getField :: (f ∈ WidgetFields w) => IPythonWidget w -> SField f -> IO (FieldType f)
+getField widget sfield = _unAttr <$> rget sfield <$> _getState <$> readIORef (state widget)
+
+-- | Useful with toJSON and OverloadedStrings
+str :: String -> String
+str = id
+
+-- | Send zero values as empty strings, which stands for default value in the frontend.
+instance ToJSON Natural where
+  toJSON 0 = String ""
+  toJSON n = String . pack $ show n
+
+
+

src/IHaskell/Eval/Evaluate.hs

@@ -239,6 +239,10 @@ initializeImports = do
   imports <- mapM parseImportDecl $ globalImports ++ displayImports
   setContext $ map IIDecl $ implicitPrelude : imports
 
+  -- Set -fcontext-stack to 100 (default in ghc-7.10). ghc-7.8 uses 20, which is too small.
+  let contextStackFlag = printf "-fcontext-stack=%d" (100 :: Int)
+  void $ setFlags [contextStackFlag]
+
 -- | Give a value for the `it` variable.
 initializeItVariable :: Interpreter ()
 initializeItVariable =

verify_formatting.py

@@ -51,9 +51,14 @@ for source_dir in ["src", "ipython-kernel", "ihaskell-display"]:
             continue
 
         for filename in filenames:
-            # Take Haskell files, but ignore the Cabal Setup.hs
-            # Also ignore IHaskellPrelude.hs, it uses CPP in weird places
-            ignored_files = ["Setup.hs", "IHaskellPrelude.hs"]
+            if "ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets" in root:
+                # Ignore Types.hs and Common.hs from ihaskell-widgets
+                # They cause issues with hindent, due to promoted types
+                ignored_files = ["Types.hs", "Common.hs"]
+            else:
+                # Take Haskell files, but ignore the Cabal Setup.hs
+                # Also ignore IHaskellPrelude.hs, it uses CPP in weird places
+                ignored_files = ["Setup.hs", "IHaskellPrelude.hs"]
             if filename.endswith(".hs") and filename not in ignored_files:
                 sources.append(os.path.join(root, filename))