Add bool widgets

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

@@ -56,6 +56,8 @@ library
   -- Modules included in this library but not exported.
   other-modules:       IHaskell.Display.Widgets.Button
                        IHaskell.Display.Widgets.Image
+                       IHaskell.Display.Widgets.Bool.CheckBox
+                       IHaskell.Display.Widgets.Bool.ToggleButton
                        -- IHaskell.Display.Widgets.Dropdown
                        IHaskell.Display.Widgets.String.HTML
                        IHaskell.Display.Widgets.String.Latex

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

@@ -2,6 +2,9 @@ module IHaskell.Display.Widgets (module X) where
 
 import           IHaskell.Display.Widgets.Button as X
 
+import           IHaskell.Display.Widgets.Bool.CheckBox as X
+import           IHaskell.Display.Widgets.Bool.ToggleButton as X
+
 -- import           IHaskell.Display.Widgets.Dropdown as X
 
 import           IHaskell.Display.Widgets.Image as X

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module IHaskell.Display.Widgets.Bool.CheckBox (
+    -- * The CheckBox Widget
+    CheckBoxWidget,
+    -- * Constructor
+    mkCheckBoxWidget,
+    ) 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           IHaskell.Display hiding (Widget)
+import           IHaskell.Eval.Widgets
+import           IHaskell.IPython.Message.UUID as U
+
+import           IHaskell.Display.Widgets.Types
+import           IHaskell.Display.Widgets.Common
+
+-- | A 'CheckBoxWidget' represents a Checkbox widget from IPython.html.widgets.
+type CheckBoxWidget = Widget CheckBoxType
+
+-- | Create a new output widget
+mkCheckBoxWidget :: IO CheckBoxWidget
+mkCheckBoxWidget = do
+  -- Default properties, with a random uuid
+  uuid <- U.random
+
+  let widgetState = WidgetState $ defaultBoolWidget "CheckboxView"
+
+  stateIO <- newIORef widgetState
+
+  let widget = Widget 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
+
+  -- Return the image widget
+  return widget
+
+instance IHaskellDisplay CheckBoxWidget where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget CheckBoxWidget where
+  getCommUUID = uuid
+  comm widget (Object dict1) _ = do
+    let key1 = "sync_data" :: Text
+        key2 = "value" :: Text
+        Just (Object dict2) = HM.lookup key1 dict1
+        Just (Bool value) = HM.lookup key2 dict2
+    setField' widget SBoolValue value

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

+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module IHaskell.Display.Widgets.Bool.ToggleButton (
+    -- * The ToggleButton Widget
+    ToggleButton,
+    -- * Constructor
+    mkToggleButton,
+    ) 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           IHaskell.Display hiding (Widget)
+import           IHaskell.Eval.Widgets
+import           IHaskell.IPython.Message.UUID as U
+
+import           IHaskell.Display.Widgets.Types
+import           IHaskell.Display.Widgets.Common
+
+-- | A 'ToggleButton' represents a ToggleButton widget from IPython.html.widgets.
+type ToggleButton = Widget ToggleButtonType
+
+-- | Create a new output widget
+mkToggleButton :: IO ToggleButton
+mkToggleButton = do
+  -- Default properties, with a random uuid
+  uuid <- U.random
+
+  let boolState = defaultBoolWidget "ToggleButtonView"
+      toggleState = (STooltip =:: "")
+                 :& (SIcon =:: "")
+                 :& (SButtonStyle =:: DefaultButton)
+                 :& RNil
+      widgetState = WidgetState (boolState <+> toggleState)
+
+  stateIO <- newIORef widgetState
+
+  let widget = Widget 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
+
+  -- Return the image widget
+  return widget
+
+instance IHaskellDisplay ToggleButton where
+  display b = do
+    widgetSendView b
+    return $ Display []
+
+instance IHaskellWidget ToggleButton where
+  getCommUUID = uuid
+  comm widget (Object dict1) _ = do
+    let key1 = "sync_data" :: Text
+        key2 = "value" :: Text
+        Just (Object dict2) = HM.lookup key1 dict1
+        Just (Bool value) = HM.lookup key2 dict2
+    setField' widget SBoolValue value

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

@@ -71,6 +71,7 @@ singletons [d|
              | ButtonStyle
              | B64Value
              | ImageFormat
+             | BoolValue
              deriving (Eq, Ord, Show)
              |]
 

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

@@ -27,8 +27,9 @@ import Data.Proxy
 import Data.Vinyl (Rec (..), (<+>), recordToList, reifyConstraint, rmap, Dict (..))
 import Data.Vinyl.Functor (Compose (..), Const (..))
 import Data.Vinyl.Lens (rget, rput, type (∈))
-import qualified Data.Vinyl.TypeLevel as TL
+import Data.Vinyl.TypeLevel (RecAll (..))
 
+import Data.Singletons.Prelude ((:++))
 import Data.Singletons.TH
 
 import Numeric.Natural
@@ -41,12 +42,13 @@ import IHaskell.Display.Widgets.Common
 
 -- Classes from IPython's widget hierarchy
 type WidgetClass = '[ModelModule, ModelName, ViewModule, ViewName, MsgThrottle, Version, OnDisplayed]
-type DOMWidgetClass = WidgetClass TL.++
+type DOMWidgetClass = WidgetClass :++
    '[ Visible, CSS, DOMClasses, Width, Height, Padding, Margin, Color
     , BackgroundColor, BorderColor, BorderWidth, BorderRadius, BorderStyle, FontStyle
     , FontWeight, FontSize, FontFamily
     ]
-type StringClass = DOMWidgetClass TL.++ '[StringValue, Disabled, Description, Placeholder]
+type StringClass = DOMWidgetClass :++ '[StringValue, Disabled, Description, Placeholder]
+type BoolClass = DOMWidgetClass :++ '[BoolValue, Disabled, Description]
 
 -- Types associated with Fields
 type family FieldType (f :: Field) :: * where
@@ -85,6 +87,7 @@ type family FieldType (f :: Field) :: * where
   FieldType ButtonStyle = ButtonStyleValue
   FieldType B64Value = Base64
   FieldType ImageFormat = ImageFormatValue
+  FieldType BoolValue = Bool
 
 data WidgetType = ButtonType
                 | ImageType
@@ -93,15 +96,19 @@ data WidgetType = ButtonType
                 | LatexType
                 | TextType
                 | TextAreaType
+                | CheckBoxType
+                | ToggleButtonType
 
 type family WidgetFields (w :: WidgetType) :: [Field] where
-  WidgetFields ButtonType = DOMWidgetClass TL.++ '[Description, Tooltip, Disabled, Icon, ButtonStyle, ClickHandler]
-  WidgetFields ImageType = DOMWidgetClass TL.++ '[ImageFormat, B64Value]
+  WidgetFields ButtonType = DOMWidgetClass :++ '[Description, Tooltip, Disabled, Icon, ButtonStyle, ClickHandler]
+  WidgetFields ImageType = DOMWidgetClass :++ '[ImageFormat, B64Value]
   WidgetFields OutputType = DOMWidgetClass
   WidgetFields HTMLType = StringClass
   WidgetFields LatexType = StringClass
-  WidgetFields TextType = StringClass TL.++ '[SubmitHandler]
+  WidgetFields TextType = StringClass :++ '[SubmitHandler]
   WidgetFields TextAreaType = StringClass
+  WidgetFields CheckBoxType = BoolClass
+  WidgetFields ToggleButtonType = BoolClass :++ '[Tooltip, Icon, ButtonStyle]
 
 newtype Attr f = Attr { _unAttr :: FieldType f }
 
@@ -144,6 +151,7 @@ instance ToPairs (Attr Icon) where toPairs (Attr x) = ["icon" .= toJSON x]
 instance ToPairs (Attr ButtonStyle) where toPairs (Attr x) = ["button_style" .= toJSON x]
 instance ToPairs (Attr B64Value) where toPairs (Attr x) = ["_b64value" .= toJSON x]
 instance ToPairs (Attr ImageFormat) where toPairs (Attr x) = ["format" .= toJSON x]
+instance ToPairs (Attr BoolValue) where toPairs (Attr x) = ["value" .= toJSON x]
 
 (=::) :: sing f -> FieldType f -> Attr f
 _ =:: x = Attr x
@@ -187,10 +195,17 @@ defaultStringWidget viewName = defaultDOMWidget viewName <+> strAttrs
                 :& (SPlaceholder =:: "")
                 :& RNil
 
+defaultBoolWidget :: FieldType ViewName -> Rec Attr BoolClass
+defaultBoolWidget viewName = defaultDOMWidget viewName <+> boolAttrs
+  where boolAttrs = (SBoolValue =:: False)
+                 :& (SDisabled =:: False)
+                 :& (SDescription =:: "")
+                 :& RNil
+
 newtype WidgetState w = WidgetState { _getState :: Rec Attr (WidgetFields w) }
 
 -- All records with ToPair instances for their Attrs will automatically have a toJSON instance now.
-instance TL.RecAll Attr (WidgetFields w) ToPairs => ToJSON (WidgetState w) where
+instance RecAll Attr (WidgetFields w) ToPairs => ToJSON (WidgetState w) where
   toJSON record =
     object
     . concat