mirror of
https://github.com/IHaskell/IHaskell.git
synced 2025-04-18 20:36:08 +00:00
Added link widgets and toKey in Singletons
This commit is contained in:
David Davó
parent
67ab446eed
commit
6275019ac1
@ -82,6 +82,8 @@ library
|
||||
IHaskell.Display.Widgets.Int.BoundedInt.IntSlider
|
||||
IHaskell.Display.Widgets.Int.BoundedInt.Play
|
||||
IHaskell.Display.Widgets.Int.BoundedIntRange.IntRangeSlider
|
||||
IHaskell.Display.Widgets.Link.Link
|
||||
IHaskell.Display.Widgets.Link.DirectionalLink
|
||||
IHaskell.Display.Widgets.Float.FloatText
|
||||
IHaskell.Display.Widgets.Float.BoundedFloat.BoundedFloatText
|
||||
IHaskell.Display.Widgets.Float.BoundedFloat.FloatProgress
|
||||
@ -138,7 +140,10 @@ library
|
||||
|
||||
-- The singletons package version is locked to the compiler
|
||||
-- so let cabal choose the right one.
|
||||
, singletons < 3.0.0
|
||||
, singletons >= 2.6
|
||||
|
||||
if impl (ghc >= 9.0)
|
||||
build-depends: singletons-base -any
|
||||
|
||||
-- Directories containing source files.
|
||||
hs-source-dirs: src
|
||||
|
||||
@ -26,6 +26,9 @@ import IHaskell.Display.Widgets.Int.BoundedInt.IntSlider as X
|
||||
import IHaskell.Display.Widgets.Int.BoundedInt.Play as X
|
||||
import IHaskell.Display.Widgets.Int.BoundedIntRange.IntRangeSlider as X
|
||||
|
||||
import IHaskell.Display.Widgets.Link.Link as X
|
||||
import IHaskell.Display.Widgets.Link.DirectionalLink as X
|
||||
|
||||
import IHaskell.Display.Widgets.Float.FloatText as X
|
||||
import IHaskell.Display.Widgets.Float.BoundedFloat.BoundedFloatText as X
|
||||
import IHaskell.Display.Widgets.Float.BoundedFloat.FloatProgress as X
|
||||
@ -64,4 +67,5 @@ import IHaskell.Display.Widgets.Style.ToggleButtonsStyle as X
|
||||
import IHaskell.Display.Widgets.Common as X
|
||||
import IHaskell.Display.Widgets.Types as X (setField, getField, properties, triggerDisplay,
|
||||
triggerChange, triggerClick, triggerSelection,
|
||||
triggerSubmit, ChildWidget(..), Date(..))
|
||||
triggerSubmit, ChildWidget(..), StyleWidget(..),
|
||||
WidgetFieldPair(..), Date(..))
|
||||
|
||||
@ -114,6 +114,8 @@ pattern DescriptionWidth = S.SDescriptionWidth
|
||||
pattern BarColor = S.SBarColor
|
||||
pattern HandleColor = S.SHandleColor
|
||||
pattern ButtonWidth = S.SButtonWidth
|
||||
pattern Target = S.STarget
|
||||
pattern Source = S.SSource
|
||||
pattern Style = S.SStyle
|
||||
-- | Close a widget's comm
|
||||
closeWidget :: IHaskellWidget w => w -> IO ()
|
||||
|
||||
@ -139,114 +139,6 @@ type instance FieldType 'S.LWidth = Maybe String
|
||||
-- type family WidgetFields (w :: WidgetType) :: [Field] where
|
||||
type instance WidgetFields 'LayoutType = LayoutClass
|
||||
|
||||
instance ToPairs (Attr 'S.LAlignContent) where
|
||||
toPairs x = ["align_content" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LAlignItems) where
|
||||
toPairs x = ["align_items" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LAlignSelf) where
|
||||
toPairs x = ["align_self" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LBorder) where
|
||||
toPairs x = ["border" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LBottom) where
|
||||
toPairs x = ["bottom" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LDisplay) where
|
||||
toPairs x = ["display" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LFlex) where
|
||||
toPairs x = ["flex" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LFlexFlow) where
|
||||
toPairs x = ["flex_flow" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LGridArea) where
|
||||
toPairs x = ["grid_area" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LGridAutoColumns) where
|
||||
toPairs x = ["grid_auto_columns" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LGridAutoFlow) where
|
||||
toPairs x = ["grid_auto_flow" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LGridAutoRows) where
|
||||
toPairs x = ["grid_auto_rows" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LGridColumn) where
|
||||
toPairs x = ["grid_column" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LGridGap) where
|
||||
toPairs x = ["grid_gap" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LGridRow) where
|
||||
toPairs x = ["grid_row" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LGridTemplateAreas) where
|
||||
toPairs x = ["grid_template_areas" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LGridTemplateColumns) where
|
||||
toPairs x = ["grid_template_columns" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LGridTemplateRows) where
|
||||
toPairs x = ["grid_template_rows" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LHeight) where
|
||||
toPairs x = ["height" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LJustifyContent) where
|
||||
toPairs x = ["justify_content" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LJustifyItems) where
|
||||
toPairs x = ["justify_items" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LLeft) where
|
||||
toPairs x = ["left" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LMargin) where
|
||||
toPairs x = ["margin" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LMaxHeight) where
|
||||
toPairs x = ["max_height" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LMaxWidth) where
|
||||
toPairs x = ["max_width" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LMinHeight) where
|
||||
toPairs x = ["min_height" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LMinWidth) where
|
||||
toPairs x = ["min_width" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LOrder) where
|
||||
toPairs x = ["order" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LOverflow) where
|
||||
toPairs x = ["overflow" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LOverflowX) where
|
||||
toPairs x = ["overflow_x" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LOverflowY) where
|
||||
toPairs x = ["overflow_y" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LPadding) where
|
||||
toPairs x = ["padding" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LRight) where
|
||||
toPairs x = ["right" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LTop) where
|
||||
toPairs x = ["top" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LVisibility) where
|
||||
toPairs x = ["visibility" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LWidth) where
|
||||
toPairs x = ["width" .= toJSON x]
|
||||
|
||||
-- | A record representing a widget of the Layour class from IPython
|
||||
defaultLayoutWidget :: Rec Attr LayoutClass
|
||||
defaultLayoutWidget = (S.SModelModule =:! "@jupyter-widgets/base")
|
||||
|
||||
@ -0,0 +1,53 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module IHaskell.Display.Widgets.Link.DirectionalLink
|
||||
( -- * The DirectionalLink Widget
|
||||
DirectionalLink
|
||||
-- * Constructor
|
||||
, mkDirectionalLink
|
||||
) where
|
||||
|
||||
-- To keep `cabal repl` happy when running from the ihaskell repo
|
||||
import Prelude
|
||||
|
||||
import Data.Aeson
|
||||
import Data.IORef (newIORef)
|
||||
import Data.Monoid (mempty)
|
||||
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
|
||||
import IHaskell.Display.Widgets.Layout.LayoutWidget
|
||||
|
||||
-- | An 'DirectionalLink' represents a DirectionalLink widget from IPython.html.widgets.
|
||||
type DirectionalLink = IPythonWidget 'DirectionalLinkType
|
||||
|
||||
-- | Create a new DirectionalLink widget
|
||||
mkDirectionalLink :: IO DirectionalLink
|
||||
mkDirectionalLink = do
|
||||
-- Default properties, with a random uuid
|
||||
wid <- U.random
|
||||
|
||||
let widgetState = WidgetState $ defaultLinkWidget "DirectionalLinkModel"
|
||||
|
||||
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 DirectionalLink widget
|
||||
return widget
|
||||
|
||||
instance IHaskellWidget DirectionalLink where
|
||||
getCommUUID = uuid
|
||||
@ -0,0 +1,53 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module IHaskell.Display.Widgets.Link.Link
|
||||
( -- * The Link Widget
|
||||
Link
|
||||
-- * Constructor
|
||||
, mkLink
|
||||
) where
|
||||
|
||||
-- To keep `cabal repl` happy when running from the ihaskell repo
|
||||
import Prelude
|
||||
|
||||
import Data.Aeson
|
||||
import Data.IORef (newIORef)
|
||||
import Data.Monoid (mempty)
|
||||
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
|
||||
import IHaskell.Display.Widgets.Layout.LayoutWidget
|
||||
|
||||
-- | An 'Link' represents a Link widget from IPython.html.widgets.
|
||||
type Link = IPythonWidget 'LinkType
|
||||
|
||||
-- | Create a new link widget
|
||||
mkLink :: IO Link
|
||||
mkLink = do
|
||||
-- Default properties, with a random uuid
|
||||
wid <- U.random
|
||||
|
||||
let widgetState = WidgetState $ defaultLinkWidget "LinkModel"
|
||||
|
||||
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 link widget
|
||||
return widget
|
||||
|
||||
instance IHaskellWidget Link where
|
||||
getCommUUID = uuid
|
||||
@ -22,9 +22,12 @@ import Data.Kind
|
||||
|
||||
#if MIN_VERSION_singletons(3,0,0)
|
||||
import Data.Singletons.Base.TH
|
||||
import Data.Eq.Singletons
|
||||
#elif MIN_VERSION_singletons(2,4,0)
|
||||
import Data.Singletons.Prelude.Eq
|
||||
import Data.Singletons.TH
|
||||
#else
|
||||
import Data.Singletons.Prelude.Eq
|
||||
import Data.Singletons.Prelude.Ord
|
||||
import Data.Singletons.TH
|
||||
#endif
|
||||
@ -122,6 +125,8 @@ singletons
|
||||
| BarColor
|
||||
| HandleColor
|
||||
| ButtonWidth
|
||||
| Target
|
||||
| Source
|
||||
| Style
|
||||
-- Now the ones for layout
|
||||
-- Every layout property comes with an L before the name to avoid conflict
|
||||
@ -164,3 +169,140 @@ singletons
|
||||
| LWidth
|
||||
deriving (Eq, Ord, Show)
|
||||
|]
|
||||
|
||||
-- Attributes that aren't synced with the frontend give "" on toKey
|
||||
promote
|
||||
[d|
|
||||
-- toKey :: Field -> String
|
||||
toKey ViewModule = "_view_module"
|
||||
toKey ViewModuleVersion = "_view_module_version"
|
||||
toKey ViewName = "_view_name"
|
||||
toKey ModelModule = "_model_module"
|
||||
toKey ModelModuleVersion = "_model_module_version"
|
||||
toKey ModelName = "_model_name"
|
||||
toKey DisplayHandler = "" -- Not sent to the frontend
|
||||
toKey DOMClasses = "_dom_classes"
|
||||
toKey Width = "width"
|
||||
toKey Height = "height"
|
||||
toKey Description = "description"
|
||||
toKey ClickHandler = "" -- Not sent to the frontend
|
||||
toKey SubmitHandler = "" -- Not sent to the frontend
|
||||
toKey Disabled = "disabled"
|
||||
toKey StringValue = "value"
|
||||
toKey Placeholder = "placeholder"
|
||||
toKey Tooltip = "tooltip"
|
||||
toKey Icon = "icon"
|
||||
toKey ButtonStyle = "button_style"
|
||||
toKey BSValue = "value"
|
||||
toKey ImageFormat = "format"
|
||||
toKey AudioFormat = "format"
|
||||
toKey VideoFormat = "format"
|
||||
toKey BoolValue = "value"
|
||||
toKey Index = "index"
|
||||
toKey OptionalIndex = "index"
|
||||
toKey OptionsLabels = "_options_labels"
|
||||
toKey SelectionHandler = "" -- Not sent to the frontend
|
||||
toKey Tooltips = "tooltips"
|
||||
toKey Icons = "icons"
|
||||
toKey Indices = "index"
|
||||
toKey IntValue = "value"
|
||||
toKey StepInt = "step"
|
||||
toKey MinInt = "min"
|
||||
toKey MaxInt = "max"
|
||||
toKey IntPairValue = "value"
|
||||
toKey LowerInt = "min"
|
||||
toKey UpperInt = "max"
|
||||
toKey FloatValue = "value"
|
||||
toKey StepFloat = "step"
|
||||
toKey MinFloat = "min"
|
||||
toKey MaxFloat = "max"
|
||||
toKey FloatPairValue = "value"
|
||||
toKey LowerFloat = "min"
|
||||
toKey UpperFloat = "max"
|
||||
toKey Orientation = "orientation"
|
||||
toKey BaseFloat = "base"
|
||||
toKey ReadOut = "readout"
|
||||
toKey ReadOutFormat = "readout_format"
|
||||
toKey BarStyle = "bar_style"
|
||||
toKey ChangeHandler = "" -- Not sent to the frontend
|
||||
toKey Children = "children"
|
||||
toKey BoxStyle = "box_style"
|
||||
toKey Pack = "pack"
|
||||
toKey Align = "align"
|
||||
toKey Titles = "_titles"
|
||||
toKey SelectedIndex = "selected_index"
|
||||
toKey ReadOutMsg = "readout"
|
||||
toKey Indent = "indent"
|
||||
toKey Child = "child"
|
||||
toKey Selector = "selector"
|
||||
toKey ContinuousUpdate = "continuous_update"
|
||||
toKey Tabbable = "tabbable"
|
||||
toKey Rows = "rows"
|
||||
toKey AutoPlay = "autoplay"
|
||||
toKey Loop = "loop"
|
||||
toKey Controls = "controls"
|
||||
toKey Options = "options"
|
||||
toKey EnsureOption = "ensure_option"
|
||||
toKey Playing = "playing"
|
||||
toKey Repeat = "repeat"
|
||||
toKey Interval = "interval"
|
||||
toKey ShowRepeat = "show_repeat"
|
||||
toKey Concise = "concise"
|
||||
toKey DateValue = "value"
|
||||
toKey Pressed = "pressed"
|
||||
toKey Name = "name"
|
||||
toKey Mapping = "mapping"
|
||||
toKey Connected = "connected"
|
||||
toKey Timestamp = "timestamp"
|
||||
toKey Buttons = "buttons"
|
||||
toKey Axes = "axes"
|
||||
toKey Layout = "layout"
|
||||
toKey ButtonColor = "button_color"
|
||||
toKey FontWeight = "font_weight"
|
||||
toKey DescriptionWidth = "description_width"
|
||||
toKey BarColor = "bar_color"
|
||||
toKey HandleColor = "handle_color"
|
||||
toKey ButtonWidth = "button_width"
|
||||
toKey Target = "target"
|
||||
toKey Source = "source"
|
||||
toKey Style = "style"
|
||||
toKey LAlignContent = "align_content"
|
||||
toKey LAlignItems = "align_items"
|
||||
toKey LAlignSelf = "align_self"
|
||||
toKey LBorder = "border"
|
||||
toKey LBottom = "bottom"
|
||||
toKey LDisplay = "display"
|
||||
toKey LFlex = "flex"
|
||||
toKey LFlexFlow = "flex_flow"
|
||||
toKey LGridArea = "grid_area"
|
||||
toKey LGridAutoColumns = "grid_auto_columns"
|
||||
toKey LGridAutoFlow = "grid_auto_flow"
|
||||
toKey LGridAutoRows = "grid_auto_rows"
|
||||
toKey LGridColumn = "grid_column"
|
||||
toKey LGridGap = "grid_gap"
|
||||
toKey LGridRow = "grid_row"
|
||||
toKey LGridTemplateAreas = "grid_template_areas"
|
||||
toKey LGridTemplateColumns = "grid_template_columns"
|
||||
toKey LGridTemplateRows = "grid_template_rows"
|
||||
toKey LHeight = "height"
|
||||
toKey LJustifyContent = "justify_content"
|
||||
toKey LJustifyItems = "justify_items"
|
||||
toKey LLeft = "left"
|
||||
toKey LMargin = "margin"
|
||||
toKey LMaxHeight = "max_height"
|
||||
toKey LMaxWidth = "max_width"
|
||||
toKey LMinHeight = "min_height"
|
||||
toKey LMinWidth = "min_width"
|
||||
toKey LOrder = "order"
|
||||
toKey LOverflow = "overflow"
|
||||
toKey LOverflowX = "overflow_x"
|
||||
toKey LOverflowY = "overflow_y"
|
||||
toKey LPadding = "padding"
|
||||
toKey LRight = "right"
|
||||
toKey LTop = "top"
|
||||
toKey LVisibility = "visibility"
|
||||
toKey LWidth = "width"
|
||||
|
||||
-- hasKey :: Field -> Bool
|
||||
hasKey x = toKey x /= ""
|
||||
|]
|
||||
@ -16,6 +16,7 @@
|
||||
{-# LANGUAGE AutoDeriveTypeable #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
|
||||
-- | This module houses all the type-trickery needed to make widgets happen.
|
||||
--
|
||||
@ -110,7 +111,7 @@ import IHaskell.Eval.Widgets (widgetSendUpdate, widgetSendView)
|
||||
import IHaskell.Display (Base64, IHaskellWidget(..), IHaskellDisplay(..), Display(..), widgetdisplay, base64)
|
||||
import IHaskell.IPython.Message.UUID
|
||||
|
||||
import IHaskell.Display.Widgets.Singletons (Field, SField)
|
||||
import IHaskell.Display.Widgets.Singletons (Field, SField, toKey, HasKey)
|
||||
import qualified IHaskell.Display.Widgets.Singletons as S
|
||||
import IHaskell.Display.Widgets.Common
|
||||
|
||||
@ -171,6 +172,8 @@ type MediaClass = CoreWidgetClass :++ DOMWidgetClass :++ '[ 'S.BSValue ]
|
||||
|
||||
type DescriptionStyleClass = StyleWidgetClass :++ '[ 'S.DescriptionWidth ]
|
||||
|
||||
type LinkClass = CoreWidgetClass :++ ['S.ModelName, 'S.Target, 'S.Source]
|
||||
|
||||
-- Types associated with Fields.
|
||||
type family FieldType (f :: Field) :: *
|
||||
|
||||
@ -263,6 +266,8 @@ type instance FieldType 'S.DescriptionWidth = String
|
||||
type instance FieldType 'S.BarColor = Maybe String
|
||||
type instance FieldType 'S.HandleColor = Maybe String
|
||||
type instance FieldType 'S.ButtonWidth = String
|
||||
type instance FieldType 'S.Target = WidgetFieldPair
|
||||
type instance FieldType 'S.Source = WidgetFieldPair
|
||||
type instance FieldType 'S.Style = StyleWidget
|
||||
|
||||
-- | Can be used to put different widgets in a list. Useful for dealing with children widgets.
|
||||
@ -297,6 +302,13 @@ instance CustomBounded Double where
|
||||
lowerBound = - fromIntegral (maxBound :: Int16)
|
||||
upperBound = fromIntegral (maxBound :: Int16)
|
||||
|
||||
-- | This type only fits if the field is among the widget's fields, and it has a key
|
||||
data WidgetFieldPair = forall w f. (f ∈ WidgetFields w, HasKey f ~ 'True, RecAll Attr (WidgetFields w) ToPairs) => WidgetFieldPair (IPythonWidget w) (SField f) | EmptyWT
|
||||
|
||||
instance ToJSON WidgetFieldPair where
|
||||
toJSON EmptyWT = Null
|
||||
toJSON (WidgetFieldPair w f) = toJSON [toJSON w, toJSON $ pack $ toKey $ fromSing f]
|
||||
|
||||
-- Different types of widgets. Every widget in IPython has a corresponding WidgetType
|
||||
data WidgetType = ButtonType
|
||||
| ColorPickerType
|
||||
@ -344,6 +356,8 @@ data WidgetType = ButtonType
|
||||
| ControllerButtonType
|
||||
| ControllerAxisType
|
||||
| ControllerType
|
||||
| LinkType
|
||||
| DirectionalLinkType
|
||||
| LayoutType
|
||||
| ButtonStyleType
|
||||
| DescriptionStyleType
|
||||
@ -435,6 +449,8 @@ type instance WidgetFields 'ControllerType =
|
||||
['S.Index, 'S.Name, 'S.Mapping, 'S.Connected, 'S.Timestamp, 'S.Buttons, 'S.Axes, 'S.ChangeHandler ]
|
||||
type instance WidgetFields 'ControllerAxisType = CoreWidgetClass :++ DOMWidgetClass :++ '[ 'S.FloatValue, 'S.ChangeHandler ]
|
||||
type instance WidgetFields 'ControllerButtonType = CoreWidgetClass :++ DOMWidgetClass :++ [ 'S.FloatValue, 'S.Pressed, 'S.ChangeHandler ]
|
||||
type instance WidgetFields 'LinkType = LinkClass
|
||||
type instance WidgetFields 'DirectionalLinkType = LinkClass
|
||||
|
||||
type instance WidgetFields 'ButtonStyleType = StyleWidgetClass :++ ['S.ButtonColor, 'S.FontWeight]
|
||||
type instance WidgetFields 'DescriptionStyleType = DescriptionStyleClass
|
||||
@ -472,280 +488,24 @@ instance ToJSON (FieldType f) => ToJSON (Attr f) where
|
||||
class ToPairs a where
|
||||
toPairs :: a -> [Pair]
|
||||
|
||||
-- Attributes that aren't synced with the frontend give [] on toPairs
|
||||
instance ToPairs (Attr 'S.ViewModule) where
|
||||
toPairs x = ["_view_module" .= toJSON x]
|
||||
-- From https://stackoverflow.com/questions/68648670/duplicate-instance-declaration-using-haskell-singletons
|
||||
-- TODO: Check if it can be done with something from Singletons
|
||||
instance ToPairs' (HasKey f) f => ToPairs (Attr f) where
|
||||
toPairs = toPairs'
|
||||
|
||||
instance ToPairs (Attr 'S.ViewModuleVersion) where
|
||||
toPairs x = ["_view_module_version" .= toJSON x]
|
||||
class hk ~ HasKey a => ToPairs' hk a where
|
||||
toPairs' :: Attr a -> [Pair]
|
||||
|
||||
instance ToPairs (Attr 'S.ViewName) where
|
||||
toPairs x = ["_view_name" .= toJSON x]
|
||||
instance HasKey f ~ 'False => ToPairs' 'False f where
|
||||
toPairs' _ = []
|
||||
|
||||
instance ToPairs (Attr 'S.ModelModule) where
|
||||
toPairs x = ["_model_module" .= toJSON x]
|
||||
instance (ToJSON (FieldType f), HasKey f ~ 'True) => ToPairs' 'True f where
|
||||
toPairs' x = [ pack (toKey $ _field x) .= toJSON x ]
|
||||
|
||||
instance ToPairs (Attr 'S.ModelModuleVersion) where
|
||||
toPairs x = ["_model_module_version" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.ModelName) where
|
||||
toPairs x = ["_model_name" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.DisplayHandler) where
|
||||
toPairs _ = [] -- Not sent to the frontend
|
||||
|
||||
instance ToPairs (Attr 'S.DOMClasses) where
|
||||
toPairs x = ["_dom_classes" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Width) where
|
||||
toPairs x = ["width" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Height) where
|
||||
toPairs x = ["height" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Description) where
|
||||
toPairs x = ["description" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.ClickHandler) where
|
||||
toPairs _ = [] -- Not sent to the frontend
|
||||
|
||||
instance ToPairs (Attr 'S.SubmitHandler) where
|
||||
toPairs _ = [] -- Not sent to the frontend
|
||||
|
||||
instance ToPairs (Attr 'S.Disabled) where
|
||||
toPairs x = ["disabled" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.StringValue) where
|
||||
toPairs x = ["value" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Placeholder) where
|
||||
toPairs x = ["placeholder" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Tooltip) where
|
||||
toPairs x = ["tooltip" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Icon) where
|
||||
toPairs x = ["icon" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.ButtonStyle) where
|
||||
toPairs x = ["button_style" .= toJSON x]
|
||||
|
||||
instance ToJSON ByteString where
|
||||
toJSON = toJSON . base64
|
||||
|
||||
instance ToPairs (Attr 'S.BSValue) where
|
||||
toPairs x = ["value" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.ImageFormat) where
|
||||
toPairs x = ["format" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.AudioFormat) where
|
||||
toPairs x = ["format" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.VideoFormat) where
|
||||
toPairs x = ["format" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.BoolValue) where
|
||||
toPairs x = ["value" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Index) where
|
||||
toPairs x = ["index" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.OptionalIndex) where
|
||||
toPairs x = ["index" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.OptionsLabels) where
|
||||
toPairs x = ["_options_labels" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.SelectionHandler) where
|
||||
toPairs _ = [] -- Not sent to the frontend
|
||||
|
||||
instance ToPairs (Attr 'S.Tooltips) where
|
||||
toPairs x = ["tooltips" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Icons) where
|
||||
toPairs x = ["icons" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Indices) where
|
||||
toPairs x = ["index" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.IntValue) where
|
||||
toPairs x = ["value" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.StepInt) where
|
||||
toPairs x = ["step" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.MinInt) where
|
||||
toPairs x = ["min" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.MaxInt) where
|
||||
toPairs x = ["max" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.IntPairValue) where
|
||||
toPairs x = ["value" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LowerInt) where
|
||||
toPairs x = ["min" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.UpperInt) where
|
||||
toPairs x = ["max" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.FloatValue) where
|
||||
toPairs x = ["value" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.StepFloat) where
|
||||
toPairs x = ["step" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.MinFloat) where
|
||||
toPairs x = ["min" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.MaxFloat) where
|
||||
toPairs x = ["max" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.FloatPairValue) where
|
||||
toPairs x = ["value" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.LowerFloat) where
|
||||
toPairs x = ["min" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.UpperFloat) where
|
||||
toPairs x = ["max" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Orientation) where
|
||||
toPairs x = ["orientation" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.BaseFloat) where
|
||||
toPairs x = ["base" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.ReadOut) where
|
||||
toPairs x = ["readout" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.ReadOutFormat) where
|
||||
toPairs x = ["readout_format" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.BarStyle) where
|
||||
toPairs x = ["bar_style" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.ChangeHandler) where
|
||||
toPairs _ = [] -- Not sent to the frontend
|
||||
|
||||
instance ToPairs (Attr 'S.Children) where
|
||||
toPairs x = ["children" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.BoxStyle) where
|
||||
toPairs x = ["box_style" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Pack) where
|
||||
toPairs x = ["pack" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Align) where
|
||||
toPairs x = ["align" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Titles) where
|
||||
toPairs x = ["_titles" .= toJSON x]
|
||||
|
||||
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.Indent) where
|
||||
toPairs x = ["indent" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Child) where
|
||||
toPairs x = ["child" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Selector) where
|
||||
toPairs x = ["selector" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.ContinuousUpdate) where
|
||||
toPairs x = ["continuous_update" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Tabbable) where
|
||||
toPairs x = ["tabbable" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Rows) where
|
||||
toPairs x = ["rows" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.AutoPlay) where
|
||||
toPairs x = ["autoplay" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Loop) where
|
||||
toPairs x = ["loop" .= toJSON x]
|
||||
|
||||
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]
|
||||
|
||||
instance ToPairs (Attr 'S.Playing) where
|
||||
toPairs x = ["playing" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Repeat) where
|
||||
toPairs x = ["repeat" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Interval) where
|
||||
toPairs x = ["interval" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.ShowRepeat) where
|
||||
toPairs x = ["show_repeat" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Concise) where
|
||||
toPairs x = ["concise" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.DateValue) where
|
||||
toPairs x = ["value" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Pressed) where
|
||||
toPairs x = ["pressed" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Name) where
|
||||
toPairs x = ["name" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Mapping) where
|
||||
toPairs x = ["mapping" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Connected) where
|
||||
toPairs x = ["connected" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Timestamp) where
|
||||
toPairs x = ["timestamp" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Buttons) where
|
||||
toPairs x = ["buttons" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Axes) where
|
||||
toPairs x = ["axes" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Layout) where
|
||||
toPairs x = ["layout" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.ButtonColor) where
|
||||
toPairs x = ["button_color" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.FontWeight) where
|
||||
toPairs x = ["font_weight" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.DescriptionWidth) where
|
||||
toPairs x = ["description_width" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.BarColor) where
|
||||
toPairs x = ["bar_color" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.HandleColor) where
|
||||
toPairs x = ["handle_color" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.ButtonWidth) where
|
||||
toPairs x = ["button_width" .= toJSON x]
|
||||
|
||||
instance ToPairs (Attr 'S.Style) where
|
||||
toPairs x = ["style" .= 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
|
||||
@ -1043,6 +803,14 @@ defaultMediaWidget viewName modelName layout = defaultCoreWidget <+> defaultDOMW
|
||||
mediaAttrs = (BSValue =:: "")
|
||||
:& RNil
|
||||
|
||||
defaultLinkWidget :: FieldType 'S.ModelName -> Rec Attr LinkClass
|
||||
defaultLinkWidget modelName = defaultCoreWidget <+> linkAttrs
|
||||
where
|
||||
linkAttrs = (ModelName =:! modelName)
|
||||
:& (Target =:: EmptyWT)
|
||||
:& (Source =:: EmptyWT)
|
||||
:& RNil
|
||||
|
||||
-- | A record representing a widget of the Style class from IPython
|
||||
defaultStyleWidget :: FieldType 'S.ModelName -> Rec Attr StyleWidgetClass
|
||||
defaultStyleWidget modelName = (ModelName =:! modelName)
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user