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