packages feed

ihaskell-widgets (empty) → 0.1.0.0

raw patch · 37 files changed

+3220/−0 lines, 37 filesdep +aesondep +basedep +containerssetup-changed

Dependencies added: aeson, base, containers, ihaskell, ipython-kernel, nats, scientific, singletons, text, unix, unordered-containers, vector, vinyl

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Sumit Sahrawat++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ MsgSpec.md view
@@ -0,0 +1,122 @@+# 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 assumptions the IHaskell 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. Some numbers need to be sent as actual numbers (when non-null), whereas some (especially+those used by sliders) need to be sent as strings.++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.++## The issue with console input++Whenever the kernel needs to fetch input from the stdin, an `input_request` message is sent to the+frontend. The format for this message requires that this message be sent in response to an+`execute_request`, which is sent by the frontend whenever a cell is executed.++If this were not so, the frontend would not be able to determine under which cell to place the text+input widget, when an `input_request` is received.++Now, widgets cannot send `execute_request` messages. They can only send `comm_data` messages, which+means that it's not possible to fetch input through widget events.++---++*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.++---
+ README.md view
@@ -0,0 +1,7 @@+# 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).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ihaskell-widgets.cabal view
@@ -0,0 +1,121 @@+-- Initial ihaskell-widgets.cabal generated by cabal init.  For +-- further documentation, see http://haskell.org/cabal/users-guide/++-- The name of the package.+name:                ihaskell-widgets++-- The package version.  See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary:      +-+------- breaking API changes+--                   | | +----- non-breaking API additions+--                   | | | +--- code changes with no API change+version:             0.1.0.0++-- A short (one-line) description of the package.+synopsis:            IPython standard widgets for IHaskell.++-- A longer description of the package.+-- description:         ++-- URL for the project homepage or repository.+homepage:            http://www.github.com/gibiansky/IHaskell++-- The license under which the package is released.+license:             MIT++-- The file containing the license text.+license-file:        LICENSE++-- The package author(s).+author:              Sumit Sahrawat++-- An email address to which users can send suggestions, bug reports, and +-- patches.+maintainer:          Sumit Sahrawat <sumit.sahrawat.apm13@iitbhu.ac.in>,+                     Andrew Gibiansky <andrew.gibiansky@gmail.com>++-- A copyright notice.+-- copyright:           ++-- category:            ++build-type:          Simple++-- Extra files to be distributed with the package, such as examples or a +-- README.+extra-source-files:  README.md, MsgSpec.md++-- Constraint on the version of Cabal needed to build this package.+cabal-version:       >=1.10++library+  -- Modules exported by the library.+  exposed-modules:     IHaskell.Display.Widgets+  +  -- Modules included in this library but not exported.+  other-modules:       IHaskell.Display.Widgets.Button+                       IHaskell.Display.Widgets.Box.Box+                       IHaskell.Display.Widgets.Box.FlexBox+                       IHaskell.Display.Widgets.Box.SelectionContainer.Accordion+                       IHaskell.Display.Widgets.Box.SelectionContainer.Tab+                       IHaskell.Display.Widgets.Bool.CheckBox+                       IHaskell.Display.Widgets.Bool.ToggleButton+                       IHaskell.Display.Widgets.Int.IntText+                       IHaskell.Display.Widgets.Int.BoundedInt.BoundedIntText+                       IHaskell.Display.Widgets.Int.BoundedInt.IntProgress+                       IHaskell.Display.Widgets.Int.BoundedInt.IntSlider+                       IHaskell.Display.Widgets.Int.BoundedIntRange.IntRangeSlider+                       IHaskell.Display.Widgets.Float.FloatText+                       IHaskell.Display.Widgets.Float.BoundedFloat.BoundedFloatText+                       IHaskell.Display.Widgets.Float.BoundedFloat.FloatProgress+                       IHaskell.Display.Widgets.Float.BoundedFloat.FloatSlider+                       IHaskell.Display.Widgets.Float.BoundedFloatRange.FloatRangeSlider+                       IHaskell.Display.Widgets.Image+                       IHaskell.Display.Widgets.Output+                       IHaskell.Display.Widgets.Selection.Dropdown+                       IHaskell.Display.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.Types+                       IHaskell.Display.Widgets.Common+                       IHaskell.Display.Widgets.Singletons++  -- LANGUAGE extensions used by modules in this package.+  -- other-extensions:    +  +  -- Other library packages from which modules are imported.+  build-depends:       aeson >=0.7 && < 0.9+                     , base >=4.7 && <4.9+                     , containers >= 0.5+                     , ipython-kernel >= 0.6.1.1+                     , text >= 0.11+                     , unordered-containers -any+                     , nats -any+                     , vinyl >= 0.5+                     , vector -any+                     , singletons >= 0.9.0+                     , scientific -any+                     , unix -any++                     , ihaskell >= 0.6.4.1+  +  -- Directories containing source files.+  hs-source-dirs:      src+  +  -- 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
+ src/IHaskell/Display/Widgets.hs view
@@ -0,0 +1,45 @@+module IHaskell.Display.Widgets (module X) where++import           IHaskell.Display.Widgets.Button as X++import           IHaskell.Display.Widgets.Box.Box as X+import           IHaskell.Display.Widgets.Box.FlexBox as X+import           IHaskell.Display.Widgets.Box.SelectionContainer.Accordion as X+import           IHaskell.Display.Widgets.Box.SelectionContainer.Tab as X++import           IHaskell.Display.Widgets.Bool.CheckBox as X+import           IHaskell.Display.Widgets.Bool.ToggleButton as X++import           IHaskell.Display.Widgets.Int.IntText as X+import           IHaskell.Display.Widgets.Int.BoundedInt.BoundedIntText as X+import           IHaskell.Display.Widgets.Int.BoundedInt.IntProgress as X+import           IHaskell.Display.Widgets.Int.BoundedInt.IntSlider as X+import           IHaskell.Display.Widgets.Int.BoundedIntRange.IntRangeSlider as X++import           IHaskell.Display.Widgets.Float.FloatText as X+import           IHaskell.Display.Widgets.Float.BoundedFloat.BoundedFloatText as X+import           IHaskell.Display.Widgets.Float.BoundedFloat.FloatProgress as X+import           IHaskell.Display.Widgets.Float.BoundedFloat.FloatSlider as X+import           IHaskell.Display.Widgets.Float.BoundedFloatRange.FloatRangeSlider as X++import           IHaskell.Display.Widgets.Image as X++import           IHaskell.Display.Widgets.Output as X++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.Common as X+import           IHaskell.Display.Widgets.Types as X (setField, getField, properties)++import           IHaskell.Display.Widgets.Types as X (triggerDisplay, triggerChange, triggerClick,+                                                      triggerSelection, triggerSubmit,+                                                      ChildWidget(..))
+ src/IHaskell/Display/Widgets/Bool/CheckBox.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++module IHaskell.Display.Widgets.Bool.CheckBox (+-- * The CheckBox Widget+CheckBox, +          -- * Constructor+          mkCheckBox) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Control.Monad (when, join, void)+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 'CheckBox' represents a Checkbox widget from IPython.html.widgets.+type CheckBox = IPythonWidget CheckBoxType++-- | Create a new output widget+mkCheckBox :: IO CheckBox+mkCheckBox = 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 CheckBox where+  display b = do+    widgetSendView b+    return $ Display []++instance IHaskellWidget CheckBox 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 BoolValue value+    triggerChange widget
+ src/IHaskell/Display/Widgets/Bool/ToggleButton.hs view
@@ -0,0 +1,70 @@+{-# 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, void)+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 = (Tooltip =:: "")+                    :& (Icon =:: "")+                    :& (ButtonStyle =:: 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 BoolValue value+    triggerChange widget
+ src/IHaskell/Display/Widgets/Box/Box.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++module IHaskell.Display.Widgets.Box.Box (+-- * The Box widget+Box, +     -- * Constructor+     mkBox) 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 'Box' represents a Box widget from IPython.html.widgets.+type Box = IPythonWidget BoxType++-- | Create a new box+mkBox :: IO Box+mkBox = do+  -- Default properties, with a random uuid+  uuid <- U.random++  let widgetState = WidgetState $ defaultBoxWidget "BoxView"++  stateIO <- newIORef widgetState++  let box = IPythonWidget uuid stateIO+      initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Box"]++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen box initData $ toJSON widgetState++  -- Return the widget+  return box++instance IHaskellDisplay Box where+  display b = do+    widgetSendView b+    return $ Display []++instance IHaskellWidget Box where+  getCommUUID = uuid
+ src/IHaskell/Display/Widgets/Box/FlexBox.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++module IHaskell.Display.Widgets.Box.FlexBox (+-- * The FlexBox widget+FlexBox, +         -- * Constructor+         mkFlexBox) 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 'FlexBox' represents a FlexBox widget from IPython.html.widgets.+type FlexBox = IPythonWidget FlexBoxType++-- | Create a new box+mkFlexBox :: IO FlexBox+mkFlexBox = do+  -- Default properties, with a random uuid+  uuid <- U.random++  let boxAttrs = defaultBoxWidget "FlexBoxView"+      flxAttrs = (Orientation =:: HorizontalOrientation)+                 :& (Flex =:: 0)+                 :& (Pack =:: StartLocation)+                 :& (Align =:: StartLocation)+                 :& RNil+      widgetState = WidgetState $ boxAttrs <+> flxAttrs++  stateIO <- newIORef widgetState++  let box = IPythonWidget uuid stateIO+      initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.FlexBox"]++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen box initData $ toJSON widgetState++  -- Return the widget+  return box++instance IHaskellDisplay FlexBox where+  display b = do+    widgetSendView b+    return $ Display []++instance IHaskellWidget FlexBox where+  getCommUUID = uuid
+ src/IHaskell/Display/Widgets/Box/SelectionContainer/Accordion.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++module IHaskell.Display.Widgets.Box.SelectionContainer.Accordion (+-- * The Accordion widget+Accordion, +           -- * Constructor+           mkAccordion) 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 qualified Data.Scientific as Sci+import           Data.Text (Text)+import           Data.Vinyl (Rec(..), (<+>))++import           IHaskell.Display+import           IHaskell.Eval.Widgets+import           IHaskell.IPython.Message.UUID as U++import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Common++-- | A 'Accordion' represents a Accordion widget from IPython.html.widgets.+type Accordion = IPythonWidget AccordionType++-- | Create a new box+mkAccordion :: IO Accordion+mkAccordion = do+  -- Default properties, with a random uuid+  uuid <- U.random++  let widgetState = WidgetState $ defaultSelectionContainerWidget "AccordionView"++  stateIO <- newIORef widgetState++  let box = IPythonWidget uuid stateIO+      initData = object+                   ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Accordion"]++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen box initData $ toJSON widgetState++  -- Return the widget+  return box++instance IHaskellDisplay Accordion where+  display b = do+    widgetSendView b+    return $ Display []++instance IHaskellWidget Accordion where+  getCommUUID = uuid+  comm widget (Object dict1) _ = do+    let key1 = "sync_data" :: Text+        key2 = "selected_index" :: Text+        Just (Object dict2) = HM.lookup key1 dict1+        Just (Number num) = HM.lookup key2 dict2+    setField' widget SelectedIndex (Sci.coefficient num)+    triggerChange widget
+ src/IHaskell/Display/Widgets/Box/SelectionContainer/Tab.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++module IHaskell.Display.Widgets.Box.SelectionContainer.Tab (+-- * The Tab widget+TabWidget, +           -- * Constructor+           mkTabWidget) 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 qualified Data.Scientific as Sci+import           Data.Text (Text)+import           Data.Vinyl (Rec(..), (<+>))++import           IHaskell.Display+import           IHaskell.Eval.Widgets+import           IHaskell.IPython.Message.UUID as U++import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Common++-- | A 'TabWidget' represents a Tab widget from IPython.html.widgets.+type TabWidget = IPythonWidget TabType++-- | Create a new box+mkTabWidget :: IO TabWidget+mkTabWidget = do+  -- Default properties, with a random uuid+  uuid <- U.random++  let widgetState = WidgetState $ defaultSelectionContainerWidget "TabView"++  stateIO <- newIORef widgetState++  let box = IPythonWidget uuid stateIO+      initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Tab"]++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen box initData $ toJSON widgetState++  -- Return the widget+  return box++instance IHaskellDisplay TabWidget where+  display b = do+    widgetSendView b+    return $ Display []++instance IHaskellWidget TabWidget where+  getCommUUID = uuid+  comm widget (Object dict1) _ = do+    let key1 = "sync_data" :: Text+        key2 = "selected_index" :: Text+        Just (Object dict2) = HM.lookup key1 dict1+        Just (Number num) = HM.lookup key2 dict2+    setField' widget SelectedIndex (Sci.coefficient num)+    triggerChange widget
+ src/IHaskell/Display/Widgets/Button.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++module IHaskell.Display.Widgets.Button (+-- * The Button Widget+Button, +        -- * Create a new button+        mkButton) 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 'Button' represents a Button from IPython.html.widgets.+type Button = IPythonWidget ButtonType++-- | Create a new button+mkButton :: IO Button+mkButton = do+  -- Default properties, with a random uuid+  uuid <- U.random++  let dom = defaultDOMWidget "ButtonView"+      but = (Description =:: "")+            :& (Tooltip =:: "")+            :& (Disabled =:: False)+            :& (Icon =:: "")+            :& (ButtonStyle =:: DefaultButton)+            :& (ClickHandler =:: 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 button initData $ toJSON buttonState++  -- Return the button widget+  return button++instance IHaskellDisplay Button where+  display b = do+    widgetSendView b+    return $ Display []++instance IHaskellWidget Button where+  getCommUUID = uuid+  comm widget (Object dict1) _ = do+    let key1 = "content" :: Text+        key2 = "event" :: Text+        Just (Object dict2) = HM.lookup key1 dict1+        Just (String event) = HM.lookup key2 dict2+    when (event == "click") $ triggerClick widget
+ src/IHaskell/Display/Widgets/Common.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+module IHaskell.Display.Widgets.Common where++import Data.Aeson+import Data.Aeson.Types (emptyObject)+import Data.Text (pack, Text)++import IHaskell.Display (IHaskellWidget)+import IHaskell.Eval.Widgets (widgetSendClose)++import qualified IHaskell.Display.Widgets.Singletons as S++pattern ViewModule = S.SViewModule+pattern ViewName = S.SViewName+pattern MsgThrottle = S.SMsgThrottle+pattern Version = S.SVersion+pattern DisplayHandler = S.SDisplayHandler+pattern Visible = S.SVisible+pattern CSS = S.SCSS+pattern DOMClasses = S.SDOMClasses+pattern Width = S.SWidth+pattern Height = S.SHeight+pattern Padding = S.SPadding+pattern Margin = S.SMargin+pattern Color = S.SColor+pattern BackgroundColor = S.SBackgroundColor+pattern BorderColor = S.SBorderColor+pattern BorderWidth = S.SBorderWidth+pattern BorderRadius = S.SBorderRadius+pattern BorderStyle = S.SBorderStyle+pattern FontStyle = S.SFontStyle+pattern FontWeight = S.SFontWeight+pattern FontSize = S.SFontSize+pattern FontFamily = S.SFontFamily+pattern Description = S.SDescription+pattern ClickHandler = S.SClickHandler+pattern SubmitHandler = S.SSubmitHandler+pattern Disabled = S.SDisabled+pattern StringValue = S.SStringValue+pattern Placeholder = S.SPlaceholder+pattern Tooltip = S.STooltip+pattern Icon = S.SIcon+pattern ButtonStyle = S.SButtonStyle+pattern B64Value = S.SB64Value+pattern ImageFormat = S.SImageFormat+pattern BoolValue = S.SBoolValue+pattern Options = S.SOptions+pattern SelectedLabel = S.SSelectedLabel+pattern SelectedValue = S.SSelectedValue+pattern SelectionHandler = S.SSelectionHandler+pattern Tooltips = S.STooltips+pattern Icons = S.SIcons+pattern SelectedLabels = S.SSelectedLabels+pattern SelectedValues = S.SSelectedValues+pattern IntValue = S.SIntValue+pattern StepInt = S.SStepInt+pattern MaxInt = S.SMaxInt+pattern MinInt = S.SMinInt+pattern IntPairValue = S.SIntPairValue+pattern LowerInt = S.SLowerInt+pattern UpperInt = S.SUpperInt+pattern FloatValue = S.SFloatValue+pattern StepFloat = S.SStepFloat+pattern MaxFloat = S.SMaxFloat+pattern MinFloat = S.SMinFloat+pattern FloatPairValue = S.SFloatPairValue+pattern LowerFloat = S.SLowerFloat+pattern UpperFloat = S.SUpperFloat+pattern Orientation = S.SOrientation+pattern ShowRange = S.SShowRange+pattern ReadOut = S.SReadOut+pattern SliderColor = S.SSliderColor+pattern BarStyle = S.SBarStyle+pattern ChangeHandler = S.SChangeHandler+pattern Children = S.SChildren+pattern OverflowX = S.SOverflowX+pattern OverflowY = S.SOverflowY+pattern BoxStyle = S.SBoxStyle+pattern Flex = S.SFlex+pattern Pack = S.SPack+pattern Align = S.SAlign+pattern Titles = S.STitles+pattern SelectedIndex = S.SSelectedIndex++-- | Close a widget's comm+closeWidget :: IHaskellWidget w => w -> IO ()+closeWidget w = widgetSendClose w emptyObject++newtype StrInt = StrInt Integer deriving (Num, Ord, Eq, Enum)++instance ToJSON StrInt where+  toJSON (StrInt x) = toJSON . pack $ show x++-- | 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 = ""++-- | Pre-defined bar styles+data BarStyleValue = SuccessBar+                   | InfoBar+                   | WarningBar+                   | DangerBar+                   | DefaultBar++instance ToJSON BarStyleValue where+  toJSON SuccessBar = "success"+  toJSON InfoBar = "info"+  toJSON WarningBar = "warning"+  toJSON DangerBar = "danger"+  toJSON DefaultBar = ""++-- | Image formats for ImageWidget+data ImageFormatValue = PNG+                      | SVG+                      | JPG+  deriving Eq++instance Show ImageFormatValue where+  show PNG = "png"+  show SVG = "svg"+  show JPG = "jpg"++instance ToJSON ImageFormatValue where+  toJSON = toJSON . pack . show++-- | Options for selection widgets.+data SelectionOptions = OptionLabels [Text] | OptionDict [(Text, Text)]++-- | Orientation values.+data OrientationValue = HorizontalOrientation+                      | VerticalOrientation++instance ToJSON OrientationValue where+  toJSON HorizontalOrientation = "horizontal"+  toJSON VerticalOrientation = "vertical"++data OverflowValue = VisibleOverflow+                   | HiddenOverflow+                   | ScrollOverflow+                   | AutoOverflow+                   | InitialOverflow+                   | InheritOverflow+                   | DefaultOverflow++instance ToJSON OverflowValue where+  toJSON VisibleOverflow = "visible"+  toJSON HiddenOverflow = "hidden"+  toJSON ScrollOverflow = "scroll"+  toJSON AutoOverflow = "auto"+  toJSON InitialOverflow = "initial"+  toJSON InheritOverflow = "inherit"+  toJSON DefaultOverflow = ""++data BoxStyleValue = SuccessBox+                   | InfoBox+                   | WarningBox+                   | DangerBox+                   | DefaultBox++instance ToJSON BoxStyleValue where+  toJSON SuccessBox = "success"+  toJSON InfoBox = "info"+  toJSON WarningBox = "warning"+  toJSON DangerBox = "danger"+  toJSON DefaultBox = ""++data LocationValue = StartLocation+                   | CenterLocation+                   | EndLocation+                   | BaselineLocation+                   | StretchLocation++instance ToJSON LocationValue where+  toJSON StartLocation = "start"+  toJSON CenterLocation = "center"+  toJSON EndLocation = "end"+  toJSON BaselineLocation = "baseline"+  toJSON StretchLocation = "stretch"
+ src/IHaskell/Display/Widgets/Float/BoundedFloat/BoundedFloatText.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++module IHaskell.Display.Widgets.Float.BoundedFloat.BoundedFloatText (+-- * The BoundedFloatText+-- Widget+BoundedFloatText, +                  -- * Constructor+                  mkBoundedFloatText) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Control.Monad (when, join, void)+import           Data.Aeson+import qualified Data.HashMap.Strict as HM+import           Data.IORef (newIORef)+import qualified Data.Scientific as Sci+import           Data.Text (Text)+import           Data.Vinyl (Rec(..), (<+>))++import           IHaskell.Display+import           IHaskell.Eval.Widgets+import           IHaskell.IPython.Message.UUID as U++import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Common++-- | 'BoundedFloatText' represents an BoundedFloatText widget from IPython.html.widgets.+type BoundedFloatText = IPythonWidget BoundedFloatTextType++-- | Create a new widget+mkBoundedFloatText :: IO BoundedFloatText+mkBoundedFloatText = do+  -- Default properties, with a random uuid+  uuid <- U.random++  let widgetState = WidgetState $ defaultBoundedFloatWidget "FloatTextView"++  stateIO <- newIORef widgetState++  let widget = IPythonWidget uuid stateIO+      initData = object+                   [ "model_name" .= str "WidgetModel"+                   , "widget_class" .= str "IPython.BoundedFloatText"+                   ]++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen widget initData $ toJSON widgetState++  -- Return the widget+  return widget++instance IHaskellDisplay BoundedFloatText where+  display b = do+    widgetSendView b+    return $ Display []++instance IHaskellWidget BoundedFloatText where+  getCommUUID = uuid+  comm widget (Object dict1) _ = do+    let key1 = "sync_data" :: Text+        key2 = "value" :: Text+        Just (Object dict2) = HM.lookup key1 dict1+        Just (Number value) = HM.lookup key2 dict2+    setField' widget FloatValue (Sci.toRealFloat value)+    triggerChange widget
+ src/IHaskell/Display/Widgets/Float/BoundedFloat/FloatProgress.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++module IHaskell.Display.Widgets.Float.BoundedFloat.FloatProgress (+-- * The FloatProgress Widget+FloatProgress, +               -- * Constructor+               mkFloatProgress) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Control.Exception (throw, ArithException(LossOfPrecision))+import           Control.Monad (when, join)+import           Data.Aeson+import qualified Data.HashMap.Strict as HM+import           Data.IORef (newIORef)+import qualified Data.Scientific as Sci+import           Data.Text (Text)+import           Data.Vinyl (Rec(..), (<+>))++import           IHaskell.Display+import           IHaskell.Eval.Widgets+import           IHaskell.IPython.Message.UUID as U++import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Common++-- | 'FloatProgress' represents an FloatProgress widget from IPython.html.widgets.+type FloatProgress = IPythonWidget FloatProgressType++-- | Create a new widget+mkFloatProgress :: IO FloatProgress+mkFloatProgress = do+  -- Default properties, with a random uuid+  uuid <- U.random++  let boundedFloatAttrs = defaultBoundedFloatWidget "ProgressView"+      progressAttrs = (BarStyle =:: DefaultBar) :& RNil+      widgetState = WidgetState $ boundedFloatAttrs <+> progressAttrs++  stateIO <- newIORef widgetState++  let widget = IPythonWidget uuid stateIO+      initData = object+                   [ "model_name" .= str "WidgetModel"+                   , "widget_class" .= str "IPython.FloatProgress"+                   ]++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen widget initData $ toJSON widgetState++  -- Return the widget+  return widget++instance IHaskellDisplay FloatProgress where+  display b = do+    widgetSendView b+    return $ Display []++instance IHaskellWidget FloatProgress where+  getCommUUID = uuid
+ src/IHaskell/Display/Widgets/Float/BoundedFloat/FloatSlider.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++module IHaskell.Display.Widgets.Float.BoundedFloat.FloatSlider (+-- * The FloatSlider Widget+FloatSlider, +             -- * Constructor+             mkFloatSlider) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Control.Monad (when, join, void)+import           Data.Aeson+import qualified Data.HashMap.Strict as HM+import           Data.IORef (newIORef)+import qualified Data.Scientific as Sci+import           Data.Text (Text)+import           Data.Vinyl (Rec(..), (<+>))++import           IHaskell.Display+import           IHaskell.Eval.Widgets+import           IHaskell.IPython.Message.UUID as U++import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Common++-- | 'FloatSlider' represents an FloatSlider widget from IPython.html.widgets.+type FloatSlider = IPythonWidget FloatSliderType++-- | Create a new widget+mkFloatSlider :: IO FloatSlider+mkFloatSlider = do+  -- Default properties, with a random uuid+  uuid <- U.random++  let boundedFloatAttrs = defaultBoundedFloatWidget "FloatSliderView"+      sliderAttrs = (Orientation =:: HorizontalOrientation)+                    :& (ShowRange =:: False)+                    :& (ReadOut =:: True)+                    :& (SliderColor =:: "")+                    :& RNil+      widgetState = WidgetState $ boundedFloatAttrs <+> sliderAttrs++  stateIO <- newIORef widgetState++  let widget = IPythonWidget uuid stateIO+      initData = object+                   ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.FloatSlider"]++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen widget initData $ toJSON widgetState++  -- Return the widget+  return widget++instance IHaskellDisplay FloatSlider where+  display b = do+    widgetSendView b+    return $ Display []++instance IHaskellWidget FloatSlider where+  getCommUUID = uuid+  comm widget (Object dict1) _ = do+    let key1 = "sync_data" :: Text+        key2 = "value" :: Text+        Just (Object dict2) = HM.lookup key1 dict1+        Just (Number value) = HM.lookup key2 dict2+    setField' widget FloatValue (Sci.toRealFloat value)+    triggerChange widget
+ src/IHaskell/Display/Widgets/Float/BoundedFloatRange/FloatRangeSlider.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++module IHaskell.Display.Widgets.Float.BoundedFloatRange.FloatRangeSlider (+-- * The FloatRangeSlider+-- Widget+FloatRangeSlider, +                  -- * Constructor+                  mkFloatRangeSlider) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Control.Exception (throw, ArithException(LossOfPrecision))+import           Control.Monad (when, join, void)+import           Data.Aeson+import qualified Data.HashMap.Strict as HM+import           Data.IORef (newIORef)+import qualified Data.Scientific as Sci+import           Data.Text (Text)+import qualified Data.Vector as V+import           Data.Vinyl (Rec(..), (<+>))++import           IHaskell.Display+import           IHaskell.Eval.Widgets+import           IHaskell.IPython.Message.UUID as U++import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Common++-- | 'FloatRangeSlider' represents an FloatRangeSlider widget from IPython.html.widgets.+type FloatRangeSlider = IPythonWidget FloatRangeSliderType++-- | Create a new widget+mkFloatRangeSlider :: IO FloatRangeSlider+mkFloatRangeSlider = do+  -- Default properties, with a random uuid+  uuid <- U.random++  let boundedFloatAttrs = defaultBoundedFloatRangeWidget "FloatSliderView"+      sliderAttrs = (Orientation =:: HorizontalOrientation)+                    :& (ShowRange =:: True)+                    :& (ReadOut =:: True)+                    :& (SliderColor =:: "")+                    :& RNil+      widgetState = WidgetState $ boundedFloatAttrs <+> sliderAttrs++  stateIO <- newIORef widgetState++  let widget = IPythonWidget uuid stateIO+      initData = object+                   [ "model_name" .= str "WidgetModel"+                   , "widget_class" .= str "IPython.FloatRangeSlider"+                   ]++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen widget initData $ toJSON widgetState++  -- Return the widget+  return widget++instance IHaskellDisplay FloatRangeSlider where+  display b = do+    widgetSendView b+    return $ Display []++instance IHaskellWidget FloatRangeSlider where+  getCommUUID = uuid+  comm widget (Object dict1) _ = do+    let key1 = "sync_data" :: Text+        key2 = "value" :: Text+        Just (Object dict2) = HM.lookup key1 dict1+        Just (Array values) = HM.lookup key2 dict2+        [x, y] = map (\(Number x) -> Sci.toRealFloat x) $ V.toList values+    setField' widget FloatPairValue (x, y)+    triggerChange widget
+ src/IHaskell/Display/Widgets/Float/FloatText.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++module IHaskell.Display.Widgets.Float.FloatText (+-- * The FloatText Widget+FloatText, +           -- * Constructor+           mkFloatText) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Control.Monad (when, join, void)+import           Data.Aeson+import qualified Data.HashMap.Strict as HM+import           Data.IORef (newIORef)+import qualified Data.Scientific as Sci+import           Data.Text (Text)+import           Data.Vinyl (Rec(..), (<+>))++import           IHaskell.Display+import           IHaskell.Eval.Widgets+import           IHaskell.IPython.Message.UUID as U++import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Common++-- | 'FloatText' represents an FloatText widget from IPython.html.widgets.+type FloatText = IPythonWidget FloatTextType++-- | Create a new widget+mkFloatText :: IO FloatText+mkFloatText = do+  -- Default properties, with a random uuid+  uuid <- U.random++  let widgetState = WidgetState $ defaultFloatWidget "FloatTextView"++  stateIO <- newIORef widgetState++  let widget = IPythonWidget uuid stateIO+      initData = object+                   ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.FloatText"]++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen widget initData $ toJSON widgetState++  -- Return the widget+  return widget++instance IHaskellDisplay FloatText where+  display b = do+    widgetSendView b+    return $ Display []++instance IHaskellWidget FloatText where+  getCommUUID = uuid+  comm widget (Object dict1) _ = do+    let key1 = "sync_data" :: Text+        key2 = "value" :: Text+        Just (Object dict2) = HM.lookup key1 dict1+        Just (Number value) = HM.lookup key2 dict2+    setField' widget FloatValue (Sci.toRealFloat value)+    triggerChange widget
+ src/IHaskell/Display/Widgets/Image.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++module IHaskell.Display.Widgets.Image (+-- * The Image Widget+ImageWidget, +             -- * Constructor+             mkImageWidget) 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.Monoid (mempty)+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++-- | 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+  uuid <- U.random++  let dom = defaultDOMWidget "ImageView"+      img = (ImageFormat =:: PNG)+            :& (B64Value =:: mempty)+            :& RNil+      widgetState = WidgetState (dom <+> img)++  stateIO <- newIORef widgetState++  let widget = IPythonWidget uuid stateIO++  let initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Image"]++  -- 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 ImageWidget where+  display b = do+    widgetSendView b+    return $ Display []++instance IHaskellWidget ImageWidget where+  getCommUUID = uuid
+ src/IHaskell/Display/Widgets/Int/BoundedInt/BoundedIntText.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++module IHaskell.Display.Widgets.Int.BoundedInt.BoundedIntText (+-- * The BoundedIntText Widget+BoundedIntText, +                -- * Constructor+                mkBoundedIntText) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Control.Monad (when, join, void)+import           Data.Aeson+import qualified Data.HashMap.Strict as HM+import           Data.IORef (newIORef)+import qualified Data.Scientific as Sci+import           Data.Text (Text)+import           Data.Vinyl (Rec(..), (<+>))++import           IHaskell.Display+import           IHaskell.Eval.Widgets+import           IHaskell.IPython.Message.UUID as U++import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Common++-- | 'BoundedIntText' represents an BoundedIntText widget from IPython.html.widgets.+type BoundedIntText = IPythonWidget BoundedIntTextType++-- | Create a new widget+mkBoundedIntText :: IO BoundedIntText+mkBoundedIntText = do+  -- Default properties, with a random uuid+  uuid <- U.random++  let widgetState = WidgetState $ defaultBoundedIntWidget "IntTextView"++  stateIO <- newIORef widgetState++  let widget = IPythonWidget uuid stateIO+      initData = object+                   [ "model_name" .= str "WidgetModel"+                   , "widget_class" .= str "IPython.BoundedIntText"+                   ]++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen widget initData $ toJSON widgetState++  -- Return the widget+  return widget++instance IHaskellDisplay BoundedIntText where+  display b = do+    widgetSendView b+    return $ Display []++instance IHaskellWidget BoundedIntText where+  getCommUUID = uuid+  comm widget (Object dict1) _ = do+    let key1 = "sync_data" :: Text+        key2 = "value" :: Text+        Just (Object dict2) = HM.lookup key1 dict1+        Just (Number value) = HM.lookup key2 dict2+    setField' widget IntValue (Sci.coefficient value)+    triggerChange widget
+ src/IHaskell/Display/Widgets/Int/BoundedInt/IntProgress.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++module IHaskell.Display.Widgets.Int.BoundedInt.IntProgress (+-- * The IntProgress Widget+IntProgress, +             -- * Constructor+             mkIntProgress) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Control.Exception (throw, ArithException(LossOfPrecision))+import           Control.Monad (when, join)+import           Data.Aeson+import qualified Data.HashMap.Strict as HM+import           Data.IORef (newIORef)+import qualified Data.Scientific as Sci+import           Data.Text (Text)+import           Data.Vinyl (Rec(..), (<+>))++import           IHaskell.Display+import           IHaskell.Eval.Widgets+import           IHaskell.IPython.Message.UUID as U++import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Common++-- | 'IntProgress' represents an IntProgress widget from IPython.html.widgets.+type IntProgress = IPythonWidget IntProgressType++-- | Create a new widget+mkIntProgress :: IO IntProgress+mkIntProgress = do+  -- Default properties, with a random uuid+  uuid <- U.random++  let boundedIntAttrs = defaultBoundedIntWidget "ProgressView"+      progressAttrs = (BarStyle =:: DefaultBar) :& RNil+      widgetState = WidgetState $ boundedIntAttrs <+> progressAttrs++  stateIO <- newIORef widgetState++  let widget = IPythonWidget uuid stateIO+      initData = object+                   ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.IntProgress"]++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen widget initData $ toJSON widgetState++  -- Return the widget+  return widget++instance IHaskellDisplay IntProgress where+  display b = do+    widgetSendView b+    return $ Display []++instance IHaskellWidget IntProgress where+  getCommUUID = uuid
+ src/IHaskell/Display/Widgets/Int/BoundedInt/IntSlider.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++module IHaskell.Display.Widgets.Int.BoundedInt.IntSlider (+-- * The IntSlider Widget+IntSlider, +           -- * Constructor+           mkIntSlider) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Control.Monad (when, join, void)+import           Data.Aeson+import qualified Data.HashMap.Strict as HM+import           Data.IORef (newIORef)+import qualified Data.Scientific as Sci+import           Data.Text (Text)+import           Data.Vinyl (Rec(..), (<+>))++import           IHaskell.Display+import           IHaskell.Eval.Widgets+import           IHaskell.IPython.Message.UUID as U++import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Common++-- | 'IntSlider' represents an IntSlider widget from IPython.html.widgets.+type IntSlider = IPythonWidget IntSliderType++-- | Create a new widget+mkIntSlider :: IO IntSlider+mkIntSlider = do+  -- Default properties, with a random uuid+  uuid <- U.random++  let boundedIntAttrs = defaultBoundedIntWidget "IntSliderView"+      sliderAttrs = (Orientation =:: HorizontalOrientation)+                    :& (ShowRange =:: False)+                    :& (ReadOut =:: True)+                    :& (SliderColor =:: "")+                    :& RNil+      widgetState = WidgetState $ boundedIntAttrs <+> sliderAttrs++  stateIO <- newIORef widgetState++  let widget = IPythonWidget uuid stateIO+      initData = object+                   ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.IntSlider"]++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen widget initData $ toJSON widgetState++  -- Return the widget+  return widget++instance IHaskellDisplay IntSlider where+  display b = do+    widgetSendView b+    return $ Display []++instance IHaskellWidget IntSlider where+  getCommUUID = uuid+  comm widget (Object dict1) _ = do+    let key1 = "sync_data" :: Text+        key2 = "value" :: Text+        Just (Object dict2) = HM.lookup key1 dict1+        Just (Number value) = HM.lookup key2 dict2+    setField' widget IntValue (Sci.coefficient value)+    triggerChange widget
+ src/IHaskell/Display/Widgets/Int/BoundedIntRange/IntRangeSlider.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++module IHaskell.Display.Widgets.Int.BoundedIntRange.IntRangeSlider (+-- * The IntRangeSlider Widget+IntRangeSlider, +                -- * Constructor+                mkIntRangeSlider) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Control.Monad (when, join, void)+import           Data.Aeson+import qualified Data.HashMap.Strict as HM+import           Data.IORef (newIORef)+import qualified Data.Scientific as Sci+import           Data.Text (Text)+import qualified Data.Vector as V+import           Data.Vinyl (Rec(..), (<+>))++import           IHaskell.Display+import           IHaskell.Eval.Widgets+import           IHaskell.IPython.Message.UUID as U++import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Common++-- | 'IntRangeSlider' represents an IntRangeSlider widget from IPython.html.widgets.+type IntRangeSlider = IPythonWidget IntRangeSliderType++-- | Create a new widget+mkIntRangeSlider :: IO IntRangeSlider+mkIntRangeSlider = do+  -- Default properties, with a random uuid+  uuid <- U.random++  let boundedIntAttrs = defaultBoundedIntRangeWidget "IntSliderView"+      sliderAttrs = (Orientation =:: HorizontalOrientation)+                    :& (ShowRange =:: True)+                    :& (ReadOut =:: True)+                    :& (SliderColor =:: "")+                    :& RNil+      widgetState = WidgetState $ boundedIntAttrs <+> sliderAttrs++  stateIO <- newIORef widgetState++  let widget = IPythonWidget uuid stateIO+      initData = object+                   [ "model_name" .= str "WidgetModel"+                   , "widget_class" .= str "IPython.IntRangeSlider"+                   ]++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen widget initData $ toJSON widgetState++  -- Return the widget+  return widget++instance IHaskellDisplay IntRangeSlider where+  display b = do+    widgetSendView b+    return $ Display []++instance IHaskellWidget IntRangeSlider where+  getCommUUID = uuid+  comm widget (Object dict1) _ = do+    let key1 = "sync_data" :: Text+        key2 = "value" :: Text+        Just (Object dict2) = HM.lookup key1 dict1+        Just (Array values) = HM.lookup key2 dict2+        [x, y] = map (\(Number x) -> Sci.coefficient x) $ V.toList values+    setField' widget IntPairValue (x, y)+    triggerChange widget
+ src/IHaskell/Display/Widgets/Int/IntText.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++module IHaskell.Display.Widgets.Int.IntText (+-- * The IntText Widget+IntText, +         -- * Constructor+         mkIntText) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Control.Monad (when, join, void)+import           Data.Aeson+import qualified Data.HashMap.Strict as HM+import           Data.IORef (newIORef)+import qualified Data.Scientific as Sci+import           Data.Text (Text)+import           Data.Vinyl (Rec(..), (<+>))++import           IHaskell.Display+import           IHaskell.Eval.Widgets+import           IHaskell.IPython.Message.UUID as U++import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Common++-- | 'IntText' represents an IntText widget from IPython.html.widgets.+type IntText = IPythonWidget IntTextType++-- | Create a new widget+mkIntText :: IO IntText+mkIntText = do+  -- Default properties, with a random uuid+  uuid <- U.random++  let widgetState = WidgetState $ defaultIntWidget "IntTextView"++  stateIO <- newIORef widgetState++  let widget = IPythonWidget uuid stateIO+      initData = object ["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.IntText"]++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen widget initData $ toJSON widgetState++  -- Return the widget+  return widget++instance IHaskellDisplay IntText where+  display b = do+    widgetSendView b+    return $ Display []++instance IHaskellWidget IntText where+  getCommUUID = uuid+  comm widget (Object dict1) _ = do+    let key1 = "sync_data" :: Text+        key2 = "value" :: Text+        Just (Object dict2) = HM.lookup key1 dict1+        Just (Number value) = HM.lookup key2 dict2+    setField' widget IntValue (Sci.coefficient value)+    triggerChange widget
+ src/IHaskell/Display/Widgets/Output.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++module IHaskell.Display.Widgets.Output (+    -- * The Output Widget+    OutputWidget,+    -- * Constructor+    mkOutputWidget,+    -- * Using the output widget+    appendOutput,+    clearOutput,+    clearOutput_,+    replaceOutput,+    ) 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++-- | 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+  uuid <- U.random++  let widgetState = WidgetState $ defaultDOMWidget "OutputView"++  stateIO <- newIORef widgetState++  let widget = IPythonWidget uuid stateIO+      initData = object ["model_name" .= str "WidgetModel"]++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen widget initData $ toJSON widgetState++  -- Return the image widget+  return widget++-- | Append to the output widget+appendOutput :: IHaskellDisplay a => OutputWidget -> a -> IO ()+appendOutput widget out = do+  disp <- display out+  widgetPublishDisplay widget disp++-- | Clear the output widget immediately+clearOutput :: OutputWidget -> IO ()+clearOutput widget = widgetClearOutput widget False++-- | Clear the output widget on next append+clearOutput_ :: OutputWidget -> IO ()+clearOutput_ widget = widgetClearOutput widget True++-- | Replace the currently displayed output for output widget+replaceOutput :: IHaskellDisplay a => OutputWidget -> a -> IO ()+replaceOutput widget d = do+  clearOutput_ widget+  appendOutput widget d++instance IHaskellDisplay OutputWidget where+  display b = do+    widgetSendView b+    return $ Display []++instance IHaskellWidget OutputWidget where+  getCommUUID = uuid
+ src/IHaskell/Display/Widgets/Selection/Dropdown.hs view
@@ -0,0 +1,76 @@+{-# 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, void)+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 = (ButtonStyle =:: 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++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 Options+    case opts of+      OptionLabels _ -> void $ do+        setField' widget SelectedLabel label+        setField' widget SelectedValue label+      OptionDict ps ->+        case lookup label ps of+          Nothing -> return ()+          Just value -> void $ do+            setField' widget SelectedLabel label+            setField' widget SelectedValue value+    triggerSelection widget
+ src/IHaskell/Display/Widgets/Selection/RadioButtons.hs view
@@ -0,0 +1,74 @@+{-# 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, void)+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++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 Options+    case opts of+      OptionLabels _ -> void $ do+        setField' widget SelectedLabel label+        setField' widget SelectedValue label+      OptionDict ps ->+        case lookup label ps of+          Nothing -> return ()+          Just value -> void $ do+            setField' widget SelectedLabel label+            setField' widget SelectedValue value+    triggerSelection widget
+ src/IHaskell/Display/Widgets/Selection/Select.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++module IHaskell.Display.Widgets.Selection.Select (+-- * The Select Widget+Select, +        -- * Constructor+        mkSelect) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Control.Monad (when, join, void)+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 'Select' represents a Select widget from IPython.html.widgets.+type Select = IPythonWidget SelectType++-- | Create a new Select widget+mkSelect :: IO Select+mkSelect = 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++instance IHaskellDisplay Select where+  display b = do+    widgetSendView b+    return $ Display []++instance IHaskellWidget Select 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 Options+    case opts of+      OptionLabels _ -> void $ do+        setField' widget SelectedLabel label+        setField' widget SelectedValue label+      OptionDict ps ->+        case lookup label ps of+          Nothing -> return ()+          Just value -> void $ do+            setField' widget SelectedLabel label+            setField' widget SelectedValue value+    triggerSelection widget
+ src/IHaskell/Display/Widgets/Selection/SelectMultiple.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++module IHaskell.Display.Widgets.Selection.SelectMultiple (+-- * The SelectMultiple Widget+SelectMultiple, +                -- * Constructor+                mkSelectMultiple) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Control.Monad (fmap, join, sequence, void)+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 'SelectMultiple' represents a SelectMultiple widget from IPython.html.widgets.+type SelectMultiple = IPythonWidget SelectMultipleType++-- | Create a new SelectMultiple widget+mkSelectMultiple :: IO SelectMultiple+mkSelectMultiple = 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++instance IHaskellDisplay SelectMultiple where+  display b = do+    widgetSendView b+    return $ Display []++instance IHaskellWidget SelectMultiple 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 Options+    case opts of+      OptionLabels _ -> void $ do+        setField' widget SelectedLabels labelList+        setField' widget SelectedValues labelList+      OptionDict ps ->+        case sequence $ map (`lookup` ps) labelList of+          Nothing -> return ()+          Just valueList -> void $ do+            setField' widget SelectedLabels labelList+            setField' widget SelectedValues valueList+    triggerSelection widget
+ src/IHaskell/Display/Widgets/Selection/ToggleButtons.hs view
@@ -0,0 +1,81 @@+{-# 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, void)+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 = (Tooltips =:: [])+                           :& (Icons =:: [])+                           :& (ButtonStyle =:: 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++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 Options+    case opts of+      OptionLabels _ -> void $ do+        setField' widget SelectedLabel label+        setField' widget SelectedValue label+      OptionDict ps ->+        case lookup label ps of+          Nothing -> return ()+          Just value -> void $ do+            setField' widget SelectedLabel label+            setField' widget SelectedValue value+    triggerSelection widget
+ src/IHaskell/Display/Widgets/Singletons.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+module IHaskell.Display.Widgets.Singletons where++import Data.Singletons.TH++-- Widget properties+singletons [d|+  data Field = ViewModule+             | ViewName+             | MsgThrottle+             | Version+             | DisplayHandler+             | 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+             | IntValue+             | StepInt+             | MaxInt+             | MinInt+             | IntPairValue+             | LowerInt+             | UpperInt+             | FloatValue+             | StepFloat+             | MaxFloat+             | MinFloat+             | FloatPairValue+             | LowerFloat+             | UpperFloat+             | Orientation+             | ShowRange+             | ReadOut+             | SliderColor+             | BarStyle+             | ChangeHandler+             | Children+             | OverflowX+             | OverflowY+             | BoxStyle+             | Flex+             | Pack+             | Align+             | Titles+             | SelectedIndex+             deriving (Eq, Ord, Show)+             |]
+ src/IHaskell/Display/Widgets/String/HTML.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++module IHaskell.Display.Widgets.String.HTML (+-- * The HTML Widget+HTMLWidget, +            -- * Constructor+            mkHTMLWidget) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Control.Monad (when, join)+import           Data.Aeson+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++-- | 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+  uuid <- U.random+  let widgetState = WidgetState $ defaultStringWidget "HTMLView"++  stateIO <- newIORef widgetState++  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 widget initData $ toJSON widgetState++  -- Return the widget+  return widget++instance IHaskellDisplay HTMLWidget where+  display b = do+    widgetSendView b+    return $ Display []++instance IHaskellWidget HTMLWidget where+  getCommUUID = uuid
+ src/IHaskell/Display/Widgets/String/Latex.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++module IHaskell.Display.Widgets.String.Latex (+-- * The Latex Widget+LatexWidget, +             -- * Constructor+             mkLatexWidget) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Control.Monad (when, join)+import           Data.Aeson+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++-- | 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+  uuid <- U.random+  let widgetState = WidgetState $ defaultStringWidget "LatexView"++  stateIO <- newIORef widgetState++  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 widget initData $ toJSON widgetState++  -- Return the widget+  return widget++instance IHaskellDisplay LatexWidget where+  display b = do+    widgetSendView b+    return $ Display []++instance IHaskellWidget LatexWidget where+  getCommUUID = uuid
+ src/IHaskell/Display/Widgets/String/Text.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++module IHaskell.Display.Widgets.String.Text (+-- * The Text Widget+TextWidget, +            -- * Constructor+            mkTextWidget) 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 Map+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 '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+  uuid <- U.random+  let strWidget = defaultStringWidget "TextView"+      txtWidget = (SubmitHandler =:: return ()) :& (ChangeHandler =:: return ()) :& RNil+      widgetState = WidgetState $ strWidget <+> txtWidget++  stateIO <- newIORef widgetState++  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 widget initData $ toJSON widgetState++  -- Return the widget+  return widget++instance IHaskellDisplay TextWidget where+  display b = do+    widgetSendView b+    return $ Display []++instance IHaskellWidget TextWidget where+  getCommUUID = uuid+  -- Two possibilities: 1. content -> event -> "submit" 2. sync_data -> value -> <new_value>+  comm tw (Object dict1) _ =+    case Map.lookup "sync_data" dict1 of+      Just (Object dict2) ->+        case Map.lookup "value" dict2 of+          Just (String val) -> setField' tw StringValue val >> triggerChange tw+          Nothing           -> return ()+      Nothing ->+        case Map.lookup "content" dict1 of+          Just (Object dict2) ->+            case Map.lookup "event" dict2 of+              Just (String event) -> when (event == "submit") $ triggerSubmit tw+              Nothing             -> return ()+          Nothing -> return ()
+ src/IHaskell/Display/Widgets/String/TextArea.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++module IHaskell.Display.Widgets.String.TextArea (+-- * The TextArea Widget+TextArea, +          -- * Constructor+          mkTextArea) 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 'TextArea' represents a Textarea widget from IPython.html.widgets.+type TextArea = IPythonWidget TextAreaType++-- | Create a new TextArea widget+mkTextArea :: IO TextArea+mkTextArea = do+  -- Default properties, with a random uuid+  uuid <- U.random+  let strAttrs = defaultStringWidget "TextareaView"+      wgtAttrs = (ChangeHandler =:: return ()) :& RNil+      widgetState = WidgetState $ strAttrs <+> wgtAttrs++  stateIO <- newIORef widgetState++  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 widget initData $ toJSON widgetState++  -- Return the widget+  return widget++instance IHaskellDisplay TextArea where+  display b = do+    widgetSendView b+    return $ Display []++instance IHaskellWidget TextArea where+  getCommUUID = uuid+  comm widget (Object dict1) _ = do+    let key1 = "sync_data" :: Text+        key2 = "value" :: Text+        Just (Object dict2) = HM.lookup key1 dict1+        Just (String value) = HM.lookup key2 dict2+    setField' widget StringValue value+    triggerChange widget
+ src/IHaskell/Display/Widgets/Types.hs view
@@ -0,0 +1,635 @@+{-# 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 #-}+{-# LANGUAGE ExistentialQuantification #-}+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 properties function can be used to view all the @Field@s associated with a widget object.+--+-- Attributes are represented by the @Attr@ data type, which holds the value of a field, along with+-- the actual @Field@ object and a function to verify validity of changes to the value.+--+-- 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. Some numbers need to+-- be sent as numbers (represented by @Integer@), whereas some need to be sent as Strings (@StrInt@).+--+-- Child widgets are expected to be sent as strings of the form "IPY_MODEL_<uuid>", where @<uuid>@+-- represents the uuid of the widget's comm.+--+-- To know more about the IPython messaging specification (as implemented in this package) take a look+-- at the supplied MsgSpec.md.+--+-- Widgets are not able to do console input, the reason for that can also be found in the messaging+-- specification+import Control.Monad (unless, join, when, void, mapM_)+import Control.Applicative ((<$>))+import qualified Control.Exception as Ex++import GHC.IO.Exception+import System.IO.Error+import System.Posix.IO++import Data.Aeson+import Data.Aeson.Types (Pair)+import Data.IORef (IORef, readIORef, modifyIORef)+import Data.Text (Text, pack)++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 IHaskell.Eval.Widgets (widgetSendUpdate)+import IHaskell.Display (Base64, IHaskellWidget (..))+import IHaskell.IPython.Message.UUID++import IHaskell.Display.Widgets.Singletons (Field, SField (..))+import qualified IHaskell.Display.Widgets.Singletons as S+import IHaskell.Display.Widgets.Common++-- Classes from IPython's widget hierarchy. Defined as such to reduce code duplication.+type WidgetClass = '[ S.ViewModule, S.ViewName, S.MsgThrottle, S.Version, S.DisplayHandler ]+type DOMWidgetClass = WidgetClass :+++   '[ S.Visible, S.CSS, S.DOMClasses, S.Width, S.Height, S.Padding, S.Margin, S.Color+    , S.BackgroundColor, S.BorderColor, S.BorderWidth, S.BorderRadius, S.BorderStyle, S.FontStyle+    , S.FontWeight, S.FontSize, S.FontFamily+    ]+type StringClass = DOMWidgetClass :++ '[S.StringValue, S.Disabled, S.Description, S.Placeholder]+type BoolClass = DOMWidgetClass :++ '[S.BoolValue, S.Disabled, S.Description, S.ChangeHandler]+type SelectionClass = DOMWidgetClass :+++   '[S.Options, S.SelectedValue, S.SelectedLabel, S.Disabled, S.Description, S.SelectionHandler]+type MultipleSelectionClass = DOMWidgetClass :+++   '[S.Options, S.SelectedLabels, S.SelectedValues, S.Disabled, S.Description, S.SelectionHandler]+type IntClass = DOMWidgetClass :++ '[S.IntValue, S.Disabled, S.Description, S.ChangeHandler]+type BoundedIntClass = IntClass :++ '[S.StepInt, S.MinInt, S.MaxInt]+type IntRangeClass = IntClass :++ '[S.IntPairValue, S.LowerInt, S.UpperInt]+type BoundedIntRangeClass = IntRangeClass :++ '[S.StepInt, S.MinInt, S.MaxInt]+type FloatClass = DOMWidgetClass :++ '[S.FloatValue, S.Disabled, S.Description, S.ChangeHandler]+type BoundedFloatClass = FloatClass :++ '[S.StepFloat, S.MinFloat, S.MaxFloat]+type FloatRangeClass = FloatClass :++ '[S.FloatPairValue, S.LowerFloat, S.UpperFloat]+type BoundedFloatRangeClass = FloatRangeClass :++ '[S.StepFloat, S.MinFloat, S.MaxFloat]+type BoxClass = DOMWidgetClass :++ '[S.Children, S.OverflowX, S.OverflowY, S.BoxStyle]+type SelectionContainerClass = BoxClass :++ '[S.Titles, S.SelectedIndex, S.ChangeHandler]++-- Types associated with Fields.+type family FieldType (f :: Field) :: * where+  FieldType S.ViewModule = Text+  FieldType S.ViewName = Text+  FieldType S.MsgThrottle = Integer+  FieldType S.Version = Integer+  FieldType S.DisplayHandler = IO ()+  FieldType S.Visible = Bool+  FieldType S.CSS = [(Text, Text, Text)]+  FieldType S.DOMClasses = [Text]+  FieldType S.Width = StrInt+  FieldType S.Height = StrInt+  FieldType S.Padding = StrInt+  FieldType S.Margin = StrInt+  FieldType S.Color = Text+  FieldType S.BackgroundColor = Text+  FieldType S.BorderColor = Text+  FieldType S.BorderWidth = StrInt+  FieldType S.BorderRadius = StrInt+  FieldType S.BorderStyle = BorderStyleValue+  FieldType S.FontStyle = FontStyleValue+  FieldType S.FontWeight = FontWeightValue+  FieldType S.FontSize = StrInt+  FieldType S.FontFamily = Text+  FieldType S.Description = Text+  FieldType S.ClickHandler = IO ()+  FieldType S.SubmitHandler = IO ()+  FieldType S.Disabled = Bool+  FieldType S.StringValue = Text+  FieldType S.Placeholder = Text+  FieldType S.Tooltip = Text+  FieldType S.Icon = Text+  FieldType S.ButtonStyle = ButtonStyleValue+  FieldType S.B64Value = Base64+  FieldType S.ImageFormat = ImageFormatValue+  FieldType S.BoolValue = Bool+  FieldType S.Options = SelectionOptions+  FieldType S.SelectedLabel = Text+  FieldType S.SelectedValue = Text+  FieldType S.SelectionHandler = IO ()+  FieldType S.Tooltips = [Text]+  FieldType S.Icons = [Text]+  FieldType S.SelectedLabels = [Text]+  FieldType S.SelectedValues = [Text]+  FieldType S.IntValue = Integer+  FieldType S.StepInt = Integer+  FieldType S.MinInt = Integer+  FieldType S.MaxInt = Integer+  FieldType S.LowerInt = Integer+  FieldType S.UpperInt = Integer+  FieldType S.IntPairValue = (Integer, Integer)+  FieldType S.Orientation = OrientationValue+  FieldType S.ShowRange = Bool+  FieldType S.ReadOut = Bool+  FieldType S.SliderColor = Text+  FieldType S.BarStyle = BarStyleValue+  FieldType S.FloatValue = Double+  FieldType S.StepFloat = Double+  FieldType S.MinFloat = Double+  FieldType S.MaxFloat = Double+  FieldType S.LowerFloat = Double+  FieldType S.UpperFloat = Double+  FieldType S.FloatPairValue = (Double, Double)+  FieldType S.ChangeHandler = IO ()+  FieldType S.Children = [ChildWidget]+  FieldType S.OverflowX = OverflowValue+  FieldType S.OverflowY = OverflowValue+  FieldType S.BoxStyle = BoxStyleValue+  FieldType S.Flex = Int+  FieldType S.Pack = LocationValue+  FieldType S.Align = LocationValue+  FieldType S.Titles = [Text]+  FieldType S.SelectedIndex = Integer++-- | Can be used to put different widgets in a list. Useful for dealing with children widgets.+data ChildWidget = forall w. RecAll Attr (WidgetFields w) ToPairs => ChildWidget (IPythonWidget w)++instance ToJSON ChildWidget where+  toJSON (ChildWidget x) = toJSON . pack $ "IPY_MODEL_" ++ uuidToString (uuid x)++-- Will use a custom class rather than a newtype wrapper with an orphan instance. The main issue is+-- the need of a Bounded instance for Float / Double.+class CustomBounded a where+  lowerBound :: a+  upperBound :: a++-- Set according to what IPython widgets use+instance CustomBounded StrInt where+  upperBound = 10 ^ 16 - 1+  lowerBound = - (10 ^ 16 - 1)++instance CustomBounded Integer where+  lowerBound = - (10 ^ 16 - 1)+  upperBound = 10 ^ 16 - 1++instance CustomBounded Double where+  lowerBound = - (10 ** 16 - 1)+  upperBound = 10 ** 16 - 1++-- 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+                | IntTextType+                | BoundedIntTextType+                | IntSliderType+                | IntProgressType+                | IntRangeSliderType+                | FloatTextType+                | BoundedFloatTextType+                | FloatSliderType+                | FloatProgressType+                | FloatRangeSliderType+                | BoxType+                | FlexBoxType+                | AccordionType+                | TabType++-- Fields associated with a widget+type family WidgetFields (w :: WidgetType) :: [Field] where+  WidgetFields ButtonType = DOMWidgetClass :++ '[S.Description, S.Tooltip, S.Disabled, S.Icon, S.ButtonStyle, S.ClickHandler]+  WidgetFields ImageType = DOMWidgetClass :++ '[S.ImageFormat, S.B64Value]+  WidgetFields OutputType = DOMWidgetClass+  WidgetFields HTMLType = StringClass+  WidgetFields LatexType = StringClass+  WidgetFields TextType = StringClass :++ '[S.SubmitHandler, S.ChangeHandler]+  WidgetFields TextAreaType = StringClass :++ '[S.ChangeHandler]+  WidgetFields CheckBoxType = BoolClass+  WidgetFields ToggleButtonType = BoolClass :++ '[S.Tooltip, S.Icon, S.ButtonStyle]+  WidgetFields DropdownType = SelectionClass :++ '[S.ButtonStyle]+  WidgetFields RadioButtonsType = SelectionClass+  WidgetFields SelectType = SelectionClass+  WidgetFields ToggleButtonsType = SelectionClass :++ '[S.Tooltips, S.Icons, S.ButtonStyle]+  WidgetFields SelectMultipleType = MultipleSelectionClass+  WidgetFields IntTextType = IntClass+  WidgetFields BoundedIntTextType = BoundedIntClass+  WidgetFields IntSliderType = BoundedIntClass :++ '[S.Orientation, S.ShowRange, S.ReadOut, S.SliderColor]+  WidgetFields IntProgressType = BoundedIntClass :++ '[S.BarStyle]+  WidgetFields IntRangeSliderType = BoundedIntRangeClass :++ '[S.Orientation, S.ShowRange, S.ReadOut, S.SliderColor]+  WidgetFields FloatTextType = FloatClass+  WidgetFields BoundedFloatTextType = BoundedFloatClass+  WidgetFields FloatSliderType = BoundedFloatClass :++ '[S.Orientation, S.ShowRange, S.ReadOut, S.SliderColor]+  WidgetFields FloatProgressType = BoundedFloatClass :++ '[S.BarStyle]+  WidgetFields FloatRangeSliderType = BoundedFloatRangeClass :++ '[S.Orientation, S.ShowRange, S.ReadOut, S.SliderColor]+  WidgetFields BoxType = BoxClass+  WidgetFields FlexBoxType = BoxClass :++ '[S.Orientation, S.Flex, S.Pack, S.Align]+  WidgetFields AccordionType = SelectionContainerClass+  WidgetFields TabType = SelectionContainerClass++-- Wrapper around a field's value. A dummy value is sent as an empty string to the frontend.+data AttrVal a = Dummy a | Real a++unwrap :: AttrVal a -> a+unwrap (Dummy x) = x+unwrap (Real x) = x++-- Wrapper around a field.+data Attr (f :: Field) =+  Attr { _value :: AttrVal (FieldType f)+       , _verify :: FieldType f -> IO (FieldType f)+       , _field :: Field+       }++instance ToJSON (FieldType f) => ToJSON (Attr f) where+  toJSON attr = case _value attr of+    Dummy _ -> ""+    Real x -> toJSON x++-- 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 S.ViewModule) where toPairs x = ["_view_module" .= toJSON x]+instance ToPairs (Attr S.ViewName) where toPairs x = ["_view_name" .= toJSON x]+instance ToPairs (Attr S.MsgThrottle) where toPairs x = ["msg_throttle" .= toJSON x]+instance ToPairs (Attr S.Version) where toPairs x = ["version" .= toJSON x]+instance ToPairs (Attr S.DisplayHandler) where toPairs _ = [] -- Not sent to the frontend+instance ToPairs (Attr S.Visible) where toPairs x = ["visible" .= toJSON x]+instance ToPairs (Attr S.CSS) where toPairs x = ["_css" .= toJSON x]+instance ToPairs (Attr S.DOMClasses) where toPairs x = ["_dom_classes" .= toJSON x]+instance ToPairs (Attr S.Width) where toPairs x = ["width" .= toJSON x]+instance ToPairs (Attr S.Height) where toPairs x = ["height" .= toJSON x]+instance ToPairs (Attr S.Padding) where toPairs x = ["padding" .= toJSON x]+instance ToPairs (Attr S.Margin) where toPairs x = ["margin" .= toJSON x]+instance ToPairs (Attr S.Color) where toPairs x = ["color" .= toJSON x]+instance ToPairs (Attr S.BackgroundColor) where toPairs x = ["background_color" .= toJSON x]+instance ToPairs (Attr S.BorderColor) where toPairs x = ["border_color" .= toJSON x]+instance ToPairs (Attr S.BorderWidth) where toPairs x = ["border_width" .= toJSON x]+instance ToPairs (Attr S.BorderRadius) where toPairs x = ["border_radius" .= toJSON x]+instance ToPairs (Attr S.BorderStyle) where toPairs x = ["border_style" .= toJSON x]+instance ToPairs (Attr S.FontStyle) where toPairs x = ["font_style" .= toJSON x]+instance ToPairs (Attr S.FontWeight) where toPairs x = ["font_weight" .= toJSON x]+instance ToPairs (Attr S.FontSize) where toPairs x = ["font_size" .= toJSON x]+instance ToPairs (Attr S.FontFamily) where toPairs x = ["font_family" .= toJSON x]+instance ToPairs (Attr S.Description) where toPairs x = ["description" .= toJSON x]+instance ToPairs (Attr S.ClickHandler) where toPairs _ = [] -- Not sent to the frontend+instance ToPairs (Attr S.SubmitHandler) where toPairs _ = [] -- Not sent to the frontend+instance ToPairs (Attr S.Disabled) where toPairs x = ["disabled" .= toJSON x]+instance ToPairs (Attr S.StringValue) where toPairs x = ["value" .= toJSON x]+instance ToPairs (Attr S.Placeholder) where toPairs x = ["placeholder" .= toJSON x]+instance ToPairs (Attr S.Tooltip) where toPairs x = ["tooltip" .= toJSON x]+instance ToPairs (Attr S.Icon) where toPairs x = ["icon" .= toJSON x]+instance ToPairs (Attr S.ButtonStyle) where toPairs x = ["button_style" .= toJSON x]+instance ToPairs (Attr S.B64Value) where toPairs x = ["_b64value" .= toJSON x]+instance ToPairs (Attr S.ImageFormat) where toPairs x = ["format" .= toJSON x]+instance ToPairs (Attr S.BoolValue) where toPairs x = ["value" .= toJSON x]+instance ToPairs (Attr S.SelectedLabel) where toPairs x = ["selected_label" .= toJSON x]+instance ToPairs (Attr S.SelectedValue) where toPairs x = ["value" .= toJSON x]+instance ToPairs (Attr S.Options) where+  toPairs x = case _value x of+    Dummy _ -> labels ("" :: Text)+    Real (OptionLabels xs) -> labels xs+    Real (OptionDict xps) -> labels $ map fst xps+    where labels xs = ["_options_labels" .= xs]+instance ToPairs (Attr S.SelectionHandler) where toPairs _ = [] -- Not sent to the frontend+instance ToPairs (Attr S.Tooltips) where toPairs x = ["tooltips" .= toJSON x]+instance ToPairs (Attr S.Icons) where toPairs x = ["icons" .= toJSON x]+instance ToPairs (Attr S.SelectedLabels) where toPairs x = ["selected_labels" .= toJSON x]+instance ToPairs (Attr S.SelectedValues) where toPairs x = ["values" .= toJSON x]+instance ToPairs (Attr S.IntValue) where toPairs x = ["value" .= toJSON x]+instance ToPairs (Attr S.StepInt) where toPairs x = ["step" .= toJSON x]+instance ToPairs (Attr S.MinInt) where toPairs x = ["min" .= toJSON x]+instance ToPairs (Attr S.MaxInt) where toPairs x = ["max" .= toJSON x]+instance ToPairs (Attr S.IntPairValue) where toPairs x = ["value" .= toJSON x]+instance ToPairs (Attr S.LowerInt) where toPairs x = ["min" .= toJSON x]+instance ToPairs (Attr S.UpperInt) where toPairs x = ["max" .= toJSON x]+instance ToPairs (Attr S.FloatValue) where toPairs x = ["value" .= toJSON x]+instance ToPairs (Attr S.StepFloat) where toPairs x = ["step" .= toJSON x]+instance ToPairs (Attr S.MinFloat) where toPairs x = ["min" .= toJSON x]+instance ToPairs (Attr S.MaxFloat) where toPairs x = ["max" .= toJSON x]+instance ToPairs (Attr S.FloatPairValue) where toPairs x = ["value" .= toJSON x]+instance ToPairs (Attr S.LowerFloat) where toPairs x = ["min" .= toJSON x]+instance ToPairs (Attr S.UpperFloat) where toPairs x = ["max" .= toJSON x]+instance ToPairs (Attr S.Orientation) where toPairs x = ["orientation" .= toJSON x]+instance ToPairs (Attr S.ShowRange) where toPairs x = ["_range" .= toJSON x]+instance ToPairs (Attr S.ReadOut) where toPairs x = ["readout" .= toJSON x]+instance ToPairs (Attr S.SliderColor) where toPairs x = ["slider_color" .= toJSON x]+instance ToPairs (Attr S.BarStyle) where toPairs x = ["bar_style" .= toJSON x]+instance ToPairs (Attr S.ChangeHandler) where toPairs _ = [] -- Not sent to the frontend+instance ToPairs (Attr S.Children) where toPairs x = ["children" .= toJSON x]+instance ToPairs (Attr S.OverflowX) where toPairs x = ["overflow_x" .= toJSON x]+instance ToPairs (Attr S.OverflowY) where toPairs x = ["overflow_y" .= toJSON x]+instance ToPairs (Attr S.BoxStyle) where toPairs x = ["box_style" .= toJSON x]+instance ToPairs (Attr S.Flex) where toPairs x = ["flex" .= toJSON x]+instance ToPairs (Attr S.Pack) where toPairs x = ["pack" .= toJSON x]+instance ToPairs (Attr S.Align) where toPairs x = ["align" .= toJSON x]+instance ToPairs (Attr S.Titles) where toPairs x = ["_titles" .= toJSON x]+instance ToPairs (Attr S.SelectedIndex) where toPairs x = ["selected_index" .= toJSON x]++-- | Store the value for a field, as an object parametrized by the Field. No verification is done+-- for these values.+(=::) :: SingI f => Sing f -> FieldType f -> Attr f+s =:: x = Attr { _value = Real x, _verify = return, _field = reflect s }++-- | If the number is in the range, return it. Otherwise raise the appropriate (over/under)flow+-- exception.+rangeCheck :: (Num a, Ord a) => (a, a) -> a -> IO a+rangeCheck (l, u) x+  | l <= x && x <= u = return x+  | l > x = Ex.throw Ex.Underflow+  | u < x = Ex.throw Ex.Overflow++-- | Store a numeric value, with verification mechanism for its range.+ranged :: (SingI f, Num (FieldType f), Ord (FieldType f))+       => Sing f -> (FieldType f, FieldType f) -> AttrVal (FieldType f) -> Attr f+ranged s range x = Attr x (rangeCheck range) (reflect s)++-- | Store a numeric value, with the invariant that it stays non-negative. The value set is set as a+-- dummy value if it's equal to zero.+(=:+) :: (SingI f, Num (FieldType f), CustomBounded (FieldType f), Ord (FieldType f))+      => Sing f -> FieldType f -> Attr f+s =:+ val = Attr ((if val == 0 then Dummy else Real) val) (rangeCheck (0, upperBound)) (reflect s)++-- | Get a field from a singleton+-- Adapted from: http://stackoverflow.com/a/28033250/2388535+reflect :: forall (f :: Field). (SingI f, SingKind ('KProxy :: KProxy Field)) => Sing f -> Field+reflect = fromSing++-- | A record representing an object of the Widget class from IPython+defaultWidget :: FieldType S.ViewName -> Rec Attr WidgetClass+defaultWidget viewName = (ViewModule =:: "")+                      :& (ViewName =:: viewName)+                      :& (MsgThrottle =:+ 3)+                      :& (Version =:: 0)+                      :& (DisplayHandler =:: return ())+                      :& RNil++-- | A record representing an object of the DOMWidget class from IPython+defaultDOMWidget :: FieldType S.ViewName -> Rec Attr DOMWidgetClass+defaultDOMWidget viewName = defaultWidget viewName <+> domAttrs+  where domAttrs = (Visible =:: True)+                :& (CSS =:: [])+                :& (DOMClasses =:: [])+                :& (Width =:+ 0)+                :& (Height =:+ 0)+                :& (Padding =:+ 0)+                :& (Margin =:+ 0)+                :& (Color =:: "")+                :& (BackgroundColor =:: "")+                :& (BorderColor =:: "")+                :& (BorderWidth =:+ 0)+                :& (BorderRadius =:+ 0)+                :& (BorderStyle =:: DefaultBorder)+                :& (FontStyle =:: DefaultFont)+                :& (FontWeight =:: DefaultWeight)+                :& (FontSize =:+ 0)+                :& (FontFamily =:: "")+                :& RNil++-- | A record representing a widget of the _String class from IPython+defaultStringWidget :: FieldType S.ViewName -> Rec Attr StringClass+defaultStringWidget viewName = defaultDOMWidget viewName <+> strAttrs+  where strAttrs = (StringValue =:: "")+                :& (Disabled =:: False)+                :& (Description =:: "")+                :& (Placeholder =:: "")+                :& RNil++-- | A record representing a widget of the _Bool class from IPython+defaultBoolWidget :: FieldType S.ViewName -> Rec Attr BoolClass+defaultBoolWidget viewName = defaultDOMWidget viewName <+> boolAttrs+  where boolAttrs = (BoolValue =:: False)+                 :& (Disabled =:: False)+                 :& (Description =:: "")+                 :& (ChangeHandler =:: return ())+                 :& RNil++-- | A record representing a widget of the _Selection class from IPython+defaultSelectionWidget :: FieldType S.ViewName -> Rec Attr SelectionClass+defaultSelectionWidget viewName = defaultDOMWidget viewName <+> selectionAttrs+  where selectionAttrs = (Options =:: OptionLabels [])+                      :& (SelectedValue =:: "")+                      :& (SelectedLabel =:: "")+                      :& (Disabled =:: False)+                      :& (Description =:: "")+                      :& (SelectionHandler =:: return ())+                      :& RNil++-- | A record representing a widget of the _MultipleSelection class from IPython+defaultMultipleSelectionWidget :: FieldType S.ViewName -> Rec Attr MultipleSelectionClass+defaultMultipleSelectionWidget viewName = defaultDOMWidget viewName <+> mulSelAttrs+  where mulSelAttrs = (Options =:: OptionLabels [])+                   :& (SelectedLabels =:: [])+                   :& (SelectedValues =:: [])+                   :& (Disabled =:: False)+                   :& (Description =:: "")+                   :& (SelectionHandler =:: return ())+                   :& RNil++-- | A record representing a widget of the _Int class from IPython+defaultIntWidget :: FieldType S.ViewName -> Rec Attr IntClass+defaultIntWidget viewName = defaultDOMWidget viewName <+> intAttrs+  where intAttrs = (IntValue =:: 0)+                :& (Disabled =:: False)+                :& (Description =:: "")+                :& (ChangeHandler =:: return ())+                :& RNil++-- | A record representing a widget of the _BoundedInt class from IPython+defaultBoundedIntWidget :: FieldType S.ViewName -> Rec Attr BoundedIntClass+defaultBoundedIntWidget viewName = defaultIntWidget viewName <+> boundedIntAttrs+  where boundedIntAttrs = (StepInt =:: 1)+                       :& (MinInt =:: 0)+                       :& (MaxInt =:: 100)+                       :& RNil++-- | A record representing a widget of the _BoundedInt class from IPython+defaultIntRangeWidget :: FieldType S.ViewName -> Rec Attr IntRangeClass+defaultIntRangeWidget viewName = defaultIntWidget viewName <+> rangeAttrs+  where rangeAttrs = (IntPairValue =:: (25, 75))+                  :& (LowerInt =:: 0)+                  :& (UpperInt =:: 100)+                  :& RNil++-- | A record representing a widget of the _BoundedIntRange class from IPython+defaultBoundedIntRangeWidget :: FieldType S.ViewName -> Rec Attr BoundedIntRangeClass+defaultBoundedIntRangeWidget viewName = defaultIntRangeWidget viewName <+> boundedIntRangeAttrs+  where boundedIntRangeAttrs = (StepInt =:+ 1)+                            :& (MinInt =:: 0)+                            :& (MaxInt =:: 100)+                            :& RNil++-- | A record representing a widget of the _Float class from IPython+defaultFloatWidget :: FieldType S.ViewName -> Rec Attr FloatClass+defaultFloatWidget viewName = defaultDOMWidget viewName <+> intAttrs+  where intAttrs = (FloatValue =:: 0)+                :& (Disabled =:: False)+                :& (Description =:: "")+                :& (ChangeHandler =:: return ())+                :& RNil++-- | A record representing a widget of the _BoundedFloat class from IPython+defaultBoundedFloatWidget :: FieldType S.ViewName -> Rec Attr BoundedFloatClass+defaultBoundedFloatWidget viewName = defaultFloatWidget viewName <+> boundedFloatAttrs+  where boundedFloatAttrs = (StepFloat =:+ 1)+                         :& (MinFloat =:: 0)+                         :& (MaxFloat =:: 100)+                         :& RNil++-- | A record representing a widget of the _BoundedFloat class from IPython+defaultFloatRangeWidget :: FieldType S.ViewName -> Rec Attr FloatRangeClass+defaultFloatRangeWidget viewName = defaultFloatWidget viewName <+> rangeAttrs+  where rangeAttrs = (FloatPairValue =:: (25, 75))+                  :& (LowerFloat =:: 0)+                  :& (UpperFloat =:: 100)+                  :& RNil++-- | A record representing a widget of the _BoundedFloatRange class from IPython+defaultBoundedFloatRangeWidget :: FieldType S.ViewName -> Rec Attr BoundedFloatRangeClass+defaultBoundedFloatRangeWidget viewName = defaultFloatRangeWidget viewName <+> boundedFloatRangeAttrs+  where boundedFloatRangeAttrs = (StepFloat =:+ 1)+                              :& (MinFloat =:: 0)+                              :& (MaxFloat =:: 100)+                              :& RNil++-- | A record representing a widget of the _Box class from IPython+defaultBoxWidget :: FieldType S.ViewName -> Rec Attr BoxClass+defaultBoxWidget viewName = defaultDOMWidget viewName <+> boxAttrs+  where boxAttrs = (Children =:: [])+                :& (OverflowX =:: DefaultOverflow)+                :& (OverflowY =:: DefaultOverflow)+                :& (BoxStyle =:: DefaultBox)+                :& RNil++-- | A record representing a widget of the _SelectionContainer class from IPython+defaultSelectionContainerWidget :: FieldType S.ViewName -> Rec Attr SelectionContainerClass+defaultSelectionContainerWidget viewName = defaultBoxWidget viewName <+> selAttrs+  where selAttrs = (Titles =:: [])+                :& (SelectedIndex =:: 0)+                :& (ChangeHandler =:: 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 fval = do+  !newattr <- setField' widget sfield fval+  let pairs = toPairs newattr+  unless (null pairs) $ widgetSendUpdate widget (object pairs)++-- | Change the value of a field, without notifying the frontend. For internal use.+setField' :: (f ∈ WidgetFields w, IHaskellWidget (IPythonWidget w))+          => IPythonWidget w -> SField f -> FieldType f -> IO (Attr f)+setField' widget sfield val = do+  attr <- getAttr widget sfield+  newval <- _verify attr val+  let newattr = attr { _value = Real newval }+  modifyIORef (state widget) (WidgetState . rput newattr . _getState)+  return newattr++-- | Pluck an attribute from a record+getAttr :: (f ∈ WidgetFields w) => IPythonWidget w -> SField f -> IO (Attr f)+getAttr widget sfield = rget sfield <$> _getState <$> readIORef (state widget)++-- | Get the value of a field.+getField :: (f ∈ WidgetFields w) => IPythonWidget w -> SField f -> IO (FieldType f)+getField widget sfield = unwrap . _value <$> getAttr widget sfield++-- | Useful with toJSON and OverloadedStrings+str :: String -> String+str = id++properties :: IPythonWidget w -> IO ()+properties widget = do+  st <- readIORef $ state widget+  let convert :: Attr f -> Const Field f+      convert attr = Const { getConst = _field attr }+  mapM_ print $ recordToList . rmap convert . _getState $ st++-- Helper function for widget to enforce their inability to fetch console input+noStdin :: IO a -> IO ()+noStdin action =+  let handler :: IOException -> IO ()+      handler e = when (ioeGetErrorType e == InvalidArgument)+                    (error "Widgets cannot do console input, sorry :)")+  in Ex.handle handler $ do+    nullFd <- openFd "/dev/null" WriteOnly Nothing defaultFileFlags+    oldStdin <- dup stdInput+    void $ dupTo nullFd stdInput+    closeFd nullFd+    void action+    void $ dupTo oldStdin stdInput++-- Trigger events+triggerEvent :: (FieldType f ~ IO (), f ∈ WidgetFields w) => SField f -> IPythonWidget w -> IO ()+triggerEvent sfield w = noStdin . join $ getField w sfield++triggerChange :: (S.ChangeHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()+triggerChange = triggerEvent ChangeHandler++triggerClick :: (S.ClickHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()+triggerClick = triggerEvent ClickHandler++triggerSelection :: (S.SelectionHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()+triggerSelection = triggerEvent SelectionHandler++triggerSubmit :: (S.SubmitHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()+triggerSubmit = triggerEvent SubmitHandler++triggerDisplay :: (S.DisplayHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()+triggerDisplay = triggerEvent DisplayHandler