Merge pull request #569 from sumitsahrawat/widgets-4.0

Make widget messages match with IPywidgets

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

@@ -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

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

@@ -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

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

@@ -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

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

@@ -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

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

@@ -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

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

@@ -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

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

@@ -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

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

@@ -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

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

@@ -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

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

@@ -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

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

@@ -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

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

@@ -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

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

@@ -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

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

@@ -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

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

@@ -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

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

@@ -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

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

@@ -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

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

@@ -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

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

@@ -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

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

@@ -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

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

@@ -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

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

@@ -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

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

@@ -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

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

@@ -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

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

@@ -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

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

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

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

@@ -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

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

@@ -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

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

@@ -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

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

@@ -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

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

@@ -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)

ipython-kernel/src/IHaskell/IPython/Message/Parser.hs

@@ -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

ipython-kernel/src/IHaskell/IPython/Message/Writer.hs

@@ -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]

ipython-kernel/src/IHaskell/IPython/Types.hs

@@ -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.

main/Main.hs

@@ -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

src/IHaskell/Eval/Widgets.hs

@@ -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

src/IHaskell/Types.hs

@@ -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