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

Add selection widgets

Browse Source 
- Selection Widgets
  - Dropdown
  - ToggleButtons
  - RadioButtons
  - Select
  - SelectMultiple
- Small fix to MsgSpec.md
This commit is contained in:
Sumit Sahrawat 2015-07-06 17:34:17 +05:30
parent 50d59210d8
commit 112c046b5d
10 changed files with 450 additions and 139 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
ihaskell-display/ihaskell-widgets/MsgSpec.md
View File

@ -22,7 +22,7 @@ The initial state update message looks like this:
}
```
Any property initialized with the empty string is provided the default value by the frontend.
Any *numeric* property initialized with the empty string is provided the default value by the frontend.
The initial state update must *at least* have the following fields:

11
ihaskell-display/ihaskell-widgets/ihaskell-widgets.cabal
View File

@ -55,15 +55,19 @@ 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.Image
IHaskell.Display.Widgets.Output
IHaskell.Display.Widgets.Selection.Dropdown
IHaskell.Display.Widgets.Selection.RadioButtons
IHaskell.Display.Widgets.Selection.Select
IHaskell.Display.Widgets.Selection.ToggleButtons
IHaskell.Display.Widgets.Selection.SelectMultiple
IHaskell.Display.Widgets.String.HTML
IHaskell.Display.Widgets.String.Latex
IHaskell.Display.Widgets.String.Text
IHaskell.Display.Widgets.String.TextArea
IHaskell.Display.Widgets.Output
IHaskell.Display.Widgets.Types
IHaskell.Display.Widgets.Common
@ -80,6 +84,7 @@ library
, unordered-containers -any
, nats -any
, vinyl >= 0.5
, vector -any
, singletons >= 0.9.0
-- Waiting for the next release

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

@ -5,16 +5,20 @@ 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
import IHaskell.Display.Widgets.Output as X
import IHaskell.Display.Widgets.Selection.Dropdown as X
import IHaskell.Display.Widgets.Selection.RadioButtons as X
import IHaskell.Display.Widgets.Selection.Select as X
import IHaskell.Display.Widgets.Selection.ToggleButtons as X
import IHaskell.Display.Widgets.Selection.SelectMultiple as X
import IHaskell.Display.Widgets.String.HTML as X
import IHaskell.Display.Widgets.String.Latex as X
import IHaskell.Display.Widgets.String.Text as X
import IHaskell.Display.Widgets.String.TextArea as X
import IHaskell.Display.Widgets.Output as X
import IHaskell.Display.Widgets.Common as X
import IHaskell.Display.Widgets.Types as X (setField, getField)

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

@ -51,9 +51,18 @@ singletons [d|
| B64Value
| ImageFormat
| BoolValue
| Options
| SelectedLabel
| SelectedValue
| SelectionHandler
| Tooltips
| Icons
| SelectedLabels
| SelectedValues
deriving (Eq, Ord, Show)
|]
-- | Pre-defined border styles
data BorderStyleValue = NoBorder
| HiddenBorder
| DottedBorder
@ -83,6 +92,7 @@ instance ToJSON BorderStyleValue where
toJSON InheritBorder = "inherit"
toJSON DefaultBorder = ""
-- | Font style values
data FontStyleValue = NormalFont
| ItalicFont
| ObliqueFont
@ -98,6 +108,7 @@ instance ToJSON FontStyleValue where
toJSON InheritFont = "inherit"
toJSON DefaultFont = ""
-- | Font weight values
data FontWeightValue = NormalWeight
| BoldWeight
| BolderWeight
@ -115,6 +126,7 @@ instance ToJSON FontWeightValue where
toJSON InitialWeight = "initial"
toJSON DefaultWeight = ""
-- | Pre-defined button styles
data ButtonStyleValue = PrimaryButton
| SuccessButton
| InfoButton
@ -143,3 +155,6 @@ instance Show ImageFormatValue where
instance ToJSON ImageFormatValue where
toJSON = toJSON . pack . show
-- | Options for selection widgets.
data SelectionOptions = OptionLabels [Text] | OptionDict [(Text, Text)]

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

@ -1,163 +1,79 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
module IHaskell.Display.Widgets.Dropdown (
-- * The dropdown widget
DropdownWidget,
module IHaskell.Display.Widgets.Selection.Dropdown (
-- * The Dropdown Widget
Dropdown,
-- * Constructor
mkDropdownWidget,
-- * Set properties
setDropdownText,
setDropdownStatus,
setDropdownOptions,
setDropdownSelected,
-- * Get properties
getDropdownText,
getDropdownStatus,
getDropdownOptions,
getDropdownSelected,
-- * Handle changes
setSelectionHandler,
getSelectionHandler,
triggerSelection,
mkDropdown,
) where
-- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude
import Control.Monad (when)
import Data.Aeson (ToJSON, Value(..), object, toJSON, (.=))
import Data.Aeson.Types (Pair)
import Data.HashMap.Strict as Map
import Data.IORef
import Control.Monad (when, join)
import Data.Aeson
import qualified Data.HashMap.Strict as HM
import Data.IORef (newIORef)
import Data.Text (Text)
import System.IO.Unsafe (unsafePerformIO)
import Data.Vinyl (Rec (..), (<+>))
import IHaskell.Display
import IHaskell.Eval.Widgets
import qualified IHaskell.IPython.Message.UUID as U
import IHaskell.IPython.Message.UUID as U
import IHaskell.Display.Widgets.Types
import IHaskell.Display.Widgets.Common
-- | A 'Dropdown' represents a Dropdown widget from IPython.html.widgets.
data DropdownWidget =
DropdownWidget
{ uuid :: U.UUID -- ^ The UUID for the comm
, description :: IORef Text -- ^ The label displayed beside the dropdown
, disabled :: IORef Bool -- ^ Whether the dropdown is disabled
, selectedLabel :: IORef Text -- ^ The label which is currently selected
, labelOptions :: IORef [Text] -- ^ The possible label options
, selectionHandler :: IORef (DropdownWidget -> IO ())
}
type Dropdown = IPythonWidget DropdownType
-- | Create a new dropdown
mkDropdownWidget :: IO DropdownWidget
mkDropdownWidget = do
-- | Create a new Dropdown widget
mkDropdown :: IO Dropdown
mkDropdown = do
-- Default properties, with a random uuid
commUUID <- U.random
desc <- newIORef ""
dis <- newIORef False
sel <- newIORef ""
opts <- newIORef []
handler <- newIORef $ const $ return ()
uuid <- U.random
let selectionAttrs = defaultSelectionWidget "DropdownView"
dropdownAttrs = (SButtonStyle =:: DefaultButton) :& RNil
widgetState = WidgetState $ selectionAttrs <+> dropdownAttrs
let b = DropdownWidget
{ uuid = commUUID
, description = desc
, disabled = dis
, selectedLabel = sel
, labelOptions = opts
, selectionHandler = handler
}
stateIO <- newIORef widgetState
let initData = object
["model_name" .= str "WidgetModel", "widget_class" .= str "IPython.Dropdown"]
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 b initData $ toJSON b
widgetSendOpen widget initData $ toJSON widgetState
-- Return the dropdown widget
return b
setDropdownText :: DropdownWidget -> Text -> IO ()
setDropdownText widget text = do
modify widget description text
update widget ["description" .= text]
setDropdownStatus :: DropdownWidget -> Bool -> IO ()
setDropdownStatus widget stat = do
let newStat = not stat
modify widget disabled newStat
update widget ["disabled" .= newStat]
setDropdownOptions :: DropdownWidget -> [Text] -> IO ()
setDropdownOptions widget opts = do
modify widget labelOptions opts
update widget ["_options_labels" .= opts]
setDropdownSelected :: DropdownWidget -> Text -> IO ()
setDropdownSelected widget opt = do
possibleOpts <- getDropdownOptions widget
when (opt `elem` possibleOpts) $ do
modify widget selectedLabel opt
update widget ["selected_label" .= opt]
triggerSelection widget
toggleDropdownStatus :: DropdownWidget -> IO ()
toggleDropdownStatus widget = modifyIORef (disabled widget) not
getDropdownText :: DropdownWidget -> IO Text
getDropdownText = readIORef . description
getDropdownStatus :: DropdownWidget -> IO Bool
getDropdownStatus = fmap not . readIORef . disabled
getDropdownOptions :: DropdownWidget -> IO [Text]
getDropdownOptions = readIORef . labelOptions
getDropdownSelected :: DropdownWidget -> IO Text
getDropdownSelected = readIORef . selectedLabel
-- | Set a function to be activated on selection
setSelectionHandler :: DropdownWidget -> (DropdownWidget -> IO ()) -> IO ()
setSelectionHandler = writeIORef . selectionHandler
-- | Get the selection handler for a dropdown
getSelectionHandler :: DropdownWidget -> IO (DropdownWidget -> IO ())
getSelectionHandler = readIORef . selectionHandler
-- Return the widget
return widget
-- | Artificially trigger a selection
triggerSelection :: DropdownWidget -> IO ()
triggerSelection widget = do
handler <- getSelectionHandler widget
handler widget
triggerSelection :: Dropdown -> IO ()
triggerSelection widget = join $ getField widget SSelectionHandler
instance ToJSON DropdownWidget where
toJSON b = object
[ "_view_name" .= str "DropdownView"
, "visible" .= True
, "_css" .= object []
, "msg_throttle" .= (3 :: Int)
, "disabled" .= get disabled b
, "description" .= get description b
, "_options_labels" .= get labelOptions b
, "selected_label" .= get selectedLabel b
, "button_style" .= str ""
]
where
get x y = unsafePerformIO . readIORef . x $ y
instance IHaskellDisplay DropdownWidget where
instance IHaskellDisplay Dropdown where
display b = do
widgetSendView b
return $ Display []
instance IHaskellWidget DropdownWidget where
instance IHaskellWidget Dropdown where
getCommUUID = uuid
comm widget (Object dict1) _ = do
let key1 = "sync_data" :: Text
key2 = "selected_label" :: Text
Just (Object dict2) = Map.lookup key1 dict1
Just (String label) = Map.lookup key2 dict2
modify widget selectedLabel label
Just (Object dict2) = HM.lookup key1 dict1
Just (String label) = HM.lookup key2 dict2
opts <- getField widget SOptions
case opts of
OptionLabels _ -> do
setField' widget SSelectedLabel label
setField' widget SSelectedValue label
OptionDict ps -> case lookup label ps of
Nothing -> return ()
Just value -> do
setField' widget SSelectedLabel label
setField' widget SSelectedValue value
triggerSelection widget

77
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Selection/RadioButtons.hs Normal file
View File

@ -0,0 +1,77 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
module IHaskell.Display.Widgets.Selection.RadioButtons (
-- * The RadioButtons Widget
RadioButtons,
-- * Constructor
mkRadioButtons,
) where
-- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude
import Control.Monad (when, join)
import Data.Aeson
import qualified 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 'RadioButtons' represents a RadioButtons widget from IPython.html.widgets.
type RadioButtons = IPythonWidget RadioButtonsType
-- | Create a new RadioButtons widget
mkRadioButtons :: IO RadioButtons
mkRadioButtons = do
-- Default properties, with a random uuid
uuid <- U.random
let widgetState = WidgetState $ defaultSelectionWidget "RadioButtonsView"
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
-- Return the widget
return widget
-- | Artificially trigger a selection
triggerSelection :: RadioButtons -> IO ()
triggerSelection widget = join $ getField widget SSelectionHandler
instance IHaskellDisplay RadioButtons where
display b = do
widgetSendView b
return $ Display []
instance IHaskellWidget RadioButtons where
getCommUUID = uuid
comm widget (Object dict1) _ = do
let key1 = "sync_data" :: Text
key2 = "selected_label" :: Text
Just (Object dict2) = HM.lookup key1 dict1
Just (String label) = HM.lookup key2 dict2
opts <- getField widget SOptions
case opts of
OptionLabels _ -> do
setField' widget SSelectedLabel label
setField' widget SSelectedValue label
OptionDict ps -> case lookup label ps of
Nothing -> return ()
Just value -> do
setField' widget SSelectedLabel label
setField' widget SSelectedValue value
triggerSelection widget

77
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Selection/Select.hs Normal file
View File

@ -0,0 +1,77 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
module IHaskell.Display.Widgets.Selection.Select (
-- * The Select Widget
SelectWidget,
-- * Constructor
mkSelectWidget,
) where
-- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude
import Control.Monad (when, join)
import Data.Aeson
import qualified 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 'SelectWidget' represents a Select widget from IPython.html.widgets.
type SelectWidget = IPythonWidget SelectType
-- | Create a new Select widget
mkSelectWidget :: IO SelectWidget
mkSelectWidget = do
-- Default properties, with a random uuid
uuid <- U.random
let widgetState = WidgetState $ defaultSelectionWidget "SelectView"
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
-- Return the widget
return widget
-- | Artificially trigger a selection
triggerSelection :: SelectWidget -> IO ()
triggerSelection widget = join $ getField widget SSelectionHandler
instance IHaskellDisplay SelectWidget where
display b = do
widgetSendView b
return $ Display []
instance IHaskellWidget SelectWidget where
getCommUUID = uuid
comm widget (Object dict1) _ = do
let key1 = "sync_data" :: Text
key2 = "selected_label" :: Text
Just (Object dict2) = HM.lookup key1 dict1
Just (String label) = HM.lookup key2 dict2
opts <- getField widget SOptions
case opts of
OptionLabels _ -> do
setField' widget SSelectedLabel label
setField' widget SSelectedValue label
OptionDict ps -> case lookup label ps of
Nothing -> return ()
Just value -> do
setField' widget SSelectedLabel label
setField' widget SSelectedValue value
triggerSelection widget

79
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Selection/SelectMultiple.hs Normal file
View File

@ -0,0 +1,79 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
module IHaskell.Display.Widgets.Selection.SelectMultiple (
-- * The SelectMultiple Widget
SelectMultipleWidget,
-- * Constructor
mkSelectMultipleWidget,
) where
-- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude
import Control.Monad (fmap, join, sequence)
import Data.Aeson
import qualified Data.HashMap.Strict as HM
import Data.IORef (newIORef)
import Data.Text (Text)
import qualified Data.Vector as V
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 'SelectMultipleWidget' represents a SelectMultiple widget from IPython.html.widgets.
type SelectMultipleWidget = IPythonWidget SelectMultipleType
-- | Create a new SelectMultiple widget
mkSelectMultipleWidget :: IO SelectMultipleWidget
mkSelectMultipleWidget = do
-- Default properties, with a random uuid
uuid <- U.random
let widgetState = WidgetState $ defaultMultipleSelectionWidget "SelectMultipleView"
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
-- Return the widget
return widget
-- | Artificially trigger a selection
triggerSelection :: SelectMultipleWidget -> IO ()
triggerSelection widget = join $ getField widget SSelectionHandler
instance IHaskellDisplay SelectMultipleWidget where
display b = do
widgetSendView b
return $ Display []
instance IHaskellWidget SelectMultipleWidget where
getCommUUID = uuid
comm widget (Object dict1) _ = do
let key1 = "sync_data" :: Text
key2 = "selected_labels" :: Text
Just (Object dict2) = HM.lookup key1 dict1
Just (Array labels) = HM.lookup key2 dict2
labelList = map (\(String x) -> x) $ V.toList labels
opts <- getField widget SOptions
case opts of
OptionLabels _ -> do
setField' widget SSelectedLabels labelList
setField' widget SSelectedValues labelList
OptionDict ps -> case sequence $ map (`lookup` ps) labelList of
Nothing -> return ()
Just valueList -> do
setField' widget SSelectedLabels labelList
setField' widget SSelectedValues valueList
triggerSelection widget

82
ihaskell-display/ihaskell-widgets/src/IHaskell/Display/Widgets/Selection/ToggleButtons.hs Normal file
View File

@ -0,0 +1,82 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
module IHaskell.Display.Widgets.Selection.ToggleButtons (
-- * The ToggleButtons Widget
ToggleButtons,
-- * Constructor
mkToggleButtons,
) where
-- To keep `cabal repl` happy when running from the ihaskell repo
import Prelude
import Control.Monad (when, join)
import Data.Aeson
import qualified 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 'ToggleButtons' represents a ToggleButtons widget from IPython.html.widgets.
type ToggleButtons = IPythonWidget ToggleButtonsType
-- | Create a new ToggleButtons widget
mkToggleButtons :: IO ToggleButtons
mkToggleButtons = do
-- Default properties, with a random uuid
uuid <- U.random
let selectionAttrs = defaultSelectionWidget "ToggleButtonsView"
toggleButtonsAttrs = (STooltips =:: [])
:& (SIcons =:: [])
:& (SButtonStyle =:: DefaultButton)
:& RNil
widgetState = WidgetState $ selectionAttrs <+> toggleButtonsAttrs
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
-- Return the widget
return widget
-- | Artificially trigger a selection
triggerSelection :: ToggleButtons -> IO ()
triggerSelection widget = join $ getField widget SSelectionHandler
instance IHaskellDisplay ToggleButtons where
display b = do
widgetSendView b
return $ Display []
instance IHaskellWidget ToggleButtons where
getCommUUID = uuid
comm widget (Object dict1) _ = do
let key1 = "sync_data" :: Text
key2 = "selected_label" :: Text
Just (Object dict2) = HM.lookup key1 dict1
Just (String label) = HM.lookup key2 dict2
opts <- getField widget SOptions
case opts of
OptionLabels _ -> do
setField' widget SSelectedLabel label
setField' widget SSelectedValue label
OptionDict ps -> case lookup label ps of
Nothing -> return ()
Just value -> do
setField' widget SSelectedLabel label
setField' widget SSelectedValue value
triggerSelection widget

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

@ -37,7 +37,7 @@ module IHaskell.Display.Widgets.Types where
-- properties wrapped together with the corresponding promoted Field type. See ('=::') for more.
--
-- The IPython widgets expect state updates of the form {"property": value}, where an empty string for
-- value is ignored by the frontend and the default value is used instead.
-- numeric values is ignored by the frontend and the default value is used instead.
--
-- To know more about the IPython messaging specification (as implemented in this package) take a look
-- at the supplied MsgSpec.md.
@ -75,6 +75,10 @@ type DOMWidgetClass = WidgetClass :++
]
type StringClass = DOMWidgetClass :++ '[StringValue, Disabled, Description, Placeholder]
type BoolClass = DOMWidgetClass :++ '[BoolValue, Disabled, Description]
type SelectionClass = DOMWidgetClass :++
'[Options, SelectedValue, SelectedLabel, Disabled, Description, SelectionHandler]
type MultipleSelectionClass = DOMWidgetClass :++
'[Options, SelectedLabels, SelectedValues, Disabled, Description, SelectionHandler]
-- Types associated with Fields.
type family FieldType (f :: Field) :: * where
@ -114,6 +118,14 @@ type family FieldType (f :: Field) :: * where
FieldType B64Value = Base64
FieldType ImageFormat = ImageFormatValue
FieldType BoolValue = Bool
FieldType Options = SelectionOptions
FieldType SelectedLabel = Text
FieldType SelectedValue = Text
FieldType SelectionHandler = IO ()
FieldType Tooltips = [Text]
FieldType Icons = [Text]
FieldType SelectedLabels = [Text]
FieldType SelectedValues = [Text]
-- Different types of widgets. Every widget in IPython has a corresponding WidgetType
data WidgetType = ButtonType
@ -125,6 +137,11 @@ data WidgetType = ButtonType
| TextAreaType
| CheckBoxType
| ToggleButtonType
| DropdownType
| RadioButtonsType
| SelectType
| ToggleButtonsType
| SelectMultipleType
-- Fields associated with a widget
type family WidgetFields (w :: WidgetType) :: [Field] where
@ -137,6 +154,11 @@ type family WidgetFields (w :: WidgetType) :: [Field] where
WidgetFields TextAreaType = StringClass
WidgetFields CheckBoxType = BoolClass
WidgetFields ToggleButtonType = BoolClass :++ '[Tooltip, Icon, ButtonStyle]
WidgetFields DropdownType = SelectionClass :++ '[ButtonStyle]
WidgetFields RadioButtonsType = SelectionClass
WidgetFields SelectType = SelectionClass
WidgetFields ToggleButtonsType = SelectionClass :++ '[Tooltips, Icons, ButtonStyle]
WidgetFields SelectMultipleType = MultipleSelectionClass
-- Wrapper around a field
newtype Attr (f :: Field) = Attr { _unAttr :: FieldType f }
@ -152,7 +174,7 @@ instance ToPairs (Attr ViewModule) where toPairs (Attr x) = ["_view_module" .= t
instance ToPairs (Attr ViewName) where toPairs (Attr x) = ["_view_name" .= toJSON x]
instance ToPairs (Attr MsgThrottle) where toPairs (Attr x) = ["msg_throttle" .= toJSON x]
instance ToPairs (Attr Version) where toPairs (Attr x) = ["version" .= toJSON x]
instance ToPairs (Attr OnDisplayed) where toPairs (Attr x) = [] -- Not sent to the frontend
instance ToPairs (Attr OnDisplayed) where toPairs _ = [] -- Not sent to the frontend
instance ToPairs (Attr Visible) where toPairs (Attr x) = ["visible" .= toJSON x]
instance ToPairs (Attr CSS) where toPairs (Attr x) = ["_css" .= toJSON x]
instance ToPairs (Attr DOMClasses) where toPairs (Attr x) = ["_dom_classes" .= toJSON x]
@ -171,8 +193,8 @@ instance ToPairs (Attr FontWeight) where toPairs (Attr x) = ["font_weight" .= to
instance ToPairs (Attr FontSize) where toPairs (Attr x) = ["font_size" .= toJSON x]
instance ToPairs (Attr FontFamily) where toPairs (Attr x) = ["font_family" .= toJSON x]
instance ToPairs (Attr Description) where toPairs (Attr x) = ["description" .= toJSON x]
instance ToPairs (Attr ClickHandler) where toPairs (Attr x) = [] -- Not sent to the frontend
instance ToPairs (Attr SubmitHandler) where toPairs (Attr x) = [] -- Not sent to the frontend
instance ToPairs (Attr ClickHandler) where toPairs _ = [] -- Not sent to the frontend
instance ToPairs (Attr SubmitHandler) where toPairs _ = [] -- Not sent to the frontend
instance ToPairs (Attr Disabled) where toPairs (Attr x) = ["disabled" .= toJSON x]
instance ToPairs (Attr StringValue) where toPairs (Attr x) = ["value" .= toJSON x]
instance ToPairs (Attr Placeholder) where toPairs (Attr x) = ["placeholder" .= toJSON x]
@ -182,6 +204,18 @@ instance ToPairs (Attr ButtonStyle) where toPairs (Attr x) = ["button_style" .=
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]
instance ToPairs (Attr SelectedLabel) where toPairs (Attr x) = ["selected_label" .= toJSON x]
instance ToPairs (Attr SelectedValue) where toPairs (Attr x) = ["value" .= toJSON x]
instance ToPairs (Attr Options) where
toPairs (Attr x) = case x of
OptionLabels xs -> labels xs
OptionDict xps -> labels $ map fst xps
where labels xs = ["_options_labels" .= xs]
instance ToPairs (Attr SelectionHandler) where toPairs _ = [] -- Not sent to the frontend
instance ToPairs (Attr Tooltips) where toPairs (Attr x) = ["tooltips" .= toJSON x]
instance ToPairs (Attr Icons) where toPairs (Attr x) = ["icons" .= toJSON x]
instance ToPairs (Attr SelectedLabels) where toPairs (Attr x) = ["selected_labels" .= toJSON x]
instance ToPairs (Attr SelectedValues) where toPairs (Attr x) = ["values" .= toJSON x]
-- | Store the value for a field, as an object parametrized by the Field
(=::) :: sing f -> FieldType f -> Attr f
@ -237,6 +271,28 @@ defaultBoolWidget viewName = defaultDOMWidget viewName <+> boolAttrs
:& (SDescription =:: "")
:& RNil
-- | A record representing a widget of the _Selection class from IPython
defaultSelectionWidget :: FieldType ViewName -> Rec Attr SelectionClass
defaultSelectionWidget viewName = defaultDOMWidget viewName <+> selectionAttrs
where selectionAttrs = (SOptions =:: OptionLabels [])
:& (SSelectedValue =:: "")
:& (SSelectedLabel =:: "")
:& (SDisabled =:: False)
:& (SDescription =:: "")
:& (SSelectionHandler =:: return ())
:& RNil
-- | A record representing a widget of the _MultipleSelection class from IPython
defaultMultipleSelectionWidget :: FieldType ViewName -> Rec Attr MultipleSelectionClass
defaultMultipleSelectionWidget viewName = defaultDOMWidget viewName <+> mulSelAttrs
where mulSelAttrs = (SOptions =:: OptionLabels [])
:& (SSelectedLabels =:: [])
:& (SSelectedValues =:: [])
:& (SDisabled =:: False)
:& (SDescription =:: "")
:& (SSelectionHandler =:: return ())
:& 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.