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

Merge pull request #569 from sumitsahrawat/widgets-4.0

Browse Source 
Make widget messages match with IPywidgets
This commit is contained in:
Andrew Gibiansky 2015-09-12 14:49:39 -07:00
commit be3d44eb26
37 changed files with 136 additions and 123 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Bool/CheckBox.hs
View File

@ -40,11 +40,9 @@ mkCheckBox = do
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
widgetSendOpen widget $ toJSON widgetState
-- Return the image widget
return widget

4
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Bool/ToggleButton.hs
View File

@ -45,11 +45,9 @@ mkToggleButton = do
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
widgetSendOpen widget $ toJSON widgetState
-- Return the image widget
return widget

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

@ -40,10 +40,9 @@ mkBox = do
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
widgetSendOpen box $ toJSON widgetState
-- Return the widget
return box

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

@ -46,10 +46,9 @@ mkFlexBox = do
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
widgetSendOpen box $ toJSON widgetState
-- Return the widget
return box

4
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Box/SelectionContainer/Accordion.hs
View File

@ -41,11 +41,9 @@ mkAccordion = do
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
widgetSendOpen box $ toJSON widgetState
-- Return the widget
return box

3
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Box/SelectionContainer/Tab.hs
View File

@ -41,10 +41,9 @@ mkTabWidget = do
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
widgetSendOpen box $ toJSON widgetState
-- Return the widget
return box

4
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Button.hs
View File

@ -49,10 +49,8 @@ mkButton = do
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
widgetSendOpen button $ toJSON buttonState
-- Return the button widget
return button

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

@ -18,6 +18,8 @@ import qualified IHaskell.Display.Widgets.Singletons as S
pattern ViewModule = S.SViewModule
pattern ViewName = S.SViewName
pattern ModelModule = S.SModelModule
pattern ModelName = S.SModelName
pattern MsgThrottle = S.SMsgThrottle
pattern Version = S.SVersion
pattern DisplayHandler = S.SDisplayHandler

6
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Float/BoundedFloat/BoundedFloatText.hs
View File

@ -42,13 +42,9 @@ mkBoundedFloatText = do
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
widgetSendOpen widget $ toJSON widgetState
-- Return the widget
return widget

10
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Float/BoundedFloat/FloatProgress.hs
View File

@ -38,19 +38,17 @@ mkFloatProgress = do
uuid <- U.random
let boundedFloatAttrs = defaultBoundedFloatWidget "ProgressView"
progressAttrs = (BarStyle =:: DefaultBar) :& RNil
progressAttrs = (Orientation =:: HorizontalOrientation)
:& (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
widgetSendOpen widget $ toJSON widgetState
-- Return the widget
return widget

4
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Float/BoundedFloat/FloatSlider.hs
View File

@ -47,11 +47,9 @@ mkFloatSlider = do
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
widgetSendOpen widget $ toJSON widgetState
-- Return the widget
return widget

6
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Float/BoundedFloatRange/FloatRangeSlider.hs
View File

@ -50,13 +50,9 @@ mkFloatRangeSlider = do
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
widgetSendOpen widget $ toJSON widgetState
-- Return the widget
return widget

4
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Float/FloatText.hs
View File

@ -41,11 +41,9 @@ mkFloatText = do
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
widgetSendOpen widget $ toJSON widgetState
-- Return the widget
return widget

6
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Image.hs
View File

@ -38,6 +38,8 @@ mkImageWidget = do
let dom = defaultDOMWidget "ImageView"
img = (ImageFormat =:: PNG)
:& (Width =:+ 0)
:& (Height =:+ 0)
:& (B64Value =:: mempty)
:& RNil
widgetState = WidgetState (dom <+> img)
@ -46,10 +48,8 @@ mkImageWidget = do
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
widgetSendOpen widget $ toJSON widgetState
-- Return the image widget
return widget

6
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Int/BoundedInt/BoundedIntText.hs
View File

@ -41,13 +41,9 @@ mkBoundedIntText = do
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
widgetSendOpen widget $ toJSON widgetState
-- Return the widget
return widget

8
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Int/BoundedInt/IntProgress.hs
View File

@ -38,17 +38,17 @@ mkIntProgress = do
uuid <- U.random
let boundedIntAttrs = defaultBoundedIntWidget "ProgressView"
progressAttrs = (BarStyle =:: DefaultBar) :& RNil
progressAttrs = (Orientation =:: HorizontalOrientation)
:& (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
widgetSendOpen widget $ toJSON widgetState
-- Return the widget
return widget

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

@ -47,11 +47,9 @@ mkIntSlider = do
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
widgetSendOpen widget $ toJSON widgetState
-- Return the widget
return widget

6
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Int/BoundedIntRange/IntRangeSlider.hs
View File

@ -48,13 +48,9 @@ mkIntRangeSlider = do
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
widgetSendOpen widget $ toJSON widgetState
-- Return the widget
return widget

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

@ -41,10 +41,9 @@ mkIntText = do
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
widgetSendOpen widget $ toJSON widgetState
-- Return the widget
return widget

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

@ -45,10 +45,9 @@ mkOutputWidget = do
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
widgetSendOpen widget $ toJSON widgetState
-- Return the image widget
return widget

4
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Selection/Dropdown.hs
View File

@ -41,11 +41,9 @@ mkDropdown = do
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
widgetSendOpen widget $ toJSON widgetState
-- Return the widget
return widget

4
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Selection/RadioButtons.hs
View File

@ -39,11 +39,9 @@ mkRadioButtons = do
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
widgetSendOpen widget $ toJSON widgetState
-- Return the widget
return widget

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

@ -39,10 +39,9 @@ mkSelect = do
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
widgetSendOpen widget $ toJSON widgetState
-- Return the widget
return widget

6
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Selection/SelectMultiple.hs
View File

@ -40,13 +40,9 @@ mkSelectMultiple = do
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
widgetSendOpen widget $ toJSON widgetState
-- Return the widget
return widget

6
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Selection/ToggleButtons.hs
View File

@ -44,13 +44,9 @@ mkToggleButtons = do
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
widgetSendOpen widget $ toJSON widgetState
-- Return the widget
return widget

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

@ -16,6 +16,8 @@ singletons
data Field = ViewModule
| ViewName
| ModelModule
| ModelName
| MsgThrottle
| Version
| DisplayHandler

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

@ -37,10 +37,9 @@ mkHTMLWidget = do
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
widgetSendOpen widget $ toJSON widgetState
-- Return the widget
return widget

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

@ -37,10 +37,9 @@ mkLatexWidget = do
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
widgetSendOpen widget $ toJSON widgetState
-- Return the widget
return widget

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

@ -41,10 +41,9 @@ mkTextWidget = do
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
widgetSendOpen widget $ toJSON widgetState
-- Return the widget
return widget

4
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/String/TextArea.hs
View File

@ -41,11 +41,9 @@ mkTextArea = do
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
widgetSendOpen widget $ toJSON widgetState
-- Return the widget
return widget

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

@ -57,7 +57,7 @@ module IHaskell.Display.Widgets.Types where
-- 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
-- Widgets are not able to do console input, the reason for that can be found in the messaging
-- specification
import Control.Monad (unless, join, when, void, mapM_)
import Control.Applicative ((<$>))
@ -89,8 +89,8 @@ 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 WidgetClass = '[S.ViewModule, S.ViewName, S.ModelModule, S.ModelName,
S.MsgThrottle, S.Version, S.DisplayHandler]
type DOMWidgetClass = WidgetClass :++ '[S.Visible, S.CSS, S.DOMClasses, S.Width, S.Height, S.Padding,
S.Margin, S.Color, S.BackgroundColor, S.BorderColor, S.BorderWidth,
@ -104,7 +104,7 @@ type BoolClass = DOMWidgetClass :++ '[S.BoolValue, S.Disabled, S.Description, S.
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,
type MultipleSelectionClass = DOMWidgetClass :++ '[S.Options, S.SelectedValues, S.SelectedLabels, S.Disabled,
S.Description, S.SelectionHandler]
type IntClass = DOMWidgetClass :++ '[S.IntValue, S.Disabled, S.Description, S.ChangeHandler]
@ -132,6 +132,8 @@ type SelectionContainerClass = BoxClass :++ '[S.Titles, S.SelectedIndex, S.Chang
type family FieldType (f :: Field) :: * where
FieldType S.ViewModule = Text
FieldType S.ViewName = Text
FieldType S.ModelModule = Text
FieldType S.ModelName = Text
FieldType S.MsgThrottle = Integer
FieldType S.Version = Integer
FieldType S.DisplayHandler = IO ()
@ -237,7 +239,9 @@ data WidgetType = ButtonType
| TextAreaType
| CheckBoxType
| ToggleButtonType
| DropdownType
|
-- TODO: Add 'Valid' widget
DropdownType
| RadioButtonsType
| SelectType
| ToggleButtonsType
@ -252,7 +256,9 @@ data WidgetType = ButtonType
| FloatSliderType
| FloatProgressType
| FloatRangeSliderType
| BoxType
|
-- TODO: Add Proxy and PlaceProxy
BoxType
| FlexBoxType
| AccordionType
| TabType
@ -265,7 +271,7 @@ type family WidgetFields (w :: WidgetType) :: [Field] where
'[S.Description, S.Tooltip, S.Disabled, S.Icon, S.ButtonStyle,
S.ClickHandler]
WidgetFields ImageType =
DOMWidgetClass :++ '[S.ImageFormat, S.B64Value]
DOMWidgetClass :++ '[S.ImageFormat, S.Width, S.Height, S.B64Value]
WidgetFields OutputType = DOMWidgetClass
WidgetFields HTMLType = StringClass
WidgetFields LatexType = StringClass
@ -286,7 +292,8 @@ type family WidgetFields (w :: WidgetType) :: [Field] where
WidgetFields IntSliderType =
BoundedIntClass :++
'[S.Orientation, S.ShowRange, S.ReadOut, S.SliderColor]
WidgetFields IntProgressType = BoundedIntClass :++ '[S.BarStyle]
WidgetFields IntProgressType =
BoundedIntClass :++ '[S.Orientation, S.BarStyle]
WidgetFields IntRangeSliderType =
BoundedIntRangeClass :++
'[S.Orientation, S.ShowRange, S.ReadOut, S.SliderColor]
@ -296,7 +303,7 @@ type family WidgetFields (w :: WidgetType) :: [Field] where
BoundedFloatClass :++
'[S.Orientation, S.ShowRange, S.ReadOut, S.SliderColor]
WidgetFields FloatProgressType =
BoundedFloatClass :++ '[S.BarStyle]
BoundedFloatClass :++ '[S.Orientation, S.BarStyle]
WidgetFields FloatRangeSliderType =
BoundedFloatRangeClass :++
'[S.Orientation, S.ShowRange, S.ReadOut, S.SliderColor]
@ -339,6 +346,12 @@ instance ToPairs (Attr S.ViewModule) where
instance ToPairs (Attr S.ViewName) where
toPairs x = ["_view_name" .= toJSON x]
instance ToPairs (Attr S.ModelModule) where
toPairs x = ["_model_module" .= toJSON x]
instance ToPairs (Attr S.ModelName) where
toPairs x = ["_model_name" .= toJSON x]
instance ToPairs (Attr S.MsgThrottle) where
toPairs x = ["msg_throttle" .= toJSON x]
@ -591,6 +604,8 @@ reflect = fromSing
defaultWidget :: FieldType S.ViewName -> Rec Attr WidgetClass
defaultWidget viewName = (ViewModule =:: "")
:& (ViewName =:: viewName)
:& (ModelModule =:: "")
:& (ModelName =:: "WidgetModel")
:& (MsgThrottle =:+ 3)
:& (Version =:: 0)
:& (DisplayHandler =:: return ())
@ -656,8 +671,8 @@ defaultMultipleSelectionWidget :: FieldType S.ViewName -> Rec Attr MultipleSelec
defaultMultipleSelectionWidget viewName = defaultDOMWidget viewName <+> mulSelAttrs
where
mulSelAttrs = (Options =:: OptionLabels [])
:& (SelectedLabels =:: [])
:& (SelectedValues =:: [])
:& (SelectedLabels =:: [])
:& (Disabled =:: False)
:& (Description =:: "")
:& (SelectionHandler =:: return ())
@ -739,8 +754,10 @@ defaultBoundedFloatRangeWidget viewName = defaultFloatRangeWidget viewName <+> b
-- | A record representing a widget of the _Box class from IPython
defaultBoxWidget :: FieldType S.ViewName -> Rec Attr BoxClass
defaultBoxWidget viewName = defaultDOMWidget viewName <+> boxAttrs
defaultBoxWidget viewName = domAttrs <+> boxAttrs
where
defaultDOM = defaultDOMWidget viewName
domAttrs = rput (ModelName =:: "BoxModel") defaultDOM
boxAttrs = (Children =:: [])
:& (OverflowX =:: DefaultOverflow)
:& (OverflowY =:: DefaultOverflow)

7
ipython-kernel/src/IHaskell/IPython/Message/Parser.hs
View File

@ -7,7 +7,7 @@
-- the low-level 0MQ interface.
module IHaskell.IPython.Message.Parser (parseMessage) where
import Data.Aeson ((.:), decode, Result(..), Object)
import Data.Aeson ((.:), (.:?), (.!=), decode, Result(..), Object)
import Control.Applicative ((<|>), (<$>), (<*>))
import Data.Aeson.Types (parse)
import Data.ByteString
@ -159,9 +159,10 @@ inputReplyParser = requestParser $ \obj -> do
commOpenParser :: LByteString -> Message
commOpenParser = requestParser $ \obj -> do
uuid <- obj .: "comm_id"
name <- obj .: "target_name"
targetName <- obj .: "target_name"
targetModule <- obj .:? "target_module" .!= ""
value <- obj .: "data"
return $ CommOpen noHeader name uuid value
return $ CommOpen noHeader targetName targetModule uuid value
commDataParser :: LByteString -> Message
commDataParser = requestParser $ \obj -> do

7
ipython-kernel/src/IHaskell/IPython/Message/Writer.hs
View File

@ -97,7 +97,12 @@ instance ToJSON Message where
object ["prompt" .= prompt]
toJSON req@CommOpen{} =
object ["comm_id" .= commUuid req, "target_name" .= commTargetName req, "data" .= commData req]
object
[ "comm_id" .= commUuid req
, "target_name" .= commTargetName req
, "target_module" .= commTargetModule req
, "data" .= commData req
]
toJSON req@CommData{} =
object ["comm_id" .= commUuid req, "data" .= commData req]

2
ipython-kernel/src/IHaskell/IPython/Types.hs
View File

@ -375,6 +375,7 @@ data Message =
CommOpen
{ header :: MessageHeader
, commTargetName :: String
, commTargetModule :: String
, commUuid :: UUID
, commData :: Value
}
@ -438,6 +439,7 @@ replyType CompleteRequestMessage = Just CompleteReplyMessage
replyType InspectRequestMessage = Just InspectReplyMessage
replyType ShutdownRequestMessage = Just ShutdownReplyMessage
replyType HistoryRequestMessage = Just HistoryReplyMessage
replyType CommOpenMessage = Just CommDataMessage
replyType _ = Nothing
-- | Data for display: a string with associated MIME type.

39
main/Main.hs
View File

@ -14,6 +14,7 @@ import qualified Data.ByteString.Char8 as CBS
-- Standard library imports.
import Control.Concurrent (threadDelay)
import Control.Concurrent.Chan
import Control.Arrow (second)
import Data.Aeson
import System.Directory
import System.Process (readProcess, readProcessWithExitCode)
@ -333,6 +334,44 @@ replyTo _ HistoryRequest{} replyHeader state = do
}
return (state, reply)
-- Accomodating the workaround for retrieving list of open comms from the kernel
--
-- The main idea is that the frontend opens a comm at kernel startup, whose target is a widget that
-- sends back the list of live comms and commits suicide.
--
-- The message needs to be written to the iopub channel, and not returned from here. If returned,
-- the same message also gets written to the shell channel, which causes issues due to two messages
-- having the same identifiers in their headers.
--
-- Sending the message only on the shell_reply channel doesn't work, so we send it as a comm message
-- on the iopub channel and return the SendNothing message.
replyTo interface open@CommOpen{} replyHeader state = do
let send msg = liftIO $ writeChan (iopubChannel interface) msg
incomingUuid = commUuid open
target = commTargetName open
targetMatches = target == "ipython.widget"
valueMatches = commData open == object ["widget_class" .= "ipywidgets.CommInfo"]
commMap = openComms state
uuidTargetPairs = map (second targetName) $ Map.toList commMap
pairProcessor (x, y) = T.pack (UUID.uuidToString x) .= object ["target_name" .= T.pack y]
currentComms = object $ map pairProcessor $ (incomingUuid, "comm") : uuidTargetPairs
replyValue = object [ "method" .= "custom"
, "content" .= object ["comms" .= currentComms]
]
msg = CommData replyHeader (commUuid open) replyValue
-- To the iopub channel you go
when (targetMatches && valueMatches) $ send msg
return (state, SendNothing)
-- TODO: What else can be implemented?
replyTo _ message _ state = do
liftIO $ hPutStrLn stderr $ "Unimplemented message: " ++ show message

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

@ -52,9 +52,8 @@ widgetSend :: IHaskellWidget a
widgetSend msgType widget value = queue $ msgType (Widget widget) value
-- | Send a message to open a comm
widgetSendOpen :: IHaskellWidget a => a -> Value -> Value -> IO ()
widgetSendOpen widget initVal stateVal =
queue $ Open (Widget widget) initVal stateVal
widgetSendOpen :: IHaskellWidget a => a -> Value -> IO ()
widgetSendOpen = widgetSend Open
-- | Send a state update message
widgetSendUpdate :: IHaskellWidget a => a -> Value -> IO ()
@ -93,8 +92,9 @@ handleMessage :: (Message -> IO ())
-> IO KernelState
handleMessage send replyHeader state msg = do
case msg of
Open widget initVal stateVal -> do
let target = targetName widget
Open widget value -> do
let target_name = targetName widget
target_module = targetModule widget
uuid = getCommUUID widget
present = isJust $ Map.lookup uuid oldComms
@ -109,12 +109,9 @@ handleMessage send replyHeader state msg = do
if present
then return state
else do
-- Send the comm open
-- Send the comm open, with the initial state
header <- dupHeader replyHeader CommOpenMessage
send $ CommOpen header target uuid initVal
-- Initial state update
communicate . toJSON $ UpdateState stateVal
send $ CommOpen header target_name target_module uuid value
-- Send anything else the widget requires.
open widget communicate
@ -123,8 +120,7 @@ handleMessage send replyHeader state msg = do
return newState
Close widget value -> do
let target = targetName widget
uuid = getCommUUID widget
let uuid = getCommUUID widget
present = isJust $ Map.lookup uuid oldComms
newComms = Map.delete uuid $ openComms state

14
src/IHaskell/Types.hs
View File

@ -65,11 +65,15 @@ class IHaskellDisplay a where
-- | Display as an interactive widget.
class IHaskellDisplay a => IHaskellWidget a where
-- | Output target name for this widget. The actual input parameter should be ignored. By default
-- evaluate to "ipython.widget", which is used by IPython for its backbone widgets.
-- | Target name for this widget. The actual input parameter should be ignored. By default evaluate
-- to "ipython.widget", which is used by IPython for its backbone widgets.
targetName :: a -> String
targetName _ = "ipython.widget"
-- | Target module for this widget. Evaluates to an empty string by default.
targetModule :: a -> String
targetModule _ = ""
-- | Get the uuid for comm associated with this widget. The widget is responsible for storing the
-- UUID during initialization.
getCommUUID :: a -> UUID
@ -102,6 +106,7 @@ instance IHaskellDisplay Widget where
instance IHaskellWidget Widget where
targetName (Widget widget) = targetName widget
targetModule (Widget widget) = targetModule widget
getCommUUID (Widget widget) = getCommUUID widget
open (Widget widget) = open widget
comm (Widget widget) = comm widget
@ -185,11 +190,10 @@ data LintStatus = LintOn
deriving (Eq, Show)
-- | Send JSON objects with specific formats
data WidgetMsg = Open Widget Value Value
data WidgetMsg = Open Widget Value
|
-- ^ Cause the interpreter to open a new comm, and register the associated widget in
-- the kernelState. Also sends a Value with comm_open, and then sends an initial
-- state update Value.
-- the kernelState. Also sends an initial state Value with comm_open.
Update Widget Value
|
-- ^ Cause the interpreter to send a comm_msg containing a state update for the