Merge pull request #574 from sumitsahrawat/widgets-4.0

Adding new widgets

ihaskell-display/ihaskell-widgets/ihaskell-widgets.cabal

@@ -57,11 +57,14 @@ library
   -- Modules included in this library but not exported.
   other-modules:       IHaskell.Display.Widgets.Button
                        IHaskell.Display.Widgets.Box.Box
+                       IHaskell.Display.Widgets.Box.Proxy
+                       IHaskell.Display.Widgets.Box.PlaceProxy
                        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.Bool.Valid
                        IHaskell.Display.Widgets.Int.IntText
                        IHaskell.Display.Widgets.Int.BoundedInt.BoundedIntText
                        IHaskell.Display.Widgets.Int.BoundedInt.IntProgress

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

@@ -3,12 +3,15 @@ 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.Proxy as X
+import           IHaskell.Display.Widgets.Box.PlaceProxy 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.Bool.Valid as X
 
 import           IHaskell.Display.Widgets.Int.IntText as X
 import           IHaskell.Display.Widgets.Int.BoundedInt.BoundedIntText as X
@@ -38,8 +41,7 @@ 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,
+import           IHaskell.Display.Widgets.Types as X (setField, getField, properties,
+                                                      triggerDisplay, triggerChange, triggerClick,
                                                       triggerSelection, triggerSubmit,
                                                       ChildWidget(..))

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module IHaskell.Display.Widgets.Bool.Valid (
+  -- * The Valid Widget
+  ValidWidget,
+  -- * Constructor
+  mkValidWidget) 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 'ValidWidget' represents a Valid widget from IPython.html.widgets.
+type ValidWidget = IPythonWidget ValidType
+
+-- | Create a new output widget
+mkValidWidget :: IO ValidWidget
+mkValidWidget = do
+  -- Default properties, with a random uuid
+  uuid <- U.random
+
+  let boolState = defaultBoolWidget "ValidView"
+      validState = (ReadOutMsg =:: "") :& RNil
+      widgetState = WidgetState $ boolState <+> validState
+
+  stateIO <- newIORef widgetState
+
+  let widget = IPythonWidget uuid stateIO
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen widget $ toJSON widgetState
+
+  -- Return the image widget
+  return widget
+
+instance IHaskellDisplay ValidWidget where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget ValidWidget where
+  getCommUUID = uuid

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+
+module IHaskell.Display.Widgets.Box.PlaceProxy (
+  -- * The PlaceProxy widget
+  PlaceProxy,
+  -- * Constructor
+  mkPlaceProxy) 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           Data.Vinyl.Lens (rput)
+
+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 PlaceProxy = IPythonWidget PlaceProxyType
+
+-- | Create a new box
+mkPlaceProxy :: IO PlaceProxy
+mkPlaceProxy = do
+  -- Default properties, with a random uuid
+  uuid <- U.random
+
+  let widgetClassState = defaultWidget "PlaceProxyView"
+      baseState = rput (ModelName =:: "ProxyModel") widgetClassState
+      proxyState = (Child =:: Nothing) :& (Selector =:: "") :& RNil
+      widgetState = WidgetState $ baseState <+> proxyState
+
+  stateIO <- newIORef widgetState
+
+  let widget = IPythonWidget uuid stateIO
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen widget $ toJSON widgetState
+
+  -- Return the widget
+  return widget
+
+instance IHaskellDisplay PlaceProxy where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget PlaceProxy where
+  getCommUUID = uuid

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module IHaskell.Display.Widgets.Box.Proxy (
+-- * The Proxy widget
+ProxyWidget,
+     -- * Constructor
+     mkProxyWidget) 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           Data.Vinyl.Lens (rput)
+
+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 ProxyWidget = IPythonWidget ProxyType
+
+-- | Create a new box
+mkProxyWidget :: IO ProxyWidget
+mkProxyWidget = do
+  -- Default properties, with a random uuid
+  uuid <- U.random
+
+  let widgetClassState = defaultWidget "ProxyView"
+      baseState = rput (ModelName =:: "ProxyModel") widgetClassState
+      proxyState = (Child =:: Nothing) :& RNil
+      widgetState = WidgetState $ baseState <+> proxyState
+
+  stateIO <- newIORef widgetState
+
+  let proxy = IPythonWidget uuid stateIO
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen proxy $ toJSON widgetState
+
+  -- Return the widget
+  return proxy
+
+instance IHaskellDisplay ProxyWidget where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget ProxyWidget where
+  getCommUUID = uuid

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

@@ -89,6 +89,9 @@ pattern Pack = S.SPack
 pattern Align = S.SAlign
 pattern Titles = S.STitles
 pattern SelectedIndex = S.SSelectedIndex
+pattern ReadOutMsg = S.SReadOutMsg
+pattern Child = S.SChild
+pattern Selector = S.SSelector
 
 -- | Close a widget's comm
 closeWidget :: IHaskellWidget w => w -> IO ()

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

@@ -13,7 +13,7 @@ import           Data.Singletons.TH
 -- Widget properties
 singletons
   [d|
-   
+
   data Field = ViewModule
              | ViewName
              | ModelModule
@@ -87,5 +87,8 @@ singletons
              | Align
              | Titles
              | SelectedIndex
+             | ReadOutMsg
+             | Child
+             | Selector
              deriving (Eq, Ord, Show)
   |]

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

@@ -128,7 +128,7 @@ type BoxClass = DOMWidgetClass :++ '[S.Children, S.OverflowX, S.OverflowY, S.Box
 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
@@ -203,6 +203,9 @@ type family FieldType (f :: Field) :: * where
         FieldType S.Align = LocationValue
         FieldType S.Titles = [Text]
         FieldType S.SelectedIndex = Integer
+        FieldType S.ReadOutMsg = Text
+        FieldType S.Child = Maybe ChildWidget
+        FieldType S.Selector = Text
 
 -- | 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)
@@ -239,9 +242,8 @@ data WidgetType = ButtonType
                 | TextAreaType
                 | CheckBoxType
                 | ToggleButtonType
-                |
-                -- TODO: Add 'Valid' widget
-                 DropdownType
+                | ValidType
+                | DropdownType
                 | RadioButtonsType
                 | SelectType
                 | ToggleButtonsType
@@ -256,15 +258,15 @@ data WidgetType = ButtonType
                 | FloatSliderType
                 | FloatProgressType
                 | FloatRangeSliderType
-                |
-                -- TODO: Add Proxy and PlaceProxy
-                 BoxType
+                | BoxType
+                | ProxyType
+                | PlaceProxyType
                 | FlexBoxType
                 | AccordionType
                 | TabType
 
 -- Fields associated with a widget
- 
+
 type family WidgetFields (w :: WidgetType) :: [Field] where
         WidgetFields ButtonType =
                                 DOMWidgetClass :++
@@ -281,6 +283,7 @@ type family WidgetFields (w :: WidgetType) :: [Field] where
         WidgetFields CheckBoxType = BoolClass
         WidgetFields ToggleButtonType =
                                       BoolClass :++ '[S.Tooltip, S.Icon, S.ButtonStyle]
+        WidgetFields ValidType = BoolClass :++ '[S.ReadOutMsg]
         WidgetFields DropdownType = SelectionClass :++ '[S.ButtonStyle]
         WidgetFields RadioButtonsType = SelectionClass
         WidgetFields SelectType = SelectionClass
@@ -308,6 +311,8 @@ type family WidgetFields (w :: WidgetType) :: [Field] where
                                           BoundedFloatRangeClass :++
                                             '[S.Orientation, S.ShowRange, S.ReadOut, S.SliderColor]
         WidgetFields BoxType = BoxClass
+        WidgetFields ProxyType = WidgetClass :++ '[S.Child]
+        WidgetFields PlaceProxyType = WidgetFields ProxyType :++ '[S.Selector]
         WidgetFields FlexBoxType =
                                  BoxClass :++ '[S.Orientation, S.Flex, S.Pack, S.Align]
         WidgetFields AccordionType = SelectionContainerClass
@@ -565,6 +570,15 @@ instance ToPairs (Attr S.Titles) where
 instance ToPairs (Attr S.SelectedIndex) where
   toPairs x = ["selected_index" .= toJSON x]
 
+instance ToPairs (Attr S.ReadOutMsg) where
+  toPairs x = ["readout" .= toJSON x]
+
+instance ToPairs (Attr S.Child) where
+  toPairs x = ["child" .= toJSON x]
+
+instance ToPairs (Attr S.Selector) where
+  toPairs x = ["selector" .= 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