packages feed

ihaskell-widgets 0.2.3.3 → 0.4.0.0

raw patch · 66 files changed

+3730/−1411 lines, 66 filesdep +bytestringdep +singletons-base

Dependencies added: bytestring, singletons-base

Files

LICENSE view
@@ -1,4 +1,6 @@-Copyright (c) 2015 Sumit Sahrawat+The MIT License (MIT)++Copyright (c) 2021 David Davó  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the
MsgSpec.md view
@@ -1,7 +1,9 @@-# IPython widget messaging specification+# IPython widget messaging specification version 2 -> Largely based on: https://github.com/ipython/ipython/wiki/IPEP-23:-Backbone.js-Widgets+The model implemented is the Model State v8, for ipywidgets 7.4., @jupyter-widgets/base 1.1., and @jupyter-widgets/controls 1.4.*. +> Largely based on: https://github.com/jupyter-widgets/ipywidgets/blob/master/packages/schema/messages.md+ > The messaging specification as detailed is riddled with assumptions the IHaskell widget > implementation makes. It works for us, so it should work for everyone. @@ -14,37 +16,73 @@  > The comm should be opened with a `target_name` of `"ipython.widget"`. +> The comm_open message's metadata gives the version of the widget messaging protocol, i.e., `{'version': '2.0.0'}`+ 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 the ones representing-lengths in CSS units need to be sent as strings.--The initial state 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.+lengths in CSS units need to be sent as strings specifying the size unit (px,em,cm,etc.). -  - `_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`.+The initial state must *at least* have the following fields in the `data.state` value of the message: -  - `_css` (default value = empty list): A list of 3-tuples, (selector, key, value).+  - `_model_module`+  - `_model_module_version`+  - `_model_name`+  - `_view_module`+  - `_view_module_version`+  - `_view_name` -  - `visible` (default = True): Whether the widget is visible or not.+You can see more info on the model state of widgets [here](https://github.com/jupyter-widgets/ipywidgets/blob/master/packages/schema/jupyterwidgetmodels.v8.md), or as a json definition [here](https://github.com/jupyter-widgets/ipywidgets/blob/79312fb164e058c3a2fddd9f3ef35493515ed64b/packages/schema/jupyterwidgetmodels.latest.json) -  - Rest of the properties as required initially.+> Warning!: By default there are two widgets modules: `@jupyter-widgets/controls` and `@jupyter-widgets/base`.  This state is also used with fragments of the overall state to sync changes between the frontend and the kernel. +### Buffer paths+To display some widgets, we need to use the `buffer_paths`. It's only an array with arrays of keys on how to get to the fields that are to considered a+byte stream. For example, in an image widget, `buffer_paths` would be the array `[ ["value"] ]`, which means that `state.value` is a buffer path. The buffers are sent in the header of the message, just before the data, so the n-th buffer corresponds to the n-th buffer path in the array.++```json+"data": {+  "state": {+    "value": ...,+    ...+  },+  "buffer_paths": ["value"]+}+```+ ## 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.+message to the frontend on the widget's iopub, with a custom mimetype instead of text/plain. Since 5.0, all custom json metadata should be encoded as a json object, instead of as a serialized string. +The `version_major` and `version_minor` fields are the version number of the schema of this specific message+(currently in sync with the WMP version). However, only the `model_id` field is required to display the widget.++[Source](https://github.com/jupyter-widgets/ipywidgets/issues/3220)+ ```json-{-    "method": "display"+method = "display_data",+content = {+    "data": {+      "application/vnd.jupyter.widget-view+json": {+      "model_id": "u-u-i-d",+      "version_major": 2,+      "version_minor": 0,+    }+}+```++## Clear output messages+A simple message that indicates that the output of the header message id's should be cleaned.++- `wait=true` indicates that it should clean the output in the next append, while `wait=false` cleans the output inmediately.++```json+method = "clear_output",+content = {+  "wait": bool } ```
README.md view
@@ -5,3 +5,81 @@ the backend is implemented in haskell.  To know more about the widget messaging protocol, see [MsgSpec.md](MsgSpec.md).++## Contributing examples+If you want to contribute with more Notebook examples, please do so on the `Examples/`+folder. Before commiting, please make sure they can be executed sequentialy and+then remove the output from the Nootebooks with:++```bash+jupyter nbconvert *.ipynb --to notebook --inplace --clear-output+```++## Things to do+- [ ] Automatic validation of the JSON implementation of widgets against the MsgSpec schema+- [ ] Create integration tests for the widgets+- [ ] Make the output widget capture output (problem: you have to get the message id of where the output is displayed)+- [ ] Make the layout widget values more 'Haskelian': Instead of checking if the string is valid at runtime, make some types so it's checked at compile-time+- [ ] Create a serializable color data type instead of using `Maybe String`+- [ ] Overload setField so it can be used with `Maybes` or other wrapper types without having to put `Just` every time.+- [ ] Add some "utils" work:+    - [ ] Create media widget from file+    - [ ] Get the selected label from a selection value++## How to...+This is a mini-guide for developers that want to update to a more recent widgets specification, but without+dwelling into the deeps of the project++### Add a new attribute+If you want to add a new attribute you'll have to:+1. Create a new singleton in [Singletons.hs](./Singletons.hs) inside the type `data Field`.+2. Write the serialization key of the field as specified in the model (see [MsgSpec.md](./MsgSpec.md)) inside the `toKey` function at [Singletons.hs](./Singletons.hs)+3. Because we use the `singletons-th` library, you have to define an alias for the attribute at [Common.hs](./Common.hs) to be able to use it at run-time more easily.+4. Now you have to specify the type of the field. Edit the type family `Fieldtype` at [Types.hs](./Types.hs)++### Add an attribute to a widget+First you have to check if the attribute is only for one widget, or is from a common class. You can check it at [ipywidget's repo](https://github.com/jupyter-widgets/ipywidgets/tree/master/ipywidgets/widgets).++- If it's only for one widget:+    1. Edit the `type instance WidgetFields <WidgetNameType> = ...` at [Types.hs](./Types.hs), adding the new field to the field array.+    2. Modify the `mk<WidgetName>` at `Module/WidgetName.hs`, adding the default value of the attribute. If the widget doesn't have any attributes yet, you can check how to do it on other widgets.+- If it's for a common class:+    1. Edit the `type <ClassName> = ...` at [Types.hs](./Types.hs)+    2. Edit the `default<ClassName>Widget` function from the same file, adding the default value for that attribute.++> Some widgets receive messages from the frontend when a value is modified (such as sliders, text areas, buttons...). You'll have to modify the `comm` function instantiated from the class `IHaskellWidget`. You can find an example at [IntSlider.hs](./Int/BoundedInt/IntSlider.hs)++## FAQ+When using widgets in ihaskell, you'll encounter a lot of compilation errors. If you are not very familiar with Haskell, they can be a bit hard to decipher, this is a mini guide that will (hopefully) appear when you paste the error in Google.++### setField: No instance for...+You probably got this error when trying to use setField like this:++```+<interactive>:1:1: error:+    • No instance for (Data.Vinyl.Lens.RecElem+                         Data.Vinyl.Core.Rec+                         'ihaskell-widgets-0.3.0.0:IHaskell.Display.Widgets.Singletons.Index+                         'ihaskell-widgets-0.3.0.0:IHaskell.Display.Widgets.Singletons.Index+                         '[]+                         '[]+                         (Data.Vinyl.TypeLevel.RIndex 'ihaskell-widgets-0.3.0.0:IHaskell.Display.Widgets.Singletons.Index '[]))+        arising from a use of ‘setField’+    • In the expression: setField select Index 0+      In an equation for ‘it’: it = setField select Index 0+```++What this error means is that there is no field called `Index` for this particular widget. You can display on screen all+the fields available for a widget using `properties widget`.++### setField: Couldn't match expected type SField f with actual type++If you get an error like this, you probably forgot to put the field name in the second argument of `setField`.+```+<interactive>:1:25: error:+    • Couldn't match expected type ‘ihaskell-widgets-0.3.0.0:IHaskell.Display.Widgets.Singletons.SField f’ with actual type ‘[a0]’+    • In the second argument of ‘setField’, namely ‘["Apples", "Oranges", "Pears"]’+      In the expression: setField selectMultiple ["Apples", "Oranges", "Pears"]+      In an equation for ‘it’: it = setField selectMultiple ["Apples", "Oranges", "Pears"]+    • Relevant bindings include it :: ihaskell-widgets-0.3.0.0:IHaskell.Display.Widgets.Types.FieldType f -> IO () (bound at <interactive>:1:1)+```
ihaskell-widgets.cabal view
@@ -10,7 +10,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             0.2.3.3+version:             0.4.0.0  -- A short (one-line) description of the package. synopsis:            IPython standard widgets for IHaskell.@@ -28,15 +28,17 @@ license-file:        LICENSE  -- The package author(s).-author:              Sumit Sahrawat+author:              David Davó+                     Sumit Sahrawat  -- An email address to which users can send suggestions, bug reports, and -- patches.-maintainer:          Sumit Sahrawat <sumit.sahrawat.apm13@iitbhu.ac.in>,+maintainer:          David Davó <david@ddavo.me>+                     Sumit Sahrawat <sumit.sahrawat.apm13@iitbhu.ac.in>,                      Andrew Gibiansky <andrew.gibiansky@gmail.com>  -- A copyright notice.--- copyright:+copyright:           Copyright (c) 2021 David Davó  -- category: @@ -47,7 +49,7 @@ extra-source-files:  README.md, MsgSpec.md  -- Constraint on the version of Cabal needed to build this package.-cabal-version:       >=1.10+cabal-version:       1.16  library   ghc-options:         -Wall@@ -58,37 +60,66 @@   -- Modules exported by the library.   exposed-modules:     IHaskell.Display.Widgets                        IHaskell.Display.Widgets.Interactive+                       IHaskell.Display.Widgets.Layout    -- Modules included in this library but not exported.   other-modules:       IHaskell.Display.Widgets.Button+                       IHaskell.Display.Widgets.ColorPicker+                       IHaskell.Display.Widgets.DatePicker                        IHaskell.Display.Widgets.Box.Box+                       IHaskell.Display.Widgets.Box.GridBox+                       IHaskell.Display.Widgets.Box.HBox+                       IHaskell.Display.Widgets.Box.VBox                        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.Bool.Valid+                       IHaskell.Display.Widgets.Controller.Controller+                       IHaskell.Display.Widgets.Controller.ControllerAxis+                       IHaskell.Display.Widgets.Controller.ControllerButton                        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.BoundedInt.Play                        IHaskell.Display.Widgets.Int.BoundedIntRange.IntRangeSlider+                       IHaskell.Display.Widgets.Link.Link+                       IHaskell.Display.Widgets.Link.DirectionalLink                        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.BoundedFloat.FloatLogSlider                        IHaskell.Display.Widgets.Float.BoundedFloatRange.FloatRangeSlider-                       IHaskell.Display.Widgets.Image+                       IHaskell.Display.Widgets.Media.Audio+                       IHaskell.Display.Widgets.Media.Image+                       IHaskell.Display.Widgets.Media.Video                        IHaskell.Display.Widgets.Output                        IHaskell.Display.Widgets.Selection.Dropdown                        IHaskell.Display.Widgets.Selection.RadioButtons                        IHaskell.Display.Widgets.Selection.Select+                       IHaskell.Display.Widgets.Selection.SelectionSlider+                       IHaskell.Display.Widgets.Selection.SelectionRangeSlider                        IHaskell.Display.Widgets.Selection.ToggleButtons                        IHaskell.Display.Widgets.Selection.SelectMultiple+                       IHaskell.Display.Widgets.String.Combobox                        IHaskell.Display.Widgets.String.HTML+                       IHaskell.Display.Widgets.String.HTMLMath                        IHaskell.Display.Widgets.String.Label+                       IHaskell.Display.Widgets.String.Password                        IHaskell.Display.Widgets.String.Text                        IHaskell.Display.Widgets.String.TextArea+                       IHaskell.Display.Widgets.Style.ButtonStyle+                       IHaskell.Display.Widgets.Style.DescriptionStyle+                       IHaskell.Display.Widgets.Style.ProgressStyle+                       IHaskell.Display.Widgets.Style.SliderStyle+                       IHaskell.Display.Widgets.Style.ToggleButtonsStyle +                       IHaskell.Display.Widgets.Layout.Common+                       IHaskell.Display.Widgets.Layout.LayoutWidget+                       IHaskell.Display.Widgets.Layout.Types+                        IHaskell.Display.Widgets.Types                        IHaskell.Display.Widgets.Common                        IHaskell.Display.Widgets.Singletons@@ -98,6 +129,7 @@    build-depends:       aeson >=0.7                      , base >=4.9 && <5+                     , bytestring                      , containers >= 0.5                      , ipython-kernel >= 0.6.1.2                      , text >= 0.11@@ -111,6 +143,9 @@ 					 -- The singletons package version is locked to the compiler 					 -- so let cabal choose the right one.                      , singletons -any++  if impl (ghc >= 9.0)+    build-depends:     singletons-base -any    -- Directories containing source files.   hs-source-dirs:      src
src/IHaskell/Display/Widgets.hs view
@@ -1,8 +1,22 @@+{-|+Module      : ihaskell-widgets+Description : Jupyter Widgets implementation for the IHaskell kernel+Copyright   : (c) Sumit Shrawat, 2015+                  David Davó, 2021+License     : MIT+Maintainer  : david@ddavo.me+Stability   : experimental+-} module IHaskell.Display.Widgets (module X) where  import           IHaskell.Display.Widgets.Button as X+import           IHaskell.Display.Widgets.ColorPicker as X+import           IHaskell.Display.Widgets.DatePicker as X  import           IHaskell.Display.Widgets.Box.Box as X+import           IHaskell.Display.Widgets.Box.GridBox as X+import           IHaskell.Display.Widgets.Box.HBox as X+import           IHaskell.Display.Widgets.Box.VBox as X import           IHaskell.Display.Widgets.Box.SelectionContainer.Accordion as X import           IHaskell.Display.Widgets.Box.SelectionContainer.Tab as X @@ -10,34 +24,59 @@ import           IHaskell.Display.Widgets.Bool.ToggleButton as X import           IHaskell.Display.Widgets.Bool.Valid as X +import           IHaskell.Display.Widgets.Controller.Controller as X+import           IHaskell.Display.Widgets.Controller.ControllerAxis as X+import           IHaskell.Display.Widgets.Controller.ControllerButton 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.BoundedInt.Play as X import           IHaskell.Display.Widgets.Int.BoundedIntRange.IntRangeSlider as X +import           IHaskell.Display.Widgets.Link.Link as X+import           IHaskell.Display.Widgets.Link.DirectionalLink 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.BoundedFloat.FloatLogSlider as X import           IHaskell.Display.Widgets.Float.BoundedFloatRange.FloatRangeSlider as X -import           IHaskell.Display.Widgets.Image as X+import           IHaskell.Display.Widgets.Media.Audio as X+import           IHaskell.Display.Widgets.Media.Image as X+import           IHaskell.Display.Widgets.Media.Video 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.SelectionSlider as X+import           IHaskell.Display.Widgets.Selection.SelectionRangeSlider as X import           IHaskell.Display.Widgets.Selection.ToggleButtons as X import           IHaskell.Display.Widgets.Selection.SelectMultiple as X +import           IHaskell.Display.Widgets.String.Combobox as X import           IHaskell.Display.Widgets.String.HTML as X+import           IHaskell.Display.Widgets.String.HTMLMath as X import           IHaskell.Display.Widgets.String.Label as X+import           IHaskell.Display.Widgets.String.Password as X import           IHaskell.Display.Widgets.String.Text as X import           IHaskell.Display.Widgets.String.TextArea as X +import           IHaskell.Display.Widgets.Style.ButtonStyle as X+import           IHaskell.Display.Widgets.Style.DescriptionStyle as X+import           IHaskell.Display.Widgets.Style.ProgressStyle as X+import           IHaskell.Display.Widgets.Style.SliderStyle as X+import           IHaskell.Display.Widgets.Style.ToggleButtonsStyle as X+ import           IHaskell.Display.Widgets.Common as X import           IHaskell.Display.Widgets.Types as X (setField, getField, properties, triggerDisplay,                                                       triggerChange, triggerClick, triggerSelection,-                                                      triggerSubmit, ChildWidget(..))+                                                      triggerSubmit, ChildWidget(..), StyleWidget(..),+                                                      WidgetFieldPair(..), Date(..), unlink,+                                                      JSONByteString(..), OutputMsg(..))+
src/IHaskell/Display/Widgets/Bool/CheckBox.hs view
@@ -18,6 +18,7 @@ import           Control.Monad (void) import           Data.Aeson import           Data.IORef (newIORef)+import           Data.Vinyl (Rec(..), (<+>))  import           IHaskell.Display import           IHaskell.Eval.Widgets@@ -25,6 +26,8 @@  import           IHaskell.Display.Widgets.Types import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle  -- | A 'CheckBox' represents a Checkbox widget from IPython.html.widgets. type CheckBox = IPythonWidget 'CheckBoxType@@ -34,8 +37,13 @@ mkCheckBox = do   -- Default properties, with a random uuid   wid <- U.random+  layout <- mkLayout+  dstyle <- mkDescriptionStyle -  let widgetState = WidgetState $ defaultBoolWidget "CheckboxView" "CheckboxModel"+  let boolAttrs = defaultBoolWidget "CheckboxView" "CheckboxModel" layout $ StyleWidget dstyle+      checkBoxAttrs = (Indent =:: True)+                      :& RNil+      widgetState = WidgetState $ boolAttrs <+> checkBoxAttrs    stateIO <- newIORef widgetState @@ -47,15 +55,10 @@   -- 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 val _ =-    case nestedObjectLookup val ["sync_data", "value"] of+    case nestedObjectLookup val ["state", "value"] of       Just (Bool value) -> do         void $ setField' widget BoolValue value         triggerChange widget
src/IHaskell/Display/Widgets/Bool/ToggleButton.hs view
@@ -26,6 +26,8 @@  import           IHaskell.Display.Widgets.Types import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle  -- | A 'ToggleButton' represents a ToggleButton widget from IPython.html.widgets. type ToggleButton = IPythonWidget 'ToggleButtonType@@ -35,10 +37,11 @@ mkToggleButton = do   -- Default properties, with a random uuid   wid <- U.random+  layout <- mkLayout+  dstyle <- mkDescriptionStyle -  let boolState = defaultBoolWidget "ToggleButtonView" "ToggleButtonModel"-      toggleState = (Tooltip =:: "")-                    :& (Icon =:: "")+  let boolState = defaultBoolWidget "ToggleButtonView" "ToggleButtonModel" layout $ StyleWidget dstyle+      toggleState = (Icon =:: "")                     :& (ButtonStyle =:: DefaultButton)                     :& RNil       widgetState = WidgetState (boolState <+> toggleState)@@ -53,15 +56,10 @@   -- 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 val _ =-    case nestedObjectLookup val ["sync_data", "value"] of+    case nestedObjectLookup val ["state", "value"] of       Just (Bool value) -> do         void $ setField' widget BoolValue value         triggerChange widget
src/IHaskell/Display/Widgets/Bool/Valid.hs view
@@ -9,7 +9,7 @@   ( -- * The Valid Widget     ValidWidget     -- * Constructor-  , mkValidWidget+  , mkValid   ) where  -- To keep `cabal repl` happy when running from the ihaskell repo@@ -25,17 +25,21 @@  import           IHaskell.Display.Widgets.Types import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle  -- | A 'ValidWidget' represents a Valid widget from IPython.html.widgets. type ValidWidget = IPythonWidget 'ValidType  -- | Create a new output widget-mkValidWidget :: IO ValidWidget-mkValidWidget = do+mkValid :: IO ValidWidget+mkValid = do   -- Default properties, with a random uuid   wid <- U.random+  layout <- mkLayout+  dstyle <- mkDescriptionStyle -  let boolState = defaultBoolWidget "ValidView" "ValidModel"+  let boolState = defaultBoolWidget "ValidView" "ValidModel" layout $ StyleWidget dstyle       validState = (ReadOutMsg =:: "") :& RNil       widgetState = WidgetState $ boolState <+> validState @@ -48,11 +52,6 @@    -- Return the image widget   return widget--instance IHaskellDisplay ValidWidget where-  display b = do-    widgetSendView b-    return $ Display []  instance IHaskellWidget ValidWidget where   getCommUUID = uuid
src/IHaskell/Display/Widgets/Box/Box.hs view
@@ -23,6 +23,7 @@ import           IHaskell.IPython.Message.UUID as U  import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Layout.LayoutWidget  -- | A 'Box' represents a Box widget from IPython.html.widgets. type Box = IPythonWidget 'BoxType@@ -32,8 +33,9 @@ mkBox = do   -- Default properties, with a random uuid   wid <- U.random+  layout <- mkLayout -  let widgetState = WidgetState $ defaultBoxWidget "BoxView" "BoxModel"+  let widgetState = WidgetState $ defaultBoxWidget "BoxView" "BoxModel" layout    stateIO <- newIORef widgetState @@ -44,11 +46,6 @@    -- 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/GridBox.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans  #-}++module IHaskell.Display.Widgets.Box.GridBox+  ( -- * The GridBox widget+    GridBox+    -- * Constructor+  , mkGridBox+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Data.Aeson+import           Data.IORef (newIORef)++import           IHaskell.Display+import           IHaskell.Eval.Widgets+import           IHaskell.IPython.Message.UUID as U++import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Layout.LayoutWidget++-- | A 'GridBox' represents a GridBox widget from IPython.html.widgets.+type GridBox = IPythonWidget 'GridBoxType++-- | Create a new GridBox+mkGridBox :: IO GridBox+mkGridBox = do+  -- Default properties, with a random uuid+  wid <- U.random+  layout <- mkLayout++  let widgetState = WidgetState $ defaultBoxWidget "GridBoxView" "GridBoxModel" layout++  stateIO <- newIORef widgetState++  let gridBox = IPythonWidget wid stateIO++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen gridBox $ toJSON widgetState++  -- Return the widget+  return gridBox++instance IHaskellWidget GridBox where+  getCommUUID = uuid
+ src/IHaskell/Display/Widgets/Box/HBox.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans  #-}++module IHaskell.Display.Widgets.Box.HBox+  ( -- * The HBox widget+    HBox+    -- * Constructor+  , mkHBox+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Data.Aeson+import           Data.IORef (newIORef)++import           IHaskell.Display+import           IHaskell.Eval.Widgets+import           IHaskell.IPython.Message.UUID as U++import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Layout.LayoutWidget++-- | A 'HBox' represents a HBox widget from IPython.html.widgets.+type HBox = IPythonWidget 'HBoxType++-- | Create a new HBox+mkHBox :: IO HBox+mkHBox = do+  -- Default properties, with a random uuid+  wid <- U.random+  layout <- mkLayout++  let widgetState = WidgetState $ defaultBoxWidget "HBoxView" "HBoxModel" layout++  stateIO <- newIORef widgetState++  let hBox = IPythonWidget wid stateIO++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen hBox $ toJSON widgetState++  -- Return the widget+  return hBox++instance IHaskellWidget HBox where+  getCommUUID = uuid
src/IHaskell/Display/Widgets/Box/SelectionContainer/Accordion.hs view
@@ -26,6 +26,7 @@  import           IHaskell.Display.Widgets.Types import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget  -- | A 'Accordion' represents a Accordion widget from IPython.html.widgets. type Accordion = IPythonWidget 'AccordionType@@ -35,8 +36,9 @@ mkAccordion = do   -- Default properties, with a random uuid   wid <- U.random+  layout <- mkLayout -  let widgetState = WidgetState $ defaultSelectionContainerWidget "AccordionView" "AccordionModel"+  let widgetState = WidgetState $ defaultSelectionContainerWidget "AccordionView" "AccordionModel" layout    stateIO <- newIORef widgetState @@ -48,16 +50,14 @@   -- Return the widget   return box -instance IHaskellDisplay Accordion where-  display b = do-    widgetSendView b-    return $ Display []- instance IHaskellWidget Accordion where   getCommUUID = uuid   comm widget val _ =-    case nestedObjectLookup val ["sync_data", "selected_index"] of+    case nestedObjectLookup val ["state", "selected_index"] of       Just (Number num) -> do-        void $ setField' widget SelectedIndex (Sci.coefficient num)+        void $ setField' widget SelectedIndex $ Just (Sci.coefficient num)+        triggerChange widget+      Just Null -> do+        void $ setField' widget SelectedIndex Nothing         triggerChange widget       _ -> pure ()
src/IHaskell/Display/Widgets/Box/SelectionContainer/Tab.hs view
@@ -9,12 +9,14 @@   ( -- * The Tab widget     TabWidget     -- * Constructor-  , mkTabWidget+  , mkTab   ) where  -- To keep `cabal repl` happy when running from the ihaskell repo import           Prelude +import           Control.Monad (void)+ import           Data.Aeson import           Data.IORef (newIORef) import qualified Data.Scientific as Sci@@ -25,17 +27,19 @@  import           IHaskell.Display.Widgets.Types import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget  -- | A 'TabWidget' represents a Tab widget from IPython.html.widgets. type TabWidget = IPythonWidget 'TabType  -- | Create a new box-mkTabWidget :: IO TabWidget-mkTabWidget = do+mkTab :: IO TabWidget+mkTab = do   -- Default properties, with a random uuid   wid <- U.random+  layout <- mkLayout -  let widgetState = WidgetState $ defaultSelectionContainerWidget "TabView" "TabModel"+  let widgetState = WidgetState $ defaultSelectionContainerWidget "TabView" "TabModel" layout    stateIO <- newIORef widgetState @@ -47,16 +51,14 @@   -- Return the widget   return box -instance IHaskellDisplay TabWidget where-  display b = do-    widgetSendView b-    return $ Display []- instance IHaskellWidget TabWidget where   getCommUUID = uuid   comm widget val _ =-    case nestedObjectLookup val ["sync_data", "selected_index"] of+    case nestedObjectLookup val ["state", "selected_index"] of       Just (Number num) -> do-        _ <- setField' widget SelectedIndex (Sci.coefficient num)+        void $ setField' widget SelectedIndex $ Just (Sci.coefficient num)+        triggerChange widget+      Just Null -> do+        void $ setField' widget SelectedIndex Nothing         triggerChange widget       _ -> pure ()
+ src/IHaskell/Display/Widgets/Box/VBox.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans  #-}++module IHaskell.Display.Widgets.Box.VBox+  ( -- * The VBox widget+    VBox+    -- * Constructor+  , mkVBox+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Data.Aeson+import           Data.IORef (newIORef)++import           IHaskell.Display+import           IHaskell.Eval.Widgets+import           IHaskell.IPython.Message.UUID as U++import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Layout.LayoutWidget++-- | A 'VBox' represents a VBox widget from IPython.html.widgets.+type VBox = IPythonWidget 'VBoxType++-- | Create a new VBox+mkVBox :: IO VBox+mkVBox = do+  -- Default properties, with a random uuid+  wid <- U.random+  layout <- mkLayout++  let widgetState = WidgetState $ defaultBoxWidget "VBoxView" "VBoxModel" layout++  stateIO <- newIORef widgetState++  let vbox = IPythonWidget wid stateIO++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen vbox $ toJSON widgetState++  -- Return the widget+  return vbox++instance IHaskellWidget VBox where+  getCommUUID = uuid
src/IHaskell/Display/Widgets/Button.hs view
@@ -25,6 +25,8 @@  import           IHaskell.Display.Widgets.Types import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Style.ButtonStyle+import           IHaskell.Display.Widgets.Layout.LayoutWidget  -- | A 'Button' represents a Button from IPython.html.widgets. type Button = IPythonWidget 'ButtonType@@ -34,16 +36,16 @@ mkButton = do   -- Default properties, with a random uuid   wid <- U.random+  layout <- mkLayout+  btnstyle <- mkButtonStyle -  let dom = defaultDOMWidget "ButtonView" "ButtonModel"-      but = (Description =:: "")-            :& (Tooltip =:: "")-            :& (Disabled =:: False)+  let ddw = defaultDescriptionWidget "ButtonView" "ButtonModel" layout $ StyleWidget btnstyle+      but = (Disabled =:: False)             :& (Icon =:: "")             :& (ButtonStyle =:: DefaultButton)             :& (ClickHandler =:: return ())             :& RNil-      buttonState = WidgetState (dom <+> but)+      buttonState = WidgetState (ddw <+> but)    stateIO <- newIORef buttonState @@ -54,11 +56,6 @@    -- Return the button widget   return button--instance IHaskellDisplay Button where-  display b = do-    widgetSendView b-    return $ Display []  instance IHaskellWidget Button where   getCommUUID = uuid
+ src/IHaskell/Display/Widgets/ColorPicker.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans  #-}++module IHaskell.Display.Widgets.ColorPicker+  ( -- * The ColorPicker Widget+    ColorPicker+    -- * Create a new ColorPicker+  , mkColorPicker+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Data.Aeson+import           Data.IORef (newIORef)+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+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle++-- | A 'ColorPicker' represents a ColorPicker from IPython.html.widgets.+type ColorPicker = IPythonWidget 'ColorPickerType++-- | Create a new ColorPicker+mkColorPicker :: IO ColorPicker+mkColorPicker = do+  -- Default properties, with a random uuid+  wid <- U.random+  layout <- mkLayout+  dstyle <- mkDescriptionStyle++  let ddw = defaultDescriptionWidget "ColorPickerView" "ColorPickerModel" layout $ StyleWidget dstyle+      color = (StringValue =:: "black")+              :& (Concise =:: False)+              :& (Disabled =:: False)+              :& (ChangeHandler =:: return ())+              :& RNil+      colorPickerState = WidgetState (ddw <+> color)++  stateIO <- newIORef colorPickerState++  let colorPicker = IPythonWidget wid stateIO++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen colorPicker $ toJSON colorPickerState++  -- Return the ColorPicker widget+  return colorPicker++instance IHaskellWidget ColorPicker where+  getCommUUID = uuid+  comm widget val _ =+    case nestedObjectLookup val ["state", "value"] of+      Just o -> case fromJSON o of+        Success (String color) -> setField' widget StringValue color >> triggerChange widget+        _ -> pure ()+      _ -> pure ()
src/IHaskell/Display/Widgets/Common.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}  -- There are lots of pattern synpnyms, and little would be gained by adding -- the type signatures.@@ -16,7 +17,6 @@  import           Data.Aeson import           Data.Aeson.Types (emptyObject)-import           Data.HashMap.Strict as HM import           Data.Text (pack, Text) import           Data.Typeable (Typeable) @@ -25,123 +25,203 @@  import qualified IHaskell.Display.Widgets.Singletons as S +#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.Aeson.Key    as Key+#else+import           Data.HashMap.Strict as HM+#endif++-- | The view module string pattern ViewModule = S.SViewModule+-- | The view module version+pattern ViewModuleVersion = S.SViewModuleVersion+-- | The view name pattern ViewName = S.SViewName+-- | The model module string pattern ModelModule = S.SModelModule+-- | The model module version+pattern ModelModuleVersion = S.SModelModuleVersion+-- | The model name pattern ModelName = S.SModelName-pattern MsgThrottle = S.SMsgThrottle-pattern Version = S.SVersion+-- | A method to be called on display pattern DisplayHandler = S.SDisplayHandler-pattern Visible = S.SVisible-pattern CSS = S.SCSS+-- | CSS classes applied to widget DOM element pattern DOMClasses = S.SDOMClasses+-- | Reference to a Layout widget+pattern Layout = S.SLayout+-- | Width of the video/image in pixels pattern Width = S.SWidth+-- | Height of the video/image in pixels 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+-- | Description of the control pattern Description = S.SDescription+-- | Method to be called on click pattern ClickHandler = S.SClickHandler+-- | Method to be called on submit pattern SubmitHandler = S.SSubmitHandler+-- | Whether the widget appears as disabled on the frontend pattern Disabled = S.SDisabled+-- | The value of the widget, of type string pattern StringValue = S.SStringValue+-- | Placeholder text to display if nothing has been typed yet pattern Placeholder = S.SPlaceholder+-- | Tooltip for the description pattern Tooltip = S.STooltip+-- | The font-awesome icon without the fa- pattern Icon = S.SIcon+-- | Predefined styling for the button pattern ButtonStyle = S.SButtonStyle-pattern B64Value = S.SB64Value+-- | Value of the widget of type bytestring+pattern BSValue = S.SBSValue+-- | The format of the image pattern ImageFormat = S.SImageFormat+-- | The value of the widget of type bool pattern BoolValue = S.SBoolValue-pattern Options = S.SOptions-pattern SelectedLabel = S.SSelectedLabel-pattern SelectedValue = S.SSelectedValue+-- | The labels for the options+pattern OptionsLabels = S.SOptionsLabels+-- | Selected index, can be Nothing+pattern OptionalIndex = S.SOptionalIndex+-- | The index of the controller+pattern Index = S.SIndex+-- | Method to be called when something is chosen pattern SelectionHandler = S.SSelectionHandler+-- | Tooltips for each button pattern Tooltips = S.STooltips+-- | Icons names for each button (FontAwesome names without the fa- prefix) pattern Icons = S.SIcons-pattern SelectedLabels = S.SSelectedLabels-pattern SelectedValues = S.SSelectedValues+-- | Selected indices+pattern Indices = S.SIndices+-- | The value of the widget of type int pattern IntValue = S.SIntValue+-- | Minimum step to increment the value pattern StepInt = S.SStepInt+-- | Max value pattern MaxInt = S.SMaxInt+-- | Min value pattern MinInt = S.SMinInt+-- | The value of the widget as an int pair pattern IntPairValue = S.SIntPairValue+-- | Min value on a range widget pattern LowerInt = S.SLowerInt+-- | Max value on a range widget pattern UpperInt = S.SUpperInt+-- | Value of the widget (float) pattern FloatValue = S.SFloatValue+-- | Minimum step to increment the value pattern StepFloat = S.SStepFloat+-- | Max value pattern MaxFloat = S.SMaxFloat+-- | Min value pattern MinFloat = S.SMinFloat+-- | Value of the widget as a float pair pattern FloatPairValue = S.SFloatPairValue+-- | Min value of a range widget pattern LowerFloat = S.SLowerFloat+-- | Max value of a range widget pattern UpperFloat = S.SUpperFloat+-- | Orientation of the widget pattern Orientation = S.SOrientation-pattern ShowRange = S.SShowRange+-- | The logarithmic base of the widget+pattern BaseFloat = S.SBaseFloat+-- | Whether to display the current value of the widget next to it pattern ReadOut = S.SReadOut-pattern SliderColor = S.SSliderColor+-- | The format of the readout+pattern ReadOutFormat = S.SReadOutFormat+-- | Use a predefined styling for the bar pattern BarStyle = S.SBarStyle+-- | A method called when the value changes in the fronted pattern ChangeHandler = S.SChangeHandler+-- | List of widget children pattern Children = S.SChildren-pattern OverflowX = S.SOverflowX-pattern OverflowY = S.SOverflowY+-- | Use a predefined styling for the box pattern BoxStyle = S.SBoxStyle-pattern Flex = S.SFlex-pattern Pack = S.SPack-pattern Align = S.SAlign+-- | Titles of the pages pattern Titles = S.STitles+-- | The index of the selected page. Is nothing if no widgets are selected. pattern SelectedIndex = S.SSelectedIndex+-- | Message displayed when the value is false pattern ReadOutMsg = S.SReadOutMsg-pattern Child = S.SChild-pattern Selector = S.SSelector+-- | Indent the control to align with other controls with a description+pattern Indent = S.SIndent+-- | Update the value as the user types. If false, update on submission.+pattern ContinuousUpdate = S.SContinuousUpdate+-- | The number of rows to display+pattern Rows = S.SRows+-- | The format of the audio+pattern AudioFormat = S.SAudioFormat+-- | The format of the image+pattern VideoFormat = S.SVideoFormat+-- | When true, the video starts on display+pattern AutoPlay = S.SAutoPlay+-- | When true, the video starts from the beginning after finishing+pattern Loop = S.SLoop+-- | Specifies that video controls should be displayed+pattern Controls = S.SControls+-- | Dropdown options for the combobox+pattern Options = S.SOptions+-- | If set, ensure the value is in options+pattern EnsureOption = S.SEnsureOption+-- | Whether the control is currently playing+pattern Playing = S.SPlaying+-- | Whether the control will repeat in a continuous loop+pattern Repeat = S.SRepeat+-- | The maximum interval for the play control+pattern Interval = S.SInterval+-- | Show the repeat toggle button on the widget+pattern ShowRepeat = S.SShowRepeat+-- | Display the short version of the selector+pattern Concise = S.SConcise+-- | The value of the widget in date format+pattern DateValue = S.SDateValue+-- | Whether the button is pressed+pattern Pressed = S.SPressed+-- | The name of the controller+pattern Name = S.SName+-- | The name of the control mapping+pattern Mapping = S.SMapping+-- | Whether the gamepad is connected+pattern Connected = S.SConnected+-- | The last time the data from this gamepad was updated+pattern Timestamp = S.STimestamp+-- | The button widgets on the gamepad+pattern Buttons = S.SButtons+-- | The axes on the gamepad+pattern Axes = S.SAxes+-- | Color of the button+pattern ButtonColor = S.SButtonColor+-- | The font weight of the text+pattern FontWeight = S.SFontWeight+-- | Width of the description to the side of the control+pattern DescriptionWidth = S.SDescriptionWidth+-- | Color of the progress bar+pattern BarColor = S.SBarColor+-- | Color of the slider handle+pattern HandleColor = S.SHandleColor+-- | The width of each button+pattern ButtonWidth = S.SButtonWidth+-- | The target (widget,field) pair+pattern Target = S.STarget+-- | The source (widget,field) pair+pattern Source = S.SSource+-- | Parent message id of messages to capture+pattern MsgID = S.SMsgID+-- | The output messages synced from the frontend+pattern Outputs = S.SOutputs+-- | Reference to a Style widget with styling customizations+pattern Style = S.SStyle  -- | Close a widget's comm closeWidget :: IHaskellWidget w => w -> IO () closeWidget w = widgetSendClose w emptyObject +-- | Transforms the Integer to a String of pixels newtype PixCount = PixCount Integer   deriving (Num, Ord, Eq, Enum, Typeable)  instance ToJSON PixCount where   toJSON (PixCount x) = toJSON . pack $ show x ++ "px" --- | 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@@ -206,24 +286,53 @@   toJSON DangerBar = "danger"   toJSON DefaultBar = "" +-- | Audio formats for AudioWidget+data AudioFormatValue = MP3+                      | OGG+                      | WAV+                      | AURL+  deriving (Eq, Typeable)++instance Show AudioFormatValue where+  show MP3 = "mp3"+  show OGG = "ogg"+  show WAV = "wav"+  show AURL = "url"++instance ToJSON AudioFormatValue where+  toJSON = toJSON . pack . show+ -- | Image formats for ImageWidget data ImageFormatValue = PNG                       | SVG                       | JPG+                      | IURL   deriving (Eq, Typeable) +-- | Image formats for ImageWidget instance Show ImageFormatValue where   show PNG = "png"   show SVG = "svg"   show JPG = "jpg"+  show IURL = "url"  instance ToJSON ImageFormatValue where   toJSON = toJSON . pack . show --- | Options for selection widgets.-data SelectionOptions = OptionLabels [Text]-                      | OptionDict [(Text, Text)]+-- | Video formats for VideoWidget+data VideoFormatValue = MP4+                      | WEBM+                      | VURL+  deriving (Eq, Typeable) +instance Show VideoFormatValue where+  show MP4 = "mp4"+  show WEBM = "webm"+  show VURL = "url"++instance ToJSON VideoFormatValue where+  toJSON = toJSON . pack . show+ -- | Orientation values. data OrientationValue = HorizontalOrientation                       | VerticalOrientation@@ -232,23 +341,7 @@   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 = ""-+-- | Predefined styles for box widgets data BoxStyleValue = SuccessBox                    | InfoBox                    | WarningBox@@ -262,23 +355,15 @@   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"- -- Could use 'lens-aeson' here but this is easier to read.+-- | Makes a lookup on a value given a path of strings to follow nestedObjectLookup :: Value -> [Text] -> Maybe Value nestedObjectLookup val [] = Just val nestedObjectLookup val (x:xs) =   case val of-    Object o -> maybe Nothing (`nestedObjectLookup` xs) $ HM.lookup x o+#if MIN_VERSION_aeson(2,0,0)+    Object o -> (`nestedObjectLookup` xs) =<< KeyMap.lookup (Key.fromText x) o+#else+    Object o -> (`nestedObjectLookup` xs) =<< HM.lookup x o+#endif     _ -> Nothing
+ src/IHaskell/Display/Widgets/Controller/Controller.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans  #-}++module IHaskell.Display.Widgets.Controller.Controller+  ( -- * The Controller Widget+    Controller+    -- * Constructor+  , mkController+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Control.Monad (void)++import           Data.Aeson+import           Data.Aeson.Types (parse)+import           Data.IORef (newIORef)+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+import           IHaskell.Display.Widgets.Layout.LayoutWidget++-- | 'Controller' represents an Controller widget from IPython.html.widgets.+type Controller = IPythonWidget 'ControllerType++-- | Create a new widget+mkController :: IO Controller+mkController = do+  -- Default properties, with a random uuid+  wid <- U.random+  layout <- mkLayout++  let domAttrs = defaultCoreWidget <+> defaultDOMWidget "ControllerView" "ControllerModel" layout+      ctrlAttrs = (Index =:+ 0)+                  :& (Name =:! "")+                  :& (Mapping =:! "")+                  :& (Connected =:! False)+                  :& (Timestamp =:! 0.0)+                  :& (Buttons =:! [])+                  :& (Axes =:! [])+                  :& (ChangeHandler =:: pure ())+                  :& RNil+      widgetState = WidgetState $ domAttrs <+> ctrlAttrs++  stateIO <- newIORef widgetState++  let widget = IPythonWidget wid stateIO++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen widget $ toJSON widgetState++  -- Return the widget+  return widget++instance IHaskellWidget Controller where+  getCommUUID = uuid+  comm widget val _ =+    case nestedObjectLookup val ["state"] of+        Just (Object o) -> do+            parseAndSet Name "name"+            parseAndSet Mapping "mapping"+            parseAndSet Connected "connected"+            parseAndSet Timestamp "timestamp"+            triggerChange widget+            where parseAndSet f s = case parse (.: s) o of+                    Success x -> void $ setField' widget f x+                    _ -> pure ()+        _ -> pure ()
+ src/IHaskell/Display/Widgets/Controller/ControllerAxis.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans  #-}++module IHaskell.Display.Widgets.Controller.ControllerAxis+  ( -- * The ControllerAxis Widget+    ControllerAxis+    -- * Constructor+  , mkControllerAxis+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Data.Aeson+import           Data.IORef (newIORef)+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+import           IHaskell.Display.Widgets.Layout.LayoutWidget++-- | 'ControllerAxis' represents an ControllerAxis widget from IPython.html.widgets.+type ControllerAxis = IPythonWidget 'ControllerAxisType++-- | Create a new widget+mkControllerAxis :: IO ControllerAxis+mkControllerAxis = do+  -- Default properties, with a random uuid+  wid <- U.random+  layout <- mkLayout++  let domAttrs = defaultCoreWidget <+> defaultDOMWidget "ControllerAxisView" "ControllerAxisModel" layout+      axisAttrs = (FloatValue =:! 0.0)+                  :& (ChangeHandler =:: pure ())+                  :& RNil+      widgetState = WidgetState $ domAttrs <+> axisAttrs++  stateIO <- newIORef widgetState++  let widget = IPythonWidget wid stateIO++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen widget $ toJSON widgetState++  -- Return the widget+  return widget++instance IHaskellWidget ControllerAxis where+  getCommUUID = uuid
+ src/IHaskell/Display/Widgets/Controller/ControllerButton.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans  #-}++module IHaskell.Display.Widgets.Controller.ControllerButton+  ( -- * The ControllerButton Widget+    ControllerButton+    -- * Constructor+  , mkControllerButton+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Data.Aeson+import           Data.IORef (newIORef)+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+import           IHaskell.Display.Widgets.Layout.LayoutWidget++-- | 'ControllerButton' represents an ControllerButton widget from IPython.html.widgets.+type ControllerButton = IPythonWidget 'ControllerButtonType++-- | Create a new widget+mkControllerButton :: IO ControllerButton+mkControllerButton = do+  -- Default properties, with a random uuid+  wid <- U.random+  layout <- mkLayout++  let domAttrs = defaultCoreWidget <+> defaultDOMWidget "ControllerButtonView" "ControllerButtonModel" layout+      btnAttrs = (FloatValue =:! 0.0)+                 :& (Pressed =:! False)+                 :& (ChangeHandler =:: pure ())+                 :& RNil+      widgetState = WidgetState $ domAttrs <+> btnAttrs++  stateIO <- newIORef widgetState++  let widget = IPythonWidget wid stateIO++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen widget $ toJSON widgetState++  -- Return the widget+  return widget++instance IHaskellWidget ControllerButton where+  getCommUUID = uuid
+ src/IHaskell/Display/Widgets/DatePicker.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans  #-}++module IHaskell.Display.Widgets.DatePicker+  ( -- * The DatePicker Widget+    DatePicker+    -- * Create a new DatePicker+  , mkDatePicker+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Data.Aeson+import           Data.IORef (newIORef)+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+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle++-- | A 'DatePicker' represents a DatePicker from IPython.html.widgets.+type DatePicker = IPythonWidget 'DatePickerType++-- | Create a new DatePicker+mkDatePicker :: IO DatePicker+mkDatePicker = do+  -- Default properties, with a random uuid+  wid <- U.random+  layout <- mkLayout+  dstyle <- mkDescriptionStyle++  let ddw = defaultDescriptionWidget "DatePickerView" "DatePickerModel" layout $ StyleWidget dstyle+      date = (DateValue =:: defaultDate)+              :& (Disabled =:: False)+              :& (ChangeHandler =:: return ())+              :& RNil+      datePickerState = WidgetState (ddw <+> date)++  stateIO <- newIORef datePickerState++  let datePicker = IPythonWidget wid stateIO++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen datePicker $ toJSON datePickerState++  -- Return the DatePicker widget+  return datePicker++instance IHaskellWidget DatePicker where+  getCommUUID = uuid+  comm widget val _ =+    case nestedObjectLookup val ["state", "value"] of+      Just o -> case fromJSON o of+        Success date -> setField' widget DateValue date >> triggerChange widget+        _ -> pure ()+      _ -> pure ()
src/IHaskell/Display/Widgets/Float/BoundedFloat/BoundedFloatText.hs view
@@ -19,6 +19,7 @@ import           Data.Aeson import           Data.IORef (newIORef) import qualified Data.Scientific as Sci+import           Data.Vinyl (Rec(..), (<+>))  import           IHaskell.Display import           IHaskell.Eval.Widgets@@ -26,6 +27,8 @@  import           IHaskell.Display.Widgets.Types import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle  -- | 'BoundedFloatText' represents an BoundedFloatText widget from IPython.html.widgets. type BoundedFloatText = IPythonWidget 'BoundedFloatTextType@@ -35,8 +38,15 @@ mkBoundedFloatText = do   -- Default properties, with a random uuid   wid <- U.random+  layout <- mkLayout+  dstyle <- mkDescriptionStyle -  let widgetState = WidgetState $ defaultBoundedFloatWidget "FloatTextView" "FloatTextModel"+  let boundedFloatAttrs = defaultBoundedFloatWidget "FloatTextView" "BoundedFloatTextModel" layout $ StyleWidget dstyle+      textAttrs = (Disabled =:: False)+                  :& (ContinuousUpdate =:: False)+                  :& (StepFloat =:: Nothing)+                  :& RNil+      widgetState = WidgetState $ boundedFloatAttrs <+> textAttrs    stateIO <- newIORef widgetState @@ -48,15 +58,10 @@   -- Return the widget   return widget -instance IHaskellDisplay BoundedFloatText where-  display b = do-    widgetSendView b-    return $ Display []- instance IHaskellWidget BoundedFloatText where   getCommUUID = uuid   comm widget val _ =-    case nestedObjectLookup val ["sync_data", "value"] of+    case nestedObjectLookup val ["state", "value"] of       Just (Number value) -> do         void $ setField' widget FloatValue (Sci.toRealFloat value)         triggerChange widget
+ src/IHaskell/Display/Widgets/Float/BoundedFloat/FloatLogSlider.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans  #-}++module IHaskell.Display.Widgets.Float.BoundedFloat.FloatLogSlider+  ( -- * The FloatSlider Widget+    FloatLogSlider+    -- * Constructor+  , mkFloatLogSlider+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Control.Monad (void)+import           Data.Aeson+import           Data.IORef (newIORef)+import qualified Data.Scientific as Sci+import           Data.Vinyl (Rec(..), (<+>))++import           IHaskell.Display+import           IHaskell.Eval.Widgets+import           IHaskell.IPython.Message.UUID as U++import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle++-- | 'FloatLogSlider' represents an FloatLogSlider widget from IPython.html.widgets.+type FloatLogSlider = IPythonWidget 'FloatLogSliderType++-- | Create a new widget+mkFloatLogSlider :: IO FloatLogSlider+mkFloatLogSlider = do+  -- Default properties, with a random uuid+  wid <- U.random+  layout <- mkLayout+  dstyle <- mkDescriptionStyle++  let boundedLogFloatAttrs = defaultBoundedLogFloatWidget "FloatLogSliderView" "FloatLogSliderModel" layout $ StyleWidget dstyle+      sliderAttrs = (StepFloat =:: Just 0.1)+                    :& (Orientation =:: HorizontalOrientation)+                    :& (ReadOut =:: True)+                    :& (ReadOutFormat =:: ".3g")+                    :& (ContinuousUpdate =:: True)+                    :& (Disabled =:: False)+                    :& (BaseFloat =:: 10.0)+                    :& RNil+      widgetState = WidgetState $ boundedLogFloatAttrs <+> sliderAttrs++  stateIO <- newIORef widgetState++  let widget = IPythonWidget wid stateIO++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen widget $ toJSON widgetState++  -- Return the widget+  return widget++instance IHaskellWidget FloatLogSlider where+  getCommUUID = uuid+  comm widget val _ =+    case nestedObjectLookup val ["state", "value"] of+      Just (Number value) -> do+        void $ setField' widget FloatValue (Sci.toRealFloat value)+        triggerChange widget+      _ -> pure ()
src/IHaskell/Display/Widgets/Float/BoundedFloat/FloatProgress.hs view
@@ -25,6 +25,8 @@  import           IHaskell.Display.Widgets.Types import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.ProgressStyle  -- | 'FloatProgress' represents an FloatProgress widget from IPython.html.widgets. type FloatProgress = IPythonWidget 'FloatProgressType@@ -34,8 +36,10 @@ mkFloatProgress = do   -- Default properties, with a random uuid   wid <- U.random+  layout <- mkLayout+  pstyle <- mkProgressStyle -  let boundedFloatAttrs = defaultBoundedFloatWidget "ProgressView" "ProgressModel"+  let boundedFloatAttrs = defaultBoundedFloatWidget "ProgressView" "FloatProgressModel" layout $ StyleWidget pstyle       progressAttrs = (Orientation =:: HorizontalOrientation)                       :& (BarStyle =:: DefaultBar)                       :& RNil@@ -50,11 +54,6 @@    -- 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
@@ -27,6 +27,8 @@  import           IHaskell.Display.Widgets.Types import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle  -- | 'FloatSlider' represents an FloatSlider widget from IPython.html.widgets. type FloatSlider = IPythonWidget 'FloatSliderType@@ -36,12 +38,16 @@ mkFloatSlider = do   -- Default properties, with a random uuid   wid <- U.random+  layout <- mkLayout+  dstyle <- mkDescriptionStyle -  let boundedFloatAttrs = defaultBoundedFloatWidget "FloatSliderView" "FloatSliderModel"-      sliderAttrs = (Orientation =:: HorizontalOrientation)-                    :& (ShowRange =:: False)+  let boundedFloatAttrs = defaultBoundedFloatWidget "FloatSliderView" "FloatSliderModel" layout $ StyleWidget dstyle+      sliderAttrs = (StepFloat =:: Just 0.1)+                    :& (Orientation =:: HorizontalOrientation)                     :& (ReadOut =:: True)-                    :& (SliderColor =:: "")+                    :& (ReadOutFormat =:: ".2f")+                    :& (ContinuousUpdate =:: True)+                    :& (Disabled =:: False)                     :& RNil       widgetState = WidgetState $ boundedFloatAttrs <+> sliderAttrs @@ -55,15 +61,10 @@   -- Return the widget   return widget -instance IHaskellDisplay FloatSlider where-  display b = do-    widgetSendView b-    return $ Display []- instance IHaskellWidget FloatSlider where   getCommUUID = uuid   comm widget val _ =-    case nestedObjectLookup val ["sync_data", "value"] of+    case nestedObjectLookup val ["state", "value"] of       Just (Number value) -> do         void $ setField' widget FloatValue (Sci.toRealFloat value)         triggerChange widget
src/IHaskell/Display/Widgets/Float/BoundedFloatRange/FloatRangeSlider.hs view
@@ -28,6 +28,8 @@  import           IHaskell.Display.Widgets.Types import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle  -- | 'FloatRangeSlider' represents an FloatRangeSlider widget from IPython.html.widgets. type FloatRangeSlider = IPythonWidget 'FloatRangeSliderType@@ -37,12 +39,16 @@ mkFloatRangeSlider = do   -- Default properties, with a random uuid   wid <- U.random+  layout <- mkLayout+  dstyle <- mkDescriptionStyle -  let boundedFloatAttrs = defaultBoundedFloatRangeWidget "FloatSliderView" "FloatSliderModel"-      sliderAttrs = (Orientation =:: HorizontalOrientation)-                    :& (ShowRange =:: True)+  let boundedFloatAttrs = defaultBoundedFloatRangeWidget "FloatRangeSliderView" "FloatRangeSliderModel" layout $ StyleWidget dstyle+      sliderAttrs = (StepFloat =:: Just 0.1)+                    :& (Orientation =:: HorizontalOrientation)                     :& (ReadOut =:: True)-                    :& (SliderColor =:: "")+                    :& (ReadOutFormat =:: ".2f")+                    :& (ContinuousUpdate =:: True)+                    :& (Disabled =:: False)                     :& RNil       widgetState = WidgetState $ boundedFloatAttrs <+> sliderAttrs @@ -56,15 +62,10 @@   -- Return the widget   return widget -instance IHaskellDisplay FloatRangeSlider where-  display b = do-    widgetSendView b-    return $ Display []- instance IHaskellWidget FloatRangeSlider where   getCommUUID = uuid   comm widget val _ =-    case nestedObjectLookup val ["sync_data", "value"] of+    case nestedObjectLookup val ["state", "value"] of       Just (Array values) ->         case map (\(Number x) -> Sci.toRealFloat x) $ V.toList values of           [x, y] -> do
src/IHaskell/Display/Widgets/Float/FloatText.hs view
@@ -19,6 +19,7 @@ import           Data.Aeson import           Data.IORef (newIORef) import qualified Data.Scientific as Sci+import           Data.Vinyl (Rec(..), (<+>))  import           IHaskell.Display import           IHaskell.Eval.Widgets@@ -26,6 +27,8 @@  import           IHaskell.Display.Widgets.Types import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle  -- | 'FloatText' represents an FloatText widget from IPython.html.widgets. type FloatText = IPythonWidget 'FloatTextType@@ -35,8 +38,15 @@ mkFloatText = do   -- Default properties, with a random uuid   wid <- U.random+  layout <- mkLayout+  dstyle <- mkDescriptionStyle -  let widgetState = WidgetState $ defaultFloatWidget "FloatTextView" "FloatTextModel"+  let floatAttrs = defaultFloatWidget "FloatTextView" "FloatTextModel" layout $ StyleWidget dstyle+      textAttrs = (Disabled =:: False)+                  :& (ContinuousUpdate =:: False)+                  :& (StepFloat =:: Nothing)+                  :& RNil+      widgetState = WidgetState $ floatAttrs <+> textAttrs    stateIO <- newIORef widgetState @@ -48,15 +58,10 @@   -- Return the widget   return widget -instance IHaskellDisplay FloatText where-  display b = do-    widgetSendView b-    return $ Display []- instance IHaskellWidget FloatText where   getCommUUID = uuid   comm widget val _ =-    case nestedObjectLookup val ["sync_data", "value"] of+    case nestedObjectLookup val ["state", "value"] of       Just (Number value) -> do         void $ setField' widget FloatValue (Sci.toRealFloat value)         triggerChange widget
− src/IHaskell/Display/Widgets/Image.hs 
@@ -1,63 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeSynonymInstances #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--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           Data.Aeson-import           Data.IORef (newIORef)-import           Data.Monoid (mempty)-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-  wid <- U.random--  let dom = defaultDOMWidget "ImageView" "ImageModel"-      img = (ImageFormat =:: PNG)-            :& (Width =:+ 0)-            :& (Height =:+ 0)-            :& (B64Value =:: mempty)-            :& RNil-      widgetState = WidgetState (dom <+> img)--  stateIO <- newIORef widgetState--  let widget = IPythonWidget wid stateIO--  -- Open a comm for this widget, and store it in the kernel state-  widgetSendOpen widget $ toJSON widgetState--  -- Return the 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
@@ -19,6 +19,7 @@ import           Data.Aeson import           Data.IORef (newIORef) import qualified Data.Scientific as Sci+import           Data.Vinyl (Rec(..), (<+>))  import           IHaskell.Display import           IHaskell.Eval.Widgets@@ -26,6 +27,8 @@  import           IHaskell.Display.Widgets.Types import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle  -- | 'BoundedIntText' represents an BoundedIntText widget from IPython.html.widgets. type BoundedIntText = IPythonWidget 'BoundedIntTextType@@ -35,8 +38,15 @@ mkBoundedIntText = do   -- Default properties, with a random uuid   wid <- U.random+  layout <- mkLayout+  dstyle <- mkDescriptionStyle -  let widgetState = WidgetState $ defaultBoundedIntWidget "IntTextView" "IntTextModel"+  let boundedIntAttrs = defaultBoundedIntWidget "IntTextView" "BoundedIntTextModel" layout $ StyleWidget dstyle+      textAttrs = (Disabled =:: False)+                  :& (ContinuousUpdate =:: False)+                  :& (StepInt =:: Just 1)+                  :& RNil+      widgetState = WidgetState $ boundedIntAttrs <+> textAttrs    stateIO <- newIORef widgetState @@ -48,15 +58,10 @@   -- Return the widget   return widget -instance IHaskellDisplay BoundedIntText where-  display b = do-    widgetSendView b-    return $ Display []- instance IHaskellWidget BoundedIntText where   getCommUUID = uuid   comm widget val _ =-    case nestedObjectLookup val ["sync_data", "value"] of+    case nestedObjectLookup val ["state", "value"] of       Just (Number value) -> do         void $ setField' widget IntValue (Sci.coefficient value)         triggerChange widget
src/IHaskell/Display/Widgets/Int/BoundedInt/IntProgress.hs view
@@ -25,6 +25,8 @@  import           IHaskell.Display.Widgets.Types import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle  -- | 'IntProgress' represents an IntProgress widget from IPython.html.widgets. type IntProgress = IPythonWidget 'IntProgressType@@ -34,8 +36,10 @@ mkIntProgress = do   -- Default properties, with a random uuid   wid <- U.random+  layout <- mkLayout+  dstyle <- mkDescriptionStyle -  let boundedIntAttrs = defaultBoundedIntWidget "ProgressView" "ProgressModel"+  let boundedIntAttrs = defaultBoundedIntWidget "ProgressView" "IntProgressModel" layout $ StyleWidget dstyle       progressAttrs = (Orientation =:: HorizontalOrientation)                       :& (BarStyle =:: DefaultBar)                       :& RNil@@ -50,11 +54,6 @@    -- 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
@@ -21,12 +21,14 @@ import qualified Data.Scientific as Sci import           Data.Vinyl (Rec(..), (<+>)) -import           IHaskell.Display import           IHaskell.Eval.Widgets import           IHaskell.IPython.Message.UUID as U +import           IHaskell.Display (IHaskellWidget(..)) import           IHaskell.Display.Widgets.Types import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle  -- | 'IntSlider' represents an IntSlider widget from IPython.html.widgets. type IntSlider = IPythonWidget 'IntSliderType@@ -36,12 +38,16 @@ mkIntSlider = do   -- Default properties, with a random uuid   wid <- U.random+  layout <- mkLayout+  dstyle <- mkDescriptionStyle -  let boundedIntAttrs = defaultBoundedIntWidget "IntSliderView" "IntSliderModel"-      sliderAttrs = (Orientation =:: HorizontalOrientation)-                    :& (ShowRange =:: False)+  let boundedIntAttrs = defaultBoundedIntWidget "IntSliderView" "IntSliderModel" layout $ StyleWidget dstyle+      sliderAttrs = (StepInt =:: Just 1)+                    :& (Orientation =:: HorizontalOrientation)                     :& (ReadOut =:: True)-                    :& (SliderColor =:: "")+                    :& (ReadOutFormat =:: "d")+                    :& (ContinuousUpdate =:: True)+                    :& (Disabled =:: False)                     :& RNil       widgetState = WidgetState $ boundedIntAttrs <+> sliderAttrs @@ -55,15 +61,10 @@   -- Return the widget   return widget -instance IHaskellDisplay IntSlider where-  display b = do-    widgetSendView b-    return $ Display []- instance IHaskellWidget IntSlider where   getCommUUID = uuid   comm widget val _ =-    case nestedObjectLookup val ["sync_data", "value"] of+    case nestedObjectLookup val ["state", "value"] of       Just (Number value) -> do         void $ setField' widget IntValue (Sci.coefficient value)         triggerChange widget
+ src/IHaskell/Display/Widgets/Int/BoundedInt/Play.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans  #-}++module IHaskell.Display.Widgets.Int.BoundedInt.Play+  ( -- * The Play Widget+    Play+    -- * Constructor+  , mkPlay+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Control.Monad (void)+import           Data.Aeson+import           Data.IORef (newIORef)+import qualified Data.Scientific as Sci+import           Data.Vinyl (Rec(..), (<+>))++import           IHaskell.Eval.Widgets+import           IHaskell.IPython.Message.UUID as U++import           IHaskell.Display (IHaskellWidget(..))+import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle++-- | 'Play' represents an Play widget from IPython.html.widgets.+type Play = IPythonWidget 'PlayType++-- | Create a new widget+mkPlay :: IO Play+mkPlay = do+  -- Default properties, with a random uuid+  wid <- U.random+  layout <- mkLayout+  dstyle <- mkDescriptionStyle++  let boundedIntAttrs = defaultBoundedIntWidget "PlayView" "PlayModel" layout $ StyleWidget dstyle+      playAttrs = (Playing =:: True)+                  :& (Repeat =:: True)+                  :& (Interval =:: 100)+                  :& (StepInt =:: Just 1)+                  :& (Disabled =:: False)+                  :& (ShowRepeat =:: True)+                  :& RNil+      widgetState = WidgetState $ boundedIntAttrs <+> playAttrs++  stateIO <- newIORef widgetState++  let widget = IPythonWidget wid stateIO++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen widget $ toJSON widgetState++  -- Return the widget+  return widget++instance IHaskellWidget Play where+  getCommUUID = uuid+  comm widget val _ =+    case nestedObjectLookup val ["state", "value"] of+      Just (Number value) -> do+        void $ setField' widget IntValue (Sci.coefficient value)+        triggerChange widget+      _ -> pure ()
src/IHaskell/Display/Widgets/Int/BoundedIntRange/IntRangeSlider.hs view
@@ -28,6 +28,8 @@  import           IHaskell.Display.Widgets.Types import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle  -- | 'IntRangeSlider' represents an IntRangeSlider widget from IPython.html.widgets. type IntRangeSlider = IPythonWidget 'IntRangeSliderType@@ -37,12 +39,16 @@ mkIntRangeSlider = do   -- Default properties, with a random uuid   wid <- U.random+  layout <- mkLayout+  dstyle <- mkDescriptionStyle -  let boundedIntAttrs = defaultBoundedIntRangeWidget "IntSliderView" "IntSliderModel"-      sliderAttrs = (Orientation =:: HorizontalOrientation)-                    :& (ShowRange =:: True)+  let boundedIntAttrs = defaultBoundedIntRangeWidget "IntRangeSliderView" "IntRangeSliderModel" layout $ StyleWidget dstyle+      sliderAttrs = (StepInt =:: Just 1)+                    :& (Orientation =:: HorizontalOrientation)                     :& (ReadOut =:: True)-                    :& (SliderColor =:: "")+                    :& (ReadOutFormat =:: "d")+                    :& (ContinuousUpdate =:: True)+                    :& (Disabled =:: False)                     :& RNil       widgetState = WidgetState $ boundedIntAttrs <+> sliderAttrs @@ -56,15 +62,10 @@   -- Return the widget   return widget -instance IHaskellDisplay IntRangeSlider where-  display b = do-    widgetSendView b-    return $ Display []- instance IHaskellWidget IntRangeSlider where   getCommUUID = uuid   comm widget val _ =-    case nestedObjectLookup val ["sync_data", "value"] of+    case nestedObjectLookup val ["state", "value"] of       Just (Array values) ->         case map (\(Number x) -> Sci.coefficient x) $ V.toList values of           [x, y] -> do
src/IHaskell/Display/Widgets/Int/IntText.hs view
@@ -19,6 +19,7 @@ import           Data.Aeson import           Data.IORef (newIORef) import qualified Data.Scientific as Sci+import           Data.Vinyl (Rec(..), (<+>))  import           IHaskell.Display import           IHaskell.Eval.Widgets@@ -26,6 +27,8 @@  import           IHaskell.Display.Widgets.Types import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle  -- | 'IntText' represents an IntText widget from IPython.html.widgets. type IntText = IPythonWidget 'IntTextType@@ -35,8 +38,15 @@ mkIntText = do   -- Default properties, with a random uuid   wid <- U.random+  layout <- mkLayout+  dstyle <- mkDescriptionStyle -  let widgetState = WidgetState $ defaultIntWidget "IntTextView" "IntTextModel"+  let intAttrs = defaultIntWidget "IntTextView" "IntTextModel" layout $ StyleWidget dstyle+      textAttrs = (Disabled =:: False)+                  :& (ContinuousUpdate =:: False)+                  :& (StepInt =:: Just 1)+                  :& RNil+      widgetState = WidgetState $ intAttrs <+> textAttrs    stateIO <- newIORef widgetState @@ -48,15 +58,10 @@   -- Return the widget   return widget -instance IHaskellDisplay IntText where-  display b = do-    widgetSendView b-    return $ Display []- instance IHaskellWidget IntText where   getCommUUID = uuid   comm widget val _ =-    case nestedObjectLookup val ["sync_data", "value"] of+    case nestedObjectLookup val ["state", "value"] of       Just (Number value) -> do         void $ setField' widget IntValue (Sci.coefficient value)         triggerChange widget
src/IHaskell/Display/Widgets/Interactive.hs view
@@ -148,7 +148,7 @@       initializers = rmap extractInitializer rc    bx <- mkBox-  out <- mkOutputWidget+  out <- mkOutput    -- Create a list of widgets   widgets <- rtraverse createWidget constructors@@ -163,7 +163,7 @@   -- Set initial values for all widgets   setInitialValues initializers widgets initvals   -- applyValueSetters valueSetters widgets $ getList defvals-  setField out Width 500+  -- setField out Width 500   -- TODO This can't be set right now since we switched FlexBox to a regular   --      Box. This is a styling/layout parameter now but these haven't been implemented yet.   -- setField bx Orientation VerticalOrientation@@ -214,7 +214,7 @@   type SuitableField Text = 'S.StringValue   data Argument Text = TextVal Text   initializer w (TextVal txt) = setField w StringValue txt-  wrapped = WrappedWidget mkTextWidget SubmitHandler StringValue+  wrapped = WrappedWidget mkText SubmitHandler StringValue  instance FromWidget Integer where   type SuitableWidget Integer = 'IntSliderType
+ src/IHaskell/Display/Widgets/Layout.hs view
@@ -0,0 +1,5 @@+module IHaskell.Display.Widgets.Layout (module X) where++import IHaskell.Display.Widgets.Layout.Common as X+import IHaskell.Display.Widgets.Layout.Types as X+import IHaskell.Display.Widgets.Layout.LayoutWidget as X
+ src/IHaskell/Display/Widgets/Layout/Common.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE AutoDeriveTypeable #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- There are lots of pattern synpnyms, and little would be gained by adding+-- the type signatures.+{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module IHaskell.Display.Widgets.Layout.Common where++import qualified IHaskell.Display.Widgets.Singletons as S++pattern AlignContent = S.SLAlignContent+pattern AlignItems = S.SLAlignItems+pattern AlignSelf = S.SLAlignSelf+pattern Border = S.SLBorder+pattern Bottom = S.SLBottom+pattern Display = S.SLDisplay+pattern Flex = S.SLFlex+pattern FlexFlow = S.SLFlexFlow+pattern GridArea = S.SLGridArea+pattern GridAutoColumns = S.SLGridAutoColumns+pattern GridAutoFlow = S.SLGridAutoFlow+pattern GridAutoRows = S.SLGridAutoRows+pattern GridColumn = S.SLGridColumn+pattern GridGap = S.SLGridGap+pattern GridRow = S.SLGridRow+pattern GridTemplateAreas = S.SLGridTemplateAreas+pattern GridTemplateColumns = S.SLGridTemplateColumns+pattern GridTemplateRows = S.SLGridTemplateRows+pattern Height = S.SLHeight+pattern JustifyContent = S.SLJustifyContent+pattern JustifyItems = S.SLJustifyItems+pattern Left = S.SLLeft+pattern Margin = S.SLMargin+pattern MaxHeight = S.SLMaxHeight+pattern MaxWidth = S.SLMaxWidth+pattern MinHeight = S.SLMinHeight+pattern MinWidth = S.SLMinWidth+pattern Order = S.SLOrder+pattern Overflow = S.SLOverflow+pattern OverflowX = S.SLOverflowX+pattern OverflowY = S.SLOverflowY+pattern Padding = S.SLPadding+pattern Right = S.SLRight+pattern Top = S.SLTop+pattern Visibility = S.SLVisibility+pattern Width = S.SLWidth++-- TODO: This should be implemented with static type checking, so it's+-- easier to verify at compile-time. "The Haskell Way".+-- But a lot of these fields have common values. ¿Maybe doing some kind+-- of singleton for the CSS fields? ¿Maybe appending the type like+-- InheritOverflow / InheritVisible / InheritGrid...+-- In the meantime we'll use arrays of strings and some runtime verification+cssProps :: [String]+cssProps = ["inherit", "initial", "unset"]+alignContentProps = ["flex-start", "flex-end", "center", "space-between", "space-around", "space-evenly", "stretch"] ++ cssProps+alignItemProps =  ["flex-start", "flex-end", "center", "baseline", "stretch"] ++ cssProps+alignSelfProps = ["auto", "flex-start", "flex-end", "center", "baseline", "stretch"] ++ cssProps+gridAutoFlowProps = ["column", "row", "row dense", "column dense"] ++ cssProps+justifyContentProps = ["flex-start", "flex-end", "center", "space-between", "space-around"] ++ cssProps+justifyItemsProps = ["flex-start", "flex-end", "center"] ++ cssProps+overflowProps = ["visible", "hidden", "scroll", "auto"] ++ cssProps+visibilityProps = ["visible", "hidden"] ++ cssProps
+ src/IHaskell/Display/Widgets/Layout/LayoutWidget.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans  #-}++module IHaskell.Display.Widgets.Layout.LayoutWidget+  ( -- * The Layout Widget+    Layout+    -- * Create a new Layout+  , mkLayout+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Data.Aeson+import           Data.IORef (newIORef)++import           IHaskell.Display+import           IHaskell.Eval.Widgets+import           IHaskell.IPython.Message.UUID as U++import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Layout.Types++-- | A 'Layout' represents a Layout from IPython.html.widgets.+type Layout = IPythonWidget 'LayoutType++-- | Create a new Layout+mkLayout :: IO Layout+mkLayout = do+  -- Default properties, with a random uuid+  wid <- U.random++  let layoutState = WidgetState defaultLayoutWidget++  stateIO <- newIORef layoutState++  let layout = IPythonWidget wid stateIO++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen layout $ toJSON layoutState++  -- Return the Layout widget+  return layout++instance IHaskellWidget Layout where+  getCommUUID = uuid
+ src/IHaskell/Display/Widgets/Layout/Types.hs view
@@ -0,0 +1,169 @@+{-# 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 #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE AutoDeriveTypeable #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}++module IHaskell.Display.Widgets.Layout.Types where++import           Prelude hiding (Right,Left)++import           Control.Monad (unless)+import qualified Control.Exception as Ex++import           Data.List (intercalate)++import           Data.Vinyl (Rec(..))++import qualified IHaskell.Display.Widgets.Singletons as S+import           IHaskell.Display.Widgets.Types++import           IHaskell.Display.Widgets.Layout.Common++type LayoutClass = [ 'S.ModelModule+                   , 'S.ModelModuleVersion+                   , 'S.ModelName+                   , 'S.ViewModule+                   , 'S.ViewModuleVersion+                   , 'S.ViewName+                   , 'S.LAlignContent+                   , 'S.LAlignItems+                   , 'S.LAlignSelf+                   , 'S.LBorder+                   , 'S.LBottom+                   , 'S.LDisplay+                   , 'S.LFlex+                   , 'S.LFlexFlow+                   , 'S.LGridArea+                   , 'S.LGridAutoColumns+                   , 'S.LGridAutoFlow+                   , 'S.LGridAutoRows+                   , 'S.LGridColumn+                   , 'S.LGridGap+                   , 'S.LGridRow+                   , 'S.LGridTemplateAreas+                   , 'S.LGridTemplateColumns+                   , 'S.LGridTemplateRows+                   , 'S.LHeight+                   , 'S.LJustifyContent+                   , 'S.LJustifyItems+                   , 'S.LLeft+                   , 'S.LMargin+                   , 'S.LMaxHeight+                   , 'S.LMaxWidth+                   , 'S.LMinHeight+                   , 'S.LMinWidth+                   , 'S.LOrder+                   , 'S.LOverflow+                   , 'S.LOverflowX+                   , 'S.LOverflowY+                   , 'S.LPadding+                   , 'S.LRight+                   , 'S.LTop+                   , 'S.LVisibility+                   , 'S.LWidth+                   ]++type instance FieldType 'S.LAlignContent = Maybe String+type instance FieldType 'S.LAlignItems = Maybe String+type instance FieldType 'S.LAlignSelf = Maybe String+type instance FieldType 'S.LBorder = Maybe String+type instance FieldType 'S.LBottom = Maybe String+type instance FieldType 'S.LDisplay = Maybe String+type instance FieldType 'S.LFlex = Maybe String+type instance FieldType 'S.LFlexFlow = Maybe String+type instance FieldType 'S.LGridArea = Maybe String+type instance FieldType 'S.LGridAutoColumns = Maybe String+type instance FieldType 'S.LGridAutoFlow = Maybe String+type instance FieldType 'S.LGridAutoRows = Maybe String+type instance FieldType 'S.LGridColumn = Maybe String+type instance FieldType 'S.LGridGap = Maybe String+type instance FieldType 'S.LGridRow = Maybe String+type instance FieldType 'S.LGridTemplateAreas = Maybe String+type instance FieldType 'S.LGridTemplateColumns = Maybe String+type instance FieldType 'S.LGridTemplateRows = Maybe String+type instance FieldType 'S.LHeight = Maybe String+type instance FieldType 'S.LJustifyContent = Maybe String+type instance FieldType 'S.LJustifyItems = Maybe String+type instance FieldType 'S.LLeft = Maybe String+type instance FieldType 'S.LMargin = Maybe String+type instance FieldType 'S.LMaxHeight = Maybe String+type instance FieldType 'S.LMaxWidth = Maybe String+type instance FieldType 'S.LMinHeight = Maybe String+type instance FieldType 'S.LMinWidth = Maybe String+type instance FieldType 'S.LOrder = Maybe String+type instance FieldType 'S.LOverflow = Maybe String+type instance FieldType 'S.LOverflowX = Maybe String+type instance FieldType 'S.LOverflowY = Maybe String+type instance FieldType 'S.LPadding = Maybe String+type instance FieldType 'S.LRight = Maybe String+type instance FieldType 'S.LTop = Maybe String+type instance FieldType 'S.LVisibility = Maybe String+type instance FieldType 'S.LWidth = Maybe String++-- type family WidgetFields (w :: WidgetType) :: [Field] where+type instance WidgetFields 'LayoutType = LayoutClass++-- | A record representing a widget of the Layour class from IPython+defaultLayoutWidget :: Rec Attr LayoutClass+defaultLayoutWidget = (S.SModelModule =:! "@jupyter-widgets/base")+                      :& (S.SModelModuleVersion =:! "1.1.0")+                      :& (S.SModelName =:! "LayoutModel")+                      :& (S.SViewModule =:! "@jupyter-widgets/base")+                      :& (S.SViewModuleVersion =:! "1.1.0")+                      :& (S.SViewName =:! "LayoutView")+                      :& (AlignContent =:. (Nothing, venum alignContentProps))+                      :& (AlignItems =:. (Nothing, venum alignItemProps))+                      :& (AlignSelf =:. (Nothing, venum alignSelfProps))+                      :& (Border =:: Nothing)+                      :& (Bottom =:: Nothing)+                      :& (Display =:: Nothing)+                      :& (Flex =:: Nothing)+                      :& (FlexFlow =:: Nothing)+                      :& (GridArea =:: Nothing)+                      :& (GridAutoColumns =:: Nothing)+                      :& (GridAutoFlow =:. (Nothing, venum gridAutoFlowProps))+                      :& (GridAutoRows =:: Nothing)+                      :& (GridColumn =:: Nothing)+                      :& (GridGap =:: Nothing)+                      :& (GridRow =:: Nothing)+                      :& (GridTemplateAreas =:: Nothing)+                      :& (GridTemplateColumns =:: Nothing)+                      :& (GridTemplateRows =:: Nothing)+                      :& (Height =:: Nothing)+                      :& (JustifyContent =:: Nothing)+                      :& (JustifyItems =:: Nothing)+                      :& (Left =:: Nothing)+                      :& (Margin =:: Nothing)+                      :& (MaxHeight =:: Nothing)+                      :& (MaxWidth =:: Nothing)+                      :& (MinHeight =:: Nothing)+                      :& (MinWidth =:: Nothing)+                      :& (Order =:: Nothing)+                      :& (Overflow =:. (Nothing, venum overflowProps))+                      :& (OverflowX =:. (Nothing, venum overflowProps))+                      :& (OverflowY =:. (Nothing, venum overflowProps))+                      :& (Padding =:: Nothing)+                      :& (Right =:: Nothing)+                      :& (Top =:: Nothing)+                      :& (Visibility =:. (Nothing, venum visibilityProps))+                      :& (Width =:: Nothing)+                      :& RNil+    where venum :: [String] -> Maybe String -> IO (Maybe String)+          venum _ Nothing = return Nothing+          venum xs (Just f) = do+            unless (f `elem` xs) (Ex.throw $ Ex.AssertionFailed ("The value should be one of: " ++ intercalate ", " xs))+            return $ Just f
+ src/IHaskell/Display/Widgets/Link/DirectionalLink.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module IHaskell.Display.Widgets.Link.DirectionalLink+  ( -- * The DirectionalLink Widget+    DirectionalLink+    -- * Constructor+  , mkDirectionalLink+    -- * Another constructor+  , jsdlink+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Data.Aeson+import           Data.IORef (newIORef)++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 'DirectionalLink' represents a DirectionalLink widget from IPython.html.widgets.+type DirectionalLink = IPythonWidget 'DirectionalLinkType++-- | Create a new DirectionalLink widget+mkDirectionalLink :: IO DirectionalLink+mkDirectionalLink = do+  -- Default properties, with a random uuid+  wid <- U.random++  let widgetState = WidgetState $ defaultLinkWidget "DirectionalLinkModel"++  stateIO <- newIORef widgetState++  let widget = IPythonWidget wid stateIO++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen widget $ toJSON widgetState++  -- Return the DirectionalLink widget+  return widget++-- | An easier constructor that links two widgets+jsdlink :: WidgetFieldPair -> WidgetFieldPair -> IO DirectionalLink+jsdlink wfp1 wfp2 = do+  dlink <- mkDirectionalLink+  _ <- setField dlink Source wfp1+  _ <- setField dlink Target wfp2+  return dlink++instance IHaskellWidget DirectionalLink where+  getCommUUID = uuid
+ src/IHaskell/Display/Widgets/Link/Link.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module IHaskell.Display.Widgets.Link.Link+  ( -- * The Link Widget+    Link+    -- * Constructor+  , mkLink+    -- * Easier constructor+  , jslink+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Data.Aeson+import           Data.IORef (newIORef)++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 'Link' represents a Link widget from IPython.html.widgets.+type Link = IPythonWidget 'LinkType++-- | Create a new link widget+mkLink :: IO Link+mkLink = do+  -- Default properties, with a random uuid+  wid <- U.random++  let widgetState = WidgetState $ defaultLinkWidget "LinkModel"++  stateIO <- newIORef widgetState++  let widget = IPythonWidget wid stateIO++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen widget $ toJSON widgetState++  -- Return the link widget+  return widget++-- | An easier constructor that links two widgets+jslink :: WidgetFieldPair -> WidgetFieldPair -> IO Link+jslink wfp1 wfp2 = do+  link <- mkLink+  _ <- setField link Source wfp1+  _ <- setField link Target wfp2+  return link++instance IHaskellWidget Link where+  getCommUUID = uuid
+ src/IHaskell/Display/Widgets/Media/Audio.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module IHaskell.Display.Widgets.Media.Audio+  ( -- * The Audio Widget+    AudioWidget+    -- * Constructor+  , mkAudio+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Data.Aeson+import           Data.IORef (newIORef)+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+import           IHaskell.Display.Widgets.Layout.LayoutWidget++-- | An 'AudioWidget' represents a Audio widget from IPython.html.widgets.+type AudioWidget = IPythonWidget 'AudioType++-- | Create a new audio widget+mkAudio :: IO AudioWidget+mkAudio = do+  -- Default properties, with a random uuid+  wid <- U.random+  layout <- mkLayout++  let mediaAttrs = defaultMediaWidget "AudioView" "AudioModel" layout+      audioAttrs = (AudioFormat =:: MP3)+              :& (AutoPlay =:: True)+              :& (Loop =:: True)+              :& (Controls =:: True)+              :& RNil+      widgetState = WidgetState (mediaAttrs <+> audioAttrs)++  stateIO <- newIORef widgetState++  let widget = IPythonWidget wid stateIO++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen widget $ toJSON widgetState++  -- Return the audio widget+  return widget++instance IHaskellWidget AudioWidget where+  getCommUUID = uuid+  getBufferPaths _ = [["value"]]
+ src/IHaskell/Display/Widgets/Media/Image.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module IHaskell.Display.Widgets.Media.Image+  ( -- * The Image Widget+    ImageWidget+    -- * Constructor+  , mkImage+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Data.Aeson+import           Data.IORef (newIORef)+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+import           IHaskell.Display.Widgets.Layout.LayoutWidget++-- | An 'ImageWidget' represents a Image widget from IPython.html.widgets.+type ImageWidget = IPythonWidget 'ImageType++-- | Create a new image widget+mkImage :: IO ImageWidget+mkImage = do+  -- Default properties, with a random uuid+  wid <- U.random+  layout <- mkLayout++  let mediaAttrs = defaultMediaWidget "ImageView" "ImageModel" layout+      imageAttrs = (ImageFormat =:: PNG)+                   :& (Width =:+ 0)+                   :& (Height =:+ 0)+                   :& RNil+      widgetState = WidgetState (mediaAttrs <+> imageAttrs)++  stateIO <- newIORef widgetState++  let widget = IPythonWidget wid stateIO++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen widget $ toJSON widgetState++  -- Return the image widget+  return widget++instance IHaskellWidget ImageWidget where+  getCommUUID = uuid+  getBufferPaths _ = [["value"]]
+ src/IHaskell/Display/Widgets/Media/Video.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module IHaskell.Display.Widgets.Media.Video+  ( -- * The Video Widget+    VideoWidget+    -- * Constructor+  , mkVideo+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Data.Aeson+import           Data.IORef (newIORef)+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+import           IHaskell.Display.Widgets.Layout.LayoutWidget++-- | An 'VideoWidget' represents a video widget from IPython.html.widgets.+type VideoWidget = IPythonWidget 'VideoType++-- | Create a new video widget+mkVideo :: IO VideoWidget+mkVideo = do+  -- Default properties, with a random uuid+  wid <- U.random+  layout <- mkLayout++  let mediaAttrs = defaultMediaWidget "VideoView" "VideoModel" layout+      videoAttrs = (VideoFormat =:: MP4)+              :& (Width =:+ 0)+              :& (Height =:+ 0)+              :& (AutoPlay =:: True)+              :& (Loop =:: True)+              :& (Controls =:: True)+              :& RNil+      widgetState = WidgetState (mediaAttrs <+> videoAttrs)++  stateIO <- newIORef widgetState++  let widget = IPythonWidget wid stateIO++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen widget $ toJSON widgetState++  -- Return the video widget+  return widget++instance IHaskellWidget VideoWidget where+  getCommUUID = uuid+  getBufferPaths _ = [["value"]]
src/IHaskell/Display/Widgets/Output.hs view
@@ -9,9 +9,11 @@   ( -- * The Output Widget     OutputWidget     -- * Constructor-  , mkOutputWidget+  , mkOutput     -- * Using the output widget-  , appendOutput+  , appendStdout+  , appendStderr+  , appendDisplay   , clearOutput   , clearOutput_   , replaceOutput@@ -22,23 +24,37 @@  import           Data.Aeson import           Data.IORef (newIORef)+import           Data.Text+import           Data.Vinyl (Rec(..), (<+>))  import           IHaskell.Display import           IHaskell.Eval.Widgets+import           IHaskell.IPython.Types (StreamType(..)) import           IHaskell.IPython.Message.UUID as U  import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget  -- | An 'OutputWidget' represents a Output widget from IPython.html.widgets. type OutputWidget = IPythonWidget 'OutputType  -- | Create a new output widget-mkOutputWidget :: IO OutputWidget-mkOutputWidget = do+mkOutput :: IO OutputWidget+mkOutput = do   -- Default properties, with a random uuid   wid <- U.random+  layout <- mkLayout -  let widgetState = WidgetState $ defaultDOMWidget "OutputView" "OutputModel"+  let domAttrs = defaultDOMWidget "OutputView" "OutputModel" layout+      outAttrs = (ViewModule =:! "@jupyter-widgets/output")+                 :& (ModelModule =:! "@jupyter-widgets/output")+                 :& (ViewModuleVersion =:! "1.0.0")+                 :& (ModelModuleVersion =:! "1.0.0")+                 :& (MsgID =:: "")+                 :& (Outputs =:: [])+                 :& RNil+      widgetState = WidgetState $ domAttrs <+> outAttrs    stateIO <- newIORef widgetState @@ -50,30 +66,49 @@   -- 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+-- | Appends the Text to the given Stream+appendStd :: StreamType -> OutputWidget -> Text -> IO ()+appendStd n out t = do+  getField out Outputs >>= setField out Outputs . updateOutputs+  where updateOutputs :: [OutputMsg] -> [OutputMsg]+        updateOutputs = (++[OutputStream n t]) +-- | Appends text to the stdout of an output widget+appendStdout :: OutputWidget -> Text -> IO ()+appendStdout = appendStd Stdout++-- | Appends text to the stderr of an output widget+appendStderr :: OutputWidget -> Text -> IO ()+appendStderr = appendStd Stderr++-- | Clears the output widget+clearOutput' :: OutputWidget -> IO ()+clearOutput' w = do+  _ <- setField w Outputs []+  _ <- setField w MsgID ""+  return ()++-- | Appends anything displayable to an output widget+appendDisplay :: IHaskellDisplay a => OutputWidget -> a -> IO ()+appendDisplay o d = do+  outputs <- getField o Outputs+  disp <- display d+  _ <- setField o Outputs $ outputs ++ [OutputData disp]+  return ()+ -- | Clear the output widget immediately clearOutput :: OutputWidget -> IO ()-clearOutput widget = widgetClearOutput widget False+clearOutput widget = widgetClearOutput False >> clearOutput' widget  -- | Clear the output widget on next append clearOutput_ :: OutputWidget -> IO ()-clearOutput_ widget = widgetClearOutput widget True+clearOutput_ widget = widgetClearOutput True >> clearOutput' widget  -- | 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 []+    disp <- display d+    setField widget Outputs [OutputData disp]  instance IHaskellWidget OutputWidget where   getCommUUID = uuid
src/IHaskell/Display/Widgets/Selection/Dropdown.hs view
@@ -18,7 +18,7 @@ import           Control.Monad (void) import           Data.Aeson import           Data.IORef (newIORef)-import           Data.Vinyl (Rec(..), (<+>))+import qualified Data.Scientific as Sci  import           IHaskell.Display import           IHaskell.Eval.Widgets@@ -26,6 +26,8 @@  import           IHaskell.Display.Widgets.Types import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle  -- | A 'Dropdown' represents a Dropdown widget from IPython.html.widgets. type Dropdown = IPythonWidget 'DropdownType@@ -35,10 +37,11 @@ mkDropdown = do   -- Default properties, with a random uuid   wid <- U.random-  let selectionAttrs = defaultSelectionWidget "DropdownView" "DropdownModel"-      dropdownAttrs = (ButtonStyle =:: DefaultButton) :& RNil-      widgetState = WidgetState $ selectionAttrs <+> dropdownAttrs+  layout <- mkLayout+  dstyle <- mkDescriptionStyle +  let widgetState = WidgetState $ defaultSelectionWidget "DropdownView" "DropdownModel" layout $ StyleWidget dstyle+   stateIO <- newIORef widgetState    let widget = IPythonWidget wid stateIO@@ -49,26 +52,11 @@   -- Return the widget   return widget -instance IHaskellDisplay Dropdown where-  display b = do-    widgetSendView b-    return $ Display []- instance IHaskellWidget Dropdown where   getCommUUID = uuid   comm widget val _ =-    case nestedObjectLookup val ["sync_data", "selected_label"] of-      Just (String label) -> do-        opts <- getField widget Options-        case opts of-          OptionLabels _ -> do-            void $ setField' widget SelectedLabel label-            void $ setField' widget SelectedValue label-          OptionDict ps ->-            case lookup label ps of-              Nothing -> return ()-              Just value -> do-                void $ setField' widget SelectedLabel label-                void $ setField' widget SelectedValue value+    case nestedObjectLookup val ["state", "index"] of+      Just (Number index) -> do+        void $ setField' widget OptionalIndex (Just $ Sci.coefficient index)         triggerSelection widget       _ -> pure ()
src/IHaskell/Display/Widgets/Selection/RadioButtons.hs view
@@ -18,6 +18,7 @@ import           Control.Monad (void) import           Data.Aeson import           Data.IORef (newIORef)+import qualified Data.Scientific as Sci  import           IHaskell.Display import           IHaskell.Eval.Widgets@@ -25,6 +26,8 @@  import           IHaskell.Display.Widgets.Types import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle  -- | A 'RadioButtons' represents a RadioButtons widget from IPython.html.widgets. type RadioButtons = IPythonWidget 'RadioButtonsType@@ -34,8 +37,11 @@ mkRadioButtons = do   -- Default properties, with a random uuid   wid <- U.random-  let widgetState = WidgetState $ defaultSelectionWidget "RadioButtonsView" "RadioButtonsModel"+  layout <- mkLayout+  dstyle <- mkDescriptionStyle +  let widgetState = WidgetState $ defaultSelectionWidget "RadioButtonsView" "RadioButtonsModel" layout $ StyleWidget dstyle+   stateIO <- newIORef widgetState    let widget = IPythonWidget wid stateIO@@ -46,26 +52,11 @@   -- Return the widget   return widget -instance IHaskellDisplay RadioButtons where-  display b = do-    widgetSendView b-    return $ Display []- instance IHaskellWidget RadioButtons where   getCommUUID = uuid   comm widget val _ =-    case nestedObjectLookup val ["sync_data", "selected_label"] of-      Just (String label) -> do-        opts <- getField widget Options-        case opts of-          OptionLabels _ -> do-            void $ setField' widget SelectedLabel label-            void $ setField' widget SelectedValue label-          OptionDict ps ->-            case lookup label ps of-              Nothing -> pure ()-              Just value -> do-                void $ setField' widget SelectedLabel label-                void $ setField' widget SelectedValue value+    case nestedObjectLookup val ["state", "index"] of+      Just (Number index) -> do+        void $ setField' widget OptionalIndex (Just $ Sci.coefficient index)         triggerSelection widget       _ -> pure ()
src/IHaskell/Display/Widgets/Selection/Select.hs view
@@ -18,6 +18,8 @@ import           Control.Monad (void) import           Data.Aeson import           Data.IORef (newIORef)+import qualified Data.Scientific as Sci+import           Data.Vinyl (Rec(..), (<+>))  import           IHaskell.Display import           IHaskell.Eval.Widgets@@ -25,6 +27,8 @@  import           IHaskell.Display.Widgets.Types import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle  -- | A 'Select' represents a Select widget from IPython.html.widgets. type Select = IPythonWidget 'SelectType@@ -34,8 +38,14 @@ mkSelect = do   -- Default properties, with a random uuid   wid <- U.random-  let widgetState = WidgetState $ defaultSelectionWidget "SelectView" "SelectModel"+  layout <- mkLayout+  dstyle <- mkDescriptionStyle +  let selectionAttrs = defaultSelectionWidget "SelectView" "SelectModel" layout $ StyleWidget dstyle+      selectAttrs = (Rows =:: Just 5)+                    :& RNil+      widgetState = WidgetState $ selectionAttrs <+> selectAttrs+   stateIO <- newIORef widgetState    let widget = IPythonWidget wid stateIO@@ -46,26 +56,11 @@   -- Return the widget   return widget -instance IHaskellDisplay Select where-  display b = do-    widgetSendView b-    return $ Display []- instance IHaskellWidget Select where   getCommUUID = uuid   comm widget val _ =-    case nestedObjectLookup val ["sync_data", "selected_label"] of-      Just (String label) -> do-        opts <- getField widget Options-        case opts of-          OptionLabels _ -> do-            void $ setField' widget SelectedLabel label-            void $ setField' widget SelectedValue label-          OptionDict ps ->-            case lookup label ps of-              Nothing -> pure ()-              Just value -> do-                void $ setField' widget SelectedLabel label-                void $ setField' widget SelectedValue value+    case nestedObjectLookup val ["state", "index"] of+      Just (Number index) -> do+        void $ setField' widget OptionalIndex (Just $ Sci.coefficient index)         triggerSelection widget       _ -> pure ()
src/IHaskell/Display/Widgets/Selection/SelectMultiple.hs view
@@ -18,7 +18,9 @@ import           Control.Monad (void) import           Data.Aeson import           Data.IORef (newIORef)+import qualified Data.Scientific as Sci import qualified Data.Vector as V+import           Data.Vinyl (Rec(..), (<+>))  import           IHaskell.Display import           IHaskell.Eval.Widgets@@ -26,6 +28,8 @@  import           IHaskell.Display.Widgets.Types import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle  -- | A 'SelectMultiple' represents a SelectMultiple widget from IPython.html.widgets. type SelectMultiple = IPythonWidget 'SelectMultipleType@@ -35,8 +39,14 @@ mkSelectMultiple = do   -- Default properties, with a random uuid   wid <- U.random-  let widgetState = WidgetState $ defaultMultipleSelectionWidget "SelectMultipleView" "SelectMultipleModel"+  layout <- mkLayout+  dstyle <- mkDescriptionStyle +  let multipleSelectionAttrs = defaultMultipleSelectionWidget "SelectMultipleView" "SelectMultipleModel" layout $ StyleWidget dstyle+      selectMultipleAttrs = (Rows =:: Just 5)+                            :& RNil+      widgetState = WidgetState $ multipleSelectionAttrs <+> selectMultipleAttrs+   stateIO <- newIORef widgetState    let widget = IPythonWidget wid stateIO@@ -47,27 +57,12 @@   -- Return the widget   return widget -instance IHaskellDisplay SelectMultiple where-  display b = do-    widgetSendView b-    return $ Display []- instance IHaskellWidget SelectMultiple where   getCommUUID = uuid   comm widget val _ =-    case nestedObjectLookup val ["sync_data", "selected_labels"] of-      Just (Array labels) -> do-        let labelList = map (\(String x) -> x) $ V.toList labels-        opts <- getField widget Options-        case opts of-          OptionLabels _ -> do-            void $ setField' widget SelectedLabels labelList-            void $ setField' widget SelectedValues labelList-          OptionDict ps ->-            case mapM (`lookup` ps) labelList of-              Nothing -> pure ()-              Just valueList -> do-                void $ setField' widget SelectedLabels labelList-                void $ setField' widget SelectedValues valueList+    case nestedObjectLookup val ["state", "index"] of+      Just (Array indices) -> do+        let indicesList = map (\(Number x) -> Sci.coefficient x) $ V.toList indices+        void $ setField' widget Indices indicesList         triggerSelection widget       _ -> pure ()
+ src/IHaskell/Display/Widgets/Selection/SelectionRangeSlider.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module IHaskell.Display.Widgets.Selection.SelectionRangeSlider+  ( -- * The SelectionRangeSlider Widget+    SelectionRangeSlider+    -- * Constructor+  , mkSelectionRangeSlider+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Control.Monad (void)+import           Data.Aeson+import           Data.IORef (newIORef)+import qualified Data.Scientific as Sci+import qualified Data.Vector as V+import           Data.Vinyl (Rec(..), (<+>), rput)++import           IHaskell.Display+import           IHaskell.Eval.Widgets+import           IHaskell.IPython.Message.UUID as U++import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle++-- | A 'SelectionRangeSlider' represents a SelectionSlider widget from IPyhon.widgets+type SelectionRangeSlider = IPythonWidget 'SelectionRangeSliderType++-- | Create a new SelectionRangeSlider widget+mkSelectionRangeSlider :: IO SelectionRangeSlider+mkSelectionRangeSlider = do+  wid <- U.random+  layout <- mkLayout+  dstyle <- mkDescriptionStyle++  let selectionAttrs = defaultMultipleSelectionWidget "SelectionRangeSliderView" "SelectionRangeSliderModel" layout $ StyleWidget dstyle+      selectionRangeSliderAttrs = (Orientation =:: HorizontalOrientation)+                                  :& (ReadOut =:: True)+                                  :& (ContinuousUpdate =:: True)+                                  :& RNil+      widgetState = WidgetState $ rput (Indices =:. ([0,0], rangeSliderVerification)) $ selectionAttrs <+> selectionRangeSliderAttrs++  stateIO <- newIORef widgetState++  let widget = IPythonWidget wid stateIO++  -- Open a comm for this widget and store it in the kernel state+  widgetSendOpen widget $ toJSON widgetState++  -- Return the created widget+  return widget++instance IHaskellWidget SelectionRangeSlider where+  getCommUUID = uuid+  comm widget val _ =+    case nestedObjectLookup val ["state", "index"] of+      Just (Array indices) -> do+        let indicesList = map (\(Number x) -> Sci.coefficient x) $ V.toList indices+        void $ setField' widget Indices indicesList+        triggerSelection widget+      _ -> pure ()
+ src/IHaskell/Display/Widgets/Selection/SelectionSlider.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module IHaskell.Display.Widgets.Selection.SelectionSlider+  ( -- * The SelectionSlider Widget+    SelectionSlider+    -- * Constructor+  , mkSelectionSlider+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Control.Monad (void)+import           Data.Aeson+import           Data.IORef (newIORef)+import qualified Data.Scientific as Sci+import           Data.Vinyl (Rec(..), (<+>))++import           IHaskell.Display+import           IHaskell.Eval.Widgets+import           IHaskell.IPython.Message.UUID as U++import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle++-- | A 'SelectionSlider' represents a SelectionSlider widget from IPyhon.widgets+type SelectionSlider = IPythonWidget 'SelectionSliderType++-- | Create a new SelectionSLider widget+mkSelectionSlider :: IO SelectionSlider+mkSelectionSlider = do+  wid <- U.random+  layout <- mkLayout+  dstyle <- mkDescriptionStyle++  let selectionAttrs = defaultSelectionNonemptyWidget "SelectionSliderView" "SelectionSliderModel" layout $ StyleWidget dstyle+      selectionSliderAttrs = (Orientation =:: HorizontalOrientation)+                             :& (ReadOut =:: True)+                             :& (ContinuousUpdate =:: True)+                             :& RNil+      widgetState = WidgetState $ selectionAttrs <+> selectionSliderAttrs++  stateIO <- newIORef widgetState++  let widget = IPythonWidget wid stateIO++  -- Open a comm for this widget and store it in the kernel state+  widgetSendOpen widget $ toJSON widgetState++  -- Return the created widget+  return widget++instance IHaskellWidget SelectionSlider where+  getCommUUID = uuid+  comm widget val _ =+    case nestedObjectLookup val ["state", "index"] of+      Just (Number index) -> do+        void $ setField' widget Index (Sci.coefficient index)+        triggerSelection widget+      _ -> pure ()
src/IHaskell/Display/Widgets/Selection/ToggleButtons.hs view
@@ -18,6 +18,7 @@ import           Control.Monad (void) import           Data.Aeson import           Data.IORef (newIORef)+import qualified Data.Scientific as Sci import           Data.Vinyl (Rec(..), (<+>))  import           IHaskell.Display@@ -26,6 +27,8 @@  import           IHaskell.Display.Widgets.Types import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle  -- | A 'ToggleButtons' represents a ToggleButtons widget from IPython.html.widgets. type ToggleButtons = IPythonWidget 'ToggleButtonsType@@ -35,7 +38,10 @@ mkToggleButtons = do   -- Default properties, with a random uuid   wid <- U.random-  let selectionAttrs = defaultSelectionWidget "ToggleButtonsView" "ToggleButtonsModel"+  layout <- mkLayout+  dstyle <- mkDescriptionStyle++  let selectionAttrs = defaultSelectionWidget "ToggleButtonsView" "ToggleButtonsModel" layout $ StyleWidget dstyle       toggleButtonsAttrs = (Tooltips =:: [])                            :& (Icons =:: [])                            :& (ButtonStyle =:: DefaultButton)@@ -52,26 +58,11 @@   -- Return the widget   return widget -instance IHaskellDisplay ToggleButtons where-  display b = do-    widgetSendView b-    return $ Display []- instance IHaskellWidget ToggleButtons where   getCommUUID = uuid   comm widget val _ =-    case nestedObjectLookup val ["sync_data", "selected_label"]  of-      Just (String label) -> do-        opts <- getField widget Options-        case opts of-          OptionLabels _ -> void $ do-            void $ setField' widget SelectedLabel label-            void $ setField' widget SelectedValue label-          OptionDict ps ->-            case lookup label ps of-              Nothing -> pure ()-              Just value -> do-                void $ setField' widget SelectedLabel label-                void $ setField' widget SelectedValue value+    case nestedObjectLookup val ["state", "index"] of+      Just (Number index) -> do+        void $ setField' widget OptionalIndex (Just $ Sci.coefficient index)         triggerSelection widget       _ -> pure ()
src/IHaskell/Display/Widgets/Singletons.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PolyKinds #-}@@ -10,14 +11,25 @@ {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE TypeApplications #-}+#if __GLASGOW_HASKELL__ >= 810+{-# LANGUAGE StandaloneKindSignatures #-}+#endif +{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+ module IHaskell.Display.Widgets.Singletons where +#if MIN_VERSION_singletons(3,0,0)+import           Data.Singletons.Base.TH+import           Data.Eq.Singletons+#elif MIN_VERSION_singletons(2,4,0)+import           Data.Singletons.Prelude.Eq import           Data.Singletons.TH--#if MIN_VERSION_singletons(2,4,0) #else+import           Data.Singletons.Prelude.Eq import           Data.Singletons.Prelude.Ord+import           Data.Singletons.TH #endif  -- Widget properties@@ -25,29 +37,16 @@   [d|    data Field = ViewModule+             | ViewModuleVersion              | ViewName              | ModelModule+             | ModelModuleVersion              | ModelName-             | MsgThrottle-             | Version              | DisplayHandler-             | Visible-             | CSS              | DOMClasses+             | Layout              | Width              | Height-             | Padding-             | Margin-             | Color-             | BackgroundColor-             | BorderColor-             | BorderWidth-             | BorderRadius-             | BorderStyle-             | FontStyle-             | FontWeight-             | FontSize-             | FontFamily              | Description              | ClickHandler              | SubmitHandler@@ -57,17 +56,16 @@              | Tooltip              | Icon              | ButtonStyle-             | B64Value+             | BSValue              | ImageFormat              | BoolValue-             | Options-             | SelectedLabel-             | SelectedValue+             | OptionsLabels+             | Index+             | OptionalIndex              | SelectionHandler              | Tooltips              | Icons-             | SelectedLabels-             | SelectedValues+             | Indices              | IntValue              | StepInt              | MaxInt@@ -83,22 +81,222 @@              | LowerFloat              | UpperFloat              | Orientation-             | ShowRange+             | BaseFloat              | ReadOut-             | SliderColor+             | ReadOutFormat              | BarStyle              | ChangeHandler              | Children-             | OverflowX-             | OverflowY              | BoxStyle-             | Flex-             | Pack-             | Align              | Titles              | SelectedIndex              | ReadOutMsg-             | Child-             | Selector+             | Indent+             | ContinuousUpdate+             | Rows+             | AudioFormat+             | VideoFormat+             | AutoPlay+             | Loop+             | Controls+             | Options+             | EnsureOption+             | Playing+             | Repeat+             | Interval+             | ShowRepeat+             | Concise+             | DateValue+             | Pressed+             | Name+             | Mapping+             | Connected+             | Timestamp+             | Buttons+             | Axes+             | ButtonColor+             | FontWeight+             | DescriptionWidth+             | BarColor+             | HandleColor+             | ButtonWidth+             | Target+             | Source+             | MsgID+             | Outputs+             | Style+             -- Now the ones for layout+             -- Every layout property comes with an L before the name to avoid conflict+             -- The patterns from Layout.Common remove that leading L+             | LAlignContent+             | LAlignItems+             | LAlignSelf+             | LBorder+             | LBottom+             | LDisplay+             | LFlex+             | LFlexFlow+             | LGridArea+             | LGridAutoColumns+             | LGridAutoFlow+             | LGridAutoRows+             | LGridColumn+             | LGridGap+             | LGridRow+             | LGridTemplateAreas+             | LGridTemplateColumns+             | LGridTemplateRows+             | LHeight+             | LJustifyContent+             | LJustifyItems+             | LLeft+             | LMargin+             | LMaxHeight+             | LMaxWidth+             | LMinHeight+             | LMinWidth+             | LOrder+             | LOverflow+             | LOverflowX+             | LOverflowY+             | LPadding+             | LRight+             | LTop+             | LVisibility+             | LWidth              deriving (Eq, Ord, Show)+  |]++-- Attributes that aren't synced with the frontend give "" on toKey+promote+  [d|+    -- toKey :: Field -> String+    toKey ViewModule = "_view_module"+    toKey ViewModuleVersion = "_view_module_version"+    toKey ViewName = "_view_name"+    toKey ModelModule = "_model_module"+    toKey ModelModuleVersion = "_model_module_version"+    toKey ModelName = "_model_name"+    toKey DisplayHandler = "" -- Not sent to the frontend+    toKey DOMClasses = "_dom_classes"+    toKey Width = "width"+    toKey Height = "height"+    toKey Description = "description"+    toKey ClickHandler = "" -- Not sent to the frontend+    toKey SubmitHandler = "" -- Not sent to the frontend+    toKey Disabled = "disabled"+    toKey StringValue = "value"+    toKey Placeholder = "placeholder"+    toKey Tooltip = "tooltip"+    toKey Icon = "icon"+    toKey ButtonStyle = "button_style"+    toKey BSValue = "value"+    toKey ImageFormat = "format"+    toKey AudioFormat = "format"+    toKey VideoFormat = "format"+    toKey BoolValue = "value"+    toKey Index = "index"+    toKey OptionalIndex = "index"+    toKey OptionsLabels = "_options_labels"+    toKey SelectionHandler = "" -- Not sent to the frontend+    toKey Tooltips = "tooltips"+    toKey Icons = "icons"+    toKey Indices = "index"+    toKey IntValue = "value"+    toKey StepInt = "step"+    toKey MinInt = "min"+    toKey MaxInt = "max"+    toKey IntPairValue = "value"+    toKey LowerInt = "min"+    toKey UpperInt = "max"+    toKey FloatValue = "value"+    toKey StepFloat = "step"+    toKey MinFloat = "min"+    toKey MaxFloat = "max"+    toKey FloatPairValue = "value"+    toKey LowerFloat = "min"+    toKey UpperFloat = "max"+    toKey Orientation = "orientation"+    toKey BaseFloat = "base"+    toKey ReadOut = "readout"+    toKey ReadOutFormat = "readout_format"+    toKey BarStyle = "bar_style"+    toKey ChangeHandler = "" -- Not sent to the frontend+    toKey Children = "children"+    toKey BoxStyle = "box_style"+    toKey Titles = "_titles"+    toKey SelectedIndex = "selected_index"+    toKey ReadOutMsg = "readout"+    toKey Indent = "indent"+    toKey ContinuousUpdate = "continuous_update"+    toKey Rows = "rows"+    toKey AutoPlay = "autoplay"+    toKey Loop = "loop"+    toKey Controls = "controls"+    toKey Options = "options"+    toKey EnsureOption = "ensure_option"+    toKey Playing = "playing"+    toKey Repeat = "repeat"+    toKey Interval = "interval"+    toKey ShowRepeat = "show_repeat"+    toKey Concise = "concise"+    toKey DateValue = "value"+    toKey Pressed = "pressed"+    toKey Name = "name"+    toKey Mapping = "mapping"+    toKey Connected = "connected"+    toKey Timestamp = "timestamp"+    toKey Buttons = "buttons"+    toKey Axes = "axes"+    toKey Layout = "layout"+    toKey ButtonColor = "button_color"+    toKey FontWeight = "font_weight"+    toKey DescriptionWidth = "description_width"+    toKey BarColor = "bar_color"+    toKey HandleColor = "handle_color"+    toKey ButtonWidth = "button_width"+    toKey Target = "target"+    toKey Source = "source"+    toKey MsgID = "msg_id"+    toKey Outputs = "outputs"+    toKey Style = "style"+    toKey LAlignContent = "align_content"+    toKey LAlignItems = "align_items"+    toKey LAlignSelf = "align_self"+    toKey LBorder = "border"+    toKey LBottom = "bottom"+    toKey LDisplay = "display"+    toKey LFlex = "flex"+    toKey LFlexFlow = "flex_flow"+    toKey LGridArea = "grid_area"+    toKey LGridAutoColumns = "grid_auto_columns"+    toKey LGridAutoFlow = "grid_auto_flow"+    toKey LGridAutoRows = "grid_auto_rows"+    toKey LGridColumn = "grid_column"+    toKey LGridGap = "grid_gap"+    toKey LGridRow = "grid_row"+    toKey LGridTemplateAreas = "grid_template_areas"+    toKey LGridTemplateColumns = "grid_template_columns"+    toKey LGridTemplateRows = "grid_template_rows"+    toKey LHeight = "height"+    toKey LJustifyContent = "justify_content"+    toKey LJustifyItems = "justify_items"+    toKey LLeft = "left"+    toKey LMargin = "margin"+    toKey LMaxHeight = "max_height"+    toKey LMaxWidth = "max_width"+    toKey LMinHeight = "min_height"+    toKey LMinWidth = "min_width"+    toKey LOrder = "order"+    toKey LOverflow = "overflow"+    toKey LOverflowX = "overflow_x"+    toKey LOverflowY = "overflow_y"+    toKey LPadding = "padding"+    toKey LRight = "right"+    toKey LTop = "top"+    toKey LVisibility = "visibility"+    toKey LWidth = "width"++    -- hasKey :: Field -> Bool+    hasKey x = toKey x /= ""   |]
+ src/IHaskell/Display/Widgets/String/Combobox.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module IHaskell.Display.Widgets.String.Combobox+  ( -- * The Combobox Widget+    ComboboxWidget+    -- * Constructor+  , mkCombobox+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Control.Monad (when)+import           Data.Aeson+import           Data.IORef (newIORef)+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+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle++-- | A 'ComboboxWidget' represents a Combobox widget from IPython.html.widgets.+type ComboboxWidget = IPythonWidget 'ComboboxType++-- | Create a new Combobox widget+mkCombobox :: IO ComboboxWidget+mkCombobox = do+  -- Default properties, with a random uuid+  wid <- U.random+  layout <- mkLayout+  dstyle <- mkDescriptionStyle++  let txtWidget = defaultTextWidget "ComboboxView" "ComboboxModel" layout $ StyleWidget dstyle+      boxWidget = (Options =:: [])+                  :& (EnsureOption =:: False)+                  :& RNil+      widgetState = WidgetState $ txtWidget <+> boxWidget++  stateIO <- newIORef widgetState++  let widget = IPythonWidget wid stateIO++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen widget $ toJSON widgetState++  -- Return the widget+  return widget++instance IHaskellWidget ComboboxWidget where+  getCommUUID = uuid+  -- Two possibilities: 1. content -> event -> "submit" 2. sync_data -> value -> <new_value>+  comm tw val _ = do+    case nestedObjectLookup val ["state", "value"] of+      Just (String value) -> setField' tw StringValue value >> triggerChange tw+      _                 -> pure ()+    case nestedObjectLookup val ["content", "event"] of+      Just (String event) -> when (event == "submit") $ triggerSubmit tw+      _                   -> pure ()
src/IHaskell/Display/Widgets/String/HTML.hs view
@@ -9,7 +9,7 @@   ( -- * The HTML Widget     HTMLWidget     -- * Constructor-  , mkHTMLWidget+  , mkHTML   ) where  -- To keep `cabal repl` happy when running from the ihaskell repo@@ -23,17 +23,22 @@ import           IHaskell.IPython.Message.UUID as U  import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle  -- | A 'HTMLWidget' represents a HTML widget from IPython.html.widgets. type HTMLWidget = IPythonWidget 'HTMLType  -- | Create a new HTML widget-mkHTMLWidget :: IO HTMLWidget-mkHTMLWidget = do+mkHTML :: IO HTMLWidget+mkHTML = do   -- Default properties, with a random uuid   wid <- U.random-  let widgetState = WidgetState $ defaultStringWidget "HTMLView" "HTMLModel"+  layout <- mkLayout+  dstyle <- mkDescriptionStyle +  let widgetState = WidgetState $ defaultStringWidget "HTMLView" "HTMLModel" layout $ StyleWidget dstyle+   stateIO <- newIORef widgetState    let widget = IPythonWidget wid stateIO@@ -43,11 +48,6 @@    -- 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/HTMLMath.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module IHaskell.Display.Widgets.String.HTMLMath+  ( -- * The HTMLMath Widget+    HTMLMathWidget+    -- * Constructor+  , mkHTMLMath+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Data.Aeson+import           Data.IORef (newIORef)++import           IHaskell.Display+import           IHaskell.Eval.Widgets+import           IHaskell.IPython.Message.UUID as U++import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle++-- | A 'HTMLMathWidget' represents a HTML Math widget from IPython.html.widgets.+type HTMLMathWidget = IPythonWidget 'HTMLMathType++-- | Create a new HTML widget+mkHTMLMath :: IO HTMLMathWidget+mkHTMLMath = do+  -- Default properties, with a random uuid+  wid <- U.random+  layout <- mkLayout+  dstyle <- mkDescriptionStyle++  let widgetState = WidgetState $ defaultStringWidget "HTMLMathView" "HTMLMathModel" layout $ StyleWidget dstyle++  stateIO <- newIORef widgetState++  let widget = IPythonWidget wid stateIO++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen widget $ toJSON widgetState++  -- Return the widget+  return widget++instance IHaskellWidget HTMLMathWidget where+  getCommUUID = uuid
src/IHaskell/Display/Widgets/String/Label.hs view
@@ -9,7 +9,7 @@   ( -- * The Label Widget     LabelWidget     -- * Constructor-  , mkLabelWidget+  , mkLabel   ) where  -- To keep `cabal repl` happy when running from the ihaskell repo@@ -23,17 +23,22 @@ import           IHaskell.IPython.Message.UUID as U  import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle  -- | A 'LabelWidget' represents a Label widget from IPython.html.widgets. type LabelWidget = IPythonWidget 'LabelType  -- | Create a new Label widget-mkLabelWidget :: IO LabelWidget-mkLabelWidget = do+mkLabel :: IO LabelWidget+mkLabel = do   -- Default properties, with a random uuid   wid <- U.random-  let widgetState = WidgetState $ defaultStringWidget "LabelView" "LabelModel"+  layout <- mkLayout+  dstyle <- mkDescriptionStyle +  let widgetState = WidgetState $ defaultStringWidget "LabelView" "LabelModel" layout $ StyleWidget dstyle+   stateIO <- newIORef widgetState    let widget = IPythonWidget wid stateIO@@ -43,11 +48,6 @@    -- Return the widget   return widget--instance IHaskellDisplay LabelWidget where-  display b = do-    widgetSendView b-    return $ Display []  instance IHaskellWidget LabelWidget where   getCommUUID = uuid
+ src/IHaskell/Display/Widgets/String/Password.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module IHaskell.Display.Widgets.String.Password+  ( -- * The Password Widget+    PasswordWidget+    -- * Constructor+  , mkPassword+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Control.Monad (when)+import           Data.Aeson+import           Data.IORef (newIORef)++import           IHaskell.Display+import           IHaskell.Eval.Widgets+import           IHaskell.IPython.Message.UUID as U++import           IHaskell.Display.Widgets.Types+import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle++-- | A 'PasswordWidget' represents a Password widget from IPython.html.widgets.+type PasswordWidget = IPythonWidget 'PasswordType++-- | Create a new Password widget+mkPassword :: IO PasswordWidget+mkPassword = do+  -- Default properties, with a random uuid+  wid <- U.random+  layout <- mkLayout+  dstyle <- mkDescriptionStyle++  let widgetState = WidgetState $ defaultTextWidget "PasswordView" "PasswordModel" layout $ StyleWidget dstyle++  stateIO <- newIORef widgetState++  let widget = IPythonWidget wid stateIO++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen widget $ toJSON widgetState++  -- Return the widget+  return widget++instance IHaskellWidget PasswordWidget where+  getCommUUID = uuid+  comm tw val _ = do+    case nestedObjectLookup val ["state", "value"] of+      Just (String value) -> setField' tw StringValue value >> triggerChange tw+      _                 -> pure ()+    case nestedObjectLookup val ["content", "event"] of+      Just (String event) -> when (event == "submit") $ triggerSubmit tw+      _                   -> pure ()
src/IHaskell/Display/Widgets/String/Text.hs view
@@ -9,7 +9,7 @@   ( -- * The Text Widget     TextWidget     -- * Constructor-  , mkTextWidget+  , mkText   ) where  -- To keep `cabal repl` happy when running from the ihaskell repo@@ -18,7 +18,6 @@ import           Control.Monad (when) import           Data.Aeson import           Data.IORef (newIORef)-import           Data.Vinyl (Rec(..), (<+>))  import           IHaskell.Display import           IHaskell.Eval.Widgets@@ -26,19 +25,22 @@  import           IHaskell.Display.Widgets.Types import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle  -- | A 'TextWidget' represents a Text widget from IPython.html.widgets. type TextWidget = IPythonWidget 'TextType  -- | Create a new Text widget-mkTextWidget :: IO TextWidget-mkTextWidget = do+mkText :: IO TextWidget+mkText = do   -- Default properties, with a random uuid   wid <- U.random-  let strWidget = defaultStringWidget "TextView" "TextModel"-      txtWidget = (SubmitHandler =:: return ()) :& (ChangeHandler =:: return ()) :& RNil-      widgetState = WidgetState $ strWidget <+> txtWidget+  layout <- mkLayout+  dstyle <- mkDescriptionStyle +  let widgetState = WidgetState $ defaultTextWidget "TextView" "TextModel" layout $ StyleWidget dstyle+   stateIO <- newIORef widgetState    let widget = IPythonWidget wid stateIO@@ -49,16 +51,11 @@   -- 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>+  -- Two possibilities: 1. content -> event -> "submit" 2. state -> value -> <new_value>   comm tw val _ = do-    case nestedObjectLookup val ["sync_data", "value"] of+    case nestedObjectLookup val ["state", "value"] of       Just (String value) -> setField' tw StringValue value >> triggerChange tw       _                 -> pure ()     case nestedObjectLookup val ["content", "event"] of
src/IHaskell/Display/Widgets/String/TextArea.hs view
@@ -25,6 +25,8 @@  import           IHaskell.Display.Widgets.Types import           IHaskell.Display.Widgets.Common+import           IHaskell.Display.Widgets.Layout.LayoutWidget+import           IHaskell.Display.Widgets.Style.DescriptionStyle  -- | A 'TextArea' represents a Textarea widget from IPython.html.widgets. type TextArea = IPythonWidget 'TextAreaType@@ -34,8 +36,15 @@ mkTextArea = do   -- Default properties, with a random uuid   wid <- U.random-  let strAttrs = defaultStringWidget "TextareaView" "TextareaModel"-      wgtAttrs = (ChangeHandler =:: return ()) :& RNil+  layout <- mkLayout+  dstyle <- mkDescriptionStyle++  let strAttrs = defaultStringWidget "TextareaView" "TextareaModel" layout $ StyleWidget dstyle+      wgtAttrs = (Rows =:: Nothing)+                 :& (Disabled =:: False)+                 :& (ContinuousUpdate =:: True)+                 :& (ChangeHandler =:: return ())+                 :& RNil       widgetState = WidgetState $ strAttrs <+> wgtAttrs    stateIO <- newIORef widgetState@@ -48,15 +57,10 @@   -- Return the widget   return widget -instance IHaskellDisplay TextArea where-  display b = do-    widgetSendView b-    return $ Display []- instance IHaskellWidget TextArea where   getCommUUID = uuid   comm widget val _ =-    case nestedObjectLookup val ["sync_data", "value"] of+    case nestedObjectLookup val ["state", "value"] of       Just (String value) -> do         void $ setField' widget StringValue value         triggerChange widget
+ src/IHaskell/Display/Widgets/Style/ButtonStyle.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans  #-}++module IHaskell.Display.Widgets.Style.ButtonStyle+  ( -- * Button style+    ButtonStyle+    -- * Create a new button style+  , mkButtonStyle+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Data.Aeson+import           Data.IORef (newIORef)+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 'ButtonStyle' represents a Button Style from IPython.html.widgets.+type ButtonStyle = IPythonWidget 'ButtonStyleType++-- | Create a new button style+mkButtonStyle :: IO ButtonStyle+mkButtonStyle = do+  wid <- U.random++  let stl = defaultStyleWidget "ButtonStyleModel"+      but = (ButtonColor =:: Nothing)+            :& (FontWeight =:: DefaultWeight)+            :& RNil+      btnStlState = WidgetState (stl <+> but)++  stateIO <- newIORef btnStlState++  let style = IPythonWidget wid stateIO++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen style $ toJSON btnStlState++  -- Return the style widget+  return style++instance IHaskellWidget ButtonStyle where+  getCommUUID = uuid
+ src/IHaskell/Display/Widgets/Style/DescriptionStyle.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans  #-}++module IHaskell.Display.Widgets.Style.DescriptionStyle+  ( -- * Description style+    DescriptionStyle+    -- * Create a new description style+  , mkDescriptionStyle+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Data.Aeson+import           Data.IORef (newIORef)++import           IHaskell.Display+import           IHaskell.Eval.Widgets+import           IHaskell.IPython.Message.UUID as U++import           IHaskell.Display.Widgets.Types++-- | A 'DescriptionStyle' represents a Button Style from IPython.html.widgets.+type DescriptionStyle = IPythonWidget 'DescriptionStyleType++-- | Create a new button style+mkDescriptionStyle :: IO DescriptionStyle+mkDescriptionStyle = do+  wid <- U.random++  let stl = defaultDescriptionStyleWidget "DescriptionStyleModel"+      btnStlState = WidgetState stl++  stateIO <- newIORef btnStlState++  let style = IPythonWidget wid stateIO++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen style $ toJSON btnStlState++  -- Return the style widget+  return style++instance IHaskellWidget DescriptionStyle where+  getCommUUID = uuid
+ src/IHaskell/Display/Widgets/Style/ProgressStyle.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans  #-}++module IHaskell.Display.Widgets.Style.ProgressStyle+  ( -- * Progress style+    ProgressStyle+    -- * Create a new progress style+  , mkProgressStyle+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Data.Aeson+import           Data.IORef (newIORef)+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 'ProgressStyle' represents a Button Style from IPython.html.widgets.+type ProgressStyle = IPythonWidget 'ProgressStyleType++-- | Create a new button style+mkProgressStyle :: IO ProgressStyle+mkProgressStyle = do+  wid <- U.random++  let stl = defaultDescriptionStyleWidget "ProgressStyleModel"+      but = (BarColor =:: Nothing)+            :& RNil+      btnStlState = WidgetState (stl <+> but)++  stateIO <- newIORef btnStlState++  let style = IPythonWidget wid stateIO++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen style $ toJSON btnStlState++  -- Return the style widget+  return style++instance IHaskellWidget ProgressStyle where+  getCommUUID = uuid
+ src/IHaskell/Display/Widgets/Style/SliderStyle.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans  #-}++module IHaskell.Display.Widgets.Style.SliderStyle+  ( -- * Slider style+    SliderStyle+    -- * Create a new slider style+  , mkSliderStyle+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Data.Aeson+import           Data.IORef (newIORef)+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 'SliderStyle' represents a Button Style from IPython.html.widgets.+type SliderStyle = IPythonWidget 'SliderStyleType++-- | Create a new button style+mkSliderStyle :: IO SliderStyle+mkSliderStyle = do+  wid <- U.random++  let stl = defaultDescriptionStyleWidget "SliderStyleModel"+      but = (HandleColor =:: Nothing)+            :& RNil+      btnStlState = WidgetState (stl <+> but)++  stateIO <- newIORef btnStlState++  let style = IPythonWidget wid stateIO++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen style $ toJSON btnStlState++  -- Return the style widget+  return style++instance IHaskellWidget SliderStyle where+  getCommUUID = uuid
+ src/IHaskell/Display/Widgets/Style/ToggleButtonsStyle.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans  #-}++module IHaskell.Display.Widgets.Style.ToggleButtonsStyle+  ( -- * ToggleButtons style+    ToggleButtonsStyle+    -- * Create a new toggle buttons style+  , mkToggleButtonsStyle+  ) where++-- To keep `cabal repl` happy when running from the ihaskell repo+import           Prelude++import           Data.Aeson+import           Data.IORef (newIORef)+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 'ToggleButtonsStyle' represents a Button Style from IPython.html.widgets.+type ToggleButtonsStyle = IPythonWidget 'ToggleButtonsStyleType++-- | Create a new button style+mkToggleButtonsStyle :: IO ToggleButtonsStyle+mkToggleButtonsStyle = do+  wid <- U.random++  let stl = defaultDescriptionStyleWidget "ToggleButtonsStyleModel"+      but = (ButtonWidth =:: "")+            :& (FontWeight =:: DefaultWeight)+            :& RNil+      btnStlState = WidgetState (stl <+> but)++  stateIO <- newIORef btnStlState++  let style = IPythonWidget wid stateIO++  -- Open a comm for this widget, and store it in the kernel state+  widgetSendOpen style $ toJSON btnStlState++  -- Return the style widget+  return style++instance IHaskellWidget ToggleButtonsStyle where+  getCommUUID = uuid
src/IHaskell/Display/Widgets/Types.hs view
@@ -15,893 +15,986 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE CPP #-}---- | 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 (css lengths) need to be sent--- as Strings (@PixCount@).------ 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 be found in the messaging--- specification.-module IHaskell.Display.Widgets.Types where--import           Control.Monad (unless, join, when, void)-import           Control.Applicative ((<$>))-import qualified Control.Exception as Ex-import           Data.Typeable (Typeable, TypeRep, typeOf)-import           Data.IORef (IORef, readIORef, modifyIORef)-import           Data.Text (Text, pack)-import           System.IO.Error-import           System.Posix.IO-import           Text.Printf (printf)--import           Data.Aeson hiding (pairs)-import           Data.Aeson.Types (Pair)-import           Data.Int (Int16)-#if MIN_VERSION_vinyl(0,9,0)-import           Data.Vinyl (Rec(..), Dict(..))-import           Data.Vinyl.Recursive ((<+>), recordToList, reifyConstraint, rmap)-#else-import           Data.Vinyl (Rec(..), (<+>), recordToList, reifyConstraint, rmap, Dict(..))-#endif-import           Data.Vinyl.Functor (Compose(..), Const(..))-import           Data.Vinyl.Lens (rget, rput, type (∈))-import           Data.Vinyl.TypeLevel (RecAll)--#if MIN_VERSION_singletons(2,4,0)-import           Data.Singletons.Prelude.List-#else-import           Data.Singletons.Prelude ((:++))-#endif--import           Data.Singletons.TH--import           GHC.IO.Exception--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--#if MIN_VERSION_singletons(2,4,0)--- Versions of the "singletons" package are tightly tied to the GHC version.--- Singletons versions 2.3.* and earlier used the type level operator ':++'--- for appending type level lists while 2.4.* and latter use the normal value--- level list append operator '++'.--- To maintain compatibility across GHC versions we keep using the ':++'--- operator for now.-type (a :++ b) = a ++ b-#endif---- Classes from IPython's widget hierarchy. Defined as such to reduce code duplication.-type WidgetClass = ['S.ViewModule, 'S.ViewName, 'S.ModelModule, 'S.ModelName,-  '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.SelectedValues, 'S.SelectedLabels, '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.ModelModule = Text-        FieldType 'S.ModelName = 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 = PixCount-        FieldType 'S.Height = PixCount-        FieldType 'S.Padding = PixCount-        FieldType 'S.Margin = PixCount-        FieldType 'S.Color = Text-        FieldType 'S.BackgroundColor = Text-        FieldType 'S.BorderColor = Text-        FieldType 'S.BorderWidth = PixCount-        FieldType 'S.BorderRadius = PixCount-        FieldType 'S.BorderStyle = BorderStyleValue-        FieldType 'S.FontStyle = FontStyleValue-        FieldType 'S.FontWeight = FontWeightValue-        FieldType 'S.FontSize = PixCount-        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-        FieldType 'S.ReadOutMsg = Text-        FieldType 'S.Child = Maybe ChildWidget-        FieldType 'S.Selector = Text---- | 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 PixCount where-  lowerBound = - fromIntegral (maxBound :: Int16)-  upperBound = fromIntegral (maxBound :: Int16)--instance CustomBounded Integer where-  lowerBound = - fromIntegral (maxBound :: Int16)-  upperBound = fromIntegral (maxBound :: Int16)--instance CustomBounded Double where-  lowerBound = - fromIntegral (maxBound :: Int16)-  upperBound = fromIntegral (maxBound :: Int16)---- Different types of widgets. Every widget in IPython has a corresponding WidgetType-data WidgetType = ButtonType-                | ImageType-                | OutputType-                | HTMLType-                | LabelType-                | TextType-                | TextAreaType-                | CheckBoxType-                | ToggleButtonType-                | ValidType-                | DropdownType-                | RadioButtonsType-                | SelectType-                | ToggleButtonsType-                | SelectMultipleType-                | IntTextType-                | BoundedIntTextType-                | IntSliderType-                | IntProgressType-                | IntRangeSliderType-                | FloatTextType-                | BoundedFloatTextType-                | FloatSliderType-                | FloatProgressType-                | FloatRangeSliderType-                | BoxType-                | 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.Width, 'S.Height, 'S.B64Value]-  WidgetFields 'OutputType = DOMWidgetClass-  WidgetFields 'HTMLType = StringClass-  WidgetFields 'LabelType = StringClass-  WidgetFields 'TextType =-                  StringClass :++ ['S.SubmitHandler, 'S.ChangeHandler]--  -- Type level lists with a single element need both the list and the-  -- constructor ticked, and a space between the open square bracket and-  -- the first constructor. See https://ghc.haskell.org/trac/ghc/ticket/15601-  WidgetFields 'TextAreaType = StringClass :++ '[ 'S.ChangeHandler]--  WidgetFields 'CheckBoxType = BoolClass-  WidgetFields 'ToggleButtonType =-                  BoolClass :++ ['S.Tooltip, 'S.Icon, 'S.ButtonStyle]-  WidgetFields 'ValidType = BoolClass :++ '[ 'S.ReadOutMsg]-  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.Orientation, '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.Orientation, 'S.BarStyle]-  WidgetFields 'FloatRangeSliderType =-                  BoundedFloatRangeClass :++-                    ['S.Orientation, 'S.ShowRange, 'S.ReadOut, 'S.SliderColor]-  WidgetFields 'BoxType = BoxClass-  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) where-  Attr :: Typeable (FieldType f)-       => { _value :: AttrVal (FieldType f)-          , _verify :: FieldType f -> IO (FieldType f)-          , _field :: Field-          } -> Attr f--getFieldType :: Attr f -> TypeRep-getFieldType Attr { _value = attrval } = typeOf $ unwrap attrval--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.ModelModule) where-  toPairs x = ["_model_module" .= toJSON x]--instance ToPairs (Attr 'S.ModelName) where-  toPairs x = ["_model_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]--instance ToPairs (Attr 'S.ReadOutMsg) where-  toPairs x = ["readout" .= toJSON x]--instance ToPairs (Attr 'S.Child) where-  toPairs x = ["child" .= toJSON x]--instance ToPairs (Attr 'S.Selector) where-  toPairs x = ["selector" .= toJSON x]---- | Store the value for a field, as an object parametrized by the Field. No verification is done--- for these values.-(=::) :: (SingI f, Typeable (FieldType 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-  | otherwise = error "The impossible happened in IHaskell.Display.Widgets.Types.rangeCheck"---- | Store a numeric value, with verification mechanism for its range.-ranged :: (SingI f, Num (FieldType f), Ord (FieldType f), Typeable (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), Typeable (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) => Sing f -> Field-reflect = fromSing---- | A record representing an object of the Widget class from IPython-defaultWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr WidgetClass-defaultWidget viewName modelName = (ViewModule =:: "jupyter-js-widgets")-                                   :& (ViewName =:: viewName)-                                   :& (ModelModule =:: "jupyter-js-widgets")-                                   :& (ModelName =:: modelName)-                                   :& (MsgThrottle =:+ 3)-                                   :& (Version =:: 0)-                                   :& (DisplayHandler =:: return ())-                                   :& RNil---- | A record representing an object of the DOMWidget class from IPython-defaultDOMWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr DOMWidgetClass-defaultDOMWidget viewName modelName = defaultWidget viewName modelName <+> 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 -> FieldType 'S.ModelName -> Rec Attr StringClass-defaultStringWidget viewName modelName = defaultDOMWidget viewName modelName <+> strAttrs-  where-    strAttrs = (StringValue =:: "")-               :& (Disabled =:: False)-               :& (Description =:: "")-               :& (Placeholder =:: "")-               :& RNil---- | A record representing a widget of the _Bool class from IPython-defaultBoolWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr BoolClass-defaultBoolWidget viewName modelName = defaultDOMWidget viewName modelName <+> 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 -> FieldType 'S.ModelName -> Rec Attr SelectionClass-defaultSelectionWidget viewName modelName = defaultDOMWidget viewName modelName <+> 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 -> FieldType 'S.ModelName -> Rec Attr MultipleSelectionClass-defaultMultipleSelectionWidget viewName modelName = defaultDOMWidget viewName modelName <+> mulSelAttrs-  where-    mulSelAttrs = (Options =:: OptionLabels [])-                  :& (SelectedValues =:: [])-                  :& (SelectedLabels =:: [])-                  :& (Disabled =:: False)-                  :& (Description =:: "")-                  :& (SelectionHandler =:: return ())-                  :& RNil---- | A record representing a widget of the _Int class from IPython-defaultIntWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr IntClass-defaultIntWidget viewName modelName = defaultDOMWidget viewName modelName <+> 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 -> FieldType 'S.ModelName -> Rec Attr BoundedIntClass-defaultBoundedIntWidget viewName modelName = defaultIntWidget viewName modelName <+> 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 -> FieldType 'S.ModelName -> Rec Attr IntRangeClass-defaultIntRangeWidget viewName modelName = defaultIntWidget viewName modelName <+> 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 -> FieldType 'S.ModelName -> Rec Attr BoundedIntRangeClass-defaultBoundedIntRangeWidget viewName modelName = defaultIntRangeWidget viewName modelName <+> 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 -> FieldType 'S.ModelName -> Rec Attr FloatClass-defaultFloatWidget viewName modelName = defaultDOMWidget viewName modelName <+> 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 -> FieldType 'S.ModelName -> Rec Attr BoundedFloatClass-defaultBoundedFloatWidget viewName modelName = defaultFloatWidget viewName modelName <+> 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 -> FieldType 'S.ModelName -> Rec Attr FloatRangeClass-defaultFloatRangeWidget viewName modelName = defaultFloatWidget viewName modelName <+> 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 -> FieldType 'S.ModelName -> Rec Attr BoundedFloatRangeClass-defaultBoundedFloatRangeWidget viewName modelName = defaultFloatRangeWidget viewName modelName <+> 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 -> FieldType 'S.ModelName -> Rec Attr BoxClass-defaultBoxWidget viewName modelName = defaultDOMWidget viewName modelName <+> intAttrs-  where-    intAttrs = (Children =:: [])-               :& (OverflowX =:: DefaultOverflow)-               :& (OverflowY =:: DefaultOverflow)-               :& (BoxStyle =:: DefaultBox)-               :& RNil---- | A record representing a widget of the _SelectionContainer class from IPython-defaultSelectionContainerWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr SelectionContainerClass-defaultSelectionContainerWidget viewName modelName = defaultBoxWidget viewName modelName <+> 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)-#if MIN_VERSION_vinyl(0,9,0)-getAttr widget _ = rget <$> _getState <$> readIORef (state widget)-#else-getAttr widget sfield = rget sfield <$> _getState <$> readIORef (state widget)-#endif---- | 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, TypeRep) f-      convert attr = Const (_field attr, getFieldType attr)--      renderRow (fname, ftype) = printf "%s ::: %s" (show fname) (show ftype)-      rows = map renderRow . recordToList . rmap convert $ _getState st-  mapM_ putStrLn rows---- 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+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- | 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 (css lengths) need to be sent+-- as Strings (@PixCount@).+--+-- 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 be found in the messaging+-- specification.+module IHaskell.Display.Widgets.Types where++import           Control.Monad (unless, join, when, void,mzero)+import           Control.Applicative ((<$>))+import qualified Control.Exception as Ex+import           Data.Typeable (Typeable, TypeRep, typeOf)+import           Data.IORef (IORef, readIORef, modifyIORef)+import           Data.String+import           Data.Text (Text, pack)+import           System.IO.Error+import           System.Posix.IO+import           Text.Printf (printf)++import           Data.Aeson hiding (pairs)+import           Data.Aeson.Types (Pair)+import           Data.ByteString (ByteString)+import           Data.Int (Int16)+#if MIN_VERSION_vinyl(0,9,0)+import           Data.Vinyl (Rec(..), Dict(..))+import           Data.Vinyl.Recursive ((<+>), recordToList, reifyConstraint, rmap)+#else+import           Data.Vinyl (Rec(..), (<+>), recordToList, reifyConstraint, rmap, Dict(..))+#endif+import           Data.Vinyl.Functor (Compose(..), Const(..))+import           Data.Vinyl.Lens (rget, rput, type (∈))+import           Data.Vinyl.TypeLevel (RecAll)++#if MIN_VERSION_singletons(3,0,0)+import           Data.List.Singletons+#elif MIN_VERSION_singletons(2,4,0)+import           Data.Singletons.Prelude.List+#else+import           Data.Singletons.Prelude ((:++))+#endif++#if MIN_VERSION_singletons(3,0,0)+import           Data.Singletons.Base.TH+#else+import           Data.Singletons.TH+#endif++import           Data.Text.Lazy (unpack)+import           Data.Text.Lazy.Encoding++import           GHC.IO.Exception++import           IHaskell.Eval.Widgets (widgetSendUpdate, widgetSendView)+import           IHaskell.Display (IHaskellWidget(..), IHaskellDisplay(..), Display(..), widgetdisplay, base64)+import           IHaskell.IPython.Types (StreamType(..))+import           IHaskell.IPython.Message.UUID++import           IHaskell.Display.Widgets.Singletons (Field, SField, toKey, HasKey)+import qualified IHaskell.Display.Widgets.Singletons as S+import           IHaskell.Display.Widgets.Common++#if MIN_VERSION_singletons(2,4,0)+-- Versions of the "singletons" package are tightly tied to the GHC version.+-- Singletons versions 2.3.* and earlier used the type level operator ':++'+-- for appending type level lists while 2.4.* and latter use the normal value+-- level list append operator '++'.+-- To maintain compatibility across GHC versions we keep using the ':++'+-- operator for now.+type (a :++ b) = a ++ b+#endif++-- Classes from IPython's widget hierarchy. Defined as such to reduce code duplication.+type CoreWidgetClass = ['S.ViewModule, 'S.ViewModuleVersion, 'S.ModelModule, 'S.ModelModuleVersion ]++type DOMWidgetClass = ['S.ModelName, 'S.ViewName, 'S.DOMClasses, 'S.Tooltip, 'S.Layout, 'S.DisplayHandler]++type StyleWidgetClass = ['S.ModelName, 'S.ViewName] :++ CoreWidgetClass++type DescriptionWidgetClass = CoreWidgetClass :++ DOMWidgetClass :++ ['S.Description,'S.Style]++type StringClass = DescriptionWidgetClass :++ ['S.StringValue, 'S.Placeholder]++type TextClass = StringClass :++ [ 'S.Disabled, 'S.ContinuousUpdate, 'S.SubmitHandler, 'S.ChangeHandler]++type BoolClass = DescriptionWidgetClass :++ ['S.BoolValue, 'S.Disabled, 'S.ChangeHandler]++type SelectionClass = DescriptionWidgetClass :++ ['S.OptionsLabels, 'S.OptionalIndex, 'S.Disabled, 'S.SelectionHandler]++type SelectionNonemptyClass = DescriptionWidgetClass :++ ['S.OptionsLabels, 'S.Index, 'S.Disabled, 'S.SelectionHandler]++type MultipleSelectionClass = DescriptionWidgetClass :++ ['S.OptionsLabels, 'S.Indices, 'S.Disabled, 'S.SelectionHandler]++type IntClass = DescriptionWidgetClass :++ [ 'S.IntValue, 'S.ChangeHandler ]++type BoundedIntClass = IntClass :++ ['S.MaxInt, 'S.MinInt]++type IntRangeClass = IntClass :++ ['S.IntPairValue, 'S.LowerInt, 'S.UpperInt]++type BoundedIntRangeClass = IntRangeClass :++ ['S.MaxInt, 'S.MinInt]++type FloatClass = DescriptionWidgetClass :++ [ 'S.FloatValue, 'S.ChangeHandler ]++type BoundedFloatClass = FloatClass :++ ['S.MinFloat, 'S.MaxFloat]++type BoundedLogFloatClass = FloatClass :++ [ 'S.MinFloat, 'S.MaxFloat, 'S.BaseFloat ]++type FloatRangeClass = FloatClass :++ '[ 'S.FloatPairValue ]++type BoundedFloatRangeClass = FloatRangeClass :++ ['S.StepFloat, 'S.MinFloat, 'S.MaxFloat]++type BoxClass = CoreWidgetClass :++ DOMWidgetClass :++ ['S.Children, 'S.BoxStyle]++type SelectionContainerClass = BoxClass :++ ['S.Titles, 'S.SelectedIndex, 'S.ChangeHandler]++type MediaClass = CoreWidgetClass :++ DOMWidgetClass :++ '[ 'S.BSValue ]++type DescriptionStyleClass = StyleWidgetClass :++ '[ 'S.DescriptionWidth ]++type LinkClass = CoreWidgetClass :++ ['S.ModelName, 'S.Target, 'S.Source]++-- Types associated with Fields.+type family FieldType (f :: Field) :: *++type instance FieldType 'S.ViewModule = Text+type instance FieldType 'S.ViewModuleVersion = Text+type instance FieldType 'S.ViewName = Text+type instance FieldType 'S.ModelModule = Text+type instance FieldType 'S.ModelModuleVersion = Text+type instance FieldType 'S.ModelName = Text+type instance FieldType 'S.Layout = IPythonWidget 'LayoutType+type instance FieldType 'S.DisplayHandler = IO ()+type instance FieldType 'S.DOMClasses = [Text]+type instance FieldType 'S.Width = PixCount+type instance FieldType 'S.Height = PixCount+type instance FieldType 'S.Description = Text+type instance FieldType 'S.ClickHandler = IO ()+type instance FieldType 'S.SubmitHandler = IO ()+type instance FieldType 'S.Disabled = Bool+type instance FieldType 'S.StringValue = Text+type instance FieldType 'S.Placeholder = Text+type instance FieldType 'S.Tooltip = Maybe Text+type instance FieldType 'S.Icon = Text+type instance FieldType 'S.ButtonStyle = ButtonStyleValue+type instance FieldType 'S.BSValue = JSONByteString+type instance FieldType 'S.ImageFormat = ImageFormatValue+type instance FieldType 'S.BoolValue = Bool+type instance FieldType 'S.OptionsLabels = [Text]+type instance FieldType 'S.Index = Integer+type instance FieldType 'S.OptionalIndex = Maybe Integer+type instance FieldType 'S.SelectionHandler = IO ()+type instance FieldType 'S.Tooltips = [Text]+type instance FieldType 'S.Icons = [Text]+type instance FieldType 'S.Indices = [Integer]+type instance FieldType 'S.IntValue = Integer+type instance FieldType 'S.StepInt = Maybe Integer+type instance FieldType 'S.MinInt = Integer+type instance FieldType 'S.MaxInt = Integer+type instance FieldType 'S.LowerInt = Integer+type instance FieldType 'S.UpperInt = Integer+type instance FieldType 'S.IntPairValue = (Integer, Integer)+type instance FieldType 'S.Orientation = OrientationValue+type instance FieldType 'S.BaseFloat = Double+type instance FieldType 'S.ReadOut = Bool+type instance FieldType 'S.ReadOutFormat = Text+type instance FieldType 'S.BarStyle = BarStyleValue+type instance FieldType 'S.FloatValue = Double+type instance FieldType 'S.StepFloat = Maybe Double+type instance FieldType 'S.MinFloat = Double+type instance FieldType 'S.MaxFloat = Double+type instance FieldType 'S.LowerFloat = Double+type instance FieldType 'S.UpperFloat = Double+type instance FieldType 'S.FloatPairValue = (Double, Double)+type instance FieldType 'S.ChangeHandler = IO ()+type instance FieldType 'S.Children = [ChildWidget]+type instance FieldType 'S.BoxStyle = BoxStyleValue+type instance FieldType 'S.Titles = [Text]+type instance FieldType 'S.SelectedIndex = Maybe Integer+type instance FieldType 'S.ReadOutMsg = Text+type instance FieldType 'S.Indent = Bool+type instance FieldType 'S.ContinuousUpdate = Bool+type instance FieldType 'S.Rows = Maybe Integer+type instance FieldType 'S.AudioFormat = AudioFormatValue+type instance FieldType 'S.VideoFormat = VideoFormatValue+type instance FieldType 'S.AutoPlay = Bool+type instance FieldType 'S.Loop = Bool+type instance FieldType 'S.Controls = Bool+type instance FieldType 'S.Options = [Text]+type instance FieldType 'S.EnsureOption = Bool+type instance FieldType 'S.Playing = Bool+type instance FieldType 'S.Repeat = Bool+type instance FieldType 'S.Interval = Integer+type instance FieldType 'S.ShowRepeat = Bool+type instance FieldType 'S.Concise = Bool+type instance FieldType 'S.DateValue = Date+type instance FieldType 'S.Pressed = Bool+type instance FieldType 'S.Name = Text+type instance FieldType 'S.Mapping = Text+type instance FieldType 'S.Connected = Bool+type instance FieldType 'S.Timestamp = Double+type instance FieldType 'S.Buttons = [IPythonWidget 'ControllerButtonType]+type instance FieldType 'S.Axes = [IPythonWidget 'ControllerAxisType]+type instance FieldType 'S.ButtonColor = Maybe String+type instance FieldType 'S.FontWeight = FontWeightValue+type instance FieldType 'S.DescriptionWidth = String+type instance FieldType 'S.BarColor = Maybe String+type instance FieldType 'S.HandleColor = Maybe String+type instance FieldType 'S.ButtonWidth = String+type instance FieldType 'S.Target = WidgetFieldPair+type instance FieldType 'S.Source = WidgetFieldPair+type instance FieldType 'S.MsgID = Text+type instance FieldType 'S.Outputs = [OutputMsg]+type instance FieldType 'S.Style = StyleWidget++-- | 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)++-- | Can be used to put different styles in a same FieldType.+data StyleWidget = forall w. RecAll Attr (WidgetFields w) ToPairs => StyleWidget (IPythonWidget w)++instance ToJSON (IPythonWidget w) where+  toJSON x = toJSON . pack $ "IPY_MODEL_" ++ uuidToString (uuid x)++instance ToJSON ChildWidget where+  toJSON (ChildWidget x) = toJSON x++instance ToJSON StyleWidget where+  toJSON (StyleWidget x) = toJSON 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 PixCount where+  lowerBound = - fromIntegral (maxBound :: Int16)+  upperBound = fromIntegral (maxBound :: Int16)++instance CustomBounded Integer where+  lowerBound = - fromIntegral (maxBound :: Int16)+  upperBound = fromIntegral (maxBound :: Int16)++instance CustomBounded Double where+  lowerBound = - fromIntegral (maxBound :: Int16)+  upperBound = fromIntegral (maxBound :: Int16)++-- | This type only fits if the field is among the widget's fields, and it has a key+data WidgetFieldPair = forall w f. (f ∈ WidgetFields w, HasKey f ~ 'True, RecAll Attr (WidgetFields w) ToPairs) => WidgetFieldPair (IPythonWidget w) (SField f) | EmptyWT++instance ToJSON WidgetFieldPair where+  toJSON EmptyWT = Null+  toJSON (WidgetFieldPair w f) = toJSON [toJSON w, toJSON $ pack $ toKey $ fromSing f]++-- Different types of widgets. Every widget in IPython has a corresponding WidgetType+data WidgetType = ButtonType+                | ColorPickerType+                | DatePickerType+                | AudioType+                | ImageType+                | VideoType+                | OutputType+                | ComboboxType+                | HTMLType+                | HTMLMathType+                | LabelType+                | PasswordType+                | TextType+                | TextAreaType+                | CheckBoxType+                | ToggleButtonType+                | ValidType+                | DropdownType+                | RadioButtonsType+                | SelectType+                | SelectionSliderType+                | SelectionRangeSliderType+                | ToggleButtonsType+                | SelectMultipleType+                | IntTextType+                | BoundedIntTextType+                | IntSliderType+                | PlayType+                | IntProgressType+                | IntRangeSliderType+                | FloatTextType+                | BoundedFloatTextType+                | FloatSliderType+                | FloatLogSliderType+                | FloatProgressType+                | FloatRangeSliderType+                | BoxType+                | GridBoxType+                | HBoxType+                | VBoxType+                | AccordionType+                | TabType+                | StackedType+                | ControllerButtonType+                | ControllerAxisType+                | ControllerType+                | LinkType+                | DirectionalLinkType+                | LayoutType+                | ButtonStyleType+                | DescriptionStyleType+                | ProgressStyleType+                | SliderStyleType+                | ToggleButtonsStyleType++-- Fields associated with a widget++type family WidgetFields (w :: WidgetType) :: [Field]+type instance WidgetFields 'ButtonType =+                DescriptionWidgetClass :+++                  ['S.Disabled, 'S.Icon, 'S.ButtonStyle,'S.ClickHandler]+type instance WidgetFields 'ColorPickerType =+                DescriptionWidgetClass :+++                  ['S.StringValue, 'S.Concise, 'S.Disabled, 'S.ChangeHandler]+type instance WidgetFields 'DatePickerType =+                DescriptionWidgetClass :+++                  ['S.DateValue, 'S.Disabled, 'S.ChangeHandler]++type instance WidgetFields 'AudioType =+                MediaClass :++ ['S.AudioFormat, 'S.AutoPlay, 'S.Loop, 'S.Controls]+type instance WidgetFields 'ImageType =+                MediaClass :++ ['S.ImageFormat, 'S.Width, 'S.Height]+type instance WidgetFields 'VideoType =+                MediaClass :++ ['S.VideoFormat, 'S.Width, 'S.Height, 'S.AutoPlay, 'S.Loop, 'S.Controls]++type instance WidgetFields 'OutputType = DOMWidgetClass :++ ['S.ViewModule,'S.ModelModule,'S.ViewModuleVersion,'S.ModelModuleVersion,'S.MsgID,'S.Outputs]+type instance WidgetFields 'HTMLType = StringClass+type instance WidgetFields 'HTMLMathType = StringClass+type instance WidgetFields 'ComboboxType = TextClass :++ [ 'S.Options, 'S.EnsureOption ]+type instance WidgetFields 'LabelType = StringClass+type instance WidgetFields 'PasswordType = TextClass+type instance WidgetFields 'TextType = TextClass++-- Type level lists with a single element need both the list and the+-- constructor ticked, and a space between the open square bracket and+-- the first constructor. See https://ghc.haskell.org/trac/ghc/ticket/15601+type instance WidgetFields 'TextAreaType =+                StringClass :+++                  [ 'S.Rows, 'S.Disabled, 'S.ContinuousUpdate, 'S.ChangeHandler]++type instance WidgetFields 'CheckBoxType = BoolClass :++ '[ 'S.Indent ]+type instance WidgetFields 'ToggleButtonType = BoolClass :++ ['S.Icon, 'S.ButtonStyle]+type instance WidgetFields 'ValidType = BoolClass :++ '[ 'S.ReadOutMsg ]+type instance WidgetFields 'DropdownType = SelectionClass+type instance WidgetFields 'RadioButtonsType = SelectionClass+type instance WidgetFields 'SelectType = SelectionClass :++ '[ 'S.Rows ]+type instance WidgetFields 'SelectionSliderType = SelectionNonemptyClass :++ '[ 'S.Orientation, 'S.ReadOut, 'S.ContinuousUpdate ]+type instance WidgetFields 'SelectionRangeSliderType = MultipleSelectionClass :++ '[ 'S.Orientation, 'S.ReadOut, 'S.ContinuousUpdate ]+type instance WidgetFields 'ToggleButtonsType =+                SelectionClass :++ ['S.Tooltips, 'S.Icons, 'S.ButtonStyle]+type instance WidgetFields 'SelectMultipleType = MultipleSelectionClass :++ '[ 'S.Rows ]+type instance WidgetFields 'IntTextType = IntClass :++ [ 'S.Disabled, 'S.ContinuousUpdate, 'S.StepInt ]+type instance WidgetFields 'BoundedIntTextType = BoundedIntClass :++ [ 'S.Disabled, 'S.ContinuousUpdate, 'S.StepInt ]+type instance WidgetFields 'IntSliderType =+                BoundedIntClass :+++                  [ 'S.StepInt, 'S.Orientation, 'S.ReadOut, 'S.ReadOutFormat, 'S.ContinuousUpdate, 'S.Disabled ]+type instance WidgetFields 'PlayType =+                BoundedIntClass :+++                  [ 'S.Playing, 'S.Repeat, 'S.Interval, 'S.StepInt, 'S.Disabled, 'S.ShowRepeat ]+type instance WidgetFields 'IntProgressType =+                BoundedIntClass :++ ['S.Orientation, 'S.BarStyle]+type instance WidgetFields 'IntRangeSliderType =+                BoundedIntRangeClass :+++                  ['S.StepInt, 'S.Orientation, 'S.ReadOut, 'S.ReadOutFormat, 'S.ContinuousUpdate, 'S.Disabled ]+type instance WidgetFields 'FloatTextType = FloatClass :++ '[ 'S.Disabled, 'S.ContinuousUpdate, 'S.StepFloat ]+type instance WidgetFields 'BoundedFloatTextType = BoundedFloatClass :++ '[ 'S.Disabled, 'S.ContinuousUpdate, 'S.StepFloat ]+type instance WidgetFields 'FloatSliderType =+                BoundedFloatClass :+++                  ['S.StepFloat, 'S.Orientation, 'S.ReadOut, 'S.ReadOutFormat, 'S.ContinuousUpdate, 'S.Disabled ]+type instance WidgetFields 'FloatLogSliderType =+                BoundedLogFloatClass :+++                  ['S.StepFloat, 'S.Orientation, 'S.ReadOut, 'S.ReadOutFormat, 'S.ContinuousUpdate, 'S.Disabled, 'S.BaseFloat]+type instance WidgetFields 'FloatProgressType =+                BoundedFloatClass :++ ['S.Orientation, 'S.BarStyle]+type instance WidgetFields 'FloatRangeSliderType =+                BoundedFloatRangeClass :+++                  ['S.StepFloat, 'S.Orientation, 'S.ReadOut, 'S.ReadOutFormat, 'S.ContinuousUpdate, 'S.Disabled ]+type instance WidgetFields 'BoxType = BoxClass+type instance WidgetFields 'GridBoxType = BoxClass+type instance WidgetFields 'HBoxType = BoxClass+type instance WidgetFields 'VBoxType = BoxClass+type instance WidgetFields 'AccordionType = SelectionContainerClass+type instance WidgetFields 'TabType = SelectionContainerClass+type instance WidgetFields 'StackedType = SelectionContainerClass+type instance WidgetFields 'ControllerType =+  CoreWidgetClass :++ DOMWidgetClass :+++    ['S.Index, 'S.Name, 'S.Mapping, 'S.Connected, 'S.Timestamp, 'S.Buttons, 'S.Axes, 'S.ChangeHandler ]+type instance WidgetFields 'ControllerAxisType = CoreWidgetClass :++ DOMWidgetClass :++ '[ 'S.FloatValue, 'S.ChangeHandler ]+type instance WidgetFields 'ControllerButtonType = CoreWidgetClass :++ DOMWidgetClass :++ [ 'S.FloatValue, 'S.Pressed, 'S.ChangeHandler ]+type instance WidgetFields 'LinkType = LinkClass+type instance WidgetFields 'DirectionalLinkType = LinkClass++type instance WidgetFields 'ButtonStyleType = StyleWidgetClass :++ ['S.ButtonColor, 'S.FontWeight]+type instance WidgetFields 'DescriptionStyleType = DescriptionStyleClass+type instance WidgetFields 'ProgressStyleType = DescriptionStyleClass :++ '[ 'S.BarColor ]+type instance WidgetFields 'SliderStyleType = DescriptionStyleClass :++ '[ 'S.HandleColor ]+type instance WidgetFields 'ToggleButtonsStyleType = DescriptionStyleClass :++ ['S.ButtonWidth,'S.FontWeight]++-- 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) where+  Attr :: Typeable (FieldType f)+       => { _value :: AttrVal (FieldType f)+          , _verify :: FieldType f -> IO (FieldType f)+          , _field :: Field+          , _ro :: Bool+          } -> Attr f++getFieldType :: Attr f -> TypeRep+getFieldType Attr { _value = attrval } = typeOf $ unwrap attrval++instance ToJSON (FieldType f) => ToJSON (Attr f) where+  toJSON attr =+    case _value attr of+      Dummy _ -> object []+      Real x  -> toJSON x++-- Types that can be converted to Aeson Pairs.+class ToPairs a where+  toPairs :: a -> [Pair]++-- From https://stackoverflow.com/questions/68648670/duplicate-instance-declaration-using-haskell-singletons+-- TODO: Check if it can be done with something from Singletons+instance ToPairs' (HasKey f) f => ToPairs (Attr f) where+  toPairs = toPairs'++class hk ~ HasKey a => ToPairs' hk a where+  toPairs' :: Attr a -> [Pair]++instance HasKey f ~ 'False => ToPairs' 'False f where+  toPairs' _ = []++instance (ToJSON (FieldType f), HasKey f ~ 'True) => ToPairs' 'True f where+  toPairs' x = [ fromString (toKey $ _field x) .= toJSON x ]++newtype JSONByteString = JSONByteString ByteString+  deriving (Eq,Ord)++instance ToJSON JSONByteString where+  toJSON (JSONByteString x) = toJSON $ base64 x++instance IsString JSONByteString where+  fromString = JSONByteString . fromString++-- | Store the value for a field, as an object parametrized by the Field. No verification is done+-- for these values.+(=::) :: (SingI f, Typeable (FieldType f)) => Sing f -> FieldType f -> Attr f+s =:: x = Attr { _value = Real x, _verify = return, _field = reflect s, _ro = False }++-- | Store the value for a field, with a custom verification+(=:.) :: (SingI f, Typeable (FieldType f)) => Sing f -> (FieldType f, FieldType f -> IO (FieldType f) ) -> Attr f+s =:. (x,v) = Attr { _value = Real x, _verify = v, _field = reflect s, _ro = False }++-- | Store the value for a field, making it read only from the frontend+(=:!) :: (SingI f, Typeable (FieldType f)) => Sing f -> FieldType f -> Attr f+s =:! x = Attr { _value = Real x, _verify = return, _field = reflect s, _ro = True}++-- | 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+  | otherwise = error "The impossible happened in IHaskell.Display.Widgets.Types.rangeCheck"++rangeSliderVerification :: [Integer] -> IO [Integer]+rangeSliderVerification xs@[a,b]+  | a <= b    = return xs+  | otherwise = Ex.throw $ Ex.AssertionFailed "The first index should be smaller than the second"+rangeSliderVerification _ = Ex.throw $ Ex.AssertionFailed "There should be two indices"++-- | Store a numeric value, with verification mechanism for its range.+ranged :: (SingI f, Num (FieldType f), Ord (FieldType f), Typeable (FieldType f))+       => Sing f -> (FieldType f, FieldType f) -> AttrVal (FieldType f) -> Attr f+ranged s range x = Attr x (rangeCheck range) (reflect s) False++-- | 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), Typeable (FieldType f))+      => Sing f -> FieldType f -> Attr f+s =:+ val = Attr+              ((if val == 0+                  then Dummy+                  else Real)+                 val)+              (rangeCheck (0, upperBound))+              (reflect s)+              False++-- | Get a field from a singleton Adapted from: http://stackoverflow.com/a/28033250/2388535+reflect :: forall (f :: Field). (SingI f) => Sing f -> Field+reflect = fromSing++-- | A record representing a Widget class from IPython from the controls modules+defaultCoreWidget :: Rec Attr CoreWidgetClass+defaultCoreWidget = (ViewModule =:! "@jupyter-widgets/controls")+                    :& (ViewModuleVersion =:! "1.4.0")+                    :& (ModelModule =:! "@jupyter-widgets/controls")+                    :& (ModelModuleVersion =:! "1.4.0")+                    :& RNil++-- | A record representing an object of the DOMWidget class from IPython+defaultDOMWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> IPythonWidget 'LayoutType -> Rec Attr DOMWidgetClass+defaultDOMWidget viewName modelName layout = (ModelName =:! modelName)+                                      :& (ViewName =:! viewName)+                                      :& (DOMClasses =:: [])+                                      :& (Tooltip =:: Nothing)+                                      :& (Layout =:: layout)+                                      :& (DisplayHandler =:: return ())+                                      :& RNil++-- | A record representing an object of the DescriptionWidget class from IPython+defaultDescriptionWidget :: FieldType 'S.ViewName+                         -> FieldType 'S.ModelName+                         -> IPythonWidget 'LayoutType+                         -> StyleWidget+                         -> Rec Attr DescriptionWidgetClass+defaultDescriptionWidget v m l d = defaultCoreWidget <+> defaultDOMWidget v m l <+> descriptionAttrs+  where+    descriptionAttrs = (Description =:: "")+                       :& (Style =:: d)+                       :& RNil++-- | A record representing a widget of the _String class from IPython+defaultStringWidget :: FieldType 'S.ViewName+                    -> FieldType 'S.ModelName+                    -> IPythonWidget 'LayoutType+                    -> StyleWidget+                    -> Rec Attr StringClass+defaultStringWidget viewName modelName l d = defaultDescriptionWidget viewName modelName l d <+> strAttrs+  where+    strAttrs = (StringValue =:: "")+               :& (Placeholder =:: "")+               :& RNil++-- | A record representing a widget of the Text class from IPython+defaultTextWidget :: FieldType 'S.ViewName+                  -> FieldType 'S.ModelName+                  -> IPythonWidget 'LayoutType+                  -> StyleWidget+                  -> Rec Attr TextClass+defaultTextWidget viewName modelName l d = defaultStringWidget viewName modelName l d <+> txtAttrs+  where+    txtAttrs = (Disabled =:: False)+               :& (ContinuousUpdate =:: True)+               :& (SubmitHandler =:: return ())+               :& (ChangeHandler =:: return ())+               :& RNil++-- | A record representing a widget of the _Bool class from IPython+defaultBoolWidget :: FieldType 'S.ViewName+                  -> FieldType 'S.ModelName+                  -> IPythonWidget 'LayoutType+                  -> StyleWidget+                  -> Rec Attr BoolClass+defaultBoolWidget viewName modelName l d = defaultDescriptionWidget viewName modelName l d <+> boolAttrs+  where+    boolAttrs = (BoolValue =:: False)+                :& (Disabled =:: False)+                :& (ChangeHandler =:: return ())+                :& RNil++-- | A record representing a widget of the _Selection class from IPython+defaultSelectionWidget :: FieldType 'S.ViewName+                       -> FieldType 'S.ModelName+                       -> IPythonWidget 'LayoutType+                       -> StyleWidget+                       -> Rec Attr SelectionClass+defaultSelectionWidget viewName modelName l d = defaultDescriptionWidget viewName modelName l d <+> selectionAttrs+  where+    selectionAttrs = (OptionsLabels =:: [])+                     :& (OptionalIndex =:: Nothing)+                     :& (Disabled =:: False)+                     :& (SelectionHandler =:: return ())+                     :& RNil++-- | A record representing a widget of the _SelectionNonempty class from IPython+defaultSelectionNonemptyWidget :: FieldType 'S.ViewName+                               -> FieldType 'S.ModelName+                               -> IPythonWidget 'LayoutType+                               -> StyleWidget+                               -> Rec Attr SelectionNonemptyClass+defaultSelectionNonemptyWidget viewName modelName l d = defaultDescriptionWidget viewName modelName l d <+> selectionAttrs+  where+    selectionAttrs = (OptionsLabels =:: [])+                     :& (Index =:: 0)+                     :& (Disabled =:: False)+                     :& (SelectionHandler =:: return ())+                     :& RNil++-- | A record representing a widget of the _MultipleSelection class from IPython+defaultMultipleSelectionWidget :: FieldType 'S.ViewName+                               -> FieldType 'S.ModelName+                               -> IPythonWidget 'LayoutType+                               -> StyleWidget+                               -> Rec Attr MultipleSelectionClass+defaultMultipleSelectionWidget viewName modelName l d = defaultDescriptionWidget viewName modelName l d <+> mulSelAttrs+  where+    mulSelAttrs = (OptionsLabels =:: [])+                  :& (Indices =:: [])+                  :& (Disabled =:: False)+                  :& (SelectionHandler =:: return ())+                  :& RNil++-- | A record representing a widget of the _Int class from IPython+defaultIntWidget :: FieldType 'S.ViewName+                 -> FieldType 'S.ModelName+                 -> IPythonWidget 'LayoutType+                 -> StyleWidget+                 -> Rec Attr IntClass+defaultIntWidget viewName modelName l d = defaultDescriptionWidget viewName modelName l d <+> intAttrs+  where+    intAttrs = (IntValue =:: 0)+               :& (ChangeHandler =:: return ())+               :& RNil++-- | A record representing a widget of the _BoundedInt class from IPython+defaultBoundedIntWidget :: FieldType 'S.ViewName+                        -> FieldType 'S.ModelName+                        -> IPythonWidget 'LayoutType+                        -> StyleWidget+                        -> Rec Attr BoundedIntClass+defaultBoundedIntWidget viewName modelName l d = defaultIntWidget viewName modelName l d <+> boundedIntAttrs+  where+    boundedIntAttrs = (MaxInt =:: 100)+                      :& (MinInt =:: 0)+                      :& RNil++-- | A record representing a widget of the _BoundedInt class from IPython+defaultIntRangeWidget :: FieldType 'S.ViewName+                      -> FieldType 'S.ModelName+                      -> IPythonWidget 'LayoutType+                      -> StyleWidget+                      -> Rec Attr IntRangeClass+defaultIntRangeWidget viewName modelName l d = defaultIntWidget viewName modelName l d <+> 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+                             -> FieldType 'S.ModelName+                             -> IPythonWidget 'LayoutType+                             -> StyleWidget+                             -> Rec Attr BoundedIntRangeClass+defaultBoundedIntRangeWidget viewName modelName l d = defaultIntRangeWidget viewName modelName l d <+> boundedIntRangeAttrs+  where+    boundedIntRangeAttrs = (MaxInt =:: 100)+                           :& (MinInt =:: 0)+                           :& RNil++-- | A record representing a widget of the _Float class from IPython+defaultFloatWidget :: FieldType 'S.ViewName+                   -> FieldType 'S.ModelName+                   -> IPythonWidget 'LayoutType+                   -> StyleWidget+                   -> Rec Attr FloatClass+defaultFloatWidget viewName modelName l d = defaultDescriptionWidget viewName modelName l d <+> floatAttrs+  where+    floatAttrs = (FloatValue =:: 0.0)+               :& (ChangeHandler =:: return ())+               :& RNil++-- | A record representing a widget of the _BoundedFloat class from IPython+defaultBoundedFloatWidget :: FieldType 'S.ViewName+                          -> FieldType 'S.ModelName+                          -> IPythonWidget 'LayoutType+                          -> StyleWidget+                          -> Rec Attr BoundedFloatClass+defaultBoundedFloatWidget viewName modelName l d = defaultFloatWidget viewName modelName l d <+> boundedFloatAttrs+  where+    boundedFloatAttrs = (MinFloat =:: 0)+                        :& (MaxFloat =:: 100)+                        :& RNil++-- | A record representing a widget of the _BoundedLogFloat class from IPython+defaultBoundedLogFloatWidget :: FieldType 'S.ViewName+                             -> FieldType 'S.ModelName+                             -> IPythonWidget 'LayoutType+                             -> StyleWidget+                             -> Rec Attr BoundedLogFloatClass+defaultBoundedLogFloatWidget viewName modelName l d = floatAttrs <+> boundedLogFloatAttrs+  where+    floatAttrs = rput (FloatValue =:: 1.0) $ defaultFloatWidget viewName modelName l d+    boundedLogFloatAttrs = (MinFloat =:: 0.0)+                           :& (MaxFloat =:: 4.0)+                           :& (BaseFloat =:: 10.0)+                           :& RNil++-- | A record representing a widget of the _BoundedFloat class from IPython+defaultFloatRangeWidget :: FieldType 'S.ViewName+                        -> FieldType 'S.ModelName+                        -> IPythonWidget 'LayoutType+                        -> StyleWidget+                        -> Rec Attr FloatRangeClass+defaultFloatRangeWidget viewName modelName l d = defaultFloatWidget viewName modelName l d <+> rangeAttrs+  where+    rangeAttrs = (FloatPairValue =:: (0.0, 1.0))+                 :& RNil++-- | A record representing a widget of the _BoundedFloatRange class from IPython+defaultBoundedFloatRangeWidget :: FieldType 'S.ViewName+                               -> FieldType 'S.ModelName+                               -> IPythonWidget 'LayoutType+                               -> StyleWidget+                               -> Rec Attr BoundedFloatRangeClass+defaultBoundedFloatRangeWidget viewName modelName l d = defaultFloatRangeWidget viewName modelName l d <+> boundedFloatRangeAttrs+  where+    boundedFloatRangeAttrs = (StepFloat =:: Just 1)+                             :& (MinFloat =:: 0)+                             :& (MaxFloat =:: 100)+                             :& RNil++-- | A record representing a widget of the _Box class from IPython+defaultBoxWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> IPythonWidget 'LayoutType -> Rec Attr BoxClass+defaultBoxWidget viewName modelName layout = defaultCoreWidget <+> defaultDOMWidget viewName modelName layout <+> intAttrs+  where+    intAttrs = (Children =:: [])+               :& (BoxStyle =:: DefaultBox)+               :& RNil++-- | A record representing a widget of the _SelectionContainer class from IPython+defaultSelectionContainerWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> IPythonWidget 'LayoutType -> Rec Attr SelectionContainerClass+defaultSelectionContainerWidget viewName modelName layout = defaultBoxWidget viewName modelName layout <+> selAttrs+  where+    selAttrs = (Titles =:: [])+               :& (SelectedIndex =:: Nothing)+               :& (ChangeHandler =:: return ())+               :& RNil++-- | A record representing a widget of the _Media class from IPython+defaultMediaWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> IPythonWidget 'LayoutType -> Rec Attr MediaClass+defaultMediaWidget viewName modelName layout = defaultCoreWidget <+> defaultDOMWidget viewName modelName layout <+> mediaAttrs+  where+    mediaAttrs = (BSValue =:: "")+                 :& RNil++defaultLinkWidget :: FieldType 'S.ModelName -> Rec Attr LinkClass+defaultLinkWidget modelName = defaultCoreWidget <+> linkAttrs+  where+    linkAttrs = (ModelName =:! modelName)+                :& (Target =:: EmptyWT)+                :& (Source =:: EmptyWT)+                :& RNil++-- | A record representing a widget of the Style class from IPython+defaultStyleWidget :: FieldType 'S.ModelName -> Rec Attr StyleWidgetClass+defaultStyleWidget modelName = (ModelName =:! modelName)+                              :& (ViewName =:! "StyleView")+                              :& (ViewModule =:! "@jupyter-widgets/base")+                              :& (ViewModuleVersion =:! "1.1.0")+                              :& (ModelModule =:! "@jupyter-widgets/controls")+                              :& (ModelModuleVersion =:! "1.4.0")+                              :& RNil++-- | A record representing a widget of the DescriptionStyle class from IPython+defaultDescriptionStyleWidget :: FieldType 'S.ModelName -> Rec Attr DescriptionStyleClass+defaultDescriptionStyleWidget modelName = defaultStyleWidget modelName <+> dstyle+  where+    dstyle = (DescriptionWidth =:: "")+            :& 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. Doesn't work if the field is read only.+setField :: (f ∈ WidgetFields w, IHaskellWidget (IPythonWidget w), ToPairs (Attr f))+         => IPythonWidget w -> SField f -> FieldType f -> IO ()+setField widget sfield fval = do+  attr <- getAttr widget sfield+  when (_ro attr) $ error ("The field " ++ show (fromSing sfield) ++ " is read only")+  !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 and without checking if is read only. 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)+#if MIN_VERSION_vinyl(0,9,0)+getAttr widget _ = rget <$> _getState <$> readIORef (state widget)+#else+getAttr widget sfield = rget sfield <$> _getState <$> readIORef (state widget)+#endif++-- | 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++-- | Displays on stdout the properties (and its types) of a given widget+properties :: IPythonWidget w -> IO ()+properties widget = do+  st <- readIORef $ state widget+  let convert :: Attr f -> Const (Field, TypeRep) f+      convert attr = Const (_field attr, getFieldType attr)++      renderRow (fname, ftype) = printf "%s ::: %s" (show fname) (show ftype)+      rows = map renderRow . recordToList . rmap convert $ _getState st+  mapM_ putStrLn rows++-- 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++-- | Common function for the different trigger events+triggerEvent :: (FieldType f ~ IO (), f ∈ WidgetFields w) => SField f -> IPythonWidget w -> IO ()+triggerEvent sfield w = noStdin . join $ getField w sfield++-- | Called when the value of an attribute is changed on the front-end+triggerChange :: ('S.ChangeHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()+triggerChange = triggerEvent ChangeHandler++-- | Called when the button is clicked+triggerClick :: ('S.ClickHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()+triggerClick = triggerEvent ClickHandler++-- | Called when a selection is made in a selection widget+triggerSelection :: ('S.SelectionHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()+triggerSelection = triggerEvent SelectionHandler++-- | Called when the text is submited in a text widget (or combobox/password)+triggerSubmit :: ('S.SubmitHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()+triggerSubmit = triggerEvent SubmitHandler++-- | Called when the widget is displayed on the notebook+triggerDisplay :: ('S.DisplayHandler ∈ WidgetFields w) => IPythonWidget w -> IO ()+triggerDisplay = triggerEvent DisplayHandler++-- | Every IHaskellWidget widget has the same IHaskellDisplay instance, for this+-- reason we need to use FlexibleContexts. The display implementation can still+-- be overriden per widget+instance IHaskellWidget (IPythonWidget w) => IHaskellDisplay (IPythonWidget w) where+  display b = do+    widgetSendView b -- Keeping compatibility with classic notebook+    return $ Display [ widgetdisplay $ unpack $ decodeUtf8 $ encode $ object [+      "model_id" .= getCommUUID b,+      "version_major" .= version_major,+      "version_minor" .= version_minor] ]+    where+      version_major = 2 :: Int+      version_minor = 0 :: Int++-- | The date class from IPython+data Date+  -- | No date specified. used by default+  = NullDate+  -- | Date year month day+  | Date Integer Integer Integer deriving (Eq,Ord)++defaultDate :: Date+defaultDate = NullDate++instance Show Date where+  show NullDate = "NullDate"+  show (Date y m d) = printf "%04d-%02d-%02d" y m d++instance ToJSON Date where+  toJSON NullDate = object []+  toJSON (Date y m d) = object [ "year" .= toJSON y+                               , "month" .= toJSON (m-1) -- In the frontend months go from 0 to 11+                               , "date" .= toJSON d+                               ]++instance FromJSON Date where+  parseJSON (Object v) = Date+    <$> v .: "year"+    <*> ((+1) <$> v .: "month")+    <*> v .: "date"+  parseJSON Null = pure NullDate+  parseJSON _ = mzero++-- | Allows you to unlink a jslink+unlink :: ('S.Source ∈ WidgetFields w, 'S.Target ∈ WidgetFields w, IHaskellWidget (IPythonWidget w))+       => IPythonWidget w+       -> IO (IPythonWidget w)+unlink w = do+  _ <- setField' w Source EmptyWT+  _ <- setField' w Target EmptyWT+  return w++data OutputMsg = OutputStream StreamType Text | OutputData Display deriving (Show)++instance ToJSON OutputMsg where+  toJSON (OutputStream n t) = object [ "output_type" .= str "stream"+                                     , "name" .= toJSON n+                                     , "text" .= toJSON t+                                     ]+  toJSON (OutputData d)     = object [ "output_type" .= str "display_data"+                                     , "data" .= toJSON d+                                     , "metadata" .= object []+                                     ]