Commit 50d59210 authored by Sumit Sahrawat's avatar Sumit Sahrawat

Polish up the refactored code

- Rename IHaskell.Display.Widget.Types.Widget to IPythonWidget
- Add explanatory comments to the source files
- Add documentation for messaging protocol in MsgSpec.md
- Add README.md
- Remove unnecessary extensions and imports
parent 869973df
# IPython widget messaging specification
> Largely based on: https://github.com/ipython/ipython/wiki/IPEP-23:-Backbone.js-Widgets
> The messaging specification as detailed is riddled with the assumptions IHaskell's widget
> implementation makes. It works for us, so it should work for everyone.
## Creating widgets
Let's say the user types in some code, and the only effect of that code is the creation of a widget.
The kernel will open a comm for the widget, and store a reference to that comm inside it. Then, to
notify the frontend about the creation of a widget, an initial state update is sent on the widget's comm.
> The comm should be opened with a `target_name` of `"ipython.widget"`.
The initial state update message looks like this:
```json
{
"method": "update",
"state": { "<some/all widget properties>" }
}
```
Any property initialized with the empty string is provided the default value by the frontend.
The initial state update must *at least* have the following fields:
- `msg_throttle` (default 3): To prevent the kernel from flooding with messages, the messages from
the widget to the kernel are throttled. If `msg_throttle` messages were sent, and all are still
processing, the widget will not send anymore state messages.
- `_view_name` (depends on the widget): The frontend uses a generic model to represent
widgets. This field determines how a set of widget properties gets rendered into a
widget. Has the form `IPython.<widgetname>`, e.g `IPython.Button`.
- `_css` (default value = empty list): A list of 3-tuples, (selector, key, value).
- `visible` (default = True): Whether the widget is visible or not.
- Rest of the properties as required initially.
This state update is also used with fragments of the overall state to sync changes between the
frontend and the kernel.
## Displaying widgets
The creation of a widget does not display it. To display a widget, the kernel sends a display
message to the frontend on the widget's comm.
```json
{
"method": "display"
}
```
* Widgets can also send a custom message, having the form:
```json
{
"method": "custom",
"content": { "<message content>" }
}
```
## Handling changes to widget in the frontend
Changes to widgets in the frontend lead to messages being sent to the backend. These messages have
two possible formats:
1. Backbone.js initiated sync:
```json
{
"method": "backbone",
"sync_data": { "<changes to sync with the backend>" }
}
```
These messages are sent by the Backbone.js library when some change is made to a widget. For
example, whenever a change is made to the text inside a `TextWidget`, the complete contents are sent
to the kernel so that the kernel stays up-to-date about the widget's contents.
2. Custom message:
```json
{
"method": "custom",
"content": { "<custom message data>" }
}
```
This form is generally used to notify the kernel about events. For example, the `TextWidget` sends a
custom message when the text is submitted by hitting the 'Enter' key.
---
*NOTE*: It's important that the messages sent on the comm are in response to an execution message
from the front-end or another widget's comm message. This is required so the widget framework knows
what cell triggered the message and can display the widget in the correct location.
---
# IHaskell-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).
......@@ -44,7 +44,7 @@ build-type: Simple
-- Extra files to be distributed with the package, such as examples or a
-- README.
-- extra-source-files:
extra-source-files: README.md, MsgSpec.md
-- Constraint on the version of Cabal needed to build this package.
cabal-version: >=1.10
......@@ -91,6 +91,10 @@ library
-- Base language which the package is written in.
default-language: Haskell2010
-- Deal with small -fcontext-stack on ghc-7.8
-- 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
......@@ -20,7 +20,7 @@ import Data.IORef (newIORef)
import Data.Text (Text)
import Data.Vinyl (Rec (..), (<+>))
import IHaskell.Display hiding (Widget)
import IHaskell.Display
import IHaskell.Eval.Widgets
import IHaskell.IPython.Message.UUID as U
......@@ -28,7 +28,7 @@ import IHaskell.Display.Widgets.Types
import IHaskell.Display.Widgets.Common
-- | A 'CheckBoxWidget' represents a Checkbox widget from IPython.html.widgets.
type CheckBoxWidget = Widget CheckBoxType
type CheckBoxWidget = IPythonWidget CheckBoxType
-- | Create a new output widget
mkCheckBoxWidget :: IO CheckBoxWidget
......@@ -40,7 +40,7 @@ mkCheckBoxWidget = do
stateIO <- newIORef widgetState
let widget = Widget uuid stateIO
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
......
......@@ -20,7 +20,7 @@ import Data.IORef (newIORef)
import Data.Text (Text)
import Data.Vinyl (Rec (..), (<+>))
import IHaskell.Display hiding (Widget)
import IHaskell.Display
import IHaskell.Eval.Widgets
import IHaskell.IPython.Message.UUID as U
......@@ -28,7 +28,7 @@ import IHaskell.Display.Widgets.Types
import IHaskell.Display.Widgets.Common
-- | A 'ToggleButton' represents a ToggleButton widget from IPython.html.widgets.
type ToggleButton = Widget ToggleButtonType
type ToggleButton = IPythonWidget ToggleButtonType
-- | Create a new output widget
mkToggleButton :: IO ToggleButton
......@@ -45,7 +45,7 @@ mkToggleButton = do
stateIO <- newIORef widgetState
let widget = Widget uuid stateIO
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
......
......@@ -22,7 +22,7 @@ import Data.IORef (newIORef)
import Data.Text (Text)
import Data.Vinyl (Rec (..), (<+>))
import IHaskell.Display hiding (Widget)
import IHaskell.Display
import IHaskell.Eval.Widgets
import IHaskell.IPython.Message.UUID as U
......@@ -30,7 +30,7 @@ import IHaskell.Display.Widgets.Types
import IHaskell.Display.Widgets.Common
-- | A 'Button' represents a Button from IPython.html.widgets.
type Button = Widget ButtonType
type Button = IPythonWidget ButtonType
-- | Create a new button
mkButton :: IO Button
......@@ -50,7 +50,7 @@ mkButton = do
stateIO <- newIORef buttonState
let button = Widget uuid stateIO
let button = IPythonWidget uuid stateIO
let initData = object
[ "model_name" .= str "WidgetModel"
......
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TypeSynonymInstances #-}
module IHaskell.Display.Widgets.Common where
import Control.Monad (when)
import Data.Aeson
import Data.Aeson.Types (emptyObject, Pair)
import Data.Text (pack, Text)
import Data.IORef (IORef, readIORef, modifyIORef)
import Data.Proxy
import Data.Vinyl (Rec (..), (<+>), recordToList, reifyConstraint, rmap, Dict (..))
import Data.Vinyl.Functor (Compose (..), Const (..))
import Data.Vinyl.Lens (rget, rput, type ())
import qualified Data.Vinyl.TypeLevel as TL
import Data.Singletons.TH
import IHaskell.Eval.Widgets (widgetSendUpdate)
import IHaskell.Display (Base64, IHaskellWidget (..))
import IHaskell.IPython.Message.UUID
-- Widget properties
singletons [d|
data Field = ModelModule
......
......@@ -21,7 +21,7 @@ import Data.Monoid (mempty)
import Data.Text (Text)
import Data.Vinyl (Rec (..), (<+>))
import IHaskell.Display hiding (Widget)
import IHaskell.Display
import IHaskell.Eval.Widgets
import IHaskell.IPython.Message.UUID as U
......@@ -29,7 +29,7 @@ import IHaskell.Display.Widgets.Types
import IHaskell.Display.Widgets.Common
-- | An 'ImageWidget' represents a Image widget from IPython.html.widgets.
type ImageWidget = Widget ImageType
type ImageWidget = IPythonWidget ImageType
-- | Create a new image widget
mkImageWidget :: IO ImageWidget
......@@ -45,7 +45,7 @@ mkImageWidget = do
stateIO <- newIORef widgetState
let widget = Widget uuid stateIO
let widget = IPythonWidget uuid stateIO
let initData = object
[ "model_name" .= str "WidgetModel"
......
......@@ -25,14 +25,14 @@ import Data.IORef (newIORef)
import Data.Text (Text)
import Data.Vinyl (Rec (..), (<+>))
import IHaskell.Display hiding (Widget)
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 = Widget OutputType
type OutputWidget = IPythonWidget OutputType
-- | Create a new output widget
mkOutputWidget :: IO OutputWidget
......@@ -44,7 +44,7 @@ mkOutputWidget = do
stateIO <- newIORef widgetState
let widget = Widget uuid stateIO
let widget = IPythonWidget uuid stateIO
initData = object ["model_name" .= str "WidgetModel"]
-- Open a comm for this widget, and store it in the kernel state
......
......@@ -19,14 +19,14 @@ import Data.IORef (newIORef)
import Data.Text (Text)
import Data.Vinyl (Rec (..), (<+>))
import IHaskell.Display hiding (Widget)
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 = Widget HTMLType
type HTMLWidget = IPythonWidget HTMLType
-- | Create a new HTML widget
mkHTMLWidget :: IO HTMLWidget
......@@ -37,7 +37,7 @@ mkHTMLWidget = do
stateIO <- newIORef widgetState
let widget = Widget uuid stateIO
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
......
......@@ -19,14 +19,14 @@ import Data.IORef (newIORef)
import Data.Text (Text)
import Data.Vinyl (Rec (..), (<+>))
import IHaskell.Display hiding (Widget)
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 = Widget LatexType
type LatexWidget = IPythonWidget LatexType
-- | Create a new Latex widget
mkLatexWidget :: IO LatexWidget
......@@ -37,7 +37,7 @@ mkLatexWidget = do
stateIO <- newIORef widgetState
let widget = Widget uuid stateIO
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
......
......@@ -22,7 +22,7 @@ import Data.IORef (newIORef)
import Data.Text (Text)
import Data.Vinyl (Rec (..), (<+>))
import IHaskell.Display hiding (Widget)
import IHaskell.Display
import IHaskell.Eval.Widgets
import IHaskell.IPython.Message.UUID as U
......@@ -30,7 +30,7 @@ import IHaskell.Display.Widgets.Types
import IHaskell.Display.Widgets.Common
-- | A 'TextWidget' represents a Text widget from IPython.html.widgets.
type TextWidget = Widget TextType
type TextWidget = IPythonWidget TextType
-- | Create a new Text widget
mkTextWidget :: IO TextWidget
......@@ -43,7 +43,7 @@ mkTextWidget = do
stateIO <- newIORef widgetState
let widget = Widget uuid stateIO
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
......
......@@ -19,14 +19,14 @@ import Data.IORef (newIORef)
import Data.Text (Text)
import Data.Vinyl (Rec (..), (<+>))
import IHaskell.Display hiding (Widget)
import IHaskell.Display
import IHaskell.Eval.Widgets
import IHaskell.IPython.Message.UUID as U
import IHaskell.Display.Widgets.Types
-- | A 'TextAreaWidget' represents a Textarea widget from IPython.html.widgets.
type TextAreaWidget = Widget TextAreaType
type TextAreaWidget = IPythonWidget TextAreaType
-- | Create a new TextArea widget
mkTextAreaWidget :: IO TextAreaWidget
......@@ -37,7 +37,7 @@ mkTextAreaWidget = do
stateIO <- newIORef widgetState
let widget = Widget uuid stateIO
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
......
......@@ -6,17 +6,42 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
module IHaskell.Display.Widgets.Types where
-- | This module houses all the type-trickery needed to make widgets happen.
--
-- All widgets have a corresponding 'WidgetType', and some fields/attributes/properties as defined by
-- the 'WidgetFields' type-family.
--
-- Each widget field corresponds to a concrete haskell type, as given by the 'FieldType' type-family.
--
-- Vinyl records are used to wrap together widget fields into a single 'WidgetState'.
--
-- Singletons are used as a way to represent the promoted types of kind Field. For example:
--
-- @
-- SViewName :: SField ViewName
-- @
--
-- This allows the user to pass the type 'ViewName' without using Data.Proxy. In essence, a singleton
-- is the only inhabitant (other than bottom) of a promoted type. Single element set/type == singleton.
--
-- It also allows the record to wrap values of properties with information about their Field type. A
-- vinyl record is represented as @Rec f ts@, which means that a record is a list of @f x@, where @x@
-- is a type present in the type-level list @ts@. Thus a 'WidgetState' is essentially a list of field
-- properties wrapped together with the corresponding promoted Field type. See ('=::') for more.
--
-- The IPython widgets expect state updates of the form {"property": value}, where an empty string for
-- value is ignored by the frontend and the default value is used instead.
--
-- To know more about the IPython messaging specification (as implemented in this package) take a look
-- at the supplied MsgSpec.md.
import Control.Monad (when)
import Control.Applicative ((<$>))
......@@ -24,7 +49,6 @@ import Data.Aeson
import Data.Aeson.Types (emptyObject, Pair)
import Data.Text (pack, Text)
import Data.IORef (IORef, readIORef, modifyIORef)
import Data.Proxy
import Data.Vinyl (Rec (..), (<+>), recordToList, reifyConstraint, rmap, Dict (..))
import Data.Vinyl.Functor (Compose (..), Const (..))
......@@ -42,7 +66,7 @@ import IHaskell.IPython.Message.UUID
import IHaskell.Display.Widgets.Common
-- Classes from IPython's widget hierarchy
-- Classes from IPython's widget hierarchy. Defined as such to reduce code duplication.
type WidgetClass = '[ModelModule, ModelName, ViewModule, ViewName, MsgThrottle, Version, OnDisplayed]
type DOMWidgetClass = WidgetClass :++
'[ Visible, CSS, DOMClasses, Width, Height, Padding, Margin, Color
......@@ -52,7 +76,7 @@ type DOMWidgetClass = WidgetClass :++
type StringClass = DOMWidgetClass :++ '[StringValue, Disabled, Description, Placeholder]
type BoolClass = DOMWidgetClass :++ '[BoolValue, Disabled, Description]
-- Types associated with Fields
-- Types associated with Fields.
type family FieldType (f :: Field) :: * where
FieldType ModelModule = Text
FieldType ModelName = Text
......@@ -91,6 +115,7 @@ type family FieldType (f :: Field) :: * where
FieldType ImageFormat = ImageFormatValue
FieldType BoolValue = Bool
-- Different types of widgets. Every widget in IPython has a corresponding WidgetType
data WidgetType = ButtonType
| ImageType
| OutputType
......@@ -101,6 +126,7 @@ data WidgetType = ButtonType
| CheckBoxType
| ToggleButtonType
-- Fields associated with a widget
type family WidgetFields (w :: WidgetType) :: [Field] where
WidgetFields ButtonType = DOMWidgetClass :++ '[Description, Tooltip, Disabled, Icon, ButtonStyle, ClickHandler]
WidgetFields ImageType = DOMWidgetClass :++ '[ImageFormat, B64Value]
......@@ -112,8 +138,10 @@ type family WidgetFields (w :: WidgetType) :: [Field] where
WidgetFields CheckBoxType = BoolClass
WidgetFields ToggleButtonType = BoolClass :++ '[Tooltip, Icon, ButtonStyle]
newtype Attr f = Attr { _unAttr :: FieldType f }
-- Wrapper around a field
newtype Attr (f :: Field) = Attr { _unAttr :: FieldType f }
-- Types that can be converted to Aeson Pairs.
class ToPairs a where
toPairs :: a -> [Pair]
......@@ -155,9 +183,11 @@ instance ToPairs (Attr B64Value) where toPairs (Attr x) = ["_b64value" .= toJSON
instance ToPairs (Attr ImageFormat) where toPairs (Attr x) = ["format" .= toJSON x]
instance ToPairs (Attr BoolValue) where toPairs (Attr x) = ["value" .= toJSON x]
-- | Store the value for a field, as an object parametrized by the Field
(=::) :: sing f -> FieldType f -> Attr f
_ =:: x = Attr x
-- | A record representing an object of the Widget class from IPython
defaultWidget :: FieldType ViewName -> Rec Attr WidgetClass
defaultWidget viewName = (SModelModule =:: "")
:& (SModelName =:: "WidgetModel")
......@@ -168,6 +198,7 @@ defaultWidget viewName = (SModelModule =:: "")
:& (SOnDisplayed =:: return ())
:& RNil
-- | A record representing an object of the DOMWidget class from IPython
defaultDOMWidget :: FieldType ViewName -> Rec Attr DOMWidgetClass
defaultDOMWidget viewName = defaultWidget viewName <+> domAttrs
where domAttrs = (SVisible =:: True)
......@@ -189,6 +220,7 @@ defaultDOMWidget viewName = defaultWidget viewName <+> domAttrs
:& (SFontFamily =:: "")
:& RNil
-- | A record representing a widget of the _String class from IPython
defaultStringWidget :: FieldType ViewName -> Rec Attr StringClass
defaultStringWidget viewName = defaultDOMWidget viewName <+> strAttrs
where strAttrs = (SStringValue =:: "")
......@@ -197,6 +229,7 @@ defaultStringWidget viewName = defaultDOMWidget viewName <+> strAttrs
:& (SPlaceholder =:: "")
:& RNil
-- | A record representing a widget of the _Bool class from IPython
defaultBoolWidget :: FieldType ViewName -> Rec Attr BoolClass
defaultBoolWidget viewName = defaultDOMWidget viewName <+> boolAttrs
where boolAttrs = (SBoolValue =:: False)
......@@ -215,35 +248,28 @@ instance RecAll Attr (WidgetFields w) ToPairs => ToJSON (WidgetState w) where
. rmap (\(Compose (Dict x)) -> Const $ toPairs x)
$ reifyConstraint (Proxy :: Proxy ToPairs) $ _getState record
data Widget (w :: WidgetType) = Widget { uuid :: UUID, state :: IORef (WidgetState w) }
-- | Reflect a (Proxy :: Proxy f) back to f
-- Copied from: http://stackoverflow.com/a/28033250/2388535
reflect ::
forall (a :: k).
(SingI a, SingKind ('KProxy :: KProxy k)) =>
Proxy a -> Demote a
reflect _ = fromSing (sing :: Sing a)
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 (Widget w), SingI f, ToPairs (Attr f)) => Widget w -> SField f -> FieldType f -> IO ()
setField :: (f WidgetFields w, IHaskellWidget (IPythonWidget w), ToPairs (Attr f)) => IPythonWidget w -> SField f -> FieldType f -> IO ()
setField widget (sfield :: SField f) fval = do
setField' widget sfield fval
let pairs = toPairs (Attr fval :: Attr f)
when (not . null $ pairs) $ widgetSendUpdate widget (object pairs)
-- | Change the value of a field, without notifying the frontend. For internal use. Uses BangPattern.
setField' :: (f WidgetFields w, IHaskellWidget (Widget w), SingI f) => Widget w -> SField f -> FieldType f -> IO ()
setField' widget (sfield :: SField f) !fval = modifyIORef (state widget) (WidgetState . rput (sfield =:: fval) . _getState)
setField' :: (f WidgetFields w, IHaskellWidget (IPythonWidget w)) => IPythonWidget w -> SField f -> FieldType f -> IO ()
setField' widget sfield !fval = modifyIORef (state widget) (WidgetState . rput (sfield =:: fval) . _getState)
-- | Get the value of a field.
getField :: (f WidgetFields w) => Widget w -> SField f -> IO (FieldType f)
getField :: (f WidgetFields w) => IPythonWidget w -> SField f -> IO (FieldType f)
getField widget sfield = _unAttr <$> rget sfield <$> _getState <$> readIORef (state widget)
-- | Useful with toJSON, and OverloadedStrings
-- | Useful with toJSON and OverloadedStrings
str :: String -> String
str = id
-- | Send zero values as empty strings, which stands for default value in the frontend.
instance ToJSON Natural where
toJSON 0 = String ""
toJSON n = String . pack $ show n
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment