mirrors/IHaskell
1
0
Fork 0
mirror of https://github.com/IHaskell/IHaskell.git synced 2025-04-16 11:26:08 +00:00
Code Issues Packages Projects Releases Wiki Activity

Widget state on comm_open

Browse Source
This commit is contained in:
David Davó 2021-06-13 16:10:36 +02:00
parent 9168aa5bef
commit 61888fd2eb
7 changed files with 38 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
ihaskell-display/ihaskell-widgets/MsgSpec.md
View File

@ -1,6 +1,6 @@
# IPython widget messaging specification
# IPython widget messaging specification version 2
> Largely based on: https://github.com/ipython/ipython/wiki/IPEP-23:-Backbone.js-Widgets
> Largely based on: https://github.com/jupyter-widgets/ipywidgets/blob/master/packages/schema/messages.md
> The messaging specification as detailed is riddled with assumptions the IHaskell widget
> implementation makes. It works for us, so it should work for everyone.
@ -20,21 +20,18 @@ Any *numeric* property initialized with the empty string is provided the default
frontend. Some numbers need to be sent as actual numbers (when non-null), whereas the ones representing
lengths in CSS units need to be sent as strings.
The initial state must *at least* have the following fields:
The initial state must *at least* have the following fields in the `data.state` value of the message:
- `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.
- `_model_module`
- `_model_module_version`
- `_model_name`
- `_view_module`
- `_view_module_version`
- `_view_name`
- `_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`.
You can see more info on the model state of widgets [here](https://github.com/jupyter-widgets/ipywidgets/blob/master/packages/schema/jupyterwidgetmodels.latest.md).
- `_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.
> Warning!: By default there are two widgets modules: `@jupyter-widgets/controls` and `@jupyter-widgets/base`.
This state is also used with fragments of the overall state to sync changes between the frontend and
the kernel.

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

@ -26,11 +26,12 @@ import IHaskell.Eval.Widgets (widgetSendClose)
import qualified IHaskell.Display.Widgets.Singletons as S
pattern ViewModule = S.SViewModule
pattern ViewModuleVersion = S.SViewModuleVersion
pattern ViewName = S.SViewName
pattern ModelModule = S.SModelModule
pattern ModelModuleVersion = S.SModelModuleVersion
pattern ModelName = S.SModelName
pattern MsgThrottle = S.SMsgThrottle
pattern Version = S.SVersion
pattern DisplayHandler = S.SDisplayHandler
pattern Visible = S.SVisible
pattern CSS = S.SCSS

1
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Int/BoundedInt/IntSlider.hs
View File

@ -62,7 +62,6 @@ instance IHaskellDisplay IntSlider where
instance IHaskellWidget IntSlider where
getCommUUID = uuid
getVersion _ = "2.0.0"
comm widget val _ =
case nestedObjectLookup val ["sync_data", "value"] of
Just (Number value) -> do

5
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Singletons.hs
View File

@ -17,7 +17,7 @@
#endif
module IHaskell.Display.Widgets.Singletons where
import Data.Singletons.TH
#if MIN_VERSION_singletons(2,4,0)
@ -30,11 +30,12 @@ singletons
[d|
data Field = ViewModule
| ViewModuleVersion
| ViewName
| ModelModule
| ModelModuleVersion
| ModelName
| MsgThrottle
| Version
| DisplayHandler
| Visible
| CSS

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

@ -113,8 +113,8 @@ type (a :++ b) = a ++ b
#endif
-- Classes from IPython's widget hierarchy. Defined as such to reduce code duplication.
type WidgetClass = ['S.ViewModule, 'S.ViewName, 'S.ModelModule, 'S.ModelName,
'S.MsgThrottle, 'S.Version, 'S.DisplayHandler]
type WidgetClass = ['S.ViewModule, 'S.ViewModuleVersion, 'S.ViewName,
'S.ModelModule, 'S.ModelModuleVersion, 'S.ModelName, 'S.MsgThrottle, '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,
@ -155,11 +155,12 @@ type SelectionContainerClass = BoxClass :++ ['S.Titles, 'S.SelectedIndex, 'S.Cha
type family FieldType (f :: Field) :: * where
FieldType 'S.ViewModule = Text
FieldType 'S.ViewModuleVersion = Text
FieldType 'S.ViewName = Text
FieldType 'S.ModelModule = Text
FieldType 'S.ModelModuleVersion = Text
FieldType 'S.ModelName = Text
FieldType 'S.MsgThrottle = Integer
FieldType 'S.Version = Integer
FieldType 'S.DisplayHandler = IO ()
FieldType 'S.Visible = Bool
FieldType 'S.CSS = [(Text, Text, Text)]
@ -374,21 +375,24 @@ class ToPairs a where
instance ToPairs (Attr 'S.ViewModule) where
toPairs x = ["_view_module" .= toJSON x]
instance ToPairs (Attr 'S.ViewModuleVersion) where
toPairs x = ["_view_module_version" .= toJSON x]
instance ToPairs (Attr 'S.ViewName) where
toPairs x = ["_view_name" .= toJSON x]
instance ToPairs (Attr 'S.ModelModule) where
toPairs x = ["_model_module" .= toJSON x]
instance ToPairs (Attr 'S.ModelModuleVersion) where
toPairs x = ["_model_module_version" .= toJSON x]
instance ToPairs (Attr 'S.ModelName) where
toPairs x = ["_model_name" .= toJSON x]
instance ToPairs (Attr 'S.MsgThrottle) where
toPairs x = ["msg_throttle" .= toJSON x]
instance ToPairs (Attr 'S.Version) where
toPairs x = ["version" .= toJSON x]
instance ToPairs (Attr 'S.DisplayHandler) where
toPairs _ = [] -- Not sent to the frontend
@ -640,20 +644,21 @@ s =:+ val = Attr
reflect :: forall (f :: Field). (SingI f) => Sing f -> Field
reflect = fromSing
-- | A record representing an object of the Widget class from IPython
defaultWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr WidgetClass
defaultWidget viewName modelName = (ViewModule =:: "jupyter-js-widgets")
-- | A record representing a Widget class from IPython from the controls modules
defaultControlWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr WidgetClass
defaultControlWidget viewName modelName = (ViewModule =:: "@jupyter-widgets/controls")
:& (ViewModuleVersion =:: "2.0.0")
:& (ViewName =:: viewName)
:& (ModelModule =:: "jupyter-js-widgets")
:& (ModelModule =:: "@jupyter-widgets/controls")
:& (ModelModuleVersion =:: "2.0.0")
:& (ModelName =:: modelName)
:& (MsgThrottle =:+ 3)
:& (Version =:: 0)
:& (DisplayHandler =:: return ())
:& RNil
-- | A record representing an object of the DOMWidget class from IPython
defaultDOMWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr DOMWidgetClass
defaultDOMWidget viewName modelName = defaultWidget viewName modelName <+> domAttrs
defaultDOMWidget viewName modelName = defaultControlWidget viewName modelName <+> domAttrs
where
domAttrs = (Visible =:: True)
:& (CSS =:: [])

7
src/IHaskell/Eval/Widgets.hs
View File

@ -18,6 +18,7 @@ import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TChan
import Control.Monad (foldM)
import Data.Aeson
import Data.Aeson.Types (emptyArray)
import qualified Data.Map as Map
import System.IO.Unsafe (unsafePerformIO)
@ -99,6 +100,8 @@ handleMessage send replyHeader state msg = do
newComms = Map.insert uuid widget oldComms
newState = state { openComms = newComms }
content = object [ "state" .= value, "buffer_paths" .= emptyArray ]
communicate val = do
head <- dupHeader replyHeader CommDataMessage
send $ CommData head uuid val
@ -109,8 +112,8 @@ handleMessage send replyHeader state msg = do
else do
-- Send the comm open, with the initial state
hdr <- dupHeader replyHeader CommOpenMessage
let hdrV = setVersion hdr $ getVersion widget
send $ CommOpen hdrV target_name target_module uuid value
let hdrV = setVersion hdr "2.0.0" -- Widget Messaging Protocol Version
send $ CommOpen hdrV target_name target_module uuid content
-- Send anything else the widget requires.
open widget communicate

4
src/IHaskell/Types.hs
View File

@ -76,9 +76,6 @@ class IHaskellDisplay a => IHaskellWidget a where
-- UUID during initialization.
getCommUUID :: a -> UUID
-- | Get the version for this widget. Sent as metadata during comm_open.
getVersion :: a -> String
-- | Called when the comm is opened. Allows additional messages to be sent after comm open.
open :: a -- ^ Widget to open a comm port with.
-> (Value -> IO ()) -- ^ A function for sending messages.
@ -131,7 +128,6 @@ instance IHaskellWidget Widget where
targetName (Widget widget) = targetName widget
targetModule (Widget widget) = targetModule widget
getCommUUID (Widget widget) = getCommUUID widget
getVersion (Widget widget) = getVersion widget
open (Widget widget) = open widget
comm (Widget widget) = comm widget
close (Widget widget) = close widget