Added more String widgets

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

@@ -89,9 +89,11 @@ library
                        IHaskell.Display.Widgets.Selection.SelectionRangeSlider
                        IHaskell.Display.Widgets.Selection.ToggleButtons
                        IHaskell.Display.Widgets.Selection.SelectMultiple
+                       IHaskell.Display.Widgets.String.Combobox
                        IHaskell.Display.Widgets.String.HTML
                        IHaskell.Display.Widgets.String.HTMLMath
                        IHaskell.Display.Widgets.String.Label
+                       IHaskell.Display.Widgets.String.Password
                        IHaskell.Display.Widgets.String.Text
                        IHaskell.Display.Widgets.String.TextArea
 

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

@@ -37,9 +37,11 @@ import           IHaskell.Display.Widgets.Selection.SelectionRangeSlider as X
 import           IHaskell.Display.Widgets.Selection.ToggleButtons as X
 import           IHaskell.Display.Widgets.Selection.SelectMultiple as X
 
+import           IHaskell.Display.Widgets.String.Combobox as X
 import           IHaskell.Display.Widgets.String.HTML as X
 import           IHaskell.Display.Widgets.String.HTMLMath as X
 import           IHaskell.Display.Widgets.String.Label as X
+import           IHaskell.Display.Widgets.String.Password as X
 import           IHaskell.Display.Widgets.String.Text as X
 import           IHaskell.Display.Widgets.String.TextArea as X
 

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

@@ -47,7 +47,7 @@ pattern ButtonStyle = S.SButtonStyle
 pattern BSValue = S.SBSValue
 pattern ImageFormat = S.SImageFormat
 pattern BoolValue = S.SBoolValue
-pattern Options = S.SOptions
+pattern OptionsLabels = S.SOptionsLabels
 pattern OptionalIndex = S.SOptionalIndex
 pattern Index = S.SIndex
 pattern SelectionHandler = S.SSelectionHandler
@@ -95,6 +95,8 @@ pattern VideoFormat = S.SVideoFormat
 pattern AutoPlay = S.SAutoPlay
 pattern Loop = S.SLoop
 pattern Controls = S.SControls
+pattern Options = S.SOptions
+pattern EnsureOption = S.SEnsureOption
 
 -- | Close a widget's comm
 closeWidget :: IHaskellWidget w => w -> IO ()
@@ -246,10 +248,6 @@ instance Show VideoFormatValue where
 instance ToJSON VideoFormatValue where
   toJSON = toJSON . pack . show
 
--- | Options for selection widgets.
-data SelectionOptions = OptionLabels [Text]
-                      | OptionDict [(Text, Text)]
-
 -- | Orientation values.
 data OrientationValue = HorizontalOrientation
                       | VerticalOrientation

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

@@ -53,7 +53,7 @@ singletons
              | BSValue
              | ImageFormat
              | BoolValue
-             | Options
+             | OptionsLabels
              | Index
              | OptionalIndex
              | SelectionHandler
@@ -101,5 +101,7 @@ singletons
              | AutoPlay
              | Loop
              | Controls
+             | Options
+             | EnsureOption
              deriving (Eq, Ord, Show)
   |]

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module IHaskell.Display.Widgets.String.Combobox
+  ( -- * The Combobox Widget
+    ComboboxWidget
+    -- * Constructor
+  , mkComboboxWidget
+  ) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Control.Monad (when)
+import           Data.Aeson
+import           Data.IORef (newIORef)
+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 'ComboboxWidget' represents a Combobox widget from IPython.html.widgets.
+type ComboboxWidget = IPythonWidget 'ComboboxType
+
+-- | Create a new Combobox widget
+mkComboboxWidget :: IO ComboboxWidget
+mkComboboxWidget = do
+  -- Default properties, with a random uuid
+  wid <- U.random
+  let txtWidget = defaultTextWidget "ComboboxView" "ComboboxModel"
+      boxWidget = (Options =:: [])
+                  :& (EnsureOption =:: False)
+                  :& RNil
+      widgetState = WidgetState $ txtWidget <+> boxWidget
+
+  stateIO <- newIORef widgetState
+
+  let widget = IPythonWidget wid stateIO
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen widget $ toJSON widgetState
+
+  -- Return the widget
+  return widget
+
+instance IHaskellWidget ComboboxWidget where
+  getCommUUID = uuid
+  -- Two possibilities: 1. content -> event -> "submit" 2. sync_data -> value -> <new_value>
+  comm tw val _ = do
+    case nestedObjectLookup val ["state", "value"] of
+      Just (String value) -> setField' tw StringValue value >> triggerChange tw
+      _                 -> pure ()
+    case nestedObjectLookup val ["content", "event"] of
+      Just (String event) -> when (event == "submit") $ triggerSubmit tw
+      _                   -> pure ()

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module IHaskell.Display.Widgets.String.Password
+  ( -- * The Password Widget
+    PasswordWidget
+    -- * Constructor
+  , mkPasswordWidget
+  ) where
+
+-- To keep `cabal repl` happy when running from the ihaskell repo
+import           Prelude
+
+import           Control.Monad (when)
+import           Data.Aeson
+import           Data.IORef (newIORef)
+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 'PasswordWidget' represents a Password widget from IPython.html.widgets.
+type PasswordWidget = IPythonWidget 'PasswordType
+
+-- | Create a new Password widget
+mkPasswordWidget :: IO PasswordWidget
+mkPasswordWidget = do
+  -- Default properties, with a random uuid
+  wid <- U.random
+  let widgetState = WidgetState $ defaultTextWidget "PasswordView" "PasswordModel"
+
+  stateIO <- newIORef widgetState
+
+  let widget = IPythonWidget wid stateIO
+
+  -- Open a comm for this widget, and store it in the kernel state
+  widgetSendOpen widget $ toJSON widgetState
+
+  -- Return the widget
+  return widget
+
+instance IHaskellWidget PasswordWidget where
+  getCommUUID = uuid
+  comm tw val _ = do
+    case nestedObjectLookup val ["state", "value"] of
+      Just (String value) -> setField' tw StringValue value >> triggerChange tw
+      _                 -> pure ()
+    case nestedObjectLookup val ["content", "event"] of
+      Just (String event) -> when (event == "submit") $ triggerSubmit tw
+      _                   -> pure ()
\ No newline at end of file

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

@@ -35,13 +35,7 @@ mkTextWidget :: IO TextWidget
 mkTextWidget = do
   -- Default properties, with a random uuid
   wid <- U.random
-  let strWidget = defaultStringWidget "TextView" "TextModel"
-      txtWidget = (Disabled =:: False)
-                  :& (ContinuousUpdate =:: True)
-                  :& (SubmitHandler =:: return ())
-                  :& (ChangeHandler =:: return ())
-                  :& RNil
-      widgetState = WidgetState $ strWidget <+> txtWidget
+  let widgetState = WidgetState $ defaultTextWidget "TextView" "TextModel"
 
   stateIO <- newIORef widgetState
 

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

@@ -133,13 +133,15 @@ type DescriptionWidgetClass = CoreWidgetClass :++ DOMWidgetClass :++ '[ 'S.Descr
 
 type StringClass = DescriptionWidgetClass :++ ['S.StringValue, 'S.Placeholder]
 
+type TextClass = StringClass :++ [ 'S.Disabled, 'S.ContinuousUpdate, 'S.SubmitHandler, 'S.ChangeHandler]
+
 type BoolClass = DescriptionWidgetClass :++ ['S.BoolValue, 'S.Disabled, 'S.ChangeHandler]
 
-type SelectionClass = DescriptionWidgetClass :++ ['S.Options, 'S.OptionalIndex, 'S.Disabled, 'S.SelectionHandler]
+type SelectionClass = DescriptionWidgetClass :++ ['S.OptionsLabels, 'S.OptionalIndex, 'S.Disabled, 'S.SelectionHandler]
 
-type SelectionNonemptyClass = DescriptionWidgetClass :++ ['S.Options, 'S.Index, 'S.Disabled, 'S.SelectionHandler]
+type SelectionNonemptyClass = DescriptionWidgetClass :++ ['S.OptionsLabels, 'S.Index, 'S.Disabled, 'S.SelectionHandler]
 
-type MultipleSelectionClass = DescriptionWidgetClass :++ ['S.Options, 'S.Indices, 'S.Disabled, 'S.SelectionHandler]
+type MultipleSelectionClass = DescriptionWidgetClass :++ ['S.OptionsLabels, 'S.Indices, 'S.Disabled, 'S.SelectionHandler]
 
 type IntClass = DescriptionWidgetClass :++ [ 'S.IntValue, 'S.ChangeHandler ]
 
@@ -190,7 +192,7 @@ type family FieldType (f :: Field) :: * where
         FieldType 'S.BSValue = ByteString
         FieldType 'S.ImageFormat = ImageFormatValue
         FieldType 'S.BoolValue = Bool
-        FieldType 'S.Options = SelectionOptions
+        FieldType 'S.OptionsLabels = [Text]
         FieldType 'S.Index = Integer
         FieldType 'S.OptionalIndex = Maybe Integer
         FieldType 'S.SelectionHandler = IO ()
@@ -238,6 +240,8 @@ type family FieldType (f :: Field) :: * where
         FieldType 'S.AutoPlay = Bool
         FieldType 'S.Loop = Bool
         FieldType 'S.Controls = Bool
+        FieldType 'S.Options = [Text]
+        FieldType 'S.EnsureOption = Bool
 
 -- | 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)
@@ -270,9 +274,11 @@ data WidgetType = ButtonType
                 | ImageType
                 | VideoType
                 | OutputType
+                | ComboboxType
                 | HTMLType
                 | HTMLMathType
                 | LabelType
+                | PasswordType
                 | TextType
                 | TextAreaType
                 | CheckBoxType
@@ -317,10 +323,10 @@ type family WidgetFields (w :: WidgetType) :: [Field] where
   WidgetFields 'OutputType = DOMWidgetClass
   WidgetFields 'HTMLType = StringClass
   WidgetFields 'HTMLMathType = StringClass
+  WidgetFields 'ComboboxType = TextClass :++ [ 'S.Options, 'S.EnsureOption ]
   WidgetFields 'LabelType = StringClass
-  WidgetFields 'TextType =
-                  StringClass :++
-                    [ 'S.Disabled, 'S.ContinuousUpdate, 'S.SubmitHandler, 'S.ChangeHandler]
+  WidgetFields 'PasswordType = TextClass
+  WidgetFields 'TextType = TextClass
 
   -- Type level lists with a single element need both the list and the
   -- constructor ticked, and a space between the open square bracket and
@@ -478,14 +484,8 @@ instance ToPairs (Attr 'S.Index) where
 instance ToPairs (Attr 'S.OptionalIndex) where
   toPairs x = ["index" .= toJSON x]
 
-instance ToPairs (Attr 'S.Options) where
-  toPairs x =
-    case _value x of
-      Dummy _                -> labels ("" :: Text)
-      Real (OptionLabels xs) -> labels xs
-      Real (OptionDict xps)  -> labels $ map fst xps
-    where
-      labels xs = ["_options_labels" .= xs]
+instance ToPairs (Attr 'S.OptionsLabels) where
+  toPairs x = ["_options_labels" .= toJSON x]
 
 instance ToPairs (Attr 'S.SelectionHandler) where
   toPairs _ = [] -- Not sent to the frontend
@@ -616,6 +616,12 @@ instance ToPairs (Attr 'S.Loop) where
 instance ToPairs (Attr 'S.Controls) where
   toPairs x = ["controls" .= toJSON x]
 
+instance ToPairs (Attr 'S.Options) where
+  toPairs x = ["options" .= toJSON x]
+
+instance ToPairs (Attr 'S.EnsureOption) where
+  toPairs x = ["ensure_option" .= toJSON x]
+
 -- | Store the value for a field, as an object parametrized by the Field. No verification is done
 -- for these values.
 (=::) :: (SingI f, Typeable (FieldType f)) => Sing f -> FieldType f -> Attr f
@@ -694,6 +700,16 @@ defaultStringWidget viewName modelName = defaultDescriptionWidget viewName model
                :& (Placeholder =:: "")
                :& RNil
 
+-- | A record representing a widget of the Text class from IPython
+defaultTextWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr TextClass
+defaultTextWidget viewName modelName = defaultStringWidget viewName modelName <+> txtAttrs
+  where
+    txtAttrs = (Disabled =:: False)
+               :& (ContinuousUpdate =:: True)
+               :& (SubmitHandler =:: return ())
+               :& (ChangeHandler =:: return ())
+               :& RNil
+
 -- | A record representing a widget of the _Bool class from IPython
 defaultBoolWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr BoolClass
 defaultBoolWidget viewName modelName = defaultDescriptionWidget viewName modelName <+> boolAttrs
@@ -707,7 +723,7 @@ defaultBoolWidget viewName modelName = defaultDescriptionWidget viewName modelNa
 defaultSelectionWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr SelectionClass
 defaultSelectionWidget viewName modelName = defaultDescriptionWidget viewName modelName <+> selectionAttrs
   where
-    selectionAttrs = (Options =:: OptionLabels [])
+    selectionAttrs = (OptionsLabels =:: [])
                      :& (OptionalIndex =:: Nothing)
                      :& (Disabled =:: False)
                      :& (SelectionHandler =:: return ())
@@ -717,7 +733,7 @@ defaultSelectionWidget viewName modelName = defaultDescriptionWidget viewName mo
 defaultSelectionNonemptyWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr SelectionNonemptyClass
 defaultSelectionNonemptyWidget viewName modelName = defaultDescriptionWidget viewName modelName <+> selectionAttrs
   where
-    selectionAttrs = (Options =:: OptionLabels [])
+    selectionAttrs = (OptionsLabels =:: [])
                      :& (Index =:: 0)
                      :& (Disabled =:: False)
                      :& (SelectionHandler =:: return ())
@@ -727,7 +743,7 @@ defaultSelectionNonemptyWidget viewName modelName = defaultDescriptionWidget vie
 defaultMultipleSelectionWidget :: FieldType 'S.ViewName -> FieldType 'S.ModelName -> Rec Attr MultipleSelectionClass
 defaultMultipleSelectionWidget viewName modelName = defaultDescriptionWidget viewName modelName <+> mulSelAttrs
   where
-    mulSelAttrs = (Options =:: OptionLabels [])
+    mulSelAttrs = (OptionsLabels =:: [])
                   :& (Indices =:: [])
                   :& (Disabled =:: False)
                   :& (SelectionHandler =:: return ())